cute_little_R_functions.R 704 KB
Newer Older
9001
9002
9003
9004
9005
9006
9007
9008
if( ! is.null(dot.border.color)){
tempo1 <- fun_check(data = dot.border.color, class = "vector", mode = "character", length = 1, fun.name = function.name, print = FALSE)
tempo2 <- fun_check(data = dot.border.color, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name, print = FALSE)
if(tempo1$problem == FALSE & tempo2$problem == TRUE & ! (all(dot.border.color %in% colors() | grepl(pattern = "^#", dot.border.color)))){ # check that all strings of low.color start by #
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.color ARGUMENT MUST BE (1) A HEXADECIMAL COLOR STRING STARTING BY #, OR (2) A COLOR NAME GIVEN BY colors(), OR (3) AN INTEGER VALUE\nHERE IT IS: ", paste(unique(dot.border.color), collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else if(tempo1$problem == TRUE & tempo2$problem == FALSE){ # convert integers into colors
dot.border.color <- fun_gg_palette(max(dot.border.color, na.rm = TRUE))[dot.border.color]
Gael  MILLOT's avatar
Gael MILLOT committed
9009
}
9010
# end integer colors into gg_palette
Gael  MILLOT's avatar
Gael MILLOT committed
9011
}
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
if(y.log != "no"){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") y.log ARGUMENT SET TO ", y.log, ".\nVALUES FROM THE y ARGUMENT COLUMN OF THE data1 DATA FRAME MUST BE ALREADY ", toupper(y.log), " TRANSFORMED, AS THE y.log ARGUMENT JUST MODIFIES THE AXIS SCALE")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
if( ! is.null(y.lim)){
if(any(y.lim <= 0)){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") y.lim ARGUMENT CAN SPAN ZERO OR NEGATIVE VALUES IF y.log ARGUMENT IS SET TO ", y.log, " BECAUSE THIS LATTER ARGUMENT DOES NOT TRANSFORM DATA, JUST MODIFIES THE AXIS SCALE")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else if(any( ! is.finite(if(y.log == "log10"){10^y.lim}else{2^y.lim}))){
tempo.cat <- paste0("ERROR IN ", function.name, ": y.lim ARGUMENT RETURNS INF WITH THE y.log ARGUMENT SET TO ", y.log, "\nAS SCALE COMPUTATION IS ", ifelse(y.log == "log10", 10, 2), "^y.lim:\n", paste(ifelse(y.log == "log10", 10, 2)^y.lim, collapse = " "), "\nARE YOU SURE THAT y.lim ARGUMENT HAS BEEN SPECIFIED WITH VALUES ALREADY IN LOG SCALE?\n", paste(y.lim, collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
9024
9025
9026
}
}
}
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037
# inactivated because y must already be log transformed data
# if(y.log != "no" & y.include.zero == TRUE){
# warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") y.log ARGUMENT SET TO ", y.log, " AND y.include.zero ARGUMENT SET TO TRUE -> y.include.zero ARGUMENT RESET TO FALSE BECAUSE NO 0 ALLOWED IN LOG SCALE")
# warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
# }
if(y.log != "no" & vertical == FALSE){
vertical <- TRUE
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") BECAUSE OF A BUG IN ggplot2, CANNOT FLIP BOXS HORIZONTALLY WITH A Y.LOG SCALE -> vertical ARGUMENT RESET TO TRUE")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9038
}
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
# end second round of checking and data preparation


# package checking
fun_pack(req.package = c("ggplot2"), lib.path = lib.path)
fun_pack(req.package = c("scales"), lib.path = lib.path)
# end package checking



# main code
# na detection and removal (done now to be sure of the correct length of categ)
column.check <- c(y, categ, "categ.color", if( ! is.null(dot.color)){"dot.color"}, dot.categ)
if(any(is.na(data1[, column.check]))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") NA DETECTED IN COLUMNS ", paste(column.check, collapse = " "), " OF data1 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(i2 in 1:length(column.check)){
if(any(is.na(data1[, column.check[i2]]))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") NA REMOVAL DUE TO COLUMN ", column.check[i2], " OF data1")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9061
9062
}
}
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
removed.row.nb <- unlist(lapply(lapply(c(data1[column.check]), FUN = is.na), FUN = which))
removed.rows <- data1[removed.row.nb, ]
column.check <- column.check[ ! column.check == y] # remove y to keep quali columns
if(length(removed.row.nb) != 0){
data1 <- data1[-removed.row.nb, ]
for(i3 in 1:length(column.check)){
if(any( ! unique(removed.rows[, column.check[i3]]) %in% unique(data1[, column.check[i3]]))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") IN COLUMN ", column.check[i3], " OF data1, THE FOLLOWING CLASSES HAVE DISAPPEARED AFTER NA REMOVAL (IF COLUMN USED IN THE PLOT, THIS CLASS WILL NOT BE DISPLAYED):\n", paste(unique(removed.rows[, column.check[i3]])[ ! unique(removed.rows[, column.check[i3]]) %in% unique(data1[, column.check[i3]])], collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9073
9074
9075
}
}
}
9076
9077
9078
9079
count.categ <- 0
for(i2 in 1:length(column.check)){
if(column.check[i2] %in% categ){
count.categ <- count.categ + 1
Gael  MILLOT's avatar
Gael MILLOT committed
9080
}
9081
9082
9083
if(column.check[i2] == categ[count.categ]){
categ.class.order[count.categ] <- list(levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])]) # remove the absent color in the character vector
data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(categ.class.order[[count.categ]]))
Gael  MILLOT's avatar
Gael MILLOT committed
9084
}
9085
9086
9087
9088
if( ! is.null(dot.color) & ! is.null(dot.categ)){ # reminder : dot.categ cannot be a column name of categ anymore (because in that case dot.categ name is changed into "..._DOT"
if(column.check[i2] == ini.dot.categ){
dot.categ.class.order <- levels(data1[, column.check[i2]])[levels(data1[,  column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector
data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.categ.class.order))
Gael  MILLOT's avatar
Gael MILLOT committed
9089
9090
}
}
9091
9092
9093
9094
if(column.check[i2] == "categ.color"){
categ.color <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector
if(length(categ.color) == 1 & length(unlist(categ.class.order[length(categ)])) > 1){ # to deal with single color
categ.color <- rep(categ.color, length(unlist(categ.class.order[length(categ)])))
Gael  MILLOT's avatar
Gael MILLOT committed
9095
}
9096
data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(categ.color))
Gael  MILLOT's avatar
Gael MILLOT committed
9097
}
9098
9099
9100
9101
if(column.check[i2] == "dot.color"){
dot.color <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector
if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color. If dot.categ.class.order == NULL (which is systematically the case if dot.categ == NULL), no rep(dot.color, length(dot.categ.class.order)
dot.color <- rep(dot.color, length(dot.categ.class.order))
Gael  MILLOT's avatar
Gael MILLOT committed
9102
}
9103
data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.color))
Gael  MILLOT's avatar
Gael MILLOT committed
9104
9105
9106
}
}
}else{
9107
9108
removed.row.nb <- NULL
removed.rows <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
9109
}
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
9136
9137
9138
9139
9140
9141
9142
9143
9144
9145
9146
9147
9148
9149
9150
9151
9152
9153
9154
9155
9156
# end na detection and removal (done now to be sure of the correct length of categ)


