cute_little_R_functions.R 809 KB
Newer Older
11001
11002
11003
11004
11005
11006
11007
11008
11009
11010
11011
11012
stop(tempo.cat, call. = FALSE)
}
# end axes management




# 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)){
11013
data1[[i2]] <- cbind(data1[[i2]], fake_categ = "", stringsAsFactors = TRUE)
11014
11015
11016
11017
11018
11019
11020
11021
if(geom[[i2]] == "geom_hline" | geom[[i2]] == "geom_vline"){
data1[[i2]][, "fake_categ"] <- factor(paste0("Line_", 1:nrow(data1[[i2]])))
}
}
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)))
}
11022
11023
11024
11025
11026
11027
11028
11029
11030
11031
11032
11033
11034
11035
11036
# 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)))
}
}
11037
# end create a fake categ if NULL to deal with legend display
11038
# categ.class.order is not NULL anymore
11039
11040


11041
# vector of color with length as in levels(categ) of data1
11042
11043
11044
11045
11046
11047
11048
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
11049
11050
11051
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]]
11052
warn.count <- warn.count + 1
11053
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 = " "))
11054
11055
11056
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}
11057
11058
# end vector of color with length as in levels(categ) of data1
# color is not NULL anymore
11059
11060


11061
11062
11063
11064
11065
11066
11067
11068
11069
11070
11071
11072
11073
11074
11075
11076
11077
11078
11079
11080
11081
11082
11083
11084
11085
11086
11087
11088
11089
11090
11091
11092
11093
11094
11095
11096
11097
11098
11099
11100
11101
11102
11103
11104
11105
11106
11107
11108
11109
11110
11111
# na detection and removal
data1.ini <- data1 # to report NA removal
removed.row.nb <- vector("list", length = length(data1)) # to report NA removal
removed.rows <- vector("list", length = length(data1)) # to report NA removal
for(i1 in 1:length(data1)){
column.check <- unlist(c( #unlist because creates a list
if(x[[i1]] == "fake_x"){NULL}else{x[[i1]]}, 
if(y[[i1]] == "fake_y"){NULL}else{y[[i1]]}, 
if(is.null(categ[[i1]])){NULL}else{categ[[i1]]}, 
if(is.null(facet.categ)){NULL}else{facet.categ}
)) # dot.categ because can be a 3rd column of data1
if(any(is.na(data1[[i1]][, column.check]))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") NA DETECTED IN COLUMNS ", paste(column.check, collapse = " "), " OF ", ifelse(length(data1) == 1, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
for(i3 in 1:length(column.check)){
if(any(is.na(data1[[i1]][, column.check[i3]]))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") NA REMOVAL DUE TO COLUMN ", column.check[i3], " OF ", ifelse(length(data1) == 1, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}
removed.row.nb[[i1]] <- unlist(lapply(lapply(c(data1[[i1]][column.check]), FUN = is.na), FUN = which))
removed.rows[[i1]] <- data1[[i1]][removed.row.nb[[i1]], ]
column.check <- column.check[ ! (column.check == x[[i1]] | column.check == y[[i1]])] # remove x and y to keep quali columns
if(length(removed.row.nb[[i1]]) != 0){
data1[[i1]] <- data1[[i1]][-removed.row.nb[[i1]], ]
for(i4 in 1:length(column.check)){
if(any( ! unique(removed.rows[[i1]][, column.check[i4]]) %in% unique(data1[[i1]][, column.check[i4]]))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") IN COLUMN ", column.check[i4], " OF ", ifelse(length(data1) == 1, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", THE FOLLOWING CLASSES HAVE DISAPPEARED AFTER NA REMOVAL\n(IF COLUMN USED IN THE PLOT, THIS CLASS WILL NOT BE DISPLAYED):\n", paste(unique(removed.rows[[i1]][, column.check[i4]])[ ! unique(removed.rows[[i1]][, column.check[i4]]) %in% unique(data1[[i1]][, column.check[i4]])], collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
if(column.check[i4] %in% categ[[i1]]){
categ.class.order[[i1]] <- levels(data1[[i1]][, column.check[i4]])[levels(data1[[i1]][, column.check[i4]]) %in% unique(data1[[i1]][, column.check[i4]])] # remove the absent class in the categ.class.order vector
color[[i1]] <-color[[i1]][levels(data1[[i1]][, column.check[i4]]) %in% unique(data1[[i1]][, column.check[i4]])] # remove the absent color in the character vector
data1[[i1]][, column.check[i4]] <- factor(as.character(data1[[i1]][, column.check[i4]]), levels = unique(categ.class.order[[i1]]))
}
if(column.check[i4] %in% facet.categ){ # works if facet.categ == NULL this method should keep the order of levels when removing some levels
tempo.levels <- levels(data1[[i1]][, column.check[i4]])[levels(data1[[i1]][, column.check[i4]]) %in% unique(as.character(data1[[i1]][, column.check[i4]]))]
data1[[i1]][, column.check[i4]] <- factor(as.character(data1[[i1]][, column.check[i4]]), levels = tempo.levels)
}
}
}
}
}else{
removed.row.nb[[i1]] <- NULL
removed.rows[[i1]] <- NULL
}
}
# end na detection and removal

11112
11113
11114
11115
11116


# last check
for(i1 in 1:length(data1)){
if(categ[[i1]] != "fake_categ" & length(color[[i1]]) != length(unique(data1[[i1]][, categ[[i1]]]))){
11117
tempo.cat <- paste0("\n\n================\n\nERROR 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]]])), "\n\n================\n\n")
11118
11119
stop(tempo.cat, call. = FALSE)
}else if(categ[[i1]] == "fake_categ" & length(color[[i1]]) != 1){
11120
tempo.cat <- paste0("\n\n================\n\nERROR 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]]), "\n\n================\n\n")
11121
11122
11123
11124
11125
11126
11127
11128
11129
11130
11131
11132
11133
11134
11135
11136
11137
11138
11139
11140
11141
11142
11143
11144
11145
11146
11147
11148
11149
11150
11151
11152
11153
11154
stop(tempo.cat, call. = FALSE)
}
}
# end last check





# 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, ])
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("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 5\n\n============\n\n")
stop(tempo.cat, call. = FALSE)
}
# 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)
}
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]]]))){
11155
tempo.cat <- paste0("\n\n================\n\nERROR 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]]])), "\n\n================\n\n")
11156
11157
11158
11159
11160
11161
11162
11163
11164
11165
11166
11167
11168
11169
11170
11171
11172
11173
11174
11175
11176
11177
11178
11179
11180
11181
11182
11183
11184
11185
11186
11187
11188
11189
11190
11191
11192
11193
11194
11195
11196
11197
11198
11199
11200
11201
11202
11203
11204
11205
11206
stop(tempo.cat, call. = FALSE)
}
}
}
# end conversion of geom_hline and geom_vline




