cute_little_R_functions.R 884 KB
Newer Older
12001
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael's avatar
tempo    
Gael committed
12002
}
12003
12004
12005
12006
12007
12008
12009
12010
12011
12012
12013
12014
12015
12016
12017
12018
12019
12020
12021
12022
12023
12024
12025
12026
12027
y.lim <- suppressWarnings(range(unlist(mapply(FUN = "[[", data1, y, SIMPLIFY = FALSE)), na.rm = TRUE, finite = TRUE)) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only. y.lim added here. If NULL, ok if y argument has values
}else if(y.log != "no"){
y.lim <- get(y.log)(y.lim) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
}
if(y.log != "no"){
if(any( ! is.finite(y.lim))){
tempo.cat <- paste0("ERROR IN ", function.name, "\ny.lim ARGUMENT CANNOT HAVE ZERO OR NEGATIVE VALUES WITH THE y.log ARGUMENT SET TO ", y.log, ":\n", paste(y.lim, collapse = " "), "\nPLEASE, CHECK DATA VALUES (PRESENCE OF ZERO OR INF VALUES)")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}
}
if(suppressWarnings(all(y.lim %in% c(Inf, -Inf)))){ # happen when y is only NULL
if(all(unlist(geom) == "geom_vline")){
tempo.cat <- paste0("ERROR IN ", function.name, " NOT POSSIBLE TO DRAW geom_vline KIND OF LINES ALONE IF y.lim ARGUMENT IS SET TO NULL, SINCE NO Y-AXIS DEFINED (", ifelse(length(y) == 1, "y", paste0("ELEMENT ", i1, " OF y")), " ARGUMENT MUST BE NULL FOR THESE KIND OF LINES)")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}else{
tempo.cat <- paste0("ERROR IN ", function.name, " y.lim ARGUMENT MADE OF NA, -Inf OR Inf ONLY: ", paste(y.lim, collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}
}
y.lim.order <- order(y.lim) # to deal with inverse axis
y.lim <- sort(y.lim)
y.lim[1] <- y.lim[1] - abs(y.lim[2] - y.lim[1]) * ifelse(diff(y.lim.order) > 0, y.bottom.extra.margin, y.top.extra.margin) # diff(y.lim.order) > 0 means not inversed axis
y.lim[2] <- y.lim[2] + abs(y.lim[2] - y.lim[1]) * ifelse(diff(y.lim.order) > 0, y.top.extra.margin, y.bottom.extra.margin) # diff(y.lim.order) > 0 means not inversed axis
if(y.include.zero == TRUE){ # no need to check y.log != "no" because done before
y.lim <- range(c(y.lim, 0), na.rm = TRUE, finite = TRUE) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only
Gael's avatar
tempo    
Gael committed
12028
}
12029
12030
12031
12032
12033
12034
y.lim <- y.lim[y.lim.order]
if(any(is.na(y.lim))){
tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 4")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}
# end axes management
12035
12036
12037
12038




12039
12040
12041
12042
12043
12044
12045
12046
# create a fake categ if NULL to deal with legend display
if(is.null(categ)){
categ <- vector("list", length(data1))
categ[] <- "fake_categ"
for(i2 in 1:length(data1)){
data1[[i2]] <- cbind(data1[[i2]], fake_categ = "", stringsAsFactors = TRUE)
if(geom[[i2]] == "geom_hline" | geom[[i2]] == "geom_vline"){
data1[[i2]][, "fake_categ"] <- factor(paste0("Line_", 1:nrow(data1[[i2]])))
Gael's avatar
tempo    
Gael committed
12047
}
12048
12049
12050
12051
12052
12053
12054
12055
12056
12057
12058
12059
12060
12061
12062
12063
12064
12065
12066
12067
12068
12069
12070
12071
12072
12073
12074
12075
12076
12077
12078
12079
12080
12081
12082
12083
12084
12085
12086
12087
12088
12089
}
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") NULL categ ARGUMENT -> FAKE \"fake_categ\" COLUMN ADDED TO EACH DATA FRAME OF data1, AND FILLED WITH \"\"")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
# categ is not NULL anymore
if(is.null(categ.class.order)){
categ.class.order <- vector("list", length = length(data1))
tempo.categ.class.order <- NULL
for(i2 in 1:length(categ.class.order)){
categ.class.order[[i2]] <- levels(data1[[i2]][, categ[[i2]]])
names(categ.class.order)[i2] <- categ[[i2]]
tempo.categ.class.order <- c(tempo.categ.class.order, ifelse(i2 != 1, "\n", ""), categ.class.order[[i2]])
}
if(any(unlist(legend.disp))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") THE categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR CLASS ORDERING:\n", paste(tempo.categ.class.order, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}
# end create a fake categ if NULL to deal with legend display
# categ.class.order is not NULL anymore


# vector of color with length as in levels(categ) of data1
if(is.null(color)){
color <- vector("list", length(data1))
length.categ.list <- lapply(lapply(mapply(FUN = "[[", data1, categ, SIMPLIFY = FALSE), FUN = unique), FUN = function(x){length(x[ ! is.na(x)])})
length.categ.list[sapply(categ, FUN = "==", "fake_categ")] <- 1 # when is.null(color), a single color for all the dots or lines of data[[i1]] that contain "fake_categ" category
total.categ.length <- sum(unlist(length.categ.list), na.rm = TRUE)
tempo.color <- fun_gg_palette(total.categ.length)
tempo.count <- 0
for(i2 in 1:length(data1)){
color[[i2]] <- tempo.color[(1:length.categ.list[[i2]]) + tempo.count]
tempo.count <- tempo.count + length.categ.list[[i2]]
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") NULL color ARGUMENT -> COLORS RESPECTIVELY ATTRIBUTED TO EACH CLASS OF ", ifelse(length(categ) == 1, "categ", paste0("ELEMENT ", i2, " OF categ ARGUMENT")), " (", categ[[i2]], ") IN ", ifelse(length(data1) == 1, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i2, " OF data1 ARGUMENT")), ":\n", paste(color[[i2]], collapse = " "), "\n", paste(if(all(levels(data1[[i2]][, categ[[i2]]]) == "")){'\"\"'}else{levels(data1[[i2]][, categ[[i2]]])}, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}
# end vector of color with length as in levels(categ) of data1
# color is not NULL anymore
12090
12091
12092
12093
12094





12095
12096
12097
12098
12099
12100
12101
12102
# last check
for(i1 in 1:length(data1)){
if(categ[[i1]] != "fake_categ" & length(color[[i1]]) != length(unique(data1[[i1]][, categ[[i1]]]))){
tempo.cat <- paste0("ERROR IN ", function.name, " LAST CHECK: ", ifelse(length(color) == 1, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST HAVE THE LENGTH OF LEVELS OF ", ifelse(length(categ) == 1, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1) == 1, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), "\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LEVELS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]])))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}else if(categ[[i1]] == "fake_categ" & length(color[[i1]]) != 1){
tempo.cat <- paste0("ERROR IN ", function.name, " LAST CHECK: ", ifelse(length(color) == 1, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST HAVE LENGTH 1 WHEN ", ifelse(length(categ) == 1, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IS NULL\nHERE IT IS COLOR LENGTH ", length(color[[i1]]))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
Gael's avatar
tempo    
Gael committed
12103
12104
}
}
12105
# end last check
12106
12107
12108
12109
12110





12111
12112
12113
12114
12115
12116
12117
12118
12119
12120
12121
12122
12123
# conversion of geom_hline and geom_vline
for(i1 in 1:length(data1)){
if(geom[[i1]] == "geom_hline" | geom[[i1]] == "geom_vline"){
final.data.frame <- data.frame()
for(i3 in 1:nrow(data1[[i1]])){
tempo.data.frame <- rbind(data1[[i1]][i3, ], data1[[i1]][i3, ], stringsAsFactors = TRUE)
if(geom[[i1]] == "geom_hline"){
tempo.data.frame[, x[[i1]]] <- x.lim
}else if(geom[[i1]] == "geom_vline"){
tempo.data.frame[, y[[i1]]] <- y.lim
}else{
tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 5")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
Gael's avatar
tempo    
Gael committed
12124
}
12125
12126
12127
12128
12129
# 3 lines below inactivated because I put that above
# if(is.null(categ[[i1]])){
# data1[, "fake_categ"] <- paste0("Line_", i3)
# }
final.data.frame <- rbind(final.data.frame, tempo.data.frame, stringsAsFactors = TRUE)
Gael's avatar
tempo    
Gael committed
12130
}
12131
12132
12133
12134
12135
12136
12137
12138
12139
12140
12141
data1[[i1]] <- final.data.frame
geom[[i1]] <- "geom_line"
if(length(color[[i1]]) == 1){
color[[i1]] <- rep(color[[i1]], length(unique(data1[[i1]][ , categ[[i1]]])))
}else if(length(color[[i1]]) != length(unique(data1[[i1]][ , categ[[i1]]]))){
tempo.cat <- paste0("ERROR IN ", function.name, " geom_hline AND geom_vline CONVERSION TO FIT THE XLIM AND YLIM LIMITS OF THE DATA: ", ifelse(length(color) == 1, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST HAVE THE LENGTH OF LEVELS OF ", ifelse(length(categ) == 1, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1) == 1, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), "\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LEVELS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]])))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}
}
}
# end conversion of geom_hline and geom_vline
12142
12143
12144
12145




12146
12147
12148
12149
12150
12151
12152
12153
12154
12155
12156
12157
# kind of geom_point (vectorial or raster)
scatter.kind <- vector("list", length = length(data1)) # list of same length as data1, that will be used to use either ggplot2::geom_point() (vectorial dot layer) or fun_gg_point_rast() (raster dot layer)
fix.ratio <- FALSE
if(is.null(raster.threshold)){
if(raster == TRUE){
scatter.kind[] <- "fun_gg_point_rast" # not important to fill everything: will be only used when geom == "geom_point"
fix.ratio <- TRUE
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") RASTER PLOT GENERATED -> ASPECT RATIO OF THE PLOT REGION SET BY THE raster.ratio ARGUMENT (", fun_round(raster.ratio, 2), ") TO AVOID A BUG OF ELLIPSOID DOT DRAWING")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else{
scatter.kind[] <- "ggplot2::geom_point"
Gael's avatar
tempo    
Gael committed
12158
}
12159
12160
12161
12162
12163
12164
12165
12166
12167
12168
12169
12170
12171
12172
12173
12174
12175
12176
12177
12178
12179
12180
12181
12182
12183
12184
12185
12186
12187
12188
12189
12190
12191
12192
12193
12194
12195
12196
12197
12198
12199
12200
12201
12202
12203
12204
12205
12206
12207
12208
12209
12210
12211
12212
12213
12214
12215
12216
12217
12218
12219
12220
12221
12222
12223
12224
12225
12226
12227
12228
12229
12230
12231
12232
12233
12234
12235
12236
12237
12238
12239
12240
12241
12242
12243
12244
12245
12246
12247
12248
12249
12250
12251
12252
12253
12254
12255
12256
12257
12258
12259
12260
12261
12262
12263
12264
12265
12266
12267
12268
12269
12270
12271
12272
12273
12274
12275
12276
12277
12278
12279
12280
12281
12282
12283
12284
12285
12286
12287
12288
12289
12290
12291
12292
12293
12294
12295
12296
12297
12298
12299
12300
12301
12302
12303
12304
12305
12306
12307
12308
12309
12310
12311
12312
12313
12314
12315
12316
12317
12318
12319
12320
12321
12322
12323
12324
12325
12326
}else{
for(i2 in 1:length(data1)){
if(geom[[i2]] == "geom_point"){
if(nrow(data1[[i2]]) <= raster.threshold){
scatter.kind[[i2]] <- "ggplot2::geom_point"
}else{
scatter.kind[[i2]] <- "fun_gg_point_rast"
fix.ratio <- TRUE
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") ", ifelse(length(data1) == 1, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i2, " OF data1 ARGUMENT")), " LAYER AS RASTER (NOT VECTORIAL)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}
}
if(any(unlist(scatter.kind) == "fun_gg_point_rast")){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") RASTER PLOT GENERATED -> ASPECT RATIO OF THE PLOT REGION SET BY THE raster.ratio ARGUMENT (", fun_round(raster.ratio, 2), ") TO AVOID A BUG OF ELLIPSOID DOT DRAWING")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}
# end kind of geom_point (vectorial or raster)




# no need loop part
coord.names <- NULL
tempo.gg.name <- "gg.indiv.plot."
tempo.gg.count <- 0
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add added here to have the facets
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::xlab(if(is.null(x.lab)){x[[1]]}else{x.lab}))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylab(if(is.null(y.lab)){y[[1]]}else{y.lab}))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title))
# text angle management
x.tempo.just <- fun_gg_just(angle = x.text.angle, pos = "bottom", kind = "axis")
y.tempo.just <- fun_gg_just(angle = y.text.angle, pos = "left", kind = "axis")
# end text angle management
add.check <- TRUE
if( ! is.null(add)){ # if add is NULL, then = 0
if(grepl(pattern = "ggplot2::theme", add) == TRUE){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") \"ggplot2::theme\" STRING DETECTED IN THE add ARGUMENT\n-> INTERNAL GGPLOT2 THEME FUNCTIONS theme() AND theme_classic() HAVE BEEN INACTIVATED, TO BE USED BY THE USER\n-> article ARGUMENT WILL BE IGNORED\nIT IS RECOMMENDED TO USE \"+ theme(aspect.ratio = raster.ratio)\" IF RASTER MODE IS ACTIVATED")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
add.check <- FALSE
}
}
if(add.check == TRUE & article == TRUE){
# WARNING: not possible to add several times theme(). NO message but the last one overwrites the others
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_classic(base_size = text.size))
if(grid == TRUE){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
text = ggplot2::element_text(size = text.size), 
plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend
line = ggplot2::element_line(size = 0.5), 
axis.line.y.left = ggplot2::element_line(colour = "black"), # draw lines for the y axis
axis.line.x.bottom = ggplot2::element_line(colour = "black"), # draw lines for the x axis
panel.grid.major.x = ggplot2::element_line(colour = "grey85", size = 0.75), 
panel.grid.minor.x = ggplot2::element_line(colour = "grey90", size = 0.25), 
panel.grid.major.y = ggplot2::element_line(colour = "grey85", size = 0.75), 
panel.grid.minor.y = ggplot2::element_line(colour = "grey90", size = 0.25), 
axis.text.x = ggplot2::element_text(angle = x.tempo.just$angle, hjust = x.tempo.just$hjust, vjust = x.tempo.just$vjust),
axis.text.y = ggplot2::element_text(angle = y.tempo.just$angle, hjust = y.tempo.just$hjust, vjust = y.tempo.just$vjust), 
aspect.ratio = if(fix.ratio == TRUE){raster.ratio}else{NULL} # for raster
))
}else{
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
text = ggplot2::element_text(size = text.size), 
plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
line = ggplot2::element_line(size = 0.5), 
legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend
axis.line.y.left = ggplot2::element_line(colour = "black"), 
axis.line.x.bottom = ggplot2::element_line(colour = "black"), 
axis.text.x = ggplot2::element_text(angle = x.tempo.just$angle, hjust = x.tempo.just$hjust, vjust = x.tempo.just$vjust),
axis.text.y = ggplot2::element_text(angle = y.tempo.just$angle, hjust = y.tempo.just$hjust, vjust = y.tempo.just$vjust), 
aspect.ratio = if(fix.ratio == TRUE){raster.ratio}else{NULL} # for raster
))
}
}else if(add.check == TRUE & article == FALSE){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
text = ggplot2::element_text(size = text.size), 
plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
line = ggplot2::element_line(size = 0.5), 
legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend
panel.background = ggplot2::element_rect(fill = "grey95"), 
axis.line.y.left = ggplot2::element_line(colour = "black"), 
axis.line.x.bottom = ggplot2::element_line(colour = "black"), 
panel.grid.major.x = ggplot2::element_line(colour = "grey85", size = 0.75), 
panel.grid.minor.x = ggplot2::element_line(colour = "grey90", size = 0.25), 
panel.grid.major.y = ggplot2::element_line(colour = "grey85", size = 0.75), 
panel.grid.minor.y = ggplot2::element_line(colour = "grey90", size = 0.25), 
strip.background = ggplot2::element_rect(fill = "white", colour = "black"), 
axis.text.x = ggplot2::element_text(angle = x.tempo.just$angle, hjust = x.tempo.just$hjust, vjust = x.tempo.just$vjust),
axis.text.y = ggplot2::element_text(angle = y.tempo.just$angle, hjust = y.tempo.just$hjust, vjust = y.tempo.just$vjust), 
aspect.ratio = if(fix.ratio == TRUE){raster.ratio}else{NULL} # for raster
# do not work -> legend.position = "none" # to remove the legend completely: https://www.datanovia.com/en/blog/how-to-remove-legend-from-a-ggplot/
))
}
# end no need loop part


