cute_little_R_functions.R 678 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
8001
8002
}
# end Method using x unit interval 
Gael  MILLOT's avatar
Gael MILLOT committed
8003
8004
8005
8006




Gael  MILLOT's avatar
Gael MILLOT committed
8007
8008
8009
8010
8011
8012
8013
8014
8015
8016
8017
8018
8019
8020
8021
8022
8023
8024
8025
8026
8027
8028
8029
8030
# Method using y unit interval 
y.data1.d <- NULL # y coord of the x upper and lower limits defined on the data1 cloud for down step line
y.data1.t <- NULL # y coord of the x upper and lower limits defined on the data1 cloud for top step line
x.data1.left.limit.d <- NULL # left limit of the data1 cloud for down step line
x.data1.right.limit.d <- NULL # right limit of the data1 cloud for down step line
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
8031
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
8032
8033
# recover data2 dots outside the range of data1
if(any(data2[, y2] < y.range[1])){
Gael  MILLOT's avatar
Gael MILLOT committed
8034
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
8035
8036
}
if(any(data2[, y2] > y.range[2])){
Gael  MILLOT's avatar
Gael MILLOT committed
8037
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
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
}
# 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
8059
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
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
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
8075
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
8076
8077
8078
8079
8080
8081
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
8082
8083
8084
8085
8086
8087
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
8088
8089
8090
8091
8092
8093
8094
8095
8096
8097
8098
8099
8100
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
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
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
8115
8116
8117
# 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
8118
8119
8120
8121



# recovering the frame coordinates
Gael  MILLOT's avatar
Gael MILLOT committed
8122
8123
8124
8125
8126
8127
8128
8129
8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
8163
8164
8165
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
8166
8167
# end recovering the frame coordinates
# recovering the dot coordinates
Gael  MILLOT's avatar
Gael MILLOT committed
8168
data1.signif.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
8169
8170
data1.non.signif.dot <- NULL
data1.incon.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
8171
data2.signif.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
8172
8173
8174
data2.non.signif.dot <- NULL
data2.unknown.dot <- NULL
data2.incon.dot <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
8175
if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
8176
8177
8178
8179
8180
8181
8182
8183
8184
8185
8186
8187
8188
8189
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216
8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
# 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
8236
if(length(unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final))) > 0){
Gael  MILLOT's avatar
Gael MILLOT committed
8237
8238
8239
8240
8241
8242
8243
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
8244
8245
}
}else if(xy.cross.kind == "&"){
Gael  MILLOT's avatar
Gael MILLOT committed
8246
8247
8248
8249
8250
8251
8252
8253
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
8254
8255
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8256
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 4\n\n============\n\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
8257
8258
8259
stop(tempo.cat)
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
8260
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
8261
if(length(unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final))) > 0){
Gael  MILLOT's avatar
Gael MILLOT committed
8262
8263
8264
8265
8266
8267
8268
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
8269
8270
}
}else if(xy.cross.kind == "&"){
Gael  MILLOT's avatar
Gael MILLOT committed
8271
8272
8273
8274
8275
8276
8277
8278
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
8279
8280
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8281
tempo.cat <- (paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 5\n\n============\n\n"))
Gael  MILLOT's avatar
Gael MILLOT committed
8282
8283
8284
stop(tempo.cat)
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8285
# end sign and non sign dot recovery
Gael  MILLOT's avatar
Gael MILLOT committed
8286
}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){
Gael  MILLOT's avatar
Gael MILLOT committed
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
8298
8299
8300
8301
8302
8303
8304
8305
8306
8307
8308
8309
8310
8311
8312
# 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
8313
8314
8315
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
8316
8317
8318
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
8319
8320
8321
8322
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
8323
8324
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
8325
}
Gael  MILLOT's avatar
Gael MILLOT committed
8326
8327
}
# end sign and non sign dot recovery
Gael  MILLOT's avatar
Gael MILLOT committed
8328
}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
8329
8330
8331
8332
8333
8334
8335
8336
8337
8338
8339
8340
8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
# 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
8355
8356
8357
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
8358
8359
8360
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
8361
8362
8363
8364
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
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
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
8376
}
Gael  MILLOT's avatar
Gael MILLOT committed
8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387
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
8388
}
Gael  MILLOT's avatar
Gael MILLOT committed
8389
8390
8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
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
8449
8450
if(graph.check == TRUE){
if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
8451
8452
8453
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8454
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8455
8456
8457
8458
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
8459
8460
8461
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8462
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8463
8464
8465
8466
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
8467
8468
8469
8470
8471
8472
8473
8474
8475
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8476
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8477
8478
8479
8480
8481
8482
8483
8484
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
8485
8486
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
8487
8488
8489
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8490
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8491
8492
8493
8494
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
8495
8496
8497
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8498
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8499
8500
8501
8502
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
8503
8504
8505
8506
8507
8508
8509
8510
8511
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8512
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8526
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8527
8528
8529
8530
8531
8532
8533
8534
8535

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
8536
8537
8538
}
}
}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){
Gael  MILLOT's avatar
Gael MILLOT committed
8539
8540
8541
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8542
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8543
8544
8545
8546
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
8547
8548
8549
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8550
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8551
8552
8553
8554
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
8555
8556
8557
8558
8559
8560
8561
8562
8563
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8564
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8565
8566
8567
8568
8569
8570
8571
8572
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
8573
8574
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
8575
8576
8577
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8578
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8579
8580
8581
8582
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
8583
8584
8585
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8586
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8587
8588
8589
8590
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
8591
8592
8593
8594
8595
8596
8597
8598
8599
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8600
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8601
8602
8603
8604
8605
8606
8607
8608
8609
8610
8611
8612
8613
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8614
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8615
8616
8617
8618
8619
8620
8621
8622
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
8623
8624
8625
}
}
}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){
Gael  MILLOT's avatar
Gael MILLOT committed
8626
8627
8628
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8629
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8630
8631
8632
8633
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
8634
8635
8636
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8637
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8638
8639
8640
8641
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
8642
8643
8644
8645
8646
8647
8648
8649
8650
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8651
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8652
8653
8654
8655
8656
8657
8658
8659
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
8660
8661
}
if( ! is.null(data2)){
Gael  MILLOT's avatar
Gael MILLOT committed
8662
8663
8664
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8665
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8666
8667
8668
8669
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
8670
8671
8672
if(graph.in.file == FALSE){
fun_open_window(pdf.disp = FALSE)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8673
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8674
8675
8676
8677
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
8678
8679
8680
8681
8682
8683
8684
8685
8686
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8687
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8688
8689
8690
8691
8692
8693
8694
8695
8696
8697
8698
8699
8700
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)
}
Gael  MILLOT's avatar
Gael MILLOT committed
8701
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, raster = raster)
Gael  MILLOT's avatar
Gael MILLOT committed
8702
8703
8704
8705
8706
8707
8708
8709
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
8710
8711
8712
8713
}
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8714
8715
# 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
8716
8717
8718
8719
8720
8721
8722
return(tempo.list)
}


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


