cute_little_R_functions.R 626 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
1
2
################################################################
##                                                            ##
Gael  MILLOT's avatar
Gael MILLOT committed
3
##     CUTE LITTLE R FUNCTIONS v6.0.0                         ##
Gael  MILLOT's avatar
Gael MILLOT committed
4
5
6
##                                                            ##
##     Gael A. Millot                                         ##
##                                                            ##
Gael  MILLOT's avatar
Gael MILLOT committed
7
##     Compatible with R v3.5.3                               ##
Gael  MILLOT's avatar
Gael MILLOT committed
8
9
10
11
##                                                            ##
################################################################


12
# https://usethis.r-lib.org/ and usethat also
Gael  MILLOT's avatar
Gael MILLOT committed
13
# BEWARE: do not forget to save the modifications in the .R file (through RSTUDIO for indentation)
Gael  MILLOT's avatar
Gael MILLOT committed
14
# add print warning argument using warning(warnings)
Gael  MILLOT's avatar
Gael MILLOT committed
15
# update graphic examples with good comment, as in barplot
Gael  MILLOT's avatar
Gael MILLOT committed
16
17
# Templates: https://prettydoc.statr.me/themes.html
# https://pkgdown.r-lib.org/
Gael  MILLOT's avatar
Gael MILLOT committed
18
# https://rdrr.io/github/gastonstat/cointoss/
Gael  MILLOT's avatar
Gael MILLOT committed
19
# doc:https://www.sphinx-doc.org/en/master/man/sphinx-autogen.html considering that https://www.ericholscher.com/blog/2014/feb/11/sphinx-isnt-just-for-python/
Gael  MILLOT's avatar
Gael MILLOT committed
20
21
22
23

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


Gael  MILLOT's avatar
Gael MILLOT committed
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
################ Object analysis	2
######## fun_check() #### check class, type, length, etc., of objects	2
######## fun_info() #### recover object information	8
######## fun_1d_comp() #### comparison of two 1D datasets (vectors, factors, 1D tables)	9
######## fun_2d_comp() #### comparison of two 2D datasets (row & col names, dimensions, etc.)	13
######## fun_2d_head() #### head of the left or right of big 2D objects	20
######## fun_2d_tail() #### tail of the left or right of big 2D objects	21
######## fun_list_comp() #### comparison of two lists	22
################ Object modification	24
######## fun_name_change() #### check a vector of character strings and modify any string if present in another vector	24
######## fun_df_remod() #### remodeling a data frame to have column name as a qualitative values and vice-versa	26
######## fun_merge() #### merge the columns of two 2D objects, by common rows	29
######## fun_round() #### rounding number if decimal present	33
######## fun_mat_rotate() #### 90° clockwise matrix rotation	35
######## fun_mat_num2color() #### convert a numeric matrix into hexadecimal color matrix	35
######## fun_mat_op() #### assemble several matrices with operation	38
######## fun_mat_inv() #### return the inverse of a square matrix	41
######## fun_mat_fill() #### fill the empty half part of a symmetric square matrix	42
######## fun_permut() #### progressively breaks a vector order	45
################ Graphics management	55
######## fun_width() #### window width depending on classes to plot	56
######## fun_open() #### open a GUI or pdf graphic window	57
######## fun_prior_plot() #### set graph param before plotting (erase axes for instance)	60
######## fun_scale() #### select nice label numbers when setting number of ticks on an axis	64
######## fun_post_plot() #### set graph param after plotting (axes redesign for instance)	69
######## fun_close() #### close specific graphic windows	80
################ Standard graphics	81
######## fun_empty_graph() #### text to display for empty graphs	82
################ gg graphics	83
######## fun_gg_palette() #### ggplot2 default color palette	83
######## fun_gg_just() #### ggplot2 justification of the axis labeling, depending on angle	84
######## fun_gg_point_rast() #### ggplot2 raster scatterplot layer	87
######## fun_gg_scatter() #### ggplot2 scatterplot + lines (up to 6 overlays totally)	90
######## fun_gg_bar_mean() #### ggplot2 mean barplot + overlaid dots if required	126
######## fun_gg_boxplot() #### ggplot2 boxplot + background dots if required	161
######## fun_gg_bar_prop() #### ggplot2 proportion barplot	166
######## fun_gg_strip() #### ggplot2 stripchart + mean/median	166
######## fun_gg_violin() #### ggplot2 violins	166
######## fun_gg_line() #### ggplot2 lines + background dots and error bars	166
######## fun_gg_heatmap() #### ggplot2 heatmap + overlaid mask if required	168
######## fun_gg_empty_graph() #### text to display for empty graphs	182
################ Graphic extraction	184
######## fun_trim() #### display values from a quantitative variable and trim according to defined cut-offs	184
######## fun_segmentation() #### segment a dot cloud on a scatterplot and define the dots from another cloud outside the segmentation	192
################ Import	224
######## fun_pack() #### check if R packages are present and import into the working environment	224
######## fun_python_pack() #### check if python packages are present	226
################ Exporting results (text & tables)	227
######## fun_report() #### print string or data object into output file	227
Gael  MILLOT's avatar
Gael MILLOT committed
73
74
75
76
77
78
79
80


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


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


Gael  MILLOT's avatar
Gael MILLOT committed
81
######## fun_check() #### check class, type, length, etc., of objects
Gael  MILLOT's avatar
Gael MILLOT committed
82
83
84