# loop part
point.count <- 0
line.count <- 0
lg.order <- vector(mode = "list", length = 6) # order of the legend
lg.order <- lapply(lg.order, as.numeric) # order of the legend
lg.color <- vector(mode = "list", length = 6) # color of the legend
lg.dot.shape <- vector(mode = "list", length = 6) # etc.
lg.dot.size <- vector(mode = "list", length = 6) # etc.
lg.dot.size <- lapply(lg.dot.size, as.numeric) # etc.
lg.dot.border.size <- vector(mode = "list", length = 6) # etc.
lg.dot.border.size <- lapply(lg.dot.border.size, as.numeric) # etc.
lg.dot.border.color <- vector(mode = "list", length = 6) # etc.
lg.line.size <- vector(mode = "list", length = 6) # etc.
lg.line.size <- lapply(lg.line.size, as.numeric) # etc.
lg.line.type <- vector(mode = "list", length = 6) # etc.
lg.alpha <- vector(mode = "list", length = 6) # etc.
lg.alpha <- lapply(lg.alpha, as.numeric) # etc.
for(i1 in 1:length(data1)){
if(geom[[i1]] == "geom_point"){
point.count <- point.count + 1
if(point.count == 1){
fin.lg.disp[[1]] <- legend.disp[[point.count + line.count]]
lg.order[[1]] <- point.count + line.count
lg.color[[1]] <- color[[i1]] # if color == NULL -> NULL
lg.dot.shape[[1]] <- dot.shape[[i1]]
lg.dot.size[[1]] <- dot.size[[i1]]
lg.dot.border.size[[1]] <- dot.border.size[[i1]]
lg.dot.border.color[[1]] <- dot.border.color[[i1]] # if dot.border.color == NULL -> NULL
if(plot == TRUE & fin.lg.disp[[1]] == TRUE & dot.shape[[1]] %in% 0:14 & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE DOTS (DOT LAYER NUMBER ", point.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
lg.alpha[[1]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
}else{
lg.alpha[[1]] <- alpha[[i1]]
}
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], fill = categ[[i1]]), shape = dot.shape[[i1]], size = dot.size[[i1]], stroke = dot.border.size[[i1]], color = if(dot.shape[[i1]] %in% 21:24 & ! is.null(dot.border.color)){dot.border.color[[i1]]}else{color[[i1]][i5]}, alpha = alpha[[i1]], show.legend = if(i5 == 1){TRUE}else{FALSE})) # WARNING: a single color allowed for color argument outside aesthetic, but here a single color for border --> loop could be inactivated but kept for commodity # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_manual(name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = as.character(color[[i1]]), breaks = class.categ)) # values are the values of fill, breaks reorder the classes according to class.categ in the legend, order argument of guide_legend determines the order of the different aesthetics in the legend (not order of classes). See guide_legend settings of scale_..._manual below
}
if(point.count == 2){
fin.lg.disp[[2]] <- legend.disp[[point.count + line.count]]
lg.order[[2]] <- point.count + line.count
lg.color[[2]] <- color[[i1]] # if color == NULL -> NULL
lg.dot.shape[[2]] <- dot.shape[[i1]]
lg.dot.size[[2]] <- dot.size[[i1]]
lg.dot.border.size[[2]] <- dot.border.size[[i1]]
lg.dot.border.color[[2]] <- dot.border.color[[i1]] # if dot.border.color == NULL -> NULL
if(plot == TRUE & fin.lg.disp[[2]] == TRUE & dot.shape[[2]] %in% 0:14 & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE DOTS (DOT LAYER NUMBER ", point.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
lg.alpha[[2]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
}else{
lg.alpha[[2]] <- alpha[[i1]]
}
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], shape = categ[[i1]]), size = dot.size[[i1]], stroke = dot.border.size[[i1]], fill = color[[i1]][i5], color = if(dot.shape[[i1]] %in% 21:24 & ! is.null(dot.border.color)){dot.border.color[[i1]]}else{color[[i1]][i5]}, alpha = alpha[[i1]], show.legend = FALSE)) # WARNING: a single color allowed for fill argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_shape_manual(name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(dot.shape[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of shape, breaks reorder the classes according to class.categ in the legend. See guide_legend settings of scale_..._manual below
Gael's avatar
Gael committed
12327

