diff --git a/examples_alone.txt b/all_wo_gg_examples - Copie.R similarity index 100% rename from examples_alone.txt rename to all_wo_gg_examples - Copie.R diff --git a/boxplot.docx b/boxplot.docx deleted file mode 100644 index aadefd289ea35c656dc4fd554d0d4307f22b418c..0000000000000000000000000000000000000000 Binary files a/boxplot.docx and /dev/null differ diff --git a/boxplot_examples.R b/boxplot_examples.R new file mode 100644 index 0000000000000000000000000000000000000000..bf7e72b89091341e5919d03f6c920f38533f2b57 --- /dev/null +++ b/boxplot_examples.R @@ -0,0 +1,112 @@ +# EXAMPLES +### nice representation (1) +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A")), categ.legend.name = "LEGEND", categ.color = NULL, box.width = 0.3, whisker.width = 0.8, dot.color = "same", dot.jitter = 0.5, dot.size = 3.5, dot.border.size = 0.2, dot.alpha = 0.5, ylim = c(10, 25), y.include.zero = TRUE, stat.disp = "above", stat.size = 4, xlab = "GROUP", ylab = "VALUE", text.size = 12, title = "GRAPH1", title.text.size = 8, text.angle = 0, classic = TRUE, grid = TRUE) +### nice representation (2) +set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(24, 0), rnorm(24, -10), rnorm(24, 10), rnorm(24, 20)), Group1 = rep(c("CAT", "DOG"), times = 48), Group2 = rep(c("A", "B", "C", "D"), each = 24)) ; set.seed(NULL) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A", "D", "C")), categ.legend.name = "LEGEND", categ.color = NULL, box.width = 0.8, dot.color = "grey50", dot.tidy = TRUE, dot.bin.nb = 60, dot.size = 3.5, dot.border.size = 0.2, dot.alpha = 0.5, ylim= c(-20, 30), stat.disp = "above", stat.size = 4, stat.dist = 1, xlab = "GROUP", ylab = "VALUE", vertical = FALSE, text.size = 12, title = "GRAPH1", title.text.size = 8, text.angle = 45, classic = FALSE) +### separate boxes. Simple example +set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; +fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1") +### separate boxes. Changing the order of the boxes +fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", categ.class.order = list(c("H", "G"))) +### separate boxs. Example (1) of modification of box color using a single value +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", categ.color = "white") +### separate boxs. Example (2) of modification of box color using one value par class of categ2 +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", categ.color = c("coral", "lightblue")) +### separate boxs. Example (3) of modification of box color using the box.color data frame column, with respect of the correspondence between categ2 and box.color columns +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), box.color = rep(c("coral", "lightblue"), time = 10)) ; obs1 ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", categ.color = obs1$box.color) +### separate boxs. Example (1) of modification of dot color, using the same dot color as the corresponding box +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", dot.color = "same") +### separate boxs. Example (2) of modification of dot color, using a single color for all the dots +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", dot.color = "green") +### separate boxs. Example (3) of modification of dot color, using one value par class of categ2 +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", dot.color = c("green", "brown")) +### separate boxs. Example (4) of modification of dot color, using different colors for each dot +obs1 <- data.frame(Time = 1:10, Group1 = rep(c("G", "H"), times = 5)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", dot.color = hsv(h = (1:nrow(obs1)) / nrow(obs1))) +### grouped boxs. Simple example +set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(20), rnorm(20) + 2), Group1 = rep(c("G", "H"), each = 10), Group2 = rep(c("A", "B"), time = 10)) ; +fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2")) +### grouped boxs. More grouped boxs +obs1 <- data.frame(Time = 1:24, Group1 = rep(c("G", "H"), times = 12), Group2 = rep(c("A", "B", "C", "D"), each = 6)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2")) +### grouped boxs. Example (1) of modification of box color, using a single value +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = "white") +### grouped boxs. Example (2) of modification of box color, using one value par class of categ2 +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = c("coral", "lightblue")) +### grouped boxs. Example (3) of modification of box color, using one value per line of obs1, with respect of the correspondence between categ2 and box.color columns +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10), box.color = rep(c("coral", "lightblue"), each = 10)) ; obs1 ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = obs1$box.color) +### grouped boxs. Example (1) of modification of dot color, using the same dot color as the corresponding box +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same") +### grouped boxs. Example (2) of modification of dot color, using a single color for all the dots +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "green") +### grouped boxs. Example (3) of modification of dot color, using one value par class of categ2 +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = c("green", "brown")) +### grouped boxs. Example (4) of modification of dot color, using different colors for each dot +obs1 <- data.frame(Time = 1:10, Group1 = rep(c("G", "H"), times = 5), Group2 = rep(c("A", "B"), each = 5)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = hsv(h = (1:nrow(obs1)) / nrow(obs1))) +### no dots (y.include.zero set to TRUE to see the lowest box): +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE) +### box width. Example (1) with box.width = 0.25 -> three times more space between single boxs than the box width (y.include.zero set to TRUE to see the lowest box) +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), each = 500)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", dot.color = NULL, y.include.zero = TRUE, box.width = 0.25) +### box width. Example (2) with box.width = 1, no space between single boxs +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), each = 500)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1", dot.color = NULL, y.include.zero = TRUE, box.width = 1) +### box width. Example (3) with box.width = 0.25 -> three times more space between sets of grouped boxs than the set width +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE, box.width = 0.25) +### box width. Example (4) with box.width = 0 -> no space between sets of grouped boxs +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE, box.width = 1) +### whisker width. Example (1) with whisker.width = 1 -> whiskers have the width of the corresponding box +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, whisker.width = 1) +### whisker width. Example (2) error boxs with no whiskers +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, whisker.width = 0) +### tidy dot distribution. Example (1) +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = TRUE, dot.bin.nb = 100) +### tidy dot distribution. Example (2) reducing the dot size with dot.bin.nb +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = TRUE, dot.bin.nb = 150) +### dot jitter. Example (1) +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = FALSE, dot.jitter = 1, dot.size = 2) +### dot jitter. Example (2) with dot.jitter = 1 -> dispersion around the corresponding box width +obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 3, dot.alpha = 1, dot.jitter = 1) +### dot jitter. Example (3) with no dispersion +obs1 <- data.frame(Time = 1:100, Group1 = rep(c("G", "H"), times = 50), Group2 = rep(LETTERS[1:5], each = 20)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 3, dot.alpha = 1, dot.jitter = 0) +### dot size, dot border size and dot transparency +obs1 <- data.frame(Time = 1:100, Group1 = rep(c("G", "H"), times = 50), Group2 = rep(LETTERS[1:5], each = 20)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 4, dot.border.size = 0, dot.alpha = 0.6) +### y-axis limits. Example (1) +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylim = c(-1, 25)) +### y-axis limits. Example (2) showing that order matters in ylim argument +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylim = c(25, -1)) +### log scale. Example (1). BEWARE: y column must be log, otherwise incoherent scale (see below warning message with the return argument) +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10") +### log scale. Example (2). BEWARE: values of the ylim must be in the corresponding log +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", ylim = c(1,4)) +### tick number. Example (1) +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.tick.nb = 10) +### tick number. Example (2) using a log2 scale +obs1 <- data.frame(Time = log2((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log2", y.tick.nb = 10, ylim = c(1, 16)) +### tick number. Example (3) using a log10 scale +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.tick.nb = 10) +### tick number. Example (4) using a log10 scale: the reverse y-axis correctly deal with log10 scale +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.tick.nb = 10, ylim = c(4, 1)) +### secondary tick number. Example (1) +obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.inter.tick.nb = 2) +### secondary ticks. Example (2) not for log2 and log10 scales (see below warning message with the return argument) +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.inter.tick.nb = 2) +### include zero in the y-axis +obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.include.zero = TRUE) +### extra margins. To avoid dot cuts +obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.25, y.bottom.extra.margin = 0.25) +### mean diplay. Example (1) at the top of the plot region +obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.1, stat.disp = "top", stat.size = 4, stat.dist = 2) +### mean diplay. Example (2) above boxs +obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.1, stat.disp = "above", stat.size = 4, stat.dist = 2) +### box orientation. Example (1) without log scale, showing that the other arguments are still operational +obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.tick.nb = 10, y.inter.tick.nb = 2, y.include.zero = TRUE, vertical = FALSE) +### box orientation. Example (2) with log scale. Horizontal orientation is blocked with log2 and log10 scales because of a bug in ggplot2 (https://github.com/tidyverse/ggplot2/issues/881) +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", vertical = FALSE) +### classic representation (use grid = TRUE to display the background lines of the y axis ticks) +obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), classic = TRUE, grid = FALSE) +### graphic info. Example (1) +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), return = TRUE) +### graphic info. Example (2) of assignation and warning message display +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; warn <- fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", return = TRUE) ; cat(warn$warnings) +### add ggplot2 functions +obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), add = "+ggplot2::theme_classic()") +### all the arguments +obs1 <- data.frame(x = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "x", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A")), categ.legend.name = "", categ.color = c("red", "blue"), box.width = 0.25, whisker.width = 0.8, dot.color = "grey", dot.tidy = FALSE, dot.bin.nb = 30, dot.jitter = 1, dot.size = 4, dot.border.size = 0, dot.alpha = 1, ylim = c(0, 25), ylog = "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, stat.disp = "above", stat.size = 4, stat.dist = 2, xlab = "GROUP", ylab = "VALUE", vertical = FALSE, text.size = 12, title = "", title.text.size = 8, text.angle = 45, classic = TRUE, grid = TRUE, return = TRUE, plot = TRUE, add = NULL, warn.print = TRUE, lib.path = NULL) + diff --git a/boxplot_examples.docx b/boxplot_examples.docx deleted file mode 100644 index ae0c6955213e723cde4fdeed5cb058a8be1dba95..0000000000000000000000000000000000000000 Binary files a/boxplot_examples.docx and /dev/null differ diff --git a/cute_little_R_functions.R b/cute_little_R_functions.R index f843e4732bde10f91cad72505d65272fecf10842..675e2bb8949692abc9885e1c703d180a73a1dd9a 100644 --- a/cute_little_R_functions.R +++ b/cute_little_R_functions.R @@ -29,58 +29,57 @@ ################################ OUTLINE ################################ -################ Object analysis 2 -######## fun_check() #### check class, type, length, etc., of objects 2 -######## fun_info() #### recover object information 8 -######## fun_head() #### head of the left or right of big 2D objects 10 -######## fun_tail() #### tail of the left or right of big 2D objects 11 -######## fun_comp_1d() #### comparison of two 1D datasets (vectors, factors, 1D tables) 13 -######## fun_comp_2d() #### comparison of two 2D datasets (row & col names, dimensions, etc.) 17 -######## fun_comp_list() #### comparison of two lists 23 -######## fun_test() #### test combinations of argument values of a function 25 -################ Object modification 28 -######## fun_name_change() #### check a vector of character strings and modify any string if present in another vector 28 -######## fun_df_remod() #### remodeling a data frame to have column name as a qualitative values and vice-versa 29 -######## fun_merge() #### merge the columns of two 2D objects, by common rows 32 -######## fun_round() #### rounding number if decimal present 36 -######## fun_mat_rotate() #### 90° clockwise matrix rotation 38 -######## fun_mat_num2color() #### convert a numeric matrix into hexadecimal color matrix 39 -######## fun_mat_op() #### assemble several matrices with operation 42 -######## fun_mat_inv() #### return the inverse of a square matrix 44 -######## fun_mat_fill() #### fill the empty half part of a symmetric square matrix 45 -######## fun_permut() #### progressively breaks a vector order 49 -################ Graphics management 59 -######## fun_width() #### window width depending on classes to plot 59 -######## fun_open() #### open a GUI or pdf graphic window 61 -######## fun_prior_plot() #### set graph param before plotting (erase axes for instance) 64 -######## fun_scale() #### select nice label numbers when setting number of ticks on an axis 68 -######## fun_post_plot() #### set graph param after plotting (axes redesign for instance) 73 -######## fun_close() #### close specific graphic windows 84 -################ Standard graphics 85 -######## fun_empty_graph() #### text to display for empty graphs 86 -################ gg graphics 87 -######## fun_gg_palette() #### ggplot2 default color palette 87 -######## fun_gg_just() #### ggplot2 justification of the axis labeling, depending on angle 89 -######## fun_gg_point_rast() #### ggplot2 raster scatterplot layer 91 -######## fun_gg_scatter() #### ggplot2 scatterplot + lines (up to 6 overlays totally) 94 -######## fun_gg_bar() #### ggplot2 mean barplot + overlaid dots if required 130 -######## fun_gg_boxplot() #### ggplot2 boxplot + background dots if required 165 -######## fun_gg_prop() #### ggplot2 proportion barplot 165 -######## fun_gg_strip() #### ggplot2 stripchart + mean/median 165 -######## fun_gg_dot() #### ggplot2 categorial dotplot + mean/median 165 -######## fun_gg_violin() #### ggplot2 violins 165 -######## fun_gg_line() #### ggplot2 lines + background dots and error bars 165 -######## fun_gg_heatmap() #### ggplot2 heatmap + overlaid mask if required 168 -######## fun_gg_empty_graph() #### text to display for empty graphs 181 -################ Graphic extraction 183 -######## fun_trim() #### display values from a quantitative variable and trim according to defined cut-offs 183 -######## fun_segmentation() #### segment a dot cloud on a scatterplot and define the dots from another cloud outside the segmentation 191 -################ Import 223 -######## fun_pack() #### check if R packages are present and import into the working environment 223 -######## fun_python_pack() #### check if python packages are present 225 -################ Print / Exporting results (text & tables) 227 -######## fun_report() #### print string or data object into output file 227 -######## fun_get_message() #### return messages of an expression (that can be exported) 230 +################ Object analysis 2 +######## fun_check() #### check class, type, length, etc., of objects 2 +######## fun_info() #### recover object information 8 +######## fun_head() #### head of the left or right of big 2D objects 10 +######## fun_tail() #### tail of the left or right of big 2D objects 11 +######## fun_comp_1d() #### comparison of two 1D datasets (vectors, factors, 1D tables) 13 +######## fun_comp_2d() #### comparison of two 2D datasets (row & col names, dimensions, etc.) 17 +######## fun_comp_list() #### comparison of two lists 23 +######## fun_test() #### test combinations of argument values of a function 25 +################ Object modification 35 +######## fun_name_change() #### check a vector of character strings and modify any string if present in another vector 35 +######## fun_df_remod() #### remodeling a data frame to have column name as a qualitative values and vice-versa 37 +######## fun_merge() #### merge the columns of two 2D objects, by common rows 40 +######## fun_round() #### rounding number if decimal present 44 +######## fun_mat_rotate() #### 90° clockwise matrix rotation 46 +######## fun_mat_num2color() #### convert a numeric matrix into hexadecimal color matrix 47 +######## fun_mat_op() #### assemble several matrices with operation 50 +######## fun_mat_inv() #### return the inverse of a square matrix 52 +######## fun_mat_fill() #### fill the empty half part of a symmetric square matrix 53 +######## fun_permut() #### progressively breaks a vector order 57 +################ Graphics management 67 +######## fun_width() #### window width depending on classes to plot 67 +######## fun_open() #### open a GUI or pdf graphic window 69 +######## fun_prior_plot() #### set graph param before plotting (erase axes for instance) 72 +######## fun_scale() #### select nice label numbers when setting number of ticks on an axis 76 +######## fun_post_plot() #### set graph param after plotting (axes redesign for instance) 81 +######## fun_close() #### close specific graphic windows 92 +################ Standard graphics 94 +######## fun_empty_graph() #### text to display for empty graphs 94 +################ gg graphics 96 +######## fun_gg_palette() #### ggplot2 default color palette 96 +######## fun_gg_just() #### ggplot2 justification of the axis labeling, depending on angle 97 +######## fun_gg_point_rast() #### ggplot2 raster scatterplot layer 100 +######## fun_gg_scatter() #### ggplot2 scatterplot + lines (up to 6 overlays totally) 103 +######## fun_gg_bar() #### ggplot2 mean barplot + overlaid dots if required 139 +######## fun_gg_boxplot() #### ggplot2 boxplot + background dots if required 174 +######## fun_gg_prop() #### ggplot2 proportion barplot 223 +######## fun_gg_dot() #### ggplot2 categorial dotplot + mean/median 223 +######## fun_gg_violin() #### ggplot2 violins 223 +######## fun_gg_line() #### ggplot2 lines + background dots and error bars 223 +######## fun_gg_heatmap() #### ggplot2 heatmap + overlaid mask if required 226 +######## fun_gg_empty_graph() #### text to display for empty graphs 239 +################ Graphic extraction 241 +######## fun_trim() #### display values from a quantitative variable and trim according to defined cut-offs 241 +######## fun_segmentation() #### segment a dot cloud on a scatterplot and define the dots from another cloud outside the segmentation 249 +################ Import 282 +######## fun_pack() #### check if R packages are present and import into the working environment 282 +######## fun_python_pack() #### check if python packages are present 283 +################ Print / Exporting results (text & tables) 286 +######## fun_report() #### print string or data object into output file 286 +######## fun_get_message() #### return messages of an expression (that can be exported) 288 ################################ FUNCTIONS ################################ @@ -4481,189 +4480,221 @@ raster.dpi = raster.dpi, ######## fun_gg_scatter() #### ggplot2 scatterplot + lines (up to 6 overlays totally) -# Check OK: clear to go Apollo -fun_gg_scatter <- function(data1, x, y, categ = NULL, legend.name = NULL, color = NULL, geom = "geom_point", alpha = 0.5, dot.size = 2, line.size = 0.5, xlim = NULL, xlab = NULL, xlog = "no", x.tick.nb = NULL, x.inter.tick.nb = NULL, x.left.extra.margin = 0.05, x.right.extra.margin = 0.05, ylim = NULL, ylab = NULL, ylog = "no", y.tick.nb = NULL, y.inter.tick.nb = NULL, y.top.extra.margin = 0.05, y.bottom.extra.margin = 0.05, xy.include.zero = FALSE, text.size = 12, title = "", title.text.size = 12, show.legend = TRUE, classic = FALSE, grid = FALSE, raster = FALSE, vectorial.limit = NULL, return = FALSE, plot = TRUE, add = NULL, warn.print = FALSE, lib.path = NULL){ + + +######## fun_gg_bar() #### ggplot2 mean barplot + overlaid dots if required + + + + + +# Check NOT DONE +fun_gg_bar <- function(data1, y, categ, categ.class.order = NULL, categ.legend.name = NULL, categ.color = NULL, bar.width = 0.5, error.disp = NULL, error.whisker.width = 0.5, dot.color = "same", dot.tidy = FALSE, dot.bin.nb = 30, dot.jitter = 0.25, dot.size = 3, dot.border.size = 0.5, dot.alpha = 0.5, ylim = NULL, ylog = "no", y.tick.nb = NULL, y.inter.tick.nb = NULL, y.include.zero = FALSE, y.top.extra.margin = 0, y.bottom.extra.margin = 0, stat.disp = NULL, stat.size = 4, stat.dist = 2, xlab = NULL, ylab = 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){ # AIM -# ggplot2 scatterplot with the possibility to overlay dots from up to 3 different data frames (-> three different legends) and lines from up to 3 different data frames (-> three different legends) -> up to 6 overlays totally +# ggplot2 vertical barplot representing mean values with the possibility to add error bars and to overlay dots # for ggplot2 specifications, see: https://ggplot2.tidyverse.org/articles/ggplot2-specs.html # WARNINGS # rows containing NA in data1[, c(y, categ)] will be removed before processing, with a warning (see below) +# if ever bars disappear, see the end of https://github.com/tidyverse/ggplot2/issues/2887 +# to have a single bar, create a factor column with a single class and specify the name of this column in categ argument as unique element (no categ2 in categ argument). For a single set of grouped bars, create a factor column with a single class and specify this column in categ argument as first element (categ1). See categ below +# with several single bars (categ argument with only one element), bar.width argument (i.e., width argument of ggplot2::geom_bar()) defines each bar width. The bar.width argument also defines the space between bars by using (1 - bar.width). In addition, xmin and xmax of the fun_gg_bar() output report the bar boundaries (around x-axis unit 1, 2, 3, etc., for each bar) +# with several sets of grouped bars (categ argument with two elements), bar.width argument defines each set of grouped bar width. The bar.width argument also defines the space between set of grouped bars by using (1 - bar.width). In addition, xmin and xmax of the fun_gg_bar() output report the bar boundaries (around x-axis unit 1, 2, 3, etc., for each set of grouped bar) +# to manually change the 0 base bar into this code, see https://stackoverflow.com/questions/35324892/ggplot2-setting-geom-bar-baseline-to-1-instead-of-zero # ARGUMENTS -# data1: a dataframe compatible with ggplot, or a list of data frames -# x: character string or list of character string (one compartment for each list compartment of data1) of the data1 column name for x-axis. write NULL for each "geom_hline" in geom argument -# y: character string or list of character string (one compartment for each list compartment of data1) of the data1 column name for y-axis. Write NULL for each "geom_vline" in geom argument -# categ: character string or list of character string (one compartment for each list compartment of data1) of the data1 column name for categories. If categ = NULL, no categories (no legend). Some of the list compartments can be NULL, and other not -# legend.name: character string list of character string (one compartment for each list compartment of data1) of the legend title. If legend.name = NULL and categ != NULL, then legend.name <- categ. Some of the list compartments can be NULL, and other not -# color: vector of character string or list of character vectors (one compartment for each list compartment of data1) for the colors of categ arguments. If color = NULL, default colors of ggplot2. If non null, it can be either: (1) a single color string (all the dots of the corresponding data1 will have this color, whatever categ NULL or not), (2) if categ non null, a vector of string colors, one for each class of categ (each color will be associated according to the alphabetical order of categ classes), (3) if categ non null, a vector or factor of string colors, like if it was one of the column of data1 data frame (beware: a single color per class of categ and a single class of categ per color must be respected). Integers are also accepted instead of character strings, as long as above rules about length are respected. Integers will be processed by fun_gg_palette() using the max integer value among all the integers in color. If color is a list, some of the compartments can be NULL. In that case, a different grey color will be used for each NULL compartment -# geom: character string or list of character string (one compartment for each list compartment of data1) for the kind of plot. Either "geom_point" (scatterplot), "geom_line" (coordinates plotted then line connection from the lowest to highest coordinates), "geom_path" (line connection respecting the order in data1), "geom_hline" (horizontal line) or "geom_vline" (vertical line). BEWARE: for "geom_hline" or "geom_vline", (1) x or y argument must be NULL, respectively, (2) xlim or ylim argument must NOT be NULL, respectively, if only these kind of lines are drawn (if other geom present, then xlim = NULL and ylim = NULL will generate xlim and ylim defined by these other geom, which is not possible with "geom_hline" or "geom_vline"), (3) the function will draw n lines for n values in the x argument column name of the data1 data frame. If several colors required, the categ argument must be specified and the corresponding categ column name must exist in the data1 data frame with a different class name for each row -# alpha: numeric value (from 0 to 1) of the transparency or list of numeric values (one compartment for each list compartment of data1) -# dot.size: numeric value of point size -# line.size: numeric value of line size -# xlim: 2 numeric values for x-axis range. If NULL, range of x in data1. Order of the 2 values matters (for inverted axis). BEWARE: values of the xlim must be already in the corresponding log if xlog argument is not "no" (see below) -# xlab: a character string or expression for x-axis legend. If NULL, x of the first data frame in data1. Warning message if the elements in x are different between data frames in data1 -# xlog: Either "no" (values in the x argument column of the data1 data frame are not log), "log2" (values in the x argument column of the data1 data frame are log2 transformed) or "log10" (values in the x argument column of the data1 data frame are log10 transformed). BEWARE: do not tranform the data, but just display ticks in a log scale manner. Thus, negative or zero values allowed. BEWARE: not possible to have horizontal bars with a log axis, due to a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) -# x.tick.nb: approximate number of desired label values on the x-axis (n argument of the the fun_scale() function) -# x.inter.tick.nb: number of desired secondary ticks between main ticks. Not considered if xlog is other than "no". In that case, play with the xlim and x.tick.nb arguments -# x.left.extra.margin: single proportion (between 0 and 1) indicating if extra margins must be added to xlim. If different from 0, add the range of the axis * x.left.extra.margin (e.g., abs(xlim[2] - xlim[1]) * x.left.extra.margin) to the left of x-axis -# x.right.extra.margin: idem as x.left.extra.margin but to the bottom of x-axis +# data1: a dataframe containing one column of values (see y argument below) and one or two columns of categories (see categ argument below). Duplicated column names not allowed +# y: character string of the data1 column name for y-axis (containing numeric values). Numeric values will be averaged by categ to generate the bars and will also be used to plot the dots +# categ: vector of character strings of the data1 column name for categories (column of characters or factor). Must either be one or two column names. If a single column name (further refered to as categ1), then one bar per class of categ1. If two column names (further refered to as categ1 and categ2), then one bar per class of categ2, which form a group of bars in each class of categ1. BEWARE, categ1 (and categ2 if it exists) must have a single value of y per class of categ1 (and categ2). To have a single bar, create a factor column with a single class and specify the name of this column in categ argument as unique element (no categ2 in categ argument). For a single set of grouped bars, create a factor column with a single class and specify this column in categ argument as first element (categ1) +# categ.class.order: list indicating the order of the classes of categ1 and categ2 represented on the barplot (the first compartment for categ1 and and the second for categ2). If categ.class.order = NULL, classes are represented according to the alphabetical order. Some compartment can be NULL and other not +# categ.legend.name: character string of the legend title for categ2. If categ.legend.name = NULL, then categ.legend.name <- categ1 if only categ1 is present and categ.legend.name <- categ2 if categ1 and categ2 are present. Write "" if no legend required +# categ.color: vector of character color string for bar filling. If categ.color = NULL, default colors of ggplot2, whatever categ1 and categ2. If categ.color is non null and only categ1 in categ argument, categ.color can be either: (1) a single color string (all the bars will have this color, whatever the classes of categ1), (2) a vector of string colors, one for each class of categ1 (each color will be associated according to categ.class.order of categ1), (3) a vector or factor of string colors, like if it was one of the column of data1 data frame (beware: a single color per class of categ1 and a single class of categ1 per color must be respected). Integers are also accepted instead of character strings, as long as above rules about length are respected. Integers will be processed by fun_gg_palette() using the max integer value among all the integers in categ.color. If categ.color is non null and categ1 and categ2 specified, all the rules described above will apply to categ2 instead of categ1 (colors will be determined for bars inside a group of bars) +# bar.width: numeric value (from 0 to 1) of the bar or set of grouped bar width (see WARNINGS above) +# error.disp: either "SD", "SD.TOP", "SEM" or "SEM.TOP". If NULL, no error bars added +# error.whisker.width: numeric value (from 0 to 1) of the whisker (error bar extremities) width, with 0 meaning no whiskers and 1 meaning a width equal to the corresponding bar width +# dot.color: vector of character string. Idem as categ.color but for dots, except that in the possibility (3), the rule "a single color per class of categ1 and a single class of categ1", cannot be respected (each dot can have a different color). If NULL, no dots plotted +# dot.tidy: logical. Nice dot spreading? If TRUE, use the geom_dotplot() function for a nice representation. If FALSE, dots are randomly spread, using the dot.jitter argument (see below) +# dot.bin.nb: positive integer indicating the number of bins (i.e., nb of separations) of the ylim range. Each dot will then be put in one of the bin, with the size the width of the bin. Not considered if dot.tidy is FALSE +# dot.jitter: numeric value (from 0 to 1) of random dot horizontal dispersion, with 0 meaning no dispersion and 1 meaning a dispersion in the corresponding bar width interval. Not considered if dot.tidy is TRUE +# dot.size: numeric value of dot size. Not considered if dot.tidy is TRUE +# dot.border.size: numeric value of border dot size. Write zero for no dot border. If dot.tidy is TRUE, value 0 remove the border. Another one leave the border without size control (geom_doplot() feature) +# dot.alpha: numeric value (from 0 to 1) of dot transparency (full transparent to full opaque, respectively) # ylim: 2 numeric values for y-axis range. If NULL, range of y in data1. Order of the 2 values matters (for inverted axis). BEWARE: values of the ylim must be already in the corresponding log if ylog argument is not "no" (see below) -# ylab: a character string or expression for y-axis legend. If NULL, y of the first data frame in data1. Warning message if the elements in y are different between data frames in data1 # ylog: Either "no" (values in the y argument column of the data1 data frame are not log), "log2" (values in the y argument column of the data1 data frame are log2 transformed) or "log10" (values in the y argument column of the data1 data frame are log10 transformed). BEWARE: do not tranform the data, but just display ticks in a log scale manner. Thus, negative or zero values allowed. BEWARE: not possible to have horizontal bars with a log axis, due to a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) # y.tick.nb: approximate number of desired label values on the y-axis (n argument of the the fun_scale() function) # y.inter.tick.nb: number of desired secondary ticks between main ticks. Not considered if ylog is other than "no". In that case, play with the ylim and y.tick.nb arguments +# y.include.zero: logical. Does ylim range include 0? Ok even if ylog = TRUE because ylim must already be log transformed values # y.top.extra.margin: single proportion (between 0 and 1) indicating if extra margins must be added to ylim. If different from 0, add the range of the axis * y.top.extra.margin (e.g., abs(ylim[2] - ylim[1]) * y.top.extra.margin) to the top of y-axis -# xy.include.zero: logical. Does xlim and ylim range include 0? Ok even if xlog = TRUE or ylog = TRUE because xlim and ylim must already be log transformed values -# text.size: numeric value of the size of the (1) axis numbers and axis legends and (2) texts in the graphic legend +# y.bottom.extra.margin: idem as y.top.extra.margin but to the bottom of y-axis +# stat.disp: add the mean number above the corresponding bar. Either NULL (no number shown), "top" (at the top of the figure region) or "above" (above each bar) +# stat.size: numeric value of the stat size (in points). Increase the value to increase text size +# stat.dist: numeric value of the stat distance. Increase the value to increase the distance +# xlab: a character string or expression for x-axis legend. If NULL, character string of categ1 +# ylab: a character string or expression for y-axis legend. If NULL, character string of the y argument +# vertical: logical. Vertical bars? BEWARE: will be automatically set to TRUE if ylog argument is other than "no". Indeed, not possible to have horizontal bars with a log axis, due to a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) +# text.size: numeric value of the size of the (1) axis numbers and axis legends, (2) texts in the graphic legend, (3) stats above bars (in points) # title: character string of the graph title # title.text.size: numeric value of the title size (in points) -# show.legend: logical. Show legend? Not considered if categ argument is NULL, because this already generate no legend +# text.angle: integer value of the text angle for the x-axis labels. Positive values for counterclockwise rotation: 0 for horizontal, 90 for vertical, 180 for upside down etc. Negative values for clockwise rotation: 0 for horizontal, -90 for vertical, -180 for upside down etc. # classic: logical. Use the classic theme (article like)? -# grid: logical. Draw horizontal and vertical lines in the background to better read the values? Not considered if classic = FALSE -# raster: logical. Dots in raster mode? If FALSE, dots from each geom_point from geom argument are in vectorial mode (bigger pdf and long to display if millions of dots). If TRUE, dots from each geom_point from geom argument are in matricial mode (smaller pdf and easy display if millions of dots, but long to generate the layer). If TRUE, the plot region will be square to avoid a bug in fun_gg_point_rast(). If TRUE, solve the transparency problem with some GUI. Overriden by vectorial.limit if non NULL -# vectorial.limit: positive integer value indicating the limit of the dot number above which geom_point from geom argument switch from vectorial mode to raster mode (see the raster argument). If any layer is raster, then the region plot will be square to avoid a bug in fun_gg_point_rast(). Inactive the raster argument if non NULL -# return: logical. Return the graph info? +# grid: logical. draw horizontal lines in the background to better read the bar values? Not considered if classic = FALSE +# return: logical. Return the graph parameters? # plot: logical. Plot the graphic? If FALSE and return argument is TRUE, graphical parameters and associated warnings are provided without plotting # add: character string allowing to add more ggplot2 features (dots, lines, themes, etc.). BEWARE: (1) must start with "+" just after the simple or double opening quote (no space, end of line, carriage return, etc., allowed), (2) must finish with ")" just before the simple or double closing quote (no space, end of line, carriage return, etc., allowed) and (3) each function must be preceded by "ggplot2::" (for instance: "ggplot2::coord_flip()). If the character string contains the "ggplot2::theme" string, then internal ggplot2 theme() and theme_classic() functions will be inactivated to be reused by add. BEWARE: handle this argument with caution since added functions can create conflicts with the preexisting internal ggplot2 functions # warn.print: logical. Print warnings at the end of the execution? No print if no warning messages # lib.path: absolute path of the required packages, if not in the default folders # REQUIRED PACKAGES # ggplot2 -# if raster plots are drawn (see the raster and vectorial.limit arguments): -# Cairo -# grid +# scales # REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_comp_2d() +# fun_gg_just() # fun_gg_palette() -# fun_gg_point_rast() +# fun_name_change() # fun_pack() # fun_check() +# fun_round() +# fun_scale() # RETURN -# a scatter plot is plot argument is TRUE +# a barplot if plot argument is TRUE # a list of the graph info if return argument is TRUE: -# $data: the graphic info coordinates -# $removed.row.nb: a list of the removed rows numbers in data frames (because of NA). NULL if no row removed -# $removed.rows: a list of the removed rows in data frames (because of NA). NULL if no row removed +# $stat: the graphic statistics +# $removed.row.nb: which rows have been removed due to NA detection in y and categ columns (NULL if no row removed) +# $removed.rows: removed rows containing NA (NULL if no row removed) +# $data: the graphic bar and dot coordinates # $axes: the x-axis and y-axis info # $warn: the warning messages. Use cat() for proper display. NULL if no warning # EXAMPLES -## NICE REPRESENTATION -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 10, 3), time = rnorm(1000, 10, 3), group1 = rep(c("A1", "A2"), 500)) ; obs2 <-data.frame(km = rnorm(1000, 15, 3), time = rnorm(1000, 15, 3), group2 = rep(c("G1", "G2"), 500)) ; set.seed(NULL) ; obs1$L1$km[2:3] <- NA ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), categ = list(L1 = "group1", L2 = "group2"), legend.name = NULL, color = list(L1 = 4:5, L2 = 7:8), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), dot.size = 3, line.size = 0.5, xlim = c(1, 25), xlab = "KM", xlog = "no", x.tick.nb = 10, x.inter.tick.nb = 1, x.left.extra.margin = 0, x.right.extra.margin = 0, ylim = c(1, 25), ylab = expression(paste("TIME (", 10^-20, " s)")), ylog = "log10", y.tick.nb = 5, y.top.extra.margin = 0, y.bottom.extra.margin = 0, xy.include.zero = TRUE, classic = TRUE) -## SINGLE GEOMETRIC LAYER -### simple example (1) of scatter plot using the classical writting -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time") -### simple example (2) of scatter plot, identical to (1) but using the list writting. Here, a list of one compartment, systematically named L1, is provided to the data1, x, y, categ, geom and alpha. Contrary to example (1), the geom and alpha argument have to be included because the default value are not lists (if data1 is a list, all the x, y, categ, legend.name, color, geom and alpha must also be list if non NULL) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = list(L1 = obs1), x = list(L1 = "km"), y = list(L1 = "time"), geom = list(L1 = "geom_point"), alpha = list(L1 = 0.5)) -### color of dots. Example (1) using the classical writting -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", color = "blue") -### color of dots. Example (2) using the list writting -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = list(L1 = obs1), x = list(L1 = "km"), y = list(L1 = "time"), color = list(L1 = "blue"), geom = list(L1 = "geom_point"), alpha = list(L1 = 1)) -### From here, classical writting is use for single element in data1 and list writting otherwise -### color of dots. Example (3) when dots are in different categories. Note that categ argument controls the legend display -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group") -### color of dots. Example (4) when dots are in different categories. A single color mentionned is applied to all the dots -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group", color = "coral") -### color of dots. Example (5) when dots are in different categories. Numbers can be used if ggplot colors are desired -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group", color = 2) -### color of dots. Example (6) when dots are in different categories, with one color per category (try also color = 2:1) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group", color = c("coral", "green")) -### color of dots. Example (7) when dots are in different categories, with colors as a data frame column. BEWARE: one color per category must be respected (try also numbers) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B"), col = rep(c("coral", "green"), each = 3)) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group", color = obs1$col) -### color of dots. Example (8) when dots are in different categories, with colors as a data frame column. Easiest way (ggplot colors) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group", color = as.numeric(obs1$group)) -### legend name -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group", legend.name = "CLASSES") -### different geom features. Example (1) with geom_line kind of lines -# obs1 <- data.frame(km = c(1, 3, 2, 6, 4, 5), time = c(1, 3, 2, 6, 4, 5)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", geom = "geom_line", categ = "group") -### different geom features. Example (2) with geom_path kind of lines (see the difference with (1)) -# obs1 <- data.frame(km = c(1, 3, 2, 6, 4, 5), time = c(1, 3, 2, 6, 4, 5)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", geom = "geom_path", categ = "group") -### different geom features. Example (3) with geom_hline kind of lines. Fake_y y-axis name by default because y argument must be NULL (see ylab argument below to change this) -# obs1 <- data.frame(km = 1:2, time = (1:2)^2, group = c("A", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = NULL, y = "km", geom = "geom_hline", categ = "group", xlim = c(1,10)) -### different geom features. Example (4) with geom_vline kind of lines. Fake_y y-axis name by default because y argument must be NULL (see ylab argument below to change this) -# obs1 <- data.frame(km = 1:2, time = (1:2)^2, group = c("A", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = NULL, geom = "geom_vline", categ = "group", ylim = c(1,10)) -## MULTI GEOMETRIC LAYERS -### Note that in subsequent examples, names of list compartments are systematically referred to as L1, L2, etc., to show the correspondence between the arguments data1, x, y, categ, etc. -### single layer (as examples above) -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1), x = list(L1 = "km"), y = list(L1 = "time"), geom = list(L1 = "geom_point"), alpha = list(L1 = 0.5)) -### simple example of two layers -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5)) -### color of dots. Example (1) -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), color = list(L1 = "coral", L2 = "green")) -### color of dots. Example (2) of the legend display. The categ argument must be supplied. Make a fake categorical colum in the data frame if necessary (as in this example). The categ argument triggers the legend display. The legend.name argument is used to remove the legend title of each layer -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = "GROUP1") ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = "GROUP2") ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), categ = list(L1 = "group1", L2 = "group2"), legend.name = list(L1 = NULL, L2 = NULL), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), color = list(L1 = "coral", L2 = "green")) -### color of dots. Example (3) when dots are in different categories (default colors) -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5)) -### color of dots. Example (3) when dots are in different categories. A single color mentionned per layer is applied to all the dots of the layer -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), color = list(L1 = "coral", L2 = "green")) -### color of dots. Example (5) when dots are in different categories, with one color per category in each layer -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), color = list(L1 = c("coral", "blue"), L2 = c("green", "black"))) -### color of dots. Example (4) when dots are in different categories. Numbers can be used if ggplot colors are desired -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), color = list(L1 = 1:2, L2 = c(4, 7))) -### color of dots. Example (7) when dots are in different categories, with colors as a data frame column. BEWARE: one color per category must be respected (try also numbers). BEWARE: in color argument, if the column of the data frame does not exist, color can be still displayed (L2 = obs2$notgood is equivalent to L2 = NULL). Such situation is reported in the warning messages (see below) -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500), col1 = rep(c("coral", "blue"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500), col2 = rep(c("green", "black"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), color = list(L1 = obs1$col1, L2 = obs2$col2)) -### color of dots. Example (8) when dots are in different categories, with colors as a data frame column. Easiest way is not recommended with mutiple layers -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500), col1 = rep(c("coral", "blue"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500), col2 = rep(c("green", "black"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), color = list(L1 = as.numeric(obs1$group1), L2 = as.numeric(obs2$group2))) -### legend name -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), legend.name = list(L1 = "CLASS A", L2 = "CLASS G"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5)) -### different geom features. Example (1) with 5 layers. Note that order in data1 defines the overlay order (from below to above) and the order in the legend (from top to bottom) -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500)) ; set.seed(NULL) ; obs3 <- data.frame(time = c(29, 31), group3 = c("HORIZ.THRESHOLD.1", "HORIZ.THRESHOLD.2")) ; obs4 <- data.frame(km = 26, group4 = "VERTIC.THRESHOLD") ; obs5 <- data.frame(km = seq(1, 100, 0.1), time = 7*seq(1, 100, 0.1)^0.5, group5 = "FUNCTION") ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2, L3 = obs3, L4 = obs4, L5 = obs5), x = list(L1 = "km", L2 = "km", L3 = NULL, L4 = "km", L5 = "km"), y = list(L1 = "time", L2 = "time", L3 = "time", L4 = NULL, L5 = "time"), categ = list(L1 = "group1", L2 = "group2", L3 = "group3", L4 = "group4", L5 = "group5"), geom = list(L1 = "geom_point", L2 = "geom_point", L3 = "geom_hline", L4 = "geom_vline", L5 = "geom_line"), alpha = list(L1 = 0.5, L2 = 0.5, L3 = 0.5, L4 = 0.5, L5 = 0.5), xlim = c(10, 40), ylim = c(10, 40), classic = TRUE, line.size = 0.75) -### layer transparency. One transparency defined by layer (from 0 invisible to 1 opaque). Note that for lines, transparency in not applied in the legend to prevent a ggplot2 bug (https://github.com/tidyverse/ggplot2/issues/2452) -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 22, 3), time = rnorm(1000, 22, 3), group1 = rep(c("A1", "A2"), each = 500)) ; obs2 <-data.frame(km = rnorm(1000, 30, 3), time = rnorm(1000, 30, 3), group2 = rep(c("G1", "G2"), each = 500)) ; set.seed(NULL) ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), , categ = list(L1 = "group1", L2 = "group2"), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 1, L2 = 0.1)) -### other different example of mutiple geom features are shown in the fun_segmentation function -## OTHER GRAPHIC ARGUMENTS -### dot size (line.size argument controls size of lines) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", dot.size = 5) -### axis management: examples are shown for x-axis but are identical for y-axis -### x-axis limits. Example (1) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlim = c(-1, 25)) -### x-axis limits. Example (2) showing that order matters in ylim argument -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlim = c(25, -1)) -### log scale. Example (1). BEWARE: x column must be log, otherwise incoherent scale (see below warning message with the return argument) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlog = "log10") -### log scale. Example (2). BEWARE: values of the xlim must be in the corresponding log -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlog = "log10", xlim = c(1, 10)) -### tick number. Example (1). Note that the final number shown is approximate -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", x.tick.nb = 6) +### nice representation (1) +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A")), categ.legend.name = "LEGEND", categ.color = NULL, bar.width = 0.3, error.disp = "SD.TOP", error.whisker.width = 0.8, dot.color = "same", dot.jitter = 0.5, dot.size = 3.5, dot.border.size = 0.2, dot.alpha = 0.5, ylim = c(10, 25), y.include.zero = TRUE, stat.disp = "above", stat.size = 4, xlab = "GROUP", ylab = "VALUE", text.size = 12, title = "GRAPH1", title.text.size = 8, text.angle = 0, classic = TRUE, grid = TRUE) +### nice representation (2) +# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(24, 0), rnorm(24, -10), rnorm(24, 10), rnorm(24, 20)), Group1 = rep(c("CAT", "DOG"), times = 48), Group2 = rep(c("A", "B", "C", "D"), each = 24)) ; set.seed(NULL) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A", "D", "C")), categ.legend.name = "LEGEND", categ.color = NULL, bar.width = 0.8, dot.color = "grey50", dot.tidy = TRUE, dot.bin.nb = 60, dot.size = 3.5, dot.border.size = 0.2, dot.alpha = 0.5, ylim= c(-20, 30), stat.disp = "above", stat.size = 4, stat.dist = 1, xlab = "GROUP", ylab = "VALUE", vertical = FALSE, text.size = 12, title = "GRAPH1", title.text.size = 8, text.angle = 45, classic = FALSE) +### simple example +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1") +### separate bars. Example (1) of modification of bar color using a single value +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", categ.color = "white") +### separate bars. Example (2) of modification of bar color using one value par class of categ2 +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", categ.color = c("coral", "lightblue")) +### separate bars. Example (3) of modification of bar color using the bar.color data frame column, with respect of the correspondence between categ2 and bar.color columns +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), bar.color = rep(c("coral", "lightblue"), time = 10)) ; obs1 ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", categ.color = obs1$bar.color) +### separate bars. Example (1) of modification of dot color, using the same dot color as the corresponding bar +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = "same") +### separate bars. Example (2) of modification of dot color, using a single color for all the dots +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = "green") +### separate bars. Example (3) of modification of dot color, using one value par class of categ2 +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = c("green", "brown")) +### separate bars. Example (4) of modification of dot color, using different colors for each dot +# obs1 <- data.frame(Time = 1:10, Group1 = rep(c("G", "H"), times = 5)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = hsv(h = (1:nrow(obs1)) / nrow(obs1))) +### grouped bars. Simple example +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2")) +### grouped bars. More grouped bars +# obs1 <- data.frame(Time = 1:24, Group1 = rep(c("G", "H"), times = 12), Group2 = rep(c("A", "B", "C", "D"), each = 6)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2")) +### grouped bars. Example (1) of modification of bar color, using a single value +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = "white") +### grouped bars. Example (2) of modification of bar color, using one value par class of categ2 +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = c("coral", "lightblue")) +### grouped bars. Example (3) of modification of bar color, using one value per line of obs1, with respect of the correspondence between categ2 and bar.color columns +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10), bar.color = rep(c("coral", "lightblue"), each = 10)) ; obs1 ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = obs1$bar.color) +### grouped bars. Example (1) of modification of dot color, using the same dot color as the corresponding bar +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same") +### grouped bars. Example (2) of modification of dot color, using a single color for all the dots +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "green") +### grouped bars. Example (3) of modification of dot color, using one value par class of categ2 +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = c("green", "brown")) +### grouped bars. Example (4) of modification of dot color, using different colors for each dot +# obs1 <- data.frame(Time = 1:10, Group1 = rep(c("G", "H"), times = 5), Group2 = rep(c("A", "B"), each = 5)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = hsv(h = (1:nrow(obs1)) / nrow(obs1))) +### no dots (y.include.zero set to TRUE to see the lowest bar): +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE) +### bar width. Example (1) with bar.width = 0.25 -> three times more space between single bars than the bar width (y.include.zero set to TRUE to see the lowest bar) +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), each = 500)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = NULL, y.include.zero = TRUE, bar.width = 0.25) +### bar width. Example (2) with bar.width = 1, no space between single bars +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), each = 500)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = NULL, y.include.zero = TRUE, bar.width = 1) +### bar width. Example (3) with bar.width = 0.25 -> three times more space between sets of grouped bars than the set width +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE, bar.width = 0.25) +### bar width. Example (4) with bar.width = 0 -> no space between sets of grouped bars +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE, bar.width = 1) +### error bars +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, error.disp = "SD.TOP") +### whisker width. Example (1) with error.whisker.width = 1 -> whiskers have the width of the corresponding bar +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, error.disp = "SD", error.whisker.width = 1) +### whisker width. Example (2) error bars with no whiskers +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, error.disp = "SD", error.whisker.width = 0) +### tidy dot distribution. Example (1) +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = TRUE, dot.bin.nb = 100) +### tidy dot distribution. Example (2) reducing the dot size with dot.bin.nb +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = TRUE, dot.bin.nb = 150) +### dot jitter. Example (1) +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = FALSE, dot.jitter = 1, dot.size = 2) +### dot jitter. Example (2) with dot.jitter = 1 -> dispersion around the corresponding bar width +# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 3, dot.alpha = 1, dot.jitter = 1) +### dot jitter. Example (3) with no dispersion +# obs1 <- data.frame(Time = 1:100, Group1 = rep(c("G", "H"), times = 50), Group2 = rep(LETTERS[1:5], each = 20)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 3, dot.alpha = 1, dot.jitter = 0) +### dot size, dot border size and dot transparency +# obs1 <- data.frame(Time = 1:100, Group1 = rep(c("G", "H"), times = 50), Group2 = rep(LETTERS[1:5], each = 20)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 4, dot.border.size = 0, dot.alpha = 0.6) +### y-axis limits. Example (1) +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylim = c(-1, 25)) +### y-axis limits. Example (2) showing that order matters in ylim argument +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylim = c(25, -1)) +### log scale. Example (1). BEWARE: y column must be log, otherwise incoherent scale (see below warning message with the return argument) +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10") +### log scale. Example (2). BEWARE: values of the ylim must be in the corresponding log +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", ylim = c(1,4)) +### tick number. Example (1) +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.tick.nb = 10) ### tick number. Example (2) using a log2 scale -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlog = "log2", x.tick.nb = 6) +# obs1 <- data.frame(Time = log2((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log2", y.tick.nb = 10, ylim = c(1, 16)) ### tick number. Example (3) using a log10 scale -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlog = "log10", x.tick.nb = 6) -### tick number. Example (4) using a log10 scale: the reverse x-axis correctly deal with log10 scale -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlog = "log10", xlim = c(7, 2)) +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.tick.nb = 10) +### tick number. Example (4) using a log10 scale: the reverse y-axis correctly deal with log10 scale +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.tick.nb = 10, ylim = c(4, 1)) ### secondary tick number. Example (1) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", x.inter.tick.nb = 4) +# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.inter.tick.nb = 2) ### secondary ticks. Example (2) not for log2 and log10 scales (see below warning message with the return argument) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlog = "log10", x.inter.tick.nb = 4) +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.inter.tick.nb = 2) +### include zero in the y-axis +# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.include.zero = TRUE) ### extra margins. To avoid dot cuts -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", x.left.extra.margin = 0.25, x.right.extra.margin = 0.25) -### include zero in both the x-axis and y-xis -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", xy.include.zero = TRUE) -### graph title, text size and legend display -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", categ = "group", text.size = 8, title = "GRAPH1", title.text.size = 16, show.legend = TRUE) -### raster display. This switchs from vectorial mode to raster mode. The display can takes some time, but this is easier to export and handle than vectorial display -# set.seed(1) ; obs1 <- data.frame(km = rnorm(100000, 22, 3), time = rnorm(100000, 22, 3)) ; set.seed(NULL) ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", raster = TRUE) +# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.25, y.bottom.extra.margin = 0.25) +### mean diplay. Example (1) at the top of the plot region +# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.1, stat.disp = "top", stat.size = 4, stat.dist = 2) +### mean diplay. Example (2) above bars +# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.1, stat.disp = "above", stat.size = 4, stat.dist = 2) +### bar orientation. Example (1) without log scale, showing that the other arguments are still operational +# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.tick.nb = 10, y.inter.tick.nb = 2, y.include.zero = TRUE, vertical = FALSE) +### bar orientation. Example (2) with log scale. Horizontal orientation is blocked with log2 and log10 scales because of a bug in ggplot2 (https://github.com/tidyverse/ggplot2/issues/881) +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", vertical = FALSE) ### classic representation (use grid = TRUE to display the background lines of the y axis ticks) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", classic = TRUE, grid = FALSE) +# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), classic = TRUE, grid = FALSE) ### graphic info. Example (1) -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", return = TRUE) +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), return = TRUE) ### graphic info. Example (2) of assignation and warning message display -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; output <- fun_gg_scatter(data1 = obs1, x = "km", y = "time", xlog = "log10", return = TRUE) ; cat(output$warn) +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; warn <- fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", return = TRUE) ; cat(warn$warn) ### add ggplot2 functions -# obs1 <- data.frame(km = 2:7, time = (2:7)^2, group = c("A", "A", "A", "B", "B", "B")) ; obs1 ; fun_gg_scatter(data1 = obs1, x = "km", y = "time", add = "+ggplot2::theme_classic()") +# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), add = "+ggplot2::theme_classic()") ### all the arguments -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 10, 3), time = rnorm(1000, 10, 3), group1 = rep(c("A1", "A2"), 500)) ; obs2 <-data.frame(km = rnorm(1000, 15, 3), time = rnorm(1000, 15, 3), group2 = rep(c("G1", "G2"), 500)) ; set.seed(NULL) ; obs1$L1$km[2:3] <- NA ; fun_gg_scatter(data1 = list(L1 = obs1, L2 = obs2), x = list(L1 = "km", L2 = "km"), y = list(L1 = "time", L2 = "time"), categ = list(L1 = "group1", L2 = "group2"), legend.name = NULL, color = list(L1 = 4:5, L2 = 7:8), geom = list(L1 = "geom_point", L2 = "geom_point"), alpha = list(L1 = 0.5, L2 = 0.5), dot.size = 3, line.size = 0.5, xlim = c(1, 25), xlab = "KM", xlog = "no", x.tick.nb = 10, x.inter.tick.nb = 1, x.left.extra.margin = 0, x.right.extra.margin = 0, ylim = c(1, 25), ylab = "TIME (s)", ylog = "log10", y.tick.nb = 5, y.inter.tick.nb = NULL, y.top.extra.margin = 0, y.bottom.extra.margin = 0, xy.include.zero = TRUE, text.size = 12, title = "", title.text.size = 8, show.legend = TRUE, classic = FALSE, grid = FALSE, raster = FALSE, vectorial.limit = NULL, return = FALSE, plot = TRUE, add = NULL, warn.print = TRUE, lib.path = NULL) +# obs1 <- data.frame(x = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "x", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A")), categ.legend.name = "", categ.color = c("red", "blue"), bar.width = 0.25, error.disp = "SD", error.whisker.width = 0.8, dot.color = "grey", dot.tidy = FALSE, dot.bin.nb = 30, dot.jitter = 1, dot.size = 4, dot.border.size = 0, dot.alpha = 1, ylim = c(0, 25), ylog = "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, stat.disp = "above", stat.size = 4, stat.dist = 2, xlab = "GROUP", ylab = "VALUE", vertical = FALSE, text.size = 12, title = "", title.text.size = 8, text.angle = 45, classic = TRUE, grid = TRUE, return = TRUE, plot = TRUE, add = NULL, warn.print = TRUE, lib.path = NULL) # DEBUGGING -# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 10, 3), time = rnorm(1000, 10, 3), group1 = rep(c("A1", "A2"), 500)) ; obs2 <-data.frame(km = rnorm(1000, 15, 3), time = rnorm(1000, 15, 3), group2 = rep(c("G1", "G2"), 500)) ; set.seed(NULL) ; obs1$L1$km[2:3] <- NA ; data1 = list(L1 = obs1, L2 = obs2) ; x = list(L1 = "km", L2 = "km") ; y = list(L1 = "time", L2 = "time") ; categ = list(L1 = "group1", L2 = "group2") ; legend.name = NULL ; color = list(L1 = 4:5, L2 = 7:8) ; geom = list(L1 = "geom_point", L2 = "geom_point") ; alpha = list(L1 = 0.5, L2 = 0.5) ; dot.size = 3 ; line.size = 0.5 ; xlim = c(25, 0) ; xlab = "KM" ; xlog = "no" ; x.tick.nb = 10 ; x.inter.tick.nb = 1 ; x.left.extra.margin = 0 ; x.right.extra.margin = 0 ; ylim = c(1, 25) ; ylab = "TIME (s)" ; ylog = "log2" ; y.tick.nb = 5 ; y.inter.tick.nb = 2 ; y.top.extra.margin = 0 ; y.bottom.extra.margin = 0 ; xy.include.zero = TRUE ; text.size = 12 ; title = "" ; title.text.size = 8 ; show.legend = TRUE ; classic = FALSE ; grid = FALSE ; raster = FALSE ; vectorial.limit = NULL ; return = FALSE ; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL -# data1 <- list(L1 = data.frame(a = 1:6, b = (1:6)^2, group = c("A", "A", "A", "B", "B", "B")), L2 = data.frame(a = (1:6)*2, b = ((1:6)^2)*2, group = c("A1", "A1", "A1", "B1", "B1", "B1")), L3 = data.frame(a = (1:6)*3, b = ((1:6)^2)*3, group3 = c("A4", "A5", "A6", "A7", "B4", "B5"))) ; data1$L1$a[3] <- NA ; data1$L1$group[5] <- NA ; data1$L3$group3[4] <- NA ; x = list(L1 = names(data1$L1)[1], L2 = names(data1$L2)[1], L3 = NULL) ; y = list(L1 = names(data1$L1)[2], L2 = names(data1$L2)[2], L3 = "a") ; categ = list(L1 = "group", L2 = NULL, L3 = NULL) ; legend.name = NULL ; color = NULL ; geom = list(L1 = "geom_point", L2 = "geom_point", L3 = "geom_hline") ; alpha = list(L1 = 0.5, L2 = 0.5, L3 = 0.5) ; dot.size = 1 ; line.size = 0.5 ; xlim = c(14, 4) ; xlab = NULL ; xlog = "log10" ; x.tick.nb = 10 ; x.inter.tick.nb = 4 ; x.left.extra.margin = 0 ; x.right.extra.margin = 0 ; ylim = c(60, 5) ; ylab = NULL ; ylog = "log10" ; y.tick.nb = 10 ; y.inter.tick.nb = 2 ; y.top.extra.margin = 0 ; y.bottom.extra.margin = 0 ; xy.include.zero = FALSE ; text.size = 12 ; title = "" ; title.text.size = 8 ; show.legend = TRUE ; classic = FALSE ; grid = FALSE ; raster = FALSE ; vectorial.limit = NULL ; return = FALSE ; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL -# data1 <- data.frame(km = 1:2, time = (1:2)^2, group = c("A", "B")) ; data1 ; x = NULL; y = "km"; categ = "group"; legend.name = NULL ; color = NULL ; geom = "geom_hline"; alpha = 0.5 ; dot.size = 1 ; line.size = 0.5 ; xlim = c(1,10) ; xlab = NULL ; xlog = "log10" ; x.tick.nb = 10 ; x.inter.tick.nb = 4 ; x.left.extra.margin = 0 ; x.right.extra.margin = 0 ; ylim = NULL ; ylab = expression(paste("TIME (", 10^-20, " s)")) ; ylog = "log10" ; y.tick.nb = 10 ; y.inter.tick.nb = 2 ; y.top.extra.margin = 0 ; y.bottom.extra.margin = 0 ; xy.include.zero = FALSE ; text.size = 12 ; title = "" ; title.text.size = 8 ; show.legend = TRUE ; classic = FALSE ; grid = FALSE ; raster = FALSE ; vectorial.limit = NULL ; return = FALSE ; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL +# data1 <- data.frame(a = 1:20, group1 = rep(c("G", "H"), times = 10), group2 = rep(c("A", "B"), each = 10), bar.color = rep(c("brown", "orange"), each = 10)) ; data1[2:3, 1] <- NA ; data1[7:8, 2] <- NA ; y = names(data1)[1] ; categ = c(names(data1)[2], names(data1)[3]) ; categ.class.order = list(L1 = NULL, L2 = c("B", "A")) ; categ.legend.name = NULL ; categ.color = na.omit(data1)$bar.color ; bar.width = 0.5 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = FALSE ; dot.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ; dot.border.size = 0.5 ; dot.alpha = 1 ; ylim = NULL ; ylog = "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 ; stat.disp = NULL ; stat.size = 4 ; stat.dist = 2 ; xlab = NULL ; ylab = 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 = TRUE ; lib.path = NULL +# data1 <-data.frame(a = rep(1:20, 5), group1 = rep(c("G", "H"), times = 50), group2 = rep(LETTERS[1:5], each = 20)) ; y = names(data1)[1] ; categ = c(names(data1)[2], names(data1)[3]) ; categ.class.order = list(L1 = NULL, L2 = c("B", "A", "E", "D", "C")) ; categ.legend.name = NULL ; categ.color = NULL ; bar.width = 0.5 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = TRUE ; dot.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ; dot.border.size = 0.5 ; dot.alpha = 1 ; ylim = NULL ; ylog = "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 ; stat.disp = NULL ; stat.size = 4 ; stat.dist = 2 ; xlab = NULL ; ylab = 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 = TRUE ; lib.path = NULL +# data1 <- data.frame(a = 1:20, group1 = rep(c("G", "H"), times = 10), group2 = rep(c("A", "B"), each = 10), bar.color = rep(c("brown", "orange"), each = 10)) ; data1[2:3, 1] <- NA ; data1[7:8, 2] <- NA ; y = names(data1)[1] ; categ = c(names(data1)[2], names(data1)[3]) ; categ.class.order = list(L1 = NULL, L2 = c("B", "A")) ; categ.legend.name = NULL ; categ.color = na.omit(data1)$bar.color ; bar.width = 0.5 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = TRUE ; dot.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ; dot.border.size = 0.5 ; dot.alpha = 1 ; ylim = NULL ; ylog = "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 ; stat.disp = "above" ; stat.size = 4 ; stat.dist = 2 ; xlab = NULL ; ylab = 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 = TRUE ; lib.path = NULL +# set.seed(1) ; data1 <- data.frame(a = c(rnorm(25, 0), rnorm(25, -10), rnorm(25, 10), rnorm(25, 20)), group1 = rep(c("G", "H"), times = 50), group2 = rep(c("A", "B", "C", "D"), each = 25)) ; set.seed(NULL) ; y = "Time" ; categ = c("group1", "group2") ; categ.class.order = list(NULL, c("B", "A", "D", "C")) ; categ.legend.name = "LEGEND" ; categ.color = NULL ; bar.width = 0.8 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = TRUE ; dot.bin.nb = 60 ; dot.jitter = 0.25 ; dot.size = 3.5 ; dot.border.size = 0 ; dot.alpha = 1 ; ylim= c(-15, 25) ; ylog = "no" ; y.tick.nb = NULL ; y.inter.tick.nb = NULL ; y.include.zero = "no" ; y.top.extra.margin = 0.05 ; y.bottom.extra.margin = 0 ; stat.disp = "above" ; stat.size = 4 ; stat.dist = 2 ; xlab = "GROUP" ; ylab = "VALUE" ; vertical = FALSE ; text.size = 12 ; title = "" ; title.text.size = 8 ; text.angle = -200 ; classic = FALSE ; grid = FALSE ; return = FALSE; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL +# set.seed(1) ; data1 <- data.frame(x = 1:1000, group1 = rep(c("G", "H"), times = 500), group2 = rep(LETTERS[1:5], each = 200)) ; set.seed(NULL) ; y = "x" ; categ <- c("group1", "group2") ; categ.class.order = list(NULL, c("B", "A", "D", "C", "E")) ; categ.legend.name = "LEGEND" ; categ.color = NULL ; bar.width = 0.8 ; error.disp = "SD" ; error.whisker.width = 1 ; dot.color = NULL ; dot.tidy = FALSE ; dot.bin.nb = 60 ; dot.jitter = 0.25 ; dot.size = 3.5 ; dot.border.size = 0.2 ; dot.alpha = 1 ; ylim= c(1, 4) ; ylog = "log10" ; y.tick.nb = NULL ; y.inter.tick.nb = NULL ; y.include.zero = FALSE ; y.top.extra.margin = 0 ; y.bottom.extra.margin = 0 ; stat.disp = "above" ; stat.size = 4 ; stat.dist = 1 ; xlab = "GROUP" ; ylab = "VALUE" ; vertical = TRUE ; text.size = 12 ; title = "" ; title.text.size = 8 ; text.angle = -200 ; classic = FALSE ; grid = FALSE ; return = FALSE; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL # function name function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") # end function name # required function checking +if(length(utils::find("fun_comp_2d", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_comp_2d() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} +if(length(utils::find("fun_gg_just", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_just() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} if(length(utils::find("fun_gg_palette", mode = "function")) == 0){ tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_palette() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") stop(tempo.cat, call. = FALSE) } -if(length(utils::find("fun_gg_point_rast", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_point_rast() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +if(length(utils::find("fun_name_change", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_name_change() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") stop(tempo.cat, call. = FALSE) } if(length(utils::find("fun_pack", mode = "function")) == 0){ @@ -4674,480 +4705,292 @@ if(length(utils::find("fun_check", mode = "function")) == 0){ tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") stop(tempo.cat, call. = FALSE) } +if(length(utils::find("fun_round", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_round() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} +if(length(utils::find("fun_scale", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_scale() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} # end required function checking # reserved words to avoid bugs (used in this function) -reserved.words <- c("fake_x", "fake_y", "fake_categ", "color") +reserved.words <- c("categ.check", "categ.color", "dot.color", "dot.max", "dot.min", "ERROR.INF", "ERROR.SUP", "group", "group.check", "max.dot.error", "MEAN", "min.dot.error", "SD", "SEM", "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) -# check list lengths (and names of data1 compartments if non name present) +# argument checking (and modification for proper color management) warn <- NULL warn.count <- 0 -if(all(class(data1) == "list")){ -if(length(data1) > 6){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": data1 ARGUMENT MUST BE A LIST OF 6 DATA FRAMES MAXIMUM (6 OVERLAYS MAX)\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if(is.null(names(data1))){ -names(data1) <- paste0("L", 1:length(data1)) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL NAME COMPARTMENT OF data1 LIST -> NAMES RESPECTIVELY ATTRIBUTED TO EACH COMPARTMENT:\n", paste(names(data1), collapse = " ")) -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -if( ! is.null(x)){ -if( ! (all(class(x) == "list") & length(data1) == length(x))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -}else{ -x <- vector("list", length(data1)) -} -if( ! is.null(y)){ -if( ! (all(class(y) == "list") & length(data1) == length(y))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +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) +if(tempo$problem == FALSE & 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 = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -}else{ -y <- vector("list", length(data1)) +tempo <- fun_check(data = y, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (y %in% names(data1))){ +tempo.cat <- paste0("ERROR IN ", function.name, ": y ARGUMENT MUST BE A COLUMN NAME OF data1") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE){ +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) } -if( ! is.null(categ)){ -if( ! (all(class(categ) == "list") & length(data1) == length(categ))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": categ ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -} -if( ! is.null(legend.name)){ -if( ! (all(class(legend.name) == "list") & length(data1) == length(legend.name))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": legend.name ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -} -if( ! is.null(color)){ -if( ! (all(class(color) == "list") & length(data1) == length(color))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": color ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -} -if( ! (all(class(geom) == "list") & length(data1) == length(geom))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": geom ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if( ! (all(class(alpha) == "list") & length(data1) == length(alpha))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": alpha ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -} -# end check list lengths (and names of data1 compartments if non name present) -# conversion into lists -if(all(is.data.frame(data1))){ -data1 <- list(L1 = data1) -if(all(class(x) == "list")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -x <- list(L1 = x) -} -if(all(class(y) == "list")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -y <- list(L1 = y) -} -if( ! is.null(categ)){ -if(all(class(categ) == "list")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": categ ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -categ <- list(L1 = categ) -} -} -if( ! is.null(legend.name)){ -if(all(class(legend.name) == "list")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": legend.name ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -legend.name <- list(L1 = legend.name) -} -} -if( ! is.null(color)){ -if(all(class(color) == "list")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": color ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -color <- list(L1 = color) -} -} -if(all(class(geom) == "list")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": geom ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -geom <- list(L1 = geom) -} -if(all(class(alpha) == "list")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": alpha ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -alpha <- list(L1 = alpha) -} -} -# end conversion into lists -# legend name filling -if(is.null(legend.name) & ! is.null(categ)){ -legend.name <- categ -}else if(is.null(legend.name) & is.null(categ)){ -legend.name <- vector("list", length(data1)) # null list -} -# end legend name filling -# ini categ for legend display -fin.lg.disp <- vector("list", 6) # will be used at the end to display or not legends -fin.lg.disp[] <- FALSE -legend.disp <- vector("list", length(data1)) -if(is.null(categ) | show.legend == FALSE){ -legend.disp[] <- FALSE -}else{ -for(i2 in 1:length(data1)){ -if(is.null(categ[[i2]])){ -legend.disp[[i2]] <- FALSE -}else{ -legend.disp[[i2]] <- TRUE -} -} -} -# end ini categ for legend display -# integer colors into gg_palette -tempo.check.color <- NULL -for(i1 in 1:length(data1)){ -if(any(is.na(color[[i1]]))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ": color ARGUMENT CANNOT CONTAIN NA\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -tempo.check.color <- c(tempo.check.color, fun_check(data = color[[i1]], data.name = ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, fun.name = function.name, print = FALSE)$problem) -} -tempo.check.color <- ! tempo.check.color # invert TRUE and FALSE because if integer, then problem = FALSE -if(any(tempo.check.color == TRUE)){ # convert integers into colors -tempo.integer <- unlist(color[tempo.check.color]) -tempo.color <- fun_gg_palette(max(tempo.integer, na.rm = TRUE)) -for(i1 in 1:length(data1)){ -if(tempo.check.color[i1] == TRUE){ -color[[i1]] <-tempo.color[color[[i1]]] -} -} -} -# end integer colors into gg_palette -# 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)) -compart.null.color <- 0 # will be used to attribute a color when color is non NULL but a compartment of color is NULL -data1.ini <- data1 # to report NA removal -removed.row.nb <- vector("list", length = length(data1)) # to report NA removal -removed.rows <- vector("list", length = length(data1)) # to report NA removal -for(i1 in 1:length(data1)){ -tempo <- fun_check(data = data1[[i1]], data.name = ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), class = "data.frame", na.contain = TRUE, fun.name = function.name) ; eval(ee) -# reserved word checking -if(any(names(data1[[i1]]) %in% reserved.words)){ # I do not use fun_name_change() because cannot control y before creating "fake_y". But ok because reserved are not that common -tempo.cat <- paste0("ERROR IN ", function.name, ": COLUMN NAMES OF ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), " ARGUMENT CANNOT BE ONE OF THESE WORDS\n", paste(reserved.words, collapse = " "), "\nTHESE ARE RESERVED FOR THE ", function.name, " FUNCTION") +tempo <- fun_check(data = categ, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & length(categ) > 2){ +tempo.cat <- paste0("ERROR IN ", function.name, ": categ ARGUMENT CANNOT HAVE MORE THAN 2 COLUMN NAMES OF data1\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) -} -# end reserved word checking -# check of geom now because required for y argument -tempo <- fun_check(data = geom[[i1]], data.name = ifelse(length(geom) == 1, "geom", paste0("geom NUMBER ", i1)), options = c("geom_point", "geom_line", "geom_path", "geom_hline", "geom_vline"), length = 1, fun.name = function.name) ; eval(ee) -# end check of geom now because required for y argument -if(is.null(x[[i1]])){ -if(all(geom[[i1]] != "geom_hline")){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(x) == 1, "x", paste0("x NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ": x ARGUMENT CANNOT BE NULL EXCEPT IF ", ifelse(length(geom) == 1, "x", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_hline\"\nHERE geom ARGUMENT IS: ", paste(geom[[i1]], collapse = " ")) +}else if(tempo$problem == FALSE & ! 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 = " ")) text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) -}else{ -x[[i1]] <- "fake_x" -data1[[i1]] <- cbind(data1[[i1]], fake_x = NA) -data1[[i1]][, "fake_x"] <- as.numeric(data1[[i1]][, "fake_x"]) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL ", ifelse(length(x) == 1, "x", paste0("x NUMBER ", i1)), " ARGUMENT ASSOCIATED TO ", ifelse(length(geom) == 1, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT ", geom[[i1]], " -> FAKE COLUMN ADDED TO DATA FRAME ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", NAMED \"fake_x\" FOR FINAL DRAWING") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -}else{ -if(all(geom[[i1]] == "geom_hline")){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(x) == 1, "x", paste0("x NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ": x ARGUMENT MUST BE NULL IF ", ifelse(length(geom) == 1, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_hline\"") +# 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 = " ")) text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } -tempo <- fun_check(data = x[[i1]], data.name = ifelse(length(x) == 1, "x", paste0("x NUMBER ", i1)), class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -} -if(is.null(y[[i1]])){ -if(all(geom[[i1]] != "geom_vline")){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(y) == 1, "y", paste0("y NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ": y ARGUMENT CANNOT BE NULL EXCEPT IF ", ifelse(length(geom) == 1, "y", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_vline\"\nHERE geom ARGUMENT IS: ", paste(geom[[i1]], collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else{ -y[[i1]] <- "fake_y" -data1[[i1]] <- cbind(data1[[i1]], fake_y = NA) -data1[[i1]][, "fake_y"] <- as.numeric(data1[[i1]][, "fake_y"]) +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] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL ", ifelse(length(y) == 1, "y", paste0("y NUMBER ", i1)), " ARGUMENT ASSOCIATED TO ", ifelse(length(geom) == 1, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT ", geom[[i1]], " -> FAKE COLUMN ADDED TO DATA FRAME ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", NAMED \"fake_y\" FOR FINAL DRAWING") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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))) } -}else{ -if(all(geom[[i1]] == "geom_vline")){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(y) == 1, "y", paste0("y NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ": y ARGUMENT MUST BE NULL IF ", ifelse(length(geom) == 1, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_vline\"") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -tempo <- fun_check(data = y[[i1]], data.name = ifelse(length(y) == 1, "y", paste0("y NUMBER ", i1)), class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +if(any(categ == tempo.output$ini[i3])){ +categ[categ == tempo.output$ini[i3]] <- tempo.output$post[i3] +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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))) } -if( ! (x[[i1]] %in% names(data1[[i1]]))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(x) == 1, "x", paste0("x NUMBER ", i1)), " ARGUMENT MUST BE A COLUMN NAME OF ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1))) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) } -if( ! (y[[i1]] %in% names(data1[[i1]]))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(y) == 1, "y", paste0("y NUMBER ", i1)), " ARGUMENT MUST BE A COLUMN NAME OF ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1))) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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))) } +# end reserved word checking # na detection and removal (done now to be sure of the correct length of categ) -if(x[[i1]] == "fake_x" & y[[i1]] == "fake_y"){ # because the code cannot accept to be both "fake_x" and "fake_y" at the same time -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 2\nTHE CODE CANNOT ACCEPT x AND y TO BE \"fake_x\" AND \"fake_y\" IN THE SAME DATA FRAME ", i1, " \n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(is.na(data1[[i1]][, c(if(x[[i1]] == "fake_x"){NULL}else{x[[i1]]}, if(y[[i1]] == "fake_y"){NULL}else{y[[i1]]})]))){ -tempo.removed.row.nb <- unlist(lapply(lapply(c(data1[[i1]][c(if(x[[i1]] == "fake_x"){NULL}else{x[[i1]]}, if(y[[i1]] == "fake_y"){NULL}else{y[[i1]]})]), FUN = is.na), FUN = which)) -removed.row.nb[[i1]] <- c(removed.row.nb[[i1]], tempo.removed.row.nb) -# report of removed rows will be performed at the very end -data1[[i1]] <- data1[[i1]][-tempo.removed.row.nb, ] +if(any(is.na(data1[, c(y, categ)]))){ +removed.row.nb <- unlist(lapply(lapply(c(data1[c(y, categ)]), FUN = is.na), FUN = which)) +removed.rows <- data1[removed.row.nb, ] +data1 <- data1[-removed.row.nb, ] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NA DETECTED IN COLUMN ", if(x[[i1]] == "fake_x"){""}else{ifelse(length(x) == 1, "x", paste0("x NUMBER ", i1))}, if(x[[i1]] != "fake_x" & y[[i1]] != "fake_y"){" AND "}, if(y[[i1]] == "fake_y"){""}else{ifelse(length(y) == 1, "y", paste0("y NUMBER ", i1))}, " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ". CORRESPONDING ROWS HAVE BEEN REMOVED (SEE $removed.row.nb AND $removed.rows)") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NA DETECTED IN COLUMN ", paste(c(y, categ), 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))) +}else{ +removed.row.nb <- NULL +removed.rows <- NULL } # end na detection and removal (done now to be sure of the correct length of categ) -tempo <- fun_check(data = data1[[i1]][, x[[i1]]], data.name = ifelse(length(x) == 1, "x OF data1", paste0("x NUMBER ", i1, " OF data1 NUMBER ", i1)), class = "vector", mode = "numeric", na.contain = ifelse(x[[i1]] == "fake_x", TRUE, FALSE), fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = data1[[i1]][, y[[i1]]], data.name = ifelse(length(y) == 1, "y OF data1", paste0("y NUMBER ", i1, " OF data1 NUMBER ", i1)), class = "vector", mode = "numeric", na.contain = ifelse(y[[i1]] == "fake_y", TRUE, FALSE), fun.name = function.name) ; eval(ee) -if(( ! is.null(categ)) & ( ! is.null(categ[[i1]]))){ # if categ[[i1]] = NULL, fake_categ will be created later on -tempo <- fun_check(data = categ[[i1]], data.name = ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)),, class = "vector", mode = "character", length = 1, fun.name = function.name) -if( ! (categ[[i1]] %in% names(data1[[i1]]))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " ARGUMENT MUST BE A COLUMN NAME OF ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1))) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -# na detection and removal (done now to be sure of the correct length of categ) -if(any(is.na(data1[[i1]][, categ[[i1]]]))){ -tempo.removed.row.nb <- unlist(lapply(lapply(c(data1[[i1]][categ[[i1]]]), FUN = is.na), FUN = which)) -removed.row.nb[[i1]] <- c(removed.row.nb[[i1]], tempo.removed.row.nb) -# report of removed rows will be performed at the very end -data1[[i1]] <- data1[[i1]][-tempo.removed.row.nb, ] +for(i1 in 1:length(categ)){ +if(any(is.na(data1[, categ[i1]]))){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", THE CATEGORY COLUMN:\n", paste(categ[[i1]], collapse = " "), "\nCONTAINS NA") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN categ NUMBER ", i1, " IN data1, THE CATEGORY COLUMN ", categ[i1], " CONTAINS NA") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -# end na detection and removal (done now to be sure of the correct length of categ) -tempo1 <- fun_check(data = data1[[i1]][, categ[[i1]]], data.name = ifelse(length(categ) == 1, "categ OF data1", paste0("categ NUMBER ", i1, " OF data1 NUMBER ", i1)), class = "vector", mode = "character", na.contain = FALSE, fun.name = function.name, print = FALSE) -tempo2 <- fun_check(data = data1[[i1]][, categ[[i1]]], data.name = ifelse(length(categ) == 1, "categ OF data1", paste0("categ NUMBER ", i1, " OF data1 NUMBER ", i1)), class = "factor", na.contain = FALSE, fun.name = function.name, print = FALSE) +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, ": ", ifelse(length(categ) == 1, "categ OF data1", paste0("categ NUMBER ", i1, " OF data1 NUMBER ", i1)), " MUST BE A FACTOR OR CHARACTER VECTOR") +tempo.cat <- paste0("ERROR IN ", function.name, ": ", paste0("categ NUMBER ", i1, " OF data1"), " MUST BE A FACTOR OR CHARACTER VECTOR\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) }else if(tempo1$problem == FALSE){ -data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", THE CHARACTER COLUMN HAS BEEN CONVERTED TO FACTOR") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN categ NUMBER ", i1, " IN data1, THE CHARACTER COLUMN HAS BEEN CONVERTED TO FACTOR") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) - } -if(geom[[i1]] == "geom_vline" | geom[[i1]] == "geom_hline"){ -if(length(unique(data1[[i1]][, categ[[i1]]])) != nrow(data1[[i1]])){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(geom) == 1, "geom OF data1", paste0("geom NUMBER ", i1, " OF data1 NUMBER ", i1)), " ARGUMENT IS ", geom[[i1]], ", MEANING THAT ", ifelse(length(categ) == 1, "categ OF data1", paste0("categ NUMBER ", i1, " OF data1 NUMBER ", i1)), " MUST HAVE A DIFFERENT CLASS PER LINE OF data1 (ONE x VALUE PER CLASS)") +data1[, categ[i1]] <- factor(data1[, categ[i1]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +} +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\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) -} -} -}else if(( ! is.null(categ)) & is.null(categ[[i1]])){ # if categ[[i1]] = NULL, fake_categ will be created. BEWARE: is.null(categ[[i1]]) means no legend display (see above), because categ has not been precised. This also means a single color for data1[[i1]] -if(length(color[[i1]]) > 1){ # 0 means is.null(color[[i1]]) and 1 is ok -> single color for data1[[i1]] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " ARGUMENT BUT CORRESPONDING COLORS IN ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " HAS LENGTH OVER 1\n", paste(color[[i1]], collapse = " "), "\nWHICH IS NOT COMPATIBLE WITH NULL CATEG -> COLOR RESET TO A SINGLE COLOR") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -color[[i1]] <- NULL # will provide a single color below -} -categ[[i1]] <- "fake_categ" -data1[[i1]] <- cbind(data1[[i1]], fake_categ = "") -# inactivated because give a different color to different "Line_" categ while a single color for all the data1[[i1]] required. Thus, put back after the color management -# if(geom[[i1]] == "geom_hline" | geom[[i1]] == "geom_vline"){ -# data1[[i1]][, "fake_categ"] <- paste0("Line_", 1:nrow(data1[[i1]])) -# }else{ -data1[[i1]][, "fake_categ"] <- data1[[i1]][, "fake_categ"] # as.numeric("") create a vector of NA but class numeric -# } +}else if(tempo$problem == FALSE){ +for(i3 in 1:length(categ.class.order)){ +if(is.null(categ.class.order[[i3]])){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " ARGUMENT -> FAKE COLUMN ADDED TO DATA FRAME ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", NAMED \"fake_categ\" FOR FINAL DRAWING") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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 +}else 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 = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}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\nHERE IT IS:\nCOMPARTMENT ", i3, " OF categ.class.order:", paste(categ.class.order[[i3]], collapse = " "), "\nCOLUMN ", categ[i3], " OF data1: ", paste( unique(data1[, categ[i3]]), collapse = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else{ +data1[, categ[i3]] <- factor(data1[, categ[i3]], levels = categ.class.order[[i3]]) # reorder the factor + } -if( ! is.null(legend.name[[i1]])){ -tempo <- fun_check(data = legend.name[[i1]], data.name = ifelse(length(legend.name) == 1, "legend.name", paste0("legend.name NUMBER ", i1)),, class = "vector", mode = "character", length = 1, fun.name = function.name) } -if( ! is.null(color)){ # if color is NULL, will be filled later on -# check the nature of color -if(is.null(color[[i1]])){ -compart.null.color <- compart.null.color + 1 -color[[i1]] <- grey(compart.null.color / 8) # cannot be more than 7 overlays. Thus 7 different greys. 8/8 is excluded because white dots -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL COLOR IN ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", SINGLE COLOR ", paste(color[[i1]], collapse = " "), " HAS BEEN ATTRIBUTED") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -tempo1 <- fun_check(data = color[[i1]], data.name = ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name, print = FALSE) -tempo2 <- fun_check(data = color[[i1]], data.name = ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), class = "factor", na.contain = TRUE, fun.name = function.name, print = FALSE) +} +if( ! is.null(categ.legend.name)){ +tempo <- fun_check(data = categ.legend.name, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) +}else{ +categ.legend.name <- categ[length(categ)] # if only categ1, then legend name of categ1, if length(categ) == 2, then legend name of categ2 +} +if( ! is.null(categ.color)){ +# check the nature of 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.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR") # integer possible because dealt above +# 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 == TRUE){ +tempo.cat <- paste0("ERROR IN ", function.name, ": categ.color MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR\n\n================\n\n") # integer possible because dealt above text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) -}else if( ! (all(color[[i1]] %in% colors() | grepl(pattern = "^#", color[[i1]])))){ # check that all strings of low.color start by # -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors(): ", paste(unique(color[[i1]]), collapse = " ")) +}else{ # convert integers into colors +categ.color <- fun_gg_palette(max(categ.color, na.rm = TRUE)) +} +# 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 = " ")) text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } -if(any(is.na(color[[i1]]))){ +if(any(is.na(categ.color))){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", THE COLORS:\n", paste(unique(color[[i1]]), collapse = " "), "\nCONTAINS NA") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": categ.color ARGUMENT CONTAINS NA") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } # end check the nature of color # check the length of color -if(is.null(categ) & length(color[[i1]]) != 1){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT MUST BE A SINGLE COLOR IF categ IS NULL") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if( ! is.null(categ)){ # No problem of NA management by ggplot2 because already removed -if(categ[[i1]] == "fake_categ" & length(color[[i1]]) != 1){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT MUST BE A SINGLE COLOR IF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IS NULL") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(length(color[[i1]]) == length(unique(data1[[i1]][, categ[[i1]]]))){ # here length(color) is equal to the different number of categ -data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +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(unique(data1[, categ[i0]]))){ # here length(categ.color) is equal to the different number of categ +data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +data1 <- data.frame(data1, categ.color = data1[, categ[i0]]) +levels(data1$categ.color) <- categ.color warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", THE FOLLOWING COLORS:\n", paste(color[[i1]], collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[[i1]][, categ[[i1]]])), collapse = " ")) +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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(color[[i1]]) == length(data1[[i1]][, categ[[i1]]])){# here length(color) is equal to nrow(data1[[i1]]) -> Modif to have length(color) equal to the different number of categ (length(color) == length(levels(data1[[i1]][, categ[[i1]]]))) -data1[[i1]] <- cbind(data1[[i1]], color = color[[i1]]) -tempo.check <- unique(data1[[i1]][ , c(categ[[i1]], "color")]) -if( ! (nrow(data1[[i1]]) == length(color[[i1]]) & nrow(tempo.check) == length(unique(data1[[i1]][ , categ[[i1]]])))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT HAS THE LENGTH OF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), " COLUMN VALUES\nBUT IS INCORRECTLY ASSOCIATED TO EACH CLASS OF THIS categ:\n", paste(unique(mapply(FUN = "paste", data1[[i1]][ ,categ[[i1]]], data1[[i1]][ ,"color"])), collapse = "\n")) +}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")) text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) }else{ -data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order -color[[i1]] <- unique(color[[i1]][order(data1[[i1]][, categ[[i1]]])]) # Modif to have length(color) equal to the different number of categ (length(color) == length(levels(data1[[i1]][, categ[[i1]]]))) +data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +categ.color <- unique(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]]))) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count, ") FROM FUNCTION ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT HAS THE LENGTH OF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), " COLUMN VALUES\nCOLORS HAVE BEEN RESPECTIVELY ASSOCIATED TO EACH CLASS OF categ AS:\n", paste(levels(factor(data1[[i1]][, categ[[i1]]])), collapse = " "), "\n", paste(color[[i1]], collapse = " ")) +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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))) } -}else if(length(color[[i1]]) == 1){ -data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order -color[[i1]] <- rep(color[[i1]], length(levels(data1[[i1]][, categ[[i1]]]))) +}else if(length(categ.color) == 1){ +data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +data1 <- data.frame(data1, categ.color = categ.color) +categ.color <- rep(categ.color, length(levels(data1[, categ[i0]]))) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), ", COLOR HAS LENGTH 1 MEANING THAT ALL THE DIFFERENT CLASSES OF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), "\n", paste(levels(factor(data1[[i1]][, categ[[i1]]])), collapse = " "), "\nWILL HAVE THE SAME COLOR\n", paste(color[[i1]], collapse = " ")) +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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))) }else{ -tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT MUST BE (1) LENGTH 1, OR (2) THE LENGTH OF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), " COLUMN VALUES, OR (3) THE LENGTH OF THE CLASSES IN THIS COLUMN. HERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LENGTH ", length(data1[[i1]][, categ[[i1]]]), " AND CATEG CLASS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]]))) +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\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } -} -} -if((geom[[i1]] == "geom_hline" | geom[[i1]] == "geom_vline") & ! is.null(categ[[i1]])){ # add here after the color management, to deal with the different lines to plot inside any data[[i1]] -if(categ[[i1]] == "fake_categ"){ -data1[[i1]][, "fake_categ"] <- paste0("Line_", 1:nrow(data1[[i1]])) -} -} -tempo <- fun_check(data = alpha[[i1]], data.name = ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) -} -if(length(data1) > 1){ -if(length(unique(unlist(x))) > 1){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE x ARGUMENT DOES NOT CONTAIN IDENTICAL COLUMN NAMES:\n", paste(unlist(x), collapse = " "), "\nX-AXIS OVERLAYING DIFFERENT VARIABLES?") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -} -if(length(data1) > 1){ -if(length(unique(unlist(y))) > 1){ +}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]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +categ.color <- fun_gg_palette(length(levels(data1[, categ[i0]]))) +data1 <- data.frame(data1, categ.color = data1[, categ[i0]]) +levels(data1$categ.color) <- categ.color warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE y ARGUMENT DOES NOT CONTAIN IDENTICAL COLUMN NAMES:\n", paste(unlist(y), collapse = " "), "\nY-AXIS OVERLAYING DIFFERENT VARIABLES?") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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))) } +tempo <- fun_check(data = bar.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) +if( ! is.null(error.disp)){ +tempo <- fun_check(data = error.disp, options = c("SD", "SD.TOP", "SEM", "SEM.TOP"), length = 1, fun.name = function.name) ; eval(ee) } -if(sum(geom %in% "geom_point") > 3){ -tempo.cat <- paste0("ERROR IN ", function.name, ": geom ARGUMENT CANNOT HAVE MORE THAN THREE \"geom_point\" ELEMENTS") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(length(geom) - sum(geom %in% "geom_point") > 3){ -tempo.cat <- paste0("ERROR IN ", function.name, ": geom ARGUMENT CANNOT HAVE MORE THAN THREE LINE ELEMENTS") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -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 = line.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -if( ! is.null(xlim)){ -tempo <- fun_check(data = xlim, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & any(xlim %in% c(Inf, -Inf))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": xlim ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES") +tempo <- fun_check(data = error.whisker.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) +if( ! is.null(dot.color)){ +# check the nature of 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){ +# 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 == TRUE){ +tempo.cat <- paste0("ERROR IN ", function.name, ": dot.color MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR\n\n================\n\n") # integer possible because dealt above text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) +}else{ # convert integers into colors +dot.color <- fun_gg_palette(max(dot.color, na.rm = TRUE)) } +# end integer colors into gg_palette } -if( ! is.null(xlab)){ -if(all(class(xlab) %in% "expression")){ # to deal with math symbols -tempo <- fun_check(data = xlab, class = "expression", length = 1, fun.name = function.name) ; eval(ee) -}else{ -tempo <- fun_check(data = xlab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -} -} -tempo <- fun_check(data = xlog, options = c("no", "log2", "log10"), length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & xlog != "no"){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": xlog ARGUMENT SET TO ", xlog, ".\nVALUES FROM THE x ARGUMENT COLUMN OF THE data1 DATA FRAME MUST BE ALREADY ", toupper(xlog), " TRANSFORMED, AS THE xlog ARGUMENT JUST MODIFIES THE AXIS SCALE") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -if( ! is.null(xlim)){ -if(any(xlim <= 0)){ +if(all(dot.color == "same") & length(dot.color) == 1){ +dot.color <- categ.color # same color of the dots as the corresponding bar color warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": xlim ARGUMENT CAN SPAN ZERO OR NEGATIVE VALUES IF xlog ARGUMENT IS SET TO ", xlog, " BECAUSE THIS LATTER ARGUMENT DOES NOT TRANSFORM DATA, JUST MODIFIES THE AXIS SCALE") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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(levels(factor(dot.color)), collapse = " ")) warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -}else if(any( ! is.finite(if(xlog == "log10"){10^xlim}else{2^xlim}))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": xlim ARGUMENT RETURNS INF WITH THE xlog ARGUMENT SET TO ", xlog, "\nAS SCALE COMPUTATION IS ", ifelse(xlog == "log10", 10, 2), "^xlim:\n", paste(ifelse(xlog == "log10", 10, 2)^xlim, collapse = " "), "\nARE YOU SURE THAT xlim ARGUMENT HAS BEEN SPECIFIED WITH VALUES ALREADY IN LOG SCALE?\n", paste(xlim, collapse = " ")) +}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 = " ")) text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } +if(any(is.na(dot.color))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": dot.color ARGUMENT CONTAINS NA") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -} -if( ! is.null(x.tick.nb)){ -tempo <- fun_check(data = x.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & x.tick.nb < 0){ -tempo.cat <- paste0("ERROR IN ", function.name, ": x.tick.nb ARGUMENT MUST BE A NON NULL POSITIVE INTEGER") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -} -if( ! is.null(x.inter.tick.nb)){ -tempo <- fun_check(data = x.inter.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & x.inter.tick.nb < 0){ -tempo.cat <- paste0("ERROR IN ", function.name, ": x.inter.tick.nb ARGUMENT MUST BE A NON NULL POSITIVE INTEGER") +# end check the nature of color +# check the length of color +# No problem of NA management by ggplot2 because already removed +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(unique(data1[, categ[i0]]))){ # here length(dot.color) is equal to the different number of categ +data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +data1 <- data.frame(data1, dot.color = data1[, categ[i0]]) +levels(data1$dot.color) <- dot.color +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +data1 <- data.frame(data1, dot.color = dot.color) +dot.color <- rep(dot.color, length(levels(data1[, categ[i0]]))) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } } -tempo <- fun_check(data = x.left.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = x.right.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = dot.tidy, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = dot.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.border.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) if( ! is.null(ylim)){ tempo <- fun_check(data = ylim, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee) if(tempo$problem == FALSE & any(ylim %in% c(Inf, -Inf))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ylim ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES") +tempo.cat <- paste0("ERROR IN ", function.name, ": ylim ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES\n\n================\n\n") + text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } } -if( ! is.null(ylab)){ -if(all(class(ylab) %in% "expression")){ # to deal with math symbols -tempo <- fun_check(data = ylab, class = "expression", length = 1, fun.name = function.name) ; eval(ee) -}else{ -tempo <- fun_check(data = ylab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -} -} tempo <- fun_check(data = ylog, options = c("no", "log2", "log10"), length = 1, fun.name = function.name) ; eval(ee) if(tempo$problem == FALSE & ylog != "no"){ warn.count <- warn.count + 1 @@ -5168,7 +5011,7 @@ arg.check <- c(arg.check, TRUE) 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") +tempo.cat <- paste0("ERROR IN ", function.name, ": y.tick.nb ARGUMENT MUST BE A NON NULL POSITIVE INTEGER\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } @@ -5176,29 +5019,51 @@ arg.check <- c(arg.check, TRUE) 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") +tempo.cat <- paste0("ERROR IN ", function.name, ": y.inter.tick.nb ARGUMENT MUST BE A NON NULL POSITIVE INTEGER\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } } -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) -tempo <- fun_check(data = xy.include.zero, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = y.include.zero, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) # inactivated because xlim and ylim already log transformed -# if(tempo$problem == FALSE & ylog == TRUE & xy.include.zero == TRUE){ -# warn.count <- warn.count + 1 ; tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": BOTH ylog AND xy.include.zero ARGUMENTS SET TO TRUE -> xy.include.zero ARGUMENT RESET TO FALSE") +# if(tempo$problem == FALSE & ylog != "no" & y.include.zero == TRUE){ +# tempo.warn <- paste0("FROM FUNCTION ", function.name, ": ylog ARGUMENT SET TO ", ylog, " 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))) # } +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) +} +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) +if( ! is.null(xlab)){ +if(all(class(xlab) %in% "expression")){ # to deal with math symbols +tempo <- fun_check(data = xlab, class = "expression", length = 1, fun.name = function.name) ; eval(ee) +}else{ +tempo <- fun_check(data = xlab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +} +} +if( ! is.null(ylab)){ +if(all(class(ylab) %in% "expression")){ # to deal with math symbols +tempo <- fun_check(data = ylab, class = "expression", length = 1, fun.name = function.name) ; eval(ee) +}else{ +tempo <- fun_check(data = ylab, class = "vector", mode = "character", 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) +if(tempo$problem == FALSE & ylog != "no" & vertical == FALSE){ +vertical <- TRUE +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": BECAUSE OF A BUG IN ggplot2, CANNOT FLIP BARS HORIZONTALLY WITH A YLOG SCALE -> vertical ARGUMENT RESET TO TRUE") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} 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 = 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 = show.legend, class = "logical", length = 1, 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 = 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 = raster, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -if( ! is.null(vectorial.limit)){ -tempo <- fun_check(data = vectorial.limit, class = "vector", typeof = "integer", neg.values = FALSE, double.as.integer.allowed = TRUE, 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)){ @@ -5211,7 +5076,7 @@ arg.check <- c(arg.check, TRUE) 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 ) +}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) @@ -5221,7 +5086,7 @@ tempo <- fun_check(data = warn.print, class = "logical", length = 1, fun.name = 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))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE lib.path PARAMETER DOES NOT EXISTS: ", lib.path) +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE lib.path PARAMETER DOES NOT EXISTS: ", lib.path, "\n\n============\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } @@ -5230,65 +5095,142 @@ if(any(arg.check) == TRUE){ stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } # 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 argument checking +# end argument checking (and modification for proper color management) # package checking fun_pack(req.package = c("ggplot2"), lib.path = lib.path) -# packages Cairo and grid tested by fun_gg_point_rast() +fun_pack(req.package = c("scales"), lib.path = lib.path) # end package checking # main code -# axes management -if(is.null(xlim)){ -if(any(unlist(mapply(FUN = "[[", data1, x, SIMPLIFY = FALSE)) %in% c(Inf, -Inf))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE x COLUMN IN data1 CONTAINS -Inf OR Inf VALUES THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -xlim <- suppressWarnings(range(unlist(mapply(FUN = "[[", data1, x, SIMPLIFY = FALSE)), na.rm = TRUE, finite = TRUE)) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only. xlim added here. If NULL, ok if x argument has values -if(suppressWarnings(all(xlim %in% c(Inf, -Inf)))){ -if(all(unlist(geom) == "geom_hline")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " NOT POSSIBLE TO ONLY DRAW geom_hline KIND OF LINES IF xlim ARGUMENT IS SET TO NULL, SINCE NO X-AXIS DEFINED (", ifelse(length(x) == 1, "x", paste0("x NUMBER ", i1)), " ARGUMENT MUST BE NULL FOR THESE KIND OF LINES)\n\n================\n\n") +if(length(categ) == 1){ +# new data frames for bar and error bars +mean.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]]) ; names(x.env) <-categ[1] ; x.env}, FUN = mean, na.rm = TRUE) +sd.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]]) ; names(x.env) <-categ[1] ; x.env}, FUN = sd, na.rm = TRUE) +nb.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]]) ; names(x.env) <- categ[1] ; x.env}, FUN = function(x.env2){length(x.env2[ ! is.na(x.env2)])}) +if( ! all(identical(mean.dataframe[, categ[1]], sd.dataframe[, categ[1]]) & identical(mean.dataframe[, categ[1]], nb.dataframe[, categ[1]]))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": aggregate OUTPUT IS DIFFERENT IN TERM OF CLASS ORDER FOR mean.dataframe, sd.dataframe AND nb.dataframe. CODE HAS TO BE MODIFIED\n\n================\n\n") stop(tempo.cat, call. = FALSE) }else{ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " xlim ARGUMENT MADE OF NA, -Inf OR Inf ONLY: ", paste(xlim, collapse = " "), "\n\n================\n\n") +sem.dataframe <- sd.dataframe +sem.dataframe[, y] <- sd.dataframe[, y] / (nb.dataframe[, y])^0.5 +} +# end new data frames for bar and error bars +# 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 bar 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(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[1]))) # fill because this is what is used with geom_bar +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(stroke = dot.border.size, size = dot.size, alpha = dot.alpha, pch = 21)) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot()) # to easily have the equivalent of the grouped bars +dot.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[1]] +if( ! is.null(dot.color)){ +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 = 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] +if( ! identical(dot.coord$y, dot.coord$y.check)){ +tempo.cat <- paste0("\n\n================\n\nERROR 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, call. = FALSE) +} +} +# end per bar dots coordinates recovery +}else if(length(categ) == 2){ +# new data frames for bar and error bars +mean.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]], data1[, categ[2]]) ; names(x.env) <- c(categ[1], categ[2]) ; x.env}, FUN = mean, na.rm = TRUE) +sd.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]], data1[, categ[2]]) ; names(x.env) <- c(categ[1], categ[2]) ; x.env}, FUN = sd, na.rm = TRUE) +nb.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]], data1[, categ[2]]) ; names(x.env) <- c(categ[1], categ[2]) ; x.env}, FUN = function(x.env2){length(x.env2[ ! is.na(x.env2)])}) +tempo.check.mean <- mapply(FUN = "paste", mean.dataframe[, categ[1]], mean.dataframe[, categ[2]], sep = "_") +tempo.check.sd <- mapply(FUN = "paste", sd.dataframe[, categ[1]], sd.dataframe[, categ[2]], sep = "_") +tempo.check.nb <- mapply(FUN = "paste", nb.dataframe[, categ[1]], nb.dataframe[, categ[2]], sep = "_") +if( ! all(identical(tempo.check.mean, tempo.check.sd) & identical(tempo.check.mean, tempo.check.nb))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": aggregate OUTPUT IS DIFFERENT IN TERM OF CLASS ORDER FOR mean.dataframe, sd.dataframe AND nb.dataframe. CODE HAS TO BE MODIFIED\n\n================\n\n") stop(tempo.cat, call. = FALSE) +}else{ +sem.dataframe <- sd.dataframe +sem.dataframe[, y] <- sd.dataframe[, y] / (nb.dataframe[, y])^0.5 } +# end new data frames for bar and error bars +# 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 bar 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(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[2]))) # fill because this is what is used with geom_bar +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(stroke = dot.border.size, size = dot.size, alpha = dot.alpha, pch = 21)) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot()) # to easily have the equivalent of the grouped bars +dot.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[1]] +if( ! is.null(dot.color)){ +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 = 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] +if( ! (identical(dot.coord$y, dot.coord$y.check) & identical(dot.coord$group, dot.coord$categ.check))){ +tempo.cat <- paste0("\n\n================\n\nERROR 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, call. = FALSE) } } -xlim.order <- order(xlim) # to deal with inverse axis -# print(xlim.order) -xlim <- sort(xlim) -xlim[1] <- xlim[1] - abs(xlim[2] - xlim[1]) * ifelse(diff(xlim.order) > 0, x.right.extra.margin, x.left.extra.margin) # diff(xlim.order) > 0 means not inversed axis -xlim[2] <- xlim[2] + abs(xlim[2] - xlim[1]) * ifelse(diff(xlim.order) > 0, x.left.extra.margin, x.right.extra.margin) # diff(xlim.order) > 0 means not inversed axis -if(xy.include.zero == TRUE){ # no need to check xlog != "no" because done before -xlim <- range(c(xlim, 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 +}else{ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -xlim <- xlim[xlim.order] -if(any(is.na(xlim))){ +data2 <- mean.dataframe +if( ! is.null(error.disp)){ +if(error.disp == "SD"){ +data2 <- data.frame(data2, SD = sd.dataframe[, y], ERROR.INF = mean.dataframe[, y] - sd.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sd.dataframe[, y]) +}else if(error.disp == "SD.TOP"){ +data2 <- data.frame(data2, SD = sd.dataframe[, y], ERROR.INF = mean.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sd.dataframe[, y]) +}else if(error.disp == "SEM"){ +data2 <- data.frame(data2, SEM = sem.dataframe[, y], ERROR.INF = mean.dataframe[, y] - sem.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sem.dataframe[, y]) +}else if(error.disp == "SEM.TOP"){ +data2 <- data.frame(data2, SEM = sem.dataframe[, y], ERROR.INF = mean.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sem.dataframe[, y]) +}else{ tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 3\n\n============\n\n") stop(tempo.cat, call. = FALSE) } +} +# stat output +stat <- data2 +names(stat)[names(stat) == y] <- "MEAN" +# end stat output +# range depending on means and error bars if(is.null(ylim)){ -if(any(unlist(mapply(FUN = "[[", data1, y, SIMPLIFY = FALSE)) %in% c(Inf, -Inf))){ +if(is.null(dot.color)){ # no dots plotted +if( ! is.null(error.disp)){ +if(any(c(data2[, "ERROR.INF"], data2[, "ERROR.SUP"]) %in% c(Inf, -Inf))){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE y COLUMN IN data1 CONTAINS -Inf OR Inf VALUES THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE data2 ARGUMENT CONTAINS -Inf OR Inf VALUES IN THE ERROR.INF OR ERROR.SUP COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -ylim <- suppressWarnings(range(unlist(mapply(FUN = "[[", data1, y, SIMPLIFY = FALSE)), na.rm = TRUE, finite = TRUE)) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only. ylim added here. If NULL, ok if y argument has values -if(suppressWarnings(all(ylim %in% c(Inf, -Inf)))){ # happen when y is only NULL -if(all(unlist(geom) == "geom_vline")){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " NOT POSSIBLE TO ONLY DRAW geom_vline KIND OF LINES IF ylim ARGUMENT IS SET TO NULL, SINCE NO Y-AXIS DEFINED (", ifelse(length(y) == 1, "y", paste0("y NUMBER ", i1)), " ARGUMENT MUST BE NULL FOR THESE KIND OF LINES)\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +ylim <- range(c(data2[, "ERROR.INF"], data2[, "ERROR.SUP"]), 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 }else{ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " ylim ARGUMENT MADE OF NA, -Inf OR Inf ONLY: ", paste(ylim, collapse = " "), "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +if(any(data2[, y] %in% c(Inf, -Inf))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE data2 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))) +} +ylim <- range(data2[, 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 +} +}else{ +if(any(data1[, y] %in% c(Inf, -Inf))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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))) +} +ylim <- 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 } } +if(suppressWarnings(all(ylim %in% c(Inf, -Inf)))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED YLIM CONTAINS Inf VALUES, BECAUSE VALUES FROM data2 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } +# end range depending on means and error bars ylim.order <- order(ylim) # to deal with inverse axis ylim <- sort(ylim) ylim[1] <- ylim[1] - abs(ylim[2] - ylim[1]) * ifelse(diff(ylim.order) > 0, y.bottom.extra.margin, y.top.extra.margin) # diff(ylim.order) > 0 means not inversed axis ylim[2] <- ylim[2] + abs(ylim[2] - ylim[1]) * ifelse(diff(ylim.order) > 0, y.top.extra.margin, y.bottom.extra.margin) # diff(ylim.order) > 0 means not inversed axis -if(xy.include.zero == TRUE){ # no need to check ylog != "no" because done before +if(y.include.zero == TRUE){ # no need to check ylog != "no" because done before ylim <- range(c(ylim, 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 } ylim <- ylim[ylim.order] @@ -5296,127 +5238,34 @@ if(any(is.na(ylim))){ tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 4\n\n============\n\n") stop(tempo.cat, call. = FALSE) } -# end axes management -# create a fake categ if NULL to deal with legend display -if(is.null(categ)){ -categ <- vector("list", length(data1)) -categ[] <- "fake_categ" -for(i2 in 1:length(data1)){ -data1[[i2]] <- cbind(data1[[i2]], fake_categ = "") -if(geom[[i2]] == "geom_hline" | geom[[i2]] == "geom_vline"){ -data1[[i2]][, "fake_categ"] <- paste0("Line_", 1:nrow(data1[[i2]])) -} -} -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL categ ARGUMENT -> FAKE COLUMN ADDED TO EACH DATA FRAME IN data1, NAMED \"fake_categ\" AND FILLED WITH \"\"") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -# end create a fake categ if NULL to deal with legend display -# vector of color with length as in data1 -if(is.null(color)){ -color <- vector("list", length(data1)) -length.categ.list <- lapply(lapply(mapply(FUN = "[[", data1, categ, SIMPLIFY = FALSE), FUN = unique), FUN = function(x){length(x[ ! is.na(x)])}) -length.categ.list[sapply(categ, FUN = "==", "fake_categ")] <- 1 # when is.null(color), a single color for all the dots or lines of data[[i1]] that contain "fake_categ" category -total.categ.length <- sum(unlist(length.categ.list), na.rm = TRUE) -tempo.color <- fun_gg_palette(total.categ.length) -tempo.count <- 0 -for(i3 in 1:length(data1)){ -color[[i3]] <- tempo.color[(1:length.categ.list[[i3]]) + tempo.count] -tempo.count <- tempo.count + length.categ.list[[i3]] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NULL color ARGUMENT -> COLORS RESPECTIVELY ATTRIBUTED TO EACH CLASS OF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i3)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i3)), ":\n", paste(unlist(color), collapse = " "), "\n", paste(names(data1), collapse = " ")) -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -} -# end vector of color with length as in data1 -# last check -for(i1 in 1:length(data1)){ -if(categ[[i1]] != "fake_categ" & length(color[[i1]]) != length(unique(data1[[i1]][, categ[[i1]]]))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " LAST CHECK: ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT MUST HAVE THE LENGTH OF LEVELS OF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), "\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LEVELS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]])), "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else if(categ[[i1]] == "fake_categ" & length(color[[i1]]) != 1){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " LAST CHECK: ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT MUST HAVE LENGTH 1 WHEN ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IS NULL\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -} -# end last check -# conversion of geom_hline and geom_vline -for(i1 in 1:length(data1)){ -if(geom[[i1]] == "geom_hline" | geom[[i1]] == "geom_vline"){ -final.data.frame <- data.frame() -for(i3 in 1:nrow(data1[[i1]])){ -tempo.data.frame <- rbind(data1[[i1]][i3, ], data1[[i1]][i3, ]) -if(geom[[i1]] == "geom_hline"){ -tempo.data.frame[, x[[i1]]] <- xlim -}else if(geom[[i1]] == "geom_vline"){ -tempo.data.frame[, y[[i1]]] <- ylim +# width commputations +if(length(categ) == 2){ +bar.width2 <- bar.width / length(unique(data1[, categ[length(categ)]])) # real width of each bar in x-axis unit, among the set of grouped bar. Not relevant if no grouped bars length(categ) == 1 +}else if(length(categ) == 1){ +bar.width2 <- bar.width }else{ tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 5\n\n============\n\n") stop(tempo.cat, call. = FALSE) } -# if(is.null(categ[[i1]])){ -# data1[, "fake_categ"] <- paste0("Line_", i3) -# } #I put that up -final.data.frame <- rbind(final.data.frame, tempo.data.frame) -} -data1[[i1]] <- final.data.frame -geom[[i1]] <- "geom_line" -if(length(color[[i1]]) == 1){ -color[[i1]] <- rep(color[[i1]], length(unique(data1[[i1]][ , categ[[i1]]]))) -}else if(length(color[[i1]]) != length(unique(data1[[i1]][ , categ[[i1]]]))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " geom_hline AND geom_vline CONVERSION TO FIT THE XLIM AND YLIM LIMITS OF THE DATA: ", ifelse(length(color) == 1, "color", paste0("color NUMBER ", i1)), " ARGUMENT MUST HAVE THE LENGTH OF LEVELS OF ", ifelse(length(categ) == 1, "categ", paste0("categ NUMBER ", i1)), " IN ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i1)), "\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LEVELS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]])), "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -} -} -# end conversion of geom_hline and geom_vline -# kind of geom_point (vectorial or raster) -scatter.kind <- vector("list", length = length(data1)) # list of same length as data1, that will be used to use either ggplot2::geom_point() (vectorial dot layer) or fun_gg_point_rast() (raster dot layer) -fix.ratio <- FALSE -if(is.null(vectorial.limit)){ -if(raster == TRUE){ -scatter.kind[] <- "fun_gg_point_rast" # not important to fill everything: will be only used when geom == "geom_point" -fix.ratio <- TRUE -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": RASTER PLOT GENERATED -> ASPECT RATIO OF THE PLOT REGION SET TO 1/1 TO AVOID A BUG OF ELLIPSOID DOT DRAWING") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -}else{ -scatter.kind[] <- "ggplot2::geom_point" -} -}else{ -for(i2 in 1:length(data1)){ -if(geom[[i2]] == "geom_point"){ -if(nrow(data1[[i2]]) <= vectorial.limit){ -scatter.kind[[i2]] <- "ggplot2::geom_point" -}else{ -scatter.kind[[i2]] <- "fun_gg_point_rast" -fix.ratio <- TRUE -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": ", ifelse(length(data1) == 1, "data1", paste0("data1 NUMBER ", i2)), " LAYER AS RASTER (NOT VECTORIAL)") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -} -} -if(any(unlist(scatter.kind) == "fun_gg_point_rast")){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": RASTER PLOT GENERATED -> ASPECT RATIO OF THE PLOT REGION SET TO 1/1 TO AVOID A BUG OF ELLIPSOID DOT DRAWING") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -} -# end kind of geom_point (vectorial or raster) +error.whisker.width <- bar.width * error.whisker.width # real error bar width +dot.jitter <- bar.width2 * dot.jitter # real dot.jitter +# end width commputations +# barplot +# constant part tempo.gg.name <- "gg.indiv.plot." tempo.gg.count <- 0 -# no need loop part 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(xlab)){x[[1]]}else{xlab})) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylab(if(is.null(ylab)){y[[1]]}else{ylab})) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::xlab(if(is.null(xlab)){categ[1]}else{xlab})) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylab(if(is.null(ylab)){y}else{ylab})) 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,") FROM FUNCTION ", function.name, ": \"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. -\nIT IS RECOMMENDED TO USE \"+ theme(aspect.ratio = 1)\" IF RASTER MODE IS ACTIVATED") +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": \"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 } @@ -5431,18 +5280,20 @@ 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 = ggplot2::element_line(colour = "grey75"), -panel.grid.major.y = ggplot2::element_line(colour = "grey75"), -aspect.ratio = if(fix.ratio == TRUE){1}else{NULL} -)) -}else{ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme( +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"), -aspect.ratio = if(fix.ratio == TRUE){1}else{NULL} +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)} )) } }else if(add.check == TRUE & classic == FALSE){ @@ -5457,172 +5308,242 @@ 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"), -aspect.ratio = if(fix.ratio == TRUE){1}else{NULL} -# do not work -> legend.position = "none" # to remove the legend completely: https://www.datanovia.com/en/blog/how-to-remove-legend-from-a-ggplot/ +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)} )) } -# end no need loop part -# loop part -point.count <- 0 -line.count <- 0 -lg.order <- vector(mode = "list", length = 6) # order of the legend -lg.order <- lapply(lg.order, as.numeric) # order of the legend -lg.color <- vector(mode = "list", length = 6) # color of the legend -lg.alpha <- vector(mode = "list", length = 6) # order of the legend -lg.alpha <- lapply(lg.alpha, as.numeric) # alpha of the legend -for(i1 in 1:length(data1)){ -if(geom[[i1]] == "geom_point"){ -point.count <- point.count + 1 -if(point.count == 1){ -fin.lg.disp[[1]] <- legend.disp[[point.count + line.count]] -lg.order[[1]] <- point.count + line.count -lg.color[[1]] <- color[[i1]] -lg.alpha[[1]] <- alpha[[i1]] -class.categ <- levels(factor(data1[[i1]][, categ[[i1]]])) -for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same -tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ] -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], fill = categ[[i1]]), size = dot.size, color = color[[i1]][i5], alpha = alpha[[i1]])) # beware: a single color allowed for color argument outside aesthetic, hence the loop # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -} -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_manual(name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = as.character(color[[i1]]), guide = ggplot2::guide_legend(override.aes = list(colour = color[[i1]], linetype = 0)))) # values are the values of fill. order determines the order in the legend -} -if(point.count == 2){ -fin.lg.disp[[2]] <- legend.disp[[point.count + line.count]] -lg.order[[2]] <- point.count + line.count -lg.color[[2]] <- color[[i1]] -lg.alpha[[2]] <- alpha[[i1]] -class.categ <- levels(factor(data1[[i1]][, categ[[i1]]])) -for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same -tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ] -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], shape = categ[[i1]]), size = dot.size, color = color[[i1]][i5], alpha = alpha[[i1]])) # beware: a single color allowed for color argument outside aesthetic, hence the loop # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -} -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_shape_manual(name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(19, length(color[[i1]])), guide = ggplot2::guide_legend(override.aes = list(colour = color[[i1]], linetype = 0)))) # values are the values of shape -} -if(point.count == 3){ -fin.lg.disp[[3]] <- legend.disp[[point.count + line.count]] -lg.order[[3]] <- point.count + line.count -lg.color[[3]] <- color[[i1]] -lg.alpha[[3]] <- alpha[[i1]] -class.categ <- levels(factor(data1[[i1]][, categ[[i1]]])) -for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same -tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ] -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], stroke = categ[[i1]]), size = dot.size, color = color[[i1]][i5], alpha = alpha[[i1]])) # beware: a single color allowed for color argument outside aesthetic, hence the loop # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -} -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "stroke", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(0.5, length(color[[i1]])), guide = ggplot2::guide_legend(override.aes = list(colour = color[[i1]], linetype = 0)))) # values are the values of stroke -} -}else{ -line.count <- line.count + 1 -if(line.count == 1){ -fin.lg.disp[[4]] <- legend.disp[[point.count + line.count]] -lg.order[[4]] <- point.count + line.count -lg.color[[4]] <- color[[i1]] -lg.alpha[[4]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf -class.categ <- levels(factor(data1[[i1]][, categ[[i1]]])) -for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same -tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ] -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste("ggplot2::", geom[[i1]], sep ="")))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], linetype = categ[[i1]]), color = color[[i1]][i5], size = line.size, lineend = "round", alpha = alpha[[i1]])) # beware: a single color allowed for color argument outside aesthetic, hence the loop # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -} -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(1, length(color[[i1]])), guide = ggplot2::guide_legend(override.aes = list(colour = color[[i1]], shape = NA)))) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, with different values -} -if(line.count == 2){ -fin.lg.disp[[5]] <- legend.disp[[point.count + line.count]] -lg.order[[5]] <- point.count + line.count -lg.color[[5]] <- color[[i1]] -lg.alpha[[5]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf -class.categ <- levels(factor(data1[[i1]][, categ[[i1]]])) -for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same -tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ] -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste("ggplot2::", geom[[i1]], sep ="")))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], alpha = categ[[i1]]), color = color[[i1]][i5], size = line.size, lineend = "round")) # beware: a single color allowed for color argument outside aesthetic, hence the loop # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -} -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(alpha[[i1]], length(color[[i1]])), guide = ggplot2::guide_legend(override.aes = list(colour = color[[i1]], shape = NA)))) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, with different values -} -if(line.count == 3){ -fin.lg.disp[[6]] <- legend.disp[[point.count + line.count]] -lg.order[[6]] <- point.count + line.count -lg.color[[6]] <- color[[i1]] -lg.alpha[[6]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf -class.categ <- levels(factor(data1[[i1]][, categ[[i1]]])) -for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same -tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ] -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste("ggplot2::", geom[[i1]], sep ="")))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], size = categ[[i1]]), color = color[[i1]][i5], alpha = alpha[[i1]], lineend = "round")) # beware: a single color allowed for color argument outside aesthetic, hence the loop # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -} -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "size", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(line.size, length(color[[i1]])), guide = ggplot2::guide_legend(override.aes = list(colour = color[[i1]], shape = NA)))) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, with different values -} -} -} -# end loop part -# legend display -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = if(fin.lg.disp[[1]] == TRUE){ggplot2::guide_legend(order = lg.order[[1]], override.aes = list(alpha = lg.alpha[[1]], color = lg.color[[1]]))}else{FALSE}, shape = if(fin.lg.disp[[2]] == TRUE){ggplot2::guide_legend(order = lg.order[[2]], override.aes = list(alpha = lg.alpha[[2]], color = lg.color[[2]]))}else{FALSE}, stroke = if(fin.lg.disp[[3]] == TRUE){ggplot2::guide_legend(order = lg.order[[3]], override.aes = list(alpha = lg.alpha[[2]], color = lg.color[[3]]))}else{FALSE}, linetype = if(fin.lg.disp[[4]] == TRUE){ggplot2::guide_legend(order = lg.order[[4]], override.aes = list(alpha = lg.alpha[[4]], color = lg.color[[4]]))}else{FALSE}, alpha = if(fin.lg.disp[[5]] == TRUE){ggplot2::guide_legend(order = lg.order[[5]], override.aes = list(alpha = lg.alpha[[5]], color = lg.color[[5]]))}else{FALSE}, size = if(fin.lg.disp[[6]] == TRUE){ggplot2::guide_legend(order = lg.order[[6]], override.aes = list(alpha = lg.alpha[[6]], color = lg.color[[6]]))}else{FALSE})) # clip = "off" to have secondary ticks outside plot region does not work -# end legend display -# scale management -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_cartesian(xlim = xlim, ylim = ylim)) # clip = "off" to have secondary ticks outside plot region does not work -# x-axis ticks and inv -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 = xlim, n = ifelse(is.null(x.tick.nb), length(tempo.coord$x.major_source), x.tick.nb)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_x_continuous( -breaks = tempo.scale, -labels = if(xlog == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(xlog == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(xlog == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") ; stop(tempo.cat, call. = FALSE)}, -expand = c(0, 0), -limits = NA, -trans = ifelse(diff(xlim) < 0, "reverse", "identity") # equivalent to ggplot2::scale_x_reverse() -)) -# end x-axis ticks and inv -# y-axis ticks and inv +# end constant part +# barplot and error bars +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_bar(data = data2, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[length(categ)]), stat = "identity", position = ggplot2::position_dodge(width = NULL), color = "black", width = bar.width)) # stat = "identity" because already counted, position = position_dodge(width = NULL) for grouped bars (width = NULL means no overlap between grouped bars). Please, see explanation in https://stackoverflow.com/questions/34889766/what-is-the-width-argument-in-position-dodge/35102486#35102486 +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), guide = ggplot2::guide_legend(override.aes = list(fill = categ.color)))) # values are the values of color (which is the border color in geom_bar. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor +if( ! is.null(error.disp)){ +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_errorbar(data = data2, mapping = ggplot2::aes_string(x = categ[1], group = categ[length(categ)], ymin = "ERROR.INF", ymax = "ERROR.SUP"), position = ggplot2::position_dodge(width = bar.width), color = "black", width = error.whisker.width)) # cannot use fill = categ[length(categ)] because not an aesthetic of geom_errorbar, but if only x = categ[1], wrong x coordinates with grouped bars +} +# end barplot and error bars +# coordinates management (for random plotting and for stat display) +# bars +bar.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[1]] # to have the summary statistics of the plot. Here because can be required for stat.disp when just bar are plotted +# end bars +if( ! is.null(dot.color)){ +# random dots +if(dot.tidy == FALSE){ +dot.coord.rd1 <- merge(dot.coord, bar.coord[c("fill", "group", "x")], by = intersect("group", "group"), sort = FALSE) # rd for random. Send the coord of the bars 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 bar.coord. Thus, no need to consider fill +if(nrow(dot.coord.rd1) != nrow(dot.coord)){ +tempo.cat <- paste0("\n\n================\n\nERROR 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, call. = FALSE) +} +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 bars 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")) +}else{ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +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\nERROR 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, call. = FALSE) +} +# end random dots +} +# tidy dots +# coordinates are recover during plotting (see dot.coord.tidy1 below) +# end tidy dots +} +# end coordinates management (for random plotting and for stat display) +# dot display +if( ! is.null(dot.color)){ +if(dot.tidy == FALSE){ +if(isTRUE(all.equal(dot.border.size, 0))){ # similar to dot.border.size == 0 but deals with floats (approx is enough) +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, color = dot.coord.rd3$dot.color, alpha = dot.alpha, pch = 16)) # 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)]), stroke = dot.border.size, size = dot.size, fill = dot.coord.rd3$dot.color, alpha = dot.alpha, pch = 21)) # 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 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", color = categ[length(categ)]), position = ggplot2::position_dodge(width = bar.width), binaxis = "y", stackdir = "center", alpha = dot.alpha, fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"], show.legend = FALSE, binwidth = (ylim[2] - ylim[1]) / dot.bin.nb)) # very weird behavior of geom_dotplot, 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.) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(isTRUE(all.equal(dot.border.size, 0))){as.character(levels(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]))}else{rep("black", 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. BEWARE: , guide = ggplot2::guide_legend(override.aes = list(fill = levels(dot.color))) here +# 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\nERROR 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, call. = FALSE) +}else{ +dot.coord.tidy1 <- tempo.coord[[which(sapply(tempo.coord, FUN = nrow) == nrow(data1))]] +} +tempo.bar.coord <- merge(bar.coord, unique(dot.coord[, c("group", categ)]), by = intersect("group", "group"), sort = FALSE) # add the categ in bar.coord. BEWARE: by = intersect("group", "group") because group is enough as only one value of x per group number in bar.coord. Thus, no need to consider fill +if(nrow(tempo.bar.coord) != nrow(bar.coord)){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE merge() FUNCTION DID NOT RETURN A CORRECT tempo.bar.coord DATA FRAME. CODE HAS TO BE MODIFIED\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} +dot.coord.tidy2 <- merge(dot.coord.tidy1, tempo.bar.coord[c("fill", "group", "x", categ)], by = intersect("group", "group"), sort = FALSE) # send the coord of the bars 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 bar.coord. Thus, no need to consider fill +if(nrow(dot.coord.tidy2) != nrow(dot.coord)){ +tempo.cat <- paste0("\n\n================\n\nERROR 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, call. = FALSE) +} +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")) +}else{ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +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\nERROR 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, call. = FALSE) +} +# end coordinates of tidy dots +} +} +# end dot display +# 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 = bar.coord$x, y = ylim[2], label = fun_round(bar.coord$y, 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 bar.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 +} +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(bar.coord[order(bar.coord$x), ], stat.coord1[order(stat.coord1$x.y), ], stat.coord2[order(stat.coord2$x.y), ]) # should be ok to use bar.coord$x and stat.coord$x.y to assemble the two data frames because x coordinates of the bars. 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\nERROR IN ", function.name, ": FUSION OF bar.coord, stat.coord1 AND stat.coord2 ACCORDING TO bar.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, call. = FALSE) +} +dot.text.coord <- stat.coord3[, c("x", "group", "dot.min", "dot.max")] +names(dot.text.coord)[names(dot.text.coord) == "dot.min"] <- "text.min.pos" +names(dot.text.coord)[names(dot.text.coord) == "dot.max"] <- "text.max.pos" +} +if( ! is.null(error.disp)){ # for text just above error bars +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 +if( ! identical(stat[order(stat[, categ[1]]), categ[1]], tempo.data1[order(tempo.data1[, categ[1]]), categ[1]])){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE stat AND tempo.data1\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +}else{ +names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check") +names(tempo.data1)[names(tempo.data1) == "group"] <- "group.check" +stat.coord4 <- cbind(stat[order(stat[, categ[1]]), ], tempo.data1[order(tempo.data1[, 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 +if( ! fun_comp_2d(stat[order(stat[, categ[1]], stat[, categ[2]]), c(categ[1], categ[2])], tempo.data1[order(tempo.data1[, categ[1]], tempo.data1[, categ[2]]), c(categ[1], categ[2])])$identical.content){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE stat AND tempo.data1\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +}else{ +names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check") +names(tempo.data1)[names(tempo.data1) == categ[2]] <- paste0(categ[2], ".check") +names(tempo.data1)[names(tempo.data1) == "group"] <- "group.check" +stat.coord4 <- cbind(stat[order(stat[, categ[1]], stat[, categ[2]]), ], tempo.data1[order(tempo.data1[, paste0(categ[1], ".check")], tempo.data1[,paste0(categ[2], ".check")]), ]) +} +}else{ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 8\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +if( ! identical(bar.coord$group[order(bar.coord$group)], stat.coord4$group.check[order(stat.coord4$group.check)])){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE bar.coord AND stat.coord4\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +}else{ +stat.coord5 <- cbind(bar.coord[order(bar.coord$group), ], stat.coord4[order(stat.coord4$group.check), ]) +error.text.coord <- stat.coord5[, c("x", "group", "ERROR.INF", "ERROR.SUP")] # +names(error.text.coord)[names(error.text.coord) == "ERROR.INF"] <- "text.min.pos" +names(error.text.coord)[names(error.text.coord) == "ERROR.SUP"] <- "text.max.pos" +} +} +if(( ! is.null(dot.color)) & ! is.null(error.disp)){ # for text above max dot or error bar +stat.coord3 <- stat.coord3[order(stat.coord3$x), ] +stat.coord5 <- stat.coord5[order(stat.coord5$x), ] +if( ! identical(stat.coord3$group, stat.coord5$group)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE stat.coord3 AND stat.coord5\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +}else{ +stat.coord6 <- data.frame(stat.coord3, min.dot.error = mapply(FUN = min, stat.coord3$dot.min, stat.coord5$ERROR.INF, na.rm = TRUE)) +stat.coord7 <- data.frame(stat.coord6, max.dot.error = mapply(FUN = max, stat.coord3$dot.max, stat.coord5$ERROR.SUP, na.rm = TRUE)) +both.text.coord <- stat.coord7[, c("x", "group", "min.dot.error", "max.dot.error")] # +names(both.text.coord)[names(both.text.coord) == "min.dot.error"] <- "text.min.pos" +names(both.text.coord)[names(both.text.coord) == "max.dot.error"] <- "text.max.pos" +} +} +if(( ! is.null(dot.color)) & is.null(error.disp)){ +text.coord <- dot.text.coord +}else if(is.null(dot.color) & ! is.null(error.disp)){ +text.coord <- error.text.coord +}else if(( ! is.null(dot.color)) & ! is.null(error.disp)){ +text.coord <- both.text.coord +} +if( ! (is.null(dot.color) & is.null(error.disp))){ +bar.coord <- bar.coord[order(bar.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(bar.coord$group)) because with error, the correspondence between x and group is not the same +if( ! identical(text.coord$x, bar.coord$x)){ +tempo.cat <- paste0("\n\n============\n\nERROR: text.coord AND bar.coord DO NOT HAVE THE SAME x COLUMN CONTENT\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +} +# end stat coordinates +# stat display +if(is.null(dot.color) & is.null(error.disp)){ # text just above bars +# 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 = bar.coord$x[bar.coord$y >= 0], y = bar.coord$y[bar.coord$y >= 0], label = fun_round(bar.coord$y, 2)[bar.coord$y >= 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 bar.coord$x set the order +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "text", x = bar.coord$x[bar.coord$y < 0], y = bar.coord$y[bar.coord$y < 0], label = fun_round(bar.coord$y, 2)[bar.coord$y < 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 bar.coord$x set the order +}else{ # text just above error bars or dots +# I checked that text.coord and bar.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[bar.coord$y >= 0], y = text.coord$text.max.pos[bar.coord$y >= 0], label = fun_round(bar.coord$y, 2)[bar.coord$y >= 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 bar.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[bar.coord$y < 0], y = text.coord$text.min.pos[bar.coord$y < 0], label = fun_round(bar.coord$y, 2)[bar.coord$y < 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 bar.coord$x set the order +} +# end stat display +}else{ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 9\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +} +# 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 = ylim, n = ifelse(is.null(y.tick.nb), length(tempo.coord$y.major_source), y.tick.nb)) +# for the ggplot2 bug with ylog, this does not work: eval(parse(text = ifelse(vertical == FALSE & ylog == "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(ylog == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(ylog == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(ylog == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") ; stop(tempo.cat, call. = FALSE)}, +labels = if(ylog == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(ylog == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(ylog == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 10\n\n============\n\n") ; stop(tempo.cat, call. = FALSE)}, expand = c(0, 0), limits = NA, trans = ifelse(diff(ylim) < 0, "reverse", "identity") # equivalent to ggplot2::scale_y_reverse() )) -# end y-axis ticks and inv -# x-axis 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]] -xlim.order <- order(xlim) # to deal with inverse axis -ylim.order <- order(ylim) # to deal with inverse axis -# no secondary ticks for log2. Play with xlim -if(xlog == "log10"){ -y.range <- tempo.coord$y.range -if(diff(ylim.order) < 0){y.range <- -(y.range)} -ini.scipen <- options()$scipen -options(scipen = -1000) # force scientific format -power10.exp <- as.integer(substring(text = 10^xlim, first = (regexpr(pattern = "\\+|\\-", text = 10^xlim)))) # recover the power of 10. Example recover 08 from 1e+08 -# print(xlim) -mantisse <- as.numeric(substr(x = 10^xlim, start = 1, stop = (regexpr(pattern = "\\+|\\-", text = 10^xlim) - 2))) # recover the mantisse. Example recover 1.22 from 1.22e+08 -options(scipen = ini.scipen) # restore the initial scientific penalty -# print(power10.exp) -tempo.tick.pos <- as.vector(outer(log10(2:10), 10^((power10.exp[1] - ifelse(diff(xlim.order) > 0, 1, -1)):(power10.exp[2] + ifelse(diff(xlim.order) > 0, 1, -1))))) -tempo.tick.pos <- sort(tempo.tick.pos, decreasing = ifelse(diff(xlim.order) > 0, FALSE, TRUE)) -tempo.tick.pos <- log10(tempo.tick.pos[tempo.tick.pos >= min(10^xlim) & tempo.tick.pos <= max(10^xlim)]) -if(any(is.na(tempo.tick.pos) | ! is.finite(tempo.tick.pos))){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 8\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -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 = y.range[1], yend = y.range[1] + diff(y.range) / 80)) -}else if(( ! is.null(x.inter.tick.nb)) & xlog == "no"){ -if(x.inter.tick.nb > 0){ -x.ticks.pos <- suppressWarnings(as.numeric(tempo.coord$x.labels)) # too difficult to predict the behavior of tempo.coord$x.major_source depending on xlim neg or not, inv or not. Inv is respected -if(any(is.na(x.ticks.pos))){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 9\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -y.range <- tempo.coord$y.range -if(diff(ylim.order) < 0){y.range <- -(y.range)} -tick.dist <- mean(diff(x.ticks.pos), na.rm = TRUE) -minor.tick.dist <- tick.dist / (x.inter.tick.nb + 1) -minor.tick.pos <- seq(x.ticks.pos[1] - tick.dist, x.ticks.pos[length(x.ticks.pos)] + tick.dist, by = minor.tick.dist) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", x = minor.tick.pos, xend = minor.tick.pos, y = y.range[1], yend = y.range[1] + diff(y.range) / 80)) -} +if(vertical == TRUE){ +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_cartesian(ylim = ylim)) # clip = "off" to have secondary ticks outside plot region does not work +}else{ +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_flip(ylim = ylim)) # clip = "off" to have secondary ticks outside plot region does not work } -# end x-axis secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip()) -# y-axis secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip()) +# 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 ylim if(ylog == "log10"){ -x.range <- tempo.coord$x.range -if(diff(xlim.order) < 0){x.range <- -(x.range)} +ylim.order <- order(ylim) # to deal with inverse axis ini.scipen <- options()$scipen options(scipen = -1000) # force scientific format power10.exp <- as.integer(substring(text = 10^ylim, first = (regexpr(pattern = "\\+|\\-", text = 10^ylim)))) # recover the power of 10. Example recover 08 from 1e+08 @@ -5632,116 +5553,183 @@ tempo.tick.pos <- as.vector(outer(log10(2:10), 10^((power10.exp[1] - ifelse(diff tempo.tick.pos <- sort(tempo.tick.pos, decreasing = ifelse(diff(ylim.order) > 0, FALSE, TRUE)) tempo.tick.pos <- log10(tempo.tick.pos[tempo.tick.pos >= min(10^ylim) & tempo.tick.pos <= max(10^ylim)]) if(any(is.na(tempo.tick.pos) | ! is.finite(tempo.tick.pos))){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 10\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -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 = x.range[1], xend = x.range[1] + diff(x.range) / 80)) -}else if(( ! is.null(y.inter.tick.nb)) & ylog == "no"){ -if(y.inter.tick.nb > 0){ -y.ticks.pos <- suppressWarnings(as.numeric(tempo.coord$y.labels)) # too difficult to predict the behavior of tempo.coord$y.major_source depending on ylim neg or not, inv or not. Inv is respected -if(any(is.na(y.ticks.pos))){ tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 11\n\n============\n\n") stop(tempo.cat, call. = FALSE) } -x.range <- tempo.coord$x.range -if(diff(xlim.order) < 0){x.range <- -(x.range)} -tick.dist <- mean(diff(y.ticks.pos), na.rm = TRUE) +# 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)) & ylog == "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 ylim neg or not, inv or not +if(any(is.na(ticks.pos))){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 12\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +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)) +}else{ +ticks.pos <- suppressWarnings(as.numeric(tempo.coord$x.labels))# too difficult to predict the behavior of tempo.coord$x.major_source depending on ylim neg or not, inv or not +if(any(is.na(ticks.pos))){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 13\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +tick.dist <- mean(diff(ticks.pos), na.rm = TRUE) minor.tick.dist <- tick.dist / (y.inter.tick.nb + 1) -minor.tick.pos <- seq(y.ticks.pos[1] - tick.dist, y.ticks.pos[length(y.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 = x.range[1], xend = x.range[1] + diff(x.range) / 80)) +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)) } } -# end y-axis secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip()) -# end scale management +} +# end secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip()) +# end y scale management (cannot be before dot plot management) if(plot == TRUE){ -suppressWarnings(print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "),if(is.null(add)){NULL}else{add}))))) +suppressWarnings(print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}))))) }else{ warn.count <- warn.count + 1 tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": PLOT NOT SHOWN AS REQUESTED") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } +# end barplot if(warn.print == TRUE & ! is.null(warn)){ warning(warn, call. = FALSE) cat("\n\n") } if(return == TRUE){ output <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))) -if(is.null(unlist(removed.row.nb))){ -removed.row.nb <- NULL -removed.rows <- NULL -}else{ -for(i3 in 1:length(data1)){ -if( ! is.null(removed.row.nb[[i3]])){ -removed.row.nb[[i3]] <- sort(removed.row.nb[[i3]]) -removed.rows[[i3]] <- data1.ini[[i3]][removed.row.nb[[i3]], ] -} -} -} -output <- list(data = output$data, removed.row.nb = removed.row.nb, removed.rows = removed.rows, axes = output$layout$panel_params[[1]], warn = paste0("\n", warn, "\n\n")) +output <- list(stat = stat, removed.row.nb = removed.row.nb, removed.rows = removed.rows, data = output$data, axes = output$layout$panel_params[[1]], warn = paste0("\n", warn, "\n\n")) return(output) } } -######## fun_gg_bar() #### ggplot2 mean barplot + overlaid dots if required +######## fun_gg_boxplot() #### ggplot2 boxplot + background dots if required - +# https://ggplot2-book.org/scales.html -# Check OK: clear to go Apollo -fun_gg_bar <- function(data1, y, categ, categ.class.order = NULL, categ.legend.name = NULL, categ.color = NULL, bar.width = 0.5, error.disp = NULL, error.whisker.width = 0.5, dot.color = "same", dot.tidy = FALSE, dot.bin.nb = 30, dot.jitter = 0.25, dot.size = 3, dot.border.size = 0.5, dot.alpha = 0.5, ylim = NULL, ylog = "no", y.tick.nb = NULL, y.inter.tick.nb = NULL, y.include.zero = FALSE, y.top.extra.margin = 0, y.bottom.extra.margin = 0, stat.disp = NULL, stat.size = 4, stat.dist = 2, xlab = NULL, ylab = 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){ + +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, +dot.color = "black", +dot.categ = NULL, +dot.categ.class.order = NULL, +dot.categ.legend.name = NULL, +dot.tidy = TRUE, +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 +){ # AIM -# ggplot2 vertical barplot representing mean values with the possibility to add error bars and to overlay dots +# ggplot2 boxplot with the possibility to add background or foreground dots # for ggplot2 specifications, see: https://ggplot2.tidyverse.org/articles/ggplot2-specs.html # WARNINGS -# rows containing NA in data1[, c(y, categ)] will be removed before processing, with a warning (see below) -# if ever bars disappear, see the end of https://github.com/tidyverse/ggplot2/issues/2887 -# to have a single bar, create a factor column with a single class and specify the name of this column in categ argument as unique element (no categ2 in categ argument). For a single set of grouped bars, create a factor column with a single class and specify this column in categ argument as first element (categ1). See categ below -# with several single bars (categ argument with only one element), bar.width argument (i.e., width argument of ggplot2::geom_bar()) defines each bar width. The bar.width argument also defines the space between bars by using (1 - bar.width). In addition, xmin and xmax of the fun_gg_bar() output report the bar boundaries (around x-axis unit 1, 2, 3, etc., for each bar) -# with several sets of grouped bars (categ argument with two elements), bar.width argument defines each set of grouped bar width. The bar.width argument also defines the space between set of grouped bars by using (1 - bar.width). In addition, xmin and xmax of the fun_gg_bar() output report the bar boundaries (around x-axis unit 1, 2, 3, etc., for each set of grouped bar) -# to manually change the 0 base bar into this code, see https://stackoverflow.com/questions/35324892/ggplot2-setting-geom-bar-baseline-to-1-instead-of-zero +# Rows containing NA in data1[, c(y, categ)] will be removed before processing, with a warning (see below) +# Hinges are not computed like in the classical boxplot() function of R +# To have a single boxplot, create a factor column with a single class and specify the name of this column in categ argument as unique element (no categ2 in categ argument). For a single set of grouped boxplot, create a factor column with a single class and specify this column in categ argument as first element (categ1). See categ below +# with separated boxs (categ argument with only one element), box.width argument defines each box width. The box.width argument also defines the space between boxs by using (1 - box.width). In addition, xmin and xmax of the fun_gg_boxplot() output report the box boundaries (around x-axis unit 1, 2, 3, etc., for each box) +# with grouped boxs (categ argument with two elements), box.width argument defines each set of grouped box width. The box.width argument also defines the space between set of grouped boxs by using (1 - box.width). In addition, xmin and xmax of the fun_gg_boxplot() output report the box boundaries (around x-axis unit 1, 2, 3, etc., for each set of grouped box) +# The dot.alpha argument can alter the display of the color boxes when using pdf output # ARGUMENTS # data1: a dataframe containing one column of values (see y argument below) and one or two columns of categories (see categ argument below). Duplicated column names not allowed -# y: character string of the data1 column name for y-axis (containing numeric values). Numeric values will be averaged by categ to generate the bars and will also be used to plot the dots -# categ: vector of character strings of the data1 column name for categories (column of characters or factor). Must either be one or two column names. If a single column name (further refered to as categ1), then one bar per class of categ1. If two column names (further refered to as categ1 and categ2), then one bar per class of categ2, which form a group of bars in each class of categ1. BEWARE, categ1 (and categ2 if it exists) must have a single value of y per class of categ1 (and categ2). To have a single bar, create a factor column with a single class and specify the name of this column in categ argument as unique element (no categ2 in categ argument). For a single set of grouped bars, create a factor column with a single class and specify this column in categ argument as first element (categ1) -# categ.class.order: list indicating the order of the classes of categ1 and categ2 represented on the barplot (the first compartment for categ1 and and the second for categ2). If categ.class.order = NULL, classes are represented according to the alphabetical order. Some compartment can be NULL and other not +# y: character string of the data1 column name for y-axis (containing numeric values). Numeric values will be averaged by categ to generate the boxs and will also be used to plot the dots +# categ: vector of character strings of the data1 column name for categories (column of characters or factor). Must either be one or two column names. If a single column name (further refered to as categ1), then one box per class of categ1. If two column names (further refered to as categ1 and categ2), then one box per class of categ2, which form a group of boxs in each class of categ1. BEWARE, categ1 (and categ2 if it exists) must have a single value of y per class of categ1 (and categ2). To have a single box, create a factor column with a single class and specify the name of this column in categ argument as unique element (no categ2 in categ argument). For a single set of grouped boxs, create a factor column with a single class and specify this column in categ argument as first element (categ1) +# categ.class.order: list indicating the order of the classes of categ1 and categ2 represented on the boxplot (the first compartment for categ1 and and the second for categ2). If categ.class.order = NULL, classes are represented according to the alphabetical order. Some compartment can be NULL and other not # categ.legend.name: character string of the legend title for categ2. If categ.legend.name = NULL, then categ.legend.name <- categ1 if only categ1 is present and categ.legend.name <- categ2 if categ1 and categ2 are present. Write "" if no legend required -# categ.color: vector of character color string for bar filling. If categ.color = NULL, default colors of ggplot2, whatever categ1 and categ2. If categ.color is non null and only categ1 in categ argument, categ.color can be either: (1) a single color string (all the bars will have this color, whatever the classes of categ1), (2) a vector of string colors, one for each class of categ1 (each color will be associated according to categ.class.order of categ1), (3) a vector or factor of string colors, like if it was one of the column of data1 data frame (beware: a single color per class of categ1 and a single class of categ1 per color must be respected). Integers are also accepted instead of character strings, as long as above rules about length are respected. Integers will be processed by fun_gg_palette() using the max integer value among all the integers in categ.color. If categ.color is non null and categ1 and categ2 specified, all the rules described above will apply to categ2 instead of categ1 (colors will be determined for bars inside a group of bars) -# bar.width: numeric value (from 0 to 1) of the bar or set of grouped bar width (see WARNINGS above) -# error.disp: either "SD", "SD.TOP", "SEM" or "SEM.TOP". If NULL, no error bars added -# error.whisker.width: numeric value (from 0 to 1) of the whisker (error bar extremities) width, with 0 meaning no whiskers and 1 meaning a width equal to the corresponding bar width -# dot.color: vector of character string. Idem as categ.color but for dots, except that in the possibility (3), the rule "a single color per class of categ1 and a single class of categ1", cannot be respected (each dot can have a different color). If NULL, no dots plotted +# categ.color: vector of character color string for box frame. If categ.color = NULL, default colors of ggplot2, whatever categ1 and categ2. If categ.color is non null and only categ1 in categ argument, categ.color can be either: (1) a single color string (all the boxs will have this color, whatever the number of classes of categ1), (2) a vector of string colors, one for each class of categ1 (each color will be associated according to categ.class.order of categ1), (3) a vector or factor of string colors, like if it was one of the column of data1 data frame (beware: a single color per class of categ1 and a single class of categ1 per color must be respected). Integers are also accepted instead of character strings, as long as above rules about length are respected. Integers will be processed by fun_gg_palette() using the max integer value among all the integers in categ.color. If categ.color is non null and categ1 and categ2 specified, all the rules described above will apply to categ2 instead of categ1 (colors will be determined for boxs inside a group of boxs) +# box.fill: logical. Fill the box? If TRUE, the categ.color argument will be used to generate filled boxplot (the box frames being black) as well as filled outlier dots (the dot border being controled by the dot.border.color argument) and if all the dots are plotted (argument dot.color other than NULL), they will be over the boxes. If FALSE, the categ.color argument will be used to color the box frames and the outlier dot borders, and if all the dots are plotted, they will be beneath the boxes +# box.width: numeric value (from 0 to 1) of the box or set of grouped box width (see warnings above) +# box.space: numeric value (from 0 to 1) indicating the box separation in grouped boxes. 0 means no space and 1 means boxes shrinked to a vertical line. Ignored if no grouped boxes +# box.line.size: numeric value of line size of boxes and whiskers (in mm) +# box.notch: logical. Notched boxplot? It TRUE, display notched boxplot, the notches corresponding approximately to the 95% confidence interval of the median (the notch interval is exactly 1.58 x Inter Quartile Range (IQR) / sqrt(n), with n the number of values that made the box). If notch intervals between two boxes do not overlap, it can be interpreted as significant median differences +# box.alpha: numeric value (from 0 to 1) of box transparency (full transparent to full opaque, respectively). BEWARE: work only for the fill of boxplots, not for the frame. See https://github.com/tidyverse/ggplot2/issues/252 +# box.mean: logical. Add mean value? It TRUE, a losange dot, additional to the solid median bar and corresponding to the mean value, is incorporated into each boxplot +# box.whisker.kind: range of the whiskers. Either "no" (no whiskers), or "std" (length of each whisker equal to 1.5 x Inter Quartile Range (IQR)), or "max" (length of the whiskers up or down to the most distant dot) +# box.whisker.width: numeric value (from 0 to 1) of the whisker width, with 0 meaning no whiskers and 1 meaning a width equal to the corresponding boxplot width +# dot.color: vector of character string. Idem as categ.color but for dots, except that in the possibility (3), the rule "a single color per class of categ1 and a single class of categ1 per color", does not have to be respected (for instance, each dot can have a different color). If NULL, no dots plotted. If "same", the dots will have the same colors as the respective boxplots +# dot.categ: optional single character string of a data1 column name (further refered to as categ3). If non NULL, then a legend will be created for the dots, in addition to the legend for the boxes +# dot.categ.class.order: optional vector of character strings indicating the order of the classes of categ3. If dot.categ is non NULL and dot.categ.class.order is NULL, classes are displayed in the legend according to the alphabetical order. Ignored if dot.categ is NULL +# dot.categ.legend.name: optional character string of the legend title for categ3. If categ.legend.name = NULL, categ3 value is used (name of the column in data1). Write "" if no legend required. Ignored if dot.categ is NULL # dot.tidy: logical. Nice dot spreading? If TRUE, use the geom_dotplot() function for a nice representation. If FALSE, dots are randomly spread, using the dot.jitter argument (see below) -# dot.bin.nb: positive integer indicating the number of bins (i.e., nb of separations) of the ylim range. Each dot will then be put in one of the bin, with the size the width of the bin. Not considered if dot.tidy is FALSE -# dot.jitter: numeric value (from 0 to 1) of random dot horizontal dispersion, with 0 meaning no dispersion and 1 meaning a dispersion in the corresponding bar width interval. Not considered if dot.tidy is TRUE -# dot.size: numeric value of dot size. Not considered if dot.tidy is TRUE -# dot.border.size: numeric value of border dot size. Write zero for no dot border. If dot.tidy is TRUE, value 0 remove the border. Another one leave the border without size control (geom_doplot() feature) +# dot.tidy.bin.nb: positive integer indicating the number of bins (i.e., nb of separations) of the y.lim range. Each dot will then be put in one of the bin, with the size the width of the bin. Not considered if dot.tidy is FALSE +# dot.jitter: numeric value (from 0 to 1) of random dot horizontal dispersion, with 0 meaning no dispersion and 1 meaning a dispersion in the corresponding box width interval. Not considered if dot.tidy is TRUE +# dot.size: numeric value of dot size (in mm). Not considered if dot.tidy is TRUE # dot.alpha: numeric value (from 0 to 1) of dot transparency (full transparent to full opaque, respectively) -# ylim: 2 numeric values for y-axis range. If NULL, range of y in data1. Order of the 2 values matters (for inverted axis). BEWARE: values of the ylim must be already in the corresponding log if ylog argument is not "no" (see below) -# ylog: Either "no" (values in the y argument column of the data1 data frame are not log), "log2" (values in the y argument column of the data1 data frame are log2 transformed) or "log10" (values in the y argument column of the data1 data frame are log10 transformed). BEWARE: do not tranform the data, but just display ticks in a log scale manner. Thus, negative or zero values allowed. BEWARE: not possible to have horizontal bars with a log axis, due to a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) +# dot.border.size: numeric value of border dot size (in mm). Write zero for no dot border. If dot.tidy is TRUE, value 0 remove the border. Another one leave the border without size control (geom_doplot() feature) +# dot.border.color: single character color string defining the color of the dot border (same color for all the dots, whatever their categories). If dot.border.color = NULL, the border color will be the same as the dot color. A single integer is also accepted instead of a character string, that will be processed by fun_gg_palette() +# x.lab: a character string or expression for x-axis legend. If NULL, character string of categ1 +# y.lab: a character string or expression for y-axis legend. If NULL, character string of the y argument +# y.lim: 2 numeric values indicating the range of the y-axis +# y.log: Either "no" (values in the y argument column of the data1 data frame are not log), "log2" (values in the y argument column of the data1 data frame are log2 transformed) or "log10" (values in the y argument column of the data1 data frame are log10 transformed). BEWARE: do not tranform the data, but just display ticks in a log scale manner. Thus, negative or zero values allowed. BEWARE: not possible to have horizontal boxs with a log axis, due to a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) # y.tick.nb: approximate number of desired label values on the y-axis (n argument of the the fun_scale() function) -# y.inter.tick.nb: number of desired secondary ticks between main ticks. Not considered if ylog is other than "no". In that case, play with the ylim and y.tick.nb arguments -# y.include.zero: logical. Does ylim range include 0? Ok even if ylog = TRUE because ylim must already be log transformed values -# y.top.extra.margin: single proportion (between 0 and 1) indicating if extra margins must be added to ylim. If different from 0, add the range of the axis * y.top.extra.margin (e.g., abs(ylim[2] - ylim[1]) * y.top.extra.margin) to the top of y-axis +# y.inter.tick.nb: number of desired secondary ticks between main ticks. Not considered if y.log is other than "no". In that case, play with the y.lim and y.tick.nb arguments +# y.include.zero: logical. Does y.lim range include 0? Ok even if y.log = TRUE because y.lim must already be log transformed values +# y.top.extra.margin: single proportion (between 0 and 1) indicating if extra margins must be added to y.lim. If different from 0, add the range of the axis * y.top.extra.margin (e.g., abs(y.lim[2] - y.lim[1]) * y.top.extra.margin) to the top of y-axis # y.bottom.extra.margin: idem as y.top.extra.margin but to the bottom of y-axis -# stat.disp: add the mean number above the corresponding bar. Either NULL (no number shown), "top" (at the top of the figure region) or "above" (above each bar) +# stat.disp: add the median number above the corresponding box. Either NULL (no number shown), "top" (at the top of the figure region) or "above" (above each box) +# stat.disp.mean: logical. Diplay means instead of medians ? # stat.size: numeric value of the stat size (in points). Increase the value to increase text size -# stat.dist: numeric value of the stat distance. Increase the value to increase the distance -# xlab: a character string or expression for x-axis legend. If NULL, character string of categ1 -# ylab: a character string or expression for y-axis legend. If NULL, character string of the y argument -# vertical: logical. Vertical bars? BEWARE: will be automatically set to TRUE if ylog argument is other than "no". Indeed, not possible to have horizontal bars with a log axis, due to a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) -# text.size: numeric value of the size of the (1) axis numbers and axis legends, (2) texts in the graphic legend, (3) stats above bars (in points) +# stat.dist: numeric value of the stat distance. Increase the value to increase the distance from the box plot +# vertical: logical. Vertical boxs? BEWARE: will be automatically set to TRUE if y.log argument is other than "no". Indeed, not possible to have horizontal boxs with a log axis, due to a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) +# text.size: numeric value of the size of the (1) axis numbers and axis legends, (2) texts in the graphic legend, (3) stats above boxs (in points) +# text.angle: integer value of the text angle for the x-axis labels. Positive values for counterclockwise rotation: 0 for horizontal, 90 for vertical, 180 for upside down etc. Negative values for clockwise rotation: 0 for horizontal, -90 for vertical, -180 for upside down etc. # title: character string of the graph title # title.text.size: numeric value of the title size (in points) -# text.angle: integer value of the text angle for the x-axis labels. Positive values for counterclockwise rotation: 0 for horizontal, 90 for vertical, 180 for upside down etc. Negative values for clockwise rotation: 0 for horizontal, -90 for vertical, -180 for upside down etc. # classic: logical. Use the classic theme (article like)? -# grid: logical. draw horizontal lines in the background to better read the bar values? Not considered if classic = FALSE +# grid: logical. draw horizontal lines in the background to better read the box values? Not considered if classic = FALSE # return: logical. Return the graph parameters? # plot: logical. Plot the graphic? If FALSE and return argument is TRUE, graphical parameters and associated warnings are provided without plotting # add: character string allowing to add more ggplot2 features (dots, lines, themes, etc.). BEWARE: (1) must start with "+" just after the simple or double opening quote (no space, end of line, carriage return, etc., allowed), (2) must finish with ")" just before the simple or double closing quote (no space, end of line, carriage return, etc., allowed) and (3) each function must be preceded by "ggplot2::" (for instance: "ggplot2::coord_flip()). If the character string contains the "ggplot2::theme" string, then internal ggplot2 theme() and theme_classic() functions will be inactivated to be reused by add. BEWARE: handle this argument with caution since added functions can create conflicts with the preexisting internal ggplot2 functions -# warn.print: logical. Print warnings at the end of the execution? No print if no warning messages -# lib.path: absolute path of the required packages, if not in the default folders +# warn.print: logical. Print warnings at the end of the execution? No print if no warning messages. some of the warning messages (those delivered by the internal ggplot2 functions) are not apparent when using the argument plot = FALSE +# lib.path: character string indicating the absolute path of the required packages, if not in the default folders # REQUIRED PACKAGES # ggplot2 # scales @@ -5755,206 +5743,233 @@ fun_gg_bar <- function(data1, y, categ, categ.class.order = NULL, categ.legend.n # fun_round() # fun_scale() # RETURN -# a barplot if plot argument is TRUE +# a boxplot if plot argument is TRUE # a list of the graph info if return argument is TRUE: # $stat: the graphic statistics # $removed.row.nb: which rows have been removed due to NA detection in y and categ columns (NULL if no row removed) # $removed.rows: removed rows containing NA (NULL if no row removed) -# $data: the graphic bar and dot coordinates +# $data: the graphic box and dot coordinates # $axes: the x-axis and y-axis info -# $warn: the warning messages. Use cat() for proper display. NULL if no warning -# EXAMPLES -### nice representation (1) -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A")), categ.legend.name = "LEGEND", categ.color = NULL, bar.width = 0.3, error.disp = "SD.TOP", error.whisker.width = 0.8, dot.color = "same", dot.jitter = 0.5, dot.size = 3.5, dot.border.size = 0.2, dot.alpha = 0.5, ylim = c(10, 25), y.include.zero = TRUE, stat.disp = "above", stat.size = 4, xlab = "GROUP", ylab = "VALUE", text.size = 12, title = "GRAPH1", title.text.size = 8, text.angle = 0, classic = TRUE, grid = TRUE) -### nice representation (2) -# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(24, 0), rnorm(24, -10), rnorm(24, 10), rnorm(24, 20)), Group1 = rep(c("CAT", "DOG"), times = 48), Group2 = rep(c("A", "B", "C", "D"), each = 24)) ; set.seed(NULL) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A", "D", "C")), categ.legend.name = "LEGEND", categ.color = NULL, bar.width = 0.8, dot.color = "grey50", dot.tidy = TRUE, dot.bin.nb = 60, dot.size = 3.5, dot.border.size = 0.2, dot.alpha = 0.5, ylim= c(-20, 30), stat.disp = "above", stat.size = 4, stat.dist = 1, xlab = "GROUP", ylab = "VALUE", vertical = FALSE, text.size = 12, title = "GRAPH1", title.text.size = 8, text.angle = 45, classic = FALSE) -### simple example -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1") -### separate bars. Example (1) of modification of bar color using a single value -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", categ.color = "white") -### separate bars. Example (2) of modification of bar color using one value par class of categ2 -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", categ.color = c("coral", "lightblue")) -### separate bars. Example (3) of modification of bar color using the bar.color data frame column, with respect of the correspondence between categ2 and bar.color columns -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), bar.color = rep(c("coral", "lightblue"), time = 10)) ; obs1 ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", categ.color = obs1$bar.color) -### separate bars. Example (1) of modification of dot color, using the same dot color as the corresponding bar -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = "same") -### separate bars. Example (2) of modification of dot color, using a single color for all the dots -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = "green") -### separate bars. Example (3) of modification of dot color, using one value par class of categ2 -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = c("green", "brown")) -### separate bars. Example (4) of modification of dot color, using different colors for each dot -# obs1 <- data.frame(Time = 1:10, Group1 = rep(c("G", "H"), times = 5)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = hsv(h = (1:nrow(obs1)) / nrow(obs1))) -### grouped bars. Simple example -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2")) -### grouped bars. More grouped bars -# obs1 <- data.frame(Time = 1:24, Group1 = rep(c("G", "H"), times = 12), Group2 = rep(c("A", "B", "C", "D"), each = 6)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2")) -### grouped bars. Example (1) of modification of bar color, using a single value -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = "white") -### grouped bars. Example (2) of modification of bar color, using one value par class of categ2 -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = c("coral", "lightblue")) -### grouped bars. Example (3) of modification of bar color, using one value per line of obs1, with respect of the correspondence between categ2 and bar.color columns -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10), bar.color = rep(c("coral", "lightblue"), each = 10)) ; obs1 ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), categ.color = obs1$bar.color) -### grouped bars. Example (1) of modification of dot color, using the same dot color as the corresponding bar -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same") -### grouped bars. Example (2) of modification of dot color, using a single color for all the dots -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "green") -### grouped bars. Example (3) of modification of dot color, using one value par class of categ2 -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = c("green", "brown")) -### grouped bars. Example (4) of modification of dot color, using different colors for each dot -# obs1 <- data.frame(Time = 1:10, Group1 = rep(c("G", "H"), times = 5), Group2 = rep(c("A", "B"), each = 5)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = hsv(h = (1:nrow(obs1)) / nrow(obs1))) -### no dots (y.include.zero set to TRUE to see the lowest bar): -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE) -### bar width. Example (1) with bar.width = 0.25 -> three times more space between single bars than the bar width (y.include.zero set to TRUE to see the lowest bar) -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), each = 500)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = NULL, y.include.zero = TRUE, bar.width = 0.25) -### bar width. Example (2) with bar.width = 1, no space between single bars -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), each = 500)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = "Group1", dot.color = NULL, y.include.zero = TRUE, bar.width = 1) -### bar width. Example (3) with bar.width = 0.25 -> three times more space between sets of grouped bars than the set width -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE, bar.width = 0.25) -### bar width. Example (4) with bar.width = 0 -> no space between sets of grouped bars -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, y.include.zero = TRUE, bar.width = 1) -### error bars -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, error.disp = "SD.TOP") -### whisker width. Example (1) with error.whisker.width = 1 -> whiskers have the width of the corresponding bar -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, error.disp = "SD", error.whisker.width = 1) -### whisker width. Example (2) error bars with no whiskers -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = NULL, error.disp = "SD", error.whisker.width = 0) -### tidy dot distribution. Example (1) -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = TRUE, dot.bin.nb = 100) -### tidy dot distribution. Example (2) reducing the dot size with dot.bin.nb -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = TRUE, dot.bin.nb = 150) -### dot jitter. Example (1) -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "same", dot.tidy = FALSE, dot.jitter = 1, dot.size = 2) -### dot jitter. Example (2) with dot.jitter = 1 -> dispersion around the corresponding bar width -# obs1 <- data.frame(Time = 1:1000, Group1 = rep(c("G", "H"), times = 500), Group2 = rep(LETTERS[1:5], each = 200)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 3, dot.alpha = 1, dot.jitter = 1) -### dot jitter. Example (3) with no dispersion -# obs1 <- data.frame(Time = 1:100, Group1 = rep(c("G", "H"), times = 50), Group2 = rep(LETTERS[1:5], each = 20)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 3, dot.alpha = 1, dot.jitter = 0) -### dot size, dot border size and dot transparency -# obs1 <- data.frame(Time = 1:100, Group1 = rep(c("G", "H"), times = 50), Group2 = rep(LETTERS[1:5], each = 20)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), dot.color = "grey", dot.size = 4, dot.border.size = 0, dot.alpha = 0.6) -### y-axis limits. Example (1) -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylim = c(-1, 25)) -### y-axis limits. Example (2) showing that order matters in ylim argument -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylim = c(25, -1)) -### log scale. Example (1). BEWARE: y column must be log, otherwise incoherent scale (see below warning message with the return argument) -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10") -### log scale. Example (2). BEWARE: values of the ylim must be in the corresponding log -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", ylim = c(1,4)) -### tick number. Example (1) -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.tick.nb = 10) -### tick number. Example (2) using a log2 scale -# obs1 <- data.frame(Time = log2((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log2", y.tick.nb = 10, ylim = c(1, 16)) -### tick number. Example (3) using a log10 scale -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.tick.nb = 10) -### tick number. Example (4) using a log10 scale: the reverse y-axis correctly deal with log10 scale -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.tick.nb = 10, ylim = c(4, 1)) -### secondary tick number. Example (1) -# obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.inter.tick.nb = 2) -### secondary ticks. Example (2) not for log2 and log10 scales (see below warning message with the return argument) -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", y.inter.tick.nb = 2) -### include zero in the y-axis -# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.include.zero = TRUE) -### extra margins. To avoid dot cuts -# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.25, y.bottom.extra.margin = 0.25) -### mean diplay. Example (1) at the top of the plot region -# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.1, stat.disp = "top", stat.size = 4, stat.dist = 2) -### mean diplay. Example (2) above bars -# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.top.extra.margin = 0.1, stat.disp = "above", stat.size = 4, stat.dist = 2) -### bar orientation. Example (1) without log scale, showing that the other arguments are still operational -# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), y.tick.nb = 10, y.inter.tick.nb = 2, y.include.zero = TRUE, vertical = FALSE) -### bar orientation. Example (2) with log scale. Horizontal orientation is blocked with log2 and log10 scales because of a bug in ggplot2 (https://github.com/tidyverse/ggplot2/issues/881) -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", vertical = FALSE) -### classic representation (use grid = TRUE to display the background lines of the y axis ticks) -# obs1 <- data.frame(Time = (1:20), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), classic = TRUE, grid = FALSE) -### graphic info. Example (1) -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), return = TRUE) -### graphic info. Example (2) of assignation and warning message display -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; warn <- fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), ylog = "log10", return = TRUE) ; cat(warn$warn) -### add ggplot2 functions -# obs1 <- data.frame(Time = log10((1:20) * 100), Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "Time", categ = c("Group1", "Group2"), add = "+ggplot2::theme_classic()") -### all the arguments -# obs1 <- data.frame(x = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_bar(data1 = obs1, y = "x", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A")), categ.legend.name = "", categ.color = c("red", "blue"), bar.width = 0.25, error.disp = "SD", error.whisker.width = 0.8, dot.color = "grey", dot.tidy = FALSE, dot.bin.nb = 30, dot.jitter = 1, dot.size = 4, dot.border.size = 0, dot.alpha = 1, ylim = c(0, 25), ylog = "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, stat.disp = "above", stat.size = 4, stat.dist = 2, xlab = "GROUP", ylab = "VALUE", vertical = FALSE, text.size = 12, title = "", title.text.size = 8, text.angle = 45, classic = TRUE, grid = TRUE, return = TRUE, plot = TRUE, add = NULL, warn.print = TRUE, lib.path = NULL) +# $warnings: the warning messages. Use cat() for proper display. NULL if no warning. BEWARE: some of the warning messages (those delivered by the internal ggplot2 functions) are not apparent when using the argument plot = FALSE +# EXAMPLE +# obs1 <- data.frame(x = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; fun_gg_boxplot(data1 = obs1, y = "x", categ = c("Group1", "Group2"), categ.class.order = list(NULL, c("B", "A")), categ.legend.name = "", categ.color = c("red", "blue"), box.width = 0.25, whisker.width = 0.8, dot.color = "grey", dot.tidy = FALSE, dot.bin.nb = 30, dot.jitter = 1, dot.size = 4, dot.border.size = 0, dot.alpha = 1, ylim = c(0, 25), ylog = "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, stat.disp = "above", stat.size = 4, stat.dist = 2, xlab = "GROUP", ylab = "VALUE", vertical = FALSE, text.size = 12, title = "", title.text.size = 8, text.angle = 45, classic = TRUE, grid = TRUE, return = TRUE, plot = TRUE, add = NULL, warn.print = TRUE, lib.path = NULL) # DEBUGGING -# data1 <- data.frame(a = 1:20, group1 = rep(c("G", "H"), times = 10), group2 = rep(c("A", "B"), each = 10), bar.color = rep(c("brown", "orange"), each = 10)) ; data1[2:3, 1] <- NA ; data1[7:8, 2] <- NA ; y = names(data1)[1] ; categ = c(names(data1)[2], names(data1)[3]) ; categ.class.order = list(L1 = NULL, L2 = c("B", "A")) ; categ.legend.name = NULL ; categ.color = na.omit(data1)$bar.color ; bar.width = 0.5 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = FALSE ; dot.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ; dot.border.size = 0.5 ; dot.alpha = 1 ; ylim = NULL ; ylog = "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 ; stat.disp = NULL ; stat.size = 4 ; stat.dist = 2 ; xlab = NULL ; ylab = 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 = TRUE ; lib.path = NULL -# data1 <-data.frame(a = rep(1:20, 5), group1 = rep(c("G", "H"), times = 50), group2 = rep(LETTERS[1:5], each = 20)) ; y = names(data1)[1] ; categ = c(names(data1)[2], names(data1)[3]) ; categ.class.order = list(L1 = NULL, L2 = c("B", "A", "E", "D", "C")) ; categ.legend.name = NULL ; categ.color = NULL ; bar.width = 0.5 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = TRUE ; dot.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ; dot.border.size = 0.5 ; dot.alpha = 1 ; ylim = NULL ; ylog = "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 ; stat.disp = NULL ; stat.size = 4 ; stat.dist = 2 ; xlab = NULL ; ylab = 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 = TRUE ; lib.path = NULL -# data1 <- data.frame(a = 1:20, group1 = rep(c("G", "H"), times = 10), group2 = rep(c("A", "B"), each = 10), bar.color = rep(c("brown", "orange"), each = 10)) ; data1[2:3, 1] <- NA ; data1[7:8, 2] <- NA ; y = names(data1)[1] ; categ = c(names(data1)[2], names(data1)[3]) ; categ.class.order = list(L1 = NULL, L2 = c("B", "A")) ; categ.legend.name = NULL ; categ.color = na.omit(data1)$bar.color ; bar.width = 0.5 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = TRUE ; dot.bin.nb = 30 ; dot.jitter = 0.25 ; dot.size = 3 ; dot.border.size = 0.5 ; dot.alpha = 1 ; ylim = NULL ; ylog = "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 ; stat.disp = "above" ; stat.size = 4 ; stat.dist = 2 ; xlab = NULL ; ylab = 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 = TRUE ; lib.path = NULL -# set.seed(1) ; data1 <- data.frame(a = c(rnorm(25, 0), rnorm(25, -10), rnorm(25, 10), rnorm(25, 20)), group1 = rep(c("G", "H"), times = 50), group2 = rep(c("A", "B", "C", "D"), each = 25)) ; set.seed(NULL) ; y = "Time" ; categ = c("group1", "group2") ; categ.class.order = list(NULL, c("B", "A", "D", "C")) ; categ.legend.name = "LEGEND" ; categ.color = NULL ; bar.width = 0.8 ; error.disp = "SD" ; error.whisker.width = 0.5 ; dot.color = "same" ; dot.tidy = TRUE ; dot.bin.nb = 60 ; dot.jitter = 0.25 ; dot.size = 3.5 ; dot.border.size = 0 ; dot.alpha = 1 ; ylim= c(-15, 25) ; ylog = "no" ; y.tick.nb = NULL ; y.inter.tick.nb = NULL ; y.include.zero = "no" ; y.top.extra.margin = 0.05 ; y.bottom.extra.margin = 0 ; stat.disp = "above" ; stat.size = 4 ; stat.dist = 2 ; xlab = "GROUP" ; ylab = "VALUE" ; vertical = FALSE ; text.size = 12 ; title = "" ; title.text.size = 8 ; text.angle = -200 ; classic = FALSE ; grid = FALSE ; return = FALSE; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL -# set.seed(1) ; data1 <- data.frame(x = 1:1000, group1 = rep(c("G", "H"), times = 500), group2 = rep(LETTERS[1:5], each = 200)) ; set.seed(NULL) ; y = "x" ; categ <- c("group1", "group2") ; categ.class.order = list(NULL, c("B", "A", "D", "C", "E")) ; categ.legend.name = "LEGEND" ; categ.color = NULL ; bar.width = 0.8 ; error.disp = "SD" ; error.whisker.width = 1 ; dot.color = NULL ; dot.tidy = FALSE ; dot.bin.nb = 60 ; dot.jitter = 0.25 ; dot.size = 3.5 ; dot.border.size = 0.2 ; dot.alpha = 1 ; ylim= c(1, 4) ; ylog = "log10" ; y.tick.nb = NULL ; y.inter.tick.nb = NULL ; y.include.zero = FALSE ; y.top.extra.margin = 0 ; y.bottom.extra.margin = 0 ; stat.disp = "above" ; stat.size = 4 ; stat.dist = 1 ; xlab = "GROUP" ; ylab = "VALUE" ; vertical = TRUE ; text.size = 12 ; title = "" ; title.text.size = 8 ; text.angle = -200 ; classic = FALSE ; grid = FALSE ; return = FALSE; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL +# 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") ; 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 = "same" ; dot.categ = "Group1"; dot.categ.class.order = c("G", "H") ; 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 +# 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 = "black" ; dot.categ = "Group1" ; 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 = FALSE ; plot = TRUE ; add = NULL ; warn.print = FALSE ; lib.path = NULL +# 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 = "black" ; dot.categ = "Group1" ; 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 = FALSE ; plot = TRUE ; add = NULL ; warn.print = FALSE ; lib.path = NULL # function name function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") # end function name # required function checking -if(length(utils::find("fun_comp_2d", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_comp_2d() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if(length(utils::find("fun_gg_just", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_just() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if(length(utils::find("fun_gg_palette", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_palette() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if(length(utils::find("fun_name_change", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_name_change() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if(length(utils::find("fun_pack", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_pack() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if(length(utils::find("fun_check", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if(length(utils::find("fun_round", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_round() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +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) } -if(length(utils::find("fun_scale", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_scale() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) } # 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", "ERROR.INF", "ERROR.SUP", "group", "group.check", "max.dot.error", "MEAN", "min.dot.error", "SD", "SEM", "tempo.categ1", "tempo.categ2", "text.max.pos", "text.min.pos", "x", "x.y", "y", "y.check", "y_from.dot.max", "ymax") +reserved.words <- c("categ.check", "categ.color", "dot.color", "dot.categ", "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) -# argument checking (and modification for proper color management) -warn <- NULL -warn.count <- 0 +# 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) -if(tempo$problem == FALSE & 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 = " ")) +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) +} +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) } -tempo <- fun_check(data = y, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (y %in% names(data1))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": y ARGUMENT MUST BE A COLUMN NAME OF data1") +} +} +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) -}else if(tempo$problem == FALSE){ -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) } -tempo <- fun_check(data = categ, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & length(categ) > 2){ -tempo.cat <- paste0("ERROR IN ", function.name, ": categ ARGUMENT CANNOT HAVE MORE THAN 2 COLUMN NAMES OF data1\n\n================\n\n") +} +} +if( ! is.null(dot.categ)){ +tempo <- fun_check(data = dot.categ, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +} +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) +} +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) +} +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) -}else if(tempo$problem == FALSE & ! 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 = " ")) +} +} +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) +} +} +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) +} +} +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) +} +} +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) +} +} +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) +} +} +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) +} +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) +} +} +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))){ +tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", paste(lib.path, collapse = "\n")) text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } +} +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # +} +# 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 +warn.count <- 0 +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) +} +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) +}else{ +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) +} +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) +} # 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 = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +} +if( ! is.null(dot.categ)){ +if(dot.categ %in% categ){ +reserved.words <- c(reserved.words, paste0(dot.categ, "_DOT")) # paste0(dot.categ, "_DOT") is added to the reserved words because in such situation, a new column will be added to data1 that is named paste0(dot.categ, "_DOT") +} } 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 @@ -5962,502 +5977,630 @@ 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] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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") +tempo.warn <- paste0("(", warn.count,") 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))) } +# BEWARE: names of y argument potentially replaced if(any(categ == tempo.output$ini[i3])){ categ[categ == tempo.output$ini[i3]] <- tempo.output$post[i3] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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") +tempo.warn <- paste0("(", warn.count,") 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))) } -} +# BEWARE: names of categ argument potentially replaced +if( ! is.null(dot.categ)){ +if(any(dot.categ == tempo.output$ini[i3])){ +dot.categ[dot.categ == tempo.output$ini[i3]] <- tempo.output$post[i3] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": REGARDING COLUMN NAMES REPLACEMENT, THE NAMES\n", paste(tempo.output$ini, collapse = " "), "\nHAVE BEEN REPLACED BY\n", paste(tempo.output$post, collapse = " ")) +tempo.warn <- paste0("(", warn.count,") IN dot.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 dot.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))) } -# end reserved word checking -# na detection and removal (done now to be sure of the correct length of categ) -if(any(is.na(data1[, c(y, categ)]))){ -removed.row.nb <- unlist(lapply(lapply(c(data1[c(y, categ)]), FUN = is.na), FUN = which)) -removed.rows <- data1[removed.row.nb, ] -data1 <- data1[-removed.row.nb, ] +} +# BEWARE: names of dot.categ argument potentially replaced +} warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NA DETECTED IN COLUMN ", paste(c(y, categ), collapse = " "), " OF data1 AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)") +tempo.warn <- paste0("(", warn.count,") 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))) -}else{ -removed.row.nb <- NULL -removed.rows <- NULL } -# end na detection and removal (done now to be sure of the correct length of categ) +# end reserved word checking +# conversion of categ columns in data1 into factors for(i1 in 1:length(categ)){ -if(any(is.na(data1[, categ[i1]]))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN categ NUMBER ", i1, " IN data1, THE CATEGORY COLUMN ", categ[i1], " CONTAINS NA") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} 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\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo1$problem == FALSE){ +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 warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": IN categ NUMBER ", i1, " IN data1, THE CHARACTER COLUMN HAS BEEN CONVERTED TO FACTOR") +tempo.warn <- paste0("(", warn.count,") 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))) } data1[, categ[i1]] <- factor(data1[, categ[i1]]) # if already a factor, change nothing, if characters, levels according to alphabetical order } +# 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\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE){ +if(length(categ.class.order) != length(categ)){ +tempo.cat <- paste0("ERROR IN ", function.name, ": categ.class.order ARGUMENT MUST BE A LIST OF LENGTH EQUAL TO LENGTH OF categ\nHERE IT IS LENGTH: ", length(categ.class.order), " VERSUS ", length(categ)) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +}else{ for(i3 in 1:length(categ.class.order)){ if(is.null(categ.class.order[[i3]])){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE categ.class.order COMPARTMENT ", i3, " IS NULL. ALPHABETICAL ORDER WILL BE APPLIED") +tempo.warn <- paste0("(", warn.count,") 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 -}else if(any(duplicated(categ.class.order[[i3]]))){ +categ.class.order[[i3]] <- levels(data1[, categ[i3]]) # character vector that will be used later +}else{ +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 +} +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 = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +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\nHERE IT IS:\nCOMPARTMENT ", i3, " OF categ.class.order:", paste(categ.class.order[[i3]], collapse = " "), "\nCOLUMN ", categ[i3], " OF data1: ", paste( unique(data1[, categ[i3]]), collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +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 } } } -} -if( ! is.null(categ.legend.name)){ -tempo <- fun_check(data = categ.legend.name, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) }else{ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") 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]]) +} +} +# categ.class.order not NULL anymore +if(is.null(categ.legend.name)){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") 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 } +# categ.legend.name not NULL anymore +# management of categ.color if( ! is.null(categ.color)){ # check the nature of 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){ # 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 == TRUE){ -tempo.cat <- paste0("ERROR IN ", function.name, ": categ.color MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR\n\n================\n\n") # integer possible because dealt above -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else{ # convert integers into colors -categ.color <- fun_gg_palette(max(categ.color, na.rm = TRUE)) +if(tempo.check.color == FALSE){ +# convert integers into colors +categ.color <- fun_gg_palette(max(categ.color, na.rm = TRUE))[categ.color] } # 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 = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) } if(any(is.na(categ.color))){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": categ.color ARGUMENT CONTAINS NA") +tempo.warn <- paste0("(", warn.count,") categ.color ARGUMENT CONTAINS NA") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } # end check the nature of color # check the length of color -# No problem of NA management by ggplot2 because already removed 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(unique(data1[, categ[i0]]))){ # here length(categ.color) is equal to the different number of categ -data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +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]]) -levels(data1$categ.color) <- categ.color +data1$categ.color <- factor(data1$categ.color, labels = categ.color) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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 = " ")) +tempo.warn <- paste0("(", warn.count,") 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")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) }else{ -data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order -categ.color <- unique(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]]))) +# 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]]))) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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 = " ")) +tempo.warn <- paste0("(", warn.count,") 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))) } }else if(length(categ.color) == 1){ -data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +# 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]]))) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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 = " ")) +tempo.warn <- paste0("(", warn.count,") 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))) }else{ -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\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +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) } }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]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +# 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]]) -levels(data1$categ.color) <- categ.color +data1$categ.color <- factor(data1$categ.color, labels = categ.color) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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 = " ")) +tempo.warn <- paste0("(", warn.count,") 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))) } -tempo <- fun_check(data = bar.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) -if( ! is.null(error.disp)){ -tempo <- fun_check(data = error.disp, options = c("SD", "SD.TOP", "SEM", "SEM.TOP"), length = 1, fun.name = function.name) ; eval(ee) -} -tempo <- fun_check(data = error.whisker.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) +# 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)){ -# check the nature of 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) +# optional legend of dot colors +if( ! is.null(dot.categ)){ +ini.dot.categ <- dot.categ +if( ! dot.categ %in% names(data1)){ # no need to use all() because length(dot.categ) = 1 +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(dot.categ %in% categ){ # no need to use all() because length(dot.categ) = 1 +# management of dot legend if dot.categ %in% categ (because legends with the same name are joined in ggplot2) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") THE COLUMN NAME OF data1 INDICATED IN THE dot.categ ARGUMENT (", dot.categ, ") HAS BEEN REPLACED BY ", paste0(dot.categ, "_DOT"), " TO AVOID MERGED LEGEND BY GGPLOT2") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +data1 <- data.frame(data1, dot.categ = data1[, dot.categ]) # dot.categ is not a column name of data1 (checked above with reserved words) +dot.categ <- paste0(dot.categ, "_DOT") +names(data1)[names(data1) == "dot.categ"] <- dot.categ # paste0(dot.categ, "_DOT") is not a column name of data1 (checked above with reserved words) +# 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, "\nINDEED, dot.categ ARGUMENT IS MADE TO HAVE MULTIPLE DOT COLORS NOT RELATED TO THE BOXPLOT CATEGORIES") +# 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) +} +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) +}else{ +data1[, dot.categ] <- factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor +} +}else{ +dot.categ.class.order <- levels(data1[, dot.categ]) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") 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))) +} +# dot.categ.class.order not NULL anymore +if(all(dot.color == "same") & length(dot.color) == 1){ +if( ! identical(ini.dot.categ, categ[length(categ)])){ +tempo.cat <- paste0("ERROR IN ", function.name, ":WHEN dot.color ARGUMENT IS \"same\", THE COLUMN NAME IN dot.categ ARGUMENT MUST BE IDENTICAL TO THE LAST COLUMN NAME IN categ ARGUMENT. HERE IT IS:\ndot.categ: ", paste(ini.dot.categ, collapse = " "), "\ncateg: ", paste(categ, collapse = " ")) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +}else if( ! identical(unlist(categ.class.order[length(categ)]), dot.categ.class.order)){ +tempo.cat <- paste0("ERROR IN ", function.name, ":WHEN dot.color ARGUMENT IS \"same\",\nLAST COMPARTMENT OF categ.class.order ARGUMENT AND dot.categ.class.order ARGUMENT CANNOT BE DIFFERENT:\nLAST COMPARTMENT OF categ.class.order: ", paste(unlist(categ.class.order[length(categ)]), collapse = " "), "\ndot.categ.class.order: ", paste(dot.categ.class.order, collapse = " ")) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +} +} +if(identical(categ, ini.dot.categ) & ! identical(unlist(categ.class.order), dot.categ.class.order) & identical(sort(unlist(categ.class.order)), sort(dot.categ.class.order))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") THE categ AND dot.categ ARGUMENT ARE IDENTICAL, BUT ORDER OF THE CLASSES IS NOT THE SAME:\ncateg.class.order: ", paste(unlist(categ.class.order), collapse = " "), "\ndot.categ.class.order: ", paste(dot.categ.class.order, collapse = " "), "\nNOTE THAT ORDER OF categ.class.order IS THE ONE USED FOR THE AXIS REPRESENTATION") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} +if(is.null(dot.categ.legend.name)){ +dot.categ.legend.name <- if(ini.dot.categ %in% categ[length(categ)]){dot.categ}else{ini.dot.categ} # +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") THE dot.categ.legend.name SETTING IS NULL. THIS NAME WILL BE USED: ", dot.categ.legend.name) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} +# dot.categ.legend.name not NULL anymore +}else{ +if( ! is.null(dot.categ.class.order)){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") THE dot.categ.class.order ARGUMENT IS NOT NULL, BUT THE dot.categ ARGUMENT IS\n-> dot.categ.class.order NOT CONSIDERED AS NO LEGEND WILL BE DRAWN") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} +} +# 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 == TRUE){ -tempo.cat <- paste0("ERROR IN ", function.name, ": dot.color MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR\n\n================\n\n") # integer possible because dealt above -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else{ # convert integers into colors -dot.color <- fun_gg_palette(max(dot.color, na.rm = TRUE)) +if(tempo.check.color == FALSE){ +# convert integers into colors +dot.color <- fun_gg_palette(max(dot.color, na.rm = TRUE))[dot.color] } # 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 bar color +dot.color <- categ.color # same color of the dots as the corresponding box color warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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(levels(factor(dot.color)), collapse = " ")) +tempo.warn <- paste0("(", warn.count,") dot.color ARGUMENT HAS BEEN SET TO \"same\"\nTHUS, DOTS WILL HAVE THE SAME COLORS AS THE CORRESPONDING BOXPLOT") 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 = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) } if(any(is.na(dot.color))){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": dot.color ARGUMENT CONTAINS NA") +tempo.warn <- paste0("(", warn.count,") dot.color ARGUMENT CONTAINS NA") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } # end check the nature of color # check the length of color -# No problem of NA management by ggplot2 because already removed +if( ! is.null(dot.categ)){ +# optional legend of dot colors +if(length(dot.color) > 1 & 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 COLUMN (", dot.categ, "):\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) +}else if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color +dot.color <- rep(dot.color, length(dot.categ.class.order)) +} +data1 <- data.frame(data1, dot.color = data1[, dot.categ]) +data1$dot.color <- factor(data1$dot.color, labels = dot.color) # do not use labels = unique(dot.color). Otherwise, we can have green1 green2 when dot.color is c("green", "green") +dot.color <- as.character(unique(data1$dot.color[order(data1[, dot.categ])])) # reorder the dot.color character vector +if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color +dot.color <- rep(dot.color, length(dot.categ.class.order)) +} +tempo.check <- unique(data1[ , c(dot.categ, "dot.color")]) +if(length(unique(data1[ , "dot.color"])) > 1 & ( ! (nrow(tempo.check) == length(unique(data1[ , "dot.color"])) & nrow(tempo.check) == length(unique(data1[ , dot.categ]))))){ # length(unique(data1[ , "dot.color"])) > 1 because if only one color, can be attributed to each class of 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) +}else{ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") IN dot.categ ARGUMENT (", ini.dot.categ, "), THE FOLLOWING COLORS Of DOTS:\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))) +} +# 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(unique(data1[, categ[i0]]))){ # here length(dot.color) is equal to the different number of categ -data1[, categ[i0]] <- factor(data1[, categ[i0]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +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]]) -levels(data1$dot.color) <- dot.color +data1$dot.color <- factor(data1$dot.color, labels = dot.color) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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 = " ")) +tempo.warn <- paste0("(", warn.count,") 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]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +# 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]]))) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": 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 = " ")) +tempo.warn <- paste0("(", warn.count,") 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\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -} -tempo <- fun_check(data = dot.tidy, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = dot.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.border.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) -if( ! is.null(ylim)){ -tempo <- fun_check(data = ylim, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & any(ylim %in% c(Inf, -Inf))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ylim ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES\n\n================\n\n") - -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +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) } +# 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 } -tempo <- fun_check(data = ylog, options = c("no", "log2", "log10"), length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ylog != "no"){ +# 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))){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": ylog ARGUMENT SET TO ", ylog, ".\nVALUES FROM THE y ARGUMENT COLUMN OF THE data1 DATA FRAME MUST BE ALREADY ", toupper(ylog), " TRANSFORMED, AS THE ylog ARGUMENT JUST MODIFIES THE AXIS SCALE") +tempo.warn <- paste0("(", warn.count,") 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))) -if( ! is.null(ylim)){ -if(any(ylim <= 0)){ +} +# 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){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": ylim ARGUMENT CAN SPAN ZERO OR NEGATIVE VALUES IF ylog ARGUMENT IS SET TO ", ylog, " BECAUSE THIS LATTER ARGUMENT DOES NOT TRANSFORM DATA, JUST MODIFIES THE AXIS SCALE") +tempo.warn <- paste0("(", warn.count,") 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))) -}else if(any( ! is.finite(if(ylog == "log10"){10^ylim}else{2^ylim}))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": ylim ARGUMENT RETURNS INF WITH THE ylog ARGUMENT SET TO ", ylog, "\nAS SCALE COMPUTATION IS ", ifelse(ylog == "log10", 10, 2), "^ylim:\n", paste(ifelse(ylog == "log10", 10, 2)^ylim, collapse = " "), "\nARE YOU SURE THAT ylim ARGUMENT HAS BEEN SPECIFIED WITH VALUES ALREADY IN LOG SCALE?\n", paste(ylim, collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) } +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) } +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] } -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\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +# end integer colors into gg_palette } +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) } -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\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) } } -tempo <- fun_check(data = y.include.zero, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) -# inactivated because xlim and ylim already log transformed -# if(tempo$problem == FALSE & ylog != "no" & y.include.zero == TRUE){ -# tempo.warn <- paste0("FROM FUNCTION ", function.name, ": ylog ARGUMENT SET TO ", ylog, " AND y.include.zero ARGUMENT SET TO TRUE -> y.include.zero ARGUMENT RESET TO FALSE BECAUSE NO 0 ALLOWED IN LOG SCALE") +# 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))) # } -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) +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))) } -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) -if( ! is.null(xlab)){ -if(all(class(xlab) %in% "expression")){ # to deal with math symbols -tempo <- fun_check(data = xlab, class = "expression", length = 1, fun.name = function.name) ; eval(ee) -}else{ -tempo <- fun_check(data = xlab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +# 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,") COLUMN ", column.check[i2], " OF data1 CONTAINS NA") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } } -if( ! is.null(ylab)){ -if(all(class(ylab) %in% "expression")){ # to deal with math symbols -tempo <- fun_check(data = ylab, class = "expression", length = 1, fun.name = function.name) ; eval(ee) -}else{ -tempo <- fun_check(data = ylab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +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[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 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))) } } -tempo <- fun_check(data = vertical, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ylog != "no" & vertical == FALSE){ -vertical <- TRUE +data1 <- data1[-removed.row.nb, ] +} +for(i2 in 1:length(column.check)){ +if(any( ! levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]]))){ warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": BECAUSE OF A BUG IN ggplot2, CANNOT FLIP BARS HORIZONTALLY WITH A YLOG SCALE -> vertical ARGUMENT RESET TO TRUE") +tempo.warn <- paste0("(", warn.count,") 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 +if(length(categ.color) == 1 & length(categ.class.order) > 1){ # to deal with single color +categ.color <- rep(categ.color, length(categ.class.order)) } -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 = 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 = 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 = 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) -} +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 +if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color +dot.color <- rep(dot.color, length(dot.categ.class.order)) } -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))){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \nDIRECTORY PATH INDICATED IN THE lib.path PARAMETER DOES NOT EXISTS: ", lib.path, "\n\n============\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.color)) +}else{ +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]])]) } } -if(any(arg.check) == TRUE){ -stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -# 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 argument checking (and modification for proper color management) -# 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 -if(length(categ) == 1){ -# new data frames for bar and error bars -mean.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]]) ; names(x.env) <-categ[1] ; x.env}, FUN = mean, na.rm = TRUE) -sd.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]]) ; names(x.env) <-categ[1] ; x.env}, FUN = sd, na.rm = TRUE) -nb.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]]) ; names(x.env) <- categ[1] ; x.env}, FUN = function(x.env2){length(x.env2[ ! is.na(x.env2)])}) -if( ! all(identical(mean.dataframe[, categ[1]], sd.dataframe[, categ[1]]) & identical(mean.dataframe[, categ[1]], nb.dataframe[, categ[1]]))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": aggregate OUTPUT IS DIFFERENT IN TERM OF CLASS ORDER FOR mean.dataframe, sd.dataframe AND nb.dataframe. CODE HAS TO BE MODIFIED\n\n================\n\n") -stop(tempo.cat, call. = FALSE) }else{ -sem.dataframe <- sd.dataframe -sem.dataframe[, y] <- sd.dataframe[, y] / (nb.dataframe[, y])^0.5 +removed.row.nb <- NULL +removed.rows <- NULL } -# end new data frames for bar and error bars +# 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 bar 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(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[1]))) # fill because this is what is used with geom_bar -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(stroke = dot.border.size, size = dot.size, alpha = dot.alpha, pch = 21)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot()) # to easily have the equivalent of the grouped bars +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]] -if( ! is.null(dot.color)){ -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 = 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 +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] -if( ! identical(dot.coord$y, dot.coord$y.check)){ -tempo.cat <- paste0("\n\n================\n\nERROR 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, call. = FALSE) -} -} -# end per bar dots coordinates recovery -}else if(length(categ) == 2){ -# new data frames for bar and error bars -mean.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]], data1[, categ[2]]) ; names(x.env) <- c(categ[1], categ[2]) ; x.env}, FUN = mean, na.rm = TRUE) -sd.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]], data1[, categ[2]]) ; names(x.env) <- c(categ[1], categ[2]) ; x.env}, FUN = sd, na.rm = TRUE) -nb.dataframe <- aggregate(x = data1[y], by = {x.env <- list(data1[, categ[1]], data1[, categ[2]]) ; names(x.env) <- c(categ[1], categ[2]) ; x.env}, FUN = function(x.env2){length(x.env2[ ! is.na(x.env2)])}) -tempo.check.mean <- mapply(FUN = "paste", mean.dataframe[, categ[1]], mean.dataframe[, categ[2]], sep = "_") -tempo.check.sd <- mapply(FUN = "paste", sd.dataframe[, categ[1]], sd.dataframe[, categ[2]], sep = "_") -tempo.check.nb <- mapply(FUN = "paste", nb.dataframe[, categ[1]], nb.dataframe[, categ[2]], sep = "_") -if( ! all(identical(tempo.check.mean, tempo.check.sd) & identical(tempo.check.mean, tempo.check.nb))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": aggregate OUTPUT IS DIFFERENT IN TERM OF CLASS ORDER FOR mean.dataframe, sd.dataframe AND nb.dataframe. CODE HAS TO BE MODIFIED\n\n================\n\n") -stop(tempo.cat, call. = FALSE) }else{ -sem.dataframe <- sd.dataframe -sem.dataframe[, y] <- sd.dataframe[, y] / (nb.dataframe[, y])^0.5 +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 } -# end new data frames for bar and error bars +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), categ[1], drop = FALSE])) +} +} +# } +# 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 bar 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(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[2]))) # fill because this is what is used with geom_bar -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(stroke = dot.border.size, size = dot.size, alpha = dot.alpha, pch = 21)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot()) # to easily have the equivalent of the grouped bars +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]] -if( ! is.null(dot.color)){ -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 = 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 +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] -if( ! (identical(dot.coord$y, dot.coord$y.check) & identical(dot.coord$group, dot.coord$categ.check))){ -tempo.cat <- paste0("\n\n================\n\nERROR 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, call. = FALSE) -} -} }else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +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 } -data2 <- mean.dataframe -if( ! is.null(error.disp)){ -if(error.disp == "SD"){ -data2 <- data.frame(data2, SD = sd.dataframe[, y], ERROR.INF = mean.dataframe[, y] - sd.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sd.dataframe[, y]) -}else if(error.disp == "SD.TOP"){ -data2 <- data.frame(data2, SD = sd.dataframe[, y], ERROR.INF = mean.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sd.dataframe[, y]) -}else if(error.disp == "SEM"){ -data2 <- data.frame(data2, SEM = sem.dataframe[, y], ERROR.INF = mean.dataframe[, y] - sem.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sem.dataframe[, y]) -}else if(error.disp == "SEM.TOP"){ -data2 <- data.frame(data2, SEM = sem.dataframe[, y], ERROR.INF = mean.dataframe[, y], ERROR.SUP = mean.dataframe[, y] + sem.dataframe[, y]) +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) }else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 3\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} +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])])) } -# stat output -stat <- data2 -names(stat)[names(stat) == y] <- "MEAN" -# end stat output -# range depending on means and error bars -if(is.null(ylim)){ -if(is.null(dot.color)){ # no dots plotted -if( ! is.null(error.disp)){ -if(any(c(data2[, "ERROR.INF"], data2[, "ERROR.SUP"]) %in% c(Inf, -Inf))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE data2 ARGUMENT CONTAINS -Inf OR Inf VALUES IN THE ERROR.INF OR ERROR.SUP COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -ylim <- range(c(data2[, "ERROR.INF"], data2[, "ERROR.SUP"]), 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 +# } }else{ -if(any(data2[, y] %in% c(Inf, -Inf))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE data2 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))) -} -ylim <- range(data2[, 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 +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") +stop(tempo.cat) } +# 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 +} +# 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,") FROM FUNCTION ", function.name, ": THE data1 ARGUMENT CONTAINS -Inf OR Inf VALUES IN THE y COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +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))) } -ylim <- 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 -} -} -if(suppressWarnings(all(ylim %in% c(Inf, -Inf)))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED YLIM CONTAINS Inf VALUES, BECAUSE VALUES FROM data2 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +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 } -# end range depending on means and error bars -ylim.order <- order(ylim) # to deal with inverse axis -ylim <- sort(ylim) -ylim[1] <- ylim[1] - abs(ylim[2] - ylim[1]) * ifelse(diff(ylim.order) > 0, y.bottom.extra.margin, y.top.extra.margin) # diff(ylim.order) > 0 means not inversed axis -ylim[2] <- ylim[2] + abs(ylim[2] - ylim[1]) * ifelse(diff(ylim.order) > 0, y.top.extra.margin, y.bottom.extra.margin) # diff(ylim.order) > 0 means not inversed axis -if(y.include.zero == TRUE){ # no need to check ylog != "no" because done before -ylim <- range(c(ylim, 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 +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) } -ylim <- ylim[ylim.order] -if(any(is.na(ylim))){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 4\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +y.lim.order <- order(y.lim) # to deal with inverse axis +y.lim <- sort(y.lim) +y.lim[1] <- y.lim[1] - abs(y.lim[2] - y.lim[1]) * ifelse(diff(y.lim.order) > 0, y.bottom.extra.margin, y.top.extra.margin) # diff(y.lim.order) > 0 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 } -# width commputations -if(length(categ) == 2){ -bar.width2 <- bar.width / length(unique(data1[, categ[length(categ)]])) # real width of each bar in x-axis unit, among the set of grouped bar. Not relevant if no grouped bars length(categ) == 1 -}else if(length(categ) == 1){ -bar.width2 <- bar.width -}else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 5\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +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) } -error.whisker.width <- bar.width * error.whisker.width # real error bar width -dot.jitter <- bar.width2 * dot.jitter # real dot.jitter -# end width commputations -# barplot +# 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(xlab)){categ[1]}else{xlab})) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylab(if(is.null(ylab)){y}else{ylab})) +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")) @@ -6466,13 +6609,13 @@ 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,") FROM FUNCTION ", function.name, ": \"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") +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 } } if(add.check == TRUE & classic == TRUE){ -# BEWARE: not possible to add several times theme(). NO message but the last one overwrites the others +# 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( @@ -6514,29 +6657,71 @@ axis.text.x = if(vertical == TRUE){ggplot2::element_text(angle = tempo.just$angl axis.text.y = if(vertical == TRUE){NULL}else{ggplot2::element_text(angle = tempo.just$angle, hjust = tempo.just$hjust, vjust = tempo.just$vjust)} )) } +# 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 -# barplot and error bars -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_bar(data = data2, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[length(categ)]), stat = "identity", position = ggplot2::position_dodge(width = NULL), color = "black", width = bar.width)) # stat = "identity" because already counted, position = position_dodge(width = NULL) for grouped bars (width = NULL means no overlap between grouped bars). Please, see explanation in https://stackoverflow.com/questions/34889766/what-is-the-width-argument-in-position-dodge/35102486#35102486 -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), guide = ggplot2::guide_legend(override.aes = list(fill = categ.color)))) # values are the values of color (which is the border color in geom_bar. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor -if( ! is.null(error.disp)){ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_errorbar(data = data2, mapping = ggplot2::aes_string(x = categ[1], group = categ[length(categ)], ymin = "ERROR.INF", ymax = "ERROR.SUP"), position = ggplot2::position_dodge(width = bar.width), color = "black", width = error.whisker.width)) # cannot use fill = categ[length(categ)] because not an aesthetic of geom_errorbar, but if only x = categ[1], wrong x coordinates with grouped bars + + + + +# 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) +}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))) + } -# end barplot and error bars -# coordinates management (for random plotting and for stat display) -# bars -bar.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data[[1]] # to have the summary statistics of the plot. Here because can be required for stat.disp when just bar are plotted -# end bars -if( ! is.null(dot.color)){ +} +# 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))) +} +} +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, bar.coord[c("fill", "group", "x")], by = intersect("group", "group"), sort = FALSE) # rd for random. Send the coord of the bars 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 bar.coord. Thus, no need to consider fill +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\nERROR 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, call. = FALSE) +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) } 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 bars into the coord data.frame of the dots (in the column x.y) +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 @@ -6548,13 +6733,13 @@ 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")) }else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") +stop(tempo.cat) } 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\nERROR 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, call. = FALSE) +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) } # end random dots } @@ -6562,35 +6747,170 @@ stop(tempo.cat, call. = FALSE) # coordinates are recover during plotting (see dot.coord.tidy1 below) # end tidy dots } -# end coordinates management (for random plotting and for stat display) +# 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) +}else{ +tempo.polygon <- cbind(tempo.polygon, c(t(stat[, c(categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE) +} +} +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(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], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE) +}else{ +tempo.polygon <- cbind(tempo.polygon, c(t(stat[, c(categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE) +} +} +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) +} +tempo.polygon$COLOR <- factor(tempo.polygon$COLOR, levels = unique(categ.color)) +if( ! is.null(categ.class.order)){ +for(i2 in 1:length(categ)){ +tempo.polygon[, categ[i2]] <- factor(tempo.polygon[, categ[i2]], levels = categ.class.order[[i2]]) +} +} +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") +} +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") +} +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") +} +# end boxplot display before dot display if box.fill = TRUE + + + + + + # dot display if( ! is.null(dot.color)){ if(dot.tidy == FALSE){ -if(isTRUE(all.equal(dot.border.size, 0))){ # similar to dot.border.size == 0 but deals with floats (approx is enough) -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, color = dot.coord.rd3$dot.color, alpha = dot.alpha, pch = 16)) # 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 +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)]), stroke = dot.border.size, size = dot.size, fill = dot.coord.rd3$dot.color, alpha = dot.alpha, pch = 21)) # 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_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 +} +}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 +} +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.color)), 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 } }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", color = categ[length(categ)]), position = ggplot2::position_dodge(width = bar.width), binaxis = "y", stackdir = "center", alpha = dot.alpha, fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"], show.legend = FALSE, binwidth = (ylim[2] - ylim[1]) / dot.bin.nb)) # very weird behavior of geom_dotplot, 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.) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(isTRUE(all.equal(dot.border.size, 0))){as.character(levels(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]))}else{rep("black", 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. BEWARE: , guide = ggplot2::guide_legend(override.aes = list(fill = levels(dot.color))) here +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 = categ[length(categ)]), +position = ggplot2::position_dodge(width = box.width), +binaxis = "y", +stackdir = "center", +alpha = dot.alpha, +fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"], +stroke = dot.border.size, +color = if(is.null(dot.border.color)){dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]}else{rep(dot.border.color, nrow(dot.coord))}, +# show.legend = FALSE, +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(dot.color)), 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 +}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(dot.color)), guide = ggplot2::guide_legend(label = FALSE, override.aes = list(name = NA, fill = rep(NA, length(dot.color)), color = if(is.null(dot.border.color)){rep(NA, length(dot.color))}else{dot.border.color}, stroke = NA)))) # 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 +} # 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\nERROR 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, call. = FALSE) +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))]] } -tempo.bar.coord <- merge(bar.coord, unique(dot.coord[, c("group", categ)]), by = intersect("group", "group"), sort = FALSE) # add the categ in bar.coord. BEWARE: by = intersect("group", "group") because group is enough as only one value of x per group number in bar.coord. Thus, no need to consider fill -if(nrow(tempo.bar.coord) != nrow(bar.coord)){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE merge() FUNCTION DID NOT RETURN A CORRECT tempo.bar.coord DATA FRAME. CODE HAS TO BE MODIFIED\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +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) } -dot.coord.tidy2 <- merge(dot.coord.tidy1, tempo.bar.coord[c("fill", "group", "x", categ)], by = intersect("group", "group"), sort = FALSE) # send the coord of the bars 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 bar.coord. Thus, no need to consider fill +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\nERROR 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, call. = FALSE) +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) } 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 @@ -6602,183 +6922,216 @@ 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")) }else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") +stop(tempo.cat) } 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\nERROR 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, call. = FALSE) +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) } # end coordinates of tidy dots } +coord.names <- c(coord.names, "dots") } # end dot display -# 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 = bar.coord$x, y = ylim[2], label = fun_round(bar.coord$y, 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 bar.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 -} -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(bar.coord[order(bar.coord$x), ], stat.coord1[order(stat.coord1$x.y), ], stat.coord2[order(stat.coord2$x.y), ]) # should be ok to use bar.coord$x and stat.coord$x.y to assemble the two data frames because x coordinates of the bars. 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\nERROR IN ", function.name, ": FUSION OF bar.coord, stat.coord1 AND stat.coord2 ACCORDING TO bar.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, call. = FALSE) -} -dot.text.coord <- stat.coord3[, c("x", "group", "dot.min", "dot.max")] -names(dot.text.coord)[names(dot.text.coord) == "dot.min"] <- "text.min.pos" -names(dot.text.coord)[names(dot.text.coord) == "dot.max"] <- "text.max.pos" -} -if( ! is.null(error.disp)){ # for text just above error bars -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 -if( ! identical(stat[order(stat[, categ[1]]), categ[1]], tempo.data1[order(tempo.data1[, categ[1]]), categ[1]])){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE stat AND tempo.data1\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check") -names(tempo.data1)[names(tempo.data1) == "group"] <- "group.check" -stat.coord4 <- cbind(stat[order(stat[, categ[1]]), ], tempo.data1[order(tempo.data1[, 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 -if( ! fun_comp_2d(stat[order(stat[, categ[1]], stat[, categ[2]]), c(categ[1], categ[2])], tempo.data1[order(tempo.data1[, categ[1]], tempo.data1[, categ[2]]), c(categ[1], categ[2])])$identical.content){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE stat AND tempo.data1\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check") -names(tempo.data1)[names(tempo.data1) == categ[2]] <- paste0(categ[2], ".check") -names(tempo.data1)[names(tempo.data1) == "group"] <- "group.check" -stat.coord4 <- cbind(stat[order(stat[, categ[1]], stat[, categ[2]]), ], tempo.data1[order(tempo.data1[, paste0(categ[1], ".check")], tempo.data1[,paste0(categ[2], ".check")]), ]) -} -}else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 8\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if( ! identical(bar.coord$group[order(bar.coord$group)], stat.coord4$group.check[order(stat.coord4$group.check)])){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE bar.coord AND stat.coord4\n\n============\n\n") -stop(tempo.cat, call. = FALSE) + + + +# 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 = as.character(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(categ.color)))) # , 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{ -stat.coord5 <- cbind(bar.coord[order(bar.coord$group), ], stat.coord4[order(stat.coord4$group.check), ]) -error.text.coord <- stat.coord5[, c("x", "group", "ERROR.INF", "ERROR.SUP")] # -names(error.text.coord)[names(error.text.coord) == "ERROR.INF"] <- "text.min.pos" -names(error.text.coord)[names(error.text.coord) == "ERROR.SUP"] <- "text.max.pos" +# 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") } +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") } -if(( ! is.null(dot.color)) & ! is.null(error.disp)){ # for text above max dot or error bar -stat.coord3 <- stat.coord3[order(stat.coord3$x), ] -stat.coord5 <- stat.coord5[order(stat.coord5$x), ] -if( ! identical(stat.coord3$group, stat.coord5$group)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE PROBLEM IN TRYING TO ASSEMBLE stat.coord3 AND stat.coord5\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -stat.coord6 <- data.frame(stat.coord3, min.dot.error = mapply(FUN = min, stat.coord3$dot.min, stat.coord5$ERROR.INF, na.rm = TRUE)) -stat.coord7 <- data.frame(stat.coord6, max.dot.error = mapply(FUN = max, stat.coord3$dot.max, stat.coord5$ERROR.SUP, na.rm = TRUE)) -both.text.coord <- stat.coord7[, c("x", "group", "min.dot.error", "max.dot.error")] # -names(both.text.coord)[names(both.text.coord) == "min.dot.error"] <- "text.min.pos" -names(both.text.coord)[names(both.text.coord) == "max.dot.error"] <- "text.max.pos" +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(categ.color)))) #, 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 = as.character(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 + } +# end boxplot display (if box.fill = FALSE, otherwise, already plotted above) + + + + +# 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 } -if(( ! is.null(dot.color)) & is.null(error.disp)){ -text.coord <- dot.text.coord -}else if(is.null(dot.color) & ! is.null(error.disp)){ -text.coord <- error.text.coord -}else if(( ! is.null(dot.color)) & ! is.null(error.disp)){ -text.coord <- both.text.coord +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) } -if( ! (is.null(dot.color) & is.null(error.disp))){ -bar.coord <- bar.coord[order(bar.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(bar.coord$group)) because with error, the correspondence between x and group is not the same -if( ! identical(text.coord$x, bar.coord$x)){ -tempo.cat <- paste0("\n\n============\n\nERROR: text.coord AND bar.coord DO NOT HAVE THE SAME x COLUMN CONTENT\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +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) } } # end stat coordinates # stat display -if(is.null(dot.color) & is.null(error.disp)){ # text just above bars +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 = bar.coord$x[bar.coord$y >= 0], y = bar.coord$y[bar.coord$y >= 0], label = fun_round(bar.coord$y, 2)[bar.coord$y >= 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 bar.coord$x set the order -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "text", x = bar.coord$x[bar.coord$y < 0], y = bar.coord$y[bar.coord$y < 0], label = fun_round(bar.coord$y, 2)[bar.coord$y < 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 bar.coord$x set the order -}else{ # text just above error bars or dots -# I checked that text.coord and bar.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[bar.coord$y >= 0], y = text.coord$text.max.pos[bar.coord$y >= 0], label = fun_round(bar.coord$y, 2)[bar.coord$y >= 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 bar.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[bar.coord$y < 0], y = text.coord$text.min.pos[bar.coord$y < 0], label = fun_round(bar.coord$y, 2)[bar.coord$y < 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 bar.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 +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 } # end stat display }else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 9\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 9\n\n============\n\n") +stop(tempo.cat) } } # 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 = ylim, n = ifelse(is.null(y.tick.nb), length(tempo.coord$y.major_source), y.tick.nb)) -# for the ggplot2 bug with ylog, this does not work: eval(parse(text = ifelse(vertical == FALSE & ylog == "log10", "ggplot2::scale_x_continuous", "ggplot2::scale_y_continuous"))) +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(ylog == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(ylog == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(ylog == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 10\n\n============\n\n") ; stop(tempo.cat, call. = FALSE)}, +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(ylim) < 0, "reverse", "identity") # equivalent to ggplot2::scale_y_reverse() +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 = ylim)) # clip = "off" to have secondary ticks outside plot region does not work +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 }else{ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_flip(ylim = ylim)) # clip = "off" to have secondary ticks outside plot region does not work +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 } # 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 ylim -if(ylog == "log10"){ -ylim.order <- order(ylim) # to deal with inverse axis +# 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^ylim, first = (regexpr(pattern = "\\+|\\-", text = 10^ylim)))) # recover the power of 10. Example recover 08 from 1e+08 -mantisse <- as.numeric(substr(x = 10^ylim, start = 1, stop = (regexpr(pattern = "\\+|\\-", text = 10^ylim) - 2))) # recover the mantisse. Example recover 1.22 from 1.22e+08 +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(ylim.order) > 0, 1, -1)):(power10.exp[2] + ifelse(diff(ylim.order) > 0, 1, -1))))) -tempo.tick.pos <- sort(tempo.tick.pos, decreasing = ifelse(diff(ylim.order) > 0, FALSE, TRUE)) -tempo.tick.pos <- log10(tempo.tick.pos[tempo.tick.pos >= min(10^ylim) & tempo.tick.pos <= max(10^ylim)]) +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\nERROR IN ", function.name, ": CODE INCONSISTENCY 11\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 11\n\n============\n\n") +stop(tempo.cat) } # 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)) & ylog == "no"){ +}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 ylim neg or not, inv or not +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\nERROR IN ", function.name, ": CODE INCONSISTENCY 12\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 12\n\n============\n\n") +stop(tempo.cat) } 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)) }else{ -ticks.pos <- suppressWarnings(as.numeric(tempo.coord$x.labels))# too difficult to predict the behavior of tempo.coord$x.major_source depending on ylim neg or not, inv or not +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\nERROR IN ", function.name, ": CODE INCONSISTENCY 13\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 13\n\n============\n\n") +stop(tempo.cat) } tick.dist <- mean(diff(ticks.pos), na.rm = TRUE) minor.tick.dist <- tick.dist / (y.inter.tick.nb + 1) @@ -6789,38 +7142,65 @@ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ann } # 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){ -suppressWarnings(print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}))))) +# 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})))))) }else{ +# 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,") FROM FUNCTION ", function.name, ": PLOT NOT SHOWN AS REQUESTED") +tempo.warn <- paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED") warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -# end barplot -if(warn.print == TRUE & ! is.null(warn)){ -warning(warn, call. = FALSE) -cat("\n\n") -} -if(return == TRUE){ -output <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))) -output <- list(stat = stat, removed.row.nb = removed.row.nb, removed.rows = removed.rows, data = output$data, axes = output$layout$panel_params[[1]], warn = paste0("\n", warn, "\n\n")) -return(output) -} -} - - -######## fun_gg_boxplot() #### ggplot2 boxplot + background dots if required - - +# 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 +} +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) +}else{ +names(output$data) <- coord.names +} +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) +} +# end outputs +# end main code +} ######## fun_gg_prop() #### ggplot2 proportion barplot -######## fun_gg_strip() #### ggplot2 stripchart + mean/median ######## fun_gg_dot() #### ggplot2 categorial dotplot + mean/median @@ -9374,1544 +9754,3 @@ return(output) # do not use cat() because the idea is to reuse the message - - - - - - - - - - - - - - - - - - - - - - - - - - -# https://ggplot2-book.org/scales.html - - - -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, -dot.color = "black", -dot.categ = NULL, -dot.categ.class.order = NULL, -dot.categ.legend.name = NULL, -dot.tidy = TRUE, -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 -){ - -# 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") ; 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 = "same" ; dot.categ = "Group1"; dot.categ.class.order = c("G", "H") ; 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 - -# 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 = "black" ; dot.categ = "Group1" ; 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 = FALSE ; plot = TRUE ; add = NULL ; warn.print = FALSE ; lib.path = NULL - -# 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 = "black" ; dot.categ = "Group1" ; 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 = FALSE ; plot = TRUE ; add = NULL ; warn.print = FALSE ; lib.path = NULL - - - - - -# 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) -} -} -# end required function checking -# reserved words to avoid bugs (used in this function) -reserved.words <- c("categ.check", "categ.color", "dot.color", "dot.categ", "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) -} -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) -} -} -} -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) -} -} -} -if( ! is.null(dot.categ)){ -tempo <- fun_check(data = dot.categ, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -} -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) -} -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) -} -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) -} -} -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) -} -} -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) -} -} -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) -} -} -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) -} -} -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) -} -} -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) -} -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) -} -} -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))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", paste(lib.path, collapse = "\n")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -} -if(any(arg.check) == TRUE){ -stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # -} -# 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 -warn.count <- 0 -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) -} -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) -}else{ -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) -} -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) -} -# 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) -} -if( ! is.null(dot.categ)){ -if(dot.categ %in% categ){ -reserved.words <- c(reserved.words, paste0(dot.categ, "_DOT")) # paste0(dot.categ, "_DOT") is added to the reserved words because in such situation, a new column will be added to data1 that is named paste0(dot.categ, "_DOT") -} -} -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] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -# BEWARE: names of y argument potentially replaced -if(any(categ == tempo.output$ini[i3])){ -categ[categ == tempo.output$ini[i3]] <- tempo.output$post[i3] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -# BEWARE: names of categ argument potentially replaced -if( ! is.null(dot.categ)){ -if(any(dot.categ == tempo.output$ini[i3])){ -dot.categ[dot.categ == tempo.output$ini[i3]] <- tempo.output$post[i3] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN dot.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 dot.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))) -} -} -# BEWARE: names of dot.categ argument potentially replaced -} -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -# 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 -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -data1[, categ[i1]] <- factor(data1[, categ[i1]]) # if already a factor, change nothing, if characters, levels according to alphabetical order -} -# 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)){ -if(length(categ.class.order) != length(categ)){ -tempo.cat <- paste0("ERROR IN ", function.name, ": categ.class.order ARGUMENT MUST BE A LIST OF LENGTH EQUAL TO LENGTH OF categ\nHERE IT IS LENGTH: ", length(categ.class.order), " VERSUS ", length(categ)) -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) -}else{ -for(i3 in 1:length(categ.class.order)){ -if(is.null(categ.class.order[[i3]])){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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 -}else{ -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 -} -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 - -} -} -} -}else{ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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]]) -} -} -# categ.class.order not NULL anymore -if(is.null(categ.legend.name)){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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 -} -# 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))[categ.color] -} -# 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) -} -if(any(is.na(categ.color))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") categ.color ARGUMENT CONTAINS NA") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -# 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) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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]]))) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -}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]]))) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -}else{ -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) -} -}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) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -# 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)){ -ini.dot.categ <- dot.categ -if( ! dot.categ %in% names(data1)){ # no need to use all() because length(dot.categ) = 1 -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(dot.categ %in% categ){ # no need to use all() because length(dot.categ) = 1 -# management of dot legend if dot.categ %in% categ (because legends with the same name are joined in ggplot2) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") THE COLUMN NAME OF data1 INDICATED IN THE dot.categ ARGUMENT (", dot.categ, ") HAS BEEN REPLACED BY ", paste0(dot.categ, "_DOT"), " TO AVOID MERGED LEGEND BY GGPLOT2") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -data1 <- data.frame(data1, dot.categ = data1[, dot.categ]) # dot.categ is not a column name of data1 (checked above with reserved words) -dot.categ <- paste0(dot.categ, "_DOT") -names(data1)[names(data1) == "dot.categ"] <- dot.categ # paste0(dot.categ, "_DOT") is not a column name of data1 (checked above with reserved words) -# 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, "\nINDEED, dot.categ ARGUMENT IS MADE TO HAVE MULTIPLE DOT COLORS NOT RELATED TO THE BOXPLOT CATEGORIES") -# 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) -} -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) -}else{ -data1[, dot.categ] <- factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor -} -}else{ -dot.categ.class.order <- levels(data1[, dot.categ]) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -# dot.categ.class.order not NULL anymore -if(all(dot.color == "same") & length(dot.color) == 1){ -if( ! identical(ini.dot.categ, categ[length(categ)])){ -tempo.cat <- paste0("ERROR IN ", function.name, ":WHEN dot.color ARGUMENT IS \"same\", THE COLUMN NAME IN dot.categ ARGUMENT MUST BE IDENTICAL TO THE LAST COLUMN NAME IN categ ARGUMENT. HERE IT IS:\ndot.categ: ", paste(ini.dot.categ, collapse = " "), "\ncateg: ", paste(categ, collapse = " ")) -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) -}else if( ! identical(unlist(categ.class.order[length(categ)]), dot.categ.class.order)){ -tempo.cat <- paste0("ERROR IN ", function.name, ":WHEN dot.color ARGUMENT IS \"same\",\nLAST COMPARTMENT OF categ.class.order ARGUMENT AND dot.categ.class.order ARGUMENT CANNOT BE DIFFERENT:\nLAST COMPARTMENT OF categ.class.order: ", paste(unlist(categ.class.order[length(categ)]), collapse = " "), "\ndot.categ.class.order: ", paste(dot.categ.class.order, collapse = " ")) -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) -} -} -if(identical(categ, ini.dot.categ) & ! identical(unlist(categ.class.order), dot.categ.class.order) & identical(sort(unlist(categ.class.order)), sort(dot.categ.class.order))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") THE categ AND dot.categ ARGUMENT ARE IDENTICAL, BUT ORDER OF THE CLASSES IS NOT THE SAME:\ncateg.class.order: ", paste(unlist(categ.class.order), collapse = " "), "\ndot.categ.class.order: ", paste(dot.categ.class.order, collapse = " "), "\nNOTE THAT ORDER OF categ.class.order IS THE ONE USED FOR THE AXIS REPRESENTATION") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -if(is.null(dot.categ.legend.name)){ -dot.categ.legend.name <- if(ini.dot.categ %in% categ[length(categ)]){dot.categ}else{ini.dot.categ} # -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -# dot.categ.legend.name not NULL anymore -}else{ -if( ! is.null(dot.categ.class.order)){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") THE dot.categ.class.order ARGUMENT IS NOT NULL, BUT THE dot.categ ARGUMENT IS\n-> dot.categ.class.order NOT CONSIDERED AS NO LEGEND WILL BE DRAWN") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -} -# 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))[dot.color] -} -# 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 -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") dot.color ARGUMENT HAS BEEN SET TO \"same\"\nTHUS, DOTS WILL HAVE THE SAME COLORS AS THE CORRESPONDING BOXPLOT") -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) -} -if(any(is.na(dot.color))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") dot.color ARGUMENT CONTAINS NA") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -# end check the nature of color -# check the length of color -if( ! is.null(dot.categ)){ -# optional legend of dot colors -if(length(dot.color) > 1 & 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 COLUMN (", dot.categ, "):\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) -}else if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color -dot.color <- rep(dot.color, length(dot.categ.class.order)) -} -data1 <- data.frame(data1, dot.color = data1[, dot.categ]) -data1$dot.color <- factor(data1$dot.color, labels = dot.color) # do not use labels = unique(dot.color). Otherwise, we can have green1 green2 when dot.color is c("green", "green") -dot.color <- as.character(unique(data1$dot.color[order(data1[, dot.categ])])) # reorder the dot.color character vector -if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color -dot.color <- rep(dot.color, length(dot.categ.class.order)) -} -tempo.check <- unique(data1[ , c(dot.categ, "dot.color")]) -if(length(unique(data1[ , "dot.color"])) > 1 & ( ! (nrow(tempo.check) == length(unique(data1[ , "dot.color"])) & nrow(tempo.check) == length(unique(data1[ , dot.categ]))))){ # length(unique(data1[ , "dot.color"])) > 1 because if only one color, can be attributed to each class of 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) -}else{ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN dot.categ ARGUMENT (", dot.categ, "), THE FOLLOWING COLORS Of DOTS:\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))) -} -# 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) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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]]))) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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) -} -# 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 -} -# 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))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -# 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){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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))) -} -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) -} -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"){ -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) -} -} -} -# 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))) -} -# 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,") COLUMN ", column.check[i2], " OF data1 CONTAINS NA") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -} -} -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[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 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))) -} -} -data1 <- data1[-removed.row.nb, ] -} -for(i2 in 1:length(column.check)){ -if(any( ! levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]]))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") 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 -if(length(categ.color) == 1 & length(categ.class.order) > 1){ # to deal with single color -categ.color <- rep(categ.color, length(categ.class.order)) -} -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 -if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color -dot.color <- rep(dot.color, length(dot.categ.class.order)) -} -data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.color)) -}else{ -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]])]) -} -} -} -}else{ -removed.row.nb <- NULL -removed.rows <- NULL -} -# 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(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] -}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 -} -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), categ[1], drop = FALSE])) -} -} -# } -# 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] -}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 -} -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) -}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], categ[2])])) -} -} -# } -}else{ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") -stop(tempo.cat) -} -# 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 -} -# 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))) -} -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 -} -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) -} -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 -} -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) -} -# 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 -} -} -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)} -)) -} -}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)} -)) -} -# 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) -}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))) - -} -} -# 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))) -} -} -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) -} -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")) -}else{ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") -stop(tempo.cat) -} -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) -} -# end random dots -} -# tidy dots -# coordinates are recover during plotting (see dot.coord.tidy1 below) -# end tidy dots -} -# 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) -}else{ -tempo.polygon <- cbind(tempo.polygon, c(t(stat[, c(categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE) -} -} -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(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], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE) -}else{ -tempo.polygon <- cbind(tempo.polygon, c(t(stat[, c(categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2], categ[i2])])), stringsAsFactors = TRUE) -} -} -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) -} -tempo.polygon$COLOR <- factor(tempo.polygon$COLOR, levels = unique(categ.color)) -if( ! is.null(categ.class.order)){ -for(i2 in 1:length(categ)){ -tempo.polygon[, categ[i2]] <- factor(tempo.polygon[, categ[i2]], levels = categ.class.order[[i2]]) -} -} -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") -} -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") -} -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") -} -# end boxplot display before dot display if box.fill = TRUE - - - - - - -# 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 -} -}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 -} -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.color)), 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 -} -}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 = categ[length(categ)]), -position = ggplot2::position_dodge(width = box.width), -binaxis = "y", -stackdir = "center", -alpha = dot.alpha, -fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"], -stroke = dot.border.size, -color = if(is.null(dot.border.color)){dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]}else{rep(dot.border.color, nrow(dot.coord))}, -# show.legend = FALSE, -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, values = rep(dot.border.size, length(dot.color)), 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 -}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(dot.color)), guide = ggplot2::guide_legend(label = FALSE, override.aes = list(name = NA, fill = rep(NA, length(dot.color)), color = if(is.null(dot.border.color)){rep(NA, length(dot.color))}else{dot.border.color}, stroke = NA)))) # 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 -} -# 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))]] -} -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) -} -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) -} -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")) -}else{ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") -stop(tempo.cat) -} -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) -} -# end coordinates of tidy dots -} -coord.names <- c(coord.names, "dots") -} -# 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 = as.character(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(categ.color)))) # , 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") -} -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") -} -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(categ.color)))) #, 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 = as.character(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 - -} -# end boxplot display (if box.fill = FALSE, otherwise, already plotted above) - - - - -# 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 -} -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) -} -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) -} -} -# 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 -} -# end stat display -}else{ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 9\n\n============\n\n") -stop(tempo.cat) -} -} -# 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 -}else{ -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 -} -# 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) -} -# 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) -} -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)) -}else{ -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) -} -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)) -} -} -} -# 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})))))) -}else{ -# 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))) -} -# 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 -} -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) -}else{ -names(output$data) <- coord.names -} -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) -} -# end outputs -# end main code -} - - - - - - - diff --git a/cute_little_R_functions.docx b/cute_little_R_functions.docx index 5ebdfb138ba96da9b5a807d9a8b36fadc04a5e8e..a6e1f521fa615e369f081fdaf2389f802ab89ddf 100644 Binary files a/cute_little_R_functions.docx and b/cute_little_R_functions.docx differ diff --git a/scatter.docx b/scatter.docx index 160a03d7a851be23878216454ad22b3537665db6..e507d6647b3d27982fd771760eead756743a4030 100644 Binary files a/scatter.docx and b/scatter.docx differ diff --git a/test.xlsx b/test.xlsx index a67aca67d54e147d09fc92bf435e6e30393d7854..981de877363611e52fe54909ca04c6ba8df0cd3c 100644 Binary files a/test.xlsx and b/test.xlsx differ