# 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"
}
}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
11207
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
11208
11209
11210
11211
11212
11213
11214
11215
11216
11217
11218
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, axis = "x")
y.tempo.just <- fun_gg_just(angle = y.text.angle, axis = "y")
# 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
11219
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")
11220
11221
11222
11223
11224
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
add.check <- FALSE
}
}
if(add.check == TRUE & article == TRUE){
11225
# WARNING: not possible to add several times theme(). NO message but the last one overwrites the others
11226
11227
11228
11229
11230
11231
11232
11233
11234
11235
11236
11237
11238
11239
11240
11241
11242
11243
11244
11245
11246
11247
11248
11249
11250
11251
11252
11253
11254
11255
11256
11257
11258
11259
11260
11261
11262
11263
11264
11265
11266
11267
11268
11269
11270
11271
11272
11273
11274
11275
11276
11277
11278
11279
11280
11281
11282
11283
11284
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
11285
11286
11287
11288
11289
11290
11291
11292
11293
11294
11295
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.
11296
11297
11298
11299
11300
11301
11302
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]]
11303
11304
11305
11306
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]]
11307
11308
lg.alpha[[1]] <- alpha[[i1]]
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
11309
11310
11311
11312
11313
11314
11315
11316
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]]
}
11317
11318
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], ]
11319
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(is.null(dot.border.color)){color[[i1]][i5]}else{dot.border.color[[i1]]}, 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
11320
11321
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
11322
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
11323
11324
11325
11326
11327
}
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]]
11328
11329
11330
11331
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]]
11332
11333
lg.alpha[[2]] <- alpha[[i1]]
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
11334
11335
11336
11337
11338
11339
11340
11341
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]]
}
11342
11343
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], ]
11344
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(is.null(dot.border.color)){color[[i1]][i5]}else{dot.border.color[[i1]]}, 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
11345
11346
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
11347
11348
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

