cute_little_R_functions.R 829 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
3001
print.count <- n
Gael  MILLOT's avatar
Gael MILLOT committed
3002
3003
}
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
3004
3005
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
3006
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3007
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
3008
3009
3010
3011
3012
3013
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
3014
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3015
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3016
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
3017
3018
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3019
final.loop <- (tempo.time - tempo.time.loop) / i3 * n # expected duration in seconds
Gael  MILLOT's avatar
Gael MILLOT committed
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
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
3030
3031
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NO PERMUTATION PERFORMED BECAUSE data1 ARGUMENT SEEMS TO BE MADE OF IDENTICAL ELEMENTS: ", names(table(data1)))
Gael  MILLOT's avatar
Gael MILLOT committed
3032
3033
3034
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
3035
3036
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NO PERMUTATION PERFORMED BECAUSE data2 ARGUMENT SEEMS TO BE MADE OF IDENTICAL ELEMENTS: ", names(table(data2)))
Gael  MILLOT's avatar
Gael MILLOT committed
3037
3038
3039
3040
3041
3042
3043
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
3044
3045
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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
3046
3047
3048
3049
3050
3051
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
3052
3053
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
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
3070
3071
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
3072
count.loop <- 0 # 
Gael  MILLOT's avatar
Gael MILLOT committed
3073
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
3074
3075
3076
3077
3078
3079
3080
3081
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
3082
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3083
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3084
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
3085
3086
3087
3088
3089
3090
3091
3092
3093
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
3094
3095
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE FIRST FOR & WHILE LOOP STEPS HAVE BEEN TOO FAR AND SUBSEQUENT LOOP STEPS WILL NOT RUN")
Gael  MILLOT's avatar
Gael MILLOT committed
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
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)){
tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 2\ncor.est.ini: ", cor.est.ini, "\ntempo.cor.est: ", tempo.cor.est, "\n\n============\n\n")
stop(tempo.cat, call. = FALSE)
}
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)){
tempo.cat <- paste0("\n\n============\n\nERROR 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, "\n\n============\n\n")
stop(tempo.cat, call. = FALSE)
}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
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(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
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) / 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
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
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
3182
3183
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
3184
count.loop <- 0 # 
Gael  MILLOT's avatar
Gael MILLOT committed
3185
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
3186
3187
3188
3189
3190
3191
3192
3193
3194
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
3195
if(print.count.loop[count.loop]){
Gael  MILLOT's avatar
Gael MILLOT committed
3196
count.loop <- 0
Gael  MILLOT's avatar
Gael MILLOT committed
3197
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
3198
3199
tempo.time <- as.numeric(Sys.time())
tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - tempo.time.loop))
3200
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
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
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)){
Gael  MILLOT's avatar
Gael MILLOT committed
3216
warning(warn, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
3217
3218
3219
3220
3221
3222
3223
cat("\n\n")
}
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
3224
3225
3226
######## fun_slide() #### return a computation made on a vector using a sliding window


Gael's avatar
Gael committed
3227
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
3228
3229
# AIM
# return a computation made on a vector using a sliding window
3230
# WARNING
Gael's avatar
Gael committed
3231
3232
# 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
3233
3234
3235
3236
# 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
3237
# 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
3238
# 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
3239
# fun: function or character string (without brackets) indicating the name of the function to apply in each window. Example: fun = "mean", or fun = mean
3240
# 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
3241
# 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
3242
# parall: logical. Force parallelization ?
3243
3244
3245
# 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
3246
# lib.path: character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
3247
3248
# 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
3249
# REQUIRED PACKAGES
3250
3251
# lubridate
# parallel if parallelization is used
Gael  MILLOT's avatar
Gael MILLOT committed
3252
3253
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
Gael's avatar
Gael committed
3254
# fun_get_message
3255
# fun_pack()
Gael  MILLOT's avatar
Gael MILLOT committed
3256
3257
3258
3259
3260
3261
3262
3263
# 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)
# EXAMPLES
# fun_slide(data = c(1:10, 100:110, 500), window.size = 5, step = 2, fun = length, boundary = "left")
Gael's avatar
Gael committed
3264
3265
# 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
3266
# DEBUGGING
Gael's avatar
Gael committed
3267
# 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
3268
# 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
3269
3270
3271
3272
3273
3274
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
instruction <- match.call()
# end function name
# required function checking
req.function <- c(
Gael's avatar
Gael committed
3275
3276
3277
"fun_check", 
"fun_get_message", 
"fun_pack"
Gael  MILLOT's avatar
Gael MILLOT committed
3278
3279
3280
3281
)
for(i1 in req.function){
if(length(find(i1, mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED ", i1, "() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
Gael's avatar
Gael committed
3282
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
3283
3284
3285
3286
3287
3288
}
}
# end required function checking
# argument primary checking
# arg with no default values
if(any(missing(data) | missing(window.size) | missing(step) | missing(fun))){
3289
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": ARGUMENTS fun, args AND val HAVE NO DEFAULT VALUE AND REQUIRE ONE\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
stop(tempo.cat, call. = FALSE)
}
# 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)
3301
3302
if( ! is.null(from)){
tempo <- fun_check(data = from, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
3303
}
3304
3305
if( ! is.null(to)){
tempo <- fun_check(data = to, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
3306
}
Gael  MILLOT's avatar
Gael MILLOT committed
3307
3308
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
3309
3310
3311
3312
3313
3314
3315
3316
3317
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)
3318
3319
3320
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
3321
tempo <- fun_check(data = parall, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
3322
3323
3324
3325
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
3326
3327
3328
if( ! is.null(lib.path)){
tempo <- fun_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
}
3329
3330
3331
3332
3333
3334
3335
3336
3337
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
3338
3339
3340
3341
3342
3343
3344
3345
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
3346
3347
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))){
tempo.cat <- paste0("\n\n================\n\nERROR 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"), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3348
3349
3350
3351
stop(tempo.cat, call. = FALSE)
}
# end dealing with NA
# dealing with NULL
Gael's avatar
Gael committed
3352
3353
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)){
tempo.cat <- paste0("\n\n================\n\nERROR 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"), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
stop(tempo.cat, call. = FALSE)
}
# 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)
}
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
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
3379
3380
3381
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"))
3382
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
3383
3384
3385
}
}
# end second round of checking and data preparation
3386
3387
3388
3389
# 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
3390
# main code
3391
3392
3393
3394
3395
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
3396
3397
3398
3399
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 <- "<"
3400
right.last.wind <- ">"
Gael  MILLOT's avatar
Gael MILLOT committed
3401
3402
3403
}else if(boundary == "right"){
left <- ">"
right <- "<="
3404
right.last.wind <- ">="
Gael  MILLOT's avatar
Gael MILLOT committed
3405
3406
}else{
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 1\n\n============\n\n")
Gael's avatar
Gael committed
3407
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
3408
}
3409
3410
3411
3412
3413
3414
3415
data <- as.vector(data)
data <- sort(data, na.last = NA) # NA removed
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))
wind <- data.frame(wind, right = wind$left + window.size)
wind <- data.frame(wind, center = (wind$left + wind$right) / 2)
if(all(wind$right < if(is.null(to)){max(data, na.rm = TRUE)}else{to})){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 2\n\n============\n\n")
Gael's avatar
Gael committed
3416
stop(tempo.cat, call. = FALSE)
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
}
# 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),]
# }
if(sum(get(right.last.wind)(wind$right, if(is.null(to)){max(data, na.rm = TRUE)}else{to}), na.rm = TRUE) > 1){
tempo.log <- get(right.last.wind)(wind$right, if(is.null(to)){max(data, na.rm = TRUE)}else{to})
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
3427

Gael's avatar
Gael committed
3428
3429
# test if lapply can be used
if(parall == FALSE){
Gael's avatar
Gael committed
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
# new environment
env.name <- paste0("env", ini.time)
if(exists(env.name, where = -1)){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE\n\n============\n\n")
stop(tempo.cat, call. = FALSE)
}else{
assign(env.name, new.env())
assign("wind", wind, envir = get(env.name))
assign("data", data, envir = get(env.name))
}
# end new environment
Gael's avatar
Gael committed
3441
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), print.no = FALSE)
Gael's avatar
Gael committed
3442
rm(env.name) # optional, because should disappear at the end of the function execution
Gael's avatar
Gael committed
3443
3444
3445
}else{
tempo.message <- "ERROR" # with this, force the parallelization by default
}
3446
# end test if lapply can be used
Gael's avatar
Gael committed
3447
if( ! any(grepl(x = tempo.message, pattern = "ERROR.*"))){
Gael  MILLOT's avatar
Gael MILLOT committed
3448
3449
3450
3451
3452
3453
3454
3455
3456
left.log <- lapply(X = wind$left, Y = data, FUN = function(X, Y){
res <- get(left)(Y, X)
return(res)
})
right.log <- lapply(X = wind$right, Y = data, FUN = function(X, Y){
res <- get(right)(Y, X)
return(res)
})
log <- mapply(FUN = "&", left.log, right.log, SIMPLIFY = FALSE)
3457
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
3458
if(length(output) != nrow(wind)){
3459
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 3\n\n============\n\n")
Gael's avatar
Gael committed
3460
stop(tempo.cat, call. = FALSE)
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
}else{
output <- data.frame(wind, value = output)
}
}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
3534
print.count.loop <- 0
3535
for(i4 in 1:length(x)){
Gael  MILLOT's avatar
Gael MILLOT committed
3536
print.count.loop <- print.count.loop + 1
3537
3538
3539
log <- get(left)(data, wind$left[x[i4]]) & get(right)(data, wind$right[x[i4]])
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
3540
3541
3542
3543
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))
3544
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
3545
3546
3547
3548
3549
3550
3551
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"))
3552
3553
3554
3555
3556
3557
}
}
}
wind <- wind[x, ]
if(length(output) != nrow(wind)){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 4\n\n============\n\n")
Gael's avatar
Gael committed
3558
stop(tempo.cat, call. = FALSE)
3559
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
3560
3561
3562
output <- data.frame(wind, value = output)
return(output)
}
3563
}
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
)
parallel::stopCluster(Clust)
# result assembly
output <- data.frame()
for(i2 in 1:length(paral.output.list)){ # compartment relatives to each parallelization
output <- rbind(output, paral.output.list[[i2]])
}
# end result assembly
if(nrow(output) != nrow(wind)){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 5\nlength(output): ", length(output), "\nnrow(wind): ", nrow(wind), "\n\n============\n\n")
Gael's avatar
Gael committed
3574
stop(tempo.cat, call. = FALSE)
3575
3576
3577
3578
3579
3580
3581
3582
}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
3583
cat(paste0("fun_slide JOB END\n\nTIME: ", end.date, "\n\nTOTAL TIME LAPSE: ", total.lapse, "\n\n\n"))
3584
3585
3586
}
return(output)
}
Gael  MILLOT's avatar
Gael MILLOT committed
3587
3588


