cute_little_R_functions.R 174 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.3.0                         ##
Gael  MILLOT's avatar
Gael MILLOT committed
4
5
6
7
8
9
10
11
12
##                                                            ##
##     Gael A. Millot                                         ##
##                                                            ##
##     Compatible with R v3.5.1                               ##
##                                                            ##
################################################################



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
15
16
17
18


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


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


################################ 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
53
    # AIM:
Gael  MILLOT's avatar
Gael MILLOT committed
54
55
56
57
58
    # 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
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
85
    # 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
86
    # 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
87
88
    if( ! is.null(data.name)){
        if( ! (length(data.name) == 1 & class(data.name) == "character")){
Gael  MILLOT's avatar
Gael MILLOT committed
89
            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
90
91
92
93
            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
94
        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
95
96
97
        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
98
        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
99
100
101
        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
102
        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
103
104
105
        stop(tempo.cat)
    }
    if(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){
Gael  MILLOT's avatar
Gael MILLOT committed
106
        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
107
108
109
110
        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
111
            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
112
113
            stop(tempo.cat)
        }
Gael  MILLOT's avatar
Gael MILLOT committed
114
115
        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
116
117
118
119
120
            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
121
            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
122
123
124
            stop(tempo.cat)
        }
        if(neg.values == FALSE & ! typeof %in% c("double", "integer")){
Gael  MILLOT's avatar
Gael MILLOT committed
125
            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
126
127
128
129
130
            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
131
            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
132
133
134
            stop(tempo.cat)
        }
        if(neg.values == FALSE & mode != "numeric"){
Gael  MILLOT's avatar
Gael MILLOT committed
135
            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
136
137
138
139
140
            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
141
            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
142
143
144
145
146
            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
147
            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
148
149
150
151
            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
152
                    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
153
154
155
156
157
                    stop(tempo.cat)
                }
            }
            if( ! is.null(mode)){
                if(mode != "numeric"){
Gael  MILLOT's avatar
Gael MILLOT committed
158
                    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
159
160
161
162
163
                    stop(tempo.cat)
                }
            }
            if( ! is.null(typeof)){
                if(typeof != "double"){
Gael  MILLOT's avatar
Gael MILLOT committed
164
                    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
165
166
167
168
169
170
                    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
171
        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
172
173
174
        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
175
        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
176
177
178
        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
179
        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
180
181
182
        stop(tempo.cat)
    }
    if( ! (all(class(print) == "logical") & length(print) == 1 & any(is.na(print)) != TRUE)){
Gael  MILLOT's avatar
Gael MILLOT committed
183
        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
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
284
        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
285
286
287
288
289
290
291


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


# Check OK: clear to go Apollo
fun_object_info <- function(data){
Gael  MILLOT's avatar
Gael MILLOT committed
292
293
294
295
296
297
298
299
    # AIM:
    # provide a full description of the object
    # REQUIRED FUNCTIONS
    # none
    # ARGUMENTS
    # data: object to test
    # RETURN
    # a list containing the info
Gael  MILLOT's avatar
Gael MILLOT committed
300
    # use names(fun_object_info()) and remove what can be to big for easy analysis
Gael  MILLOT's avatar
Gael MILLOT committed
301
302
    # EXAMPLES
    # fun_object_info(data = 1:3)
Gael  MILLOT's avatar
Gael MILLOT committed
303
    # fun_object_info(data.frame(a = 1:2, b = ordered(factor(c("A", "B")))))
Gael  MILLOT's avatar
Gael MILLOT committed
304
    # fun_object_info(list(a = 1:3, b = ordered(factor(c("A", "B")))))
Gael  MILLOT's avatar
Gael MILLOT committed
305
306
307
308
    # DEBUGGING
    # data = NULL # for function debugging
    # data = 1:3 # for function debugging
    # data = matrix(1:3) # for function debugging
Gael  MILLOT's avatar
Gael MILLOT committed
309
310
311
312
313
    # 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
314
    # argument checking
Gael  MILLOT's avatar
Gael MILLOT committed
315
    # 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
316
317
318
    # end argument checking
    data.name <- deparse(substitute(data))
    output <- list("FILE_NAME" = data.name)
Gael  MILLOT's avatar
Gael MILLOT committed
319
320
    tempo <- list("CLASS" = class(data))
    output <- c(output, tempo)
Gael  MILLOT's avatar
Gael MILLOT committed
321
322
323
324
325
326
327
328
329
330
331
332
333
    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)
    }
Gael  MILLOT's avatar
Gael MILLOT committed
334
335
336
337
    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]])
Gael  MILLOT's avatar
Gael MILLOT committed
338
339
        output <- c(output, tempo)
    }
