cute_little_R_functions.R 871 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
3001
3002
3003
3004
3005
# ARGUMENTS
# data1: a vector of at least 2 elements. Must be numeric if data2 is specified
# data2: a numeric vector of same length as data1
# n: number of times "flipping 2 randomly selected consecutive positions". Ignored if data2 is specified
# seed: integer number used by set.seed(). Write NULL if random result is required, an integer otherwise. BEWARE: if not NULL, fun_permut() will systematically return the same result when the other parameters keep the same settings
Gael  MILLOT's avatar
Gael MILLOT committed
3006
3007
# print.count: interger value. Print a working progress message every print.count during loops. BEWARE: can increase substentially the time to complete the process using a small value, like 10 for instance. Use Inf is no loop message desired
# text.print: optional message to add to the working progress message every print.count loop
Gael  MILLOT's avatar
Gael MILLOT committed
3008
3009
3010
# cor.method: correlation method. Either "pearson", "kendall" or "spearman". Ignored if data2 is not specified
# cor.limit: a correlation limit (between 0 and 1). Ignored if data2 is not specified. Compute the correlation between data1 and data2, permute the data1 values, and stop the permutation process when the correlation between data1 and data2 decreases down below the cor limit value (0.2 by default). If cor(data1, data2) is negative, then -cor.limit is used and the process stops until the correlation between data1 and data2 increases up over cor.limit (-0.2 by default). BEWARE: write a positive cor.limit even if cor(data1, data2) is known to be negative. The function will automatically uses -cor.limit. If the initial correlation is already below cor.limit (positive correlation) or over -cor.limit (negative correlation), then the data1 value positions are completely randomized (correlation between data1 and data2 is expected to be 0)
# warn.print: logical. Print warnings at the end of the execution? No print if no warning messages
3011
# lib.path: character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
Gael  MILLOT's avatar
Gael MILLOT committed
3012
3013
3014
3015
3016
3017
# RETURN
# a list containing:
# $data: the modified vector
# $warn: potential warning messages (in case of negative correlation when data2 is specified). NULL if non warning message
# $cor: a spearman correlation between the initial positions (1:length(data1) and the final positions if data2 is not specified and the final correlation between data1 and data2 otherwise, according to cor.method
# $count: the number of loops used
Gael's avatar
tempo    
Gael committed
3018
3019
3020
3021
3022
3023
# REQUIRED PACKAGES
# lubridate
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# fun_pack()
# fun_round()
Gael  MILLOT's avatar
Gael MILLOT committed
3024
3025
3026
3027
3028
# EXAMPLES
# example (1) showing that for loop, used in fun_permut(), is faster than while loop
# ini.time <- as.numeric(Sys.time()) ; count <- 0 ; for(i0 in 1:1e9){count <- count + 1} ; tempo.time <- as.numeric(Sys.time()) ; tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time)) ; tempo.lapse
# example (2) showing that for loop, used in fun_permut(), is faster than while loop
# ini.time <- as.numeric(Sys.time()) ; count <- 0 ; while(count < 1e9){count <- count + 1} ; tempo.time <- as.numeric(Sys.time()) ; tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time)) ; tempo.lapse
Gael  MILLOT's avatar
Gael MILLOT committed
3029
3030
# fun_permut(data1 = LETTERS[1:5], data2 = NULL, n = 100, seed = 1, print.count = 10, text.print = "CPU NB 4")
# fun_permut(data1 = 101:110, data2 = 21:30, seed = 1, print.count = 1e4, text.print = "", cor.method = "spearman", cor.limit = 0.2)
Gael  MILLOT's avatar
Gael MILLOT committed
3031
# a way to use the cor.limit argument just considering data1
Gael  MILLOT's avatar
Gael MILLOT committed
3032
3033
3034
3035
# obs1 <- 101:110 ; fun_permut(data1 = obs1, data2 = obs1, seed = 1, print.count = 10, cor.method = "spearman", cor.limit = 0.2)
# fun_permut(data1 = 1:1e3, data2 = 1e3:1, seed = 1, print.count = 1e6, text.print = "", cor.method = "spearman", cor.limit = 0.7)
# fun_permut(data1 = 1:1e2, data2 = 1e2:1, seed = 1, print.count = 1e3, cor.limit = 0.5)
# fun_permut(data1 = c(0,0,0,0,0), n = 5, data2 = NULL, seed = 1, print.count = 1e3, cor.limit = 0.5)
Gael  MILLOT's avatar
Gael MILLOT committed
3036
# DEBUGGING
Gael  MILLOT's avatar
Gael MILLOT committed
3037
3038
3039
3040
# data1 = LETTERS[1:5] ; data2 = NULL ; n = 1e6 ; seed = NULL ; print.count = 1e3 ; text.print = "" ; cor.method = "spearman" ; cor.limit = 0.2 ; warn.print = TRUE ; lib.path = NULL
# data1 = LETTERS[1:5] ; data2 = NULL ; n = 10 ; seed = 22 ; print.count = 10 ; text.print = "" ; cor.method = "spearman" ; cor.limit = 0.2 ; warn.print = TRUE ; lib.path = NULL
# data1 = 101:110 ; data2 = 21:30 ; n = 10 ; seed = 22 ; print.count = 10 ; text.print = "" ; cor.method = "spearman" ; cor.limit = 0.2 ; warn.print = TRUE ; lib.path = NULL
# data1 = 1:1e3 ; data2 = 1e3:1 ; n = 20 ; seed = 22 ; print.count = 1e6 ; text.print = "" ; cor.method = "spearman" ; cor.limit = 0.5 ; warn.print = TRUE ; lib.path = NULL
Gael  MILLOT's avatar
Gael MILLOT committed
3041
# function name
3042
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3043
3044
3045
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
3046
3047
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3048
3049
}
if(length(utils::find("fun_pack", mode = "function")) == 0){
3050
3051
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_pack() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3052
3053
}
if(length(utils::find("fun_round", mode = "function")) == 0){
3054
3055
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_pack() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3056
3057
3058
3059
3060
3061
3062
3063
3064
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = data1, class = "vector", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & length(data1) < 2){
3065
tempo.cat <- paste0("ERROR IN ", function.name, ": data1 ARGUMENT MUST BE A VECTOR OF MINIMUM LENGTH 2. HERE IT IS: ", length(data1))
Gael  MILLOT's avatar
Gael MILLOT committed
3066
3067
3068
3069
3070
3071
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
if( ! is.null(data2)){
tempo <- fun_check(data = data1, class = "vector", mode = "numeric", fun.name = function.name) ; eval(ee)
if(tempo$problem == TRUE){
3072
tempo.cat <- paste0("ERROR IN ", function.name, ": data1 MUST BE A NUMERIC VECTOR IF data2 ARGUMENT IS SPECIFIED")
Gael  MILLOT's avatar
Gael MILLOT committed
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
tempo <- fun_check(data = data2, class = "vector", mode = "numeric", fun.name = function.name) ; eval(ee)
if(length(data1) != length(data2)){
tempo.cat <- paste0("ERROR IN ", function.name, ": data1 AND data2 MUST BE VECTOR OF SAME LENGTH. HERE IT IS ", length(data1)," AND ", length(data2))
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
}else if(is.null(n)){
3083
tempo.cat <- paste0("ERROR IN ", function.name, ": n ARGUMENT CANNOT BE NULL IF data2 ARGUMENT IS NULL")
Gael  MILLOT's avatar
Gael MILLOT committed
3084
3085
3086
3087
3088
3089
3090
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
if( ! is.null(n)){
tempo <- fun_check(data = n, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
}
if( ! is.null(seed)){
3091
tempo <- fun_check(data = seed, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = TRUE, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
3092
}
Gael  MILLOT's avatar
Gael MILLOT committed
3093
tempo <- fun_check(data = print.count, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
3094
3095
3096
3097
3098
tempo <- fun_check(data = text.print, class = "character", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = cor.method, options = c("pearson", "kendall", "spearman"), length =1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = cor.limit, class = "vector", mode = "numeric", prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = warn.print, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(lib.path)){
Gael  MILLOT's avatar
Gael MILLOT committed
3099
3100
3101
3102
tempo <- fun_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE){
if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", paste(lib.path, collapse = "\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
3103
3104
3105
3106
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
3107
}
Gael  MILLOT's avatar
Gael MILLOT committed
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end argument checking
# package checking
fun_pack(req.package = "lubridate", lib.path = lib.path)
# end package checking
# main code
# code that protects set.seed() in the global environment
# see also Protocol 100-rev0 Parallelization in R.docx
if(exists(".Random.seed", envir = .GlobalEnv)){ # if .Random.seed does not exists, it means that no random operation has been performed yet in any R environment
tempo.random.seed <- .Random.seed
on.exit(assign(".Random.seed", tempo.random.seed, env = .GlobalEnv))
}else{
on.exit(set.seed(NULL)) # inactivate seeding -> return to complete randomness
}
set.seed(seed)
3126
# end code that protects set.seed() in the global environment
Gael  MILLOT's avatar
Gael MILLOT committed
3127
3128
3129
3130
3131
3132
ini.date <- Sys.time() # time of process begin, converted into seconds
ini.time <- as.numeric(ini.date) # time of process begin, converted into seconds
ini.pos <- 1:length(data1) # positions of data1 before permutation loops
tempo.pos <- ini.pos # positions of data1 that will be modified during loops
# pos.selec.seq <- ini.pos[-length(data1)] # selection of 1 position in initial position, without the last because always up permutation (pos -> pos+1 & pos+1 -> pos)
pos.selec.seq.max <- length(ini.pos) - 1 # max position (used by sample.int() function). See  below for - 1
3133
ini.warning.length <- options()$warning.length
Gael  MILLOT's avatar
Gael MILLOT committed
3134
warn <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
3135
warn.count <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3136
3137
3138
3139
3140
3141
count <- 0
round <- 0
BREAK <- FALSE
tempo.cor <- 0
if(is.null(data2)){
if(length(table(data1)) == 1){
Gael  MILLOT's avatar
Gael MILLOT committed
3142
warn.count <- warn.count + 1
3143
tempo.warn <- paste0("(", warn.count,") NO PERMUTATION PERFORMED BECAUSE data1 ARGUMENT SEEMS TO BE MADE OF IDENTICAL ELEMENTS: ", names(table(data1)))
Gael  MILLOT's avatar
Gael MILLOT committed
3144
3145
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) #
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
3146
3147
if(print.count > n){
print.count <- n
Gael  MILLOT's avatar
Gael MILLOT committed
3148
3149
}
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FOR LOOP OF ", n, " LOOPS INITIATED | LOOP COUNT: ", format(count, big.mark=",")))
Gael  MILLOT's avatar
Gael MILLOT committed
3150
3151
print.count.loop <- logical(length = print.count)
print.count.loop[length(print.count.loop)] <- TRUE # not this to avoid long vector, but not forget to reset during printing: print.count.loop[(1:trunc(n / print.count) * print.count)] <- TRUE # counter to speedup
Gael  MILLOT's avatar
Gael MILLOT committed
3152
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3153
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # selection of random positions. BEWARE: n = pos.selec.seq.max because already - 1 (see above) but is connected to tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
Gael  MILLOT's avatar
Gael MILLOT committed
3154
3155
3156
3157
3158
3159
tempo.date.loop <- Sys.time()
tempo.time.loop <- as.numeric(tempo.date.loop)
for(i3 in 1:n){
count.loop <- count.loop + 1
pos2 <- pos[count.loop] # selection of 1 position
tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
Gael  MILLOT's avatar
Gael MILLOT committed
3160
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3161
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3162
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # BEWARE: never forget to resample here
Gael  MILLOT's avatar
Gael MILLOT committed
3163
3164
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3165
final.loop <- (tempo.time - tempo.time.loop) / i3 * n # expected duration in seconds
Gael  MILLOT's avatar
Gael MILLOT committed
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
final.exp <- as.POSIXct(final.loop, origin = tempo.date.loop)
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FOR LOOP ", i3, " / ", n, " | TIME SPENT: ", tempo.lapse, " | EXPECTED END: ", final.exp))
}
}
count <- count + n # out of the loop to speedup
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FOR LOOP ENDED | LOOP COUNT: ", format(count, big.mark=",")))
cat("\n\n")
}
}else{
if(length(table(data1)) == 1){
Gael  MILLOT's avatar
Gael MILLOT committed
3176
warn.count <- warn.count + 1
3177
tempo.warn <- paste0("(", warn.count,") NO PERMUTATION PERFORMED BECAUSE data1 ARGUMENT SEEMS TO BE MADE OF IDENTICAL ELEMENTS: ", names(table(data1)))
Gael  MILLOT's avatar
Gael MILLOT committed
3178
3179
3180
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) #
tempo.cor <- 1
}else if(length(table(data2)) == 1){
Gael  MILLOT's avatar
Gael MILLOT committed
3181
warn.count <- warn.count + 1
3182
tempo.warn <- paste0("(", warn.count,") NO PERMUTATION PERFORMED BECAUSE data2 ARGUMENT SEEMS TO BE MADE OF IDENTICAL ELEMENTS: ", names(table(data2)))
Gael  MILLOT's avatar
Gael MILLOT committed
3183
3184
3185
3186
3187
3188
3189
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) #
tempo.cor <- 1
}else{
cor.ini <- cor(x = data1, y = data2, use = "pairwise.complete.obs", method = cor.method)
tempo.cor <- cor.ini # correlation that will be modified during loops
neg.cor <- FALSE
if(tempo.cor < 0){
Gael  MILLOT's avatar
Gael MILLOT committed
3190
warn.count <- warn.count + 1
3191
tempo.warn <- paste0("(", warn.count,") INITIAL ", toupper(cor.method), " CORRELATION BETWEEN data1 AND data2 HAS BEEN DETECTED AS NEGATIVE: ", tempo.cor, ". THE LOOP STEPS WILL BE PERFORMED USING POSITIVE CORRELATIONS BUT THE FINAL CORRELATION WILL BE NEGATIVE")
Gael  MILLOT's avatar
Gael MILLOT committed
3192
3193
3194
3195
3196
3197
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) #
neg.cor <- TRUE
tempo.cor <- abs(tempo.cor)
cor.ini <- abs(cor.ini)
}
if(tempo.cor < cor.limit){ # randomize directly all the position to be close to correlation zero
Gael  MILLOT's avatar
Gael MILLOT committed
3198
warn.count <- warn.count + 1
3199
tempo.warn <- paste0("(", warn.count,") INITIAL ABSOLUTE VALUE OF THE ", toupper(cor.method), " CORRELATION ", fun_round(tempo.cor), " BETWEEN data1 AND data2 HAS BEEN DETECTED AS BELOW THE CORRELATION LIMIT PARAMETER ", cor.limit, "\nTHE data1 SEQUENCE HAS BEEN COMPLETELY RANDOMIZED TO CORRESPOND TO CORRELATION ZERO")
Gael  MILLOT's avatar
Gael MILLOT committed
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) #
for(i4 in 1:5){ # done 5 times to be sure of the complete randomness
tempo.pos <- sample(x = tempo.pos, size = length(tempo.pos), replace = FALSE)
}
count <- count + 5 # out of the loop to speedup
}else{
# smallest correlation decrease
count <- count + 1 # 1 and not 0 because already 1 performed just below
pos <- sample.int(n = pos.selec.seq.max , size = 1, replace = TRUE) # selection of 1 position # pos.selec.seq.max  because selection of 1 position in initial position, without the last because always up permutation (pos -> pos+1 & pos+1 -> pos)
tempo.pos[c(pos + 1, pos)] <- tempo.pos[c(pos, pos + 1)]
tempo.cor <- abs(cor(x = data1[tempo.pos], y = data2, use = "pairwise.complete.obs", method = cor.method))
smallest.cor.dec <- cor.ini - tempo.cor
# end smallest correlation decrease
# going out of tempo.cor == cor.ini
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "CORRELATION DECREASE AFTER A SINGLE PERMUTATION: ", fun_round(smallest.cor.dec, 4)))
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FIRST WHILE LOOP STEP -> GOING OUT FROM EQUALITY | LOOP COUNT: ", format(count, big.mark=","), " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4)))
Gael  MILLOT's avatar
Gael MILLOT committed
3216
3217
print.count.loop <- logical(length = print.count)
print.count.loop[length(print.count.loop)] <- TRUE # counter to speedup
Gael  MILLOT's avatar
Gael MILLOT committed
3218
count.loop <- 0 # 
Gael  MILLOT's avatar
Gael MILLOT committed
3219
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # selection of random positions. BEWARE: n = pos.selec.seq.max because already - 1 (see above) but is connected to tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
Gael  MILLOT's avatar
Gael MILLOT committed
3220
3221
3222
3223
3224
3225
3226
3227
tempo.date.loop <- Sys.time()
tempo.time.loop <- as.numeric(tempo.date.loop)
while(tempo.cor == cor.ini){ # to be out of equality between tempo.cor and cor.ini at the beginning (only valid for very long vector)
count <- count + 1
count.loop <- count.loop + 1
pos2 <- pos[count.loop]
tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
tempo.cor <- abs(cor(x = data1[tempo.pos], y = data2, use = "pairwise.complete.obs", method = cor.method))
Gael  MILLOT's avatar
Gael MILLOT committed
3228
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3229
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3230
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # BEWARE: never forget to resample here
Gael  MILLOT's avatar
Gael MILLOT committed
3231
3232
3233
3234
3235
3236
3237
3238
3239
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FIRST WHILE LOOP STEP", format(count.loop, big.mark=","), " / ? | COUNT: ", format(count, big.mark=","), " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4), " | TIME SPENT: ", tempo.lapse))
}
}
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FIRST WHILE LOOP STEP END | LOOP COUNT: ", format(count, big.mark=","), " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4), " | TOTAL SPENT TIME: ", tempo.lapse))
if(tempo.cor < cor.limit){
Gael  MILLOT's avatar
Gael MILLOT committed
3240
warn.count <- warn.count + 1
3241
tempo.warn <- paste0("(", warn.count,") THE FIRST FOR & WHILE LOOP STEPS HAVE BEEN TOO FAR AND SUBSEQUENT LOOP STEPS WILL NOT RUN")
Gael  MILLOT's avatar
Gael MILLOT committed
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
# end going out of tempo.cor == cor.ini
# estimation of the average correlation decrease per loop on x loops and for loop execution
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "WHILE/FOR LOOPS INITIATION | LOOP COUNT: ", format(count, big.mark=","), " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4)))
count.est <- 1e5
first.round <- TRUE
GOBACK <- FALSE
while(tempo.cor > cor.limit){
round <- round + 1
# estimation step
if(first.round == TRUE){
first.round <- FALSE
cor.dec.per.loop <- numeric(length = 5)
loop.nb.est <- Inf
cor.est.ini <- tempo.cor
cor.est <- numeric(length = 5)
for(i6 in 1:5){ # connected to cor.dec.per.loop
tempo.pos.est <- tempo.pos
pos <- sample.int(n = pos.selec.seq.max , size = count.est, replace = TRUE) # selection of n position
for(i7 in 1:count.est){
pos2 <- pos[i7] # selection of 1 position
tempo.pos.est[c(pos2 + 1, pos2)] <- tempo.pos.est[c(pos2, pos2 + 1)]
}
tempo.cor.est <- abs(cor(x = data1[tempo.pos.est], y = data2, use = "pairwise.complete.obs", method = cor.method))
cor.est[i6] <- tempo.cor.est
tempo.cor.dec.per.loop <- (cor.est.ini - tempo.cor.est) / count.est # correlation decrease per loop
if(is.na(tempo.cor.dec.per.loop) | ! is.finite(tempo.cor.dec.per.loop)){
3270
3271
tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 2\ncor.est.ini: ", cor.est.ini, "\ntempo.cor.est: ", tempo.cor.est)
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
}
cor.dec.per.loop[i6] <- tempo.cor.dec.per.loop
}
cor.est <- cor.est[which.max(cor.dec.per.loop)] # max to avoid to go to far with for loop (tempo.cor below tempo.limit)
cor.dec.per.loop <- max(cor.dec.per.loop, na.rm = TRUE) # max to avoid to go to far with for loop (tempo.cor below tempo.limit)
loop.nb.est <- round((tempo.cor - cor.limit) / cor.dec.per.loop)
}else{
if(GOBACK == TRUE){
loop.nb.est <- round(loop.nb.est / 2)
}else{
cor.dec.per.loop <- (cor.ini - tempo.cor) / count
loop.nb.est <- round((tempo.cor - cor.limit) / cor.dec.per.loop)
}
}
# end estimation step
# loop step
if(is.na(loop.nb.est) | ! is.finite(loop.nb.est)){
3289
3290
tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 1\nloop.nb.est: ", loop.nb.est, "\ncor.ini: ", cor.ini, "\ntempo.cor: ", tempo.cor, "\ncor.limit: ", cor.limit, "\ncor.dec.per.loop: ", cor.dec.per.loop)
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3291
3292
3293
3294
3295
}else if(loop.nb.est > 1e4){ # below -> leave the while loop
tempo.pos.secu <- tempo.pos
count.secu <- count
tempo.cor.secu <- tempo.cor
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "INITIAL SETTINGS BEFORE ROUND: ", round, " | LOOP COUNT: ", format(count, big.mark=","), " | GO BACK: ", GOBACK, " | LOOP NUMBER ESTIMATION: ", format(loop.nb.est, big.mark=","), " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4)))
Gael  MILLOT's avatar
Gael MILLOT committed
3296
3297
print.count.loop <- logical(length = print.count)
print.count.loop[length(print.count.loop)] <- TRUE # not this to avoid long vector, but not forget to reset during printing: print.count.loop[(1:trunc(n / print.count) * print.count)] <- TRUE # counter to speedup
Gael  MILLOT's avatar
Gael MILLOT committed
3298
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3299
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # selection of random positions. BEWARE: n = pos.selec.seq.max because already - 1 (see above) but is connected to tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
Gael  MILLOT's avatar
Gael MILLOT committed
3300
3301
3302
3303
3304
3305
tempo.date.loop <- Sys.time()
tempo.time.loop <- as.numeric(tempo.date.loop)
for(i6 in 1:loop.nb.est){
count.loop <- count.loop + 1
pos2 <- pos[count.loop] # selection of 1 position
tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
Gael  MILLOT's avatar
Gael MILLOT committed
3306
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3307
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3308
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # BEWARE: never forget to resample here
Gael  MILLOT's avatar
Gael MILLOT committed
3309
3310
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3311
final.loop <- (tempo.time - tempo.time.loop) / i6 * loop.nb.est # expected duration in seconds # intra nb.compar loop lapse: time lapse / cycles done * cycles remaining
Gael  MILLOT's avatar
Gael MILLOT committed
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
final.exp <- as.POSIXct(final.loop, origin = tempo.date.loop)
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FOR LOOP | ROUND ", round, " | LOOP: ", format(i6, big.mark=","), " / ", format(loop.nb.est, big.mark=","), " | TIME SPENT: ", tempo.lapse, " | EXPECTED END: ", final.exp))
}
}
count <- count + loop.nb.est # out of the loop to speedup
tempo.cor <- abs(cor(x = data1[tempo.pos], y = data2, use = "pairwise.complete.obs", method = cor.method))
if(tempo.cor > tempo.cor.secu | ((tempo.cor - cor.limit) < 0 & abs(tempo.cor - cor.limit) > smallest.cor.dec * round(log10(max(ini.pos, na.rm = TRUE))))){
GOBACK <- TRUE
tempo.pos <- tempo.pos.secu
count <- count.secu
tempo.cor <- tempo.cor.secu
}else{
GOBACK <- FALSE
}
}else{
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "FINAL WHILE LOOP | LOOP COUNT: ", format(count, big.mark=","), " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4)))
Gael  MILLOT's avatar
Gael MILLOT committed
3328
3329
print.count.loop <- logical(length = print.count)
print.count.loop[length(print.count.loop)] <- TRUE # counter to speedup
Gael  MILLOT's avatar
Gael MILLOT committed
3330
count.loop <- 0 # 
Gael  MILLOT's avatar
Gael MILLOT committed
3331
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # selection of random positions. BEWARE: n = pos.selec.seq.max because already - 1 (see above) but is connected to tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
Gael  MILLOT's avatar
Gael MILLOT committed
3332
3333
3334
3335
3336
3337
3338
3339
3340
tempo.cor.loop <- tempo.cor
tempo.date.loop <- Sys.time()
tempo.time.loop <- as.numeric(tempo.date.loop)
while(tempo.cor > cor.limit){
count <- count + 1
count.loop <- count.loop + 1
pos2 <- pos[count.loop]
tempo.pos[c(pos2 + 1, pos2)] <- tempo.pos[c(pos2, pos2 + 1)]
tempo.cor <- abs(cor(x = data1[tempo.pos], y = data2, use = "pairwise.complete.obs", method = cor.method))
Gael  MILLOT's avatar
Gael MILLOT committed
3341
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3342
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3343
pos <- sample.int(n = pos.selec.seq.max , size = print.count, replace = TRUE) # BEWARE: never forget to resample here
Gael  MILLOT's avatar
Gael MILLOT committed
3344
3345
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3346
final.loop <- (tempo.time - tempo.time.loop) / (tempo.cor.loop - tempo.cor) * (tempo.cor - cor.limit) # expected duration in seconds # tempo.cor.loop - tempo.cor always positive and tempo.cor decreases progressively starting from tempo.cor.loop
Gael  MILLOT's avatar
Gael MILLOT committed
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
final.exp <- as.POSIXct(final.loop, origin = tempo.date.loop)
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "WHILE LOOP | LOOP NB: ", format(count.loop, big.mark=","), " | COUNT: ", format(count, big.mark=","), " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4), " | TIME SPENT: ", tempo.lapse, " | EXPECTED END: ", final.exp))
}
}
}
}
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
cat(paste0("\n", ifelse(text.print == "", "", paste0(text.print, " | ")), "WHILE/FOR LOOPS END | LOOP COUNT: ", format(count, big.mark=","), " | NB OF ROUNDS: ", round, " | CORRELATION LIMIT: ", fun_round(cor.limit, 4), " | ABS TEMPO CORRELATION: ", fun_round(tempo.cor, 4), " | TOTAL SPENT TIME: ", tempo.lapse))
}
tempo.cor <- ifelse(neg.cor == TRUE, -tempo.cor, tempo.cor)
}
}
cat("\n\n")
if(warn.print == TRUE & ! is.null(warn)){
3362
3363
3364
options(warning.length = 8170)
on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE), add = TRUE)
on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
3365
3366
3367
3368
3369
3370
}
output <- list(data = data1[tempo.pos], warn = warn, cor = if(is.null(data2)){cor(ini.pos, tempo.pos, method = "spearman")}else{tempo.cor}, count = count)
return(output)
}