Gael  MILLOT's avatar
Gael MILLOT committed
8723
######## fun_pack_import() #### check if R packages are present and import into the working environment
Gael  MILLOT's avatar
Gael MILLOT committed
8724
8725
8726


# Check OK: clear to go Apollo
8727
fun_pack_import <- function(req.package, load = FALSE, path.lib = NULL){
Gael  MILLOT's avatar
Gael MILLOT committed
8728
8729
8730
8731
# 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
8732
# req.package: logical. Load the package into the environement (using library())?
Gael  MILLOT's avatar
Gael MILLOT committed
8733
8734
8735
8736
8737
8738
8739
8740
8741
8742
8743
8744
8745
8746
8747
8748
8749
8750
8751
8752
8753
8754
8755
8756
8757
8758
# 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))
8759
8760
tempo <- fun_param_check(data = req.package, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
tempo <- fun_param_check(data = load, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
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{
8777
.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
Gael  MILLOT's avatar
Gael MILLOT committed
8778
8779
8780
8781
8782
}
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{
8783
if(load == TRUE){
Gael  MILLOT's avatar
Gael MILLOT committed
8784
8785
8786
8787
suppressWarnings(suppressPackageStartupMessages(library(req.package[i0], lib.loc = path.lib, quietly = TRUE, character.only = TRUE)))
}
}
}
8788
}
Gael  MILLOT's avatar
Gael MILLOT committed
8789
8790


Gael  MILLOT's avatar
Gael MILLOT committed
8791
######## fun_python_pack_import() #### check if python packages are present
Gael  MILLOT's avatar
Gael MILLOT committed
8792
8793
8794
8795
8796
8797
8798
8799
8800
8801
8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
8823
8824
8825
8826
8827
8828
8829
8830
8831
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
8846
8847
8848
8849
8850
8851
8852
8853
8854
8855
8856
8857
8858
8859
8860
8861
8862
8863
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
8879
8880


# 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
8881
######## fun_report() #### print string or data object into output file
Gael  MILLOT's avatar
Gael MILLOT committed
8882
8883
8884
8885
8886
8887
8888
8889
8890
8891
8892
8893
8894
8895
8896
8897
8898
8899
8900
8901


# 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
Gael  MILLOT's avatar
Gael MILLOT committed
8902
8903
# fun_report()
# fun_report(data = 1:3, output = "results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = FALSE, sep = 2)
Gael  MILLOT's avatar
Gael MILLOT committed
8904
8905
8906
8907
8908
8909
8910
8911
8912
8913
8914
8915
8916
8917
8918
8919
8920
8921
8922
8923
8924
8925
8926
8927
8928
# 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")
Gael  MILLOT's avatar
Gael MILLOT committed
8929
cat(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
8930
8931
8932
8933
8934
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")
Gael  MILLOT's avatar
Gael MILLOT committed
8935
cat(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
8936
8937
8938
8939
8940
8941
8942
8943
8944
8945
8946
8947
8948
8949
8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
8979
8980
8981
8982
8983
8984
8985
8986
8987
8988
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
8989
8990
8991
}