# y coordinates recovery (create ini.box.coord, dot.coord and modify data1)
if(length(categ) == 1){
# width commputations
box.width2 <- box.width
box.space <- 0 # to inactivate the shrink that add space between grouped boxes, because  no grouped boxes here
# end width commputations
# data1 check categ order for dots coordinates recovery
data1 <- data.frame(data1, categ.check = data1[, categ[1]])
data1$categ.check <- as.integer(data1$categ.check) # to check that data1[, categ[1]] and dot.coord$group are similar, during merging
# end data1 check categ order for dots coordinates recovery
# per box dots coordinates recovery
tempo.gg.name <- "gg.indiv.plot."
tempo.gg.count <- 0
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggplot())
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[1]), stroke = dot.border.size, size = dot.size, alpha = dot.alpha, shape = 21))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(is.null(dot.color)){rep(NA, length(unique(data1[, categ[1]])))}else if(length(dot.color) == 1){rep(dot.color, length(unique(data1[, categ[1]])))}else{dot.color}))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[1]), coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf})) # fill because this is what is used with geom_box # to easily have the equivalent of the grouped boxs
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[1]])))}else{categ.color}))
dot.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[1]]
ini.box.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[2]]
tempo.mean <- aggregate(x = dot.coord$y, by = list(dot.coord$group), FUN = mean, na.rm = TRUE)
names(tempo.mean)[names(tempo.mean) == "x"] <- "MEAN"
names(tempo.mean)[names(tempo.mean) == "Group.1"] <- "BOX"
# if( ! is.null(dot.color)){
if(is.null(dot.categ)){
dot.coord <- data.frame(
dot.coord[order(dot.coord$group, dot.coord$y), ], 
y.check = as.double(data1[order(data1$categ.check, data1[, y]), y]), 
categ.check = data1[order(data1$categ.check, data1[, y]), "categ.check"], 
dot.color = if(is.null(dot.color)){NA}else{data1[order(data1$categ.check, data1[, y]), "dot.color"]}, 
tempo.categ1 = data1[order(data1$categ.check, data1[, y]), categ[1]]
) # y.check to be sure that the order is the same between the y of data1 and the y of dot.coord
names(dot.coord)[names(dot.coord) == "tempo.categ1"] <- categ[1]
}else{
dot.coord <- data.frame(
dot.coord[order(dot.coord$group, dot.coord$y), ], 
y.check = as.double(data1[order(data1$categ.check, data1[, y]), y]), 
categ.check = data1[order(data1$categ.check, data1[, y]), "categ.check"], 
dot.color = if(is.null(dot.color)){NA}else{data1[order(data1$categ.check, data1[, y]), "dot.color"]}, 
tempo.categ1 = data1[order(data1$categ.check, data1[, y]), categ[1]], 
tempo.categ3 = data1[order(data1$categ.check, data1[, y]), dot.categ]
) # y.check to be sure that the order is the same between the y of data1 and the y of dot.coord
names(dot.coord)[names(dot.coord) == "tempo.categ1"] <- categ[1]
names(dot.coord)[names(dot.coord) == "tempo.categ3"] <- dot.categ
Gael  MILLOT's avatar
Gael MILLOT committed
9157
}
9158
9159
9160
9161
9162
9163
9164
9165
9166
if( ! identical(dot.coord$y, dot.coord$y.check)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (dot.coord$y AND dot.coord$y.check) AS WELL AS (dot.coord$group AND dot.coord$categ.check) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
}else{
if( ! identical(tempo.mean[order(tempo.mean$BOX), ]$BOX, unique(dot.coord[order(dot.coord$group), ]$group))){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (tempo.mean$BOX AND dot.coord$group) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
}else{
tempo.mean <- data.frame(tempo.mean[order(tempo.mean$BOX), ], unique(dot.coord[order(dot.coord$group), c(categ[1], if( ! is.null(dot.color) & ! is.null(dot.categ)){if(dot.categ != ini.dot.categ){dot.categ}}), drop = FALSE]))
Gael  MILLOT's avatar
Gael MILLOT committed
9167
}
Gael  MILLOT's avatar
Gael MILLOT committed
9168
}
9169
9170
9171
9172
9173
9174
9175
9176
9177
9178
9179
9180
9181
9182
9183
9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
# }
# end per box dots coordinates recovery
}else if(length(categ) == 2){
# width commputations
box.width2 <- box.width / length(unique(data1[, categ[length(categ)]])) # real width of each box in x-axis unit, among the set of grouped box. Not relevant if no grouped boxs length(categ) == 1
# end width commputations
# data1 check categ order for dots coordinates recovery
tempo.factor <- paste0(data1[order(data1[, categ[2]], data1[, categ[1]]), categ[2]], "_", data1[order(data1[, categ[2]], data1[, categ[1]]), categ[1]])
data1 <- data.frame(data1[order(data1[, categ[2]], data1[, categ[1]]), ], categ.check = factor(tempo.factor, levels = unique(tempo.factor)))
data1$categ.check <- as.integer(data1$categ.check)
# end data1 check categ order for dots coordinates recovery
# per box dots coordinates recovery
tempo.gg.name <- "gg.indiv.plot."
tempo.gg.count <- 0
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggplot())
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[2]), stroke = dot.border.size, size = dot.size, alpha = dot.alpha, shape = 21))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(is.null(dot.color)){rep(NA, length(unique(data1[, categ[2]])))}else if(length(dot.color) == 1){rep(dot.color, length(unique(data1[, categ[2]])))}else{dot.color}))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[2]), coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf})) # fill because this is what is used with geom_box # to easily have the equivalent of the grouped boxs
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[2]])))}else{categ.color}))
dot.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[1]]
ini.box.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[2]]
tempo.mean <- aggregate(x = dot.coord$y, by = list(dot.coord$group), FUN = mean, na.rm = TRUE)
names(tempo.mean)[names(tempo.mean) == "x"] <- "MEAN"
names(tempo.mean)[names(tempo.mean) == "Group.1"] <- "BOX"
# if( ! is.null(dot.color)){
if(is.null(dot.categ)){
dot.coord <- data.frame(
dot.coord[order(dot.coord$group, dot.coord$y), ], 
y.check = as.double(data1[order(data1$categ.check, data1[, y]), y]), 
categ.check = data1[order(data1$categ.check, data1[, y]), "categ.check"], 
dot.color = if(is.null(dot.color)){NA}else{data1[order(data1$categ.check, data1[, y]), "dot.color"]}, 
tempo.categ1 = data1[order(data1$categ.check, data1[, y]), categ[1]], 
tempo.categ2 = data1[order(data1$categ.check, data1[, y]), categ[2]]
) # y.check to be sure that the order is the same between the y of data1 and the y of dot.coord
names(dot.coord)[names(dot.coord) == "tempo.categ1"] <- categ[1]
names(dot.coord)[names(dot.coord) == "tempo.categ2"] <- categ[2]
}else{
dot.coord <- data.frame(
dot.coord[order(dot.coord$group, dot.coord$y), ], 
y.check = as.double(data1[order(data1$categ.check, data1[, y]), y]), 
categ.check = data1[order(data1$categ.check, data1[, y]), "categ.check"], 
dot.color = if(is.null(dot.color)){NA}else{data1[order(data1$categ.check, data1[, y]), "dot.color"]}, 
tempo.categ1 = data1[order(data1$categ.check, data1[, y]), categ[1]], 
tempo.categ2 = data1[order(data1$categ.check, data1[, y]), categ[2]], 
tempo.categ3 = data1[order(data1$categ.check, data1[, y]), dot.categ]
) # y.check to be sure that the order is the same between the y of data1 and the y of dot.coord
names(dot.coord)[names(dot.coord) == "tempo.categ1"] <- categ[1]
names(dot.coord)[names(dot.coord) == "tempo.categ2"] <- categ[2]
names(dot.coord)[names(dot.coord) == "tempo.categ3"] <- dot.categ
Gael  MILLOT's avatar
Gael MILLOT committed
9218
}
9219
9220
9221
if( ! (identical(dot.coord$y, dot.coord$y.check) & identical(dot.coord$group, dot.coord$categ.check))){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (dot.coord$y AND dot.coord$y.check) AS WELL AS (dot.coord$group AND dot.coord$categ.check) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9222
}else{
9223
9224
9225
9226
9227
if( ! identical(tempo.mean[order(tempo.mean$BOX), ]$BOX, unique(dot.coord[order(dot.coord$group), ]$group))){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (tempo.mean$BOX AND dot.coord$group) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
}else{
tempo.mean <- data.frame(tempo.mean[order(tempo.mean$BOX), ], unique(dot.coord[order(dot.coord$group), c(categ[1], categ[2], if( ! is.null(dot.color) & ! is.null(dot.categ)){if(dot.categ != ini.dot.categ){dot.categ}})]))
Gael  MILLOT's avatar
Gael MILLOT committed
9228
}
Gael  MILLOT's avatar
Gael MILLOT committed
9229
}
9230
# }
Gael  MILLOT's avatar
Gael MILLOT committed
9231
}else{
9232
9233
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9234
}
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
# at that stage, categ color and dot color are correctly attributed in data1, box.coord and dot.coord
# end y dot coordinates recovery (create ini.box.coord, dot.coord and modify data1)