# Check OK: clear to go Apollo
Gael  MILLOT's avatar
Gael MILLOT committed
85
fun_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, fun.name = NULL){
Gael  MILLOT's avatar
Gael MILLOT committed
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
# AIM
# check the class, type, mode and length of the data argument
# mainly used to check the arguments of other functions
# check also other kind of data parameters, is it a proportion? Is it type double but numbers without decimal part?
# if options = NULL, then at least class, 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 FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data: object to test
# data.name: name of the object to test. If NULL, use the name of the object assigned to the data argument
# class: one of the class() result or "vector"
# typeof: one of the typeof() result
# mode: one of the mode() result (for non vector object)
# length: length of the object
# prop: logical, are the numeric values between 0 and 1 (proportion)?
# double.as.integer.allowed: logical. If TRUE, no error is reported if argument is set to typeof = "integer" or class = "integer", while the reality is typeof = "double" or class = "numeric" but the numbers have a zero as modulo (remainder of a division). This means that i<-1 , which is typeof(i) -> "double" is considered as integer with double.as.integer.allowed = TRUE
# options: a vector of possible values for data
# all.options.in.data: If TRUE, all of the options must be present at least once in data, and nothing else. If FALSE, some of the options must be present in data, and nothing else
# na.contain: can data contains NA?
# neg.values: are negative numeric values authorized? BEWARE: only considered if set to FALSE, to check for non negative values when class is set to "numeric", "matrix", "array", "data.frame", "table", or typeof is set to "double", "integer", or mode is set to "numeric"
# print: print the error message if $problem is TRUE?
Gael  MILLOT's avatar
Gael MILLOT committed
108
# fun.name: name of the function when fun_check() is used to check its argument. If non NULL, name will be added into the error message returned by fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
109
110
111
112
113
114
# RETURN
# a list containing:
# $problem: logical. Is there any problem detected ?
# $text: the problem detected
# $param.name: name of the checked parameter
# EXAMPLES
Gael  MILLOT's avatar
Gael MILLOT committed
115
116
117
118
# test <- 1:3 ; fun_check(data = test, data.name = NULL, print = TRUE, options = NULL, all.options.in.data = FALSE, class = NULL, typeof = NULL, mode = NULL, prop = TRUE, double.as.integer.allowed = FALSE, length = NULL)
# test <- 1:3 ; fun_check(data = test, print = TRUE, class = "numeric", typeof = NULL, double.as.integer.allowed = FALSE)
# test <- 1:3 ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric")
# test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric")
Gael  MILLOT's avatar
Gael MILLOT committed
119
# DEBUGGING
120
# data = expression(TEST) ; data.name = NULL ; class = "vector" ; typeof = NULL ; mode = NULL ; length = 1 ; prop = NULL ; double.as.integer.allowed = FALSE ; options = NULL ; all.options.in.data = FALSE ; na.contain = FALSE ; neg.values = TRUE ; print = TRUE ; fun.name = NULL
Gael  MILLOT's avatar
Gael MILLOT committed
121
# function name: no used in this function for the error message, to avoid env colliding
Gael  MILLOT's avatar
Gael MILLOT committed
122
123
124
# argument checking
if( ! is.null(data.name)){
if( ! (length(data.name) == 1 & class(data.name) == "character")){
Gael  MILLOT's avatar
Gael MILLOT committed
125
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " "), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
126
127
128
129
stop(tempo.cat)
}
}
if(is.null(options) & is.null(class) & is.null(typeof) & is.null(mode) & is.null(prop) & is.null(length)){
Gael  MILLOT's avatar
Gael MILLOT committed
130
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
131
132
133
stop(tempo.cat)
}
if( ! is.null(options) & ( ! is.null(class) | ! is.null(typeof) | ! is.null(mode) | ! is.null(prop))){
Gael  MILLOT's avatar
Gael MILLOT committed
134
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_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")
Gael  MILLOT's avatar
Gael MILLOT committed
135
136
137
stop(tempo.cat)
}
if( ! (all(class(neg.values) == "logical") & length(neg.values) == 1 & any(is.na(neg.values)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
138
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
139
140
141
stop(tempo.cat)
}
if(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){
Gael  MILLOT's avatar
Gael MILLOT committed
142
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE NULL\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
143
144
145
stop(tempo.cat)
}
if( ! is.null(class)){
Gael  MILLOT's avatar
Gael MILLOT committed
146
if( ! all(class %in% c("vector", "logical", "integer", "numeric", "complex", "character", "matrix", "array", "data.frame", "list", "factor", "table", "expression", "name", "symbol", "function", "uneval") & any(is.na(class)) != TRUE)){ # not length == 1 here because ordered factors are class "factor" "ordered" (length == 2)
Gael  MILLOT's avatar
Gael MILLOT committed
147
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"vector\", \"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\" \n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
148
149
150
stop(tempo.cat)
}
if(neg.values == FALSE & ! any(class %in% c("vector", "numeric", "integer", "matrix", "array", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
151
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
152
153
154
155
156
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)){
Gael  MILLOT's avatar
Gael MILLOT committed
157
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_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")
Gael  MILLOT's avatar
Gael MILLOT committed
158
159
160
stop(tempo.cat)
}
if(neg.values == FALSE & ! typeof %in% c("double", "integer")){
Gael  MILLOT's avatar
Gael MILLOT committed
161
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
162
163
164
165
166
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)){
Gael  MILLOT's avatar
Gael MILLOT committed
167
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\"\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
168
169
170
stop(tempo.cat)
}
if(neg.values == FALSE & mode != "numeric"){
Gael  MILLOT's avatar
Gael MILLOT committed
171
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
172
173
174
175
176
stop(tempo.cat)
}
}
if( ! is.null(length)){
if( ! (is.numeric(length) & length(length) == 1 & ! grepl(length, pattern = "\\.") & any(is.na(length)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
177
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): length ARGUMENT MUST BE A SINGLE INTEGER VALUE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
178
179
180
181
182
stop(tempo.cat)
}
}
if( ! is.null(prop)){
if( ! (is.logical(prop) | length(prop) == 1 & any(is.na(prop)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
183
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): prop ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
184
185
186
187
stop(tempo.cat)
}else if(prop == TRUE){
if( ! is.null(class)){
if( ! any(class %in% c("vector", "numeric", "integer", "matrix", "array", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
188
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
189
190
191
192
193
stop(tempo.cat)
}
}
if( ! is.null(mode)){
if(mode != "numeric"){
Gael  MILLOT's avatar
Gael MILLOT committed
194
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
195
196
197
198
199
stop(tempo.cat)
}
}
if( ! is.null(typeof)){
if(typeof != "double"){
Gael  MILLOT's avatar
Gael MILLOT committed
200
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
201
202
203
204
205
206
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)){
Gael  MILLOT's avatar
Gael MILLOT committed
207
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(double.as.integer.allowed, collapse = " "), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
208
209
210
stop(tempo.cat)
}
if( ! (is.logical(all.options.in.data) & length(all.options.in.data) == 1 & any(is.na(all.options.in.data)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
211
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY): ", paste(all.options.in.data, collapse = " "), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
212
213
214
stop(tempo.cat)
}
if( ! (all(class(na.contain) == "logical") & length(na.contain) == 1 & any(is.na(na.contain)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
215
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(na.contain, collapse = " "), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
216
217
218
stop(tempo.cat)
}
if( ! (all(class(print) == "logical") & length(print) == 1 & any(is.na(print)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
219
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(print, collapse = " "), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
220
221
222
223
stop(tempo.cat)
}
if( ! is.null(fun.name)){
if( ! (class(fun.name) == "character" & length(fun.name) == 1)){
Gael  MILLOT's avatar
Gael MILLOT committed
224
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1: ", paste(fun.name, collapse = " "), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
stop(tempo.cat)
}
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
if(is.null(data.name)){
data.name <- deparse(substitute(data))
}
problem <- FALSE
text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER")
if( ! is.null(options)){
text <- ""
if( ! all(data %in% options)){
problem <- TRUE
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " PARAMETER MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", data.name, " ARE: ", paste(unique(data[ ! (data %in% options)]), collapse = " "))
}
if(all.options.in.data == TRUE){
if( ! all(options %in% data)){
problem <- TRUE
if(text == ""){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " PARAMETER MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", data.name, " ARE: ", unique(data[ ! (data %in% options)]))
}else{
text <- paste0(text, "\n", ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " PARAMETER MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", data.name, " ARE: ", unique(data[ ! (data %in% options)]))
}
}
}
if( ! is.null(length)){
if(length(data) != length){
problem <- TRUE
if(text == ""){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", length(data))
}else{
text <- paste0(text, "\n", ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", length(data))
}
}
}
if(text == ""){
text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER")
}
}
arg.names <- c("class", "typeof", "mode", "length")
if(is.null(options)){
for(i2 in 1:length(arg.names)){
if( ! is.null(get(arg.names[i2]))){
# script to execute
tempo.script <- '
Gael  MILLOT's avatar
Gael MILLOT committed
272
problem <- TRUE ;
Gael  MILLOT's avatar
Gael MILLOT committed
273
274
if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " PARAMETER MUST BE ") ;
Gael  MILLOT's avatar
Gael MILLOT committed
275
276
277
278
279
}else{
text <- paste0(text, " AND "); 
}
text <- paste0(text, toupper(arg.names[i2]), " ", get(arg.names[i2]))
'
Gael  MILLOT's avatar
Gael MILLOT committed
280
281
282
283
284
285
286
287
288
289
290
291
292
# end script to execute
if(typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & get(arg.names[i2]) == "integer") | (arg.names[i2] == "typeof" & get(arg.names[i2]) == "integer"))){
if(! all(data%%1 == 0)){ # to check integers (use %%, meaning the remaining of a division): see the precedent line
eval(parse(text = tempo.script)) # execute tempo.script
}
}else if(get(arg.names[i2]) != "vector" & eval(parse(text = paste0(arg.names[i2], "(data)"))) != get(arg.names[i2])){
eval(parse(text = tempo.script)) # execute tempo.script
}else if(arg.names[i2] == "class" & get(arg.names[i2]) == "vector" & ! (class(data) == "numeric" | class(data) == "integer" | class(data) == "character" | class(data) == "logical")){
eval(parse(text = tempo.script)) # execute tempo.script
}
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
293
if( ! is.null(prop)){
Gael  MILLOT's avatar
Gael MILLOT committed
294
295
296
297
298
299
300
301
302
303
304
if(prop == TRUE){
if(any(data < 0 | data > 1, na.rm = TRUE)){
problem <- TRUE
if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ")
}else{
text <- paste0(text, " AND ")
}
text <- paste0(text, "THE ", data.name, " PARAMETER MUST BE DECIMAL VALUES BETWEEN 0 AND 1")
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
305
}
306
307
308
if(all(class(data) %in% "expression")){
data <- as.character(data) # to evaluate the presence of NA
}
Gael  MILLOT's avatar
Gael MILLOT committed
309
if(na.contain == FALSE & any(is.na(data)) == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
310
311
312
313
314
315
316
problem <- TRUE
if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ")
}else{
text <- paste0(text, " AND ")
}
text <- paste0(text, "THE ", data.name, " PARAMETER CONTAINS NA WHILE NOT AUTHORIZED (na.contain ARGUMENT SET TO FALSE)")
Gael  MILLOT's avatar
Gael MILLOT committed
317
318
}
if(neg.values == FALSE){
Gael  MILLOT's avatar
Gael MILLOT committed
319
320
321
322
323
324
325
326
327
if(any(data < 0, na.rm = TRUE)){
problem <- TRUE
if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ")
}else{
text <- paste0(text, " AND ")
}
text <- paste0(text, "THE ", data.name, " PARAMETER MUST BE NON NEGATIVE NUMERIC VALUES")
}
Gael  MILLOT's avatar
Gael MILLOT committed
328
329
}
if(print == TRUE & problem == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
330
cat(paste0("\n\n================\n\n", text, "\n\n================\n\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
331
332
333
334
}
output <- list(problem = problem, text = text, param.name = data.name)
return(output)
}
Gael  MILLOT's avatar
Gael MILLOT committed
335
336


Gael  MILLOT's avatar
Gael MILLOT committed
337
######## fun_info() #### recover object information
Gael  MILLOT's avatar
Gael MILLOT committed
338
339
340


# Check OK: clear to go Apollo
Gael  MILLOT's avatar
Gael MILLOT committed
341
fun_info <- function(data){
Gael  MILLOT's avatar
Gael MILLOT committed
342
# AIM
Gael  MILLOT's avatar
Gael MILLOT committed
343
# provide a full description of an object
Gael  MILLOT's avatar
Gael MILLOT committed
344
345
346
347
348
349
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data: object to test
# RETURN
# a list containing the info
Gael  MILLOT's avatar
Gael MILLOT committed
350
# please, use names(fun_info()) and remove what can be too big for easy analysis
Gael  MILLOT's avatar
Gael MILLOT committed
351
# EXAMPLES
Gael  MILLOT's avatar
Gael MILLOT committed
352
353
354
# fun_info(data = 1:3)
# fun_info(data.frame(a = 1:2, b = ordered(factor(c("A", "B")))))
# fun_info(list(a = 1:3, b = ordered(factor(c("A", "B")))))
Gael  MILLOT's avatar
Gael MILLOT committed
355
356
357
358
359
360
361
362
363
# DEBUGGING
# data = NULL # for function debugging
# data = 1:3 # for function debugging
# data = matrix(1:3) # for function debugging
# data = data.frame(a = 1:2, b = c("A", "B")) # for function debugging
# data = factor(c("b", "a")) # for function debugging
# data = ordered(factor(c("b", "a"))) # for function debugging
# data = list(a = 1:3, b = factor(c("A", "B"))) # for function debugging
# data = list(a = 1:3, b = ordered(factor(c("A", "B")))) # for function debugging
Gael  MILLOT's avatar
Gael MILLOT committed
364
# function name: no need because no check and no message
Gael  MILLOT's avatar
Gael MILLOT committed
365
366
367
368
369
# argument checking
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
data.name <- deparse(substitute(data))
Gael  MILLOT's avatar
Gael MILLOT committed
370
output <- list("NAME" = data.name)
Gael  MILLOT's avatar
Gael MILLOT committed
371
372
tempo <- list("CLASS" = class(data))
output <- c(output, tempo)
Gael  MILLOT's avatar
Gael MILLOT committed
373
374
375
tempo <- list("TYPE" = typeof(data))
output <- c(output, tempo)
tempo <- list("HEAD" = head(data))
Gael  MILLOT's avatar
Gael MILLOT committed
376
377
output <- c(output, tempo)
if( ! is.null(data)){
Gael  MILLOT's avatar
Gael MILLOT committed
378
tempo <- list("TAIL" = tail(data))
Gael  MILLOT's avatar
Gael MILLOT committed
379
380
output <- c(output, tempo)
if( ! is.null(dim(data))){
Gael  MILLOT's avatar
Gael MILLOT committed
381
tempo <- list("DIMENSION" = dim(data))
Gael  MILLOT's avatar
Gael MILLOT committed
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
names(tempo[[1]]) <- c("NROW", "NCOL")
output <- c(output, tempo)
}
tempo <- list("SUMMARY" = summary(data))
output <- c(output, tempo)
}
if(all(class(data) == "data.frame" | class(data) == "matrix")){
tempo <- list("ROW_NAMES" = dimnames(data)[[1]])
output <- c(output, tempo)
tempo <- list("COLUM_NAMES" = dimnames(data)[[2]])
output <- c(output, tempo)
}
if(all(class(data) == "data.frame")){
tempo <- list("STRUCTURE" = ls.str(data))
output <- c(output, tempo)
tempo <- list("COLUMN_TYPE" = sapply(data, FUN = "typeof"))
if(any(sapply(data, FUN = "class") %in% "factor")){ # if an ordered factor is present, then sapply(data, FUN = "class") return a list but works with any(sapply(data, FUN = "class") %in% "factor") 
tempo.class <- sapply(data, FUN = "class")
if(any(unlist(tempo.class) %in% "ordered")){
tempo2 <- sapply(tempo.class, paste, collapse = " ") # paste the "ordered" factor" in "ordered factor"
}else{
tempo2 <- unlist(tempo.class)
}
tempo[["COLUMN_TYPE"]][grepl(x = tempo2, pattern = "factor")] <- tempo2[grepl(x = tempo2, pattern = "factor")]
}
output <- c(output, tempo)
}
if(all(class(data) == "list")){
tempo <- list("COMPARTMENT_NAMES" = names(data))
output <- c(output, tempo)
tempo <- list("COMPARTMENT_TYPE" = sapply(data, FUN = "typeof"))
if(any(unlist(sapply(data, FUN = "class")) %in% "factor")){ # if an ordered factor is present, then sapply(data, FUN = "class") return a list but works with any(sapply(data, FUN = "class") %in% "factor") 
tempo.class <- sapply(data, FUN = "class")
if(any(unlist(tempo.class) %in% "ordered")){
tempo2 <- sapply(tempo.class, paste, collapse = " ") # paste the "ordered" factor" in "ordered factor"
}else{
tempo2 <- unlist(tempo.class)
}
tempo[["COMPARTMENT_TYPE"]][grepl(x = tempo2, pattern = "factor")] <- tempo2[grepl(x = tempo2, pattern = "factor")]
}
output <- c(output, tempo)
}
return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
425
426
427
}


Gael  MILLOT's avatar
Gael MILLOT committed
428
######## fun_1d_comp() #### comparison of two 1D datasets (vectors, factors, 1D tables)
Gael  MILLOT's avatar
Gael MILLOT committed
429
430
431


# Check OK: clear to go Apollo
Gael  MILLOT's avatar
Gael MILLOT committed
432
fun_1d_comp <- function(data1, data2){
Gael  MILLOT's avatar
Gael MILLOT committed
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
# AIM
# compare two 1D datasets (vector of factor or 1D table) of the same class or not. Check and report in a list if the 2 datasets have:
# same class
# common elements
# common element names (except factors)
# common levels (factors only)
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data1: vector or factor or 1D table
# data2: vector or factor or 1D table
# RETURN
# a list containing:
# $same.class: logical. Are class identical?
# $class: class of the 2 datasets (NULL otherwise)
# $same.length: logical. Are number of elements identical?
# $length: number of elements in the 2 datasets (NULL otherwise)
# $same.levels: logical. Are levels identical? (NULL if data1 and data2 are not factors)
# $levels: levels of the 2 datasets if identical (NULL otherwise or NULL if data1 and data2 are not factors)
# $any.id.levels: logical. Is there any identical levels? (NULL if data1 and data2 are not factors)
# $same.levels.pos1: position, in data1, of the levels identical in data2 (NULL if data1 and data2 are not factors)
# $same.levels.pos2: position, in data2, of the levels identical in data1 (NULL if data1 and data2 are not factors)
# $common.levels: common levels between data1 and data2 (can be a subset of $levels or not). NULL if no common levels or if data1 and data2 are not factors
# $same.name: logical. Are element names identical ?
# $name: name of elements of the 2 datasets if identical (NULL otherwise)
# $any.id.name: logical. Is there any element names identical ?
# $same.name.pos1: position, in data1, of the element names identical in data2
# $same.name.pos2: position, in data2, of the elements names identical in data1
# $common.names: common element names between data1 and data2 (can be a subset of $name or not). NULL if no common element names
# $any.id.element: logical. is there any identical elements ?
# $same.element.pos1: position, in data1, of the elements identical in data2
# $same.element.pos2: position, in data2, of the elements identical in data1
# $common.elements: common elements between data1 and data2. NULL if no common elements
# $identical.object: logical. Are objects identical (kind of object, element names and content)?
# $identical.content: logical. Are content objects identical (identical elements excluding kind of object and element names)?
# EXAMPLES
Gael  MILLOT's avatar
Gael MILLOT committed
469
470
471
472
473
474
475
476
477
478
# obs1 = 1:5 ; obs2 = 1:5 ; names(obs1) <- LETTERS[1:5] ; names(obs2) <- LETTERS[1:5] ; fun_1d_comp(obs1, obs2)
# obs1 = 1:5 ; obs2 = 1:5 ; names(obs1) <- LETTERS[1:5] ; fun_1d_comp(obs1, obs2)
# obs1 = 1:5 ; obs2 = 3:6 ; names(obs1) <- LETTERS[1:5] ; names(obs2) <- LETTERS[1:4] ; fun_1d_comp(obs1, obs2)
# obs1 = factor(LETTERS[1:5]) ; obs2 = factor(LETTERS[1:5]) ; fun_1d_comp(obs1, obs2)
# obs1 = factor(LETTERS[1:5]) ; obs2 = factor(LETTERS[10:11]) ; fun_1d_comp(obs1, obs2)
# obs1 = factor(LETTERS[1:5]) ; obs2 = factor(LETTERS[4:7]) ; fun_1d_comp(obs1, obs2)
# obs1 = 1:5 ; obs2 = factor(LETTERS[1:5]) ; fun_1d_comp(obs1, obs2)
# 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)
Gael  MILLOT's avatar
Gael MILLOT committed
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
# DEBUGGING
# data1 = 1:5 ; data2 = 1:5 ; names(data1) <- LETTERS[1:5] ; names(data2) <- LETTERS[1:5] # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# argument checking
if( ! any(class(data1) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}else if(all(class(data1) %in% "table")){
if(length(dim(data1)) > 1){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}
}
if( ! any(class(data2) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}else if(all(class(data2) %in% "table")){
if(length(dim(data2)) > 1){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
stop(tempo.cat)
}
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
same.class <- NULL
class <- NULL
same.length <- NULL
length <- NULL
same.levels <- NULL
levels <- NULL
any.id.levels <- NULL
same.levels.pos1 <- NULL
same.levels.pos2 <- NULL
common.levels <- NULL
same.name <- NULL
name <- NULL
any.id.name <- NULL
same.name.pos1 <- NULL
same.name.pos2 <- NULL
common.names <- NULL
any.id.element <- NULL
same.element.pos1 <- NULL
same.element.pos2 <- NULL
common.elements <- NULL
identical.object <- NULL
identical.content <- NULL
if(identical(data1, data2)){
same.class <- TRUE
class <- class(data1)
same.length <- TRUE
length <- length(data1)
if(any(class(data1) %in% "factor")){
same.levels <- TRUE
levels <- levels(data1)
any.id.levels <- TRUE
same.levels.pos1 <- 1:length(levels(data1))
same.levels.pos2 <- 1:length(levels(data2))
common.levels <- levels(data1)
}
if( ! is.null(names(data1))){
same.name <- TRUE
name <- names(data1)
any.id.name <- TRUE
same.name.pos1 <- 1:length(data1)
same.name.pos2 <- 1:length(data2)
common.names <- names(data1)
}
any.id.element <- TRUE
same.element.pos1 <- 1:length(data1)
same.element.pos2 <- 1:length(data2)
common.elements <- data1
identical.object <- TRUE
identical.content <- TRUE
}else{
identical.object <- FALSE
if( ! identical(class(data1), class(data2))){
same.class <- FALSE
}else{
same.class <- TRUE
class <- class(data1)
}
if( ! identical(length(data1), length(data2))){
same.length<- FALSE
}else{
same.length<- TRUE
length <- length(data1)
}
if(any(class(data1) %in% "factor") & any(class(data2) %in% "factor")){
if( ! identical(levels(data1), levels(data2))){
same.levels <- FALSE
}else{
same.levels <- TRUE
levels <- levels(data1)
}
any.id.levels <- FALSE
if(any(levels(data1) %in% levels(data2))){
any.id.levels <- TRUE
same.levels.pos1 <- which(levels(data1) %in% levels(data2))
}
if(any(levels(data2) %in% levels(data1))){
any.id.levels <- TRUE
same.levels.pos2 <- which(levels(data2) %in% levels(data1))
}
if(any.id.levels == TRUE){
common.levels <- unique(c(levels(data1)[same.levels.pos1], levels(data2)[same.levels.pos2]))
}
}
if(any(class(data1) %in% "factor")){ # to compare content
data1 <- as.character(data1)
}
if(any(class(data2) %in% "factor")){ # to compare content
data2 <- as.character(data2)
}
if( ! (is.null(names(data1)) & is.null(names(data2)))){
if( ! identical(names(data1), names(data2))){
same.name <- FALSE
}else{
same.name <- TRUE
name <- names(data1)
}
any.id.name <- FALSE
if(any(names(data1) %in% names(data2))){
any.id.name <- TRUE
same.name.pos1 <- which(names(data1) %in% names(data2))
}
if(any(names(data2) %in% names(data1))){
any.id.name <- TRUE
same.name.pos2 <- which(names(data2) %in% names(data1))
}
if(any.id.name == TRUE){
common.names <- unique(c(names(data1)[same.name.pos1], names(data2)[same.name.pos2]))
}
}
any.id.element <- FALSE
if(any(data1 %in% data2)){
any.id.element <- TRUE
same.element.pos1 <- which(data1 %in% data2)
}
if(any(data2 %in% data1)){
any.id.element <- TRUE
same.element.pos2 <- which(data2 %in% data1)
}
if(any.id.element == TRUE){
common.elements <- unique(c(data1[same.element.pos1], data2[same.element.pos2]))
}
if(same.length == TRUE & ! all(is.null(same.element.pos1), is.null(same.element.pos2))){
names(same.element.pos1) <- NULL
names(same.element.pos2) <- NULL
if(identical(same.element.pos1, same.element.pos2)){
identical.content <- TRUE
}else{
identical.content <- FALSE
}
}else{
identical.content <- FALSE
}
}
output <- list(same.class = same.class, class = class, same.length = same.length, length = length, same.levels = same.levels, levels = levels, any.id.levels = any.id.levels, same.levels.pos1 = same.levels.pos1, same.levels.pos2 = same.levels.pos2, common.levels = common.levels, same.name = same.name, name = name, any.id.name = any.id.name, same.name.pos1 = same.name.pos1, same.name.pos2 = same.name.pos2, common.names = common.names, any.id.element = any.id.element, same.element.pos1 = same.element.pos1, same.element.pos2 = same.element.pos2, common.elements = common.elements, identical.object = identical.object, identical.content = identical.content)
return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
641
642
643
}


Gael  MILLOT's avatar
Gael MILLOT committed
644
######## fun_2d_comp() #### comparison of two 2D datasets (row & col names, dimensions, etc.)
Gael  MILLOT's avatar
Gael MILLOT committed
645
646
647


# Check OK: clear to go Apollo
Gael  MILLOT's avatar
Gael MILLOT committed
648
fun_2d_comp <- function(data1, data2){
Gael  MILLOT's avatar
Gael MILLOT committed
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
# AIM
# compare two 2D datasets of the same class or not. Check and report in a list if the 2 datasets have:
# same class
# common row names
# common column names
# same row number
# same column number
# potential identical rows between the 2 datasets
# potential identical columns between the 2 datasets
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data1: matrix, data frame or table
# data2: matrix, data frame or table
# RETURN
# a list containing:
# $same.class: logical. Are class identical ?
# $class: classes of the 2 datasets (NULL otherwise)
# $same.dim: logical. Are dimension identical ?
# $dim: dimension of the 2 datasets (NULL otherwise)
# $same.row.nb: logical. Are number of rows identical ?
# $row.nb: nb of rows of the 2 datasets if identical (NULL otherwise)
# $same.col.nb: logical. Are number of columns identical ?
# $col.nb: nb of columns of the 2 datasets if identical (NULL otherwise)
# $same.row.name: logical. Are row names identical ? NULL if no row names in the two 2D datasets
# $row.name: name of rows of the 2 datasets if identical (NULL otherwise)
# $any.id.row.name: logical. Is there any row names identical ? NULL if no row names in the two 2D datasets
# $same.row.name.pos1: position, in data1, of the row names identical in data2
# $same.row.name.pos2: position, in data2, of the row names identical in data1
# $common.row.names: common row names between data1 and data2 (can be a subset of $name or not). NULL if no common row names
# $same.col.name: logical. Are column names identical ? NULL if no col names in the two 2D datasets
# $col.name: name of columns of the 2 datasets if identical (NULL otherwise)
# $any.id.col.name: logical. Is there any column names identical ? NULL if no col names in the two 2D datasets
# $same.col.name.pos1: position, in data1, of the column names identical in data2
# $same.col.name.pos2: position, in data2, of the column names identical in data1
# $common.col.names: common column names between data1 and data2 (can be a subset of $name or not). NULL if no common column names
# $any.id.row: logical. is there identical rows (not considering row names) ?
# $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
Gael  MILLOT's avatar
Gael MILLOT committed
694
695
696
697
# 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(101:110, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; obs2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; obs1 ; obs2 ; fun_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)
Gael  MILLOT's avatar
Gael MILLOT committed
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
# DEBUGGING
# data1 = matrix(1:10, ncol = 5) ; data2 = matrix(1:10, ncol = 5) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5) # for function debugging
# data1 = matrix(1:15, byrow = TRUE, ncol = 5, dimnames = list(letters[1:3], LETTERS[1:5])) ; data2 = matrix(1:10, byrow = TRUE, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:15, ncol = 5, dimnames = list(letters[1:3], LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:15, ncol = 5, dimnames = list(paste0("A", letters[1:3]), LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:15, ncol = 5, dimnames = list(letters[1:3], LETTERS[1:5])) ; data2 = matrix(1:12, ncol = 4, dimnames = list(letters[1:3], LETTERS[1:4])) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(101:110, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = data.frame(a = 1:3, b= letters[1:3], row.names = LETTERS[1:3]) ; data2 = data.frame(A = 1:3, B= letters[1:3]) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = as.data.frame(matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5]))) # for function debugging
# data1 = matrix(1:10, byrow = TRUE, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(c(1:5, 101:105, 6:10), byrow = TRUE, ncol = 5, dimnames = list(c("a", "z", "b"), c(LETTERS[1:2], "k", LETTERS[5:4]))) # for function debugging
# data1 = table(Exp1 = c("A", "A", "A", "B", "B", "B"), Exp2 = c("A1", "B1", "A1", "C1", "C1", "B1")) ; data2 = data.frame(A = 1:3, B= letters[1:3]) # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# argument checking
if( ! any(class(data1) %in% c("matrix", "data.frame", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat)
}
if( ! any(class(data2) %in% c("matrix", "data.frame", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat)
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
same.class <- NULL
class <- NULL
same.dim <- NULL
dim <- NULL
same.row.nb <- NULL
row.nb <- NULL
same.col.nb <- NULL
col.nb <- NULL
same.row.name <- NULL
row.name <- NULL
any.id.row.name <- NULL
same.row.name.pos1 <- NULL
same.row.name.pos2 <- NULL
common.row.names <- NULL
same.col.name <- NULL
any.id.col.name <- NULL
same.col.name.pos1 <- NULL
same.col.name.pos2 <- NULL
common.col.names <- NULL
col.name <- NULL
any.id.row <- NULL
same.row.pos1 <- NULL
same.row.pos2 <- NULL
any.id.col <- NULL
same.col.pos1 <- NULL
same.col.pos2 <- NULL
identical.object <- NULL
identical.content <- NULL
if(identical(data1, data2) & any(class(data1) %in% c("matrix", "data.frame", "table"))){
same.class <- TRUE
class <- class(data1)
same.dim <- TRUE
dim <- dim(data1)
same.row.nb <- TRUE
row.nb <- nrow(data1)
same.col.nb <- TRUE
col.nb <- ncol(data1)
same.row.name <- TRUE
row.name <- dimnames(data1)[[1]]
any.id.row.name <- TRUE
same.row.name.pos1 <- 1:row.nb
same.row.name.pos2 <- 1:row.nb
common.row.names <- dimnames(data1)[[1]]
same.col.name <- TRUE
col.name <- dimnames(data1)[[2]]
any.id.col.name <- TRUE
same.col.name.pos1 <- 1:col.nb
same.col.name.pos2 <- 1:col.nb
common.col.names <- dimnames(data1)[[2]]
any.id.row <- TRUE
same.row.pos1 <- 1:row.nb
same.row.pos2 <- 1:row.nb
any.id.col <- TRUE
same.col.pos1 <- 1:col.nb
same.col.pos2 <- 1:col.nb
identical.object <- TRUE
identical.content <- TRUE
}else{
identical.object <- FALSE
if(all(class(data1) == "table") & length(dim(data1)) == 1){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT IS A 1D TABLE. USE THE 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 IN ", function.name, ": 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 IN ", function.name, ": THE data1 AND data2 ARGUMENTS MUST BE EITHER MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat)
}else{
same.class <- TRUE
class <- class(data1)
}
if( ! identical(dim(data1), dim(data2))){
same.dim <- FALSE
}else{
same.dim <- TRUE
dim <- dim(data1)
}
if( ! identical(nrow(data1), nrow(data2))){
same.row.nb <- FALSE
}else{
same.row.nb <- TRUE
row.nb <- nrow(data1)
}
if( ! identical(ncol(data1), ncol(data2))){
same.col.nb <- FALSE
}else{
same.col.nb <- TRUE
col.nb <- ncol(data1)
}
# row and col names
if(is.null(dimnames(data1)) & is.null(dimnames(data2))){
same.row.name <- NULL
same.col.name <- NULL
# row and col names remain NULL
}else if((is.null(dimnames(data1)) & ! is.null(dimnames(data2))) | ( ! is.null(dimnames(data1)) & is.null(dimnames(data2)))){
same.row.name <- FALSE
same.col.name <- FALSE
# row and col names remain NULL
}else{
if( ! identical(dimnames(data1)[[1]], dimnames(data2)[[1]])){
same.row.name <- FALSE
# row names remain NULL
}else{
same.row.name <- TRUE
row.name <- dimnames(data1)[[1]]
}
# row names
any.id.row.name <- FALSE
if(any(dimnames(data1)[[1]] %in% dimnames(data2)[[1]])){
any.id.row.name <- TRUE
same.row.name.pos1 <- which(dimnames(data1)[[1]] %in% dimnames(data2)[[1]])
}
if(any(dimnames(data2)[[1]] %in% dimnames(data1)[[1]])){
any.id.row.name <- TRUE
same.row.name.pos2 <- which(dimnames(data2)[[1]] %in% dimnames(data1)[[1]])
}
if(any.id.row.name == TRUE){
common.row.names <- unique(c(dimnames(data1)[[1]][same.row.name.pos1], dimnames(data2)[[1]][same.row.name.pos2]))
}
# col names
any.id.col.name <- FALSE
if(any(dimnames(data1)[[2]] %in% dimnames(data2)[[2]])){
any.id.col.name <- TRUE
same.col.name.pos1 <- which(dimnames(data1)[[2]] %in% dimnames(data2)[[2]])
}
if(any(dimnames(data2)[[2]] %in% dimnames(data1)[[2]])){
any.id.col.name <- TRUE
same.col.name.pos2 <- which(dimnames(data2)[[2]] %in% dimnames(data1)[[2]])
}
if(any.id.col.name == TRUE){
common.col.names <- unique(c(dimnames(data1)[[2]][same.col.name.pos1], dimnames(data2)[[2]][same.col.name.pos2]))
}
if( ! identical(dimnames(data1)[[2]], dimnames(data2)[[2]])){
same.col.name <- FALSE
# col names remain NULL
}else{
same.col.name <- TRUE
col.name <- dimnames(data1)[[2]]
}
}
# identical row and col content
if(all(class(data1) == "table")){
as.data.frame(matrix(data1, ncol = ncol(data1)), stringsAsFactors = FALSE)
}else if(all(class(data1) == "matrix")){
data1 <- as.data.frame(data1, stringsAsFactors = FALSE)
}else if(all(class(data1) == "data.frame")){
data1 <- data.frame(lapply(data1, as.character), stringsAsFactors=FALSE)
}
if(all(class(data2) == "table")){
as.data.frame(matrix(data2, ncol = ncol(data2)), stringsAsFactors = FALSE)
}else if(all(class(data2) == "matrix")){
data2 <- as.data.frame(data2, stringsAsFactors = FALSE)
}else if(all(class(data2) == "data.frame")){
data2 <- data.frame(lapply(data2, as.character), stringsAsFactors=FALSE)
}
row.names(data1) <- paste0("A", 1:nrow(data1))
row.names(data2) <- paste0("A", 1:nrow(data2))
if(same.col.nb == TRUE){ # because if not the same col nb, the row cannot be identical
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))){
same.row.pos1 <- NULL
}else{
same.row.pos1 <- same.row.pos1[ ! is.na(same.row.pos1)]
any.id.row <- TRUE
}
if(all(is.na(same.row.pos2))){
same.row.pos2 <- NULL
}else{
same.row.pos2 <- same.row.pos2[ ! is.na(same.row.pos2)]
any.id.row <- TRUE
}
if(is.null(same.row.pos1) & is.null(same.row.pos2)){
any.id.row <- FALSE
}
}else{
any.id.row <- FALSE
# same.row.pos1 and 2 remain NULL
}
if(same.row.nb == TRUE){ # because if not the same row nb, the col cannot be identical
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))){
same.col.pos1 <- NULL
}else{
same.col.pos1 <- same.col.pos1[ ! is.na(same.col.pos1)]
any.id.col <- TRUE
}
if(all(is.na(same.col.pos2))){
same.col.pos2 <- NULL
}else{
same.col.pos2 <- same.col.pos2[ ! is.na(same.col.pos2)]
any.id.col <- TRUE
}
if(is.null(same.col.pos1) & is.null(same.col.pos2)){
any.id.col <- FALSE
}
}else{
any.id.col <- FALSE
# same.col.pos1 and 2 remain NULL
}
if(same.dim == TRUE & ! all(is.null(same.row.pos1), is.null(same.row.pos2), is.null(same.col.pos1), is.null(same.col.pos2))){ # same.dim == TRUE means that same.row.nb == TRUE and same.col.nb == TRUE, meaning that row.nb != NULL and col.nb != NULL. Thus, no need to include these checkings
if(identical(same.row.pos1, 1:row.nb) & identical(same.row.pos2, 1:row.nb) & identical(same.col.pos1, 1:col.nb) & identical(same.col.pos2, 1:col.nb)){
identical.content <- TRUE
}else{
identical.content <- FALSE
}
}else{
identical.content <- FALSE
}
}
output <- list(same.class = same.class, class = class, same.dim = same.dim, dim = dim, same.row.nb = same.row.nb, row.nb = row.nb, same.col.nb = same.col.nb , col.nb = col.nb, same.row.name = same.row.name, row.name = row.name, any.id.row.name = any.id.row.name, same.row.name.pos1 = same.row.name.pos1, same.row.name.pos2 = same.row.name.pos2, common.row.names = common.row.names, same.col.name = same.col.name, col.name = col.name,any.id.col.name = any.id.col.name, same.col.name.pos1 = same.col.name.pos1, same.col.name.pos2 = same.col.name.pos2, common.col.names = common.col.names, any.id.row = any.id.row, same.row.pos1 = same.row.pos1, same.row.pos2 = same.row.pos2, any.id.col = any.id.col, same.col.pos1 = same.col.pos1, same.col.pos2 = same.col.pos2, identical.object = identical.object, identical.content = identical.content)
return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
948
949
950
}


Gael  MILLOT's avatar
Gael MILLOT committed
951
######## fun_2d_head() #### head of the left or right of big 2D objects
Gael  MILLOT's avatar
Gael MILLOT committed
952
953
954


# Check OK: clear to go Apollo
Gael  MILLOT's avatar
Gael MILLOT committed
955
fun_2d_head <- function(data1, n = 10, side = "l"){
Gael  MILLOT's avatar
Gael MILLOT committed
956
957
958
# AIM
# display the head of the left or right of big 2D objects
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
Gael  MILLOT's avatar
Gael MILLOT committed
959
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
960
961
962
963
964
965
966
# ARGUMENTS
# data1: matrix, data frame or table
# n: number of dimension to print (10 means 10 rows and columns)
# side: either "l" or "r" for the left or right side of the 2D object
# RETURN
# the head
# EXAMPLES
Gael  MILLOT's avatar
Gael MILLOT committed
967
968
# obs1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:6], LETTERS[1:5])) ; obs1 ; fun_2d_head(obs1, 3)
# obs1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:6], LETTERS[1:5])) ; obs1 ; fun_2d_head(obs1, 3, "right")
Gael  MILLOT's avatar
Gael MILLOT committed
969
970
971
972
973
974
975
# DEBUGGING
# data1 = matrix(1:30, ncol = 5) # for function debugging
# data1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
Gael  MILLOT's avatar
Gael MILLOT committed
976
977
if(length(find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
978
979
980
981
stop(tempo.cat)
}
# end required function checking
# argument checking
Gael  MILLOT's avatar
Gael MILLOT committed
982
# argument checking without fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
983
984
985
986
if( ! any(class(data1) %in% c("matrix", "data.frame", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat)
}
Gael  MILLOT's avatar
Gael MILLOT committed
987
988
# end argument checking without fun_check()
# argument checking with fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
989
990
991
arg.check <- NULL # for function debbuging
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
Gael  MILLOT's avatar
Gael MILLOT committed
992
993
tempo <- fun_check(data = n, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = side, options = c("l", "r"), length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
994
if(any(arg.check) == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
995
stop() # nothing else because print = TRUE by default in fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
996
}
Gael  MILLOT's avatar
Gael MILLOT committed
997
998
# end argument checking with fun_check()
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
999
1000
# end argument checking
# main code