Gael  MILLOT's avatar
Gael MILLOT committed
3371
3372
3373
######## fun_slide() #### return a computation made on a vector using a sliding window


Gael's avatar
tempo    
Gael committed
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
fun_slide <- function(
data, 
window.size, 
step, 
from = NULL, 
to = NULL, 
fun, 
args = NULL, 
boundary = "left", 
parall = FALSE, 
thread.nb = NULL, 
print.count = 100, 
res.path = NULL, 
lib.path = NULL, 
verbose = TRUE, 
cute.path = "C:\\Users\\Gael\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R"
){
Gael  MILLOT's avatar
Gael MILLOT committed
3391
3392
# AIM
# return a computation made on a vector using a sliding window
Gael's avatar
tempo    
Gael committed
3393
# WARNINGS
Gael's avatar
Gael committed
3394
3395
# The function uses two strategies, depending on the amout of memory required which depends on the data, window.size and step arguments. The first one uses lapply(), is generally fast but requires lots of memory. The second one uses a parallelized loop. The choice between the two strategies is automatic if parall argument is FALSE, and is forced toward parallelization if parall argument is TRUE
# The parall argument forces the parallelization, which is convenient when the data argument is big, because the lapply() function is sometimes slower than the parallelization
Gael  MILLOT's avatar
Gael MILLOT committed
3396
3397
3398
3399
# ARGUMENTS
# data: vector, matrix, table or array of numeric values (mode must be numeric). Inf not allowed. NA will be removed before computation
# window.size: single numeric value indicating the width of the window sliding across data (in the same unit as data value)
# step: single numeric value indicating the step between each window (in the same unit as data value). Cannot be larger than window.size
3400
# from: value of the left boundary of the first sliding window. If NULL, min(data) is used. The first window will strictly have from or min(data) as left boundary
3401
# to: value of the right boundary of the last sliding window. If NULL, max(data) is used. Warning: (1) the final last window will not necessary have to|max(data) as right boundary. In fact the last window will be the one that contains to|max(data) for the first time, i.e., min[from|min(data) + window.size + n * step >= to|max(data)]; (2) In fact, the >= in min[from|min(data) + window.size + n * step >= to|max(data)] depends on the boundary argument (>= for "right" and > for "left"); (3) to have the rule (1) but for the center of the last window, use to argument as to = to|max(data) + window.size / 2
Gael  MILLOT's avatar
Gael MILLOT committed
3402
# fun: function or character string (without brackets) indicating the name of the function to apply in each window. Example: fun = "mean", or fun = mean
3403
# args: character string of additional arguments of fun (separated by a comma between the quotes). Example args = "na.rm = TRUE" for fun = mean. Ignored if NULL
Gael  MILLOT's avatar
Gael MILLOT committed
3404
# boundary: either "left" or "right". Indicates if the sliding window includes values equal to left boundary and exclude values equal to right boundary ("left") or the opposite ("right")
Gael's avatar
Gael committed
3405
# parall: logical. Force parallelization ?
3406
3407
3408
# thread.nb: numeric value indicating the number of threads to use if ever parallelization is required. If NULL, all the available threads will be used
# print.count: interger value. Print a working progress message every print.count during loops. BEWARE: can increase substentially the time to complete the process using a small value, like 10 for instance. Use Inf is no loop message desired
# res.path: character string indicating the absolute pathway where the parallelization log file will be created if parallelization is used. If NULL, will be created in the R current directory
Gael  MILLOT's avatar
Gael MILLOT committed
3409
# lib.path: character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
3410
3411
# verbose: logical. Display messages?
# cute.path: character string indicating the absolute path of the cute.R file. Will be remove when cute will be a package. Not considered if thread.nb is NULL
Gael  MILLOT's avatar
Gael MILLOT committed
3412
3413
3414
3415
3416
3417
# RETURN
# a data frame containing
#$left : the left boundary of each window (in the unit of the data argument)
#$right : the right boundary of each window (in the unit of data argument)
#$center : the center of each window (in the unit of data argument)
#$value : the computed value by the fun argument in each window)
Gael's avatar
tempo    
Gael committed
3418
3419
# REQUIRED PACKAGES
# lubridate
Gael's avatar
Gael committed
3420
# parallel if parallelization is used (included in the R installation packages but not automatically loaded)
Gael's avatar
tempo    
Gael committed
3421
3422
3423
3424
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# fun_get_message
# fun_pack()
Gael  MILLOT's avatar
Gael MILLOT committed
3425
3426
# EXAMPLES
# fun_slide(data = c(1:10, 100:110, 500), window.size = 5, step = 2, fun = length, boundary = "left")
Gael's avatar
Gael committed
3427
3428
# fun_slide(data = c(1:10, 100:110, 500), window.size = 5, step = 2, fun = length, boundary = "right") # effect of boundary argument
# fun_slide(data = c(1:10, 100:110, 500), window.size = 5, step = 2, fun = length, boundary = "left", parall = TRUE) # effect of parall argument
Gael  MILLOT's avatar
Gael MILLOT committed
3429
# DEBUGGING
Gael's avatar
Gael committed
3430
# data = c(1:10, 100:110, 500) ; window.size = 5 ; step = 2 ; from = NULL ; to = NULL ; fun = length ; args = NULL ; boundary = "left" ; parall = FALSE ; thread.nb = NULL ; print.count = 100 ; res.path = NULL ; lib.path = NULL ; verbose = TRUE ; cute.path = "C:\\Users\\Gael\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R"
Gael's avatar
Gael committed
3431
# data = lag.pos; window.size = window.size; step = step; fun = length; from = min(a$pos); to = max(a$pos)
Gael  MILLOT's avatar
Gael MILLOT committed
3432
# function name
3433
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3434
3435
3436
3437
instruction <- match.call()
# end function name
# required function checking
req.function <- c(
Gael's avatar
Gael committed
3438
3439
3440
"fun_check", 
"fun_get_message", 
"fun_pack"
Gael  MILLOT's avatar
Gael MILLOT committed
3441
3442
3443
)
for(i1 in req.function){
if(length(find(i1, mode = "function")) == 0){
3444
3445
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED ", i1, "() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3446
3447
3448
3449
3450
3451
}
}
# end required function checking
# argument primary checking
# arg with no default values
if(any(missing(data) | missing(window.size) | missing(step) | missing(fun))){
3452
3453
tempo.cat <- paste0("ERROR IN ", function.name, ": ARGUMENTS fun, args AND val HAVE NO DEFAULT VALUE AND REQUIRE ONE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
}
# end arg with no default values
# using fun_check()
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = data, mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = window.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = step, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
3464
3465
if( ! is.null(from)){
tempo <- fun_check(data = from, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
3466
}
3467
3468
if( ! is.null(to)){
tempo <- fun_check(data = to, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
3469
}
Gael  MILLOT's avatar
Gael MILLOT committed
3470
3471
tempo1 <- fun_check(data = fun, class = "vector", mode = "character", length = 1, fun.name = function.name)
tempo2 <- fun_check(data = fun, class = "function", length = 1, fun.name = function.name)
Gael  MILLOT's avatar
Gael MILLOT committed
3472
3473
3474
3475
3476
3477
3478
3479
3480
if(tempo1$problem == TRUE & tempo2$problem == TRUE){
tempo.cat <- paste0("ERROR IN ", function.name, ": fun ARGUMENT MUST BE A FUNCTION OR A CHARACTER STRING OF THE NAME OF A FUNCTION")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
if( ! is.null(args)){
tempo <- fun_check(data = args, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
}
tempo <- fun_check(data = boundary, options = c("left", "right"), length = 1, fun.name = function.name) ; eval(ee)
3481
3482
3483
if( ! is.null(thread.nb)){
tempo <- fun_check(data = thread.nb, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
}
Gael's avatar
Gael committed
3484
tempo <- fun_check(data = parall, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
3485
3486
3487
3488
tempo <- fun_check(data = print.count, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
if( ! is.null(res.path)){
tempo <- fun_check(data = res.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
}
Gael  MILLOT's avatar
Gael MILLOT committed
3489
3490
3491
if( ! is.null(lib.path)){
tempo <- fun_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
}
3492
3493
3494
3495
3496
3497
3498
3499
3500
tempo <- fun_check(data = cute.path, class = "vector", typeof = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE){
if( ! file.exists(cute.path)){
tempo.cat <- paste0("ERROR IN ", function.name, ": FILE PATH INDICATED IN THE cute.path PARAMETER DOES NOT EXISTS:\n", cute.path)
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
}
tempo <- fun_check(data = verbose, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
3501
3502
3503
3504
3505
3506
3507
3508
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# end using fun_check()
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end argument primary checking
# second round of checking and data preparation
# dealing with NA
Gael's avatar
Gael committed
3509
if(any(is.na(window.size)) | any(is.na(step)) | any(is.na(from)) | any(is.na(to)) | suppressWarnings(any(is.na(fun))) | any(is.na(args)) | any(is.na(boundary)) | any(is.na(parall)) | any(is.na(thread.nb)) | any(is.na(print.count)) | any(is.na(res.path)) | any(is.na(lib.path)) | any(is.na(verbose))){
3510
3511
tempo.cat <- paste0("ERROR IN ", function.name, ": NO ARGUMENT EXCEPT data CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENTS ARE: ", paste(c("window.size", "step", "from", "to", "fun", "args", "boundary", "parall", "thread.nb", "print.count", "res.path", "lib.path", "verbose")[c(any(is.na(window.size)), any(is.na(step)), any(is.na(from)), any(is.na(to)), suppressWarnings(any(is.na(fun))), any(is.na(args)), any(is.na(boundary)), any(is.na(parall)), any(is.na(thread.nb)), any(is.na(print.count)), any(is.na(res.path)), any(is.na(lib.path)), any(is.na(verbose)))], collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3512
3513
3514
}
# end dealing with NA
# dealing with NULL
Gael's avatar
Gael committed
3515
if(is.null(data) | is.null(window.size) | is.null(step) | is.null(fun) | is.null(boundary) | is.null(parall) | is.null(print.count) | is.null(verbose)){
3516
3517
tempo.cat <- paste0("ERROR IN ", function.name, ": THESE ARGUMENTS\ndata\nwindow.size\nstep\nfun\nboundary\nparall\nprint.count\nverbose\nCANNOT BE NULL\nPROBLEMATIC ARGUMENTS ARE: ", paste(c("data", "window.size", "step", "fun", "boundary", "parall", "print.count", "verbose")[c(is.null(data), is.null(window.size), is.null(step), is.null(fun), is.null(boundary), is.null(parall), is.null(print.count), is.null(verbose))], collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
}
# end dealing with NULL
if(any( ! is.finite(data))){
tempo.cat <- paste0("ERROR IN ", function.name, ": data ARGUMENT CANNOT CONTAIN Inf VALUES")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}
if(step > window.size){
tempo.cat <- paste0("ERROR IN ", function.name, ": step ARGUMENT MUST BE LOWER THAN window.size ARGUMENT\nstep: ", paste(step, collapse = " "), "\nwindow.size: ", paste(window.size, collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
if( ! is.null(thread.nb)){
if(thread.nb < 1){
tempo.cat <- paste0("ERROR IN ", function.name, ": thread.nb PARAMETER MUST EQUAL OR GREATER THAN 1: ", thread.nb)
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}
}
if( ! is.null(res.path)){
if( ! all(dir.exists(res.path))){ # separation to avoid the problem of tempo$problem == FALSE and res.path == NA
tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE res.path ARGUMENT DOES NOT EXISTS:\n", paste(res.path, collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}
}else{
res.path <- getwd() # working directory
}
Gael  MILLOT's avatar
Gael MILLOT committed
3542
3543
3544
if( ! is.null(lib.path)){
if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", paste(lib.path, collapse = "\n"))
3545
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
3546
3547
3548
}
}
# end second round of checking and data preparation
3549
3550
3551
3552
# package checking
fun_pack(req.package = c("lubridate"), lib.path = lib.path)
fun_pack(req.package = c("parallel"), lib.path = lib.path)
# end package checking
Gael  MILLOT's avatar
Gael MILLOT committed
3553
# main code
3554
3555
3556
3557
3558
if(verbose == TRUE){
cat("\nfun_slide JOB IGNITION\n")
}
ini.date <- Sys.time()
ini.time <- as.numeric(ini.date) # time of process begin, converted into seconds
Gael  MILLOT's avatar
Gael MILLOT committed
3559
3560
3561
3562
fun <- match.fun(fun) # make fun <- get(fun) is fun is a function name written as character string of length 1
if(boundary == "left"){
left <- ">="
right <- "<"
3563
right.last.wind <- ">"
Gael  MILLOT's avatar
Gael MILLOT committed
3564
3565
3566
}else if(boundary == "right"){
left <- ">"
right <- "<="
3567
right.last.wind <- ">="
Gael  MILLOT's avatar
Gael MILLOT committed
3568
}else{
3569
3570
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 1")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3571
}
3572
3573
data <- as.vector(data)
data <- sort(data, na.last = NA) # NA removed
3574
3575
3576
wind <- data.frame(left = seq(from = if(is.null(from)){min(data, na.rm = TRUE)}else{from}, to = if(is.null(to)){max(data, na.rm = TRUE)}else{to}, by = step), stringsAsFactors = TRUE)
wind <- data.frame(wind, right = wind$left + window.size, stringsAsFactors = TRUE)
wind <- data.frame(wind, center = (wind$left + wind$right) / 2, stringsAsFactors = TRUE)
3577
if(all(wind$right < if(is.null(to)){max(data, na.rm = TRUE)}else{to})){
3578
3579
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 2")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
3580
3581
3582
3583
3584
}
# The 3 next lines is for the rule of to argument with center (see to argument description)
# if(any(wind$center > max(data, na.rm = TRUE))){
# wind <- wind[ ! wind$center > max(data, na.rm = TRUE),]
# }
3585
3586
if(sum(get(right.last.wind)(wind$right, if(is.null(to)){max(data, na.rm = TRUE)}else{to}), na.rm = TRUE) > 1){  # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
tempo.log <- get(right.last.wind)(wind$right, if(is.null(to)){max(data, na.rm = TRUE)}else{to}) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
3587
3588
3589
tempo.log[min(which(tempo.log), na.rm = TRUE)] <- FALSE # convert the first left boundary that goes above max(data, na.rm = TRUE) to FALSE to keep it (the next ones will be removed)
wind <- wind[ ! tempo.log,]
}
Gael's avatar
Gael committed
3590

Gael's avatar
Gael committed
3591
3592
# test if lapply can be used
if(parall == FALSE){
Gael's avatar
Gael committed
3593
3594
3595
# new environment
env.name <- paste0("env", ini.time)
if(exists(env.name, where = -1)){
3596
3597
tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael's avatar
Gael committed
3598
3599
}else{
assign(env.name, new.env())
3600
3601
assign("wind", wind, envir = get(env.name, env = sys.nframe(), inherit = FALSE))
assign("data", data, envir = get(env.name, env = sys.nframe(), inherit = FALSE))
Gael's avatar
Gael committed
3602
3603
}
# end new environment
3604
tempo.message <- fun_get_message(data="lapply(X = wind$left, Y = data, FUN = function(X, Y){res <- get(left)(Y, X) ; return(res)})", kind = "error", header = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE), print.no = FALSE) # no env = sys.nframe(), inherit = FALSE in get(left) because look for function in the classical scope
Gael's avatar
Gael committed
3605
rm(env.name) # optional, because should disappear at the end of the function execution
Gael's avatar
Gael committed
3606
3607
3608
}else{
tempo.message <- "ERROR" # with this, force the parallelization by default
}
3609
# end test if lapply can be used
Gael's avatar
Gael committed
3610
if( ! any(grepl(x = tempo.message, pattern = "ERROR.*"))){
Gael  MILLOT's avatar
Gael MILLOT committed
3611
left.log <- lapply(X = wind$left, Y = data, FUN = function(X, Y){
3612
res <- get(left)(Y, X) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
Gael  MILLOT's avatar
Gael MILLOT committed
3613
3614
3615
return(res)
})
right.log <- lapply(X = wind$right, Y = data, FUN = function(X, Y){
3616
res <- get(right)(Y, X) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
Gael  MILLOT's avatar
Gael MILLOT committed
3617
3618
3619
return(res)
})
log <- mapply(FUN = "&", left.log, right.log, SIMPLIFY = FALSE)
3620
output <- eval(parse(text = paste0("sapply(lapply(log, FUN = function(X){(data[X])}), FUN = fun", if( ! is.null(args)){paste0(", ", args)}, ")"))) # take the values of the data vector according to log (list of logical, each compartment of length(data)) and apply fun with args of fun
3621
if(length(output) != nrow(wind)){
3622
3623
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 3")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
3624
}else{
3625
output <- data.frame(wind, value = output, stringsAsFactors = TRUE)
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
}
}else{
if(verbose == TRUE){
tempo.cat <- paste0("PARALLELIZATION INITIATED AT: ", ini.date)
cat(paste0("\n", tempo.cat, "\n"))
}
tempo.thread.nb = parallel::detectCores(all.tests = FALSE, logical = TRUE) # detect the number of threads
if( ! is.null(thread.nb)){
if(tempo.thread.nb < thread.nb){
thread.nb <- tempo.thread.nb
if(verbose == TRUE){
tempo.cat <- paste0("ONLY: ", tempo.thread.nb, " THREADS AVAILABLE")
cat(paste0("\n", tempo.cat, "\n"))
}
}
}else{
thread.nb <- tempo.thread.nb
}
if(verbose == TRUE){
tempo.cat <- paste0("NUMBER OF THREADS USED: ", thread.nb)
cat(paste0("\n    ", tempo.cat, "\n"))
}
Clust <- parallel::makeCluster(thread.nb, outfile = paste0(res.path, "/fun_slide_parall_log.txt")) # outfile to print or cat during parallelization (only possible in a file, outfile = "" do not work on windows)
cluster.list <- parallel::clusterSplit(Clust, 1:nrow(wind)) # split according to the number of cluster
if(verbose == TRUE){
tempo.cat <- paste0("SPLIT OF TEST NUMBERS IN PARALLELISATION:")
cat(paste0("\n    ", tempo.cat, "\n"))
str(cluster.list) # using print(str()) add a NULL below the result
cat("\n")
}
paral.output.list <- parallel::clusterApply( #
cl = Clust,
x = cluster.list,
function.name = function.name, 
data = data, 
FUN = fun, # because fun argument of clusterApply
args = args, 
thread.nb = thread.nb, 
print.count = print.count, 
wind = wind, 
left = left, 
right = right, 
res.path = res.path, 
lib.path = lib.path, 
verbose = verbose, 
cute.path = cute.path, 
fun = function(
x, 
function.name, 
data, 
FUN, 
args, 
thread.nb, 
print.count, 
wind, 
left, 
right, 
res.path, 
lib.path, 
verbose, 
cute.path
){
# check again: very important because another R
process.id <- Sys.getpid()
cat(paste0("\nPROCESS ID ", process.id, " -> TESTS ", x[1], " TO ", x[length(x)], "\n"))
source(cute.path, local = .GlobalEnv)
fun_pack(req.package = "lubridate", lib.path = lib.path, load = TRUE) # load = TRUE to be sure that functions are present in the environment. And this prevent to use R.lib.path argument of fun_python_pack()
# end check again: very important because another R
ini.date <- Sys.time()
ini.time <- as.numeric(ini.date) # time of process begin, converted into 
output <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
3697
print.count.loop <- 0
3698
for(i4 in 1:length(x)){
Gael  MILLOT's avatar
Gael MILLOT committed
3699
print.count.loop <- print.count.loop + 1
3700
log <- get(left)(data, wind$left[x[i4]]) & get(right)(data, wind$right[x[i4]]) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
3701
3702
output <- c(output, eval(parse(text = paste0("FUN(data[log]", if( ! is.null(args)){paste0(", ", args)}, ")"))))
if(verbose == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
3703
3704
3705
3706
if(print.count.loop == print.count){
print.count.loop <- 0
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
3707
final.loop <- (tempo.time - ini.time) / i4 * length(x) # expected duration in seconds # intra nb.compar loop lapse: time lapse / cycles done * cycles remaining
Gael  MILLOT's avatar
Gael MILLOT committed
3708
3709
3710
3711
3712
3713
3714
final.exp <- as.POSIXct(final.loop, origin = ini.date)
cat(paste0("\nIN PROCESS ", process.id, " | LOOP ", format(i4, big.mark=","), " / ", format(length(x), big.mark=","), " | TIME SPENT: ", tempo.lapse, " | EXPECTED END: ", final.exp))
}
if(i4 == length(x)){
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
cat(paste0("\nPROCESS ", process.id, " ENDED | LOOP ", format(i4, big.mark=","), " / ", format(length(x), big.mark=","), " | TIME SPENT: ", tempo.lapse, "\n\n"))
3715
3716
3717
3718
3719
}
}
}
wind <- wind[x, ]
if(length(output) != nrow(wind)){
3720
3721
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 4")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
3722
}else{
3723
output <- data.frame(wind, value = output, stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
3724
3725
return(output)
}
3726
}
3727
3728
3729
3730
3731
)
parallel::stopCluster(Clust)
# result assembly
output <- data.frame()
for(i2 in 1:length(paral.output.list)){ # compartment relatives to each parallelization
3732
output <- rbind(output, paral.output.list[[i2]], stringsAsFactors = TRUE)
3733
3734
3735
}
# end result assembly
if(nrow(output) != nrow(wind)){
3736
3737
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 5\nlength(output): ", length(output), "\nnrow(wind): ", nrow(wind))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
3738
3739
3740
3741
3742
3743
3744
3745
}else{
output <- output[order(output$left), ]
}
}
if(verbose == TRUE){
end.date <- Sys.time()
end.time <- as.numeric(end.date)
total.lapse <- round(lubridate::seconds_to_period(end.time - ini.time))
Gael's avatar
Gael committed
3746
cat(paste0("fun_slide JOB END\n\nTIME: ", end.date, "\n\nTOTAL TIME LAPSE: ", total.lapse, "\n\n\n"))
3747
3748
3749
}
return(output)
}
Gael  MILLOT's avatar
Gael MILLOT committed
3750
3751


Gael  MILLOT's avatar
Gael MILLOT committed
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
################ Graphics management


# this order can be used:
# fun_width()
# fun_open()
# fun_prior_plot() # not for ggplot2
# plot() or any other plotting
# fun_post_plot() if fun_prior_plot() has been used # not for ggplot2
# fun_close()


######## fun_width() #### window width depending on classes to plot


# Check OK: clear to go Apollo
Gael's avatar
tempo    
Gael committed
3768
3769
3770
3771
3772
3773
3774
3775
fun_width <- function(
class.nb, 
inches.per.class.nb = 1, 
ini.window.width = 7, 
inch.left.space, 
inch.right.space, 
boundarie.space = 0.5
){
Gael  MILLOT's avatar
Gael MILLOT committed
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
# AIM
# rescale the width of a window to open depending on the number of classes to plot
# can be used for height, considering that it is as if it was a width
# this order can be used:
# fun_width()
# fun_open()
# fun_prior_plot() # not for ggplot2
# plot() or any other plotting
# fun_post_plot() if fun_prior_plot() has been used # not for ggplot2
# fun_close()
# ARGUMENTS
# class.nb: number of class to plot
# inches.per.class.nb: number of inches per unit of class.nb. 2 means 2 inches for each boxplot for instance
# ini.window.width:initial window width in inches
# inch.left.space: left horizontal margin of the figure region (in inches)
# inch.right.space: right horizontal margin of the figure region (in inches)
# boundarie.space: space between the right and left limits of the plotting region and the plot (0.5 means half a class width)
# RETURN
# the new window width in inches
Gael's avatar
tempo    
Gael committed
3795
3796
3797
3798
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
3799
3800
3801
3802
3803
# EXAMPLES
# fun_width(class.nb = 10, inches.per.class.nb = 0.2, ini.window.width = 7, inch.left.space = 1, inch.right.space = 1, boundarie.space = 0.5)
# DEBUGGING
# class.nb = 10 ; inches.per.class.nb = 0.2 ; ini.window.width = 7 ; inch.left.space = 1 ; inch.right.space = 1 ; boundarie.space = 0.5 # for function debugging
# function name
3804
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3805
3806
3807
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
3808
3809
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = class.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = inches.per.class.nb, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = ini.window.width, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = inch.left.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = inch.right.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = boundarie.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end argument checking
# main code
range.max <- class.nb + boundarie.space # the max range of the future plot
range.min <- boundarie.space # the min range of the future plot
window.width <- inch.left.space + inch.right.space + inches.per.class.nb * (range.max - range.min)
return(window.width)
}


######## fun_open() #### open a GUI or pdf graphic window


# Check OK: clear to go Apollo
Gael's avatar
tempo    
Gael committed
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
fun_open <- function(
pdf = TRUE, 
pdf.path = "working.dir", 
pdf.name = "graph", 
width = 7, 
height = 7, 
paper = "special", 
pdf.overwrite = FALSE, 
rescale = "fixed", 
remove.read.only = TRUE, 
return.output = FALSE
){
Gael  MILLOT's avatar
Gael MILLOT committed
3852
# AIM
3853
# open a pdf or screen (GUI) graphic window and return initial graphic parameters
Gael  MILLOT's avatar
Gael MILLOT committed
3854
3855
3856
3857
3858
3859
3860
# this order can be used:
# fun_width()
# fun_open()
# fun_prior_plot() # not for ggplot2
# plot() or any other plotting
# fun_post_plot() if fun_prior_plot() has been used # not for ggplot2
# fun_close()
Gael's avatar
tempo    
Gael committed
3861
# WARNINGS
3862
# On Linux, use pdf = TRUE, if (GUI) graphic window is not always available, meaning that X is not installed (clusters for instance). Use X11() in R to test if available
Gael  MILLOT's avatar
Gael MILLOT committed
3863
# ARGUMENTS:
3864
# pdf: logical. Use pdf display? If FALSE, a GUI is opened
3865
# pdf.path: where the pdf is saved (do not terminate by / or \\). Write "working.dir" if working directory is required (default). Ignored if pdf == FALSE
3866
# pdf.name: name of the pdf file containing the graphs (the .pdf extension is added by the function, if not detected in the name end). Ignored if pdf == FALSE
3867
3868
3869
3870
# width: width of the window (in inches)
# height: height of the window (in inches)
# paper: paper argument of the pdf function (paper format). Only used for pdf(). Either "a4", "letter", "legal", "us", "executive", "a4r", "USr" or "special". If "special", means that the paper dimension will be width and height. With another paper format, if width or height is over the size of the paper, width or height will be modified such that the plot is adjusted to the paper dimension (see $dim in the returned list below to see the modified dimensions). Ignored if pdf == FALSE
# pdf.overwrite: logical. Existing pdf can be overwritten? . Ignored if pdf == FALSE
3871
# rescale: kind of GUI. Either "R", "fit", or "fixed". Ignored on Mac and Linux OS. See ?windows for details
3872
3873
# remove.read.only: logical. remove the read only (R.O.) graphical parameters? If TRUE, the graphical parameters are returned without the R.O. parameters. The returned $ini.par list can be used to set the par() of a new graphical device. If FALSE, graphical parameters are returned with the R.O. parameters, which provides information like text dimension (see ?par() ). The returned $ini.par list can be used to set the par() of a new graphical device, but generate a warning message. Ignored if return.output == FALSE. 
# return.output: logical. Return output ? If TRUE the output list is displayed
Gael  MILLOT's avatar
Gael MILLOT committed
3874
3875
3876
# RETURN
# a list containing:
# $pdf.loc: path of the pdf created
3877
3878
3879
# $ini.par: initial par() parameters
# $zone.ini: initial window spliting
# $dim: dimension of the graphical device (in inches)
Gael's avatar
tempo    
Gael committed
3880
3881
3882
3883
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
3884
# EXAMPLES
3885
# fun_open(pdf = FALSE, pdf.path = "C:/Users/Gael/Desktop", pdf.name = "graph", width = 7, height = 7, paper = "special", pdf.overwrite = FALSE, return.output = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
3886
# DEBUGGING
3887
# pdf = TRUE ; pdf.path = "C:/Users/Gael/Desktop" ; pdf.name = "graphs" ; width = 7 ; height = 7 ; paper = "special" ; pdf.overwrite = FALSE ; rescale = "fixed" ; remove.read.only = TRUE ; return.output = TRUE # for function debugging
Gael  MILLOT's avatar
Gael MILLOT committed
3888
# function name
3889
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3890
3891
3892
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
3893
3894
tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3895
3896
3897
3898
3899
3900
3901
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
3902
3903
tempo <- fun_check(data = pdf, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = pdf.path, class = "character", length = 1, fun.name = function.name) ; eval(ee)
3904
tempo <- fun_check(data = pdf.name, class = "character", length = 1, fun.name = function.name) ; eval(ee)
3905
3906
tempo <- fun_check(data = width, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = height, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
3907
tempo <- fun_check(data = paper, options = c("a4", "letter", "legal", "us", "executive", "a4r", "USr", "special", "A4", "LETTER", "LEGAL", "US"), length = 1, fun.name = function.name) ; eval(ee)
3908
tempo <- fun_check(data =pdf.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
3909
tempo <- fun_check(data = rescale, options = c("R", "fit", "fixed"), length = 1, fun.name = function.name) ; eval(ee)
3910
tempo <- fun_check(data = remove.read.only, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
3911
3912
3913
3914
3915
3916
3917
tempo <- fun_check(data = return.output, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end argument checking
# main code
3918
3919
if(pdf.path == "working.dir"){
pdf.path <- getwd()
Gael  MILLOT's avatar
Gael MILLOT committed
3920
}else{
3921
if(grepl(x = pdf.path, pattern = ".+/$")){
3922
3923
3924
pdf.path <- sub(x = pdf.path, pattern = "/$", replacement = "") # remove the last /
}else if(grepl(x = pdf.path, pattern = ".+[\\]$")){ # or ".+\\\\$" # cannot be ".+\$" because \$ does not exist contrary to \n
pdf.path <- sub(x = pdf.path, pattern = "[\\]$", replacement = "") # remove the last /
Gael  MILLOT's avatar
Gael MILLOT committed
3925
}
3926
if(dir.exists(pdf.path) == FALSE){
3927
3928
tempo.cat <- paste0("ERROR IN ", function.name, "\npdf.path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n", pdf.path)
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3929
3930
3931
3932
3933
3934
}
}
# par.ini recovery
# cannot use pdf(file = NULL), because some small differences between pdf() and other devices. For instance, differences with windows() for par()$fin, par()$pin and par()$plt
if(Sys.info()["sysname"] == "Windows"){ # Note that .Platform$OS.type() only says "unix" for macOS and Linux and "Windows" for Windows
open.fail <- NULL
3935
grDevices::windows()
3936
ini.par <- par(no.readonly = remove.read.only) # to recover the initial graphical parameters if required (reset). BEWARE: this command alone opens a pdf of GUI window if no window already opened. But here, protected with the code because always a tempo window opened
Gael  MILLOT's avatar
Gael MILLOT committed
3937
3938
invisible(dev.off()) # close the new window
}else if(Sys.info()["sysname"] == "Linux"){
3939
if(pdf == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
3940
tempo.code <- 0
3941
while(file.exists(paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf")) == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
3942
3943
tempo.code <- tempo.code + 1
}
3944
grDevices::pdf(width = width, height = height, file=paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf"), paper = paper)
3945
3946
ini.par <- par(no.readonly = remove.read.only) # to recover the initial graphical parameters if required (reset). BEWARE: this command alone opens a pdf of GUI window if no window already opened. But here, protected with the code because always a tempo window opened
invisible(dev.off()) # close the pdf window
3947
file.remove(paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf")) # remove the pdf file
Gael  MILLOT's avatar
Gael MILLOT committed
3948
3949
3950
}else{
# test if X11 can be opened
if(file.exists(paste0(getwd(), "/Rplots.pdf"))){
3951
3952
tempo.cat <- paste0("ERROR IN ", function.name, "\nTHIS FUNCTION CANNOT BE USED ON LINUX IF A Rplots.pdf FILE ALREADY EXISTS HERE\n", getwd())
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3953
}else{
3954
open.fail <- suppressWarnings(try(grDevices::X11(), silent = TRUE))[] # try to open a X11 window. If open.fail == NULL, no problem, meaning that the X11 window is opened. If open.fail != NULL, a pdf can be opened here paste0(getwd(), "/Rplots.pdf")
Gael  MILLOT's avatar
Gael MILLOT committed
3955
if(is.null(open.fail)){
3956
ini.par <- par(no.readonly = remove.read.only) # to recover the initial graphical parameters if required (reset). BEWARE: this command alone opens a pdf of GUI window if no window already opened. But here, protected with the code because always a tempo window opened
Gael  MILLOT's avatar
Gael MILLOT committed
3957
3958
3959
invisible(dev.off()) # close the new window
}else if(file.exists(paste0(getwd(), "/Rplots.pdf"))){
file.remove(paste0(getwd(), "/Rplots.pdf")) # remove the pdf file
3960
3961
tempo.cat <- ("ERROR IN fun_open()\nTHIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET)\nTO OVERCOME THIS, PLEASE SET pdf ARGUMENT TO TRUE AND RERUN")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3962
3963
3964
3965
3966
}
}
}
}else{
open.fail <- NULL
3967
grDevices::quartz()
3968
ini.par <- par(no.readonly = remove.read.only) # to recover the initial graphical parameters if required (reset). BEWARE: this command alone opens a pdf of GUI window if no window already opened. But here, protected with the code because always a tempo window opened
Gael  MILLOT's avatar
Gael MILLOT committed
3969
3970
3971
3972
invisible(dev.off()) # close the new window
}
# end par.ini recovery 
zone.ini <- matrix(1, ncol=1) # to recover the initial parameters for next figure region when device region split into several figure regions
3973
if(pdf == TRUE){
3974
3975
3976
3977
if(grepl(x = pdf.name, pattern = "\\.pdf$")){
pdf.name <- sub(x = pdf.name, pattern = "\\.pdf$", replacement = "") # remove the last .pdf
}
pdf.loc <- paste0(pdf.path, "/", pdf.name, ".pdf")
3978
if(file.exists(pdf.loc) == TRUE & pdf.overwrite == FALSE){
3979
3980
tempo.cat <- paste0("ERROR IN ", function.name, "\npdf.loc FILE ALREADY EXISTS AND CANNOT BE OVERWRITTEN DUE TO pdf.overwrite ARGUMENT SET TO TRUE\n", pdf.loc)
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3981
}else{
3982
grDevices::pdf(width = width, height = height, file=pdf.loc, paper = paper)
Gael  MILLOT's avatar
Gael MILLOT committed
3983
}
3984
}else if(pdf == FALSE){
Gael  MILLOT's avatar
Gael MILLOT committed
3985
3986
pdf.loc <- NULL
if(Sys.info()["sysname"] == "Windows"){ # .Platform$OS.type() only says "unix" for macOS and Linux and "Windows" for Windows
3987
grDevices::windows(width = width, height = height, rescale = rescale)
Gael  MILLOT's avatar
Gael MILLOT committed
3988
3989
}else if(Sys.info()["sysname"] == "Linux"){
if( ! is.null(open.fail)){
3990
3991
tempo.cat <- "ERROR IN fun_open()\nTHIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET)\nTO OVERCOME THIS, PLEASE SET pdf ARGUMENT TO TRUE AND RERUN"
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
Gael  MILLOT's avatar
Gael MILLOT committed
3992
}else{
3993
grDevices::X11(width = width, height = height)
Gael  MILLOT's avatar
Gael MILLOT committed
3994
3995
}
}else{
3996
grDevices::quartz(width = width, height = height)
Gael  MILLOT's avatar
Gael MILLOT committed
3997
3998
3999
}
}
if(return.output == TRUE){
4000
output <- list(pdf.loc = pdf.loc, ini.par = ini.par, zone.ini = zone.ini, dim = dev.size())