# stat output (will also serve for boxplot and mean display)
ini.box.coord <- ini.box.coord[order(ini.box.coord$group), ]
stat <- data.frame(MIN = ini.box.coord$ymin, QUART1 = ini.box.coord$lower, MEDIAN = ini.box.coord$middle, QUART3 = ini.box.coord$upper, MAX = ini.box.coord$ymax, NOTCHUPPER = ini.box.coord$notchupper, NOTCHLOWER = ini.box.coord$notchlower, OUTLIERS = ini.box.coord["outliers"], COLOR = ini.box.coord$fill, stringsAsFactors = TRUE) # ini.box.coord["outliers"] written like this because it is a list. X coordinates not put now because several features to set
names(stat)[names(stat) == "outliers"] <- "OUTLIERS"
tempo.mean <- tempo.mean[order(tempo.mean$BOX), ]
if( ! identical(ini.box.coord$group, tempo.mean$BOX)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (ini.box.coord$group AND tempo.mean$BOX) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
}else{
stat <- data.frame(stat[c("MIN", "QUART1", "MEDIAN")], MEAN = tempo.mean$MEAN, stat[c("QUART3", "MAX", "NOTCHUPPER", "NOTCHLOWER", "OUTLIERS")], tempo.mean[colnames(tempo.mean) != "MEAN"], stat["COLOR"], stringsAsFactors = TRUE) # ini.box.coord["outliers"] written like this because it is a list
Gael  MILLOT's avatar
Gael MILLOT committed
9260
}
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
# end stat output (will also serve for boxplot and mean display)








# ylim range
if(is.null(y.lim)){
if(any(data1[, y] %in% c(Inf, -Inf))){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") THE data1 ARGUMENT CONTAINS -Inf OR Inf VALUES IN THE y COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9276
}
9277
y.lim <- range(data1[, y], 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  MILLOT's avatar
Gael MILLOT committed
9278
}
9279
9280
9281
if(suppressWarnings(all(y.lim %in% c(Inf, -Inf)))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED y.lim CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9282
}
9283
9284
9285
9286
9287
9288
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 medians 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 medians 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  MILLOT's avatar
Gael MILLOT committed
9289
}
9290
9291
9292
9293
y.lim <- y.lim[y.lim.order]
if(any(is.na(y.lim))){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 4\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9294
}
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
9314
9315
9316
9317
9318
9319
# end ylim range






# drawing
# constant part
tempo.gg.name <- "gg.indiv.plot."
tempo.gg.count <- 0
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggplot())
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::xlab(if(is.null(x.lab)){categ[1]}else{x.lab}))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylab(if(is.null(y.lab)){y}else{y.lab}))
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title))
# text angle management
tempo.just <- fun_gg_just(angle = text.angle, axis = ifelse(vertical == TRUE, "x", "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
tempo.warn <- paste0("(", warn.count,") \"ggplot2::theme\" STRING DETECTED IN THE add ARGUMENT -> INTERNAL GGPLOT2 THEME FUNCTIONS theme() AND theme_classic() HAVE BEEN INACTIVATED, TO BE USED BY THE USER")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
add.check <- FALSE
Gael  MILLOT's avatar
Gael MILLOT committed
9320
9321
}
}
9322
9323
9324
9325
9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
if(add.check == TRUE & classic == TRUE){
# BEWARE: not possible to add theme()several times. 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
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 = if(vertical == TRUE){NULL}else{ggplot2::element_line(colour = "grey75")},
panel.grid.major.y = if(vertical == TRUE){ggplot2::element_line(colour = "grey75")}else{NULL},
axis.text.x = if(vertical == TRUE){ggplot2::element_text(angle = tempo.just$angle, hjust = tempo.just$hjust, vjust = tempo.just$vjust)}else{NULL},
axis.text.y = if(vertical == TRUE){NULL}else{ggplot2::element_text(angle = tempo.just$angle, hjust = tempo.just$hjust, vjust = tempo.just$vjust)}
))
}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), 
axis.line.y.left = ggplot2::element_line(colour = "black"), 
axis.line.x.bottom = ggplot2::element_line(colour = "black"),
axis.text.x = if(vertical == TRUE){ggplot2::element_text(angle = tempo.just$angle, hjust = tempo.just$hjust, vjust = tempo.just$vjust)}else{NULL},
axis.text.y = if(vertical == TRUE){NULL}else{ggplot2::element_text(angle = tempo.just$angle, hjust = tempo.just$hjust, vjust = tempo.just$vjust)}
))
Gael  MILLOT's avatar
Gael MILLOT committed
9347
}
9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362
9363
}else if(add.check == TRUE & classic == 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), 
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 = "grey75"), 
panel.grid.major.y = ggplot2::element_line(colour = "grey75"), 
panel.grid.minor.x = ggplot2::element_blank(), 
panel.grid.minor.y = ggplot2::element_blank(), 
strip.background = ggplot2::element_rect(fill = "white", colour = "black"),
axis.text.x = if(vertical == TRUE){ggplot2::element_text(angle = tempo.just$angle, hjust = tempo.just$hjust, vjust = tempo.just$vjust)}else{NULL},
axis.text.y = if(vertical == TRUE){NULL}else{ggplot2::element_text(angle = tempo.just$angle, hjust = tempo.just$hjust, vjust = tempo.just$vjust)}
))
Gael  MILLOT's avatar
Gael MILLOT committed
9364
}
9365
9366
9367
# Contrary to fun_gg_bar(), cannot plot the  boxplot right now, because I need the dots plotted first
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, group = categ[length(categ)]), position = ggplot2::position_dodge(width = NULL), color = NA, width = box.width, fill = NA)) # this is to set the graph (i.e., a blanck boxplot to be able to use x coordinates to plot dots before boxes)
# end constant part
Gael  MILLOT's avatar
Gael MILLOT committed
9368
9369
9370
9371