11349
11350
11351
11352
11353
}
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]]
11354
11355
11356
11357
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]]
11358
11359
lg.alpha[[3]] <- alpha[[i1]]
class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
11360
11361
11362
11363
11364
11365
11366
11367
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]]
}
11368
11369
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], ]
11370
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(is.null(dot.border.color)){color[[i1]][i5]}else{dot.border.color[[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
11371
11372
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
11373
11374
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

11375
11376
11377
11378
11379
11380
11381
}
}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]]
11382
11383
11384
lg.line.size[[4]] <- line.size[[i1]]
lg.line.type[[4]] <- line.type[[i1]]
lg.alpha[[4]] <- alpha[[i1]]
11385
11386
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
11387
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)")
11388
11389
11390
11391
11392
11393
11394
11395
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], ]
11396
11397
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0(
"ggplot2::", 
11398
ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
11399
11400
"(data = tempo.data.frame, mapping = ggplot2::aes(x = ", 
x[[i1]], 
11401
ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "), 
11402
y[[i1]], 
11403
if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', y.lim[1])}, 
11404
11405
11406
11407
11408
11409
11410
11411
11412
11413
11414
", 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 = FALSE)"
11415
)))) # 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
11416
11417
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
11418
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
11419
11420
11421
11422
11423
}
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]]
11424
11425
11426
lg.line.size[[5]] <- line.size[[i1]]
lg.line.type[[5]] <- line.type[[i1]]
lg.alpha[[5]] <- alpha[[i1]]
11427
11428
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
11429
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)")
11430
11431
11432
11433
11434
11435
11436
11437
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], ]
11438
11439
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0(
"ggplot2::", 
11440
ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
11441
11442
"(data = tempo.data.frame, mapping = ggplot2::aes(x = ", 
x[[i1]], 
11443
ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "), 
11444
y[[i1]], 
11445
if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', y.lim[1])}, 
11446
11447
11448
11449
11450
11451
11452
11453
11454
11455
11456
11457
11458
11459
11460
", 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 = ", 
ifelse(i5 == 1, TRUE, FALSE), 
")"
11461
)))) # 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
11462
11463
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
11464
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
11465
11466
11467
11468
11469
}
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]]
11470
11471
11472
lg.line.size[[6]] <- line.size[[i1]]
lg.line.type[[6]] <- line.type[[i1]]
lg.alpha[[6]] <- alpha[[i1]]
11473
11474
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
11475
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)")
11476
11477
11478
11479
11480
11481
11482
11483
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], ]
11484
11485
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("
ggplot2::", 
11486
ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
11487
11488
"(data = tempo.data.frame, mapping = ggplot2::aes(x = ", 
x[[i1]], 
11489
ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "), 
11490
y[[i1]], 
11491
if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', y.lim[1])}, 
11492
11493
11494
11495
11496
11497
11498
11499
11500
11501
11502
11503
11504
", 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)"
11505
)))) # 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
11506
11507
coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
}
11508
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
11509
11510
11511
11512
11513
11514
11515
11516
11517
}
}
}
# end loop part




