cute_little_R_functions.R 866 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
3001
# $count: the number of loops used
Gael's avatar
tempo    
Gael committed
3002
3003
3004
3005
3006
3007
# REQUIRED PACKAGES
# lubridate
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# fun_pack()
# fun_round()
Gael  MILLOT's avatar
Gael MILLOT committed
3008
3009
3010
3011
3012
# 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
3013
3014
# 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
3015
# a way to use the cor.limit argument just considering data1
Gael  MILLOT's avatar
Gael MILLOT committed
3016
3017
3018
3019
# 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
3020
# DEBUGGING
Gael  MILLOT's avatar
Gael MILLOT committed
3021
3022
3023
3024
# 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
3025
# function name
3026
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3027
3028
3029
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
3030
3031
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
3032
3033
}
if(length(utils::find("fun_pack", mode = "function")) == 0){
3034
3035
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
3036
3037
}
if(length(utils::find("fun_round", mode = "function")) == 0){
3038
3039
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
3040
3041
3042
3043
3044
3045
3046
3047
3048
}
# 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){
3049
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
3050
3051
3052
3053
3054
3055
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){
3056
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
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
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)){
3067
tempo.cat <- paste0("ERROR IN ", function.name, ": n ARGUMENT CANNOT BE NULL IF data2 ARGUMENT IS NULL")
Gael  MILLOT's avatar
Gael MILLOT committed
3068
3069
3070
3071
3072
3073
3074
3075
3076
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)){
tempo <- fun_check(data = seed, 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
3077
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
3078
3079
3080
3081
3082
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
3083
3084
3085
3086
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
3087
3088
3089
3090
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
3091
}
Gael  MILLOT's avatar
Gael MILLOT committed
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
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
}
# end code that protects set.seed() in the global environment
if( ! is.null(seed)){
set.seed(seed)
}
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
3119
3120
3121
ini.warning.length <- options()$warning.length
options(warning.length = 8170)
on.exit(exp = options(warning.length = ini.warning.length))
Gael  MILLOT's avatar
Gael MILLOT committed
3122
warn <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
3123
warn.count <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3124
3125
3126
3127
3128
3129
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
3130
warn.count <- warn.count + 1
3131
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
3132
3133
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) #
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
3134
3135
if(print.count > n){
print.count <- n
Gael  MILLOT's avatar
Gael MILLOT committed
3136
3137
}
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
3138
3139
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
3140
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3141
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
3142
3143
3144
3145
3146
3147
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
3148
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3149
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3150
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
3151
3152
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3153
final.loop <- (tempo.time - tempo.time.loop) / i3 * n # expected duration in seconds
Gael  MILLOT's avatar
Gael MILLOT committed
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
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
3164
warn.count <- warn.count + 1
3165
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
3166
3167
3168
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
3169
warn.count <- warn.count + 1
3170
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
3171
3172
3173
3174
3175
3176
3177
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
3178
warn.count <- warn.count + 1
3179
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
3180
3181
3182
3183
3184
3185
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
3186
warn.count <- warn.count + 1
3187
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
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
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
3204
3205
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
3206
count.loop <- 0 # 
Gael  MILLOT's avatar
Gael MILLOT committed
3207
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
3208
3209
3210
3211
3212
3213
3214
3215
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
3216
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3217
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3218
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
3219
3220
3221
3222
3223
3224
3225
3226
3227
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
3228
warn.count <- warn.count + 1
3229
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
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
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)){
3258
3259
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
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
}
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)){
3277
3278
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
3279
3280
3281
3282
3283
}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
3284
3285
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
3286
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3287
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
3288
3289
3290
3291
3292
3293
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
3294
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3295
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3296
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
3297
3298
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3299
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
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
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
3316
3317
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
3318
count.loop <- 0 # 
Gael  MILLOT's avatar
Gael MILLOT committed
3319
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
3320
3321
3322
3323
3324
3325
3326
3327
3328
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
3329
if(print.count.loop[count.loop]){
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) # BEWARE: never forget to resample here
Gael  MILLOT's avatar
Gael MILLOT committed
3332
3333
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3334
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
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
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)){
3350
warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
3351
3352
3353
3354
3355
3356
}
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
3357
3358
3359
######## fun_slide() #### return a computation made on a vector using a sliding window