9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
9382
9383
9384
9385
9386
# x coordinates management (for random plotting and for stat display)
# boxs
tempo.graph.info <- ggplot2::ggplot_build(eval(parse(text = paste0(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), ' + ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[length(categ)]), position = ggplot2::position_dodge(width = NULL), width = box.width, notch = box.notch, coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf}) + ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color})')))) # will be recovered later again, when ylim will be considered
tempo.yx.ratio <- (tempo.graph.info$layout$panel_params[[1]]$y.range[2] - tempo.graph.info$layout$panel_params[[1]]$y.range[1]) / (tempo.graph.info$layout$panel_params[[1]]$x.range[2] - tempo.graph.info$layout$panel_params[[1]]$x.range[1])
box.coord <- tempo.graph.info$data[[2]] # to have the summary statistics of the plot. Contrary to ini.box.plot, now integrates ylim Here because can be required for stat.disp when just box are plotted
box.coord <- box.coord[order(box.coord$group), ]
if(stat.disp.mean == TRUE){ # for mean display
if( ! identical(tempo.mean$BOX, box.coord$group)){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": tempo.mean$BOX AND box.coord$group DO NOT HAVE THE SAME VALUE ORDER\n\n============\n\n")
stop(tempo.cat)
}else{
box.coord <- data.frame(box.coord, tempo.mean)
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") MEAN VALUES INSTEAD OF MEDIAN VALUES DISPLAYED")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9387
9388
9389

}
}
9390
9391
9392
9393
9394
9395
9396
9397
9398
9399
9400
9401
9402
9403
9404
9405
9406
9407
9408
9409
9410
9411
9412
9413
# width commputations
width.ini <- c(box.coord$xmax - box.coord$xmin)[1] # all the box widths are equal here. Only the first one taken
width.correct <- width.ini * box.space / 2
if( ! identical(box.coord$group, stat$BOX)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (box.coord$group AND stat$BOX) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
}else{
stat <- data.frame(
stat, 
X = box.coord$x, 
X_BOX_INF = box.coord$xmin + width.correct, 
X_BOX_SUP = box.coord$xmax - width.correct, 
X_NOTCH_INF = box.coord$x - (box.coord$x - (box.coord$xmin + width.correct)) / 2,  
X_NOTCH_SUP = box.coord$x + (box.coord$x - (box.coord$xmin + width.correct)) / 2, 
X_WHISK_INF = box.coord$x - (box.coord$x - (box.coord$xmin + width.correct)) * box.whisker.width, 
X_WHISK_SUP = box.coord$x + (box.coord$x - (box.coord$xmin + width.correct)) * box.whisker.width, 
tempo.mean[colnames(tempo.mean) != "MEAN"], 
stringsAsFactors = TRUE
)
stat$COLOR <- factor(stat$COLOR, levels = unique(categ.color))
if( ! all(stat$NOTCHUPPER < stat$QUART3 & stat$NOTCHLOWER > stat$QUART1) & box.notch == TRUE){
warn.count <- warn.count + 1
tempo.warn <- paste0("(", warn.count,") SOME NOTCHES ARE BEYOND BOX HINGES. TRY ARGUMENT box.notch = FALSE")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
9414
}
Gael  MILLOT's avatar
Gael MILLOT committed
9415
}
9416
9417
9418
9419
9420
9421
9422
9423
9424
9425
dot.jitter <- c((box.coord$xmax - width.correct) - (box.coord$xmin + width.correct))[1] * dot.jitter # real dot.jitter. (box.coord$xmin + width.correct) - (box.coord$xmax - width.correct))[1] is the width of the box. Is  equivalent to (box.coord$x - (box.coord$xmin + width.correct))[1] * 2
# end width commputations
# end boxs
if( ! is.null(dot.color)){
# random dots
if(dot.tidy == FALSE){
dot.coord.rd1 <- merge(dot.coord, box.coord[c("fill", "group", "x")], by = intersect("group", "group"), sort = FALSE) # rd for random. Send the coord of the boxs into the coord data.frame of the dots (in the column x.y). BEWARE: by = intersect("group", "group") because group is enough as only one value of x per group number in box.coord. Thus, no need to consider fill
if(nrow(dot.coord.rd1) != nrow(dot.coord)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": THE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.rd1 DATA FRAME. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9426
}
9427
9428
9429
9430
9431
9432
9433
9434
9435
9436
9437
9438
9439
set.seed(1)
sampled.dot.jitter <- if(nrow(dot.coord.rd1) == 1){runif(n = nrow(dot.coord.rd1), min = - dot.jitter / 2, max = dot.jitter / 2)}else{sample(x = runif(n = nrow(dot.coord.rd1), min = - dot.jitter / 2, max = dot.jitter / 2), size = nrow(dot.coord.rd1), replace = FALSE)}
dot.coord.rd2 <- data.frame(dot.coord.rd1, dot.x = dot.coord.rd1$x.y + sampled.dot.jitter) # set the dot.jitter thanks to runif and dot.jitter range. Then, send the coord of the boxs into the coord data.frame of the dots (in the column x.y)
set.seed(NULL)
if(length(categ) == 1){
tempo.data1 <- unique(data.frame(data1[categ[1]], group = as.integer(factor(as.numeric(data1[, categ[1]]))))) # categ[2] first if categ[2] is used to make the categories in ggplot and categ[1] is used to make the x-axis
names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
verif <- paste0(categ[1], ".check")
}else if(length(categ) == 2){
tempo.data1 <- unique(data.frame(data1[c(categ[1], categ[2])], group = as.integer(factor(paste0(as.numeric(data1[, categ[2]]), ".", as.numeric(data1[, categ[1]])))))) # categ[2] first if categ[2] is used to make the categories in ggplot and categ[1] is used to make the x-axis
names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
names(tempo.data1)[names(tempo.data1) == categ[2]] <- paste0(categ[2], ".check")
verif <- c(paste0(categ[1], ".check"), paste0(categ[2], ".check"))
Gael  MILLOT's avatar
Gael MILLOT committed
9440
}else{
9441
9442
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9443
}
9444
9445
9446
9447
dot.coord.rd3 <- merge(dot.coord.rd2, tempo.data1, by = "group", sort = FALSE) # send the factors of data1 into coord
if(nrow(dot.coord.rd3) != nrow(dot.coord) | ( ! fun_comp_2d(dot.coord.rd3[categ], dot.coord.rd3[verif])$identical.content)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": THE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.rd3 DATA FRAME. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9448
}
9449
# end random dots
Gael  MILLOT's avatar
Gael MILLOT committed
9450
}
9451
9452
9453
# tidy dots
# coordinates are recover during plotting (see dot.coord.tidy1 below)
# end tidy dots
Gael  MILLOT's avatar
Gael MILLOT committed
9454
}
9455
# end x coordinates management (for random plotting and for stat display)
Gael  MILLOT's avatar
Gael MILLOT committed
9456
9457
9458
9459




9460
9461
9462
9463
9464
9465
9466
9467
9468
9469