Gael  MILLOT's avatar
Gael MILLOT committed
340
    if(all(class(data) == "data.frame")){
Gael  MILLOT's avatar
Gael MILLOT committed
341
342
343
        tempo <- list("STRUCTURE" = ls.str(data))
        output <- c(output, tempo)
        tempo <- list("COLUMN_TYPE" = sapply(data, FUN = "typeof"))
Gael  MILLOT's avatar
Gael MILLOT committed
344
345
346
347
348
349
350
351
352
        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")]
        }
Gael  MILLOT's avatar
Gael MILLOT committed
353
354
        output <- c(output, tempo)
    }
Gael  MILLOT's avatar
Gael MILLOT committed
355
    if(all(class(data) == "list")){
Gael  MILLOT's avatar
Gael MILLOT committed
356
357
        tempo <- list("COMPARTMENT_NAMES" = names(data))
        output <- c(output, tempo)
Gael  MILLOT's avatar
Gael MILLOT committed
358
359
360
361
362
363
364
365
366
367
368
        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)
Gael  MILLOT's avatar
Gael MILLOT committed
369
370
    }
    return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
371
372
373
374
375
376
377
378
}


######## 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
379
380
381
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
425
426
427
    # 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
428
    # 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
429
    if( ! any(class(data1) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
430
        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
431
432
433
        stop(tempo.cat)
    }else if(all(class(data1) %in% "table")){
        if(length(dim(data1)) > 1){
Gael  MILLOT's avatar
Gael MILLOT committed
434
            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
435
436
437
438
            stop(tempo.cat)
        }
    }
    if( ! any(class(data2) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
439
        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
440
441
442
        stop(tempo.cat)
    }else if(all(class(data2) %in% "table")){
        if(length(dim(data2)) > 1){
Gael  MILLOT's avatar
Gael MILLOT committed
443
            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
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
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
            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
583
584
585
586
587
588
589
590
}


######## 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
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
    # 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
615
    # $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
616
    # $row.name: name of rows of the 2 datasets if identical (NULL otherwise)
Gael  MILLOT's avatar
Gael MILLOT committed
617
618
619
620
621
    # $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
622
    # $col.name: name of columns of the 2 datasets if identical (NULL otherwise)
Gael  MILLOT's avatar
Gael MILLOT committed
623
624
625
626
627
628
629
630
631
632
    # $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
633
634
635
    # $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
636
    # 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
637
    # 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
638
639
    # 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
640
641
642
    # 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
643
    # 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
644
645
646
647
648
649
650
    # 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
651
    # 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
652
653
    # 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
654
    # 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
655
    if( ! any(class(data1) %in% c("matrix", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
656
        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
657
658
659
        stop(tempo.cat)
    }
    if( ! any(class(data2) %in% c("matrix", "data.frame", "table"))){
Gael  MILLOT's avatar
Gael MILLOT committed
660
        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
661
662
663
664
665
666
667
668
669
670
671
672
673
        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
674
675
676
677
    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
678
    same.col.name <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
679
680
681
682
    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
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
    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
703
704
705
        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
706
        common.row.names <- dimnames(data1)[[1]]
Gael  MILLOT's avatar
Gael MILLOT committed
707
708
        same.col.name <- TRUE
        col.name <- dimnames(data1)[[2]]
Gael  MILLOT's avatar
Gael MILLOT committed
709
710
711
        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
712
        common.col.names <- dimnames(data1)[[2]]
Gael  MILLOT's avatar
Gael MILLOT committed
713
714
715
716
717
718
719
720
721
722
723
        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
724
            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
725
726
727
            stop(tempo.cat)
        }
        if(all(class(data2) == "table") & length(dim(data2)) == 1){
Gael  MILLOT's avatar
Gael MILLOT committed
728
            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
729
730
731
732
733
            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
734
            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
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
            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
760
761
            same.row.name <- NULL
            same.col.name <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
762
763
764
765
766
767
768
769
770
771
772
773
774
            # 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
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
            # 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
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
            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
827
828
            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
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
            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
851
852
            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
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
            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
877
878
            }else{
                identical.content <- FALSE
Gael  MILLOT's avatar
Gael MILLOT committed
879
880
881
882
883
            }
        }else{
            identical.content <- FALSE
        }
    }
Gael  MILLOT's avatar
Gael MILLOT committed
884
    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
885
    return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
886
887
888
889
890
891
892
893
}


######## 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
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
    # 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
927
    # 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
928
    if( ! any(class(data1) %in% "list")){
Gael  MILLOT's avatar
Gael MILLOT committed
929
        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
930
931
932
        stop(tempo.cat)
    }
    if( ! any(class(data2) %in% "list")){
Gael  MILLOT's avatar
Gael MILLOT committed
933
        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
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
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
        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))){