Gael's avatar
tempo    
Gael committed
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
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
3377
3378
# AIM
# return a computation made on a vector using a sliding window
Gael's avatar
tempo    
Gael committed
3379
# WARNINGS
Gael's avatar
Gael committed
3380
3381
# 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
3382
3383
3384
3385
# 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
3386
# 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
3387
# 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
3388
# fun: function or character string (without brackets) indicating the name of the function to apply in each window. Example: fun = "mean", or fun = mean
3389
# 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
3390
# 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
3391
# parall: logical. Force parallelization ?
3392
3393
3394
# 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
3395
# lib.path: character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
3396
3397
# 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
3398
3399
3400
3401
3402
3403
# 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
3404
3405
3406
3407
3408
3409
3410
# REQUIRED PACKAGES
# lubridate
# parallel if parallelization is used (included in the R installation packages)
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# fun_get_message
# fun_pack()
Gael  MILLOT's avatar
Gael MILLOT committed
3411
3412
# EXAMPLES
# fun_slide(data = c(1:10, 100:110, 500), window.size = 5, step = 2, fun = length, boundary = "left")
Gael's avatar
Gael committed
3413
3414
# 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
3415
# DEBUGGING
Gael's avatar
Gael committed
3416
# 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
3417
# 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
3418
# function name
3419
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3420
3421
3422
3423
instruction <- match.call()
# end function name
# required function checking
req.function <- c(
Gael's avatar
Gael committed
3424
3425
3426
"fun_check", 
"fun_get_message", 
"fun_pack"
Gael  MILLOT's avatar
Gael MILLOT committed
3427
3428
3429
)
for(i1 in req.function){
if(length(find(i1, mode = "function")) == 0){
3430
3431
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
3432
3433
3434
3435
3436
3437
}
}
# end required function checking
# argument primary checking
# arg with no default values
if(any(missing(data) | missing(window.size) | missing(step) | missing(fun))){
3438
3439
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
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
}
# 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)
3450
3451
if( ! is.null(from)){
tempo <- fun_check(data = from, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
3452
}
3453
3454
if( ! is.null(to)){
tempo <- fun_check(data = to, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
3455
}
Gael  MILLOT's avatar
Gael MILLOT committed
3456
3457
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
3458
3459
3460
3461
3462
3463
3464
3465
3466
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)
3467
3468
3469
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
3470
tempo <- fun_check(data = parall, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
3471
3472
3473
3474
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
3475
3476
3477
if( ! is.null(lib.path)){
tempo <- fun_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
}
3478
3479
3480
3481
3482
3483
3484
3485
3486
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
3487
3488
3489
3490
3491
3492
3493
3494
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
3495
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))){
3496
3497
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
3498
3499
3500
}
# end dealing with NA
# dealing with NULL
Gael's avatar
Gael committed
3501
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)){
3502
3503
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
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
}
# 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)
}
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
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
3528
3529
3530
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"))
3531
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
3532
3533
3534
}
}
# end second round of checking and data preparation
3535
3536
3537
3538
# 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
3539
# main code
3540
3541
3542
3543
3544
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
3545
3546
3547
3548
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 <- "<"
3549
right.last.wind <- ">"
Gael  MILLOT's avatar
Gael MILLOT committed
3550
3551
3552
}else if(boundary == "right"){
left <- ">"
right <- "<="
3553
right.last.wind <- ">="
Gael  MILLOT's avatar
Gael MILLOT committed
3554
}else{
3555
3556
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
3557
}
3558
3559
data <- as.vector(data)
data <- sort(data, na.last = NA) # NA removed
3560
3561
3562
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)
3563
if(all(wind$right < if(is.null(to)){max(data, na.rm = TRUE)}else{to})){
3564
3565
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 ==
3566
3567
3568
3569
3570
}
# 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),]
# }
3571
3572
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
3573
3574
3575
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
3576