# boxplot display before dot display if box.fill = TRUE
coord.names <- NULL
# creation of the data frame for (main box + legend) and data frame for means
if(box.notch == FALSE){
for(i3 in 1:length(categ)){
if(i3 == 1){
tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE)
}else{
tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9470
}
Gael  MILLOT's avatar
Gael MILLOT committed
9471
}
9472
9473
9474
9475
9476
9477
9478
9479
names(tempo.polygon) <- categ
tempo.polygon <- data.frame(X = c(t(stat[, c("X_BOX_INF", "X_BOX_SUP", "X_BOX_SUP", "X_BOX_INF", "X_BOX_INF")])), Y = c(t(stat[, c("QUART1", "QUART1", "QUART3", "QUART3", "QUART1")])), COLOR = c(t(stat[, c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), BOX = as.character(c(t(stat[, c("BOX", "BOX", "BOX", "BOX", "BOX")]))), tempo.polygon, stringsAsFactors = TRUE)
}else{
for(i3 in 1:length(categ)){
if(i3 == 1){
tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE)
}else{
tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9480
}
Gael  MILLOT's avatar
Gael MILLOT committed
9481
}
9482
9483
names(tempo.polygon) <- categ
tempo.polygon <- data.frame(X = c(t(stat[, c("X_BOX_INF", "X_BOX_SUP", "X_BOX_SUP", "X_NOTCH_SUP", "X_BOX_SUP", "X_BOX_SUP", "X_BOX_INF", "X_BOX_INF", "X_NOTCH_INF", "X_BOX_INF", "X_BOX_INF")])), Y = c(t(stat[, c("QUART1", "QUART1", "NOTCHLOWER", "MEDIAN", "NOTCHUPPER", "QUART3", "QUART3", "NOTCHUPPER", "MEDIAN", "NOTCHLOWER", "QUART1")])), COLOR = c(t(stat[, c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), BOX = as.character(c(t(stat[, c("BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX")]))), tempo.polygon, stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
9484
}
9485
9486
9487
9488
tempo.polygon$COLOR <- factor(tempo.polygon$COLOR, levels = unique(categ.color))
if( ! is.null(categ.class.order)){
for(i3 in 1:length(categ)){
tempo.polygon[, categ[i3]] <- factor(tempo.polygon[, categ[i3]], levels = categ.class.order[[i3]])
Gael  MILLOT's avatar
Gael MILLOT committed
9489
}
Gael  MILLOT's avatar
Gael MILLOT committed
9490
}
9491
9492
9493
9494
9495
9496
# modified name of dot.categ column (e.g., "Group1_DOT") must be included for boxplot using ridy dots
if( ! is.null(dot.color) & ! is.null(dot.categ)){
if(dot.categ != ini.dot.categ){
tempo.polygon <- data.frame(tempo.polygon, GROUPX = tempo.polygon[, ini.dot.categ])
names(tempo.polygon)[names(tempo.polygon) == "GROUPX"] <- dot.categ

Gael  MILLOT's avatar
Gael MILLOT committed
9497
9498
}
}
9499
9500
9501
9502
9503
9504
9505
9506
9507
9508
9509
9510
9511
9512
9513
9514
9515
9516
9517
9518
9519
tempo.diamon.mean <- data.frame(X = c(t(stat[, c("X", "X_NOTCH_INF", "X", "X_NOTCH_SUP", "X")])), Y = c(t(cbind(stat["MEAN"] - (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stat["MEAN"], stat["MEAN"] + (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stat["MEAN"], stat["MEAN"] - (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio))), COLOR = c(t(stat[, c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), GROUP = c(t(stat[, c("BOX", "BOX", "BOX", "BOX", "BOX")])), stringsAsFactors = TRUE)
tempo.diamon.mean$COLOR <- factor(tempo.diamon.mean$COLOR, levels = unique(categ.color))
# end creation of the data frame for (main box + legend) and data frame for means
if(box.fill == TRUE){
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[length(categ)], fill = categ[length(categ)]), position = ggplot2::position_dodge(width = NULL), width = box.width, size = box.line.size, notch = box.notch, coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf}, alpha = box.alpha, outlier.shape = if( ! is.null(dot.color)){NA}else{21}, outlier.color = if( ! is.null(dot.color)){NA}else{dot.border.color}, outlier.fill = if( ! is.null(dot.color)){NA}else{NULL}, outlier.size = if( ! is.null(dot.color)){NA}else{dot.size}, outlier.stroke = if( ! is.null(dot.color)){NA}else{dot.border.size}, outlier.alpha = if( ! is.null(dot.color)){NA}else{dot.alpha})) # the color, size, etc. of the outliers are dealt here. outlier.color = NA to do not plot outliers when dots are already plotted. Finally, boxplot redrawn (see below)
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_polygon(
data = tempo.polygon, 
mapping = ggplot2::aes_string(x = "X", y = "Y", group = "BOX", fill = categ[length(categ)], color = categ[length(categ)]), 
size = box.line.size, 
alpha = box.alpha
))
coord.names <- c(coord.names, "main.box")
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = QUART3, yend = MAX, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha)) # 
coord.names <- c(coord.names, "sup.whisker")
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = QUART1, yend = MIN, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha)) # 
coord.names <- c(coord.names, "inf.whisker")
if(box.whisker.width > 0){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = MAX, yend = MAX, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha, lineend = "round")) # 
coord.names <- c(coord.names, "sup.whisker.edge")
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = MIN, yend = MIN, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha, lineend = "round")) # 
coord.names <- c(coord.names, "inf.whisker.edge")
Gael  MILLOT's avatar
Gael MILLOT committed
9520
}
9521
9522
9523
9524
9525
9526
9527
9528
9529
9530
9531
if(box.mean == TRUE){
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = stat, mapping = ggplot2::aes_string(x = "X", y = "MEAN", group = categ[length(categ)]), shape = 23, stroke = box.line.size * 2, fill = stat$COLOR, size = box.mean.size, color = "black", alpha = box.alpha)) # group used in aesthetic to do not have it in the legend
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_polygon(
data = tempo.diamon.mean, 
mapping = ggplot2::aes(x = X, y = Y, group = GROUP), 
fill = tempo.diamon.mean[, "COLOR"], 
color = hsv(0, 0, 0, alpha = box.alpha), # outline of the polygon in black but with alpha
size = box.line.size * 2, 
alpha = box.alpha
))
coord.names <- c(coord.names, "mean")
Gael  MILLOT's avatar
Gael MILLOT committed
9532
}
9533
9534
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = if(box.notch == FALSE){X_BOX_INF}else{X_NOTCH_INF}, xend = if(box.notch == FALSE){X_BOX_SUP}else{X_NOTCH_SUP}, y = MEDIAN, yend = MEDIAN, group = categ[length(categ)]), color = "black", size = box.line.size * 2, alpha = box.alpha)) # 
coord.names <- c(coord.names, "median")
Gael  MILLOT's avatar
Gael MILLOT committed
9535
}
9536
# end boxplot display before dot display if box.fill = TRUE
Gael  MILLOT's avatar
Gael MILLOT committed
9537

Gael  MILLOT's avatar
Gael MILLOT committed
9538
9539


Gael  MILLOT's avatar
Gael MILLOT committed
9540
9541
9542