12328
12329
12330
12331
12332
12333
12334
12335
12336
12337
12338
12339
12340
12341
12342
12343
12344
12345
12346
12347
12348
12349
12350
12351
}
if(point.count == 3){
fin.lg.disp[[3]] <- legend.disp[[point.count + line.count]]
lg.order[[3]] <- point.count + line.count
lg.color[[3]] <- color[[i1]] # if color == NULL -> NULL
lg.dot.shape[[3]] <- dot.shape[[i1]]
lg.dot.size[[3]] <- dot.size[[i1]]
lg.dot.border.size[[3]] <- dot.border.size[[i1]]
lg.dot.border.color[[3]] <- dot.border.color[[i1]] # if dot.border.color == NULL -> NULL
if(plot == TRUE & fin.lg.disp[[3]] == TRUE & dot.shape[[3]] %in% 0:14 & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE DOTS (DOT LAYER NUMBER ", point.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
lg.alpha[[3]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
}else{
lg.alpha[[3]] <- alpha[[i1]]
}
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], stroke = categ[[i1]]), shape = dot.shape[[i1]], size = dot.size[[i1]], fill = color[[i1]][i5], stroke = dot.border.size[[i1]], color = if(dot.shape[[i1]] %in% 21:24 & ! is.null(dot.border.color)){dot.border.color[[i1]]}else{color[[i1]][i5]}, alpha = alpha[[i1]], show.legend = FALSE)) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "stroke", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(dot.border.size[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of stroke, breaks reorder the classes according to class.categ in the legend. See guide_legend settings of scale_..._manual below
Gael's avatar
Gael committed
12352

12353
12354
12355
12356
12357
12358
12359
12360
12361
12362
12363
12364
12365
12366
12367
12368
12369
12370
12371
12372
12373
12374
12375
12376
12377
12378
12379
12380
12381
12382
12383
12384
12385
12386
12387
12388
12389
12390
12391
12392
12393
12394
12395
12396
12397
12398
12399
12400
12401
12402
12403
12404
12405
12406
12407
12408
12409
12410
12411
12412
12413
12414
12415
12416
12417
12418
12419
12420
12421
12422
12423
12424
12425
12426
12427
12428
12429
12430
12431
12432
12433
12434
12435
12436
12437
12438
12439
12440
12441
12442
12443
12444
12445
12446
12447
12448
12449
12450
12451
12452
12453
12454
12455
12456
12457
12458
12459
12460
12461
12462
12463
12464
12465
12466
12467
12468
12469
12470
12471
12472
12473
12474
12475
12476
12477
12478
12479
12480
12481
12482
12483
12484
}
}else{
line.count <- line.count + 1
if(line.count == 1){
fin.lg.disp[[4]] <- legend.disp[[point.count + line.count]]
lg.order[[4]] <- point.count + line.count
lg.color[[4]] <- color[[i1]] # if color == NULL -> NULL
lg.line.size[[4]] <- line.size[[i1]]
lg.line.type[[4]] <- line.type[[i1]]
if(plot == TRUE & fin.lg.disp[[4]] == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES (LINE LAYER NUMBER ", line.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
lg.alpha[[4]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
}else{
lg.alpha[[4]] <- alpha[[i1]]
}
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::", # no CR here te0("ggpl
ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
"(data = tempo.data.frame, mapping = ggplot2::aes(x = ", 
x[[i1]], 
ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "), 
y[[i1]], 
if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', y.lim[1])}, 
", linetype = ", 
categ[[i1]], 
"), color = \"", 
color[[i1]][i5], 
"\", size = ", 
line.size[[i1]], 
ifelse(geom[[i1]] == 'geom_path', ', lineend = \"round\"', ''), 
ifelse(geom[[i1]] == 'geom_step', paste0(', direction = \"', geom.step.dir[[i1]], '\"'), ''), 
", alpha = ", 
alpha[[i1]], 
", show.legend = ", 
ifelse(i5 == 1, TRUE, FALSE), 
")"
)))) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(line.type[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, with different values, breaks reorder the classes according to class.categ in the legend
}
if(line.count == 2){
fin.lg.disp[[5]] <- legend.disp[[point.count + line.count]]
lg.order[[5]] <- point.count + line.count
lg.color[[5]] <- color[[i1]] # if color == NULL -> NULL
lg.line.size[[5]] <- line.size[[i1]]
lg.line.type[[5]] <- line.type[[i1]]
if(plot == TRUE & fin.lg.disp[[5]] == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES (LINE LAYER NUMBER ", line.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
lg.alpha[[5]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
}else{
lg.alpha[[5]] <- alpha[[i1]]
}
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::", # no CR here te0("ggpl
ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
"(data = tempo.data.frame, mapping = ggplot2::aes(x = ", 
x[[i1]], 
ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "), 
y[[i1]], 
if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', y.lim[1])}, 
", alpha = ", 
categ[[i1]], 
"), color = \"", 
color[[i1]][i5], 
"\", size = ", 
line.size[[i1]], 
", linetype = ", 
ifelse(is.numeric(line.type[[i1]]), "", "\""), 
line.type[[i1]], 
ifelse(is.numeric(line.type[[i1]]), "", "\""), 
ifelse(geom[[i1]] == 'geom_path', ', lineend = \"round\"', ''), 
ifelse(geom[[i1]] == 'geom_step', paste0(', direction = \"', geom.step.dir[[i1]], '\"'), ''), 
", show.legend = FALSE)"
)))) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(alpha[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, with different values, breaks reorder the classes according to class.categ in the legend
}
if(line.count == 3){
fin.lg.disp[[6]] <- legend.disp[[point.count + line.count]]
lg.order[[6]] <- point.count + line.count
lg.color[[6]] <- color[[i1]] # if color == NULL -> NULL
lg.line.size[[6]] <- line.size[[i1]]
lg.line.type[[6]] <- line.type[[i1]]
if(plot == TRUE & fin.lg.disp[[6]] == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES (LINE LAYER NUMBER ", line.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
lg.alpha[[6]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
}else{
lg.alpha[[6]] <- alpha[[i1]]
}
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::", # no CR here te0("ggpl
ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
"(data = tempo.data.frame, mapping = ggplot2::aes(x = ", 
x[[i1]], 
ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "), 
y[[i1]], 
if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', y.lim[1])}, 
", size = ", 
categ[[i1]], 
"), color = \"", 
color[[i1]][i5], 
"\", linetype = ", 
ifelse(is.numeric(line.type[[i1]]), "", "\""), 
line.type[[i1]], 
ifelse(is.numeric(line.type[[i1]]), "", "\""), 
ifelse(geom[[i1]] == 'geom_path', ', lineend = \"round\"', ''), 
ifelse(geom[[i1]] == 'geom_step', paste0(', direction = \"', geom.step.dir[[i1]], '\"'), ''), 
", alpha = ", 
alpha[[i1]], 
", show.legend = FALSE)"
)))) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "size", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(line.size[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, breaks reorder the classes according to class.categ in the legend
}
}
}
# end loop part
Gael's avatar
Gael committed
12485
12486


