cute_little_R_functions.R 172 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
1
2
################################################################
##                                                            ##
Gael  MILLOT's avatar
Gael MILLOT committed
3
##     CUTE LITTLE R FUNCTIONS v4.2.0                         ##
Gael  MILLOT's avatar
Gael MILLOT committed
4
5
6
7
8
9
10
11
12
13
14
15
16
17
##                                                            ##
##     Gael A. Millot                                         ##
##                                                            ##
##     Compatible with R v3.5.1                               ##
##                                                            ##
################################################################





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


Gael  MILLOT's avatar
Gael MILLOT committed
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
################ 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
Gael  MILLOT's avatar
Gael MILLOT committed
39
40
41
42
43
44
45
46
47
48
49
50
51


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


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


######## fun_param_check() #### Checking class, type, length, etc. of objects


# 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){
Gael  MILLOT's avatar
Gael MILLOT committed
52
    # AIM:
Gael  MILLOT's avatar
Gael MILLOT committed
53
54
55
56
57
    # 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
Gael  MILLOT's avatar
Gael MILLOT committed
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
    # REQUIRED FUNCTIONS
    # 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
    # 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?
    # RETURN
    # a list containing:
    # $problem: logical. Is there any problem detected ?
    # $text: the problem detected
    # $param.name: name of the checked parameter
    # EXAMPLES
    # test <- 1:3 ; fun_param_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_param_check(data = test, print = TRUE, class = "numeric", typeof = NULL, double.as.integer.allowed = FALSE)
    # DEBUGGING
    # data = 1:3 ; data.name = NULL ; print = TRUE; options = NULL ; all.options.in.data = FALSE ; class = "numeric" ; typeof = NULL ; mode = NULL ; prop = NULL ; double.as.integer.allowed = TRUE ; length = NULL # for function debugging
    # argument checking
Gael  MILLOT's avatar
Gael MILLOT committed
85
    # 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))
Gael  MILLOT's avatar
Gael MILLOT committed
86
87
    if( ! is.null(data.name)){
        if( ! (length(data.name) == 1 & class(data.name) == "character")){
Gael  MILLOT's avatar
Gael MILLOT committed
88
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
89
90
91
92
            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
93
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
94
95
96
        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
97
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
98
99
100
        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
101
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
102
103
104
        stop(tempo.cat)
    }
    if(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){
Gael  MILLOT's avatar
Gael MILLOT committed
105
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
106
107
108
109
        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)
Gael  MILLOT's avatar
Gael MILLOT committed
110
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
111
112
            stop(tempo.cat)
        }
Gael  MILLOT's avatar
Gael MILLOT committed
113
114
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
115
116
117
118
119
            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
120
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
121
122
123
            stop(tempo.cat)
        }
        if(neg.values == FALSE & ! typeof %in% c("double", "integer")){
Gael  MILLOT's avatar
Gael MILLOT committed
124
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
125
126
127
128
129
            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
130
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
131
132
133
            stop(tempo.cat)
        }
        if(neg.values == FALSE & mode != "numeric"){
Gael  MILLOT's avatar
Gael MILLOT committed
134
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
135
136
137
138
139
            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
140
            tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): length ARGUMENT MUST BE A SINGLE INTEGER VALUE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
141
142
143
144
145
            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
146
            tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): prop ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