9543
9544
9545
9546
9547
9548
9549
9550
9551
9552
9553
9554
9555
9556
9557
9558
9559
9560
9561
9562
9563
9564
9565
9566
# dot display
if( ! is.null(dot.color)){
if(dot.tidy == FALSE){
if(is.null(dot.categ)){
if(dot.border.size == 0){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3, 
mapping = ggplot2::aes_string(x = "dot.x", y = "y", group = categ[length(categ)]), 
size = dot.size, 
shape = 19, 
color = dot.coord.rd3$dot.color, 
alpha = dot.alpha
)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
}else{
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3, 
mapping = ggplot2::aes_string(x = "dot.x", y = "y", group = categ[length(categ)]), 
shape = 21, 
stroke = dot.border.size, 
color = if(is.null(dot.border.color)){dot.coord.rd3$dot.color}else{rep(dot.border.color, nrow(dot.coord.rd3))}, 
size = dot.size, 
fill = dot.coord.rd3$dot.color, 
alpha = dot.alpha
)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9567
}
9568
9569
9570
9571
9572
9573
9574
9575
9576
9577
9578
9579
9580
9581
9582
9583
9584
9585
9586
}else{
if(dot.border.size == 0){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3, 
mapping = ggplot2::aes_string(x = "dot.x", y = "y", alpha = dot.categ), 
size = dot.size, 
shape = 19, 
color = dot.coord.rd3$dot.color
)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
}else{
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3, 
mapping = ggplot2::aes_string(x = "dot.x", y = "y", alpha = dot.categ), 
size = dot.size, 
shape = 21, 
stroke = dot.border.size, 
color = if(is.null(dot.border.color)){dot.coord.rd3$dot.color}else{rep(dot.border.color, nrow(dot.coord.rd3))}, 
fill = dot.coord.rd3$dot.color
)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
Gael  MILLOT's avatar
Gael MILLOT committed
9587
}
9588
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = dot.categ.legend.name, values = rep(dot.alpha,  length(dot.categ.class.order)), guide = ggplot2::guide_legend(override.aes = list(fill = dot.color, color = if(is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size)))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor
Gael  MILLOT's avatar
Gael MILLOT committed
9589
}
9590
9591
9592
9593
9594
9595
9596
9597
9598
9599
9600
9601
9602
9603
9604
9605
9606
9607
9608
9609
}else if(dot.tidy == TRUE){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_dotplot(
data = dot.coord, 
mapping = ggplot2::aes_string(x = categ[1], y = "y", linetype = if(is.null(dot.categ)){categ[length(categ)]}else{dot.categ}), 
position = ggplot2::position_dodge(width = box.width), 
binaxis = "y", 
stackdir = "center", 
alpha = dot.alpha, 
fill = as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]), 
stroke = dot.border.size, 
color = if(is.null(dot.border.color)){as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"])}else{rep(dot.border.color, nrow(dot.coord))}, 
# show.legend = ifelse(is.null(dot.categ), FALSE, TRUE), # BEWARE: do not use because it uses the arguments outside aes() as aesthetics (here color and fill). Thus I must find a way using ggplot2::scale_discrete_manual()
binwidth = (y.lim[2] - y.lim[1]) / dot.tidy.bin.nb
)) # very weird behavior of geom_dotplot, (1) because with aes group = (to avoid legend), the dot plotting is not good in term of coordinates, and (2) because data1 seems reorderer according to x = categ[1] before plotting. Thus, I have  to use fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"] to have the good corresponding colors # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.)
if( ! is.null(dot.categ)){
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = dot.categ.legend.name, values = rep(1, length(categ.color)))) # values = rep("black", length(categ.color)) are the values of color (which is the border color of dots), and this modify the border color on the plot. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = dot.categ.legend.name, labels = dot.categ.class.order, values = rep(dot.border.size, length(unique(data1[, dot.categ]))), guide = ggplot2::guide_legend(override.aes = list(fill = dot.color, color = if(is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size)))) # BEWARE: here length(unique(data1[, categ[length(categ)]])) and not length(dot.categ.class.order) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor
}else{
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = dot.categ.legend.name, values = rep(dot.border.size, length(unique(data1[, categ[length(categ)]]))), guide = ggplot2::guide_legend(label = FALSE, override.aes = list(name = NA, fill = NA, color = NA, stroke = NA)))) # 
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = dot.categ.legend.name, values = rep(dot.border.size, length(unique(data1[, categ[length(categ)]]))), guide = FALSE)) # guide = FALSE to remove the legend # BEWARE: here length(unique(data1[, categ[length(categ)]])) and not length(dot.categ.class.order)
Gael  MILLOT's avatar
Gael MILLOT committed
9610
}
9611
9612
9613
9614
9615
9616
9617
# coordinates of tidy dots
tempo.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data # to have the tidy dot coordinates
if(length(which(sapply(tempo.coord, FUN = nrow) == nrow(data1))) > 1){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": MORE THAN 2 COMPARTMENT WITH NROW EQUAL TO nrow(data1) IN THE tempo.coord LIST (FOR TIDY DOT COORDINATES). CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
}else{
dot.coord.tidy1 <- tempo.coord[[which(sapply(tempo.coord, FUN = nrow) == nrow(data1))]]
Gael  MILLOT's avatar
Gael MILLOT committed
9618
}
9619
9620
9621
9622
tempo.box.coord <- merge(box.coord, unique(dot.coord[, c("group", categ)]), by = intersect("group", "group"), sort = FALSE) # add the categ in box.coord. BEWARE: by = intersect("group", "group") because group is enough as only one value of x per group number in box.coord. Thus, no need to consider fill
if(nrow(tempo.box.coord) != nrow(box.coord)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": THE merge() FUNCTION DID NOT RETURN A CORRECT tempo.box.coord DATA FRAME. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9623
}
9624
9625
9626
9627
dot.coord.tidy2 <- merge(dot.coord.tidy1, tempo.box.coord[c("fill", "group", "x", categ)], by = intersect("group", "group"), sort = FALSE) # send the coord of the boxs into the coord data.frame of the dots (in the column x.y). BEWARE: by = intersect("group", "group") because group is enough as only one value of x per group number in box.coord. Thus, no need to consider fill
if(nrow(dot.coord.tidy2) != nrow(dot.coord)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": THE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.tidy2 DATA FRAME. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9628
}
9629
9630
9631
9632
9633
9634
9635
9636
9637
if(length(categ) == 1){
tempo.data1 <- unique(data.frame(data1[categ[1]], group = as.integer(factor(as.numeric(data1[, categ[1]]))))) # categ[2] first if categ[2] is used to make the categories in ggplot and categ[1] is used to make the x-axis
names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
verif <- paste0(categ[1], ".check")
}else if(length(categ) == 2){
tempo.data1 <- unique(data.frame(data1[c(categ[1], categ[2])], group = as.integer(factor(paste0(as.numeric(data1[, categ[2]]), ".", as.numeric(data1[, categ[1]])))))) # categ[2] first if categ[2] is used to make the categories in ggplot and categ[1] is used to make the x-axis
names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
names(tempo.data1)[names(tempo.data1) == categ[2]] <- paste0(categ[2], ".check")
verif <- c(paste0(categ[1], ".check"), paste0(categ[2], ".check"))
Gael  MILLOT's avatar
Gael MILLOT committed
9638
}else{
9639
9640
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9641
}
9642
9643
9644
9645
dot.coord.tidy3 <- merge(dot.coord.tidy2, tempo.data1, by = "group", sort = FALSE) # send the factors of data1 into coord
if(nrow(dot.coord.tidy3) != nrow(dot.coord) | ( ! fun_comp_2d(dot.coord.tidy3[categ], dot.coord.tidy3[verif])$identical.content)){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": THE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.tidy3 DATA FRAME. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9646
}
9647
# end coordinates of tidy dots
Gael  MILLOT's avatar
Gael MILLOT committed
9648
}
9649
coord.names <- c(coord.names, "dots")
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9650
}
9651
9652
9653
9654
9655
9656
9657
9658
9659
9660
9661
9662
9663
9664
9665
9666
9667
9668
9669
9670
9671
9672
9673
9674
9675
9676
9677
9678
9679
9680
# end dot display



# boxplot display (if box.fill = FALSE, otherwise, already plotted above)
if(box.fill == TRUE){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values =  if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color})) #, guide = ggplot2::guide_legend(override.aes = list(fill = levels(tempo.polygon$COLOR), color = "black")))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = rep(hsv(0, 0, 0, alpha = box.alpha), length(unique(data1[, categ[length(categ)]]))))) # , guide = ggplot2::guide_legend(override.aes = list(color = "black")))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor # outline of the polygon in black but with alpha
}else{
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[length(categ)], fill = categ[length(categ)]), position = ggplot2::position_dodge(width = NULL), width = box.width, size = box.line.size, notch = box.notch, alpha = box.alpha, coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf}, outlier.shape = if( ! is.null(dot.color)){NA}else{21}, outlier.color = if( ! is.null(dot.color)){NA}else{if(dot.border.size == 0){NA}else{dot.border.color}}, outlier.fill = if( ! is.null(dot.color)){NA}else{NULL}, outlier.size = if( ! is.null(dot.color)){NA}else{dot.size}, outlier.stroke = if( ! is.null(dot.color)){NA}else{dot.border.size}, outlier.alpha = if( ! is.null(dot.color)){NA}else{dot.alpha})) # the color, size, etc. of the outliers are dealt here. outlier.color = NA to do not plot outliers when dots are already plotted
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_path(
data = tempo.polygon, 
mapping = ggplot2::aes_string(x = "X", y = "Y", group = "BOX", color = categ[length(categ)]), 
size = box.line.size, 
alpha = box.alpha, 
lineend = "round", 
linejoin = "round"
))
coord.names <- c(coord.names, "main.box")
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = if(box.notch == FALSE){X_BOX_INF}else{X_NOTCH_INF}, xend = if(box.notch == FALSE){X_BOX_SUP}else{X_NOTCH_SUP}, y = MEDIAN, yend = MEDIAN, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size * 2, alpha = box.alpha)) # 
coord.names <- c(coord.names, "median")
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = QUART3, yend = MAX, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha)) # 
coord.names <- c(coord.names, "sup.whisker")
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = QUART1, yend = MIN, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha)) # 
coord.names <- c(coord.names, "inf.whisker")
if(box.whisker.width > 0){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = MAX, yend = MAX, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha, lineend = "round")) # 
coord.names <- c(coord.names, "sup.whisker.edge")
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = MIN, yend = MIN, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha, lineend = "round")) # 
coord.names <- c(coord.names, "inf.whisker.edge")
Gael  MILLOT's avatar
Gael MILLOT committed
9681
}
9682
9683
9684
9685
9686
9687
9688
9689
9690
9691
9692
9693
if(box.mean == TRUE){
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = stat, mapping = ggplot2::aes_string(x = "X", y = "MEAN", group = categ[length(categ)]), shape = 23, stroke = box.line.size * 2, color = stat$COLOR, size = box.mean.size, fill = NA, alpha = box.alpha)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_path(
data = tempo.diamon.mean, 
mapping = ggplot2::aes(x = X, y = Y, group = GROUP), 
color = tempo.diamon.mean[, "COLOR"], 
size = box.line.size * 2, 
alpha = box.alpha, 
lineend = "round", 
linejoin = "round"
))
coord.names <- c(coord.names, "mean")
Gael  MILLOT's avatar
Gael MILLOT committed
9694
}
9695
9696
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = rep(NA, length(unique(data1[, categ[length(categ)]]))))) #, guide = ggplot2::guide_legend(override.aes = list(color = categ.color)))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color})) # , guide = ggplot2::guide_legend(override.aes = list(color = as.character(categ.color))))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor
Gael  MILLOT's avatar
Gael MILLOT committed
9697

9698
9699
}
# end boxplot display (if box.fill = FALSE, otherwise, already plotted above)
Gael  MILLOT's avatar
Gael MILLOT committed
9700
9701
9702