Gael  MILLOT's avatar
Gael MILLOT committed
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
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
################ 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
fun_width <- function(class.nb, inches.per.class.nb = 1, ini.window.width = 7, inch.left.space, inch.right.space, boundarie.space = 0.5){
# 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()
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# 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
# 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
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# 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
3668
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
3669
# AIM
3670
# open a pdf or screen (GUI) graphic window and return initial graphic parameters
Gael  MILLOT's avatar
Gael MILLOT committed
3671
3672
3673
3674
3675
3676
3677
# 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()
3678
#WARNING
3679
# 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
3680
3681
3682
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS:
3683
# pdf: logical. Use pdf display? If FALSE, a GUI is opened
3684
# 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
3685
# 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
3686
3687
3688
3689
# 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
3690
# rescale: kind of GUI. Either "R", "fit", or "fixed". Ignored on Mac and Linux OS. See ?windows for details
3691
3692
# 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
3693
3694
3695
# RETURN
# a list containing:
# $pdf.loc: path of the pdf created
3696
3697
3698
# $ini.par: initial par() parameters
# $zone.ini: initial window spliting
# $dim: dimension of the graphical device (in inches)
Gael  MILLOT's avatar
Gael MILLOT committed
3699
# EXAMPLES
3700
# 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
3701
# DEBUGGING
3702
# 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
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# 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))
3717
3718
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)
3719
tempo <- fun_check(data = pdf.name, class = "character", length = 1, fun.name = function.name) ; eval(ee)
3720
3721
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
3722
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)
3723
tempo <- fun_check(data =pdf.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
3724
tempo <- fun_check(data = rescale, options = c("R", "fit", "fixed"), length = 1, fun.name = function.name) ; eval(ee)
3725
tempo <- fun_check(data = remove.read.only, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
3726
3727
3728
3729
3730
3731
3732
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
3733
3734
if(pdf.path == "working.dir"){
pdf.path <- getwd()
Gael  MILLOT's avatar
Gael MILLOT committed
3735
}else{
3736
if(grepl(x = pdf.path, pattern = ".+/$")){
3737
3738
3739
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
3740
}
3741
if(dir.exists(pdf.path) == FALSE){
3742
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, "\npdf.path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n", pdf.path, "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3743
3744
3745
3746
3747
3748
3749
3750
stop(tempo.cat, call. = FALSE)
}
}
# 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()
3751
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
3752
3753
invisible(dev.off()) # close the new window
}else if(Sys.info()["sysname"] == "Linux"){
3754
if(pdf == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
3755
tempo.code <- 0
3756
while(file.exists(paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf")) == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
3757
3758
tempo.code <- tempo.code + 1
}
3759
pdf(width = width, height = height, file=paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf"), paper = paper)
3760
3761
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
3762
file.remove(paste0(pdf.path, "/recover_ini_par", tempo.code, ".pdf")) # remove the pdf file
Gael  MILLOT's avatar
Gael MILLOT committed
3763
3764
3765
}else{
# test if X11 can be opened
if(file.exists(paste0(getwd(), "/Rplots.pdf"))){
3766
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, "\nTHIS FUNCTION CANNOT BE USED ON LINUX IF A Rplots.pdf FILE ALREADY EXISTS HERE\n", getwd(), "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3767
3768
3769
3770
stop(tempo.cat, call. = FALSE)
}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)){
3771
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
3772
3773
3774
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
3775
tempo.cat <- ("\n\n================\n\nERROR 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\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3776
3777
3778
3779
3780
3781
3782
stop(tempo.cat, call. = FALSE)
}
}
}
}else{
open.fail <- NULL
quartz()
3783
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
3784
3785
3786
3787
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
3788
if(pdf == TRUE){
3789
3790
3791
3792
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")
3793
if(file.exists(pdf.loc) == TRUE & pdf.overwrite == FALSE){
3794
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, "\npdf.loc FILE ALREADY EXISTS AND CANNOT BE OVERWRITTEN DUE TO pdf.overwrite ARGUMENT SET TO TRUE\n", pdf.loc, "\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3795
3796
stop(tempo.cat, call. = FALSE)
}else{
3797
pdf(width = width, height = height, file=pdf.loc, paper = paper)
Gael  MILLOT's avatar
Gael MILLOT committed
3798
}
3799
}else if(pdf == FALSE){
Gael  MILLOT's avatar
Gael MILLOT committed
3800
3801
pdf.loc <- NULL
if(Sys.info()["sysname"] == "Windows"){ # .Platform$OS.type() only says "unix" for macOS and Linux and "Windows" for Windows
3802
windows(width = width, height = height, rescale = rescale)
Gael  MILLOT's avatar
Gael MILLOT committed
3803
3804
}else if(Sys.info()["sysname"] == "Linux"){
if( ! is.null(open.fail)){
3805
tempo.cat <- "\n\n================\n\nERROR 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\n\n================\n\n"
Gael  MILLOT's avatar
Gael MILLOT committed
3806
3807
stop(tempo.cat, call. = FALSE)
}else{
3808
X11(width = width, height = height)
Gael  MILLOT's avatar
Gael MILLOT committed
3809
3810
}
}else{
3811
quartz(width = width, height = height)
Gael  MILLOT's avatar
Gael MILLOT committed
3812
3813
3814
}
}
if(return.output == TRUE){
3815
output <- list(pdf.loc = pdf.loc, ini.par = ini.par, zone.ini = zone.ini, dim = dev.size())
Gael  MILLOT's avatar
Gael MILLOT committed
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
return(output)
}
}


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


# Check OK: clear to go Apollo
fun_prior_plot <- function(param.reinitial = FALSE, xlog.scale = FALSE, ylog.scale = FALSE, remove.label = TRUE, remove.x.axis = TRUE, remove.y.axis = TRUE, std.x.range = TRUE, std.y.range = TRUE, down.space = 1, left.space = 1, up.space = 1, right.space = 1, orient = 1, dist.legend = 3.5, tick.length = 0.5, box.type = "n", amplif.label = 1, amplif.axis = 1, display.extend = FALSE, return.par = FALSE){
# AIM
# very convenient to erase the axes for post plot axis redrawing using fun_post_plot()
# reinitialize and set the graphic parameters before plotting
# CANNOT be used if no graphic device already opened
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS
# param.reinitial: reinitialize graphic parameters before applying the new ones, as defined by the other arguments? Either TRUE or FALSE
# xlog.scale: Log scale for the x-axis? Either TRUE or FALSE. If TRUE, erases the x-axis, except legend, for further drawing by fun_post_plot()(xlog argument of par())
# ylog.scale: Log scale for the y-axis? Either TRUE or FALSE. If TRUE, erases the y-axis, except legend, for further drawing by fun_post_plot()(ylog argument of par())
# remove.label: remove labels (axis legend) of the two axes? Either TRUE or FALSE (ann argument of par())
# remove.x.axis: remove x-axis except legend? Either TRUE or FALSE (control the xaxt argument of par()). Automately set to TRUE if xlog.scale == TRUE
# remove.y.axis: remove y-axis except legend? Either TRUE or FALSE (control the yaxt argument of par()). Automately set to TRUE if ylog.scale == TRUE
# std.x.range: standard range on the x-axis? TRUE (no range extend) or FALSE (4% range extend). Controls xaxs argument of par() (TRUE is xaxs = "i", FALSE is xaxs = "r")
# std.y.range: standard range on the y-axis? TRUE (no range extend) or FALSE (4% range extend). Controls yaxs argument of par() (TRUE is yaxs = "i", FALSE is yaxs = "r")
# down.space: lower vertical margin (in inches, mai argument of par())
# left.space: left horizontal margin (in inches, mai argument of par())
# up.space: upper vertical margin between plot region and grapical window (in inches, mai argument of par())
# right.space: right horizontal margin (in inches, mai argument of par())
# orient: scale number orientation (las argument of par()). 0, always parallel to the axis; 1, always horizontal; 2, always perpendicular to the axis; 3, always vertical
# dist.legend: numeric value that moves axis legends away in inches (first number of mgp argument of par() but in inches thus / 0.2)
# tick.length: length of the ticks (1 means complete the distance between the plot region and the axis numbers, 0.5 means half the length, etc. 0 means no tick
# box.type: bty argument of par(). Either "o", "l", "7", "c", "u", "]", the resulting box resembles the corresponding upper case letter. A value of "n" suppresses the box
# amplif.label: increase or decrease the size of the text in legends
# amplif.axis: increase or decrease the size of the scale numbers in axis
# display.extend: extend display beyond plotting region? Either TRUE or FALSE (xpd argument of par() without NA)
# return.par: return graphic parameter modification?
# RETURN
# return graphic parameter modification
# EXAMPLES
# fun_prior_plot(param.reinitial = FALSE, xlog.scale = FALSE, ylog.scale = FALSE, remove.label = TRUE, remove.x.axis = TRUE, remove.y.axis = TRUE, std.x.range = TRUE, std.y.range = TRUE, down.space = 1, left.space = 1, up.space = 1, right.space = 1, orient = 1, dist.legend = 4.5, tick.length = 0.5, box.type = "n", amplif.label = 1, amplif.axis = 1, display.extend = FALSE, return.par = FALSE)
# DEBUGGING
# param.reinitial = FALSE ; xlog.scale = FALSE ; ylog.scale = FALSE ; remove.label = TRUE ; remove.x.axis = TRUE ; remove.y.axis = TRUE ; std.x.range = TRUE ; std.y.range = TRUE ; down.space = 1 ; left.space = 1 ; up.space = 1 ; right.space = 1 ; orient = 1 ; dist.legend = 4.5 ; tick.length = 0.5 ; box.type = "n" ; amplif.label = 1 ; amplif.axis = 1 ; display.extend = FALSE ; return.par = FALSE # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# 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 = param.reinitial, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = xlog.scale, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = ylog.scale, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = remove.label, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = remove.x.axis, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = remove.y.axis, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = std.x.range, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = std.y.range, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = down.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = left.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = up.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = right.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = orient, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = dist.legend, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = tick.length, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.type, options = c("o", "l", "7", "c", "u", "]", "n"), length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = amplif.label, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = amplif.axis, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = display.extend, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = return.par, 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
if(is.null(dev.list())){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THIS FUNCTION CANNOT BE USED IF NO GRAPHIC DEVICE ALREADY OPENED (dev.list() IS CURRENTLY NULL)\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# 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(param.reinitial == TRUE){
if( ! all(names(dev.cur()) == "null device")){
active.wind.nb <- dev.cur()
}else{
active.wind.nb <- 0
}
if(Sys.info()["sysname"] == "Windows"){ # Note that .Platform$OS.type() only says "unix" for macOS and Linux and "Windows" for Windows
windows()
Gael  MILLOT's avatar
Gael MILLOT committed
3913
ini.par <- par(no.readonly = FALSE) # 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
3914
3915
3916
3917
3918
3919
3920
3921
invisible(dev.off()) # close the new window
}else if(Sys.info()["sysname"] == "Linux"){
if(file.exists(paste0(getwd(), "/Rplots.pdf"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THIS FUNCTION CANNOT BE USED ON LINUX WITH param.reinitial SET TO TRUE IF A Rplots.pdf FILE ALREADY EXISTS HERE: ", getwd(), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}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)){
Gael  MILLOT's avatar
Gael MILLOT committed
3922
ini.par <- par(no.readonly = FALSE) # 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(file.exists(paste0(getwd(), "/Rplots.pdf"))){
Gael  MILLOT's avatar
Gael MILLOT committed
3925
ini.par <- par(no.readonly = FALSE) # 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
3926
3927
3928
invisible(dev.off()) # close the new window
file.remove(paste0(getwd(), "/Rplots.pdf")) # remove the pdf file
}else{
3929
tempo.cat <- ("\n\n================\n\nERROR IN fun_prior_plot()\nTHIS FUNCTION CANNOT OPEN GUI ON LINUX OR NON MACOS UNIX SYSTEM (X GRAPHIC INTERFACE HAS TO BE SET)\nTO OVERCOME THIS, PLEASE USE PDF GRAPHIC INTERFACES AND RERUN\n\n================\n\n")
Gael  MILLOT's avatar
Gael MILLOT committed
3930
3931
3932
3933
3934
stop(tempo.cat, call. = FALSE)
}
}
}else{ # macOS
quartz()
Gael  MILLOT's avatar
Gael MILLOT committed
3935
ini.par <- par(no.readonly = FALSE) # 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
3936
3937
3938
invisible(dev.off()) # close the new window
}
if( ! all(names(dev.cur()) == "null device")){
3939
invisible(dev.set(active.wind.nb)) # go back to the active window if exists
Gael  MILLOT's avatar
Gael MILLOT committed
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
par(ini.par) # apply the initial par to current window
}
}
# end par.ini recovery
if(remove.x.axis == TRUE){
par(xaxt = "n") # suppress the y-axis label
}else{
par(xaxt = "s")
}
if(remove.y.axis == TRUE){
par(yaxt = "n") # suppress the y-axis label
}else{
par(yaxt = "s")
}
if(std.x.range == TRUE){
par(xaxs = "i")
}else{
par(xaxs = "r")
}
if(std.y.range == TRUE){
par(yaxs = "i")
}else{
par(yaxs = "r")
}
par(mai = c(down.space, left.space, up.space, right.space), ann = ! remove.label, las = orient, mgp = c(dist.legend/0.2, 1, 0), xpd = display.extend, bty= box.type, cex.lab = amplif.label, cex.axis = amplif.axis)
par(tcl = -par()$mgp[2] * tick.length) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region)
if(xlog.scale == TRUE){
par(xaxt = "n", xlog = TRUE) # suppress the x-axis label
}else{
par(xlog = FALSE)
}
if(ylog.scale == TRUE){
par(yaxt = "n", ylog = TRUE) # suppress the y-axis label
}else{
par(ylog = FALSE)
}
if(return.par == TRUE){
tempo.par <- par()
return(tempo.par)
}
}


######## fun_scale() #### select nice label numbers when setting number of ticks on an axis


 


# Check OK: clear to go Apollo
fun_scale <- function(n, lim, kind = "approx", lib.path = NULL){
# AIM
# attempt to select nice scale numbers when setting n ticks on a lim axis range
# ARGUMENTS
3994
# n: desired number of main ticks on the axis (integer above 0)
Gael  MILLOT's avatar
Gael MILLOT committed
3995
3996
# lim: vector of 2 numbers indicating the limit range of the axis. Order of the 2 values matters (for inverted axis). Can be log transformed values
# kind: either "approx" (approximative), "strict" (strict) or "strict.cl" (strict clean). If "approx", use the scales::trans_breaks() function to provide an easy to read scale of approximately n ticks spanning the range of the lim argument. If "strict", cut the range of the lim argument into n + 1 equidistant part and return the n numbers at each boundary. This often generates numbers uneasy to read. If "strict.cl", provide an easy to read scale of exactly n ticks, but sometimes not completely spanning the range of the lim argument
3997
# 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
3998
3999
4000
# REQUIRED PACKAGES
# if kind = "approx":
# ggplot2