cute_little_R_functions.R 591 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
7012
7013
7014
7015
7016
7017
7018
7019
x.data1.left.limit.t <- NULL # left limit of the data1 cloud for top step line
x.data1.right.limit.t <- NULL # right limit of the data1 cloud for top step line
if( ! is.null(y.range.split)){
# data.frame ordering to slide the window from small to big values + sliding window definition
data1 <- data1[order(data1[, y1], na.last = TRUE), ]
if( ! is.null(data2)){
data2 <- data2[order(data2[, y2], na.last = TRUE), ]
}
y.win.size <- abs(diff(y.range) / y.range.split) # in unit of y-axis
step <- y.win.size / y.step.factor
# end data.frame ordering to slide the window from small to big values + sliding window definition
# y-axis sliding and x-axis limits of the data1 cloud -> x significant data2
loop.nb <- ceiling((diff(y.range) - y.win.size) / step) # y.win.size + n * step covers the y range if y.win.size + n * step >= diff(y.range), thus if n >= (diff(y.range) - y.win.size) / step 
x.outside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are upper or lower than the frame
x.inside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are not upper or lower than the frame
x.data1.median <- median(data1[, x1], na.rm = TRUE) # will be used for sliding windows without data1 in it
if( ! is.null(data2)){
x.outside.data2.dot.nb <- integer() # vector that will contain the selected 1D coordinates (i.e., dots) of data2 that are upper or lower than the data1 frame
x.inside.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are not upper or lower than the data1 frame
Gael  MILLOT's avatar
Gael MILLOT committed
7020
x.unknown.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are problematic: data2 dots outside of the range of data1, or data2 dots in a sliding window without data1 dots
Gael  MILLOT's avatar
Gael MILLOT committed
7021
7022
# recover data2 dots outside the range of data1
if(any(data2[, y2] < y.range[1])){
Gael  MILLOT's avatar
Gael MILLOT committed
7023
x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[data2[, y2] < y.range[1]])
Gael  MILLOT's avatar
Gael MILLOT committed
7024
7025
}
if(any(data2[, y2] > y.range[2])){
Gael  MILLOT's avatar
Gael MILLOT committed
7026
x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[data2[, y2] > y.range[2]])
Gael  MILLOT's avatar
Gael MILLOT committed
7027
7028
7029
7030
7031
7032
7033
7034
7035
7036
7037
7038
7039
7040
7041
7042
7043
7044
7045
7046
7047
}
# end recover data2 dots outside the range of data1
}
# loop.ini.time <- as.numeric(Sys.time())
for(i1 in 0:(loop.nb + 1)){
min.pos <- y.range[1] + step * i1 # lower position of the sliding window in data1
max.pos <- min.pos + y.win.size # upper position of the sliding window in data1
y.data1.d <- c(y.data1.d, min.pos, min.pos + step) # min.pos + step to make the steps
y.data1.t <- c(y.data1.t, max.pos, max.pos + step) # max.pos + step to make the steps
y.data1.dot.here <- data1[, y1] >= min.pos & data1[, y1] < max.pos # is there data1 dot present in the sliding window, considering the y axis?
if( ! is.null(data2)){
y.data2.dot.here <- data2[, y2] >= min.pos & data2[, y2] < max.pos # is there data2 dot present in the sliding window, considering the y axis?
}
# recover the data1 dots outside the frame
if(any(y.data1.dot.here == TRUE)){
tempo.x.data1.right.limit <- quantile(data1[y.data1.dot.here, x1], probs = 1 - error, na.rm = TRUE)
tempo.x.data1.left.limit <- quantile(data1[y.data1.dot.here, x1], probs = 0 + error, na.rm = TRUE)
x.data1.right.limit.d <- c(x.data1.right.limit.d, tempo.x.data1.right.limit, tempo.x.data1.right.limit)
x.data1.left.limit.d <- c(x.data1.left.limit.d, tempo.x.data1.left.limit, tempo.x.data1.left.limit)
x.data1.right.limit.t <- c(x.data1.right.limit.t, tempo.x.data1.right.limit, tempo.x.data1.right.limit)
x.data1.left.limit.t <- c(x.data1.left.limit.t, tempo.x.data1.left.limit, tempo.x.data1.left.limit)
Gael  MILLOT's avatar
Gael MILLOT committed
7048
x.data1.dot.signif <- ( ! ((data1[, x1] <= tempo.x.data1.right.limit) & (data1[, x1] >= tempo.x.data1.left.limit))) & y.data1.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the x axis?
Gael  MILLOT's avatar
Gael MILLOT committed
7049
7050
7051
7052
7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
x.data1.dot.not.signif <- y.data1.dot.here & ! x.data1.dot.signif
x.outside.data1.dot.nb <- c(x.outside.data1.dot.nb, data1$DOT_NB[x.data1.dot.signif]) # recover the row number of data1
x.outside.data1.dot.nb <- unique(x.outside.data1.dot.nb)
x.inside.data1.dot.nb <- c(x.inside.data1.dot.nb, data1$DOT_NB[x.data1.dot.not.signif])
x.inside.data1.dot.nb <- unique(x.inside.data1.dot.nb)
}else{
x.data1.right.limit.d <- c(x.data1.right.limit.d, x.data1.median, x.data1.median)
x.data1.left.limit.d <- c(x.data1.left.limit.d, x.data1.median, x.data1.median)
x.data1.right.limit.t <- c(x.data1.right.limit.t, x.data1.median, x.data1.median)
x.data1.left.limit.t <- c(x.data1.left.limit.t, x.data1.median, x.data1.median)
}
# end recover the data1 dots outside the frame
# recover the data2 dots outside the frame
if( ! is.null(data2)){
if(any(y.data1.dot.here == TRUE) & any(y.data2.dot.here == TRUE)){ 
Gael  MILLOT's avatar
Gael MILLOT committed
7064
x.data2.dot.signif <- ( ! ((data2[, x2] <= tempo.x.data1.right.limit) & (data2[, x2] >= tempo.x.data1.left.limit))) & y.data2.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the x axis?
Gael  MILLOT's avatar
Gael MILLOT committed
7065
7066
7067
7068
7069
7070
x.data2.dot.not.signif <- y.data2.dot.here & ! x.data2.dot.signif
x.outside.data2.dot.nb <- c(x.outside.data2.dot.nb, data2$DOT_NB[x.data2.dot.signif])
x.outside.data2.dot.nb <- unique(x.outside.data2.dot.nb)
x.inside.data2.dot.nb <- c(x.inside.data2.dot.nb, data2$DOT_NB[x.data2.dot.not.signif])
x.inside.data2.dot.nb <- unique(x.inside.data2.dot.nb)
}else if(any(y.data1.dot.here == FALSE) & any(y.data2.dot.here == TRUE)){ # recover the data2 dots outside the range of the data1 cloud
Gael  MILLOT's avatar
Gael MILLOT committed
7071
7072
7073
7074
7075
7076
x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[y.data2.dot.here])
x.unknown.data2.dot.nb <- unique(x.unknown.data2.dot.nb)



# tempo.warning <- paste0("FROM FUNCTION ", function.name, ": THE [", round(min.pos, 3), " ; ", round(max.pos, 3), "] INTERVAL DOES NOT CONTAIN data1 Y VALUES BUT CONTAINS data2 Y VALUES WHICH CANNOT BE EVALUATED.\nTHE CONCERNED data2 ROW NUMBERS ARE:\n", paste(which(y.data1.dot.here == FALSE & y.data2.dot.here == TRUE), collapse = "\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
7077
7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
warning <- paste0(ifelse(is.null(warning), tempo.warning, paste0(warning, "\n\n", tempo.warning)))
}
}
# end recover the data2 dots outside the frame
# if(any(i1 == seq(1, loop.nb, 500))){
# loop.fin.time <- as.numeric(Sys.time()) # time of process end
# cat(paste0("COMPUTATION TIME OF LOOP ", i1, " / ", loop.nb, ": ", as.character(lubridate::seconds_to_period(round(loop.fin.time - loop.ini.time))), "\n"))
# }
}
if(max.pos < y.range[2]){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE SLIDING WINDOW HAS NOT REACHED THE MAX VALUE OF data1 ON THE Y-AXIS: ", max.pos, " VERSUS ", y.range[2], "\n\n================\n\n")
stop(tempo.cat)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
x.incon.data1.dot.nb.final <- unique(c(x.outside.data1.dot.nb[x.outside.data1.dot.nb %in% x.inside.data1.dot.nb], x.inside.data1.dot.nb[x.inside.data1.dot.nb %in% x.outside.data1.dot.nb])) # inconsistent dots: if a row number of x.inside.data1.dot.nb is present in x.outside.data1.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list
x.outside.data1.dot.nb.final <- x.outside.data1.dot.nb[ ! (x.outside.data1.dot.nb %in% x.incon.data1.dot.nb.final)] # inconsistent dots removed from the outside list
x.inside.data1.dot.nb.final <- x.inside.data1.dot.nb[ ! (x.inside.data1.dot.nb %in% x.incon.data1.dot.nb.final)] # inconsistent dots removed from the inside list
if( ! is.null(data2)){
# if some unknown dots are also inside, and/or outside, they are put in the inside and/or outside. Ok, because then the intersection between inside and outside is treated -> inconsistent dots
tempo.unknown.out <- x.unknown.data2.dot.nb[x.unknown.data2.dot.nb %in% x.outside.data2.dot.nb]
x.outside.data2.dot.nb <- unique(c(x.outside.data2.dot.nb, tempo.unknown.out)) # if a row number of x.unknown.data2.dot.nb is present in x.outside.data2.dot.nb, it is put into outside
tempo.unknown.in <- x.unknown.data2.dot.nb[x.unknown.data2.dot.nb %in% x.inside.data2.dot.nb]
x.inside.data2.dot.nb <- unique(c(x.inside.data2.dot.nb, tempo.unknown.in)) # if a row number of x.unknown.data2.dot.nb is present in x.inside.data2.dot.nb, it is put into inside
x.unknown.data2.dot.nb.final <- x.unknown.data2.dot.nb[ ! (x.unknown.data2.dot.nb %in% c(x.outside.data2.dot.nb, x.inside.data2.dot.nb))] # then dots also in inside and outside are remove from unknown
x.incon.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb[x.outside.data2.dot.nb %in% x.inside.data2.dot.nb], x.inside.data2.dot.nb[x.inside.data2.dot.nb %in% x.outside.data2.dot.nb])) # inconsistent dots: if a row number of x.inside.data2.dot.nb is present in x.outside.data2.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list
x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb[ ! (x.outside.data2.dot.nb %in% x.incon.data2.dot.nb.final)] # inconsistent dots removed from the outside list
x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb[ ! (x.inside.data2.dot.nb %in% x.incon.data2.dot.nb.final)] # inconsistent dots removed from the inside list
}
Gael  MILLOT's avatar
Gael MILLOT committed
7104
7105
7106
# end y-axis sliding and x-axis limits of the data1 cloud -> x significant data2
}
# end Method using y unit interval 
Gael  MILLOT's avatar
Gael MILLOT committed
7107
7108
7109
7110



