cute_little_R_functions.R 106 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# https://ggplot2-book.org/scales.html
#remain do do:
# add names to the output. NULL vector, and name added for echa plotted feature
# add legend if dots have specific colors
# add message recov
# 3) quanti variable for categ
# numbers the different warnings (make a count)

# to solve:
#  fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group2"), categ.color = c("green", "red"), categ.class.order = list(c("A", "B")), return = TRUE, box.fill = TRUE)
#  fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group2"), categ.color = c("green", "red"), categ.class.order = list(c("A", "B")), return = TRUE, box.fill = FALSE)
#  fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group2"), dot.color=c("green", "blue"), dot.categ = "Group3", dot.border.color = "black", dot.alpha = 1, dot.border.size = 2, dot.categ.class.order = c("J", "I"))

# fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", categ.color= c("blue"), categ.class.order=list(c("H", "G")), box.width=0.5, box.line.size=1, box.notch=TRUE, box.alpha = 1, box.fill = FALSE, box.whisker.kind = "max", box.whisker.width = 0, dot.color=1:2, dot.categ = "Group2")
# error: this message appear when no class disappear, when NA are present "THE FOLLOWING CLASSES HAVE BEEN LOST DUE TO NA REMOVAL IN data1"


fun_gg_boxplot <- function(
data1, 
y, 
categ, 
categ.class.order = NULL, 
categ.legend.name = NULL, 
categ.color = NULL, 
box.fill = FALSE, 
box.width = 0.5, 
box.space = 0.1, 
box.line.size = 0.5, 
box.notch = FALSE, 
box.alpha = 1, 
box.mean = TRUE, 
box.whisker.kind = "std", 
box.whisker.width = 0.5, 
dot.color = "black", 
dot.categ = NULL, 
dot.categ.class.order = NULL, 
dot.categ.legend.name = NULL, 
dot.tidy = FALSE, 
dot.tidy.bin.nb = 30, 
dot.jitter = 0.5, 
dot.size = 3, 
dot.alpha = 0.5, 
dot.border.size = 0.5, 
dot.border.color = NULL, 
x.lab = NULL, 
y.lab = NULL, 
y.lim = NULL, 
y.log = "no", 
y.tick.nb = NULL, 
y.inter.tick.nb = NULL, 
y.include.zero = FALSE, 
y.top.extra.margin = 0.05, 
y.bottom.extra.margin = 0.05, 
stat.disp = NULL, 
stat.disp.mean = FALSE, 
stat.size = 4, 
stat.dist = 2, 
vertical = TRUE, 
text.size = 12, 
text.angle = 0, 
title = "", 
title.text.size = 8, 
classic = TRUE, 
grid = FALSE, 
return = FALSE, 
plot = TRUE, 
add = NULL, 
warn.print = TRUE, 
lib.path = NULL
){
Gael  MILLOT's avatar
Gael MILLOT committed
71

Gael  MILLOT's avatar
Gael MILLOT committed
72
73
# DEBUGGING
# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; data1 = obs1 ; y = "Time" ; categ = "Group1" ; categ.class.order = list(c("G", "H")) ; categ.legend.name = NULL ; categ.color = c("green", "blue") ; box.fill = FALSE ; box.width = 0.5 ; box.space = 0.1 ; box.notch = FALSE ; box.line.size = 0.5 ; box.alpha = 0.5 ; box.mean = TRUE ; box.whisker.kind = "std" ; box.whisker.width = 0.5 ; dot.color = NULL ; dot.categ = NULL ; dot.categ.class.order = NULL ; dot.categ.legend.name = NULL ; dot.tidy = TRUE ; dot.tidy.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ;  dot.alpha = 0.5 ; dot.border.size = 0.5 ; dot.border.color = NULL ; y.lim = NULL ; y.log = "no" ; y.tick.nb = NULL ; y.inter.tick.nb = NULL ; y.include.zero = FALSE ; y.top.extra.margin = 0.05 ; y.bottom.extra.margin = 0.05 ; stat.disp = NULL ; stat.disp.mean = FALSE ; stat.size = 4 ; stat.dist = 2 ; x.lab = NULL ; y.lab = NULL ; vertical = TRUE ; text.size = 12 ; title = "" ; title.text.size = 8 ; text.angle = 0 ; classic = FALSE ; grid = FALSE ; return = TRUE ; plot = TRUE ; add = NULL ; warn.print = FALSE ; lib.path = NULL
Gael  MILLOT's avatar
Gael MILLOT committed
74

Gael  MILLOT's avatar
Gael MILLOT committed
75
# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), Group2 = rep(c("A", "B"), time = 10), Group3 = rep(c("I", "J"), time = 10)) ; data1 = obs1 ; y = "Time" ; categ = c("Group1", "Group2") ; categ.class.order = list(c("G", "H"), c("A", "B")); categ.legend.name = NULL ; categ.color = c("green", "blue") ; box.fill = FALSE ; box.width = 0.5 ; box.space = 0.1 ; box.notch = FALSE ; box.line.size = 0.5 ; box.alpha = 0.5 ; box.mean = TRUE ; box.whisker.kind = "std" ; box.whisker.width = 0.5 ; dot.color = NULL ; dot.categ = NULL ; dot.categ.class.order = NULL ; dot.categ.legend.name = NULL ; dot.tidy = FALSE ; dot.tidy.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ;  dot.alpha = 0.5 ; dot.border.size = 0.5 ; dot.border.color = NULL ; y.lim = NULL ; y.log = "no" ; y.tick.nb = NULL ; y.inter.tick.nb = NULL ; y.include.zero = FALSE ; y.top.extra.margin = 0.05 ; y.bottom.extra.margin = 0.05 ; stat.disp = NULL ; stat.disp.mean = FALSE ; stat.size = 4 ; stat.dist = 2 ; x.lab = NULL ; y.lab = NULL ; vertical = TRUE ; text.size = 12 ; title = "" ; title.text.size = 8 ; text.angle = 0 ; classic = FALSE ; grid = FALSE ; return = FALSE ; plot = TRUE ; add = NULL ; warn.print = FALSE ; lib.path = NULL
Gael  MILLOT's avatar
Gael MILLOT committed
76

Gael  MILLOT's avatar
Gael MILLOT committed
77
# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), Group2 = rep(c("A", "B"), time = 10)) ; data1 = obs1 ; y = "Time" ; categ = c("Group1") ; categ.class.order = list(c("H", "G")); categ.legend.name = NULL ; categ.color = c("blue") ; box.fill = FALSE ; box.width = 0.5 ; box.space = 0.1 ; box.notch = TRUE ; box.line.size = 1 ; box.alpha = 1 ; box.mean = FALSE ; box.whisker.kind = "max" ; box.whisker.width = 0 ; dot.color = 1:2 ; dot.categ = "Group2" ; dot.categ.class.order = NULL ; dot.categ.legend.name = NULL ; dot.tidy = FALSE ; dot.tidy.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ;  dot.alpha = 0.5 ; dot.border.size = 0.5 ; dot.border.color = NULL ; y.lim = NULL ; y.log = "no" ; y.tick.nb = NULL ; y.inter.tick.nb = NULL ; y.include.zero = FALSE ; y.top.extra.margin = 0.05 ; y.bottom.extra.margin = 0.05 ; stat.disp = NULL ; stat.disp.mean = FALSE ; stat.size = 4 ; stat.dist = 2 ; x.lab = NULL ; y.lab = NULL ; vertical = TRUE ; text.size = 12 ; title = "" ; title.text.size = 8 ; text.angle = 0 ; classic = FALSE ; grid = FALSE ; return = FALSE ; plot = TRUE ; add = NULL ; warn.print = FALSE ; lib.path = NULL
Gael  MILLOT's avatar
Gael MILLOT committed
78
79
80
81
82





Gael  MILLOT's avatar
Gael MILLOT committed
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
req.function <- c(
"fun_comp_2d", 
"fun_gg_just", 
"fun_gg_palette", 
"fun_name_change", 
"fun_pack", 
"fun_check", 
"fun_round", 
"fun_scale"
)
for(i1 in req.function){
if(length(find(i1, mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED ", i1, "() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat)
Gael  MILLOT's avatar
Gael MILLOT committed
101
102
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
# end required function checking
# reserved words to avoid bugs (used in this function)
reserved.words <- c("categ.check", "categ.color", "dot.color", "dot.max", "dot.min", "group", "group.check", "MEAN", "tempo.categ1", "tempo.categ2", "text.max.pos", "text.min.pos", "x", "x.y", "y", "y.check", "y_from.dot.max", "ymax")
# end reserved words to avoid bugs (used in this function)
# primary argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = data1, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = y, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = categ, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
if( ! is.null(categ.class.order)){
tempo <- fun_check(data = categ.class.order, class = "list", fun.name = function.name) ; eval(ee)
}
if( ! is.null(categ.legend.name)){
tempo <- fun_check(data = categ.legend.name, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
120
}
Gael  MILLOT's avatar
Gael MILLOT committed
121
122
123
124
125
126
127
128
129
if( ! is.null(categ.color)){
tempo1 <- fun_check(data = categ.color, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name, print = FALSE)
tempo2 <- fun_check(data = categ.color, class = "factor", na.contain = TRUE, fun.name = function.name, print = FALSE)
if(tempo1$problem == TRUE & tempo2$problem == TRUE){
tempo.check.color <- fun_check(data = categ.color, class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, fun.name = function.name, print = FALSE)$problem
if(tempo.check.color == TRUE){
tempo.cat <- paste0("ERROR IN ", function.name, ": categ.color MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR") # integer possible because dealt above
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
130
131
132
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
tempo <- fun_check(data = box.fill, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.space, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.line.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.notch, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.alpha, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.mean, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.whisker.kind, options = c("no", "std", "max"), length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = box.whisker.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(dot.color)){
tempo1 <- fun_check(data = dot.color, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name, print = FALSE)
tempo2 <- fun_check(data = dot.color, class = "factor", na.contain = TRUE, fun.name = function.name, print = FALSE)
if(tempo1$problem == TRUE & tempo2$problem == TRUE){
tempo.check.color <- fun_check(data = dot.color, class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, fun.name = function.name, print = FALSE)$problem
if(tempo.check.color == TRUE){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.color MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR") # integer possible because dealt above
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
151
152
153
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
154
155
if( ! is.null(dot.categ)){
tempo <- fun_check(data = dot.categ, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
156
}
Gael  MILLOT's avatar
Gael MILLOT committed
157
158
if( ! is.null(dot.categ.class.order)){
tempo <- fun_check(data = dot.categ.class.order, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
159
}
Gael  MILLOT's avatar
Gael MILLOT committed
160
161
if( ! is.null(dot.categ.legend.name)){
tempo <- fun_check(data = dot.categ.legend.name, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
162
}
Gael  MILLOT's avatar
Gael MILLOT committed
163
164
165
166
167
168
169
170
171
172
173
174
175
176
tempo <- fun_check(data = dot.tidy, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = dot.tidy.bin.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = dot.jitter, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = dot.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = dot.alpha, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = dot.border.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
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 == TRUE & tempo2$problem == TRUE){
# integer colors into gg_palette
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.color MUST BE A SINGLE CHARACTER STRING OF COLOR OR A SINGLE INTEGER VALUE") # integer possible because dealt above
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
177
178
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
179
180
181
182
183
if( ! is.null(x.lab)){
if(all(class(x.lab) %in% "expression")){ # to deal with math symbols
tempo <- fun_check(data = x.lab, class = "expression", length = 1, fun.name = function.name) ; eval(ee)
}else{
tempo <- fun_check(data = x.lab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
184
185
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
186
187
188
189
190
if( ! is.null(y.lab)){
if(all(class(y.lab) %in% "expression")){ # to deal with math symbols
tempo <- fun_check(data = y.lab, class = "expression", length = 1, fun.name = function.name) ; eval(ee)
}else{
tempo <- fun_check(data = y.lab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
191
192
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
193
194
195
196
197
198
if( ! is.null(y.lim)){
tempo <- fun_check(data = y.lim, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & any(y.lim %in% c(Inf, -Inf))){
tempo.cat <- paste0("ERROR IN ", function.name, ": y.lim ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
199
200
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
201
202
203
204
205
206
207
tempo <- fun_check(data = y.log, options = c("no", "log2", "log10"), length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(y.tick.nb)){
tempo <- fun_check(data = y.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & y.tick.nb < 0){
tempo.cat <- paste0("ERROR IN ", function.name, ": y.tick.nb ARGUMENT MUST BE A NON NULL POSITIVE INTEGER")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
208
209
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
210
211
212
213
214
215
if( ! is.null(y.inter.tick.nb)){
tempo <- fun_check(data = y.inter.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & y.inter.tick.nb < 0){
tempo.cat <- paste0("ERROR IN ", function.name, ": y.inter.tick.nb ARGUMENT MUST BE A NON NULL POSITIVE INTEGER")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
216
217
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
218
219
220
221
222
tempo <- fun_check(data = y.include.zero, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = y.top.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = y.bottom.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(stat.disp)){
tempo <- fun_check(data = stat.disp, options = c("top", "above"), length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
223
}
Gael  MILLOT's avatar
Gael MILLOT committed
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
tempo <- fun_check(data = stat.disp.mean, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = stat.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = stat.dist, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = vertical, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = text.angle, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, neg.values = TRUE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = title, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = title.text.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = classic, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = grid, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = return, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = plot, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(add)){
tempo <- fun_check(data = add, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! grepl(pattern = "^\\+", add)){ # check that the add string start by +
tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST START WITH \"+\": ", paste(unique(add), collapse = " "))
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}else if(tempo$problem == FALSE & ! grepl(pattern = "ggplot2::", add)){ #
tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST CONTAIN \"ggplot2::\" IN FRONT OF EACH GGPLOT2 FUNCTION: ", paste(unique(add), collapse = " "))
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
}else if(tempo$problem == FALSE & ! grepl(pattern = ")$", add)){ # check that the add string  finished by )
tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST FINISH BY \")\": ", paste(unique(add), collapse = " "))
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
250
251
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
252
253
254
255
256
257
tempo <- fun_check(data = warn.print, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(lib.path)){
tempo <- fun_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & ! all(dir.exists(lib.path))){
cat(paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS: ", lib.path, "\n\n============\n\n"))
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
258
259
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
260
261
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
Gael  MILLOT's avatar
Gael MILLOT committed
262
}
Gael  MILLOT's avatar
Gael MILLOT committed
263
264
265
266
267
268
269
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end primary argument checking
# second round of checking and data preparation
warn <- NULL
if(any(duplicated(names(data1)))){
tempo.cat <- paste0("ERROR IN ", function.name, ": DUPLICATED COLUMN NAMES OF data1 ARGUMENT NOT ALLOWED:\n", paste(names(data1)[duplicated(names(data1))], collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
270
}
Gael  MILLOT's avatar
Gael MILLOT committed
271
272
273
if( ! (y %in% names(data1))){
tempo.cat <- paste0("ERROR IN ", function.name, ": y ARGUMENT MUST BE A COLUMN NAME OF data1")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
274
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
275
tempo <- fun_check(data = data1[, y], data.name = "y COLUMN OF data1", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
276
}
Gael  MILLOT's avatar
Gael MILLOT committed
277
278
279
280
281
282
if(length(categ) > 2){
tempo.cat <- paste0("ERROR IN ", function.name, ": categ ARGUMENT CANNOT HAVE MORE THAN 2 COLUMN NAMES OF data1")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else if( ! all(categ %in% names(data1))){
tempo.cat <- paste0("ERROR IN ", function.name, ": categ ARGUMENT MUST BE COLUMN NAMES OF data1. HERE IT IS:\n", paste(categ, collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
283
}
Gael  MILLOT's avatar
Gael MILLOT committed
284
285
286
287
288
# reserved word checking
if(any(names(data1) %in% reserved.words)){
if(any(duplicated(names(data1)))){
tempo.cat <- paste0("ERROR IN ", function.name, ": DUPLICATED COLUMN NAMES OF data1 ARGUMENT NOT ALLOWED:\n", paste(names(data1)[duplicated(names(data1))], collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
289
}
Gael  MILLOT's avatar
Gael MILLOT committed
290
291
292
293
294
295
296
297
298
299
300
301
tempo.output <- fun_name_change(names(data1), reserved.words)
for(i3 in 1:length(tempo.output$ini)){ # a loop to be sure to take the good ones
names(data1)[names(data1) == tempo.output$ini[i3]] <- tempo.output$post[i3]
if(any(y == tempo.output$ini[i3])){
y[y == tempo.output$ini[i3]] <- tempo.output$post[i3]
tempo.warn <- paste0("IN y ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i3], " HAS BEEN REPLACED BY ", tempo.output$post[i3], "\nBECAUSE RISK OF BUG AS SOME NAMES IN y ARGUMENT ARE RESERVED WORD USED BY THE ", function.name, " FUNCTION")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}
if(any(categ == tempo.output$ini[i3])){
categ[categ == tempo.output$ini[i3]] <- tempo.output$post[i3]
tempo.warn <- paste0("IN categ ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i3], " HAS BEEN REPLACED BY ", tempo.output$post[i3], "\nBECAUSE RISK OF BUG AS SOME NAMES IN categ ARGUMENT ARE RESERVED WORD USED BY THE ", function.name, " FUNCTION")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
302
303
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
304
305
tempo.warn <- paste0("REGARDING COLUMN NAMES REPLACEMENT, THE NAMES\n", paste(tempo.output$ini, collapse = " "), "\nHAVE BEEN REPLACED BY\n", paste(tempo.output$post, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
306
}
Gael  MILLOT's avatar
Gael MILLOT committed
307
308
309
310
311
312
313
314
315
316
317
# end reserved word checking
# conversion of categ columns in data1 into factors
for(i1 in 1:length(categ)){
tempo1 <- fun_check(data = data1[, categ[i1]], data.name = paste0("categ NUMBER ", i1, " OF data1"), class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name, print = FALSE)
tempo2 <- fun_check(data = data1[, categ[i1]], data.name = paste0("categ NUMBER ", i1, " OF data1"), class = "factor", na.contain = TRUE, fun.name = function.name, print = FALSE)
if(tempo1$problem == TRUE & tempo2$problem == TRUE){
tempo.cat <- paste0("ERROR IN ", function.name, ": ", paste0("categ NUMBER ", i1, " OF data1"), " MUST BE A FACTOR OR CHARACTER VECTOR")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else if(tempo1$problem == FALSE){ # character vector
tempo.warn <- paste0("IN categ NUMBER ", i1, " IN data1, THE CHARACTER COLUMN HAS BEEN CONVERTED TO FACTOR, WITH LEVELS ACCORDING TO THE ALPHABETICAL ORDER")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
318
}
Gael  MILLOT's avatar
Gael MILLOT committed
319
data1[, categ[i1]] <- factor(data1[, categ[i1]]) # if already a factor, change nothing, if characters, levels according to alphabetical order
Gael  MILLOT's avatar
Gael MILLOT committed
320
}
Gael  MILLOT's avatar
Gael MILLOT committed
321
322
323
324
325
326
327
328
329
330
331
332
333
334
# OK: all the categ columns of data1 are factors from here
# end conversion of categ columns in data1 into factors
if( ! is.null(categ.class.order)){
tempo <- fun_check(data = categ.class.order, class = "list", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & length(categ.class.order) > 2){
tempo.cat <- paste0("ERROR IN ", function.name, ": categ.class.order ARGUMENT MUST BE A LIST OF MAX LENGTH 2")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else if(tempo$problem == FALSE){
for(i3 in 1:length(categ.class.order)){
if(is.null(categ.class.order[[i3]])){
tempo.warn <- paste0("THE categ.class.order COMPARTMENT ", i3, " IS NULL. ALPHABETICAL ORDER WILL BE APPLIED")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
data1[, categ[i3]] <- factor(as.character(data1[, categ[i3]])) # if already a factor, change nothing, if characters, levels according to alphabetical order
categ.class.order[[i3]] <- levels(data1[, categ[i3]]) # character vector that will be used later
Gael  MILLOT's avatar
Gael MILLOT committed
335
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
336
tempo <- fun_check(data = categ.class.order[[i3]], data.name = paste0("COMPARTMENT ", i3 , " OF categ.class.order ARGUMENT"), class = "vector", mode = "character", length = length(levels(data1[, categ[i1]])), fun.name = function.name) ; eval(ee) # length(data1[, categ[i1]) -> if data1[, categ[i1] was initially character vector, then conversion as factor after the NA removal, thus class number ok. If data1[, categ[i1] was initially factor, no modification after the NA removal, thus class number ok
Gael  MILLOT's avatar
Gael MILLOT committed
337
}
Gael  MILLOT's avatar
Gael MILLOT committed
338
339
340
341
342
343
344
345
346
if(any(duplicated(categ.class.order[[i3]]))){
tempo.cat <- paste0("ERROR IN ", function.name, ": COMPARTMENT ", i3, " OF categ.class.order ARGUMENT CANNOT HAVE DUPLICATED CLASSES: ", paste(categ.class.order[[i3]], collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else if( ! (all(categ.class.order[[i3]] %in% unique(data1[, categ[i3]])) & all(unique(data1[, categ[i3]]) %in% categ.class.order[[i3]]))){
tempo.cat <- paste0("ERROR IN ", function.name, ": COMPARTMENT ", i3, " OF categ.class.order ARGUMENT MUST BE CLASSES OF ELEMENT ", i3, " OF categ ARGUMENT\nHERE IT IS:\n", paste(categ.class.order[[i3]], collapse = " "), "\nFOR COMPARTMENT ", i3, " OF categ.class.order AND IT IS:\n", paste(unique(data1[, categ[i3]]), collapse = " "), "\nFOR COLUMN ", categ[i3], " OF data1")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else{
data1[, categ[i3]] <- factor(data1[, categ[i3]], levels = categ.class.order[[i3]]) # reorder the factor

Gael  MILLOT's avatar
Gael MILLOT committed
347
348
349
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
350
351
352
353
354
355
}else{
tempo.warn <- paste0("THE categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR ", paste(categ, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
categ.class.order <- vector("list", length = length(categ))
for(i2 in 1:length(categ.class.order)){
categ.class.order[[i2]] <- levels(data1[, categ[i2]])
Gael  MILLOT's avatar
Gael MILLOT committed
356
357
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
358
359
360
361
362
# categ.class.order not NULL anymore
if(is.null(categ.legend.name)){
tempo.warn <- paste0("THE categ.legend.name SETTING IS NULL. NAMES OF categ WILL BE USED: ", paste(categ, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
categ.legend.name <- categ[length(categ)] # if only categ1, then legend name of categ1, if length(categ) == 2, then legend name of categ2
Gael  MILLOT's avatar
Gael MILLOT committed
363
}
Gael  MILLOT's avatar
Gael MILLOT committed
364
365
366
367
368
369
370
371
372
# categ.legend.name not NULL anymore
# management of categ.color
if( ! is.null(categ.color)){
# check the nature of color
# integer colors into gg_palette
tempo.check.color <- fun_check(data = categ.color, class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, fun.name = function.name, print = FALSE)$problem
if(tempo.check.color == FALSE){
# convert integers into colors
categ.color <- fun_gg_palette(max(categ.color, na.rm = TRUE))
Gael  MILLOT's avatar
Gael MILLOT committed
373
}
Gael  MILLOT's avatar
Gael MILLOT committed
374
375
376
377
# end integer colors into gg_palette
if( ! (all(categ.color %in% colors() | grepl(pattern = "^#", categ.color)))){ # check that all strings of low.color start by #
tempo.cat <- paste0("ERROR IN ", function.name, ": categ.color ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors(): ", paste(unique(categ.color), collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
378
}
Gael  MILLOT's avatar
Gael MILLOT committed
379
380
381
if(any(is.na(categ.color))){
tempo.warn <- paste0("categ.color ARGUMENT CONTAINS NA")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
382
}
Gael  MILLOT's avatar
Gael MILLOT committed
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
# end check the nature of color
# check the length of color
i0 <- length(categ) # if only categ1, then colors for classes of categ1, if length(categ) == 2, then colors for classes of categ2
if(length(categ.color) == length(levels(data1[, categ[i0]]))){ # here length(categ.color) is equal to the different number of categ
# data1[, categ[i0]] <- factor(data1[, categ[i0]]) # not required because sure that is is a factor
data1 <- data.frame(data1, categ.color = data1[, categ[i0]])
data1$categ.color <- factor(data1$categ.color, labels = categ.color)
tempo.warn <- paste0("IN ", categ[i0], " OF categ ARGUMENT, THE FOLLOWING COLORS:\n", paste(categ.color, collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[, categ[i0]])), collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else if(length(categ.color) == length(data1[, categ[i0]])){# here length(categ.color) is equal to nrow(data1) -> Modif to have length(categ.color) equal to the different number of categ (length(categ.color) == length(levels(data1[, categ[i0]])))
data1 <- data.frame(data1, categ.color = categ.color)
tempo.check <- unique(data1[ , c(categ[i0], "categ.color")])
if( ! (nrow(tempo.check) == length(unique(categ.color)) & nrow(tempo.check) == length(unique(data1[ , categ[i0]])))){
tempo.cat <- paste0("ERROR IN ", function.name, ": categ.color ARGUMENT HAS THE LENGTH OF data1 ROW NUMBER\nBUT IS INCORRECTLY ASSOCIATED TO EACH CLASS OF categ ", categ[i0], ":\n", paste(unique(mapply(FUN = "paste", data1[ ,categ[i0]], data1[ ,"categ.color"])), collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else{
# data1[, categ[i0]] <- factor(data1[, categ[i0]]) # not required because sure that is is a factor
categ.color <- unique(data1$categ.color[order(data1[, categ[i0]])]) # Modif to have length(categ.color) equal to the different number of categ (length(categ.color) == length(levels(data1[, categ[i0]])))
tempo.warn <- paste0("categ.color ARGUMENT HAS THE LENGTH OF data1 ROW NUMBER\nCOLORS HAVE BEEN RESPECTIVELY ASSOCIATED TO EACH CLASS OF categ ", categ[i0], " AS:\n", paste(levels(factor(data1[, categ[i0]])), collapse = " "), "\n", paste(categ.color, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
403
}
Gael  MILLOT's avatar
Gael MILLOT committed
404
405
406
407
408
409
}else if(length(categ.color) == 1){
# data1[, categ[i0]] <- factor(data1[, categ[i0]]) # not required because sure that is is a factor
data1 <- data.frame(data1, categ.color = categ.color)
categ.color <- rep(categ.color, length(levels(data1[, categ[i0]])))
tempo.warn <- paste0("categ.color ARGUMENT HAS LENGTH 1, MEANING THAT ALL THE DIFFERENT CLASSES OF ", categ[i0], "\n", paste(levels(factor(data1[, categ[i0]])), collapse = " "), "\nWILL HAVE THE SAME COLOR\n", paste(categ.color, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
410
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
411
412
tempo.cat <- paste0("ERROR IN ", function.name, ": categ.color ARGUMENT MUST BE (1) LENGTH 1, OR (2) THE LENGTH OF data1 NROWS, OR (3) THE LENGTH OF THE CLASSES IN THE categ ", categ[i0], " COLUMN. HERE IT IS COLOR LENGTH ", length(categ.color), " VERSUS CATEG LENGTH ", length(data1[, categ[i0]]), " AND CATEG CLASS LENGTH ", length(unique(data1[, categ[i0]])), "\nPRESENCE OF NA COULD BE THE PROBLEM")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
413
}
Gael  MILLOT's avatar
Gael MILLOT committed
414
415
416
417
418
419
420
421
}else{
i0 <- length(categ) # if only categ1, then colors for classes of categ1, if length(categ) == 2, then colors for classes of categ2
# data1[, categ[i0]] <- factor(data1[, categ[i0]]) # not required because sure that is is a factor
categ.color <- fun_gg_palette(length(levels(data1[, categ[i0]])))
data1 <- data.frame(data1, categ.color = data1[, categ[i0]])
data1$categ.color <- factor(data1$categ.color, labels = categ.color)
tempo.warn <- paste0("NULL categ.color ARGUMENT -> COLORS RESPECTIVELY ATTRIBUTED TO EACH CLASS OF ", categ[i0], " IN data1:\n", paste(categ.color, collapse = " "), "\n", paste(levels(data1[, categ[i0]]), collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
422
}
Gael  MILLOT's avatar
Gael MILLOT committed
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
# categ.color not NULL anymore
categ.color <- as.character(categ.color)
# categ.color is a character string representing the diff classes
data1$categ.color <- factor(data1$categ.color, levels = unique(categ.color)) # ok because if categ.color is a character string, the order make class 1, class 2, etc. unique() because no duplicates allowed
# data1$categ.color is a factor with order of levels -> categ.color
# end management of categ.color
# management of dot.color
if( ! is.null(dot.color)){
# optional legend of dot colors
if( ! is.null(dot.categ)){
if( ! all(dot.categ %in% names(data1))){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.categ ARGUMENT MUST BE A COLUMN NAME OF data1. HERE IT IS:\n", dot.categ)
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else if(all(dot.categ %in% categ)){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.categ ARGUMENT CANNOT BE A COLUMN NAME OF data1 ALREADY SPECIFIED IN THE categ ARGUMENT:\n", dot.categ)
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}
tempo1 <- fun_check(data = data1[, dot.categ], data.name = paste0(dot.categ, " COLUMN OF data1"), class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name, print = FALSE)
tempo2 <- fun_check(data =  data1[, dot.categ], data.name = paste0(dot.categ, " COLUMN OF data1"), class = "factor", na.contain = TRUE, fun.name = function.name, print = FALSE)
if(tempo1$problem == TRUE & tempo2$problem == TRUE){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.categ COLUMN MUST BE A FACTOR OR CHARACTER VECTOR") #
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
445
}
Gael  MILLOT's avatar
Gael MILLOT committed
446
447
448
449
450
451
452
453
454
data1[, dot.categ] <- factor(data1[, dot.categ]) # if already a factor, change nothing, if characters, levels according to alphabetical order
# dot.categ column of data1 is factor from here
if( ! is.null(dot.categ.class.order)){
if(any(duplicated(dot.categ.class.order))){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.categ.class.order ARGUMENT CANNOT HAVE DUPLICATED CLASSES: ", paste(dot.categ.class.order, collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
}else if( ! (all(dot.categ.class.order %in% levels(data1[, dot.categ])) & all(levels(data1[, dot.categ]) %in% dot.categ.class.order))){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.categ.class.order ARGUMENT MUST BE CLASSES OF dot.categ ARGUMENT\nHERE IT IS:\n", paste(dot.categ.class.order, collapse = " "), "\nFOR dot.categ.class.order AND IT IS:\n", paste(levels(data1[, dot.categ]), collapse = " "), "\nFOR dot.categ COLUMN (", dot.categ, ") OF data1")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
455
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
456
data1[, dot.categ] <- factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor
Gael  MILLOT's avatar
Gael MILLOT committed
457
}
Gael  MILLOT's avatar
Gael MILLOT committed
458
459
460
461
}else{
dot.categ.class.order <- levels(data1[, dot.categ])
tempo.warn <- paste0("THE dot.categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR LEGEND DISPLAY:", paste(dot.categ.class.order, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
462
}
Gael  MILLOT's avatar
Gael MILLOT committed
463
464
465
466
467
# dot.categ.class.order not NULL anymore
if(is.null(dot.categ.legend.name)){
dot.categ.legend.name <- dot.categ #
tempo.warn <- paste0("THE dot.categ.legend.name SETTING IS NULL. VALUES OF dot.categ WILL BE USED: ", paste(dot.categ, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
468
}
Gael  MILLOT's avatar
Gael MILLOT committed
469
# dot.categ.legend.name not NULL anymore
Gael  MILLOT's avatar
Gael MILLOT committed
470
}
Gael  MILLOT's avatar
Gael MILLOT committed
471
472
473
474
475
476
477
# end optional legend of dot colors
# check the nature of color
# integer colors into gg_palette
tempo.check.color <- fun_check(data = dot.color, class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, fun.name = function.name, print = FALSE)$problem
if(tempo.check.color == FALSE){
# convert integers into colors
dot.color <- fun_gg_palette(max(dot.color, na.rm = TRUE))
Gael  MILLOT's avatar
Gael MILLOT committed
478
}
Gael  MILLOT's avatar
Gael MILLOT committed
479
480
481
482
483
484
485
486
# end integer colors into gg_palette
if(all(dot.color == "same") & length(dot.color) == 1){
dot.color <- categ.color # same color of the dots as the corresponding box color
tempo.warn <- paste0("dot.color ARGUMENT HAS BEEN SET TO \"SAME\"\nTHUS, DOT COLORS HAVE BEEN RESPECTIVELY ASSOCIATED TO EACH CLASS OF categ ", categ[i0], " AS:\n", paste(levels(factor(data1[, categ[i0]])), collapse = " "), "\n", paste(dot.color, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else if( ! (all(dot.color %in% colors() | grepl(pattern = "^#", dot.color)))){ # check that all strings of low.color start by #
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.color ARGUMENT MUST BE (1) A HEXADECIMAL COLOR VECTOR STARTING BY #, OR (2) COLOR NAMES GIVEN BY colors(), OR (3) INTEGERS, OR THE STRING\"same\"\nHERE IT IS: ", paste(unique(dot.color), collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
487
}
Gael  MILLOT's avatar
Gael MILLOT committed
488
489
490
if(any(is.na(dot.color))){
tempo.warn <- paste0("dot.color ARGUMENT CONTAINS NA")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
491
}
Gael  MILLOT's avatar
Gael MILLOT committed
492
493
494
495
496
497
498
# end check the nature of color
# check the length of color
if( ! is.null(dot.categ)){
# optional legend of dot colors
if(length(unique(data1[, dot.categ])) != length(dot.color)){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.color ARGUMENT IS NOT THE SAME LENGTH AS LEVELS OF dot.categ (", dot.categ, ") COLUMN:\ndot.color: ", paste(dot.color, collapse = " "), "\ndot.categ LEVELS: ", paste(levels(data1$dot.categ), collapse = " "))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
499
}
Gael  MILLOT's avatar
Gael MILLOT committed
500
501
502
503
504
505
506
data1 <- data.frame(data1, dot.color = data1[, dot.categ])
data1$dot.color <- factor(data1$dot.color, labels = dot.color)
dot.color <- as.character(unique(data1$dot.color[order(data1[, dot.categ])])) # reorder the dot.color character vector
tempo.check <- unique(data1[ , c(dot.categ, "dot.color")])
if(( ! (nrow(tempo.check) == length(unique(data1[ , "dot.color"])) & nrow(tempo.check) == length(unique(data1[ , dot.categ]))))){
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.color ARGUMENT IS INCORRECTLY ASSOCIATED TO EACH CLASS OF dot.categ (", dot.categ, ") COLUMN:\n", paste(unique(mapply(FUN = "paste", data1[ , dot.categ], data1[ ,"dot.color"])), collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
507
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
508
509
tempo.warn <- paste0("IN dot.categ ARGUMENT (", dot.categ, "), THE FOLLOWING COLORS:\n", paste(dot.color, collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(data1[, dot.categ]), collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
510
}
Gael  MILLOT's avatar
Gael MILLOT committed
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
# dot.color is a character string representing the diff classes of dot.categ
# data1$dot.color is a factor with order of levels -> dot.categ
# end optional legend of dot colors
}else{
i0 <- length(categ) # if only categ1, then colors for classes of categ1, if length(categ) == 2, then colors for classes of categ2
if(length(dot.color) == length(levels(data1[, categ[i0]]))){ # here length(dot.color) is equal to the different number of categ
# data1[, categ[i0]] <- factor(data1[, categ[i0]]) # not required because sure that is is a factor
data1 <- data.frame(data1, dot.color = data1[, categ[i0]])
data1$dot.color <- factor(data1$dot.color, labels = dot.color)
tempo.warn <- paste0("IN ", categ[i0], " OF categ ARGUMENT, THE FOLLOWING COLORS:\n", paste(dot.color, collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[, categ[i0]])), collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else if(length(dot.color) == length(data1[, categ[i0]])){# here length(dot.color) is equal to nrow(data1) -> Modif to have length(dot.color) equal to the different number of categ (length(dot.color) == length(levels(data1[, categ[i0]])))
data1 <- data.frame(data1, dot.color = dot.color)
}else if(length(dot.color) == 1 & ! all(dot.color == "same")){
# data1[, categ[i0]] <- factor(data1[, categ[i0]]) # not required because sure that is is a factor
data1 <- data.frame(data1, dot.color = dot.color)
dot.color <- rep(dot.color, length(levels(data1[, categ[i0]])))
tempo.warn <- paste0("dot.color ARGUMENT HAS LENGTH 1, MEANING THAT ALL THE DIFFERENT CLASSES OF ", categ[i0], "\n", paste(levels(factor(data1[, categ[i0]])), collapse = " "), "\nWILL HAVE THE SAME COLOR\n", paste(dot.color, collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
}else{
tempo.cat <- paste0("ERROR IN ", function.name, ": dot.color ARGUMENT MUST BE (1) LENGTH 1, OR (2) THE LENGTH OF data1 NROWS, OR (3) THE LENGTH OF THE CLASSES IN THE categ ", categ[i0], " COLUMN. HERE IT IS COLOR LENGTH ", length(dot.color), " VERSUS CATEG LENGTH ", length(data1[, categ[i0]]), " AND CATEG CLASS LENGTH ", length(unique(data1[, categ[i0]])), "\nPRESENCE OF NA COULD BE THE PROBLEM")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
533
}
Gael  MILLOT's avatar
Gael MILLOT committed
534
535
536
537
538
# end check the length of color
dot.color <- as.character(dot.color)
# dot.color is a character string representing the diff classes
data1$dot.color <- factor(data1$dot.color, levels = unique(dot.color)) # ok because if dot.color is a character string, the order make class 1, class 2, etc. If dot.color is a column of data1, then levels will be created, without incidence, except if dot.categ specified (see below). unique() because no duplicates allowed
# data1$dot.color is a factor with order of levels -> dot.color
Gael  MILLOT's avatar
Gael MILLOT committed
539
}
Gael  MILLOT's avatar
Gael MILLOT committed
540
541
542
543
# end optional legend of dot colors
}else if(is.null(dot.color) & ! (is.null(dot.categ) & is.null(dot.categ.class.order) & is.null(dot.categ.legend.name))){
tempo.warn <- paste0("dot.categ OR dot.categ.class.order OR dot.categ.legend.name ARGUMENT HAS BEEN SPECIFIED BUT dot.color ARGUMENT IS NULL (NO DOT PLOTTED)")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
544
}
Gael  MILLOT's avatar
Gael MILLOT committed
545
546
547
548
549
550
# dot.color either NULL (no dot plotted) or character string (potentially representing the diff classes of dot.categ)
# data1$dot.color is either NA or a factor (with order of levels -> depending on dot.categ or categ[length(categ)], or other
# end management of dot.color
if(is.null(dot.color) & box.fill == FALSE & dot.alpha <= 0.025){
tempo.warn <- paste0("THE FOLLOWING ARGUMENTS WERE SET AS:\ndot.color = NULL (NOT ALL DOTS BUT ONLY POTENTIAL OUTLIER DOTS DISPLAYED)\nbox.fill = FALSE (NO FILLING COLOR FOR BOTH BOXES AND POTENTIAL OUTLIER DOTS)\ndot.alpha = ", fun_round(dot.alpha, 4), "\n-> POTENTIAL OUTLIER DOTS MIGHT NOT BE VISIBLE BECAUSE ALMOST TRANSPARENT")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
551
}
Gael  MILLOT's avatar
Gael MILLOT committed
552
553
554
if(is.null(dot.color) & box.fill == FALSE & dot.border.size == 0){
tempo.cat <- paste0("ERROR IN ", function.name, ": THE FOLLOWING ARGUMENTS WERE SET AS:\ndot.color = NULL (NOT ALL DOTS BUT ONLY POTENTIAL OUTLIER DOTS DISPLAYED)\nbox.fill = FALSE (NO FILLING COLOR FOR BOTH BOXES AND POTENTIAL OUTLIER DOTS)\ndot.border.size = 0 (NO BORDER FOR POTENTIAL OUTLIER DOTS)\n-> THESE SETTINGS ARE NOT ALLOWED BECAUSE THE POTENTIAL OUTLIER DOTS WILL NOT BE VISIBLE")
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
555
}
Gael  MILLOT's avatar
Gael MILLOT committed
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
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]
}
# end integer colors into gg_palette
}
if(y.log != "no"){
tempo.warn <- paste0("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)){
tempo.warn <- paste0("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
577
578
579
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
580
581
582
583
584
585
586
587
588
# inactivated because y must already be log transformed data
# if(y.log != "no" & y.include.zero == TRUE){
# tempo.warn <- paste0("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
tempo.warn <- paste0("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
589
}
Gael  MILLOT's avatar
Gael MILLOT committed
590
# end second round of checking and data preparation
Gael  MILLOT's avatar
Gael MILLOT committed
591
592


Gael  MILLOT's avatar
Gael MILLOT committed
593
594
595
596
# 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
Gael  MILLOT's avatar
Gael MILLOT committed
597
598
599
600
# main code



Gael  MILLOT's avatar
Gael MILLOT committed
601
602
603
604
605
606
607
608
609
# 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]))){
tempo.warn <- paste0("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]]))){
tempo.warn <- paste0("COLUMN ", column.check[i2], " OF data1 CONTAINS NA")
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
610
611
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
612
613
614
615
616
617
618
619
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){
for(i3 in 1:length(column.check)){
if(any( ! unique(removed.rows[, column.check[i1]]) %in% unique(data1[, column.check[i3]]))){
tempo.warn <- paste0("IN COLUMN ", column.check[i3], " OF data1, THE FOLLOWING CLASSES HAVE BEEN LOST DUE TO NA REMOVAL IN data1:\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
620
621
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
622
data1 <- data1[-removed.row.nb, ]
Gael  MILLOT's avatar
Gael MILLOT committed
623
}
Gael  MILLOT's avatar
Gael MILLOT committed
624
625
626
627
628
629
630
631
632
633
for(i2 in 1:length(column.check)){
if(any( ! levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]]))){
tempo.warn <- paste0("IN COLUMN ", column.check[i2], " OF data1, , THE FOLLOWING LEVELS ARE NOT REPRESENTED IN THE COLUMN:\n", paste(levels(data1[, column.check[i2]])[ ! levels(data1[,  column.check[i2]]) %in% unique(data1[, column.check[i2]])], collapse = " "))
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
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
data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(categ.color))
}else 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
data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.color))
Gael  MILLOT's avatar
Gael MILLOT committed
634
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
635
data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = levels(data1[, column.check[i2]])[levels(data1[,  column.check[i2]]) %in% unique(data1[, column.check[i2]])])
Gael  MILLOT's avatar
Gael MILLOT committed
636
637
638
639
}
}
}
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
640
641
removed.row.nb <- NULL
removed.rows <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
642
}
Gael  MILLOT's avatar
Gael MILLOT committed
643
# end na detection and removal (done now to be sure of the correct length of categ)
Gael  MILLOT's avatar
Gael MILLOT committed
644
645


Gael  MILLOT's avatar
Gael MILLOT committed
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
# 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(categ.color))}else{as.character(dot.color)})) # rep(NA, length(categ.color)) used because dot.color is NULL
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 = as.character(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]
Gael  MILLOT's avatar
Gael MILLOT committed
679
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
680
681
682
683
684
685
686
687
688
689
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
690
}
Gael  MILLOT's avatar
Gael MILLOT committed
691
692
693
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)
Gael  MILLOT's avatar
Gael MILLOT committed
694
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
695
696
697
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)
Gael  MILLOT's avatar
Gael MILLOT committed
698
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
699
tempo.mean <- data.frame(tempo.mean[order(tempo.mean$BOX), ], unique(dot.coord[order(dot.coord$group), categ[1], drop = FALSE]))
Gael  MILLOT's avatar
Gael MILLOT committed
700
701
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
# }
# 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(categ.color))}else{as.character(dot.color)})) # rep(NA, length(categ.color)) used because dot.color is NULL
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 = as.character(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]
Gael  MILLOT's avatar
Gael MILLOT committed
738
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
739
740
741
742
743
744
745
746
747
748
749
750
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
751
}
Gael  MILLOT's avatar
Gael MILLOT committed
752
753
754
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
755
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
756
757
758
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)
Gael  MILLOT's avatar
Gael MILLOT committed
759
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
760
tempo.mean <- data.frame(tempo.mean[order(tempo.mean$BOX), ], unique(dot.coord[order(dot.coord$group), c(categ[1], categ[2])]))
Gael  MILLOT's avatar
Gael MILLOT committed
761
762
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
763
# }
Gael  MILLOT's avatar
Gael MILLOT committed
764
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
765
766
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
767
}
Gael  MILLOT's avatar
Gael MILLOT committed
768
769
# 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)
Gael  MILLOT's avatar
Gael MILLOT committed
770
771


Gael  MILLOT's avatar
Gael MILLOT committed
772
773


Gael  MILLOT's avatar
Gael MILLOT committed
774

Gael  MILLOT's avatar
Gael MILLOT committed
775
776
777



Gael  MILLOT's avatar
Gael MILLOT committed
778

Gael  MILLOT's avatar
Gael MILLOT committed
779
780


Gael  MILLOT's avatar
Gael MILLOT committed
781
782


Gael  MILLOT's avatar
Gael MILLOT committed
783
784
785
786
787
788
789
790
# 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)
Gael  MILLOT's avatar
Gael MILLOT committed
791
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
792
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
793
}
Gael  MILLOT's avatar
Gael MILLOT committed
794
# end stat output (will also serve for boxplot and mean display)
Gael  MILLOT's avatar
Gael MILLOT committed
795
796


Gael  MILLOT's avatar
Gael MILLOT committed
797
798


Gael  MILLOT's avatar
Gael MILLOT committed
799
800
801



Gael  MILLOT's avatar
Gael MILLOT committed
802
803
804
805
806
807

# ylim range
if(is.null(y.lim)){
if(any(data1[, y] %in% c(Inf, -Inf))){
tempo.warn <- paste0("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
808
}
Gael  MILLOT's avatar
Gael MILLOT committed
809
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
810
}
Gael  MILLOT's avatar
Gael MILLOT committed
811
812
813
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
814
}
Gael  MILLOT's avatar
Gael MILLOT committed
815
816
817
818
819
820
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
821
}
Gael  MILLOT's avatar
Gael MILLOT committed
822
823
824
825
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
826
}
Gael  MILLOT's avatar
Gael MILLOT committed
827
# end ylim range
Gael  MILLOT's avatar
Gael MILLOT committed
828
829
830
831




Gael  MILLOT's avatar
Gael MILLOT committed
832
833


Gael  MILLOT's avatar
Gael MILLOT committed
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
# 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){
tempo.warn <- paste0("\"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")
Gael  MILLOT's avatar
Gael MILLOT committed
849
warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
Gael  MILLOT's avatar
Gael MILLOT committed
850
add.check <- FALSE
Gael  MILLOT's avatar
Gael MILLOT committed
851
852
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
if(add.check == TRUE & classic == TRUE){
# BEWARE: not possible to add several times theme(). NO message but the last one overwrites the others
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_classic(base_size = text.size))
if(grid == TRUE){
assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
text = ggplot2::element_text(size = text.size), 
plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
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)}
))
Gael  MILLOT's avatar
Gael MILLOT committed
868
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
869
870
871
872
873
874
875
876
877
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
878
}
Gael  MILLOT's avatar
Gael MILLOT committed
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
}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
895
}
Gael  MILLOT's avatar
Gael MILLOT committed
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
# 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




# 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 = as.character(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)
Gael  MILLOT's avatar
Gael MILLOT committed
913
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
914
915
916
917
box.coord <- data.frame(box.coord, tempo.mean)
tempo.warn <- paste0("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
918
919
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
# 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){
tempo.warn <- paste0("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
943
944
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
945
946
947
948
949
950
951
952
953
954
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
955
}
Gael  MILLOT's avatar
Gael MILLOT committed
956
957
958
959
960
961
962
963
964
965
966
967
968
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
969
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
970
971
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
972
}
Gael  MILLOT's avatar
Gael MILLOT committed
973
974
975
976
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
977
}
Gael  MILLOT's avatar
Gael MILLOT committed
978
# end random dots
Gael  MILLOT's avatar
Gael MILLOT committed
979
}
Gael  MILLOT's avatar
Gael MILLOT committed
980
981
982
# tidy dots
# coordinates are recover during plotting (see dot.coord.tidy1 below)
# end tidy dots
Gael  MILLOT's avatar
Gael MILLOT committed
983
}
Gael  MILLOT's avatar
Gael MILLOT committed
984
985
986
987
988
989
990
991
992
993
994
995
996
# end x coordinates management (for random plotting and for stat display)





# 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(i2 in 1:length(categ)){
if(i2 == 1){
tempo.polygon <- data.frame(GROUPX = c(t(stat[, c(categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
997
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
998
tempo.polygon <- cbind(tempo.polygon, c(t(stat[, c(categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
999
1000
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
1001
1002
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)
Gael  MILLOT's avatar
Gael MILLOT committed
1003
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
1004
1005
1006
1007
1008
for(i2 in 1:length(