Gael's avatar
Gael committed
3577
3578
# test if lapply can be used
if(parall == FALSE){
Gael's avatar
Gael committed
3579
3580
3581
# new environment
env.name <- paste0("env", ini.time)
if(exists(env.name, where = -1)){
3582
3583
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
3584
3585
}else{
assign(env.name, new.env())
3586
3587
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
3588
3589
}
# end new environment
3590
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
3591
rm(env.name) # optional, because should disappear at the end of the function execution
Gael's avatar
Gael committed
3592
3593
3594
}else{
tempo.message <- "ERROR" # with this, force the parallelization by default
}
3595
# end test if lapply can be used
Gael's avatar
Gael committed
3596
if( ! any(grepl(x = tempo.message, pattern = "ERROR.*"))){
Gael  MILLOT's avatar
Gael MILLOT committed
3597
left.log <- lapply(X = wind$left, Y = data, FUN = function(X, Y){
3598
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
3599
3600
3601
return(res)
})
right.log <- lapply(X = wind$right, Y = data, FUN = function(X, Y){
3602
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
3603
3604
3605
return(res)
})
log <- mapply(FUN = "&", left.log, right.log, SIMPLIFY = FALSE)
3606
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
3607
if(length(output) != nrow(wind)){
3608
3609
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 ==
3610
}else{
3611
output <- data.frame(wind, value = output, stringsAsFactors = TRUE)
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
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
}
}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
3683
print.count.loop <- 0
3684
for(i4 in 1:length(x)){
Gael  MILLOT's avatar
Gael MILLOT committed
3685
print.count.loop <- print.count.loop + 1
3686
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
3687
3688
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
3689
3690
3691
3692
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))
3693
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
3694
3695
3696
3697
3698
3699
3700
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"))
3701
3702
3703
3704
3705
}
}
}
wind <- wind[x, ]
if(length(output) != nrow(wind)){
3706
3707
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 ==
3708
}else{
3709
output <- data.frame(wind, value = output, stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
3710
3711
return(output)
}
3712
}
3713
3714
3715
3716
3717
)
parallel::stopCluster(Clust)
# result assembly
output <- data.frame()
for(i2 in 1:length(paral.output.list)){ # compartment relatives to each parallelization
3718
output <- rbind(output, paral.output.list[[i2]], stringsAsFactors = TRUE)
3719
3720
3721
}
# end result assembly
if(nrow(output) != nrow(wind)){
3722
3723
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 ==
3724
3725
3726
3727
3728
3729
3730
3731
}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
3732
cat(paste0("fun_slide JOB END\n\nTIME: ", end.date, "\n\nTOTAL TIME LAPSE: ", total.lapse, "\n\n\n"))
3733
3734
3735
}
return(output)
}
Gael  MILLOT's avatar
Gael MILLOT committed
3736
3737