9703
9704
9705
9706
9707
9708
9709
9710
9711
9712
9713
9714
9715

# stat display
# layer after dots but ok, behind dots on the plot
if( ! is.null(stat.disp)){
if(stat.disp == "top"){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1),  ggplot2::annotate(geom = "text", x = stat$X, y = y.lim[2], label = if(stat.disp.mean == FALSE){fun_round(stat$MEDIAN, 2)}else{fun_round(stat$MEAN, 2)}, size = stat.size, color = "black", hjust = ifelse(vertical == TRUE, 0.5, 1.1), vjust = ifelse(vertical == TRUE, 1.1, 0.5))) # beware: no need of order() for labels because box.coord$x set the order. For justification, see https://stackoverflow.com/questions/7263849/what-do-hjust-and-vjust-do-when-making-a-plot-using-ggplot
}else if(stat.disp == "above"){
# stat coordinates
if( ! is.null(dot.color)){ # for text just above max dot
if(dot.tidy == FALSE){
tempo.stat.ini <- dot.coord.rd3
}else if(dot.tidy == TRUE){
tempo.stat.ini <- dot.coord.tidy3
Gael  MILLOT's avatar
Gael MILLOT committed
9716
}
9717
9718
9719
9720
9721
9722
9723
9724
9725
stat.coord1 <- aggregate(x = tempo.stat.ini["y"], by = {x.env <- if(length(categ) == 1){list(tempo.stat.ini$group, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]])}else if(length(categ) == 2){list(tempo.stat.ini$group, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]], tempo.stat.ini[, categ[2]])} ; names(x.env) <- if(length(categ) == 1){c("group", "x.y", categ[1])}else if(length(categ) == 2){c("group", "x.y", categ[1], categ[2])} ; x.env}, FUN = min, na.rm = TRUE)
names(stat.coord1)[names(stat.coord1) == "y"] <- "dot.min"
stat.coord2 <- aggregate(x = tempo.stat.ini["y"], by = {x.env <- if(length(categ) == 1){list(tempo.stat.ini$group, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]])}else if(length(categ) == 2){list(tempo.stat.ini$group, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]], tempo.stat.ini[, categ[2]])} ; names(x.env) <- if(length(categ) == 1){c("group", "x.y", categ[1])}else if(length(categ) == 2){c("group", "x.y", categ[1], categ[2])} ; x.env}, FUN = max, na.rm = TRUE)
names(stat.coord2) <- paste0(names(stat.coord2), "_from.dot.max")
names(stat.coord2)[names(stat.coord2) == "y_from.dot.max"] <- "dot.max"
stat.coord3 <- cbind(box.coord[order(box.coord$x), ], stat.coord1[order(stat.coord1$x.y), ], stat.coord2[order(stat.coord2$x.y), ]) # should be ok to use box.coord$x and stat.coord$x.y to assemble the two data frames because x coordinates of the boxs. Thus, we cannot have identical values
if( ! all(identical(round(stat.coord3$x, 9), round(stat.coord3$x.y, 9)))){
tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": FUSION OF box.coord, stat.coord1 AND stat.coord2 ACCORDING TO box.coord$x, stat.coord1$x.y AND stat.coord2$x.y IS NOT CORRECT. CODE HAS TO BE MODIFIED\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9726
}
9727
9728
9729
9730
9731
9732
9733
9734
text.coord <- stat.coord3[, c("x", "group", "dot.min", "dot.max")]
names(text.coord)[names(text.coord) == "dot.min"] <- "text.min.pos"
names(text.coord)[names(text.coord) == "dot.max"] <- "text.max.pos"
box.coord <- box.coord[order(box.coord$x), ]
text.coord <- text.coord[order(text.coord$x), ] # to be sure to have the two objects in the same order for x. BEWARE: cannot add identical(as.integer(text.coord$group), as.integer(box.coord$group)) because with error, the correspondence between x and group is not the same
if( ! identical(text.coord$x, box.coord$x)){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": text.coord AND box.coord DO NOT HAVE THE SAME x COLUMN CONTENT\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9735
9736
}
}
9737
9738
9739
9740
9741
9742
9743
9744
9745
9746
9747
9748
9749
9750
9751
9752
9753
9754
9755
9756
9757
9758
9759
9760
9761
9762
9763
9764
9765
9766
9767
9768
9769
9770
9771
9772
9773
9774
9775
9776
9777
9778
9779
9780
9781
9782
# end stat coordinates
# stat display
if(is.null(dot.color)){ # text just above boxs
# performed twice: first for y values >=0, then y values < 0, because only a single value allowed for hjust anf vjust
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "text", 
x = box.coord$x[box.coord$middle >= 0], 
y = box.coord$middle[box.coord$middle >= 0], 
label = if(stat.disp.mean == FALSE){fun_round(box.coord$middle, 2)[box.coord$middle >= 0]}else{fun_round(box.coord$MEAN, 2)[box.coord$MEAN >= 0]}, 
size = stat.size, 
color = "black", 
hjust = ifelse(vertical == TRUE, 0.5, 0.5 - stat.dist), 
vjust = ifelse(vertical == TRUE, 0.5 - stat.dist, 0.5)
)) # beware: no need of order() for labels because box.coord$x set the order
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "text", 
x = box.coord$x[box.coord$middle < 0], 
y = box.coord$middle[box.coord$middle < 0], 
label = if(stat.disp.mean == FALSE){fun_round(box.coord$middle, 2)[box.coord$middle < 0]}else{fun_round(box.coord$MEAN, 2)[box.coord$MEAN < 0]}, 
size = stat.size, 
color = "black", 
hjust = ifelse(vertical == TRUE, 0.5, 0.5 + stat.dist), 
vjust = ifelse(vertical == TRUE, 0.5 + stat.dist, 0.5)
)) # beware: no need of order() for labels because box.coord$x set the order
}else{ # text just above error boxs or dots
# I checked that text.coord and box.coord have the same x and group column content. Thus, ok to use them together
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "text", 
x = text.coord$x[box.coord$middle >= 0], 
y = text.coord$text.max.pos[box.coord$middle >= 0], 
label = if(stat.disp.mean == FALSE){fun_round(box.coord$middle, 2)[box.coord$middle >= 0]}else{fun_round(box.coord$MEAN, 2)[box.coord$MEAN >= 0]}, 
size = stat.size, 
color = "black", 
hjust = ifelse(vertical == TRUE, 0.5, 0.5 - stat.dist), 
vjust = ifelse(vertical == TRUE, 0.5 - stat.dist, 0.5)
)) # beware: no need of order() for labels because box.coord$x set the order
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "text", 
x = text.coord$x[box.coord$middle < 0], 
y = text.coord$text.min.pos[box.coord$middle < 0], 
label = if(stat.disp.mean == FALSE){fun_round(box.coord$middle, 2)[box.coord$middle < 0]}else{fun_round(box.coord$MEAN, 2)[box.coord$MEAN < 0]}, 
size = stat.size, 
color = "black", 
hjust = ifelse(vertical == TRUE, 0.5, 0.5 + stat.dist), 
vjust = ifelse(vertical == TRUE, 0.5 + stat.dist, 0.5)
)) # beware: no need of order() for labels because box.coord$x set the order
Gael  MILLOT's avatar
fun_get    
Gael MILLOT committed
9783
}
9784
# end stat display
Gael  MILLOT's avatar
Gael MILLOT committed
9785
}else{
9786
9787
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 9\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9788
}
9789
9790
9791
9792
9793
9794
9795
9796
9797
9798
9799
9800
9801
9802
9803
9804
9805
9806
}
# end stat display