147
148
149
150
            stop(tempo.cat)
        }else if(prop == TRUE){
            if( ! is.null(class)){
                if( ! any(class %in% c("numeric", "matrix", "array", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
151
                    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")
Gael  MILLOT's avatar
Gael MILLOT committed
152
153
154
155
156
                    stop(tempo.cat)
                }
            }
            if( ! is.null(mode)){
                if(mode != "numeric"){
Gael  MILLOT's avatar
Gael MILLOT committed
157
                    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")
Gael  MILLOT's avatar
Gael MILLOT committed
158
159
160
161
162
                    stop(tempo.cat)
                }
            }
            if( ! is.null(typeof)){
                if(typeof != "double"){
Gael  MILLOT's avatar
Gael MILLOT committed
163
                    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")
Gael  MILLOT's avatar
Gael MILLOT committed
164
165
166
167
168
169
                    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
170
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
171
172
173
        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
174
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
175
176
177
        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
178
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
179
180
181
        stop(tempo.cat)
    }
    if( ! (all(class(print) == "logical") & length(print) == 1 & any(is.na(print)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
182
        tempo.cat <- paste0("\n\n================\n\nERROR IN fun_param_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
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
272
273
274
275
276
277
278
279
280
281
282
283
        stop(tempo.cat)
    }
    # end argument checking
    if(is.null(data.name)){
        data.name <- deparse(substitute(data))
    }
    problem <- FALSE
    text <- paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER")
    if( ! is.null(options)){
        text <- ""
        if( ! all(data %in% options)){
            problem <- TRUE
            text <- paste0("PROBLEM: 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("PROBLEM: 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, "\nPROBLEM: 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("PROBLEM: THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", length(data))
                }else{
                    text <- paste0(text, "\nPROBLEM: THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", length(data))
                }
            }
        }
        if(text == ""){
            text <- paste0("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 <- '
                problem <- TRUE ;
                if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
                text <- paste0("PROBLEM: THE ", data.name, " PARAMETER MUST BE ") ;
                }else{
                text <- paste0(text, " AND "); 
                }
                text <- paste0(text, toupper(arg.names[i2]), " ", get(arg.names[i2]))
                '
                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(eval(parse(text = paste0(arg.names[i2], "(data)"))) != get(arg.names[i2])){
                    eval(parse(text = tempo.script)) # execute tempo.script
                }
            }
    }
        }
    if( ! is.null(prop)){
        if(prop == TRUE){
            if(any(data < 0 | data > 1, na.rm = TRUE)){
                problem <- TRUE
                if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
                    text <- paste0("PROBLEM: ")
                }else{
                    text <- paste0(text, " AND ")
                }
                text <- paste0(text, "THE ", data.name, " PARAMETER MUST BE DECIMAL VALUES BETWEEN 0 AND 1")
            }
        }
    }
    if(na.contain == FALSE & any(is.na(data)) == TRUE){
        problem <- TRUE
        if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
            text <- paste0("PROBLEM: ")
        }else{
            text <- paste0(text, " AND ")
        }
        text <- paste0(text, "THE ", data.name, " PARAMETER CONTAINS NA WHILE NOT AUTHORIZED (na.contain ARGUMENT SET TO FALSE)")
    }
    if(neg.values == FALSE){
        if(any(data < 0, na.rm = TRUE)){
            problem <- TRUE
            if(identical(text, paste0("NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
                text <- paste0("PROBLEM: ")
            }else{
                text <- paste0(text, " AND ")
            }
            text <- paste0(text, "THE ", data.name, " PARAMETER MUST NON NEGATIVE NUMERIC VALUES")
        }
    }
    if(print == TRUE & problem == TRUE){
        cat(paste0("\n\n================\n\n", text, "\n\n================\n\n"))
    }
    output <- list(problem = problem, text = text, param.name = data.name)
    return(output)
    }
Gael  MILLOT's avatar
Gael MILLOT committed
284
285
286
287
288
289
290


######## fun_object_info() #### Recovering object information


# Check OK: clear to go Apollo
fun_object_info <- function(data){
Gael  MILLOT's avatar
Gael MILLOT committed
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
    # AIM:
    # provide a full description of the object
    # REQUIRED FUNCTIONS
    # none
    # ARGUMENTS
    # data: object to test
    # RETURN
    # a list containing the info
    # EXAMPLES
    # fun_object_info(data = 1:3)
    # DEBUGGING
    # data = NULL # for function debugging
    # data = 1:3 # for function debugging
    # data = matrix(1:3) # for function debugging
    # data = data.frame(a = 1:3) # for function debugging
    # data = factor(1:3) # for function debugging
    # data = list(1:3) # for function debugging
    # argument checking
Gael  MILLOT's avatar
Gael MILLOT committed
309
    # 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()
Gael  MILLOT's avatar
Gael MILLOT committed
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
    # end argument checking
    data.name <- deparse(substitute(data))
    output <- list("FILE_NAME" = data.name)
    tempo <- list("FILE_HEAD" = head(data))
    output <- c(output, tempo)
    if( ! is.null(data)){
        tempo <- list("FILE_TAIL" = tail(data))
        output <- c(output, tempo)
        if( ! is.null(dim(data))){
            tempo <- list("FILE_DIMENSION" = dim(data))
            names(tempo[[1]]) <- c("NROW", "NCOL")
            output <- c(output, tempo)
        }
        tempo <- list("SUMMARY" = summary(data))
        output <- c(output, tempo)
    }
    if(class(data) == "data.frame" | class(data) == "matrix"){
        tempo <- list("COLUM_NAMES" = names(data))
        output <- c(output, tempo)
    }
    if(class(data) == "data.frame"){
        tempo <- list("STRUCTURE" = ls.str(data))
        output <- c(output, tempo)
        tempo <- list("COLUMN_TYPE" = sapply(data, FUN = "typeof"))
        output <- c(output, tempo)
    }
    if(class(data) == "list"){
        tempo <- list("COMPARTMENT_NAMES" = names(data))
        output <- c(output, tempo)
    }
    return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
341
342
343
344
345
346
347
348
}


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


# Check OK: clear to go Apollo
fun_1D_comp <- function(data1, data2){
Gael  MILLOT's avatar
Gael MILLOT committed
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
    # 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
    # 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
    # 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)
    # DEBUGGING
    # data1 = 1:5 ; data2 = 1:5 ; names(data1) <- LETTERS[1:5] ; names(data2) <- LETTERS[1:5] # for function debugging
    # argument checking
Gael  MILLOT's avatar
Gael MILLOT committed
398
    # 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()
Gael  MILLOT's avatar
Gael MILLOT committed
399
    if( ! any(class(data1) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
400
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
401
402
403
        stop(tempo.cat)
    }else if(all(class(data1) %in% "table")){
        if(length(dim(data1)) > 1){
Gael  MILLOT's avatar
Gael MILLOT committed
404
            tempo.cat <- paste0("\n\n================\n\nERROR IN fun_1D_comp(): THE data1 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
405
406
407
408
            stop(tempo.cat)
        }
    }
    if( ! any(class(data2) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
409
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
410
411
412
        stop(tempo.cat)
    }else if(all(class(data2) %in% "table")){
        if(length(dim(data2)) > 1){
Gael  MILLOT's avatar
Gael MILLOT committed
413
            tempo.cat <- paste0("\n\n================\n\nERROR IN fun_1D_comp(): THE data2 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
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
469
470
471
472
473
474
475
476
477
478
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
            stop(tempo.cat)
        }
    }
    # end argument checking
    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
553
554
555
556
557
558
559
560
}


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


# Check OK: clear to go Apollo
fun_2D_comp <- function(data1, data2){
Gael  MILLOT's avatar
Gael MILLOT committed
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
    # 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
    # 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)
Gael  MILLOT's avatar
Gael MILLOT committed
585
    # $same.row.name: logical. Are row names identical ? NULL if no row names in the two 2D datasets
Gael  MILLOT's avatar
Gael MILLOT committed
586
    # $row.name: name of rows of the 2 datasets if identical (NULL otherwise)
Gael  MILLOT's avatar
Gael MILLOT committed
587
588
589
590
591
    # $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
Gael  MILLOT's avatar
Gael MILLOT committed
592
    # $col.name: name of columns of the 2 datasets if identical (NULL otherwise)
Gael  MILLOT's avatar
Gael MILLOT committed
593
594
595
596
597
598
599
600
601
602
    # $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)
Gael  MILLOT's avatar
Gael MILLOT committed
603
604
605
    # $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
606
    # 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)
Gael  MILLOT's avatar
Gael MILLOT committed
607
    # 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)
Gael  MILLOT's avatar
Gael MILLOT committed
608
609
    # 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
610
611
612
    # 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
Gael  MILLOT's avatar
Gael MILLOT committed
613
    # data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5) # for function debugging
Gael  MILLOT's avatar
Gael MILLOT committed
614
615
616
617
618
619
620
    # 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
Gael  MILLOT's avatar
Gael MILLOT committed
621
    # 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
Gael  MILLOT's avatar
Gael MILLOT committed
622
623
    # 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
Gael  MILLOT's avatar
Gael MILLOT committed
624
    # 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()
Gael  MILLOT's avatar
Gael MILLOT committed
625
    if( ! any(class(data1) %in% c("matrix", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
626
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
627
628
629
        stop(tempo.cat)
    }
    if( ! any(class(data2) %in% c("matrix", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
630
        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")
Gael  MILLOT's avatar
Gael MILLOT committed
631
632
633
634
635
636
637
638
639
640
641
642
643
        stop(tempo.cat)
    }
    # end argument checking
    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
Gael  MILLOT's avatar
Gael MILLOT committed
644
645
646
647
    any.id.row.name <- NULL
    same.row.name.pos1 <- NULL
    same.row.name.pos2 <- NULL
    common.row.names <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
648
    same.col.name <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
649
650
651
652
    any.id.col.name <- NULL
    same.col.name.pos1 <- NULL
    same.col.name.pos2 <- NULL
    common.col.names <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
    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]]
Gael  MILLOT's avatar
Gael MILLOT committed
673
674
675
        any.id.row.name <- TRUE
        same.row.name.pos1 <- 1:row.nb
        same.row.name.pos2 <- 1:row.nb
Gael  MILLOT's avatar
Gael MILLOT committed
676
        common.row.names <- dimnames(data1)[[1]]
Gael  MILLOT's avatar
Gael MILLOT committed
677
678
        same.col.name <- TRUE
        col.name <- dimnames(data1)[[2]]
Gael  MILLOT's avatar
Gael MILLOT committed
679
680
681
        any.id.col.name <- TRUE
        same.col.name.pos1 <- 1:col.nb
        same.col.name.pos2 <- 1:col.nb
Gael  MILLOT's avatar
Gael MILLOT committed
682
        common.col.names <- dimnames(data1)[[2]]
Gael  MILLOT's avatar
Gael MILLOT committed
683
684
685
686
687
688
689
690
691
692
693
        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){
Gael  MILLOT's avatar
Gael MILLOT committed
694
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
695
696
697
            stop(tempo.cat)
        }
        if(all(class(data2) == "table") & length(dim(data2)) == 1){
Gael  MILLOT's avatar
Gael MILLOT committed
698
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
699
700
701
702
703
            stop(tempo.cat)
        }
        if( ! identical(class(data1), class(data2))){
            same.class <- FALSE
        }else if( ! any(class(data1) %in% c("matrix", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
704
            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")
Gael  MILLOT's avatar
Gael MILLOT committed
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
            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))){
Gael  MILLOT's avatar
Gael MILLOT committed
730
731
            same.row.name <- NULL
            same.col.name <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
732
733
734
735
736
737
738
739
740
741
742
743
744
            # 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]]
            }
Gael  MILLOT's avatar
Gael MILLOT committed
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
            # 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]))
            }
Gael  MILLOT's avatar
Gael MILLOT committed
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
            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
Gael  MILLOT's avatar
Gael MILLOT committed
797
798
            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)))
Gael  MILLOT's avatar
Gael MILLOT committed
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
            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
Gael  MILLOT's avatar
Gael MILLOT committed
821
822
            same.col.pos1 <- which(c(data1) %in% c(data2))
            same.col.pos2 <- which(c(data2) %in% c(data1))
Gael  MILLOT's avatar
Gael MILLOT committed
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
            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
Gael  MILLOT's avatar
Gael MILLOT committed
847
848
            }else{
                identical.content <- FALSE
Gael  MILLOT's avatar
Gael MILLOT committed
849
850
851
852
853
            }
        }else{
            identical.content <- FALSE
        }
    }
Gael  MILLOT's avatar
Gael MILLOT committed
854
    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)
Gael  MILLOT's avatar
Gael MILLOT committed
855
    return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
856
857
858
859
860
861
862
863
}


######## fun_list_comp() #### comparison of two lists


# Check OK: clear to go Apollo
fun_list_comp <- function(data1, data2){
Gael  MILLOT's avatar
Gael MILLOT committed
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
    # AIM:
    # compare two lists. Check and report in a list if the 2 datasets have:
    # same length
    # common names
    # common compartments
    # REQUIRED FUNCTIONS
    # none
    # ARGUMENTS
    # data1: list
    # data2: list
    # RETURN
    # a list containing:
    # $same.length: logical. Are number of elements identical?
    # $length: number of elements in the 2 datasets (NULL otherwise)
    # $same.name: logical. Are element names identical ?
    # $name: name of elements of the 2 datasets if identical (NULL otherwise)
    # $any.id.name: logical. Is there any element names identical ?
    # $same.name.pos1: position, in data1, of the element names identical in data2
    # $same.name.pos2: position, in data2, of the compartment names identical in data1
    # $any.id.compartment: logical. is there any identical compartments ?
    # $same.compartment.pos1: position, in data1, of the compartments identical in data2
    # $same.compartment.pos2: position, in data2, of the compartments identical in data1
    # $identical.object: logical. Are objects identical (kind of object, compartment names and content)?
    # $identical.content: logical. Are content objects identical (identical compartments excluding compartment names)?
    # EXAMPLES
    # obs1 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; obs2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; fun_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)
    # obs1 = list(b = 1:5, c = LETTERS[1:2]) ; obs2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; fun_list_comp(obs1, obs2)
    # obs1 = list(b = 1:5, c = LETTERS[1:2]) ; obs2 = list(LETTERS[5:9], matrix(1:6), 1:5) ; fun_list_comp(obs1, obs2)
    # DEBUGGING
    # data1 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; data2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) # for function debugging
    # data1 = list(a = 1:5, b = LETTERS[1:2]) ; data2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) # for function debugging
    # argument checking
Gael  MILLOT's avatar
Gael MILLOT committed
897
    # 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()
Gael  MILLOT's avatar
Gael MILLOT committed
898
    if( ! any(class(data1) %in% "list")){
Gael  MILLOT's avatar
Gael MILLOT committed
899
        tempo.cat <- paste0("\n\n================\n\nERROR IN fun_list_comp(): THE data1 ARGUMENT MUST BE A LIST\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
900
901
902
        stop(tempo.cat)
    }
    if( ! any(class(data2) %in% "list")){
Gael  MILLOT's avatar
Gael MILLOT committed
903
        tempo.cat <- paste0("\n\n================\n\nERROR IN fun_list_comp(): THE data2 ARGUMENT MUST BE A LIST\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
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
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
        stop(tempo.cat)
    }
    # end argument checking
    same.length <- NULL
    length <- NULL
    same.name <- NULL
    name <- NULL
    any.id.name <- NULL
    same.name.pos1 <- NULL
    same.name.pos2 <- NULL
    any.id.compartment <- NULL
    same.compartment.pos1 <- NULL
    same.compartment.pos2 <- NULL
    identical.object <- NULL
    identical.content <- NULL
    if(identical(data1, data2)){
        same.length <- TRUE
        length <- length(data1)
        if( ! is.null(names(data1))){
            same.name <- TRUE
            name <- names(data1)
            any.id.name <- TRUE
            same.name.pos1 <- 1:length(data1)
            same.name.pos2 <- 1:length(data2)
        }
        any.id.compartment <- TRUE
        same.compartment.pos1 <- 1:length(data1)
        same.compartment.pos2 <- 1:length(data2)
        identical.object <- TRUE
        identical.content <- TRUE
    }else{
        identical.object <- FALSE
        if( ! identical(length(data1), length(data2))){
            same.length<- FALSE
        }else{
            same.length<- TRUE
            length <- length(data1)
        }
        if( ! (is.null(names(data1)) & is.null(names(data2)))){
            if( ! identical(names(data1), names(data2))){
                same.name <- FALSE
            }else{
                same.name <- TRUE
                name <- names(data1)
            }
            any.id.name <- FALSE
            if(any(names(data1) %in% names(data2))){
                any.id.name <- TRUE
                same.name.pos1 <- which(names(data1) %in% names(data2))
            }
            if(any(names(data2) %in% names(data1))){
                any.id.name <- TRUE
                same.name.pos2 <- which(names(data2) %in% names(data1))
            }
        }
        names(data1) <- NULL
        names(data2) <- NULL
        any.id.compartment <- FALSE
        if(any(data1 %in% data2)){
            any.id.compartment <- TRUE
            same.compartment.pos1 <- which(data1 %in% data2)
        }
        if(any(data2 %in% data1)){
            any.id.compartment <- TRUE
            same.compartment.pos2 <- which(data2 %in% data1)
        }
        if(same.length == TRUE & ! all(is.null(same.compartment.pos1), is.null(same.compartment.pos2))){
            if(identical(same.compartment.pos1, same.compartment.pos2)){
                identical.content <- TRUE
            }else{
                identical.content <- FALSE
            }
        }else{
            identical.content <- FALSE
        }
    }
    output <- list(same.length = same.length, length = length, same.name = same.name, name = name, any.id.name = any.id.name, same.name.pos1 = same.name.pos1, same.name.pos2 = same.name.pos2, any.id.compartment = any.id.compartment, same.compartment.pos1 = same.compartment.pos1, same.compartment.pos2 = same.compartment.pos2, identical.object = identical.object, identical.content = identical.content)
    return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
982
983
984
985
986
987
988
989
990
991
992
}


################ Object modification


######## fun_dataframe_remodeling() #### remodeling a data frame to have column name as a qualitative column and vice-versa


# Check OK: clear to go Apollo
fun_dataframe_remodeling <- function(data, quanti.col.name = "quanti", quali.col.name = "quali"){
Gael  MILLOT's avatar
Gael MILLOT committed
993
994
995
996
997
998
999
1000
    # AIM:
    # if the data frame is made of numeric columns, a new data frame is created, with the 1st column gathering all the numeric values, and the 2nd column being the name of the columns of the initial data frame
    
    
    
    # If the data frame is made of one numeric column and one character or factor column, a new data frame is created, with the new columns corresponding to the split numeric values (according to the character column). NA are added a the end of each column to have the same number of rows