diff --git a/README.md b/README.md
index 79f99b9262e4b390454dd09ebc9236dd5417a609..22f221f212cc78ba1962eb9f06718d5a5de1b635 100644
--- a/README.md
+++ b/README.md
@@ -1,23 +1,24 @@
#### DESCRIPTION
-Cute Little R Functions contains 16 functions for R/RStudio that facilitate basic procedures in 1) object analysis, 2) object modification, 3) graphic handling and 4) log file management.
+Cute Little R Functions contains 17 functions for R/RStudio that facilitate basic procedures in 1) object analysis, 2) object modification, 3) graphic handling and 4) log file management.
The function names are:
-fun_param_check()
-fun_object_info()
-fun_1D_comp()
-fun_2D_comp()
-fun_list_comp()
-fun_dataframe_flipping()
-fun_refactorization()
-fun_rounding()
-fun_90clock_matrix_rot()
-fun_hexa_hsv_color_matrix()
-fun_window_width_resizing()
-fun_open_window()
-fun_graph_param_prior_plot()
-fun_feature_post_plot()
-fun_close_specif_window()
-fun_export_data()
+fun_param_check() Check the class, type, mode and length, prop, neg values, na.contains, etc., of an object
+fun_object_info() provide a full description of the object
+fun_1D_comp() compare two 1D datasets (vector of factor or 1D table) of the same class or not
+fun_2D_comp() compare two 2D datasets of the same class or not
+fun_list_comp() compare two lists
+fun_dataframe_remodeling() remodel data frames
+fun_refactorization() refactorize a factor or the factor columns of a data frame, such as only the class present are in the levels (no empty levels). The class order in levels is kept
+fun_rounding() round a vector of values, if decimal, with the desired number of decimal digits after the decimal leading zeros
+fun_90clock_matrix_rot() 90° clockwise matrix rotation
+fun_hexa_hsv_color_matrix() convert a matrix made of numbers into a hexadecimal matrix for rgb colorization
+fun_window_width_resizing() rescale the width of a window to open depending on the number of classes to plot
+fun_open_window() open a pdf or screen (GUI) graphic window
+fun_graph_param_prior_plot() very convenient to erase the axes for post plot axis redrawing using fun_feature_post_plot()
+fun_feature_post_plot() redesign axis and provide convenients coordinates for adding elements on the drawn graph
+fun_close_specif_window() close only specific graphic windows (devices)
+fun_var_trim_display() trim and display values from a numeric vector or matrix
+fun_export_data() log file function: print a character string or a data object into a same output file
#### HOW TO USE IT
@@ -47,6 +48,17 @@ Check for updated versions (more recent release tags) at https://gitlab.pasteur.
#### WHAT'S NEW IN
+## v4.0.0
+
+1) fun_var_trim_display() function added
+
+2) fun_feature_post_plot() function now provides additional coordinates when there are margins between the figure region and the device region
+
+3) fun_2D_comp() function now provide the common row and column names, and a bug fixed in the detection of identical row or column content
+
+4) error messages now mention the function that generates this message
+
+
## v3.1.0
1) fun_export_data() function modified: argument data cannot be NULL
diff --git a/cute_little_R_functions.R b/cute_little_R_functions.R
index 46250a36b2b5608dcecdf2572878aa3f407abea9..3a3239d7db2dc13ed5c096b508e7895a977812f0 100644
--- a/cute_little_R_functions.R
+++ b/cute_little_R_functions.R
@@ -1,6 +1,6 @@
################################################################
## ##
-## CUTE LITTLE R FUNCTIONS v3.1.0 ##
+## CUTE LITTLE R FUNCTIONS v4.0.0 ##
## ##
## Gael A. Millot ##
## ##
@@ -15,29 +15,27 @@
################################ OUTLINE ################################
-################ Object analysis 1
-######## fun_param_check() #### Checking class, type, length, etc. of objects 1
-######## fun_object_info() #### Recovering object information 7
-######## fun_1D_comp() #### comparison of two 1D datasets (vectors, factors, 1D tables) 7
-######## fun_2D_comp() #### comparison of two 2D datasets (row & col names, dimensions, etc.) 11
-######## fun_list_comp() #### comparison of two lists 16
-
-################ Object modification 18
-######## fun_dataframe_remodeling() #### remodeling a data frame to have column name as a qualitative column and vice-versa 18
-######## fun_refactorization() #### remove classes that are not anymore present in factors or factor columns in data frames 20
-######## fun_rounding() #### Rounding number if decimal present 22
-######## fun_90clock_matrix_rot() #### 90° clockwise matrix rotation 23
-######## fun_hexa_hsv_color_matrix() #### Conversion of a numeric matrix into hexadecimal color matrix 23
-
-################ Graphics 26
-######## fun_window_width_resizing() #### window width depending on classes to plot 26
-######## fun_open_window() #### Open a GUI or pdf graphic window 27
-######## fun_graph_param_prior_plot() #### Graph param before plotting 30
-######## fun_feature_post_plot() #### Graph param after plotting 33
-######## fun_close_specif_window() #### Closing specific graphic windows 41
-
-################ Exporting results (text & tables) 42
-######## fun_export_data() #### Print string or data object into output file 42
+################ Object analysis 1
+######## fun_param_check() #### Checking class, type, length, etc. of objects 1
+######## fun_object_info() #### Recovering object information 7
+######## fun_1D_comp() #### comparison of two 1D datasets (vectors, factors, 1D tables) 8
+######## fun_2D_comp() #### comparison of two 2D datasets (row & col names, dimensions, etc.) 11
+######## fun_list_comp() #### comparison of two lists 16
+################ Object modification 18
+######## fun_dataframe_remodeling() #### remodeling a data frame to have column name as a qualitative column and vice-versa 18
+######## fun_refactorization() #### remove classes that are not anymore present in factors or factor columns in data frames 21
+######## fun_rounding() #### Rounding number if decimal present 23
+######## fun_90clock_matrix_rot() #### 90° clockwise matrix rotation 24
+######## fun_hexa_hsv_color_matrix() #### Conversion of a numeric matrix into hexadecimal color matrix 25
+################ Graphics 28
+######## fun_window_width_resizing() #### window width depending on classes to plot 28
+######## fun_open_window() #### Open a GUI or pdf graphic window 29
+######## fun_graph_param_prior_plot() #### Graph param before plotting 32
+######## fun_feature_post_plot() #### Graph param after plotting 35
+######## fun_close_specif_window() #### Closing specific graphic windows 43
+######## fun_quant_var_trim_display() #### Display values from a quantitative variable and trim according to defined cut-offs 45
+################ Exporting results (text & tables) 52
+######## fun_export_data() #### Print string or data object into output file 52
################################ FUNCTIONS ################################
@@ -52,11 +50,11 @@
# Check OK: clear to go Apollo
fun_param_check <- function(data, data.name = NULL, class = NULL, typeof = NULL, mode = NULL, length = NULL, prop = NULL, double.as.integer.allowed = FALSE, options = NULL, all.options.in.data = FALSE, na.contain = FALSE, neg.values = TRUE, print = TRUE){
# 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 even if it is an integer?
- # If options = NULL, then at least class, type, mode or length must be non null
- # If options is non null, then class, type and mode must be NULL, and length can be NULL or specified
+ # 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 even if it is an integer?
+ # if options = NULL, then at least class, type, mode or length must be non null
+ # if options is non null, then class, type and mode must be NULL, and length can be NULL or specified
# REQUIRED FUNCTIONS
# none
# ARGUMENTS
@@ -87,101 +85,101 @@ fun_param_check <- function(data, data.name = NULL, class = NULL, typeof = NULL,
# 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))
if( ! is.null(data.name)){
if( ! (length(data.name) == 1 & class(data.name) == "character")){
- tempo.cat <- paste0("\n\n================\n\nERROR: data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " "), "\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " "), "\n\n================\n\n")
stop(tempo.cat)
}
}
if(is.null(options) & is.null(class) & is.null(typeof) & is.null(mode) & is.null(prop) & is.null(length)){
- tempo.cat <- paste0("\n\n================\n\nERROR: AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED\n\n================\n\n")
stop(tempo.cat)
}
if( ! is.null(options) & ( ! is.null(class) | ! is.null(typeof) | ! is.null(mode) | ! is.null(prop))){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE class, typeof, mode AND prop ARGUMENTS MUST BE NULL IF THE option ARGUMENT IS SPECIFIED\nTHE option ARGUMENT MUST BE NULL IF THE class AND/OR typeof AND/OR mode AND/OR prop ARGUMENT IS SPECIFIED\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): THE class, typeof, mode AND prop ARGUMENTS MUST BE NULL IF THE option ARGUMENT IS SPECIFIED\nTHE option 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)
}
if( ! (all(class(neg.values) == "logical") & length(neg.values) == 1 & any(is.na(neg.values)) != TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
stop(tempo.cat)
}
if(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE NULL\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE NULL\n\n================\n\n")
stop(tempo.cat)
}
if( ! is.null(class)){
if( ! all(class %in% c("logical", "integer", "numeric", "complex", "character", "matrix", "array", "data.frame", "list", "factor", "table", "expression", "name", "symbol", "function") & any(is.na(class)) != TRUE)){ # not length == 1 here because ordered factors are class "factor" "ordered" (length == 2)
- tempo.cat <- paste0("\n\n================\n\nERROR: class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\" \n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\" \n\n================\n\n")
stop(tempo.cat)
}
- if(neg.values == FALSE & ! any(class %in% c("numeric", "matrix", "array", "data.frame", "table"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: class ARGUMENT CANNOT BE OTHER THAN \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
+ if(neg.values == FALSE & ! any(class %in% c("numeric", "integer", "table"))){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): class ARGUMENT CANNOT BE OTHER THAN \"numeric\", \"integer\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
stop(tempo.cat)
}
}
if( ! is.null(typeof)){
if( ! (all(typeof %in% c("logical", "integer", "double", "complex", "character", "list", "expression", "name", "symbol", "closure", "special", "builtin")) & length(typeof) == 1 & any(is.na(typeof)) != TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: typeof ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"double\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"closure\", \"special\", \"builtin\" \n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): typeof ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"double\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"closure\", \"special\", \"builtin\" \n\n================\n\n")
stop(tempo.cat)
}
if(neg.values == FALSE & ! typeof %in% c("double", "integer")){
- tempo.cat <- paste0("\n\n================\n\nERROR: typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
stop(tempo.cat)
}
}
if( ! is.null(mode)){
if( ! (all(mode %in% c("logical", "numeric", "complex", "character", "list", "expression", "name", "symbol", "function")) & length(mode) == 1 & any(is.na(mode)) != TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\"\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\"\n\n================\n\n")
stop(tempo.cat)
}
if(neg.values == FALSE & mode != "numeric"){
- tempo.cat <- paste0("\n\n================\n\nERROR: mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
stop(tempo.cat)
}
}
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: length ARGUMENT MUST BE A SINGLE INTEGER VALUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): length ARGUMENT MUST BE A SINGLE INTEGER VALUE\n\n================\n\n")
stop(tempo.cat)
}
}
if( ! is.null(prop)){
if( ! (is.logical(prop) | length(prop) == 1 & any(is.na(prop)) != TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: prop ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): prop ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
stop(tempo.cat)
}else if(prop == TRUE){
if( ! is.null(class)){
if( ! any(class %in% c("numeric", "matrix", "array", "data.frame", "table"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: class ARGUMENT CANNOT BE OTHER THAN \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): class ARGUMENT CANNOT BE OTHER THAN \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
stop(tempo.cat)
}
}
if( ! is.null(mode)){
if(mode != "numeric"){
- tempo.cat <- paste0("\n\n================\n\nERROR: mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
stop(tempo.cat)
}
}
if( ! is.null(typeof)){
if(typeof != "double"){
- tempo.cat <- paste0("\n\n================\n\nERROR: typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
stop(tempo.cat)
}
}
}
}
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: THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
stop(tempo.cat)
}
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: all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY)\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY)\n\n================\n\n")
stop(tempo.cat)
}
if( ! (all(class(na.contain) == "logical") & length(na.contain) == 1 & any(is.na(na.contain)) != TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
stop(tempo.cat)
}
if( ! (all(class(print) == "logical") & length(print) == 1 & any(is.na(print)) != TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE print ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking
@@ -399,20 +397,20 @@ fun_1D_comp <- function(data1, data2){
# 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 and if they have been checked using fun_param_check()
if( ! any(class(data1) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data1 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_1D_comp(): THE data1 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}else if(all(class(data1) %in% "table")){
if(length(dim(data1)) > 1){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data1 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_1D_comp(): THE data1 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}
}
if( ! any(class(data2) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data2 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_1D_comp(): THE data2 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}else if(all(class(data2) %in% "table")){
if(length(dim(data2)) > 1){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data2 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_1D_comp(): THE data2 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}
}
@@ -584,20 +582,30 @@ fun_2D_comp <- function(data1, data2){
# $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 ?
+ # $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)
- # $same.col.name: logical. Are column names identical ?
+ # $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.row: logical. is there identical rows ?
- # $same.row.pos1: position, in data1, of the rows identical in data2
- # $same.row.pos2: position, in data2, of the rows identical in data1
- # $any.id.col: logical. is there identical columns ?
- # $same.col.pos1: position in data1 of the cols identical in data2
- # $same.col.pos2: position in data2 of the cols identical in data1
+ # $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) ?
+ # $same.row.pos1: position, in data1, of the rows identical in data2 (not considering row names)
+ # $same.row.pos2: position, in data2, of the rows identical in data1 (not considering row names)
+ # $any.id.col: logical. is there identical columns (not considering column names)?
+ # $same.col.pos1: position in data1 of the cols identical in data2 (not considering column names)
+ # $same.col.pos2: position in data2 of the cols identical in data1 (not considering column names)
# $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]))) ; fun_2D_comp(obs1, obs2)
+ # 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_2D_comp(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_2D_comp(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_2D_comp(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
@@ -608,15 +616,16 @@ fun_2D_comp <- function(data1, data2){
# 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
# 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 and if they have been checked using fun_param_check()
if( ! any(class(data1) %in% c("matrix", "data.frame", "table"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data1 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_2D_comp(): THE data1 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat)
}
if( ! any(class(data2) %in% c("matrix", "data.frame", "table"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data2 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_2D_comp(): THE data2 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking
@@ -630,7 +639,15 @@ fun_2D_comp <- function(data1, data2){
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
@@ -651,8 +668,16 @@ fun_2D_comp <- function(data1, data2){
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(mat1)[[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(mat1)[[2]]
any.id.row <- TRUE
same.row.pos1 <- 1:row.nb
same.row.pos2 <- 1:row.nb
@@ -664,17 +689,17 @@ fun_2D_comp <- function(data1, data2){
}else{
identical.object <- FALSE
if(all(class(data1) == "table") & length(dim(data1)) == 1){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data1 ARGUMENT IS A 1D TABLE. USE THE info_1D_dataset_fun FUNCTION\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_2D_comp(): THE data1 ARGUMENT IS A 1D TABLE. USE THE info_1D_dataset_fun FUNCTION\n\n================\n\n")
stop(tempo.cat)
}
if(all(class(data2) == "table") & length(dim(data2)) == 1){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data2 ARGUMENT IS A 1D TABLE. USE THE info_1D_dataset_fun FUNCTION\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_2D_comp(): THE data2 ARGUMENT IS A 1D TABLE. USE THE info_1D_dataset_fun FUNCTION\n\n================\n\n")
stop(tempo.cat)
}
if( ! identical(class(data1), class(data2))){
same.class <- FALSE
}else if( ! any(class(data1) %in% c("matrix", "data.frame", "table"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data1 AND data2 ARGUMENTS MUST BE EITHER MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_2D_comp(): THE data1 AND data2 ARGUMENTS MUST BE EITHER MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat)
}else{
same.class <- TRUE
@@ -700,8 +725,8 @@ fun_2D_comp <- function(data1, data2){
}
# row and col names
if(is.null(dimnames(data1)) & is.null(dimnames(data2))){
- same.row.name <- TRUE
- same.col.name <- TRUE
+ 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
@@ -715,6 +740,32 @@ fun_2D_comp <- function(data1, data2){
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
@@ -741,8 +792,8 @@ fun_2D_comp <- function(data1, data2){
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
- same.row.pos1 <- suppressWarnings(which(mapply(FUN = identical, c(as.data.frame(t(data1), stringsAsFactors = FALSE)), c(as.data.frame(t(data2), stringsAsFactors = FALSE)))))
- same.row.pos2 <- suppressWarnings(which(mapply(FUN = identical, c(as.data.frame(t(data2), stringsAsFactors = FALSE)), c(as.data.frame(t(data1), stringsAsFactors = FALSE)))))
+ same.row.pos1 <- which(c(as.data.frame(t(data1), stringsAsFactors = FALSE)) %in% c(as.data.frame(t(data2), stringsAsFactors = FALSE)))
+ same.row.pos2 <- which(c(as.data.frame(t(data2), stringsAsFactors = FALSE)) %in% c(as.data.frame(t(data1), stringsAsFactors = FALSE)))
names(same.row.pos1) <- NULL
names(same.row.pos2) <- NULL
if(all(is.na(same.row.pos1))){
@@ -765,8 +816,8 @@ fun_2D_comp <- function(data1, data2){
# same.row.pos1 and 2 remain NULL
}
if(same.row.nb == TRUE){ # because if not the same row nb, the col cannot be identical
- same.col.pos1 <- suppressWarnings(which(mapply(FUN = identical, c(data1), c(data2))))
- same.col.pos2 <- suppressWarnings(which(mapply(FUN = identical, c(data2), c(data1))))
+ same.col.pos1 <- which(c(data1) %in% c(data2))
+ same.col.pos2 <- which(c(data2) %in% c(data1))
names(same.col.pos1) <- NULL
names(same.col.pos2) <- NULL
if(all(is.na(same.col.pos1))){
@@ -796,7 +847,7 @@ fun_2D_comp <- function(data1, data2){
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, same.col.name = same.col.name, col.name = col.name, 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)
+ 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)
}
@@ -841,11 +892,11 @@ fun_list_comp <- function(data1, data2){
# 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 and if they have been checked using fun_param_check()
if( ! any(class(data1) %in% "list")){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data1 ARGUMENT MUST BE A LIST\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_list_comp(): THE data1 ARGUMENT MUST BE A LIST\n\n================\n\n")
stop(tempo.cat)
}
if( ! any(class(data2) %in% "list")){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data2 ARGUMENT MUST BE A LIST\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_list_comp(): THE data2 ARGUMENT MUST BE A LIST\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking
@@ -964,7 +1015,7 @@ fun_dataframe_remodeling <- function(data, quanti.col.name = "quanti", quali.col
# data = data.frame(b = c("e", "e", "h"), a = 1:3) ; quanti.col.name = "quanti" ; quali.col.name = "quali" # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_dataframe_remodeling(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -978,7 +1029,7 @@ fun_dataframe_remodeling <- function(data, quanti.col.name = "quanti", quali.col
}
# 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_param_check_dev)) # activate this line and use the function to check arguments status and if they have been checked using fun_param_check()
if( ! any(class(data) %in% "data.frame")){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data ARGUMENT MUST BE A DATA FRAME\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_dataframe_remodeling(): THE data ARGUMENT MUST BE A DATA FRAME\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking
@@ -991,21 +1042,21 @@ fun_dataframe_remodeling <- function(data, quanti.col.name = "quanti", quali.col
tempo.factor <- unlist(lapply(data, mode))
if(length(data) == 2){
if( ! ((mode(data[, 1]) == "character" & mode(data[, 2]) == "numeric") | mode(data[, 2]) == "character" & mode(data[, 1]) == "numeric" | mode(data[, 2]) == "numeric" & mode(data[, 1]) == "numeric") ){
- tempo.cat <- paste0("\n\n================\n\nERROR: IF data ARGUMENT IS A DATA FRAME MADE OF 2 COLUMNS, EITHER A COLUMN MUST BE NUMERIC AND THE OTHER CHARACTER, OR THE TWO COLUMNS MUST BE NUMERIC\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_dataframe_remodeling(): IF data ARGUMENT IS A DATA FRAME MADE OF 2 COLUMNS, EITHER A COLUMN MUST BE NUMERIC AND THE OTHER CHARACTER, OR THE TWO COLUMNS MUST BE NUMERIC\n\n================\n\n")
stop(tempo.cat)
}
if((mode(data[, 1]) == "character" | mode(data[, 2]) == "character") & (quanti.col.name != "quanti" | quali.col.name != "quali")){
- tempo.cat <- paste0("\n\n================\n\nERROR: IMPROPER quanti.col.name OR quali.col.name RESETTINGS. THESE ARGUMENTS ARE RESERVED FOR DATA FRAMES MADE OF n NUMERIC COLUMNS ONLY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_dataframe_remodeling(): IMPROPER quanti.col.name OR quali.col.name RESETTINGS. THESE ARGUMENTS ARE RESERVED FOR DATA FRAMES MADE OF n NUMERIC COLUMNS ONLY\n\n================\n\n")
stop(tempo.cat)
}
}else{
if( ! all(tempo.factor %in% "numeric")){
- tempo.cat <- paste0("\n\n================\n\nERROR: IF data ARGUMENT IS A DATA FRAME MADE OF ONE COLUMN, OR MORE THAN 2 COLUMNS, THESE COLUMNS MUST BE NUMERIC\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_dataframe_remodeling(): IF data ARGUMENT IS A DATA FRAME MADE OF ONE COLUMN, OR MORE THAN 2 COLUMNS, THESE COLUMNS MUST BE NUMERIC\n\n================\n\n")
stop(tempo.cat)
}
}
if(( ! any(tempo.factor %in% "character")) & is.null(names(data))){
- tempo.cat <- paste0("\n\n================\n\nERROR: NUMERIC DATA FRAME in the data ARGUMENT MUST HAVE COLUMN NAMES\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_dataframe_remodeling(): NUMERIC DATA FRAME in the data ARGUMENT MUST HAVE COLUMN NAMES\n\n================\n\n")
stop()
}
if(all(tempo.factor %in% "numeric")){
@@ -1059,7 +1110,7 @@ fun_refactorization <- function(data, also.ordered = TRUE){
# data <- ordered(LETTERS[1:6])[-c(1:2)] ; also.ordered <- TRUE # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_refactorization(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -1074,13 +1125,13 @@ fun_refactorization <- function(data, also.ordered = TRUE){
# 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_param_check_dev)) # activate this line and use the function to check arguments status and if they have been checked using fun_param_check()
if(also.ordered == FALSE){
if( ! (all(class(data) == "data.frame") | all(class(data) == "factor"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: data ARGUMENT MUST BE A FACTOR (NON ORDERED BECAUSE THE also.ordered ARGUMENT IS SET TO FALSE) OR A DATA FRAME\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_refactorization(): data ARGUMENT MUST BE A FACTOR (NON ORDERED BECAUSE THE also.ordered ARGUMENT IS SET TO FALSE) OR A DATA FRAME\n\n================\n\n")
stop(tempo.cat)
}
}
if(also.ordered == TRUE){
if( ! (all(class(data) == "data.frame") | all(class(data) == "factor") | all(class(data) %in% c("ordered", "factor")))){
- tempo.cat <- paste0("\n\n================\n\nERROR: data ARGUMENT MUST BE A FACTOR OR A DATA FRAME\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_refactorization(): data ARGUMENT MUST BE A FACTOR OR A DATA FRAME\n\n================\n\n")
stop(tempo.cat)
}
}
@@ -1148,7 +1199,7 @@ fun_rounding <- function(data, dec.nb = 2, after.lead.zero = TRUE){
# data = data = c("10", "100.001", "333.0001254", "12312.1235") ; dec.nb = 2 ; after.lead.zero = TRUE # # for function debugging
# argument checking
if( ! (all(typeof(data) == "character") | all(typeof(data) == "double") | all(typeof(data) == "integer"))){
- tempo.cat <- paste0("\n\n================\n\nERROR: data ARGUMENT MUST BE A VECTOR OF NUMBERS (IN NUMERIC OR CHARACTER MODE)\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_rounding(): data ARGUMENT MUST BE A VECTOR OF NUMBERS (IN NUMERIC OR CHARACTER MODE)\n\n================\n\n")
stop(tempo.cat)
}
arg.check <- NULL # for function debbuging
@@ -1209,14 +1260,14 @@ fun_90clock_matrix_rot <- function(data){
# data = matrix(1:10, ncol = 1)
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_90clock_matrix_rot(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# 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 and if they have been checked using fun_param_check()
if( ! any(class(data) %in% "matrix")){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE data ARGUMENT MUST BE A MATRIX\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_90clock_matrix_rot(): THE data ARGUMENT MUST BE A MATRIX\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking
@@ -1254,7 +1305,7 @@ fun_hexa_hsv_color_matrix <- function(mat1, mat.hsv.h = TRUE, notch = 1, s = 1,
# mat1 = matrix(c(1,1,1,2,1,5,9,NA), ncol = 2) ; dimnames(mat1) <- list(LETTERS[1:4], letters[1:2]); mat.hsv.h = FALSE ; notch = 1 ; s = 1 ; v = 1 ; forced.color = c(hsv(1,1,1), hsv(0,0,0)) # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -1272,7 +1323,7 @@ fun_hexa_hsv_color_matrix <- function(mat1, mat.hsv.h = TRUE, notch = 1, s = 1,
}
# 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_param_check_dev)) # activate this line and use the function to check arguments status and if they have been checked using fun_param_check()
if(mat.hsv.h == TRUE & fun_param_check(data = mat1, mode = "numeric", prop = TRUE, print = FALSE)$problem == TRUE){
- tempo.cat <- paste0("\n\n================\n\nERROR: mat1 ARGUMENT MUST BE A MATRIX OF PROPORTIONS SINCE THE mat.hsv.h ARGUMENT IS SET TO TRUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): mat1 ARGUMENT MUST BE A MATRIX OF PROPORTIONS SINCE THE mat.hsv.h ARGUMENT IS SET TO TRUE\n\n================\n\n")
stop(tempo.cat)
}
if( ! is.null(forced.color)){
@@ -1281,7 +1332,7 @@ fun_hexa_hsv_color_matrix <- function(mat1, mat.hsv.h = TRUE, notch = 1, s = 1,
stop()
}
if( ! all(forced.color %in% colors() | grepl(pattern = "^#", forced.color))){ # check that all strings of forced.color start by #
- tempo.cat <- paste0("\n\n================\n\nERROR: forced.color ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): forced.color ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n")
stop(tempo.cat)
}
}
@@ -1292,12 +1343,12 @@ fun_hexa_hsv_color_matrix <- function(mat1, mat.hsv.h = TRUE, notch = 1, s = 1,
# change the scale of the plotted matrix
if(mat.hsv.h == TRUE){
if(any(min(mat1, na.rm = TRUE) < 0 | max(mat1, na.rm = TRUE) > 1, na.rm = TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: mat1 MUST BE MADE OF VALUES BETWEEN 0 AND 1 BECAUSE mat.hsv.h ARGUMENT SET TO TRUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): mat1 MUST BE MADE OF VALUES BETWEEN 0 AND 1 BECAUSE mat.hsv.h ARGUMENT SET TO TRUE\n\n================\n\n")
stop(tempo.cat)
}
}else{
if(any(mat1 - floor(mat1) > 0, na.rm = TRUE) | any(mat1 == 0, na.rm = TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: mat1 MUST BE MADE OF INTEGER VALUES WITHOUT 0 BECAUSE mat.hsv.h ARGUMENT SET TO FALSE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): mat1 MUST BE MADE OF INTEGER VALUES WITHOUT 0 BECAUSE mat.hsv.h ARGUMENT SET TO FALSE\n\n================\n\n")
stop(tempo.cat)
}else{
mat1 <- mat1 / max(mat1, na.rm = TRUE)
@@ -1309,10 +1360,10 @@ fun_hexa_hsv_color_matrix <- function(mat1, mat.hsv.h = TRUE, notch = 1, s = 1,
tempo.different.color <- different.color + c(0, cumsum(rep(notch, length(different.color) - 1)))
tempo.different.color <- tempo.different.color - floor(tempo.different.color)
if(any(duplicated(tempo.different.color) == TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: DUPLICATED VALUES AFTER USING notch (", paste(tempo.different.color[duplicated(tempo.different.color)], collapse = " "), "). TRY ANOTHER notch VALUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): DUPLICATED VALUES AFTER USING notch (", paste(tempo.different.color[duplicated(tempo.different.color)], collapse = " "), "). TRY ANOTHER notch VALUE\n\n================\n\n")
stop(tempo.cat)
}else if(length(different.color) != length(tempo.different.color)){
- tempo.cat <- paste0("\n\n================\n\nERROR: LENGTH OF different.color (", paste(different.color, collapse = " "), ") DIFFERENT FROM LENGTH OF tempo.different.color (", paste(tempo.different.color, collapse = " "), ")\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): LENGTH OF different.color (", paste(different.color, collapse = " "), ") DIFFERENT FROM LENGTH OF tempo.different.color (", paste(tempo.different.color, collapse = " "), ")\n\n================\n\n")
stop(tempo.cat)
}else{
for(i in 1:length(different.color)){
@@ -1333,7 +1384,7 @@ fun_hexa_hsv_color_matrix <- function(mat1, mat.hsv.h = TRUE, notch = 1, s = 1,
}
for(i in 1:length(hexa.values.to.change)){
if( ! any(mat1 == hexa.values.to.change[i], na.rm = TRUE)){
- tempo.cat <- paste0("\n\n================\n\nERROR: THE ", hexa.values.to.change[i], " VALUE FROM hexa.values.to.change IS NOT REPRESENTED IN mat1 : ", paste(unique(as.vector(mat1)), collapse = " "), "\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_hexa_hsv_color_matrix(): THE ", hexa.values.to.change[i], " VALUE FROM hexa.values.to.change IS NOT REPRESENTED IN mat1 : ", paste(unique(as.vector(mat1)), collapse = " "), "\n\n================\n\n")
stop(tempo.cat)
}else{
mat1[which(mat1 == hexa.values.to.change[i])] <- forced.color[i]
@@ -1389,7 +1440,7 @@ fun_window_width_resizing <- function(class.nb, inches.per.class.nb = 1, ini.win
# class.nb = 10 ; inches.per.class.nb = 0.2 ; ini.window.width = 7 ; inch.left.space = 1 ; inch.right.space = 1 ; boundarie.space = 0.5 # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_window_width_resizing(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -1452,7 +1503,7 @@ fun_open_window <- function(pdf.disp = TRUE, path.fun = "working.dir", pdf.name.
# pdf.disp = TRUE ; path.fun = "C:/Users/Gael/Desktop" ; pdf.name.file = "graphs" ; width.fun = 7 ; height.fun = 7 ; paper = "special" ; no.pdf.overwrite = TRUE ; return.output = TRUE # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_open_window(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -1478,7 +1529,7 @@ fun_open_window <- function(pdf.disp = TRUE, path.fun = "working.dir", pdf.name.
path.fun <- getwd()
}else{
if(dir.exists(path.fun) == FALSE){
- tempo.cat <- paste0("\n\n================\n\nERROR: path.fun ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_open_window(): path.fun ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n\n================\n\n")
stop(tempo.cat)
}
}
@@ -1493,7 +1544,7 @@ fun_open_window <- function(pdf.disp = TRUE, path.fun = "working.dir", pdf.name.
ini.par <- par(no.readonly = TRUE) # recover the initial graphical parameters. Works even if X11 is not working as R opens a pdf
invisible(dev.off()) # can be used here to close the pdf windows if tempo != NULL and to close the X11 window if tempo == NULL
}else{
- tempo.cat <- paste0("\n\n================\n\nPROBLEM: THIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET.\nTO OVERCOME THIS, PLEASE SET pdf.disp ARGUMENT TO TRUE AND RERUN\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nPROBLEM IN fun_open_window(): THIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET.\nTO OVERCOME THIS, PLEASE SET pdf.disp ARGUMENT TO TRUE AND RERUN\n\n================\n\n")
stop(tempo.cat)
}
}else{
@@ -1506,7 +1557,7 @@ fun_open_window <- function(pdf.disp = TRUE, path.fun = "working.dir", pdf.name.
if(pdf.disp == TRUE){
pdf.loc <- paste0(path.fun, "/", pdf.name.file, ".pdf")
if(file.exists(pdf.loc) == TRUE & no.pdf.overwrite == TRUE){
- tempo.cat <- paste0("\n\n================\n\nERROR: pdf.loc FILE ALREADY EXISTS AND CANNOT BE OVERWRITTEN DUE TO no.pdf.overwrite ARGUMENT SET TO TRUE\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_open_window(): pdf.loc FILE ALREADY EXISTS AND CANNOT BE OVERWRITTEN DUE TO no.pdf.overwrite ARGUMENT SET TO TRUE\n\n================\n\n")
stop(tempo.cat)
}else{
pdf(width = width.fun, height = height.fun, file=pdf.loc, paper = paper)
@@ -1517,7 +1568,7 @@ fun_open_window <- function(pdf.disp = TRUE, path.fun = "working.dir", pdf.name.
windows(width = width.fun, height = height.fun, rescale="fixed")
}else if(Sys.info()["sysname"] == "Linux"){
if( ! is.null(tempo)){
- stop("PROBLEM: THIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET.\nTO OVERCOME THIS, PLEASE SET pdf.disp ARGUMENT TO TRUE AND RERUN")
+ stop("PROBLEM IN fun_open_window(): THIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET.\nTO OVERCOME THIS, PLEASE SET pdf.disp ARGUMENT TO TRUE AND RERUN")
}else{
X11(width = width.fun, height = height.fun)
}
@@ -1571,7 +1622,7 @@ fun_graph_param_prior_plot <- function(param.reinitial = FALSE, xlog.scale = FAL
# param.reinitial = FALSE ; xlog.scale = FALSE ; ylog.scale = FALSE ; remove.label = TRUE ; remove.x.axis = TRUE ; remove.y.axis = TRUE ; down.space = 1 ; left.space = 1 ; up.space = 1 ; right.space = 1 ; orient = 1 ; dist.legend = 4.5 ; tick.length = 0.5 ; box.type = "n" ; amplif.label = 1 ; amplif.axis = 1 ; display.extend = FALSE ; return.par = FALSE # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_graph_param_prior_plot(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -1616,7 +1667,7 @@ fun_graph_param_prior_plot <- function(param.reinitial = FALSE, xlog.scale = FAL
if( ! file.exists(paste0(getwd(), "/Rplots.pdf"))){
tempo <- suppressWarnings(try(X11(), silent = TRUE))[] # open a X11 window or a pdf. So no need to use again X11(). tempo == NULL if no problem, meaning that the X11 window is opened. If tempo != NULL, a pdf is open here paste0(getwd(), "/Rplots.pdf")
}else{
- tempo.cat <- paste0("\n\n================\n\nPROBLEM: THIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET.\nTO OVERCOME THIS, PLEASE SET pdf.disp ARGUMENT TO TRUE AND RERUN\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nPROBLEM IN fun_graph_param_prior_plot(): THIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET.\nTO OVERCOME THIS, PLEASE SET pdf.disp ARGUMENT TO TRUE AND RERUN\n\n================\n\n")
stop(tempo.cat)
}
}else{ # macOS
@@ -1712,6 +1763,10 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
# custom.par: list that provides the parameters that reset all the graphics parameters. BEWARE: if NULL and par.reset == TRUE, the default par() parameters are used
# RETURN
# a list containing:
+ # $x.mid.left.dev.region: middle of the left margin of the device region, in coordinates of the x-axis
+ # $x.left.dev.region: left side of the left margin (including the potential margin of the device region), in coordinates of the x-axis
+ # $x.mid.right.dev.region: middle of the right margin of the device region, in coordinates of the x-axis
+ # $x.right.dev.region: right side of the right margin (including the potential margin of the device region), in coordinates of the x-axis
# $x.mid.left.fig.region: middle of the left margin of the figure region, in coordinates of the x-axis
# $x.left.fig.region: left side of the left margin, in coordinates of the x-axis
# $x.mid.right.fig.region: middle of the right margin of the figure region, in coordinates of the x-axis
@@ -1719,6 +1774,10 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
# $x.left.plot.region: left side of the plot region, in coordinates of the x-axis
# $x.right.plot.region: right side of the plot region, in coordinates of the x-axis
# $x.mid.plot.region: middle of the plot region, in coordinates of the x-axis
+ # $y.mid.bottom.dev.region: middle of the bottom margin of the device region, in coordinates of the y-axis
+ # $y.bottom.dev.region: bottom side of the bottom margin (including the potential margin of the device region), in coordinates of the y-axis
+ # $y.mid.top.dev.region: middle of the top margin of the device region, in coordinates of the y-axis
+ # $y.top.dev.region: top side of the top margin (including the potential margin of the device region), in coordinates of the y-axis
# $y.mid.bottom.fig.region: middle of the bottom margin of the figure region, in coordinates of the y-axis
# $y.bottom.fig.region: bottom of the bottom margin of the figure region, in coordinates of the y-axis
# $y.mid.top.fig.region: middle of the top margin of the figure region, in coordinates of the y-axis
@@ -1732,15 +1791,17 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
# prior.par <- fun_graph_param_prior_plot(param.reinitial = TRUE, xlog.scale = FALSE, ylog.scale = TRUE, remove.label = TRUE, remove.x.axis = FALSE, remove.y.axis = TRUE, down.space = 1, left.space = 1, up.space = 1, right.space = 1, orient = 1, dist.legend = 0.5, tick.length = 0.5, box.type = "n", amplif.label = 1, amplif.axis = 1, display.extend = FALSE, return.par = TRUE) ; plot(1:100, log = "y") ; fun_feature_post_plot(y.side = 2, y.log.scale = prior.par$ylog, x.lab = "Values", y.lab = "TEST", y.axis.magnific = 1.25, y.label.magnific = 1.5, y.dist.legend = 0.7, just.label.add = ! prior.par$ann)
# Example of log axis with redrawn x-axis and y-axis:
# prior.par <- fun_graph_param_prior_plot(param.reinitial = TRUE) ; plot(1:100) ; fun_feature_post_plot(x.side = 1, x.lab = "Values", y.side = 2, y.lab = "TEST", y.axis.magnific = 1, y.label.magnific = 2, y.dist.legend = 0.6)
+ # example with margins in the device region:
+ # windows(5,5) ; par(mai=c(0.5,0.5,0.5,0.5), omi = c(0.25,0.25,1,0.25), xaxs = "i", yaxs = "i") ; plot(0:10) ; a <- fun_feature_post_plot(x.side = 0, y.side = 0) ; x <- c(a$x.mid.left.dev.region, a$x.left.dev.region, a$x.mid.right.dev.region, a$x.right.dev.region, a$x.mid.left.fig.region, a$x.left.fig.region, a$x.mid.right.fig.region, a$x.right.fig.region, a$x.right.plot.region, a$x.left.plot.region, a$x.mid.plot.region) ; y <- c(a$y.mid.bottom.dev.region, a$y.bottom.dev.region, a$y.mid.top.dev.region, a$y.top.dev.region, a$y.mid.bottom.fig.region, a$y.bottom.fig.region, a$y.mid.top.fig.region, a$y.top.fig.region, a$y.top.plot.region, a$y.bottom.plot.region, a$y.mid.plot.region) ; par(xpd = NA) ; points(x = rep(5, length(y)), y = y, pch = 16, col = "red") ; text(x = rep(5, length(y)), y = y, c("y.mid.bottom.dev.region", "y.bottom.dev.region", "y.mid.top.dev.region", "y.top.dev.region", "y.mid.bottom.fig.region", "y.bottom.fig.region", "y.mid.top.fig.region", "y.top.fig.region", "y.top.plot.region", "y.bottom.plot.region", "y.mid.plot.region"), cex = 0.65, col = grey(0.25)) ; points(y = rep(5, length(x)), x = x, pch = 16, col = "blue") ; text(y = rep(5, length(x)), x = x, c("x.mid.left.dev.region", "x.left.dev.region", "x.mid.right.dev.region", "x.right.dev.region", "x.mid.left.fig.region", "x.left.fig.region", "x.mid.right.fig.region", "x.right.fig.region", "x.right.plot.region", "x.left.plot.region", "x.mid.plot.region"), cex = 0.65, srt = 90, col = grey(0.25))
# DEBUGGING
# x.side = 0 ; x.log.scale = FALSE ; x.categ = NULL ; x.categ.pos = NULL ; x.lab = "" ; x.axis.magnific = 1.5 ; x.label.magnific = 1.5 ; x.dist.legend = 1 ; x.nb.inter.tick = 1 ; y.side = 0 ; y.log.scale = FALSE ; y.categ = NULL ; y.categ.pos = NULL ; y.lab = "" ; y.axis.magnific = 1.5 ; y.label.magnific = 1.5 ; y.dist.legend = 0.7 ; y.nb.inter.tick = 1 ; text.angle = 90 ; tick.length = 0.5 ; sec.tick.length = 0.3 ; bg.color = NULL ; grid.lwd = NULL ; grid.col = "white" ; corner.text = "" ; magnific.corner.text = 1 ; just.label.add = FALSE ; par.reset = FALSE ; custom.par = NULL # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_feature_post_plot(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
if(length(find("fun_open_window", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_open_window() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_feature_post_plot(): REQUIRED fun_open_window() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -1780,7 +1841,7 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
if( ! is.null(bg.color)){
tempo <- fun_param_check(data = bg.color, class = "character", length = 1) ; eval(ee)
if( ! (bg.color %in% colors() | grepl(pattern = "^#", bg.color))){ # check color
- tempo.cat <- paste0("\n\n================\n\nERROR: bg.color ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # OR A COLOR NAME GIVEN BY colors()\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_feature_post_plot(): bg.color ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # OR A COLOR NAME GIVEN BY colors()\n\n================\n\n")
stop(tempo.cat)
}
}
@@ -1790,7 +1851,7 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
if( ! is.null(grid.col)){
tempo <- fun_param_check(data = grid.col, class = "character", length = 1) ; eval(ee)
if( ! (grid.col %in% colors() | grepl(pattern = "^#", grid.col))){ # check color
- tempo.cat <- paste0("\n\n================\n\nERROR: grid.col ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # OR A COLOR NAME GIVEN BY colors()\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_feature_post_plot(): grid.col ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # OR A COLOR NAME GIVEN BY colors()\n\n================\n\n")
stop(tempo.cat)
}
}
@@ -1825,6 +1886,10 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
grid(nx = NA, ny = NULL, col = grid.col, lty = 1, lwd = grid.lwd)
}
if(x.log.scale == TRUE){
+ x.mid.left.dev.region <- 10^(par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * par("omd")[1] / 2) # in x coordinates, to position axis labeling at the bottom of the graph (according to x scale)
+ x.left.dev.region <- 10^(par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * par("omd")[1]) # in x coordinates
+ x.mid.right.dev.region <- 10^(par("usr")[2] + ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * (1 - par("plt")[2]) + ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * (1 - par("omd")[2]) / 2) # in x coordinates, to position axis labeling at the top of the graph (according to x scale)
+ x.right.dev.region <- 10^(par("usr")[2] + ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * (1 - par("plt")[2]) + ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * (1 - par("omd")[2])) # in x coordinates
x.mid.left.fig.region <- 10^(par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] / 2) # in x coordinates, to position axis labeling at the bottom of the graph (according to x scale)
x.left.fig.region <- 10^(par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1]) # in x coordinates
x.mid.right.fig.region <- 10^(par("usr")[2] + ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * (1 - par("plt")[2]) / 2) # in x coordinates, to position axis labeling at the top of the graph (according to x scale)
@@ -1833,6 +1898,10 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
x.right.plot.region <- 10^par("usr")[2] # in x coordinates, right of the plot region (according to x scale)
x.mid.plot.region <- 10^((par("usr")[2] + par("usr")[1]) / 2) # in x coordinates, right of the plot region (according to x scale)
}else{
+ x.mid.left.dev.region <- (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * par("omd")[1] / 2) # in x coordinates, to position axis labeling at the bottom of the graph (according to x scale)
+ x.left.dev.region <- (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * par("omd")[1]) # in x coordinates
+ x.mid.right.dev.region <- (par("usr")[2] + ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * (1 - par("plt")[2]) + ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * (1 - par("omd")[2]) / 2) # in x coordinates, to position axis labeling at the top of the graph (according to x scale)
+ x.right.dev.region <- (par("usr")[2] + ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * (1 - par("plt")[2]) + ((par("usr")[2] - par("usr")[1]) / ((par("omd")[2] - par("omd")[1]) * (par("plt")[2] - par("plt")[1]))) * (1 - par("omd")[2])) # in x coordinates
x.mid.left.fig.region <- (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] / 2) # in x coordinates, to position axis labeling at the bottom of the graph (according to x scale)
x.left.fig.region <- (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1]) # in x coordinates
x.mid.right.fig.region <- (par("usr")[2] + ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * (1 - par("plt")[2]) / 2) # in x coordinates, to position axis labeling at the top of the graph (according to x scale)
@@ -1842,6 +1911,10 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
x.mid.plot.region <- (par("usr")[2] + par("usr")[1]) / 2 # in x coordinates, right of the plot region (according to x scale)
}
if(y.log.scale == TRUE){
+ y.mid.bottom.dev.region <- 10^(par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3] - ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * (par("omd")[3] / 2)) # in y coordinates, to position axis labeling at the bottom of the graph (according to y scale). Ex mid.bottom.space
+ y.bottom.dev.region <- 10^(par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3] - ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * par("omd")[3]) # in y coordinates
+ y.mid.top.dev.region <- 10^(par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * (1 - par("omd")[4]) / 2) # in y coordinates, to position axis labeling at the top of the graph (according to y scale). Ex mid.top.space
+ y.top.dev.region <- 10^(par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * (1 - par("omd")[4])) # in y coordinates
y.mid.bottom.fig.region <- 10^(par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3] / 2) # in y coordinates, to position axis labeling at the bottom of the graph (according to y scale). Ex mid.bottom.space
y.bottom.fig.region <- 10^(par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3]) # in y coordinates
y.mid.top.fig.region <- 10^(par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) / 2) # in y coordinates, to position axis labeling at the top of the graph (according to y scale). Ex mid.top.space
@@ -1850,13 +1923,17 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
y.bottom.plot.region <- 10^par("usr")[3] # in y coordinates, bottom of the plot region (according to y scale)
y.mid.plot.region <- (par("usr")[3] + par("usr")[4]) / 2 # in x coordinates, right of the plot region (according to x scale)
}else{
+ y.mid.bottom.dev.region <- (par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3] - ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * (par("omd")[3] / 2)) # in y coordinates, to position axis labeling at the bottom of the graph (according to y scale). Ex mid.bottom.space
+ y.bottom.dev.region <- (par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3] - ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * par("omd")[3]) # in y coordinates
+ y.mid.top.dev.region <- (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * (1 - par("omd")[4]) / 2) # in y coordinates, to position axis labeling at the top of the graph (according to y scale). Ex mid.top.space
+ y.top.dev.region <- (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / ((par("omd")[4] - par("omd")[3]) * (par("plt")[4] - par("plt")[3]))) * (1 - par("omd")[4])) # in y coordinates
y.mid.bottom.fig.region <- (par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3] / 2) # in y coordinates, to position axis labeling at the bottom of the graph (according to y scale). Ex mid.bottom.space
y.bottom.fig.region <- (par("usr")[3] - ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * par("plt")[3]) # in y coordinates
y.mid.top.fig.region <- (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) / 2) # in y coordinates, to position axis labeling at the top of the graph (according to y scale). Ex mid.top.space
y.top.fig.region <- (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4])) # in y coordinates
y.top.plot.region <- par("usr")[4] # in y coordinates, top of the plot region (according to y scale)
y.bottom.plot.region <- par("usr")[3] # in y coordinates, bottom of the plot region (according to y scale)
- y.mid.plot.region <- 10^((par("usr")[3] + par("usr")[4]) / 2) # in x coordinates, right of the plot region (according to x scale)
+ y.mid.plot.region <- ((par("usr")[3] + par("usr")[4]) / 2) # in x coordinates, right of the plot region (according to x scale)
}
if(x.side == 1 | x.side == 3){
par(xpd=FALSE, xaxt="s")
@@ -1977,7 +2054,7 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
invisible(dev.off()) # close the new window
if( ! is.null(custom.par)){
if( ! names(custom.par) %in% names(tempo.par$ini.par)){
- tempo.cat <- paste0("\n\n================\n\nERROR: custom.par ARGUMENT SHOULD HAVE THE NAMES OF THE COMPARTMENT LIST COMING FROM THE par() LIST\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_feature_post_plot(): custom.par ARGUMENT SHOULD HAVE THE NAMES OF THE COMPARTMENT LIST COMING FROM THE par() LIST\n\n================\n\n")
stop(tempo.cat)
}
par(custom.par)
@@ -1987,7 +2064,7 @@ fun_feature_post_plot <- function(x.side = 0, x.log.scale = FALSE, x.categ = NUL
text <- c(text, "\nGRAPH PARAMETERS RESET TO par() DEFAULT VALUES\n")
}
}
- output <- list(x.mid.left.fig.region = x.mid.left.fig.region, x.left.fig.region = x.left.fig.region, x.mid.right.fig.region = x.mid.right.fig.region, x.right.fig.region = x.right.fig.region, x.left.plot.region = x.left.plot.region, x.right.plot.region = x.right.plot.region, x.mid.plot.region = x.mid.plot.region, y.mid.bottom.fig.region = y.mid.bottom.fig.region, y.bottom.fig.region = y.bottom.fig.region, y.mid.top.fig.region = y.mid.top.fig.region, y.top.fig.region = y.top.fig.region, y.top.plot.region = y.top.plot.region, y.bottom.plot.region = y.bottom.plot.region, y.mid.plot.region = y.mid.plot.region, text = text)
+ output <- list(x.mid.left.dev.region = x.mid.left.dev.region, x.left.dev.region = x.left.dev.region, x.mid.right.dev.region = x.mid.right.dev.region, x.right.dev.region = x.right.dev.region, x.mid.left.fig.region = x.mid.left.fig.region, x.left.fig.region = x.left.fig.region, x.mid.right.fig.region = x.mid.right.fig.region, x.right.fig.region = x.right.fig.region, x.left.plot.region = x.left.plot.region, x.right.plot.region = x.right.plot.region, x.mid.plot.region = x.mid.plot.region, y.mid.bottom.dev.region = y.mid.bottom.dev.region, y.bottom.dev.region = y.bottom.dev.region, y.mid.top.dev.region = y.mid.top.dev.region, y.top.dev.region = y.top.dev.region, y.mid.bottom.fig.region = y.mid.bottom.fig.region, y.bottom.fig.region = y.bottom.fig.region, y.mid.top.fig.region = y.mid.top.fig.region, y.top.fig.region = y.top.fig.region, y.top.plot.region = y.top.plot.region, y.bottom.plot.region = y.bottom.plot.region, y.mid.plot.region = y.mid.plot.region, text = text)
return(output)
}
@@ -2012,7 +2089,7 @@ fun_close_specif_window <- function(kind = "pdf", return.text = FALSE){
# kind = c("windows", "pdf") ; return.text = FALSE # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_close_specif_window(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
@@ -2065,6 +2142,287 @@ fun_close_specif_window <- function(kind = "pdf", return.text = FALSE){
}
+######## fun_var_trim_display() #### Display values from a quantitative variable and trim according to defined cut-offs
+
+
+fun_var_trim_display <- function(data, displayed.nb = NULL, single.value.display = FALSE, trim.method = "", trim.cutoffs = c(0.05, 0.975), interval.scale.disp = TRUE, down.space = 0.75, left.space = 0.75, up.space = 0.3, right.space = 0.25, orient = 1, dist.legend = 0.37, box.type = "l", amplif.label = 1.25, amplif.axis = 1.25, std.x.range = TRUE, std.y.range = TRUE, cex.pt = 0.2, col.box = hsv(0.55, 0.8, 0.8), x.nb.inter.tick = 4, y.nb.inter.tick = 0, tick.length = 1, sec.tick.length = 0.75, text.corner = "", amplif.legend = 1, magnific.text.corner = 0.75, trim.return = FALSE){
+ # AIM:
+ # trim and display values from a numeric vector or matrix
+ # plot 4 graphs: stripchart of values, stripchart of rank of values, hitogramme and normal QQPlot
+ # different kinds of intervals are displayed on the top of graphes to facilitate the analysis of the variable and a trimming setting
+ # the trimming interval chosen is displayed on top of graphs
+ # both trimmed and not trimmed values are returned in a list
+ # REQUIRED FUNCTIONS
+ # fun_param_check()
+ # ARGUMENTS
+ # data: values to plot (either a numeric vector or a numeric matrix)
+ # displayed.nb: number of values displayed. If NULL, all the values are displayed. Otherwise, if the number of values is over displayed.nb, then displayed.nb values are displayed after random selection
+ # single.value.display: provide the 4 graphs if data is made of a single (potentially repeated value)? If FALSE, an empty graph is displayed if data is made of a single (potentially repeated value). And the return list is made of NULL compartments
+ # trim.method: Write "" if not required. write "mean.sd" if mean +/- sd has to be displayed as a trimming interval (only recommanded for normal distribution). Write "quantile" to display a trimming interval based on quantile cut-offs. No other possibility allowed. See trim.cutoffs below
+ # trim.cutoffs: 2 values cutoff for the trimming interval displayed, each value between 0 and 1. Not used if trim.method == "".The couple of values c(lower, upper) represents the lower and upper boundaries of the trimming interval (in proportion), which represent the interval of distribution kept (between 0 and 1). Example: trim.cutoffs = c(0.05, 0.975). What is strictly kept for the display is ]lower , upper[, boundaries excluded. Using the "mean.sd" method, 0.025 and 0.975 represent 95% CI which is mean +/- 1.96 * sd
+ # interval.scale.disp: display sd and quantiles intervals on top of graphs ?
+ # down.space: lower vertical margin (in inches, mai argument of par())
+ # left.space: left horizontal margin (in inches, mai argument of par())
+ # up.space: upper vertical margin between plot region and grapical window (in inches, mai argument of par())
+ # right.space: right horizontal margin (in inches, mai argument of par())
+ # orient: scale number orientation (las argument of par()). 0, always parallel to the axis; 1, always horizontal; 2, always perpendicular to the axis; 3, always vertical
+ # dist.legend: numeric value that moves axis legends away in inches (first number of mgp argument of par() but in inches thus / 0.2)
+ # box.type: bty argument of par(). Either "o", "l", "7", "c", "u", "]", the resulting box resembles the corresponding upper case letter. A value of "n" suppresses the box
+ # amplif.label: increase or decrease the size of the text in legends
+ # amplif.axis: increase or decrease the size of the scale numbers in axis
+ # std.x.range: standard range on the x-axis? TRUE (no range extend) or FALSE (4% range extend). Controls xaxs argument of par() (TRUE is xaxs = "i", FALSE is xaxs = "r")
+ # std.y.range: standard range on the y-axis? TRUE (no range extend) or FALSE (4% range extend). Controls yaxs argument of par() (TRUE is yaxs = "i", FALSE is yaxs = "r")
+ # cex.pt: size of points in stripcharts (in inches, thus cex.pt will be thereafter / 0.2)
+ # col.box: color of boxplot
+ # x.nb.inter.tick: number of secondary ticks between main ticks on x-axis (only if not log scale). Zero means non secondary ticks
+ # y.nb.inter.tick: number of secondary ticks between main ticks on y-axis (only if not log scale). Zero means non secondary ticks
+ # tick.length: length of the ticks (1 means complete the distance between the plot region and the axis numbers, 0.5 means half the length, etc. 0 means no tick
+ # sec.tick.length: length of the secondary ticks (1 means complete the distance between the plot region and the axis numbers, 0.5 means half the length, etc., 0 for no ticks)
+ # text.corner: text to add at the top right corner of the window
+ # amplif.legend: increase or decrease the size of the text of legend
+ # magnific.text.corner: increase or decrease the size of the text
+ # trim.return: return the trimmed and non trimmed values? NULL returned for trimmed and non trimmed values if trim.method == ""
+ # RETURN
+ # a list containing:
+ # $trim.method: correspond to trim.method above
+ # $trim.cutoffs: correspond to trim.cutoffs above
+ # $real.trim.cutoffs: the two boundary values (in the unit of the numeric vector or numeric matrix analyzed). NULL
+ # $trimmed.values: the values outside of the trimming interval as defined in trim.cutoffs above
+ # $kept.values: the values inside the trimming interval as defined in trim.cutoffs above
+ # EXAMPLES
+ # fun_var_trim_display(data = c(1:100, 1:10), displayed.nb = NULL, single.value.display = FALSE, trim.method = "mean.sd", trim.cutoffs = c(0.05, 0.975), interval.scale.disp = TRUE, down.space = 0.75, left.space = 0.75, up.space = 0.3, right.space = 0.25, orient = 1, dist.legend = 0.37, box.type = "l", amplif.label = 1.25, amplif.axis = 1.25, std.x.range = TRUE, std.y.range = TRUE, cex.pt = 0.2, col.box = hsv(0.55, 0.8, 0.8), x.nb.inter.tick = 4, y.nb.inter.tick = 0, tick.length = 0.5, sec.tick.length = 0.3, text.corner = "", amplif.legend = 1, magnific.text.corner = 0.75, trim.return = TRUE)
+ # DEBUGGING
+ # data = c(1:100, 1:10) ; displayed.nb = NULL ; single.value.display = FALSE ; trim.method = "quantile" ; trim.cutoffs = c(0.05, 0.975) ; interval.scale.disp = TRUE ; down.space = 1 ; left.space = 1 ; up.space = 0.5 ; right.space = 0.25 ; orient = 1 ; dist.legend = 0.5 ; box.type = "l" ; amplif.label = 1 ; amplif.axis = 1 ; std.x.range = TRUE ; std.y.range = TRUE ; cex.pt = 0.1 ; col.box = hsv(0.55, 0.8, 0.8) ; x.nb.inter.tick = 4 ; y.nb.inter.tick = 0 ; tick.length = 0.5 ; sec.tick.length = 0.3 ; text.corner = "" ; amplif.legend = 1 ; magnific.text.corner = 0.75 ; trim.return = TRUE # for function debugging
+ # required function checking
+ if(length(find("fun_param_check", mode = "function")) == 0){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_var_trim_display(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ stop(tempo.cat)
+ }
+ # end required function checking
+ # argument checking
+ arg.check <- NULL # for function debbuging
+ checked.arg.names <- NULL # for function debbuging
+ ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
+ if( ! (all(class(data) == "numeric") | all(class(data) == "integer") | (all(class(data) == "matrix") & mode(data) == "numeric"))){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_var_trim_display(): data ARGUMENT MUST BE A NUMERIC VECTOR OR NUMERIC MATRIX\n\n================\n\n")
+ stop(tempo.cat)
+ }
+ if( ! is.null(displayed.nb)){
+ tempo <- fun_param_check(data = displayed.nb, class = "numeric", length = 1) ; eval(ee)
+ if(displayed.nb < 2){
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_var_trim_display(): displayed.nb ARGUMENT MUST BE A SINGLE INTEGER VALUE GREATER THAN 1 AND NOT: ", paste(displayed.nb, collapse = " "), "\n\n================\n\n")
+ stop(tempo.cat)
+ }
+ }
+ tempo <- fun_param_check(data = single.value.display, class = "logical", length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = trim.method, options = c("", "mean.sd", "quantile"), length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = trim.cutoffs, class = "numeric", length = 2, prop = TRUE) ; eval(ee)
+ tempo <- fun_param_check(data = interval.scale.disp, class = "logical", length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = down.space, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = left.space, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = up.space, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = right.space, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = orient, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = dist.legend, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = box.type, options = c("o", "l", "7", "c", "u", "]", "n"), length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = amplif.label, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = amplif.axis, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = std.x.range, class = "logical", length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = std.y.range, class = "logical", length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = cex.pt, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = col.box, class = "character", length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = x.nb.inter.tick, class = "integer", length = 1, neg.values = FALSE, double.as.integer.allowed = TRUE) ; eval(ee)
+ tempo <- fun_param_check(data = y.nb.inter.tick, class = "integer", length = 1, neg.values = FALSE, double.as.integer.allowed = TRUE) ; eval(ee)
+ tempo <- fun_param_check(data = tick.length, class = "numeric", length = 1, prop = TRUE) ; eval(ee)
+ tempo <- fun_param_check(data = sec.tick.length, class = "numeric", length = 1, prop = TRUE) ; eval(ee)
+ tempo <- fun_param_check(data = text.corner, class = "character", length = 1) ; eval(ee)
+ tempo <- fun_param_check(data = amplif.legend, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = magnific.text.corner, class = "numeric", length = 1, neg.values = FALSE) ; eval(ee)
+ tempo <- fun_param_check(data = trim.return, class = "logical", length = 1) ; eval(ee)
+ if(any(arg.check) == TRUE){
+ stop()
+ }
+ # 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_param_check_dev)) # activate this line and use the function to check arguments status and if they have been checked using fun_param_check()
+ # end argument checking
+ if(class(data) == "matrix"){
+ data <- as.vector(data)
+ }
+ color.cut <- hsv(0.75, 1, 1) # color of interval selected
+ col.mean <- hsv(0.25, 1, 0.8) # color of interval using mean+/-sd
+ col.quantile <- "orange" # color of interval using quantiles
+ quantiles.selection <- c(0.01, 0.025, 0.05, 0.1, 0.25, 0.5, 0.75, 0.9, 0.95, 0.975, 0.99) # quantiles used in axis to help for choosing trimming cutoffs
+ if(single.value.display == FALSE & length(unique(data)) == 1){
+ par(bty = "n", xaxt = "n", yaxt = "n", xpd = TRUE)
+ plot(1, pch = 16, col = "white", xlab = "", ylab = "")
+ text(x = 1, y = 1, paste0("No graphic displayed\nBecause data made of a single different value (", formatC(as.double(table(data))), ")"), cex = 2)
+ output <- list(trim.method = NULL, trim.cutoffs = NULL, real.trim.cutoffs = NULL, trimmed.values = NULL, kept.values = NULL)
+ }else{
+ output <- list(trim.method = trim.method, trim.cutoffs = trim.cutoffs, real.trim.cutoffs = NULL, trimmed.values = NULL, kept.values = NULL)
+ fun.rug <- function(sec.tick.length.f = sec.tick.length, x.nb.inter.tick.f = x.nb.inter.tick, y.nb.inter.tick.f = y.nb.inter.tick){
+ if(x.nb.inter.tick.f > 0){
+ inter.tick.unit <- (par("xaxp")[2] - par("xaxp")[1]) / par("xaxp")[3]
+ par.ini <- par()[c("xpd", "tcl")]
+ par(xpd = FALSE)
+ par(tcl = -par()$mgp[2] * sec.tick.length.f) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region)
+ suppressWarnings(rug(seq(par("xaxp")[1] - 10 * inter.tick.unit, par("xaxp")[2] + 10 * inter.tick.unit, by = inter.tick.unit / (1 + x.nb.inter.tick.f)), ticksize = NA, side = 1)) # ticksize = NA to allow the use of par()$tcl value
+ par(par.ini)
+ rm(par.ini)
+ }
+ if(y.nb.inter.tick.f > 0){
+ inter.tick.unit <- (par("yaxp")[2] - par("yaxp")[1]) / par("yaxp")[3]
+ par.ini <- par()[c("xpd", "tcl")]
+ par(xpd = FALSE)
+ par(tcl = -par()$mgp[2] * sec.tick.length.f) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region)
+ suppressWarnings(rug(seq(par("yaxp")[1] - 10 * inter.tick.unit, par("yaxp")[2] + 10 * inter.tick.unit, by = inter.tick.unit / (1 + y.nb.inter.tick.f)), ticksize = NA, side = 2)) # ticksize = NA to allow the use of par()$tcl value
+ par(par.ini)
+ rm(par.ini)
+ }
+ }
+ fun.add.cut <- function(data.f, trim.method.f = trim.method, trim.cutoffs.f = trim.cutoffs, color.cut.f = color.cut, return.f = FALSE){
+ # DEBUGGING
+ # data.f = data ; trim.method.f = "mean.sd"; trim.cutoffs.f = trim.cutoffs ; color.cut.f = color.cut ; return.f = TRUE
+ real.trim.cutoffs.f <- NULL
+ if(trim.method.f != ""){
+ data.f <- sort(data.f)
+ par.ini <- par()$xpd
+ par(xpd = FALSE)
+ if(trim.method.f == "mean.sd"){
+ real.trim.cutoffs.f <- qnorm(trim.cutoffs.f, mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE))
+ abline(v = qnorm(trim.cutoffs.f, mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), col = color.cut.f)
+ segments(qnorm(trim.cutoffs.f[1], mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), par()$usr[4] * 0.75, qnorm(trim.cutoffs.f[2], mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), par()$usr[4] * 0.75, col = color.cut.f)
+ }
+ if(trim.method.f == "quantile"){
+ real.trim.cutoffs.f <- quantile(data.f, probs = trim.cutoffs.f, type = 7)
+ abline(v = quantile(data.f, probs = trim.cutoffs.f, type = 7), col = color.cut.f)
+ segments(quantile(data.f, probs = trim.cutoffs.f[1], type = 7), par()$usr[4] * 0.75, quantile(data.f, probs = trim.cutoffs.f[2], type = 7), par()$usr[4] * 0.75, col = color.cut.f)
+ }
+ par(par.ini)
+ if(return.f == TRUE){
+ trimmed.values.f <- data.f[data.f <= real.trim.cutoffs.f[1] | data.f >= real.trim.cutoffs.f[2]]
+ kept.values.f <- data.f[data.f > real.trim.cutoffs.f[1] & data.f < real.trim.cutoffs.f[2]]
+ }
+ }else{
+ real.trim.cutoffs.f <- NULL
+ trimmed.values.f <- NULL
+ kept.values.f <- NULL
+ }
+ if(return.f == TRUE){
+ output <- list(trim.method = trim.method.f, trim.cutoffs = trim.cutoffs.f, real.trim.cutoffs = real.trim.cutoffs.f, trimmed.values = trimmed.values.f, kept.values = kept.values.f)
+ return(output)
+ }
+ }
+ fun.interval.scale.display <- function(data.f, col.quantile.f = col.quantile, quantiles.selection.f = quantiles.selection, col.mean.f = col.mean){ # intervals on top of graphs
+ par.ini <- par()[c("mgp", "xpd")]
+ par(mgp = c(0.25, 0.25, 0), xpd = NA)
+ axis(side = 3, at = c(par()$usr[1], par()$usr[2]), labels = rep("", 2), col = col.quantile.f, lwd.ticks = 0)
+ par(xpd = FALSE)
+ axis(side = 3, at = quantile(as.vector(data.f), probs = quantiles.selection.f, type = 7), labels = quantiles.selection.f, col.axis = col.quantile.f, col = col.quantile.f)
+ par(mgp = c(1.75, 1.75, 1.5), xpd = NA)
+ axis(side = 3, at = c(par()$usr[1], par()$usr[2]), labels = rep("", 2), col = col.mean.f, lwd.ticks = 0)
+ par(xpd = FALSE)
+ axis(side = 3, at = m + s * qnorm(quantiles.selection.f), labels = formatC(round(qnorm(quantiles.selection.f), 2)), col.axis = col.mean.f, col = col.mean.f, lwd.ticks = 1)
+ par(par.ini)
+ }
+ zone<-matrix(1:4, ncol=2)
+ layout(zone)
+ par(omi = c(0, 0, 1.5, 0), mai = c(down.space, left.space, up.space, right.space), las = orient, mgp = c(dist.legend / 0.2, 0.5, 0), xpd = FALSE, bty= box.type, cex.lab = amplif.label, cex.axis = amplif.axis, xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r"))
+ par(tcl = -par()$mgp[2] * tick.length) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region)
+ if(is.null(displayed.nb)){
+ sampled.data <- as.vector(data)
+ if(text.corner == ""){
+ text.corner <- paste0("ALL VALUES OF THE DATASET DISPLAYED")
+ }else{
+ text.corner <- paste0(text.corner, "\nALL VALUES OF THE DATASET DISPLAYED")
+ }
+ }else{
+ if(length(as.vector(data)) > displayed.nb){
+ sampled.data <- sample(as.vector(data), displayed.nb, replace = FALSE)
+ if(text.corner == ""){
+ text.corner <- paste0("BEWARE: ONLY ", displayed.nb, " VALUES ARE DISPLAYED AMONG THE ", length(as.vector(data)), " VALUES OF THE DATASET ANALYZED")
+ }else{
+ text.corner <- paste0(text.corner, "\nBEWARE: ONLY ", displayed.nb, " VALUES ARE DISPLAYED AMONG THE ", length(as.vector(data)), " VALUES OF THE DATASET ANALYZED")
+ }
+ }else{
+ sampled.data <- as.vector(data)
+ if(text.corner == ""){
+ text.corner <- paste0("BEWARE: THE DISPLAYED NUMBER OF VALUES PARAMETER ", deparse(substitute(displayed.nb)), " HAS BEEN SET TO ", displayed.nb, " WHICH IS ABOVE THE NUMBER OF VALUES OF THE DATASET ANALYZED -> ALL VALUES DISPLAYED")
+ }else{
+ text.corner <- paste0(text.corner, "\nBEWARE: THE DISPLAYED NUMBER OF VALUES PARAMETER ", deparse(substitute(displayed.nb)), " HAS BEEN SET TO ", displayed.nb, " WHICH IS ABOVE THE NUMBER OF VALUES OF THE DATASET ANALYZED -> ALL VALUES DISPLAYED")
+ }
+ }
+ }
+ stripchart(sampled.data, method="jitter", jitter=0.4, vertical=FALSE, ylim=c(0.5, 1.5), group.names = "", xlab = "Value", ylab="", pch=1, cex = cex.pt / 0.2)
+ fun.rug(y.nb.inter.tick.f = 0)
+ boxplot(as.vector(data), horizontal=TRUE, add=TRUE, boxwex = 0.4, staplecol = col.box, whiskcol = col.box, medcol = col.box, boxcol = col.box, range = 0, whisklty = 1)
+ m <- mean(as.vector(data), na.rm = TRUE)
+ s <- sd(as.vector(data), na.rm = TRUE)
+ segments(m, 0.8, m, 1, lwd=2, col="red") # mean
+ segments(m -1.96 * s, 0.9, m + 1.96 * s, 0.9, lwd=1, col="red") # mean
+ graph.xlim <- par()$usr[1:2] # for hist() and qqnorm() below
+ if(interval.scale.disp == TRUE){
+ fun.interval.scale.display(data.f = data)
+ if(text.corner == ""){
+ text.corner <- paste0("MULTIPLYING FACTOR DISPLAYED (MEAN +/- SD) ON SCALES: ", paste(formatC(round(qnorm(quantiles.selection), 2))[-(1:(length(quantiles.selection) - 1) / 2)], collapse = ", "), "\nQUANTILES DISPLAYED ON SCALES: ", paste(quantiles.selection, collapse = ", "))
+ }else{
+ text.corner <- paste0(text.corner, "\nMULTIPLYING FACTOR DISPLAYED (MEAN +/- SD) ON SCALES: ", paste(formatC(round(qnorm(quantiles.selection), 2))[-(1:(length(quantiles.selection) - 1) / 2)], collapse = ", "), "\nQUANTILES DISPLAYED ON SCALES: ", paste(quantiles.selection, collapse = ", "))
+ }
+ }
+ output.tempo <- fun.add.cut(data.f = data, return.f = TRUE) # to recover real.trim.cutoffs
+ if(trim.return == TRUE){
+ output <- output.tempo
+ }
+ par(xpd = NA)
+ if(trim.method != ""){
+ if(text.corner == ""){
+ text.corner <- paste0("SELECTED CUT-OFFS (PROPORTION): ", paste(trim.cutoffs, collapse = ", "), "\nSELECTED CUT-OFFS: ", paste(output.tempo$real.trim.cutoffs, collapse = ", "))
+ }else{
+ text.corner <- paste0(text.corner, "\nSELECTED CUT-OFFS (PROPORTION): ", paste(trim.cutoffs, collapse = ", "), "\nSELECTED CUT-OFFS: ", paste(output.tempo$real.trim.cutoffs, collapse = ", "))
+ }
+ if(interval.scale.disp == TRUE){
+ legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- 1.96sd", paste0("Trimming interval: ", paste0(trim.cutoffs, collapse = " , ")), "Mean +/- sd multiplying factor", "Quantile"), yjust = 0, lty=1, col=c(col.box, "red", color.cut, col.mean, col.quantile), bty="n", cex = amplif.legend)
+ }else{
+ legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- 1.96sd", paste0("Trimming interval: ", paste0(trim.cutoffs, collapse = " , "))), yjust = 0, lty=1, col=c(col.box, "red", color.cut), bty="n", cex = amplif.legend, y.intersp=1.25)
+ }
+ }else{
+ if(interval.scale.disp == TRUE){
+ legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- sd", "Mean +/- sd multiplying factor", "Quantile"), yjust = 0, lty=1, col=c(col.box, "red", col.mean, col.quantile), bty="n", cex = amplif.legend)
+ }else{
+ legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- sd"), yjust = 0, lty=1, col=c(col.box, "red"), bty="n", cex = amplif.legend, y.intersp=1.25)
+ }
+ }
+ par(xpd = FALSE, xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r"))
+ hist(as.vector(data), main = "", breaks = seq(min(as.vector(data), na.rm = TRUE), max(as.vector(data), na.rm = TRUE), length.out = length(as.vector(data)) / 10), xlim = graph.xlim, xlab = "Value", ylab="Density", col = grey(0.25))
+ abline(h = par()$usr[3])
+ fun.rug()
+ if(interval.scale.disp == TRUE){
+ fun.interval.scale.display(data.f = data)
+ }
+ fun.add.cut(data.f = data)
+ par(xaxs = ifelse(std.x.range, "i", "r"))
+ stripchart(rank(sampled.data), method="stack", vertical=FALSE, ylim=c(0.99, 1.3), group.names = "", xlab = "Rank of values", ylab="", pch=1, cex = cex.pt / 0.2)
+ fun.rug(y.nb.inter.tick.f = 0)
+ x.text <- par("usr")[2] + (par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1]) * (1 - par("plt")[2]) / 2
+ y.text <- (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / ((par()$omd[4] / 2) * ((par("plt")[4] - par("plt")[3])))) * (1 - par("omd")[4])) # BEWARE. Here in "(par()$omd[4] / 2", division by two because there are 2 graphs staked on the y axis, and not one
+ par(xpd=NA)
+ text(x = x.text, y = y.text, paste0(text.corner), adj=c(1, 1.1), cex = magnific.text.corner) # text at the topright corner
+ par(xpd=FALSE)
+ par(xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r"))
+ qqnorm(as.vector(sampled.data), main = "", datax = TRUE, ylab = "Value", pch = 1, col = "red", cex = cex.pt / 0.2)
+ fun.rug()
+ if(diff(quantile(as.vector(data), probs = c(0.25, 0.75), na.rm = TRUE)) != 0){ # otherwise, error generated
+ qqline(as.vector(data), datax = TRUE)
+ }
+ if(interval.scale.disp == TRUE){
+ fun.interval.scale.display(data.f = data)
+ }
+ fun.add.cut(data.f = data)
+ }
+ if(trim.return == TRUE){
+ return(output)
+ }
+}
+
+
################ Exporting results (text & tables)
@@ -2074,7 +2432,7 @@ fun_close_specif_window <- function(kind = "pdf", return.text = FALSE){
# Check OK: clear to go Apollo
fun_export_data <- function(data = NULL, output ="results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, sep = 2){
# AIM:
- # print a character string or a data object into an output file
+ # log file function: print a character string or a data object into a same output file
# REQUIRED FUNCTIONS
# fun_param_check()
# ARGUMENTS
@@ -2094,13 +2452,13 @@ fun_export_data <- function(data = NULL, output ="results.txt", path = "C:/Users
# data = 1:3 ; output = "results.txt" ; path = "C:/Users/Gael/Desktop" ; no.overwrite = TRUE ; rownames.kept = FALSE ; vector.cat = FALSE ; sep = 2 # for function debugging
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
- tempo.cat <- paste0("\n\n================\n\nERROR: REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_export_data(): REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# argument checking
if(is.null(data)){
- tempo.cat <- paste0("\n\n================\n\nERROR: data ARGUMENT CANNOT BE NULL\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_export_data(): data ARGUMENT CANNOT BE NULL\n\n================\n\n")
stop(tempo.cat)
}
arg.check <- NULL # for function debbuging
@@ -2121,15 +2479,15 @@ fun_export_data <- function(data = NULL, output ="results.txt", path = "C:/Users
# default.arg.list <- formals(fun = sys.function(sys.parent())) # list of all the arguments of the function with their default values (not the values of the user !). It seems that ls() as first line of the function provide the names of the arguments (empty, called, etc., or not)
# arg.without.default.value <- sapply(default.arg.list, is.symbol) & sapply(sapply(default.arg.list, as.character), identical, "") # logical to detect argument without default values (these are typeof "symbol" and class "name" and empty character
# if( ! all(names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list))){ # test that the arguments with no null values are provided by the user
- # tempo.cat <- paste0("\n\n================\n\nERROR: VALUE REQUIRED FOR THESE ARGUMENTS WITH NO DEFAULTS VALUES: ", paste(names(default.arg.list)[arg.without.default.value][ ! names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list)], collapse = " "), "\n\n================\n\n")
+ # tempo.cat <- paste0("\n\n================\n\nERROR IN fun_export_data(): VALUE REQUIRED FOR THESE ARGUMENTS WITH NO DEFAULTS VALUES: ", paste(names(default.arg.list)[arg.without.default.value][ ! names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list)], collapse = " "), "\n\n================\n\n")
#stop(tempo.cat)
# }
if(output == ""){
- tempo.cat <- paste0("\n\n================\n\nERROR: output ARGUMENT DOES NOT CORRESPOND TO A VALID CHARACTER STRING\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_export_data(): output ARGUMENT DOES NOT CORRESPOND TO A VALID CHARACTER STRING\n\n================\n\n")
stop(tempo.cat)
}
if(dir.exists(path) == FALSE){
- tempo.cat <- paste0("\n\n================\n\nERROR: path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n\n================\n\n")
+ tempo.cat <- paste0("\n\n================\n\nERROR IN fun_export_data(): path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking
diff --git a/cute_little_R_functions.docx b/cute_little_R_functions.docx
index 792665c4e0cbdbaf2e8e43c91768677109e367f9..a4a6315266cec8d8ee1eff3c2510578c05822c86 100644
Binary files a/cute_little_R_functions.docx and b/cute_little_R_functions.docx differ
diff --git a/examples_alone.txt b/examples_alone.txt
index 452ccdba92d7586fc023a4d8e0410751508e1946..f62689110f306caf07266fc4c5dfb484c014b56a 100644
--- a/examples_alone.txt
+++ b/examples_alone.txt
@@ -16,7 +16,10 @@ obs1 = 1:5 ; obs2 = 1.1:6.1 ; fun_1D_comp(obs1, obs2)
obs1 = as.table(1:5); obs2 = as.table(1:5) ; fun_1D_comp(obs1, obs2)
obs1 = as.table(1:5); obs2 = 1:5 ; fun_1D_comp(obs1, obs2)
-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]))) ; fun_2D_comp(obs1, obs2)
+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_2D_comp(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_2D_comp(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_2D_comp(obs1, obs2)
+
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_list_comp(obs1, obs2)
obs1 = list(1:5, LETTERS[1:2]) ; obs2 = list(a = 1:5, b = LETTERS[1:2]) ; fun_list_comp(obs1, obs2)
@@ -50,9 +53,13 @@ fun_graph_param_prior_plot(param.reinitial = FALSE, xlog.scale = FALSE, ylog.sca
prior.par <- fun_graph_param_prior_plot(param.reinitial = TRUE, xlog.scale = FALSE, ylog.scale = TRUE, remove.label = TRUE, remove.x.axis = FALSE, remove.y.axis = TRUE, down.space = 1, left.space = 1, up.space = 1, right.space = 1, orient = 1, dist.legend = 0.5, tick.length = 0.5, box.type = "n", amplif.label = 1, amplif.axis = 1, display.extend = FALSE, return.par = TRUE) ; plot(1:100, log = "y") ; fun_feature_post_plot(y.side = 2, y.log.scale = prior.par$ylog, x.lab = "Values", y.lab = "TEST", y.axis.magnific = 1.25, y.label.magnific = 1.5, y.dist.legend = 0.7, just.label.add = ! prior.par$ann)
# Example of log axis with redrawn x-axis and y-axis:
prior.par <- fun_graph_param_prior_plot(param.reinitial = TRUE) ; plot(1:100) ; fun_feature_post_plot(x.side = 1, x.lab = "Values", y.side = 2, y.lab = "TEST", y.axis.magnific = 1, y.label.magnific = 2, y.dist.legend = 0.6)
-
+# example with margins in the device region:
+windows(5,5) ; par(mai=c(0.5,0.5,0.5,0.5), omi = c(0.25,0.25,1,0.25), xaxs = "i", yaxs = "i") ; plot(0:10) ; a <- fun_feature_post_plot(x.side = 0, y.side = 0) ; x <- c(a$x.mid.left.dev.region, a$x.left.dev.region, a$x.mid.right.dev.region, a$x.right.dev.region, a$x.mid.left.fig.region, a$x.left.fig.region, a$x.mid.right.fig.region, a$x.right.fig.region, a$x.right.plot.region, a$x.left.plot.region, a$x.mid.plot.region) ; y <- c(a$y.mid.bottom.dev.region, a$y.bottom.dev.region, a$y.mid.top.dev.region, a$y.top.dev.region, a$y.mid.bottom.fig.region, a$y.bottom.fig.region, a$y.mid.top.fig.region, a$y.top.fig.region, a$y.top.plot.region, a$y.bottom.plot.region, a$y.mid.plot.region) ; par(xpd = NA) ; points(x = rep(5, length(y)), y = y, pch = 16, col = "red") ; text(x = rep(5, length(y)), y = y, c("y.mid.bottom.dev.region", "y.bottom.dev.region", "y.mid.top.dev.region", "y.top.dev.region", "y.mid.bottom.fig.region", "y.bottom.fig.region", "y.mid.top.fig.region", "y.top.fig.region", "y.top.plot.region", "y.bottom.plot.region", "y.mid.plot.region"), cex = 0.65, col = grey(0.25)) ; points(y = rep(5, length(x)), x = x, pch = 16, col = "blue") ; text(y = rep(5, length(x)), x = x, c("x.mid.left.dev.region", "x.left.dev.region", "x.mid.right.dev.region", "x.right.dev.region", "x.mid.left.fig.region", "x.left.fig.region", "x.mid.right.fig.region", "x.right.fig.region", "x.right.plot.region", "x.left.plot.region", "x.mid.plot.region"), cex = 0.65, srt = 90, col = grey(0.25))
+
windows() ; windows() ; pdf() ; dev.list() ; fun_close_specif_window(kind = c("pdf", "x11"), return.text = TRUE) ; dev.list()
+fun_var_trim_display(data = c(1:100, 1:10), displayed.nb = NULL, single.value.display = FALSE, trim.method = "mean.sd", trim.cutoffs = c(0.05, 0.975), interval.scale.disp = TRUE, down.space = 0.75, left.space = 0.75, up.space = 0.3, right.space = 0.25, orient = 1, dist.legend = 0.37, box.type = "l", amplif.label = 1.25, amplif.axis = 1.25, std.x.range = TRUE, std.y.range = TRUE, cex.pt = 0.2, col.box = hsv(0.55, 0.8, 0.8), x.nb.inter.tick = 4, y.nb.inter.tick = 0, tick.length = 0.5, sec.tick.length = 0.3, text.corner = "", amplif.legend = 1, magnific.text.corner = 0.75, trim.return = TRUE)
+
fun_export_data()
fun_export_data(data = 1:3, output = "results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, sep = 2)