# legend display
11518
11519
11520
11521
11522
11523
11524
11525
11526
11527
11528
11529
11530
11531
11532
11533
11534
11535
11536
11537
11538
11539
11540
11541
11542
11543
11544
11545
11546
11547
11548
11549
11550
11551
11552
11553
11554
11555
11556
11557
11558
11559
11560
11561
11562
11563
11564
11565
11566
11567
11568
11569
11570
11571
11572
11573
11574
11575
11576
11577
11578
11579
11580
11581
11582
11583
11584
11585
11586
11587
11588
11589
11590
11591
11592
11593
11594
11595
11596
11597
11598
11599
11600
11601
11602
11603
11604
11605
11606
11607
11608
11609
tempo.legend.final <- 'ggplot2::guides(
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
)
)
}else{
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
)
)
}else{
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
)
)
}else{
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
)
)
}else{
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
)
)
}else{
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
)
)
}else{
FALSE
}
)' # clip = "off" to have secondary ticks outside plot region does not work
11610
11611
11612
11613
if( ! is.null(legend.width)){
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
11614
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
11615
11616
11617
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
11618
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")
11619
11620
11621
11622
11623
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}else if(plot == TRUE){ # means all FALSE
legend.final <- fun_gg_empty_graph() # empty graph instead of legend
warn.count <- warn.count + 1
11624
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")
11625
11626
11627
11628
11629
11630
11631
11632
11633
11634
11635
11636
11637
11638
11639
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
}
if( ! any(unlist(legend.disp))){
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
}
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
11640
# 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")
11641
11642
11643
11644
11645
11646
11647
11648
11649
11650
11651
11652
11653
11654
11655
11656
11657
11658
11659
11660
11661
11662
if(x.log != "no"){ # integer main ticks for log2 and log10
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("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$x$breaks\n\n============\n\n")
stop(tempo.cat)
}
if(length(unique(x.lim)) <= 1){
tempo.cat <- paste0("\n\n============\n\nERROR 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\n\n============\n\n")
stop(tempo.cat)
}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))
}
}
x.second.tick.values <- NULL
x.second.tick.pos <- NULL
if(x.log != "no"){
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
11663
11664
11665
11666
11667
11668
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}
))
11669
# }else{ # not working because of the ggplot2 bug
11670
11671
11672
11673
11674
11675
11676
11677
11678
11679
11680
11681
# 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")
}else if(( ! is.null(x.second.tick.nb)) & x.log == "no"){
# 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, 
11682
11683
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}
11684
11685
11686
11687
11688
11689
11690
))
coord.names <- c(coord.names, "x.second.tick.positions")
}
# 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(
breaks = tempo.scale, 
minor_breaks = x.second.tick.pos, 
11691
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("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 10\n\n============\n\n") ; stop(tempo.cat)}, 
11692
11693
11694
11695
11696
11697
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
))
# end x.second.tick.positions
11698
# 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")
11699
11700
11701
11702
11703
11704
11705
11706
11707
11708
11709
11710
11711
11712
11713
11714
11715
11716
11717
11718
11719
11720
if(y.log != "no"){ # integer main ticks for log2 and log10
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("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$y$breaks\n\n============\n\n")
stop(tempo.cat)
}
if(length(unique(y.lim)) <= 1){
tempo.cat <- paste0("\n\n============\n\nERROR 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\n\n============\n\n")
stop(tempo.cat)
}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))
}
}
y.second.tick.values <- NULL
y.second.tick.pos <- NULL
if(y.log != "no"){
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
11721
11722
11723
11724
11725
11726
11727
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}
))
11728
# }else{ # not working because of the ggplot2 bug
11729
11730
11731
11732
11733
11734
11735
11736
11737
11738
11739
11740
# 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")
}else if(( ! is.null(y.second.tick.nb)) & y.log == "no"){
# 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, 
11741
11742
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}
11743
11744
11745
11746
11747
11748
11749
))
coord.names <- c(coord.names, "y.second.tick.positions")
}
# 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(
breaks = tempo.scale, 
minor_breaks = y.second.tick.pos, 
11750
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("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 10\n\n============\n\n") ; stop(tempo.cat)}, 
11751
11752
11753
11754
11755
11756
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
))
# end y.second.tick.positions
11757
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
11758
11759
11760
11761
11762
11763
# end scale management




# drawing
11764
fin.plot <- eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))
11765
11766
11767
11768
11769
11770
11771
11772
11773
11774
11775
11776
11777
11778
11779
11780
11781
if(plot == TRUE){
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
suppressMessages(suppressWarnings(gridExtra::grid.arrange(fin.plot, legend.final, ncol=2, widths=c(1, legend.width))))
}else{
suppressMessages(suppressWarnings(print(fin.plot)))
}
}else{
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)))
}
# end drawing



# outputs
if(warn.print == TRUE & ! is.null(warn)){
11782
options(warning.length = 8170)
11783
11784
11785
11786
11787
11788
11789
11790
11791
11792
11793
11794
11795
11796
11797
11798
11799
11800
11801
11802
11803
11804
11805
11806
11807
11808
11809
11810
warning(paste0("FROM ", function.name, " FUNCTION:\n\n", warn), call. = FALSE) # to recover the warning messages, use return = TRUE
}
if(return == TRUE){
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("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": length(output$data) AND length(coord.names) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
}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)), 
11811
panel = facet.categ, 
11812
11813
11814
11815
11816
11817
11818
11819
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))}
), 
11820
11821
warn = paste0("\n", warn, "\n\n"), 
ggplot = if(return.ggplot == TRUE){fin.plot}else{NULL} # fin.plot plots the graph if return == TRUE
11822
)
11823
return(output) # this plots the graph if return.ggplot is TRUE and if no assignment
11824
11825
11826
11827
11828
11829
11830
}
# end outputs
# end main code
}



Gael's avatar
Gael committed
11831