12487
12488


12489
12490
# legend display
tempo.legend.final <- 'ggplot2::guides(
Gael's avatar
Gael committed
12491
12492
12493
12494
12495
12496
12497
12498
12499
12500
12501
12502
12503
fill = if(fin.lg.disp[[1]] == TRUE){
ggplot2::guide_legend(
order = lg.order[[1]], 
override.aes = list(
fill = lg.color[[1]], 
colour = if(lg.dot.shape[[1]] %in% 21:24 & ! is.null(dot.border.color)){lg.dot.border.color[[1]]}else{lg.color[[1]]}, # lg.dot.shape[[1]] %in% 21:24 are the only one that can be filled
shape = lg.dot.shape[[1]], 
size = lg.dot.size[[1]], 
stroke = lg.dot.border.size[[1]], 
alpha = lg.alpha[[1]], 
linetype = 0
)
)
12504
}else{
Gael's avatar
Gael committed
12505
12506
12507
12508
12509
12510
12511
12512
12513
12514
12515
12516
12517
12518
12519
FALSE
}, 
shape = if(fin.lg.disp[[2]] == TRUE){
ggplot2::guide_legend(
order = lg.order[[2]], 
override.aes = list(
fill = lg.color[[2]], 
colour = if(lg.dot.shape[[2]] %in% 21:24 & ! is.null(dot.border.color)){lg.dot.border.color[[2]]}else{lg.color[[2]]}, # lg.dot.shape[[2]] %in% 21:24 are the only one that can be filled
shape = lg.dot.shape[[2]], 
size = lg.dot.size[[2]], 
stroke = lg.dot.border.size[[2]], 
alpha = lg.alpha[[2]], 
linetype = 0
)
)
Gael  MILLOT's avatar
Gael MILLOT committed
12520
}else{
Gael's avatar
Gael committed
12521
12522
12523
12524
12525
12526
12527
12528
12529
12530
12531
12532
12533
12534
FALSE
}, 
stroke = if(fin.lg.disp[[3]] == TRUE){
ggplot2::guide_legend(
order = lg.order[[3]], 
override.aes = list(
fill = lg.color[[3]], 
colour = if(lg.dot.shape[[3]] %in% 21:24 & ! is.null(dot.border.color)){lg.dot.border.color[[3]]}else{lg.color[[3]]}, # lg.dot.shape[[3]] %in% 21:24 are the only one that can be filled
shape = lg.dot.shape[[3]], 
size = lg.dot.size[[3]], 
stroke = lg.dot.border.size[[3]], 
alpha = lg.alpha[[3]], 
linetype = 0
)
12535
)
12536
}else{
Gael's avatar
Gael committed
12537
12538
12539
12540
12541
12542
12543
12544
12545
12546
12547
12548
12549
FALSE
}, 
linetype = if(fin.lg.disp[[4]] == TRUE){
ggplot2::guide_legend(
order = lg.order[[4]], 
override.aes = list(
color = lg.color[[4]], 
size = lg.line.size[[4]], 
linetype = lg.line.type[[4]], 
alpha = lg.alpha[[4]], 
shape = NA
)
)
12550
}else{
Gael's avatar
Gael committed
12551
12552
12553
12554
12555
12556
12557
12558
12559
12560
12561
12562
12563
FALSE
}, 
alpha = if(fin.lg.disp[[5]] == TRUE){
ggplot2::guide_legend(
order = lg.order[[5]], 
override.aes = list(
color = lg.color[[5]], 
size = lg.line.size[[5]], 
linetype = lg.line.type[[5]], 
alpha = lg.alpha[[5]], 
shape = NA
)
)
12564
}else{
Gael's avatar
Gael committed
12565
12566
12567
12568
12569
12570
12571
12572
12573
12574
12575
12576
12577
FALSE
}, 
size = if(fin.lg.disp[[6]] == TRUE){
ggplot2::guide_legend(
order = lg.order[[6]], 
override.aes = list(
color = lg.color[[6]], 
size = lg.line.size[[6]], 
linetype = lg.line.type[[6]], 
alpha = lg.alpha[[6]], 
shape = NA
)
)
12578
}else{
Gael's avatar
Gael committed
12579
12580
12581
12582
FALSE
}
)' # clip = "off" to have secondary ticks outside plot region does not work
if( ! is.null(legend.width)){
12583
12584
12585
12586
12587
12588
12589
12590
12591
12592
12593
12594
12595
12596
12597
12598
if(any(unlist(legend.disp))){ # means some TRUE
tempo.graph.info <- suppressMessages(ggplot2::ggplot_build(eval(parse(text = paste0(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), ' + ', tempo.legend.final))))) # will be recovered later again, when ylim will be considered
legend.final <- fun_gg_get_legend(ggplot_built = tempo.graph.info, fun.name = function.name) # get legend
fin.lg.disp[] <- FALSE # remove all the legends. Must be done even if fin.lg.disp is not appearing in the code thenafter. Otherwise twice the legend
if(is.null(legend.final) & plot == TRUE){ # even if any(unlist(legend.disp)) is TRUE
legend.final <- fun_gg_empty_graph() # empty graph instead of legend
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") LEGEND REQUESTED (NON-NULL categ ARGUMENT OR legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON-NULL legend.width ARGUMENT\n")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}else if(plot == TRUE){ # means all FALSE
legend.final <- ggplot2::ggplot()+ggplot2::theme_void() # empty graph instead of legend
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") LEGEND REQUESTED (NON-NULL categ ARGUMENT OR legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON-NULL legend.width ARGUMENT\n")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
Gael's avatar
Gael committed
12599
12600
}
if( ! any(unlist(legend.disp))){
12601
fin.lg.disp[] <- FALSE # remove all the legends. Must be done even if fin.lg.disp is not appearing in the code thenafter. Otherwise twice the legend
Gael's avatar
Gael committed
12602
12603
12604
12605
12606
12607
12608
12609
12610
12611
12612
12613
}
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = tempo.legend.final)))
# end legend display