# recovering the frame coordinates
Gael  MILLOT's avatar
Gael MILLOT committed
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
hframe = rbind(
data.frame(
x = if(is.null(x.data1.l)){NULL}else{x.data1.l}, 
y = if(is.null(x.data1.l)){NULL}else{y.data1.down.limit.l}, 
kind = if(is.null(x.data1.l)){NULL}else{"down.frame1"}
), 
data.frame(
x = if(is.null(x.data1.r)){NULL}else{x.data1.r}, 
y = if(is.null(x.data1.r)){NULL}else{y.data1.down.limit.r}, 
kind = if(is.null(x.data1.r)){NULL}else{"down.frame2"}
), 
data.frame(
x = if(is.null(x.data1.l)){NULL}else{x.data1.l}, 
y = if(is.null(x.data1.l)){NULL}else{y.data1.top.limit.l}, 
kind = if(is.null(x.data1.l)){NULL}else{"top.frame1"}
), 
data.frame(
x = if(is.null(x.data1.r)){NULL}else{x.data1.r}, 
y = if(is.null(x.data1.r)){NULL}else{y.data1.top.limit.r}, 
kind = if(is.null(x.data1.r)){NULL}else{"top.frame2"}
)
)
vframe = rbind(
data.frame(
x = if(is.null(y.data1.d)){NULL}else{x.data1.left.limit.d}, 
y = if(is.null(y.data1.d)){NULL}else{y.data1.d}, 
kind = if(is.null(y.data1.d)){NULL}else{"left.frame1"}
), 
data.frame(
x = if(is.null(y.data1.t)){NULL}else{x.data1.left.limit.t}, 
y = if(is.null(y.data1.t)){NULL}else{y.data1.t}, 
kind = if(is.null(y.data1.t)){NULL}else{"left.frame2"}
), 
data.frame(
x = if(is.null(y.data1.d)){NULL}else{x.data1.right.limit.d}, 
y = if(is.null(y.data1.d)){NULL}else{y.data1.d}, 
kind = if(is.null(y.data1.d)){NULL}else{"right.frame1"}
),
data.frame(
x = if(is.null(y.data1.t)){NULL}else{x.data1.right.limit.t}, 
y = if(is.null(y.data1.t)){NULL}else{y.data1.t}, 
kind = if(is.null(y.data1.t)){NULL}else{"right.frame2"}
)
)
Gael  MILLOT's avatar
Gael MILLOT committed
7155
7156
# end recovering the frame coordinates
# recovering the dot coordinates
Gael  MILLOT's avatar
Gael MILLOT committed
7157
data1.signif.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
7158
7159
data1.non.signif.dot <- NULL
data1.incon.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
7160
data2.signif.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
7161
7162
7163
data2.non.signif.dot <- NULL
data2.unknown.dot <- NULL
data2.incon.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
7164
if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
# inconsistent dots recovery 
if(length(unique(c(x.incon.data1.dot.nb.final, y.incon.data1.dot.nb.final))) > 0){
data1.incon.dot <- data1[data1$DOT_NB %in% unique(c(x.incon.data1.dot.nb.final, y.incon.data1.dot.nb.final)), ] # if a dot in inconsistent in x or y -> classified as inconsistent (so unique() used)
# removal of the inconsistent dot in the other classifications
x.inside.data1.dot.nb.final <- x.inside.data1.dot.nb.final[ ! x.inside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB]
y.inside.data1.dot.nb.final <- y.inside.data1.dot.nb.final[ ! y.inside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB]
x.outside.data1.dot.nb.final <- x.outside.data1.dot.nb.final[ ! x.outside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB]
y.outside.data1.dot.nb.final <- y.outside.data1.dot.nb.final[ ! y.outside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB]
x.unknown.data1.dot.nb.final <- x.unknown.data1.dot.nb.final[ ! x.unknown.data1.dot.nb.final %in% data1.incon.dot$DOT_NB]
y.unknown.data1.dot.nb.final <- y.unknown.data1.dot.nb.final[ ! y.unknown.data1.dot.nb.final %in% data1.incon.dot$DOT_NB]
# end removal of the inconsistent dot in the other classifications
}
if( ! is.null(data2)){
if(length(unique(c(x.incon.data2.dot.nb.final, y.incon.data2.dot.nb.final))) > 0){
data2.incon.dot <- data2[data2$DOT_NB %in% unique(c(x.incon.data2.dot.nb.final, y.incon.data2.dot.nb.final)), ]
# removal of the inconsistent dot in the other classifications
x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB]
y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB]
x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB]
y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB]
x.unknown.data2.dot.nb.final <- x.unknown.data2.dot.nb.final[ ! x.unknown.data2.dot.nb.final %in% data2.incon.dot$DOT_NB]
y.unknown.data2.dot.nb.final <- y.unknown.data2.dot.nb.final[ ! y.unknown.data2.dot.nb.final %in% data2.incon.dot$DOT_NB]
# end removal of the inconsistent dot in the other classifications
}
}
# end inconsistent dots recovery 
# unknown dots recovery 
if( ! is.null(data2)){
if(data2.pb.dot == "signif"){
x.outside.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb.final, x.unknown.data2.dot.nb.final))
x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% x.unknown.data2.dot.nb.final] # remove x.unknown.data2.dot.nb.final from x.inside.data2.dot.nb.final
y.outside.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb.final, y.unknown.data2.dot.nb.final))
y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% y.unknown.data2.dot.nb.final] # remove y.unknown.data2.dot.nb.final from y.inside.data2.dot.nb.final
x.unknown.data2.dot.nb.final <- NULL
y.unknown.data2.dot.nb.final <- NULL
data2.unknown.dot <- NULL
}else if(data2.pb.dot == "not.signif"){
x.inside.data2.dot.nb.final <- unique(c(x.inside.data2.dot.nb.final, x.unknown.data2.dot.nb.final))
x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% x.unknown.data2.dot.nb.final] # remove x.unknown.data2.dot.nb.final from x.outside.data2.dot.nb.final
y.inside.data2.dot.nb.final <- unique(c(y.inside.data2.dot.nb.final, y.unknown.data2.dot.nb.final))
y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% y.unknown.data2.dot.nb.final] # remove y.unknown.data2.dot.nb.final from y.outside.data2.dot.nb.final
x.unknown.data2.dot.nb.final <- NULL
y.unknown.data2.dot.nb.final <- NULL
data2.unknown.dot <- NULL
}else if(data2.pb.dot == "unknown"){
if(length(unique(c(x.unknown.data2.dot.nb.final, y.unknown.data2.dot.nb.final))) > 0){
data2.unknown.dot <- data2[data2$DOT_NB %in% unique(c(x.unknown.data2.dot.nb.final, y.unknown.data2.dot.nb.final)), ] # if a dot in unknown in x or y -> classified as unknown (so unique() used)
x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove x.unknown.data2.dot.nb.final from x.outside.data2.dot.nb.final
x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove x.unknown.data2.dot.nb.final from x.inside.data2.dot.nb.final
y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove y.unknown.data2.dot.nb.final from y.outside.data2.dot.nb.final
y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove y.unknown.data2.dot.nb.final from y.inside.data2.dot.nb.final
}
}else{
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 3\n\n============\n\n"))
stop(tempo.cat)
}
}
# end unknown dots recovery 
# sign and non sign dot recovery
if(xy.cross.kind == "|"){ # here the problem is to deal with significant dots depending on x and y. Thus I start with that, recover dots finally non significant in outside and put them in inside (when &), and remove from inside the dots in outside
Gael  MILLOT's avatar
Gael MILLOT committed
7225
if(length(unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final))) > 0){
Gael  MILLOT's avatar
Gael MILLOT committed
7226
7227
7228
7229
7230
7231
7232
tempo.outside <- unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final)) # union so unique() used
tempo.inside <- unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final))
tempo.inside <- tempo.inside[ ! tempo.inside %in% tempo.outside]
data1.signif.dot <- data1[data1$DOT_NB %in% tempo.outside, ]
data1.non.signif.dot <- data1[data1$DOT_NB %in% tempo.inside, ]
}else{
data1.non.signif.dot <- data1[unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it
Gael  MILLOT's avatar
Gael MILLOT committed
7233
7234
}
}else if(xy.cross.kind == "&"){
Gael  MILLOT's avatar
Gael MILLOT committed
7235
7236
7237
7238
7239
7240
7241
7242
if(sum(x.outside.data1.dot.nb.final %in% y.outside.data1.dot.nb.final) > 0){ # that is intersection
tempo.outside <- unique(x.outside.data1.dot.nb.final[x.outside.data1.dot.nb.final %in% y.outside.data1.dot.nb.final]) # intersection
tempo.outside.removed <- unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final))[ ! unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final)) %in% tempo.outside]
tempo.inside <- unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final))
data1.signif.dot <- data1[data1$DOT_NB %in% tempo.outside, ]
data1.non.signif.dot <- data1[data1$DOT_NB %in% tempo.inside, ]
}else{
data1.non.signif.dot <- data1[unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it
Gael  MILLOT's avatar
Gael MILLOT committed
7243
7244
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7245
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 4\n\n============\n\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
7246
7247
7248
stop(tempo.cat)
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
7249
if(xy.cross.kind == "|"){ # here the problem is to deal with significant dots depending on x and y. Thus I start with that, recover dots finally non significant in outside and put them in inside (when &), and remove from inside the dots in outside
Gael  MILLOT's avatar
Gael MILLOT committed
7250
if(length(unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final))) > 0){
Gael  MILLOT's avatar
Gael MILLOT committed
7251
7252
7253
7254
7255
7256
7257
tempo.outside <- unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final)) # union so unique() used
tempo.inside <- unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final))
tempo.inside <- tempo.inside[ ! tempo.inside %in% tempo.outside]
data2.signif.dot <- data2[data2$DOT_NB %in% tempo.outside, ]
data2.non.signif.dot <- data2[data2$DOT_NB %in% tempo.inside, ]
}else{
data2.non.signif.dot <- data2[unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it
Gael  MILLOT's avatar
Gael MILLOT committed
7258
7259
}
}else if(xy.cross.kind == "&"){
Gael  MILLOT's avatar
Gael MILLOT committed
7260
7261
7262
7263
7264
7265
7266
7267
if(sum(x.outside.data2.dot.nb.final %in% y.outside.data2.dot.nb.final) > 0){ # that is intersection
tempo.outside <- unique(x.outside.data2.dot.nb.final[x.outside.data2.dot.nb.final %in% y.outside.data2.dot.nb.final]) # intersection
tempo.outside.removed <- unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final))[ ! unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final)) %in% tempo.outside]
tempo.inside <- unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final))
data2.signif.dot <- data2[data2$DOT_NB %in% tempo.outside, ]
data2.non.signif.dot <- data2[data2$DOT_NB %in% tempo.inside, ]
}else{
data2.non.signif.dot <- data2[unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it
Gael  MILLOT's avatar
Gael MILLOT committed
7268
7269
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7270
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 5\n\n============\n\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
7271
7272
7273
stop(tempo.cat)
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
7274
# end sign and non sign dot recovery
Gael  MILLOT's avatar
Gael MILLOT committed
7275
}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){
Gael  MILLOT's avatar
Gael MILLOT committed
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300
7301
# inconsistent dots recovery 
if(length(y.incon.data1.dot.nb.final) > 0){
data1.incon.dot <- data1[data1$DOT_NB %in% y.incon.data1.dot.nb.final, ]
}
if( ! is.null(data2)){
if(length(y.incon.data2.dot.nb.final) > 0){
data2.incon.dot <- data2[data2$DOT_NB %in% y.incon.data2.dot.nb.final, ]
}
}# end inconsistent dots recovery 
# unknown dots recovery 
if( ! is.null(data2)){
if(data2.pb.dot == "signif"){
y.outside.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb.final, y.unknown.data2.dot.nb.final))
}else if(data2.pb.dot == "not.signif"){
y.inside.data2.dot.nb.final <- unique(c(y.inside.data2.dot.nb.final, y.unknown.data2.dot.nb.final))
}else if(data2.pb.dot == "unknown"){
if(length(y.unknown.data2.dot.nb.final) > 0){
data2.unknown.dot <- data2[data2$DOT_NB %in% y.unknown.data2.dot.nb.final, ]
}
}else{
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n"))
stop(tempo.cat)
}
}
# end unknown dots recovery 
# sign and non sign dot recovery
Gael  MILLOT's avatar
Gael MILLOT committed
7302
7303
7304
if(length(y.outside.data1.dot.nb.final) > 0){
data1.signif.dot <- data1[data1$DOT_NB %in% y.outside.data1.dot.nb.final, ]
}
Gael  MILLOT's avatar
Gael MILLOT committed
7305
7306
7307
if(length(y.inside.data1.dot.nb.final) > 0){
data1.non.signif.dot <- data1[data1$DOT_NB %in% y.inside.data1.dot.nb.final, ]
}
Gael  MILLOT's avatar
Gael MILLOT committed
7308
7309
7310
7311
if( ! is.null(data2)){
if(length(y.outside.data2.dot.nb.final) > 0){
data2.signif.dot <- data2[data2$DOT_NB %in% y.outside.data2.dot.nb.final, ]
}
Gael  MILLOT's avatar
Gael MILLOT committed
7312
7313
if(length(y.inside.data2.dot.nb.final) > 0){
data2.non.signif.dot <- data2[data2$DOT_NB %in% y.inside.data2.dot.nb.final, ]
Gael  MILLOT's avatar
Gael MILLOT committed
7314
}
Gael  MILLOT's avatar
Gael MILLOT committed
7315
7316
}
# end sign and non sign dot recovery
Gael  MILLOT's avatar
Gael MILLOT committed
7317
}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
# inconsistent dots recovery 
if(length(x.incon.data1.dot.nb.final) > 0){
data1.incon.dot <- data1[data1$DOT_NB %in% x.incon.data1.dot.nb.final, ]
}
if( ! is.null(data2)){
if(length(x.incon.data2.dot.nb.final) > 0){
data2.incon.dot <- data2[data2$DOT_NB %in% x.incon.data2.dot.nb.final, ]
}
}# end inconsistent dots recovery 
# unknown dots recovery 
if( ! is.null(data2)){
if(data2.pb.dot == "signif"){
x.outside.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb.final, x.unknown.data2.dot.nb.final))
}else if(data2.pb.dot == "not.signif"){
x.inside.data2.dot.nb.final <- unique(c(x.inside.data2.dot.nb.final, x.unknown.data2.dot.nb.final))
}else if(data2.pb.dot == "unknown"){
if(length(x.unknown.data2.dot.nb.final) > 0){
data2.unknown.dot <- data2[data2$DOT_NB %in% x.unknown.data2.dot.nb.final, ]
}
}else{
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n"))
stop(tempo.cat)
}
}
# end unknown dots recovery 
# sign and non sign dot recovery
Gael  MILLOT's avatar
Gael MILLOT committed
7344
7345
7346
if(length(x.outside.data1.dot.nb.final) > 0){
data1.signif.dot <- data1[data1$DOT_NB %in% x.outside.data1.dot.nb.final, ]
}
Gael  MILLOT's avatar
Gael MILLOT committed
7347
7348
7349
if(length(x.inside.data1.dot.nb.final) > 0){
data1.non.signif.dot <- data1[data1$DOT_NB %in% x.inside.data1.dot.nb.final, ]
}
Gael  MILLOT's avatar
Gael MILLOT committed
7350
7351
7352
7353
if( ! is.null(data2)){
if(length(x.outside.data2.dot.nb.final) > 0){
data2.signif.dot <- data2[data2$DOT_NB %in% x.outside.data2.dot.nb.final, ]
}
Gael  MILLOT's avatar
Gael MILLOT committed
7354
7355
7356
7357
7358
7359
7360
7361
7362
7363
7364
if(length(x.inside.data2.dot.nb.final) > 0){
data2.non.signif.dot <- data2[data2$DOT_NB %in% x.inside.data2.dot.nb.final, ]
}
}
# end sign and non sign dot recovery
}
# end recovering the dot coordinates
# verif
if(any(data1.signif.dot$DOT_NB %in% data1.non.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", FUNCTION.NAME, ": CODE INCONSISTENCY 8\n\n============\n\n"))
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
7365
}
Gael  MILLOT's avatar
Gael MILLOT committed
7366
7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
if(any(data1.non.signif.dot$DOT_NB %in% data1.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", FUNCTION.NAME, ": CODE INCONSISTENCY 9\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data1.signif.dot$DOT_NB %in% data1.incon.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 10\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data1.incon.dot$DOT_NB %in% data1.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 11\n\n============\n\n"))
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
7377
}
Gael  MILLOT's avatar
Gael MILLOT committed
7378
7379
7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
7409
7410
7411
7412
7413
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
if(any(data1.non.signif.dot$DOT_NB %in% data1.incon.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 12\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data1.incon.dot$DOT_NB %in% data1.non.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 13\n\n============\n\n"))
stop(tempo.cat)
}
if( ! is.null(data2)){
if(any(data2.signif.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 14\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.non.signif.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 15\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.signif.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 16\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.unknown.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 17\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.signif.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 18\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.incon.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 19\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.non.signif.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 20\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.unknown.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 21\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.non.signif.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 22\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.incon.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 23\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.unknown.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 24\n\n============\n\n"))
stop(tempo.cat)
}
if(any(data2.incon.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 25\n\n============\n\n"))
stop(tempo.cat)
}
}
# end verif
# plot
Gael  MILLOT's avatar
Gael MILLOT committed
7438
7439
if(graph.check == TRUE){
if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
7440
7441
7442
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7443
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe), x = list(x1, "x", "x"), y = list(y1, "y", "y"), categ = list(NULL, "kind", "kind"), legend.name = list("data1", "hframe" , "vframe"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7444
7445
7446
7447
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
if( ! is.null(data1.signif.dot)){
Gael  MILLOT's avatar
Gael MILLOT committed
7448
7449
7450
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7451
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.signif.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list(NULL, "kind", "kind", NULL), legend.name = list("data1", "hframe" , "vframe", "data1.signif.dots"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7452
7453
7454
7455
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7456
7457
7458
7459
7460
7461
7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
7473
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA1 DOTS OUTSIDE THE FRAMES", text.size = 12, title = "DATA1 + DATA1 SIGNIFICANT DOTS")
}
if( ! is.null(data1.incon.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.incon.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list(NULL, "kind", "kind", NULL), legend.name = list("data1", "hframe" , "vframe", "data1.incon.dots"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA1 INCONSISTENT DOTS", text.size = 12, title = "DATA1 + DATA1 INCONSISTENT DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
7474
7475
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
7476
7477
7478
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7479
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe , vframe), x = list(x1, x2, "x", "x"), y = list(y1, y2, "y", "y"), categ = list(NULL, NULL, "kind", "kind"), legend.name = list("data1", "data2", "hframe" , "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7480
7481
7482
7483
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
if( ! is.null(data2.signif.dot)){
Gael  MILLOT's avatar
Gael MILLOT committed
7484
7485
7486
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7487
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list(NULL, NULL, NULL, "kind", "kind"), legend.name = list("data1", "data2", "data2.signif.dots", "hframe" , "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7488
7489
7490
7491
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7492
7493
7494
7495
7496
7497
7498
7499
7500
7501
7502
7503
7504
7505
7506
7507
7508
7509
7510
7511
7512
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522
7523
7524
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 DOTS OUTSIDE THE FRAMES", text.size = 12, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS")
}
if( ! is.null(data2.incon.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list(NULL, NULL, NULL, "kind", "kind"), legend.name = list("data1", "data2", "data2.incon.dots", "hframe" , "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 INCONSISTENT DOTS", text.size = 12, title = "DATA2 + DATA2 INCONSISTENT DOTS")
}
if( ! is.null(data2.unknown.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list(NULL, NULL, NULL, "kind", "kind"), legend.name = list("data1", "data2", "data2.unknown.dots", "hframe" , "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", xlim = x.range.plot, ylim = y.range.plot)

if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 UNKNOWN DOTS", text.size = 12, title = "DATA2 + DATA2 UNKNOWN DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
7525
7526
7527
}
}
}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){
Gael  MILLOT's avatar
Gael MILLOT committed
7528
7529
7530
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7531
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe), x = list(x1, "x"), y = list(y1, "y"), categ = list(NULL, "kind"), legend.name = list("data1", "hframe"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7532
7533
7534
7535
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
if( ! is.null(data1.signif.dot)){
Gael  MILLOT's avatar
Gael MILLOT committed
7536
7537
7538
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7539
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list(NULL, "kind", NULL), legend.name = list("data1", "hframe", "data1.signif.dots"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7540
7541
7542
7543
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7544
7545
7546
7547
7548
7549
7550
7551
7552
7553
7554
7555
7556
7557
7558
7559
7560
7561
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA1 DOTS OUTSIDE THE FRAMES", text.size = 12, title = "DATA1 + DATA1 SIGNIFICANT DOTS")
}
if( ! is.null(data1.incon.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list(NULL, "kind", NULL), legend.name = list("data1", "hframe", "data1.incon.dots"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA1 INCONSISTENT DOTS", text.size = 12, title = "DATA1 + DATA1 INCONSISTENT DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
7562
7563
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
7564
7565
7566
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7567
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list(NULL, NULL, "kind"), legend.name = list("data1", "data2", "hframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7568
7569
7570
7571
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
if( ! is.null(data2.signif.dot)){
Gael  MILLOT's avatar
Gael MILLOT committed
7572
7573
7574
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7575
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list(NULL, NULL, NULL, "kind"), legend.name = list("data1", "data2", "data2.signif.dots", "hframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7576
7577
7578
7579
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7580
7581
7582
7583
7584
7585
7586
7587
7588
7589
7590
7591
7592
7593
7594
7595
7596
7597
7598
7599
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 DOTS OUTSIDE THE FRAMES", text.size = 12, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS")
}
if( ! is.null(data2.incon.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list(NULL, NULL, NULL, "kind"), legend.name = list("data1", "data2", "data2.incon.dots", "hframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 INCONSISTENT DOTS", text.size = 12, title = "DATA2 + DATA2 INCONSISTENT DOTS")
}
if( ! is.null(data2.unknown.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list(NULL, NULL, NULL, "kind"), legend.name = list("data1", "data2", "data2.unknown.dots", "hframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 UNKNOWN DOTS", text.size = 12, title = "DATA2 + DATA2 UNKNOWN DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
7612
7613
7614
}
}
}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
7615
7616
7617
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7618
tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe), x = list(x1, "x"), y = list(y1, "y"), categ = list(NULL, "kind"), legend.name = list("data1", "vframe"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7619
7620
7621
7622
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
if( ! is.null(data1.signif.dot)){
Gael  MILLOT's avatar
Gael MILLOT committed
7623
7624
7625
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7626
tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list(NULL, "kind", NULL), legend.name = list("data1", "vframe", "data1.signif.dots"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7627
7628
7629
7630
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642
7643
7644
7645
7646
7647
7648
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA1 DOTS OUTSIDE THE FRAMES", text.size = 12, title = "DATA1 + DATA1 SIGNIFICANT DOTS")
}
if( ! is.null(data1.incon.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list(NULL, "kind", NULL), legend.name = list("data1", "vframe", "data1.incon.dots"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA1 INCONSISTENT DOTS", text.size = 12, title = "DATA1 + DATA1 INCONSISTENT DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
7649
7650
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
7651
7652
7653
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7654
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, vframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list(NULL, NULL, "kind"), legend.name = list("data1", "data2", "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7655
7656
7657
7658
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
if( ! is.null(data2.signif.dot)){
Gael  MILLOT's avatar
Gael MILLOT committed
7659
7660
7661
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
7662
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list(NULL, NULL, NULL, "kind"), legend.name = list("data1", "data2", "data2.signif.dots", "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", xlim = x.range.plot, ylim = y.range.plot)
Gael  MILLOT's avatar
Gael MILLOT committed
7663
7664
7665
7666
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
7667
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682
7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 DOTS OUTSIDE THE FRAMES", text.size = 12, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS")
}
if( ! is.null(data2.incon.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list(NULL, NULL, NULL, "kind"), legend.name = list("data1", "data2", "data2.incon.dots", "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 INCONSISTENT DOTS", text.size = 12, title = "DATA2 + DATA2 INCONSISTENT DOTS")
}
if( ! is.null(data2.unknown.dot)){
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list(NULL, NULL, NULL, "kind"), legend.name = list("data1", "data2", "data2.unknown.dots", "vframe"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", xlim = x.range.plot, ylim = y.range.plot)
if( ! is.null(tempo.graph$warnings)){
warning <- paste0(ifelse(is.null(warning), tempo.graph$warnings, paste0(warning, "\n", tempo.graph$warnings)))
}
}else{
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
fun_gg_empty_graph(text = "NO PLOT BECAUSE NO DATA2 UNKNOWN DOTS", text.size = 12, title = "DATA2 + DATA2 UNKNOWN DOTS")
Gael  MILLOT's avatar
Gael MILLOT committed
7699
7700
7701
7702
}
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
7703
7704
# end plot
tempo.list <- list(data1.removed.row.nb = data1.removed.row.nb, data1.removed.rows = data1.removed.rows, data2.removed.row.nb = data2.removed.row.nb, data2.removed.rows = data2.removed.rows, hframe = hframe, vframe = vframe, data1.signif.dot = data1.signif.dot, data1.non.signif.dot = data1.non.signif.dot, data1.inconsistent.dot = data1.incon.dot, data2.signif.dot = data2.signif.dot, data2.non.signif.dot = data2.non.signif.dot, data2.unknown.dot = data2.unknown.dot, data2.inconsistent.dot = data2.incon.dot, warnings = warning)
Gael  MILLOT's avatar
Gael MILLOT committed
7705
7706
7707
7708
7709
7710
7711
return(tempo.list)
}


################ Import


Gael  MILLOT's avatar
Gael MILLOT committed
7712
######## fun_pack_import() #### check if R packages are present and import into the working environment
Gael  MILLOT's avatar
Gael MILLOT committed
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732
7733
7734
7735
7736
7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775


# Check OK: clear to go Apollo
fun_pack_import <- function(req.package, path.lib = NULL){
# AIM
# check if the specified R packages are present in the computer and import them into the working environment
# ARGUMENTS
# req.package: character vector of package names to import
# path.lib: optional character vector specifying the absolute pathways of the directories containing some of the listed packages
# REQUIRED PACKAGES
# none
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_param_check()
# RETURN
# nothing
# EXAMPLES
# fun_pack_import(req.package = "nopackage")
# fun_pack_import(req.package = "ggplot2")
# fun_pack_import(req.package = "ggplot2", path.lib = "blablabla")
# DEBUGGING
# req.package = "ggplot2" ; path.lib = "C:/Program Files/R/R-3.5.1/library"
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# argument checking
arg.check <- NULL # for function debbuging
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
tempo <- fun_param_check(data = req.package, class = "character", fun.name = function.name) ; eval(ee)
if( ! is.null(path.lib)){
tempo <- fun_param_check(data = path.lib, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(path.lib))){
cat(paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE path.lib PARAMETER DOES NOT EXISTS: ", path.lib, "\n\n============\n\n"))
arg.check <- c(arg.check, TRUE)
}
}
if(any(arg.check) == TRUE){
stop() # nothing else because print = TRUE by default in fun_param_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_param_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_param_check()
# end argument checking
# main code
if(is.null(path.lib)){
path.lib <- .libPaths() # .libPaths(new = path.lib) # or .libPaths(new = c(.libPaths(), path.lib))
}else{
.libPaths(new = sub(x = path.lib, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. Beware: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
}
for(i0 in 1:length(req.package)){
if( ! req.package[i0] %in% rownames(installed.packages(lib.loc = path.lib))){
stop(paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i0], " MUST BE INSTALLED IN:\n", paste(path.lib, collapse = "\n"), "\n\n================\n\n"))
}else{
suppressWarnings(suppressPackageStartupMessages(library(req.package[i0], lib.loc = path.lib, quietly = TRUE, character.only = TRUE)))
}
}
}


Gael  MILLOT's avatar
Gael MILLOT committed
7776
######## fun_python_pack_import() #### check if python packages are present
Gael  MILLOT's avatar
Gael MILLOT committed
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794
7795
7796
7797
7798
7799
7800
7801
7802
7803
7804
7805
7806
7807
7808
7809
7810
7811
7812
7813
7814
7815
7816
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837
7838
7839
7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7863
7864
7865


# Check OK: clear to go Apollo
fun_python_pack_import <- function(req.package, path.lib = NULL, R.path.lib = NULL){
# AIM
# check if the specified python packages are present in the computer (no import)
# ARGUMENTS
# req.package: character vector of package names to import
# path.lib: optional character vector specifying the absolute pathways of the directories containing some of the listed packages
# R.path.lib: absolute path of the required packages, if not in the default folders
# REQUIRED PACKAGES
# reticulate
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_param_check()
# fun_pack_import()
# RETURN
# nothing
# EXAMPLES
# fun_python_pack_import(req.package = "nopackage")
# fun_python_pack_import(req.package = "serpentine")
# fun_python_pack_import(req.package = "serpentine", path.lib = "blablabla")
# DEBUGGING
# req.package = "serpentine" ; path.lib = "C:/Program Files/R/R-3.5.1/library" ; R.path.lib = NULL
# req.package = "bad" ; path.lib = NULL ; R.path.lib = NULL
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
if(length(find("fun_pack_import", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_pack_import() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# argument checking
arg.check <- NULL # for function debbuging
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
tempo <- fun_param_check(data = req.package, class = "character", fun.name = function.name) ; eval(ee)
if( ! is.null(path.lib)){
tempo <- fun_param_check(data = path.lib, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(path.lib))){
cat(paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE path.lib PARAMETER DOES NOT EXISTS: ", path.lib, "\n\n============\n\n"))
arg.check <- c(arg.check, TRUE)
}
}
if( ! is.null(R.path.lib)){
tempo <- fun_param_check(data = R.path.lib, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(R.path.lib))){
cat(paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE R.path.lib PARAMETER DOES NOT EXISTS: ", R.path.lib, "\n\n============\n\n"))
arg.check <- c(arg.check, TRUE)
}
}
if(any(arg.check) == TRUE){
stop() # nothing else because print = TRUE by default in fun_param_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_param_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_param_check()
# end argument checking
# package checking
fun_pack_import(req.package = "reticulate", path.lib = R.path.lib)
# end package checking
# main code
if(is.null(path.lib)){
path.lib <- reticulate::py_run_string("
import sys ;
path_lib = sys.path
") # python string
path.lib <- path.lib$path_lib
}
for(i0 in 1:length(req.package)){
tempo.try <- vector("list", length = length(path.lib))
for(i1 in 1:length(path.lib)){
tempo.try[[i1]] <- try(suppressWarnings(reticulate::import_from_path(req.package[i0], path = path.lib[i1])), silent = TRUE)
}
if(all(sapply(tempo.try, FUN = grepl, pattern = "[Ee]rror"))){
stop(paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i0], " MUST BE INSTALLED IN THE MENTIONNED DIRECTORY:\n", paste(path.lib, collapse = "\n"), "\n\n================\n\n"))
}else{
assign(req.package[i0], reticulate::import(req.package[i0]))
}
}
}


################ Exporting results (text & tables)


Gael  MILLOT's avatar
Gael MILLOT committed
7866
######## fun_export_data() #### print string or data object into output file
Gael  MILLOT's avatar
Gael MILLOT committed
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878
7879
7880
7881
7882
7883
7884
7885
7886
7887
7888
7889
7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
7938
7939
7940
7941
7942
7943
7944
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971


# Check OK: clear to go Apollo
fun_export_data <- function(data = NULL, output ="results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = TRUE, sep = 2){
# AIM
# log file function: print a character string or a data object into a same output file
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_param_check()
# ARGUMENTS
# data: object to print in the output file. cannot be NULL
# output: name of the output file
# path: location of the output file
# no.overwrite: (logical) if output file already exists, defines if the printing is appended (default TRUE) or if the output file content is erased before printing (FALSE)
# rownames.kept: (logical) defines whether row names have to be removed or not in small tables (less than length.rows rows)
# vector.cat (logical). If TRUE print a vector of length > 1 using cat() instead of capture.output(). Otherwise (default FALSE) the opposite
# noquote: (logical). If TRUE no quote are present for the characters
# sep: number of separating lines after printed data (must be integer)
# RETURN
# nothing
# EXAMPLES
# fun_export_data()
# fun_export_data(data = 1:3, output = "results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = FALSE, sep = 2)
# DEBUGGING
# data = 1:3 ; output = "results.txt" ; path = "C:/Users/Gael/Desktop" ; no.overwrite = TRUE ; rownames.kept = FALSE ; vector.cat = FALSE ; noquote = FALSE ; sep = 2 # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(find("fun_param_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_param_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
}
# end required function checking
# argument checking
# argument checking without fun_param_check()
if(is.null(data)){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": data ARGUMENT CANNOT BE NULL\n\n================\n\n")
stop(tempo.cat)
}
# end argument checking without fun_param_check()
# argument checking with fun_param_check()
arg.check <- NULL # for function debbuging
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , checked.arg.names <- c(checked.arg.names, tempo$param.name))
tempo <- fun_param_check(data = output, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & output == ""){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": output ARGUMENT AS \"\" DOES NOT CORRESPOND TO A VALID FILE NAME\n\n================\n\n")
arg.check <- c(arg.check, TRUE)
}
tempo <- fun_param_check(data = path, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & dir.exists(path) == FALSE){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n", paste(path, collapse = "\n"),"\n\n================\n\n")
arg.check <- c(arg.check, TRUE)
}
tempo <- fun_param_check(data = no.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = rownames.kept, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = vector.cat, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = noquote, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = sep, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop() # nothing else because print = TRUE by default in fun_param_check()
}
# end argument checking with fun_param_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_param_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_param_check()
# the 4 next lines are inactivated but kept because at a time, I might have a problem with data (solved with data = NULL). These 4 lines are just to know how to detect a missing argument. Important here because if data is not provided, print the code of the data function
# arg.user.list <- as.list(match.call(expand.dots=FALSE))[-1] # recover all the arguments provided by the function user (excluding the argument with defaults values not provided by the user. Thus, it is really the list indicated by the user)
# default.arg.list <- formals(fun = sys.function(sys.parent())) # list of all the arguments of the function with their default values (not the values of the user !). It seems that ls() as first line of the function provide the names of the arguments (empty, called, etc., or not)
# arg.without.default.value <- sapply(default.arg.list, is.symbol) & sapply(sapply(default.arg.list, as.character), identical, "") # logical to detect argument without default values (these are typeof "symbol" and class "name" and empty character
# if( ! all(names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list))){ # test that the arguments with no null values are provided by the user
# tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": VALUE REQUIRED FOR THESE ARGUMENTS WITH NO DEFAULTS VALUES: ", paste(names(default.arg.list)[arg.without.default.value][ ! names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list)], collapse = " "), "\n\n================\n\n")
#stop(tempo.cat)
# }
# end argument checking
# main code
if(all(class(data) %in% c("matrix", "data.frame", "table"))){
if(rownames.kept == FALSE & all(class(data) == "data.frame") & nrow(data) != 0 & nrow(data) <= 4){ # for data frames with nrows <= 4
rownames.output.tables <- ""
length.rows <- nrow(data)
for(i in 1:length.rows){ # replace the rownames of the first 4 rows by increasing number of spaces (beacause identical row names not allowed in data frames). This method cannot be extended to more rows as the printed data frame is shifted on the right because of "big empty rownames"
rownames.output.tables <- c(rownames.output.tables, paste0(rownames.output.tables[i]," ", collapse=""))
}
row.names(data) <- rownames.output.tables[1:length.rows]
}else if(rownames.kept == FALSE & all(class(data) %in% c("matrix", "table"))){
rownames(data) <- rep("", nrow(data)) # identical row names allowed in matrices and tables
}
if(noquote == TRUE){
capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
}
}else if(is.vector(data) & all(class(data) != "list") & (length(data) == 1 | vector.cat == TRUE)){
if(noquote == TRUE){
cat(noquote(data), file= paste0(path, "/", output), append = no.overwrite)
}else{
cat(data, file= paste0(path, "/", output), append = no.overwrite)
}
}else{ # other (array, list, factor or vector with vector.cat = FALSE)
if(noquote == TRUE){
capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
}
}
sep.final <- paste0(rep("\n", sep), collapse = "")
write(sep.final, file= paste0(path, "/", output), append = TRUE) # add a sep
Gael  MILLOT's avatar
Gael MILLOT committed
7972
7973
7974
}