# y scale management (cannot be before dot plot management)
tempo.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$layout$panel_params[[1]]
tempo.scale <- fun_scale(lim = y.lim, n = ifelse(is.null(y.tick.nb), length(tempo.coord$y.major_source), y.tick.nb))
# 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, 
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, ": CODE INCONSISTENCY 10\n\n============\n\n") ; stop(tempo.cat)}, 
expand = c(0, 0),
limits = NA,
trans = ifelse(diff(y.lim) < 0, "reverse", "identity") # equivalent to ggplot2::scale_y_reverse()
))
if(vertical == TRUE){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_cartesian(ylim = y.lim)) # clip = "off" to have secondary ticks outside plot region does not work
Gael  MILLOT's avatar
Gael MILLOT committed
9807
}else{
9808
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_flip(ylim = y.lim)) # clip = "off" to have secondary ticks outside plot region does not work
Gael  MILLOT's avatar
Gael MILLOT committed
9809
}
9810
9811
9812
9813
9814
9815
9816
9817
9818
9819
9820
9821
9822
9823
9824
9825
# secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip())
tempo.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$layout$panel_params[[1]]
# no secondary ticks for log2. Play with y.lim
if(y.log == "log10"){
y.lim.order <- order(y.lim) # to deal with inverse axis
ini.scipen <- options()$scipen
options(scipen = -1000) # force scientific format
power10.exp <- as.integer(substring(text = 10^y.lim, first = (regexpr(pattern = "\\+|\\-", text = 10^y.lim)))) # recover the power of 10. Example recover 08 from 1e+08
mantisse <- as.numeric(substr(x = 10^y.lim, start = 1, stop = (regexpr(pattern = "\\+|\\-", text = 10^y.lim) - 2))) # recover the mantisse. Example recover 1.22 from 1.22e+08
options(scipen = ini.scipen) # restore the initial scientific penalty
tempo.tick.pos <- as.vector(outer(log10(2:10), 10^((power10.exp[1] - ifelse(diff(y.lim.order) > 0, 1, -1)):(power10.exp[2] + ifelse(diff(y.lim.order) > 0, 1, -1)))))
tempo.tick.pos <- sort(tempo.tick.pos, decreasing = ifelse(diff(y.lim.order) > 0, FALSE, TRUE))
tempo.tick.pos <- log10(tempo.tick.pos[tempo.tick.pos >= min(10^y.lim) & tempo.tick.pos <= max(10^y.lim)])
if(any(is.na(tempo.tick.pos) | ! is.finite(tempo.tick.pos))){ 
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 11\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9826
}
9827
9828
9829
9830
9831
9832
9833
9834
9835
9836
9837
9838
# 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 = tempo.tick.pos, yend = tempo.tick.pos, x = tempo.coord$x.range[1], xend = tempo.coord$x.range[1] + 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 = tempo.tick.pos, xend = tempo.tick.pos, y = tempo.coord$y.range[1], yend = tempo.coord$y.range[1] + diff(tempo.coord$y.range) / 80))
# }
}else if(( ! is.null(y.inter.tick.nb)) & y.log == "no"){
if(y.inter.tick.nb > 0){
if(vertical == TRUE){
ticks.pos <- suppressWarnings(as.numeric(tempo.coord$y.labels)) # too difficult to predict the behavior of tempo.coord$x.major_source depending on y.lim neg or not, inv or not
if(any(is.na(ticks.pos))){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 12\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9839
}
9840
9841
9842
9843
tick.dist <- mean(diff(ticks.pos), na.rm = TRUE)
minor.tick.dist <- tick.dist / (y.inter.tick.nb + 1)
minor.tick.pos <- seq(ticks.pos[1] - tick.dist, ticks.pos[length(ticks.pos)] + tick.dist, by = minor.tick.dist)
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", y = minor.tick.pos, yend = minor.tick.pos, x = tempo.coord$x.range[1], xend = tempo.coord$x.range[1] + diff(tempo.coord$x.range) / 80))
Gael  MILLOT's avatar
Gael MILLOT committed
9844
}else{
9845
9846
9847
9848
ticks.pos  <- suppressWarnings(as.numeric(tempo.coord$x.labels))# too difficult to predict the behavior of tempo.coord$x.major_source depending on y.lim neg or not, inv or not
if(any(is.na(ticks.pos))){
tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 13\n\n============\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
9849
}
9850
9851
9852
9853
tick.dist <- mean(diff(ticks.pos), na.rm = TRUE)
minor.tick.dist <- tick.dist / (y.inter.tick.nb + 1)
minor.tick.pos <- seq(ticks.pos[1] - tick.dist, ticks.pos[length(ticks.pos)] + tick.dist, by = minor.tick.dist)
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", y = minor.tick.pos, yend = minor.tick.pos, x = tempo.coord$y.range[1], xend = tempo.coord$y.range[1] + diff(tempo.coord$y.range) / 80))
Gael  MILLOT's avatar
Gael MILLOT committed
9854
9855
9856
}
}
}
9857
9858
9859
9860
9861
9862
9863
9864
9865
9866
9867
9868
9869
9870
9871
9872
9873
# end secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip())
# end y scale  management (cannot be before dot plot management)




# drawing
if(plot == TRUE){
# following lines inactivated because of problem in warn.recov and message.recov
# assign("env_fun_get_message", new.env())
# assign("tempo.gg.name", tempo.gg.name, envir = env_fun_get_message)
# assign("tempo.gg.count", tempo.gg.count, envir = env_fun_get_message)
# assign("add", add, envir = env_fun_get_message)
# two next line: for the moment, I cannot prevent the warning printing
# warn.recov <- fun_get_message(paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}), kind = "warning", header = FALSE, print.no = FALSE, env = env_fun_get_message) # for recovering warnings printed by ggplot() functions
# message.recov <- fun_get_message('print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}))))', kind = "message", header = FALSE, print.no = FALSE, env = env_fun_get_message) # for recovering messages printed by ggplot() functions
suppressMessages(suppressWarnings(print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}))))))
Gael  MILLOT's avatar
Gael MILLOT committed
9874
}else{
9875
9876
9877
9878
9879
9880
# following lines inactivated because of problem in warn.recov and message.recov
# message.recov <- NULL
# warn.recov <- NULL
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
9881
}
9882
9883
9884
9885
9886
9887
9888
9889
9890
9891
9892
9893
9894
9895
9896
# end drawing



# outputs
# following lines inactivated because of problem in warn.recov and message.recov
# if( ! (is.null(warn) & is.null(warn.recov) & is.null(message.recov))){
# warn <- paste0(warn, "\n\n", if(length(warn.recov) > 0 | length(message.recov) > 0){paste0(paste0("MESSAGES FROM ggplot2 FUNCTIONS: ", ifelse( ! is.null(warn.recov), unique(message.recov), ""), ifelse( ! is.null(message.recov), unique(message.recov), ""), collapse = "\n\n"), "\n\n")})
# }else if( ! (is.null(warn) & is.null(warn.recov)) & is.null(message.recov)){
# warn <- paste0(warn, "\n\n", if(length(warn.recov) > 0){paste0(paste0("MESSAGES FROM ggplot2 FUNCTIONS: ", unique(warn.recov), collapse = "\n\n"), "\n\n")})
# }else if( ! (is.null(warn) & is.null(message.recov)) & is.null(warn.recov)){
# warn <- paste0(warn, "\n\n", if(length(message.recov) > 0){paste0(paste0("MESSAGES FROM ggplot2 FUNCTIONS: ", unique(message.recov), collapse = "\n\n"), "\n\n")})
# }
if(warn.print == TRUE & ! is.null(warn)){
warning(paste0("FROM ", function.name, " FUNCTION:\n\n", warn), call. = FALSE) # to recover the warning messages, use return = TRUE
Gael  MILLOT's avatar
Gael MILLOT committed
9897
}
9898
9899
9900
9901
9902
9903
if(return == TRUE){
output <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))
output$data <- output$data[-1] # 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)
Gael  MILLOT's avatar
Gael MILLOT committed
9904
}else{
9905
names(output$data) <- coord.names
Gael  MILLOT's avatar
Gael MILLOT committed
9906
}
9907
9908
output <- list(data = data1, stat = stat, removed.row.nb = removed.row.nb, removed.rows = removed.rows, plot = output$data, axes = output$layout$panel_params[[1]], warn = paste0("\n", warn, "\n\n"))
return(output)
Gael  MILLOT's avatar
Gael MILLOT committed
9909
}
9910
9911
# end outputs
# end main code
Gael  MILLOT's avatar
Gael MILLOT committed
9912
9913
}