# scale management
tempo.coord <- suppressMessages(ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ", ' + ggplot2::scale_x_continuous(expand = c(0, 0), limits = sort(x.lim), oob = scales::rescale_none) + ggplot2::scale_y_continuous(expand = c(0, 0), limits = sort(y.lim), oob = scales::rescale_none)'))))$layout$panel_params[[1]]) # here I do not need the x-axis and y-axis orientation, I just need the number of main ticks
# x.second.tick.positions # coordinates of secondary ticks (only if x.second.tick.nb argument is non-null or if x.log argument is different from "no")
if(x.log != "no"){ # integer main ticks for log2 and log10
12614
12615
12616
12617
12618
12619
12620
12621
12622
12623
12624
12625
12626
tempo.scale <- (as.integer(min(x.lim, na.rm = TRUE)) - 1):(as.integer(max(x.lim, na.rm = TRUE)) + 1)
}else{
tempo <- if(is.null(attributes(tempo.coord$x$breaks))){tempo.coord$x$breaks}else{unlist(attributes(tempo.coord$x$breaks))}
if(all(is.na(tempo))){
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$x$breaks")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}
if(length(unique(x.lim)) <= 1){
tempo.cat <- paste0("ERROR IN ", function.name, "\nIT SEEMS THAT X-AXIS VALUES HAVE A NULL RANGE: ", paste(x.lim, collapse = " "), "\nPLEASE, USE THE x.lim ARGUMENT WITH 2 DIFFERENT VALUES TO SOLVE THIS")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}else{
tempo.scale <- fun_scale(lim = x.lim, n = ifelse(is.null(x.tick.nb), length(tempo[ ! is.na(tempo)]), x.tick.nb)) # in ggplot 3.3.0, tempo.coord$x.major_source replaced by tempo.coord$x$breaks. If fact: n = ifelse(is.null(x.tick.nb), length(tempo[ ! is.na(tempo)]), x.tick.nb)) replaced by n = ifelse(is.null(x.tick.nb), 4, x.tick.nb))
}
Gael's avatar
Gael committed
12627
12628
12629
12630
}
x.second.tick.values <- NULL
x.second.tick.pos <- NULL
if(x.log != "no"){
12631
12632
12633
12634
12635
12636
12637
12638
12639
12640
12641
12642
12643
12644
tempo <- fun_inter_ticks(lim = x.lim, log = x.log)
x.second.tick.values <- tempo$values
x.second.tick.pos <- tempo$coordinates
# if(vertical == TRUE){ # do not remove in case the bug is fixed
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "segment", x = x.second.tick.pos, 
xend = x.second.tick.pos, 
y = if(diff(y.lim) > 0){tempo.coord$y.range[1]}else{tempo.coord$y.range[2]}, 
yend = if(diff(y.lim) > 0){tempo.coord$y.range[1] + abs(diff(tempo.coord$y.range)) / 80}else{tempo.coord$y.range[2] - abs(diff(tempo.coord$y.range)) / 80}
))
# }else{ # not working because of the ggplot2 bug
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", y = x.second.tick.pos, yend = x.second.tick.pos, x = tempo.coord$x.range[1], xend = tempo.coord$x.range[1] + diff(tempo.coord$x.range) / 80))
# }
coord.names <- c(coord.names, "x.second.tick.positions")
Gael's avatar
Gael committed
12645
}else if(( ! is.null(x.second.tick.nb)) & x.log == "no"){
12646
12647
12648
12649
12650
12651
12652
12653
12654
12655
12656
12657
# if(x.second.tick.nb > 0){ #inactivated because already checked before
tempo <- fun_inter_ticks(lim = x.lim, log = x.log, breaks = tempo.scale, n = x.second.tick.nb)
x.second.tick.values <- tempo$values
x.second.tick.pos <- tempo$coordinates
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "segment", 
x = x.second.tick.pos, 
xend = x.second.tick.pos, 
y = if(diff(y.lim) > 0){tempo.coord$y.range[1]}else{tempo.coord$y.range[2]}, 
yend = if(diff(y.lim) > 0){tempo.coord$y.range[1] + abs(diff(tempo.coord$y.range)) / 80}else{tempo.coord$y.range[2] - abs(diff(tempo.coord$y.range)) / 80}
))
coord.names <- c(coord.names, "x.second.tick.positions")
Gael's avatar
Gael committed
12658
12659
12660
}
# for the ggplot2 bug with x.log, this does not work: eval(parse(text = ifelse(vertical == FALSE & x.log == "log10", "ggplot2::scale_x_continuous", "ggplot2::scale_x_continuous")))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_x_continuous(
12661
12662
12663
12664
12665
12666
12667
breaks = tempo.scale, 
minor_breaks = x.second.tick.pos, 
labels = if(x.log == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(x.log == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(x.log == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 10") ; stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)}, 
expand = c(0, 0), # remove space after after axis limits
limits = sort(x.lim), # NA indicate that limits must correspond to data limits but xlim() already used
oob = scales::rescale_none, 
trans = ifelse(diff(x.lim) < 0, "reverse", "identity") # equivalent to ggplot2::scale_x_reverse() but create the problem of x-axis label disappearance with x.lim decreasing. Thus, do not use. Use xlim() below and after this
Gael's avatar
Gael committed
12668
12669
12670
12671
))
# end x.second.tick.positions
# y.second.tick.positions # coordinates of secondary ticks (only if y.second.tick.nb argument is non-null or if y.log argument is different from "no")
if(y.log != "no"){ # integer main ticks for log2 and log10
12672
12673
12674
12675
12676
12677
12678
12679
12680
12681
12682
12683
12684
tempo.scale <- (as.integer(min(y.lim, na.rm = TRUE)) - 1):(as.integer(max(y.lim, na.rm = TRUE)) + 1)
}else{
tempo <- if(is.null(attributes(tempo.coord$y$breaks))){tempo.coord$y$breaks}else{unlist(attributes(tempo.coord$y$breaks))}
if(all(is.na(tempo))){
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$y$breaks")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}
if(length(unique(y.lim)) <= 1){
tempo.cat <- paste0("ERROR IN ", function.name, "\nIT SEEMS THAT Y-AXIS VALUES HAVE A NULL RANGE: ", paste(y.lim, collapse = " "), "\nPLEASE, USE THE y.lim ARGUMENT WITH 2 DIFFERENT VALUES TO SOLVE THIS")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}else{
tempo.scale <- fun_scale(lim = y.lim, n = ifelse(is.null(y.tick.nb), length(tempo[ ! is.na(tempo)]), y.tick.nb)) # in ggplot 3.3.0, tempo.coord$y.major_source replaced by tempo.coord$y$breaks. If fact: n = ifelse(is.null(y.tick.nb), length(tempo[ ! is.na(tempo)]), y.tick.nb)) replaced by n = ifelse(is.null(y.tick.nb), 4, y.tick.nb))
}
Gael's avatar
Gael committed
12685
12686
12687
12688
}
y.second.tick.values <- NULL
y.second.tick.pos <- NULL
if(y.log != "no"){
12689
12690
12691
12692
12693
12694
12695
12696
12697
12698
12699
12700
12701
12702
12703
tempo <- fun_inter_ticks(lim = y.lim, log = y.log)
y.second.tick.values <- tempo$values
y.second.tick.pos <- tempo$coordinates
# if(vertical == TRUE){ # do not remove in case the bug is fixed
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "segment", 
y = y.second.tick.pos, 
yend = y.second.tick.pos, 
x = if(diff(x.lim) > 0){tempo.coord$x.range[1]}else{tempo.coord$x.range[2]}, 
xend = if(diff(x.lim) > 0){tempo.coord$x.range[1] + abs(diff(tempo.coord$x.range)) / 80}else{tempo.coord$x.range[2] - abs(diff(tempo.coord$x.range)) / 80}
))
# }else{ # not working because of the ggplot2 bug
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", x = y.second.tick.pos, xend = y.second.tick.pos, y = tempo.coord$y.range[1], yend = tempo.coord$y.range[1] + diff(tempo.coord$y.range) / 80))
# }
coord.names <- c(coord.names, "y.second.tick.positions")
Gael's avatar
Gael committed
12704
}else if(( ! is.null(y.second.tick.nb)) & y.log == "no"){
12705
12706
12707
12708
12709
12710
12711
12712
12713
12714
12715
12716
# if(y.second.tick.nb > 0){ #inactivated because already checked before
tempo <- fun_inter_ticks(lim = y.lim, log = y.log, breaks = tempo.scale, n = y.second.tick.nb)
y.second.tick.values <- tempo$values
y.second.tick.pos <- tempo$coordinates
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "segment", 
y = y.second.tick.pos, 
yend = y.second.tick.pos, 
x = if(diff(x.lim) > 0){tempo.coord$x.range[1]}else{tempo.coord$x.range[2]}, 
xend = if(diff(x.lim) > 0){tempo.coord$x.range[1] + abs(diff(tempo.coord$x.range)) / 80}else{tempo.coord$x.range[2] - abs(diff(tempo.coord$x.range)) / 80}
))
coord.names <- c(coord.names, "y.second.tick.positions")
Gael's avatar
Gael committed
12717
12718
12719
}
# for the ggplot2 bug with y.log, this does not work: eval(parse(text = ifelse(vertical == FALSE & y.log == "log10", "ggplot2::scale_x_continuous", "ggplot2::scale_y_continuous")))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_y_continuous(
12720
12721
12722
12723
12724
12725
12726
breaks = tempo.scale, 
minor_breaks = y.second.tick.pos, 
labels = if(y.log == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(y.log == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(y.log == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 10") ; stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)}, 
expand = c(0, 0), # remove space after axis limits
limits = sort(y.lim), # NA indicate that limits must correspond to data limits but ylim() already used
oob = scales::rescale_none, 
trans = ifelse(diff(y.lim) < 0, "reverse", "identity") # equivalent to ggplot2::scale_y_reverse() but create the problem of y-axis label disappearance with y.lim decreasing. Thus, do not use. Use ylim() below and after this
Gael's avatar
Gael committed
12727
12728
12729
12730
12731
12732
12733
12734
12735
12736
12737
12738
))
# end y.second.tick.positions
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_cartesian(xlim = x.lim, ylim = y.lim)) # clip = "off" to have secondary ticks outside plot region. The problem is that points out of bounds are also drawn outside the plot region. Thus, I cannot use it # at that stage, x.lim and y.lim not NULL anymore
# end scale management