Gael  MILLOT's avatar
Gael MILLOT committed
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
################ 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
3754
3755
3756
3757
3758
3759
3760
3761
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
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
# 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
3781
3782
3783
3784
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
3785
3786
3787
3788
3789
# 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
3790
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3791
3792
3793
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
3794
3795
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
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
}
# 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
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
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
3838
# AIM
3839
# open a pdf or screen (GUI) graphic window and return initial graphic parameters
Gael  MILLOT's avatar
Gael MILLOT committed
3840
3841
3842
3843
3844
3845
3846
# 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
3847
# WARNINGS
3848
# 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
3849
# ARGUMENTS:
3850
# pdf: logical. Use pdf display? If FALSE, a GUI is opened
3851
# 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
3852
# 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
3853
3854
3855
3856
# 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
3857
# rescale: kind of GUI. Either "R", "fit", or "fixed". Ignored on Mac and Linux OS. See ?windows for details
3858
3859
# 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
3860
3861
3862
# RETURN
# a list containing:
# $pdf.loc: path of the pdf created
3863
3864
3865
# $ini.par: initial par() parameters
# $zone.ini: initial window spliting
# $dim: dimension of the graphical device (in inches)
Gael's avatar
tempo    
Gael committed
3866
3867
3868
3869
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael  MILLOT's avatar
Gael MILLOT committed
3870
# EXAMPLES
3871
# 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
3872
# DEBUGGING
3873
# pdf = TRUE ; pdf.path = "C:/Users/Gael/Desktop" ; pdf.name = "graphs" ; width = 7 ; height = 7 ; paper = "special" ; pdf.overwrite = FALSE ; remove.read.only = TRUE ; return.output = TRUE # for function debugging
Gael  MILLOT's avatar
Gael MILLOT committed
3874
# function name
3875
function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
Gael  MILLOT's avatar
Gael MILLOT committed
3876
3877
3878
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
3879
3880
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
3881
3882
3883
3884
3885
3886
3887
}
# 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))
3888
3889
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)
3890
tempo <- fun_check(data = pdf.name, class = "character", length = 1, fun.name = function.name) ; eval(ee)
3891
3892
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
3893
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)
3894
tempo <- fun_check(data =pdf.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
3895
tempo <- fun_check(data = rescale, options = c("R", "fit", "fixed"), length = 1, fun.name = function.name) ; eval(ee)
3896
tempo <- fun_check(data = remove.read.only, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
3897
3898
3899
3900
3901
3902
3903
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
3904
3905
if(pdf.path == "working.dir"){
pdf.path <- getwd()
Gael  MILLOT's avatar
Gael MILLOT committed
3906
}else{
3907
if(grepl(x = pdf.path, pattern = ".+/$")){
3908
3909
3910
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
3911
}
3912
if(dir.exists(pdf.path) == FALSE){
3913
3914
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
3915
3916
3917
3918
3919
3920
3921
}
}
# 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
windows()
3922
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
3923
3924
invisible(dev.off()) # close the new window
}else if(Sys.info()["sysname"] == "Linux"){
3925
if(pdf == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
3926
tempo.code <- 0
3927
while(file.exists(paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf")) == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
3928
3929
tempo.code <- tempo.code + 1
}
3930
pdf(width = width, height = height, file=paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf"), paper = paper)
3931
3932
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
3933
file.remove(paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf")) # remove the pdf file
Gael  MILLOT's avatar
Gael MILLOT committed
3934
3935
3936
}else{
# test if X11 can be opened
if(file.exists(paste0(getwd(), "/Rplots.pdf"))){
3937
3938
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
3939
3940
3941
}else{
open.fail <- suppressWarnings(try(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")
if(is.null(open.fail)){
3942
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
3943
3944
3945
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
3946
3947
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
3948
3949
3950
3951
3952
3953
}
}
}
}else{
open.fail <- NULL
quartz()
3954
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
3955
3956
3957
3958
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
3959
if(pdf == TRUE){
3960
3961
3962
3963
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")
3964
if(file.exists(pdf.loc) == TRUE & pdf.overwrite == FALSE){
3965
3966
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
3967
}else{
3968
pdf(width = width, height = height, file=pdf.loc, paper = paper)
Gael  MILLOT's avatar
Gael MILLOT committed
3969
}
3970
}else if(pdf == FALSE){
Gael  MILLOT's avatar
Gael MILLOT committed
3971
3972
pdf.loc <- NULL
if(Sys.info()["sysname"] == "Windows"){ # .Platform$OS.type() only says "unix" for macOS and Linux and "Windows" for Windows
3973
windows(width = width, height = height, rescale = rescale)
Gael  MILLOT's avatar
Gael MILLOT committed
3974
3975
}else if(Sys.info()["sysname"] == "Linux"){
if( ! is.null(open.fail)){
3976
3977
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
3978
}else{
3979
X11(width = width, height = height)
Gael  MILLOT's avatar
Gael MILLOT committed
3980
3981
}
}else{
3982
quartz(width = width, height = height)
Gael  MILLOT's avatar
Gael MILLOT committed
3983
3984
3985
}
}
if(return.output == TRUE){
3986
output <- list(pdf.loc = pdf.loc, ini.par = ini.par, zone.ini = zone.ini, dim = dev.size())
Gael  MILLOT's avatar
Gael MILLOT committed
3987
3988
3989
3990
3991
3992
3993
3994
3995
return(output)
}
}


######## fun_prior_plot() #### set graph param before plotting (erase axes for instance)


# Check OK: clear to go Apollo
Gael's avatar
tempo    
Gael committed
3996
3997
3998
3999
4000
fun_prior_plot <- function(
param.reinitial = FALSE, 
xlog.scale = FALSE, 
ylog.scale = FALSE, 
remove.label = TRUE, 
For faster browsing, not all history is shown. View entire blame