# drawing
fin.plot <- eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))
grob.save <- NULL
if(plot == TRUE){
12739
12740
12741
12742
12743
if( ! is.null(legend.width)){ # any(unlist(legend.disp)) == TRUE removed to have empty legend space # not & any(unlist(fin.lg.disp)) == TRUE here because converted to FALSE
grob.save <- suppressMessages(suppressWarnings(gridExtra::grid.arrange(fin.plot, legend.final, ncol=2, widths=c(1, legend.width))))
}else{
grob.save <- suppressMessages(suppressWarnings(print(fin.plot)))
}
12744
}else{
12745
12746
12747
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
12748
}
Gael's avatar
Gael committed
12749
12750
12751
12752
# end drawing



12753
# output
Gael's avatar
Gael committed
12754
if(warn.print == TRUE & ! is.null(warn)){
12755
12756
12757
options(warning.length = 8170)
on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
12758
}
Gael's avatar
Gael committed
12759
if(return == TRUE){
12760
12761
12762
12763
12764
12765
12766
12767
12768
12769
12770
12771
12772
12773
12774
12775
12776
12777
12778
12779
12780
12781
12782
12783
12784
12785
12786
12787
12788
12789
12790
12791
12792
12793
12794
12795
12796
12797
12798
output <- suppressMessages(ggplot2::ggplot_build(fin.plot))
# output$data <- output$data[-1] # yes for boxplot but not for scatter # remove the first data because corresponds to the initial empty boxplot
if(length(output$data) != length(coord.names)){
tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, ": length(output$data) AND length(coord.names) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
}else{
names(output$data) <- coord.names
}
if(is.null(unlist(removed.row.nb))){
removed.row.nb <- NULL
removed.rows <- NULL
}else{
for(i3 in 1:length(data1)){
if( ! is.null(removed.row.nb[[i3]])){
removed.row.nb[[i3]] <- sort(removed.row.nb[[i3]])
removed.rows[[i3]] <- data1.ini[[i3]][removed.row.nb[[i3]], ]
}
}
}
tempo <- output$layout$panel_params[[1]]
output <- list(
data = data1, 
removed.row.nb = removed.row.nb, 
removed.rows = removed.rows, 
plot = c(output$data, x.second.tick.values = list(x.second.tick.values), y.second.tick.values = list(y.second.tick.values)), 
panel = facet.categ, 
axes = list(
x.range = tempo$x.range, 
x.labels = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{tempo$x$scale$get_labels()}, # is.null(attributes(tempo$x$breaks)) test if it is number (TRUE) or character (FALSE)
x.positions = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{unlist(attributes(tempo$x$breaks))}, 
y.range = tempo$y.range, 
y.labels = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{tempo$y$scale$get_labels()}, 
y.positions = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{unlist(attributes(tempo$y$breaks))}
), 
warn = paste0("\n", warn, "\n\n"), 
ggplot = if(return.ggplot == TRUE){fin.plot}else{NULL}, # fin.plot plots the graph if return == TRUE
gtable = if(return.gtable == TRUE){grob.save}else{NULL} #
)
return(output) # this plots the graph if return.ggplot is TRUE and if no assignment
12799
12800
}
# end output
Gael's avatar
Gael committed
12801
# end main code
Gael  MILLOT's avatar
Gael MILLOT committed
12802
}
12803
12804
12805