diff --git a/boxplot.docx b/boxplot.docx index bbefdb0337fa44fdf71fe059511498ad70476773..90ecf42141f07d3713b84f7c5ebcac0c5ce377c7 100644 Binary files a/boxplot.docx and b/boxplot.docx differ diff --git a/boxplot_ new.docx b/boxplot_ new.docx deleted file mode 100644 index 2aaebef9151e31c50358546427a0f422181db60d..0000000000000000000000000000000000000000 Binary files a/boxplot_ new.docx and /dev/null differ diff --git a/boxplot_ new_facet.docx b/boxplot_ new_log.docx similarity index 100% rename from boxplot_ new_facet.docx rename to boxplot_ new_log.docx diff --git a/cute_little_R_functions.R b/cute_little_R_functions.R index 096f0dde6814431eec318596b875419876b45341..f8d25e508b9fb8c848e3be6d09021b4da7e5210f 100644 --- a/cute_little_R_functions.R +++ b/cute_little_R_functions.R @@ -5754,373 +5754,322 @@ return(output) # Error message with empty classes. Test: obs1 <- data.frame(Time = 1:20, Group1 = rep(c("G", "H"), times = 10), Group2 = rep(c("A", "B"), each = 10)) ; obs1[obs1$Group2 == "A", "Time"] <- NA, and the example below # In classic mode, no bar for box legend - - - -######## fun_gg_prop() #### ggplot2 proportion barplot - - -######## fun_gg_dot() #### ggplot2 categorial dotplot + mean/median - - -######## fun_gg_violin() #### ggplot2 violins - - -######## fun_gg_line() #### ggplot2 lines + background dots and error bars - - -# DO NOT ERASE. COMPARE WITH BAR MEAN BEFORE AND RECOVER WHAT HAS BEEN MODIFIED - -fun_gg_line <- function(data1, y, categ, categ.class.order = NULL, categ.legend.name = NULL, categ.color = NULL, line.size = 1, 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 = FALSE, y.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, title = "", text.size = 12, text.angle = 0, classic = FALSE, grid = FALSE, return = 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 = FALSE, +dot.tidy.bin.nb = 50, +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, +article = 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 box, create a factor column with a single class and specify the name of this column in the 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 (i.e., as categ1, knowing that categ2 must also be specified in this situation). 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 -# 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) +# data1: dataframe containing one column of values (see y argument below) and one or two columns of categories (see categ argument below). Duplicated column names are not allowed +# y: character string of the data1 column name for y-axis (column containing numeric values). Numeric values will be split according to the classes of the column names indicated in the categ argument 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 be either 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: no empty classes allowed. To have a single box, create a factor column with a single class and specify the name of this column in the categ argument (here, 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 (i.e., as categ1, knowing that categ2 must also be specified in this situation) +# 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 color character 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 color character string for color of dots. +# If NULL, no dots plotted +# If "same", the dots will have the same colors as the respective boxplots +# Otherwise, colors will depend on the dot.categ argument. If dot.categ is NULL, then colors will be applied to each class of the last column name specified in categ. If dot.categ is non NULL, colors will be applied to each class of the column name specified in dot.categ. Color strings can be (1), (2) or (3) of categ.color argument, except that in the possibility (3), the rule "a single color per class of categ and a single class of categ per color", does not have to be respected (for instance, each dot can have a different color). See examples Put in example or leave here? -> Example: with categ = "Group1", dot.color = "red" and dot.categ = NULL, all the dots will be red, whatever the classes in Group1 column of data1, and no legend will be display for dots. With categ = c("Group1", "Group2"), dot.color = c("red", "blue") and dot.categ = NULL, the dots will be red for first class of Group2 and blue for the 2nd class of Group2, and no legend will be display for dots. With categ = c("Group1", "Group2"), dot.color = c("red", "blue") and dot.categ = "Group1", the dots will be red for first class of Group1 and blue for the 2nd class of Group1, and a legend will be display for dots +# dot.categ: optional single character string of a data1 column name (further refered to as categ3), which is associated to the dot.color argument to generate a legend for dots. If non NULL, then a legend will be created for the dots, in addition to the legend for the boxes. If NULL, no legend created and the colors of dot will depend on dot.color and categ arguments (see the explanation in dot.color) +# 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. BEWARE: change the true coordinates of dots that are aligned. Thus the gain in aestheticism is associated with a loss in precision that can be very important. If FALSE, dots are randomly spread, using the dot.jitter argument (see below) keeping the true dot coordinates +# 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. In other words, increase the number to have smaller dots. 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 -# ylog: logical. Log scale for the y-axis? BEWARE: do not tranform the data, but just display ticks in a log scale manner. BEWARE: if TRUE, ylim must not contain null or negative values. In addition, will be automatically set to FALSE if vertical argument is set to FALSE, to prevent a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) -# y.tick.nb: number of desired values on the y-axis -# y.include.zero: logical. Does ylim range include 0? BEWARE: if ylog = TRUE, will be automately set to FALSE with a warning message -# 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. BEWARE with ylog = TRUE, the range result must not overlap zero or negative values +# 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 (i.e., main ticks) on the y-axis (n argument of the the cute::fun_scale() function). BEWARE: provide this number even if y.log is "log2" or "log10", which can be difficult to read (e.g., ..., 2^2, 2^2.5, 2^3, ...). If NULL and if y.log is "no", then the number of label values is set by ggplot2. If NULL and if y.log is "log2" or "log10", then the number of label values correspond to integer units between y.lim (e.g., ..., 2^1, 2^2, 2^3, ...) +# y.inter.tick.nb: number of desired secondary ticks between main ticks. Ignored if y.log is other than "no" (log scale plotted) +# 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 for x-axis legend. If NULL, character string of categ1 -# ylab: a character string y-axis legend. If NULL, character string of the y argument -# vertical: logical. Vertical bars? BEWARE: cannot have horizontal bars with a log axis, i.e., ylog = TRUE & vertical = FALSE (see ylog above) -# title: character string of the graph title -# text.size: numeric value of the text size (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. -# 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 -# return: logical. Return the graph parameters? -# lib.path: absolute path of the required packages, if not in the default folders -} - - -######## fun_gg_heatmap() #### ggplot2 heatmap + overlaid mask if required - - -#test plot.margin = margin(up.space.mds, right.space.mds, down.space.mds, left.space.mds, "inches") to set the dim of the region plot ? -# if matrix is full of zero (or same value I guess), heatmap is complicate. Test it and error message - -# Check OK: clear to go Apollo -fun_gg_heatmap <- function(data1, legend.name1 = "", low.color1 = "blue", mid.color1 = "white", high.color1 = "red", limit1 = NULL, midpoint1 = NULL, data2 = NULL, color2 = "black", alpha2 = 0.5, invert2 = FALSE, text.size = 12, title = "", title.text.size = 12, show.scale = TRUE, rotate = FALSE, return = FALSE, plot = TRUE, add = NULL, warn.print = FALSE, lib.path = NULL){ -# AIM -# ggplot2 heatmap with the possibility to overlay a mask -# see also: -# draw : http://www.sthda.com/english/wiki/ggplot2-quick-correlation-matrix-heatmap-r-software-and-data-visualization -# same range scale : https://stackoverflow.com/questions/44655723/r-ggplot2-heatmap-fixed-scale-color-between-graphs -# for ggplot2 specifications, see: https://ggplot2.tidyverse.org/articles/ggplot2-specs.html -# ARGUMENTS -# data1: numeric matrix or data frame resulting from the conversion of the numeric matrix by reshape2::melt() -# legend.name1: character string of the data1 heatmap scale legend -# low.color1: character string of the color (i.e., "blue" or "#0000FF") of the lowest scale value -# mid.color1: same as low.color1 but for the middle scale value. If NULL, the middle color is the default color between low.color1 and high.color1. BEWARE: argument midpoint1 is not ignored, even if mid.color1 is NULL, meaning that the default mid color can still be controled -# high.color1: same as low.color1 but for the highest scale value -# limit1: 2 numeric values defining the lowest and higest color scale values. If NULL, take the range of data1 values -# midpoint1: single numeric value defining the value corresponding to the mid.color1 argument. A warning message is returned if midpoint1 does not correspond to the mean of limit1 values, because the color scale is not linear anymore. If NULL, takes the mean of limit1 values. Mean of data1, instead of mean of limit1, can be used here if required -# data2: binary mask matrix (made of 0 and 1) of same dimension as data1 or a data frame resulting from the conversion of the binary mask matrix by reshape2::melt(). Value 1 of data2 will correspond to color2 argument (value 0 will be NA color), and the opposite if invert2 argument is TRUE (inverted mask) -# color2: color of the 1 values of the binary mask matrix. The 0 values will be color NA -# alpha2: numeric value (from 0 to 1) of the mask transparency -# invert2: logical. Invert the mask (1 -> 0 and 0 -> 1)? -# text.size: numeric value of the size of the texts in scale # title: character string of the graph title # title.text.size: numeric value of the title size (in points) -# show.scale: logical. Show color scale? -# rotate: logical. Rotate the heatmap 90° clockwise? +# article: logical. If TRUE, use a article theme (article like). If FALSE, use a classic related ggplot theme. Use the add argument (add = "+ggplot2::theme_classic()" for the exact classic ggplot theme +# grid: logical. Draw horizontal lines in the background to better read the box values? Not considered if article == 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 +# add: character string allowing to add more ggplot2 features (dots, lines, themes, facet, etc.). Ignored if NULL. +# BEWARE: (1) must start with "+" just after the simple or double opening quote (no space, end of line, carriage return, etc., allowed between the two characters), (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::". Example: "+ ggplot2::coord_flip() + ggplot2::theme_bw()" +# If the character string contains the "ggplot2::theme" string, then the article argument of fun_gg_boxplot() (see above) is ignored with a warning +# Handle the add 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. 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 (see below). if NULL, the function will use the R library default folders # REQUIRED PACKAGES # ggplot2 -# reshape2 +# scales # REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_check() +# fun_comp_2d() +# fun_gg_just() +# fun_gg_palette() +# fun_name_change() # fun_pack() +# fun_check() # fun_round() +# fun_scale() # RETURN -# a heatmap if plot argument is TRUE +# a boxplot if plot argument is TRUE # a list of the graph info if return argument is TRUE: -# $data: a list of the graphic info -# $axes: a list of the axes info -# $scale: the scale info (lowest, mid and highest values) -# $warn: the warning messages. Use cat() for proper display. NULL if no warning -# EXAMPLES -# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), title = "GRAPH 1") -# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), return = TRUE) -# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), legend.name1 = "VALUE", title = "GRAPH 1", text.size = 5, data2 = matrix(rep(c(1,0,0,0), 4), ncol = 4), invert2 = FALSE, return = TRUE) -# diagonal matrix -# fun_gg_heatmap(data1 = matrix(c(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), ncol = 4)) -# fun_gg_heatmap(data1 = reshape2::melt(matrix(c(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), ncol = 4))) -# error message -# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), data2 = matrix(rep(c(1,0,0,0), 5), ncol = 5)) -# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), data2 = reshape2::melt(matrix(rep(c(1,0,0,0), 4), ncol = 4))) -# fun_gg_heatmap(data1 = reshape2::melt(matrix(1:16, ncol = 4)), data2 = reshape2::melt(matrix(rep(c(1,0,0,0), 4), ncol = 4))) -#### 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) -# 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) -# 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)) -# 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) -# 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) -# 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) -# 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) -# 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) -# 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) -# 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()") -# 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) - - - - - +# $data: the initial data +# $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) +# $plot: the graphic box and dot coordinates +# $dots: dot coordinates +# $main.box: coordinates of boxes +# $median: median coordinates +# $sup.whisker: coordinates of top whiskers (y for base and y.end for extremities) +# $inf.whisker: coordinates of bottom whiskers (y for base and y.end for extremities) +# $sup.whisker.edge: coordinates of top whisker edges (x and xend) +# $inf.whisker.edge: coordinates of bottom whisker edges(x and xend) +# $mean: diamon mean coordinates (only if box.mean argument is TRUE) +# $stat.display.positive: coordinates of stat numbers when positive (only if stat.disp argument is TRUE) +# $stat.display.negative: coordinates of stat numbers when negative (only if stat.disp argument is TRUE) +# y.second.tick.positions: coordinates of secondary ticks (only if y.inter.tick.nb argument is non NULL or if y.log argument is different from "no") +# y.second.tick.values: values of secondary ticks. NULL except if y.inter.tick.nb argument is non NULL or if y.log argument is different from "no") +# $panel: the variable names used for the panels (NULL if no panels) +# $axes: the x-axis and y-axis info +# $warn: 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.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 = 50, 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, article = TRUE, grid = FALSE, return = FALSE, plot = TRUE, add = NULL, warn.print = TRUE, lib.path = NULL) # DEBUGGING -# data1 = matrix(1:16, ncol = 4) ; legend.name1 = "" ; low.color1 = "blue" ; mid.color1 = "white" ; high.color1 = "red" ; limit1 = NULL ; midpoint1 = NULL ; data2 = matrix(rep(c(1,0,0,0), 4), ncol = 4) ; color2 = "black" ; alpha2 = 0.5 ; invert2 = FALSE ; text.size = 12 ; title = "" ; title.text.size = 12 ; show.scale = TRUE ; rotate = 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)) ; set.seed(NULL) ; obs1$Time[1:10] <- NA ; data1 = obs1 ; y = "Time" ; categ = c("Group1") ; categ.class.order = NULL ; 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 = "black" ; dot.categ = "Group1"; dot.categ.class.order = c("G", "H") ; dot.categ.legend.name = NULL ; dot.tidy = TRUE ; dot.tidy.bin.nb = 50 ; 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 ; article = 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)) ; set.seed(NULL) ; obs1$Time[1:10] <- NA ; 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 ; article = 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)) ; set.seed(NULL) ; 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 ; article = 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_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_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) +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_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) } # end required function checking -# no reserved words required for this function -# argument checking -warn <- NULL -warn.count <- 0 +# reserved words to avoid bugs (names of dataframe columns used in this function) +reserved.words <- c("categ.check", "categ.color", "dot.color", "dot.categ", "dot.max", "dot.min", "group", "PANEL", "group.check", "MEAN", "tempo.categ1", "tempo.categ2", "text.max.pos", "text.min.pos", "x", "x.y", "y", "y.check", "y_from.dot.max", "ymax", "tidy_group") +# end reserved words to avoid bugs (used in this function) +# argument primary 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)) -if(all(is.matrix(data1))){ -tempo <- fun_check(data = data1, class = "matrix", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) -}else if(all(is.data.frame(data1))){ -tempo <- fun_check(data = data1, class = "data.frame", length = 3, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE){ -# structure of reshape2::melt() data frame -tempo <- fun_check(data = data1[, 1], typeof = "integer", fun.name = function.name) -tempo <- fun_check(data = data1[, 2], typeof = "integer", fun.name = function.name) -tempo <- fun_check(data = data1[, 3], mode = "numeric", na.contain = TRUE, fun.name = function.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) } -}else{ -tempo.cat <- paste0("ERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A NUMERIC MATRIX OR A DATA FRAME OUTPUT OF THE reshape::melt() FUNCTION\n\n================\n\n") +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 = legend.name1, class = "character", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = low.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (all(low.color1 %in% colors() | grepl(pattern = "^#", low.color1)))){ # check that all strings of low.color1 start by # -tempo.cat <- paste0("ERROR IN ", function.name, ": low.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n") +} +} +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(mid.color1)){ -tempo <- fun_check(data = mid.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (all(mid.color1 %in% colors() | grepl(pattern = "^#", mid.color1)))){ # check that all strings of mid.color1 start by # -tempo.cat <- paste0("ERROR IN ", function.name, ": mid.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\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) } } -tempo <- fun_check(data = high.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (all(high.color1 %in% colors() | grepl(pattern = "^#", high.color1)))){ # check that all strings of high.color1 start by # -tempo.cat <- paste0("ERROR IN ", function.name, ": high.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n") +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) } -if( ! is.null(limit1)){ -tempo <- fun_check(data = limit1, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & any(limit1 %in% c(Inf, -Inf))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": limit1 ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES\n\n================\n\n") +} +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(midpoint1)){ -tempo <- fun_check(data = midpoint1, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +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) } -if( ! is.null(data2)){ -if(all(is.matrix(data2))){ -tempo <- fun_check(data = data2, class = "matrix", mode = "numeric", fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! all(unique(data2) %in% c(0,1))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": MATRIX IN data2 MUST BE MADE OF 0 AND 1 ONLY (MASK MATRIX)\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & all(is.matrix(data1)) & ! identical(dim(data1), dim(data2))){ # matrix and matrix -tempo.cat <- paste0("ERROR IN ", function.name, ": MATRIX DIMENSION IN data2 MUST BE IDENTICAL AS MATRIX DIMENSION IN data1. HERE IT IS RESPECTIVELY:\n", paste(dim(data2), collapse = " "), "\n", paste(dim(data1), collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & all(is.data.frame(data1)) & nrow(data1) != prod(dim(data2))){ # reshape2 and matrix -tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME IN data2 MUST HAVE ROW NUMBER EQUAL TO PRODUCT OF DIMENSIONS OF data1 MATRIX. HERE IT IS RESPECTIVELY:\n", paste(nrow(data1), collapse = " "), "\n", paste(prod(dim(data2)), collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -}else if(all(is.data.frame(data2))){ -tempo <- fun_check(data = data2, class = "data.frame", length = 3, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE){ -# structure of reshape2::melt() data frame -tempo <- fun_check(data = data2[, 1], typeof = "integer", fun.name = function.name) -tempo <- fun_check(data = data2[, 2], typeof = "integer", fun.name = function.name) -tempo <- fun_check(data = data2[, 3], mode = "numeric", fun.name = function.name) -} -if(tempo$problem == FALSE & ! all(unique(data2[, 3]) %in% c(0,1))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": THIRD COLUMN OF DATA FRAME IN data2 MUST BE MADE OF 0 AND 1 ONLY (MASK DATA FRAME)\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & all(is.data.frame(data1)) & ! identical(dim(data1), dim(data2))){ # data frame and data frame -tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME DIMENSION IN data2 MUST BE IDENTICAL TO DATA FRAME DIMENSION IN data1. HERE IT IS RESPECTIVELY:\n", paste(dim(data2), collapse = " "), "\n", paste(dim(data1), collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & all(is.matrix(data1)) & nrow(data2) != prod(dim(data1))){ # reshape2 and matrix -tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME IN data2 MUST HAVE ROW NUMBER EQUAL TO PRODUCT OF DIMENSION OF data1 MATRIX. HERE IT IS RESPECTIVELY:\n", paste(nrow(data2), collapse = " "), "\n", paste(prod(dim(data1)), collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -}else{ -tempo.cat <- paste0("ERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A NUMERIC MATRIX OR A DATA FRAME OUTPUT OF THE reshape::melt() FUNCTION\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) +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 = color2, class = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (all(color2 %in% colors() | grepl(pattern = "^#", color2)))){ # check that all strings of color2 start by # -tempo.cat <- paste0("ERROR IN ", function.name, ": color2 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -tempo <- fun_check(data = alpha2, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = invert2, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = title, class = "character", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = title.text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = show.scale, class = "logical", 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 = article, 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)){ @@ -6154,1810 +6103,2319 @@ 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 -# package checking -fun_pack(req.package = c("reshape2", "ggplot2"), lib.path = lib.path) -# end package checking -# main code -if(all(is.matrix(data1))){ -data1 <- reshape2::melt(data1) # transform a matrix into a dataframe with 2 coordinates columns and the third intensity column +# end argument primary 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(rotate == TRUE){ -data1[, 1] <- rev(data1[, 1]) +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(is.null(limit1)){ -if(any(data1[, 3] %in% c(Inf, -Inf))){ +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(i2 in 1:length(tempo.output$ini)){ # a loop to be sure to take the good ones +names(data1)[names(data1) == tempo.output$ini[i2]] <- tempo.output$post[i2] +if(any(y == tempo.output$ini[i2])){ +y[y == tempo.output$ini[i2]] <- tempo.output$post[i2] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE data1 ARGUMENT CONTAINS -Inf OR Inf VALUES IN THE THIRD COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +tempo.warn <- paste0("(", warn.count,") IN y ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i2], " HAS BEEN REPLACED BY ", tempo.output$post[i2], "\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))) } -limit1 <- range(data1[, 3], 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 +# BEWARE: names of y argument potentially replaced +if(any(categ == tempo.output$ini[i2])){ +categ[categ == tempo.output$ini[i2]] <- tempo.output$post[i2] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE limit1 ARGUMENT IS NULL -> RANGE OF data1 ARGUMENT HAS BEEN TAKEN: ", paste(fun_round(limit1), collapse = " ")) +tempo.warn <- paste0("(", warn.count,") IN categ ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i2], " HAS BEEN REPLACED BY ", tempo.output$post[i2], "\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(suppressWarnings(any(limit1 %in% c(Inf, -Inf)))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED LIMIT CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") -stop(tempo.cat, call. = FALSE) } -} -if(is.null(midpoint1)){ -midpoint1 <- mean(limit1, na.rm = TRUE) +# BEWARE: names of categ argument potentially replaced +if( ! is.null(dot.categ)){ +if(any(dot.categ == tempo.output$ini[i2])){ +dot.categ[dot.categ == tempo.output$ini[i2]] <- tempo.output$post[i2] warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE midpoint1 ARGUMENT IS NULL -> MEAN OF limit1 ARGUMENT HAS BEEN TAKEN: ", paste(fun_round(midpoint1), collapse = " ")) +tempo.warn <- paste0("(", warn.count,") IN dot.categ ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i2], " HAS BEEN REPLACED BY ", tempo.output$post[i2], "\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))) -}else if(fun_round(midpoint1, 9) != fun_round(mean(limit1), 9)){ +} +} +# BEWARE: names of dot.categ argument potentially replaced +} warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE midpoint1 ARGUMENT (", fun_round(mean(midpoint1), 9), ") DOES NOT CORRESPOND TO THE MEAN OF THE limit1 ARGUMENT (", fun_round(mean(limit1), 9), "). COLOR SCALE IS NOT LINEAR") +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))) +if( ! (is.null(add) | is.null(tempo.output$ini))){ +if(grepl(x = add, pattern = paste(tempo.output$ini, collapse = "|"))){ +tempo.cat <- paste0("ERROR IN ", function.name, ": DETECTION OF COLUMN NAMES OF data1 IN THE add ARGUMENT STRING, THAT CORRESPOND TO RESERVED STRINGS FOR ", function.name, "\nCOLUMN NAMES HAVE TO BE CHANGED\nTHE PROBLEMATIC COLUMN NAMES ARE SOME OF THESE NAMES:\n", paste(tempo.output$ini, collapse = " "), "\nIN THE DATA FRAME OF data1 AND IN THE STRING OF add ARGUMENT, TRY TO REPLACE NAMES BY:\n", paste(tempo.output$post, collapse = " "), "\n\nFOR INFORMATION, THE RESERVED WORDS ARE:\n", paste(reserved.words, collapse = "\n")) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) } -if( ! is.null(data2)){ -if(all(is.matrix(data2))){ -data2 <- reshape2::melt(data2) # transform a matrix into a dataframe with 2 coordinates columns and the third intensity column } -if(rotate == TRUE){ -data2[, 1] <- rev(data2[, 1]) } -data2[, 3] <- factor(data2[, 3]) # to converte continuous scale into discrete scale +# end reserved word checking +# management of add containing facet +facet.categ <- NULL +if( ! is.null(add)){ +facet.check <- TRUE +tempo <- unlist(strsplit(x = add, split = "\\+")) # +if(any(grepl(x = tempo, pattern = "ggplot2::facet_wrap"))){ +tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_wrap")]))) +facet.categ <- names(tempo1$params$facets) +tempo.text <- "facet_wrap" +facet.check <- FALSE +}else if(grepl(x = add, pattern = "ggplot2::facet_grid")){ +tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_grid")]))) +facet.categ <- c(names(tempo1$params$rows), names(tempo1$params$cols)) +tempo.text <- "facet_grid" +facet.check <- FALSE } -tempo.gg.name <- "gg.indiv.plot." -tempo.gg.count <- 0 # to facilitate debugging -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_raster(data = data1, mapping = ggplot2::aes_string(x = names(data1)[ifelse(rotate == FALSE, 2, 1)], y = names(data1)[ifelse(rotate == FALSE, 1, 2)], fill = names(data1)[3]), show.legend = show.scale)) # 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_gradient2(low = low.color1, high = high.color1, mid = mid.color1, midpoint = midpoint1, limit = limit1, breaks = c(limit1[1], midpoint1, limit1[2]), labels = fun_round(c(limit1[1], midpoint1, limit1[2])), name = legend.name1)) -if( ! is.null(data2)){ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_raster(data = data2, mapping = ggplot2::aes_string(x = names(data2)[ifelse(rotate == FALSE, 2, 1)], y = names(data2)[ifelse(rotate == FALSE, 1, 2)], alpha = names(data2)[3]), fill = color2, show.legend = FALSE)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", values = if(invert2 == FALSE){c(0, alpha2)}else{c(alpha2, 0)}, guide = FALSE)) -# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_raster(data = data2, mapping = ggplot2::aes_string(x = names(data2)[ifelse(rotate == FALSE, 2, 1)], y = names(data2)[ifelse(rotate == FALSE, 1, 2)], group = names(data2)[3]), fill = data2[, 3], alpha = alpha2, show.legend = FALSE)) # BEWARE: this does not work if NA present, because geom_raster() has a tendency to complete empty spaces, and thus, behave differently than geom_tile(). See https://github.com/tidyverse/ggplot2/issues/3025 +if(facet.check == FALSE & ! all(facet.categ %in% names(data1))){ # BEWARE: all(facet.categ %in% names(data1)) is TRUE when facet.categ is NULL +tempo.cat <- paste0("ERROR IN ", function.name, ": DETECTION OF \"", tempo.text, "\" STRING IN THE add ARGUMENT BUT PROBLEM OF VARIABLE DETECTION (COLUMN NAMES OF data1)\nTHE DETECTED VARIABLES ARE:\n", paste(facet.categ, collapse = " "), "\nTHE data1 COLUMN NAMES ARE:\n", paste(names(data1), collapse = " "), "\nPLEASE REWRITE THE add STRING AND RERUN") +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) } -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_fixed()) # x = y -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_y_reverse()) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title)) -add.check <- TRUE -if( ! is.null(add)){ # if add is NULL, then = 0 -if(grepl(pattern = "ggplot2::theme", add) == TRUE){ +} +# end management of add containing facet +# 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,") 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,") 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))) -add.check <- FALSE -} } -if(add.check == TRUE){ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_classic(base_size = text.size)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme( -text = ggplot2::element_text(size = text.size), -plot.title = ggplot2::element_text(size = title.text.size), # stronger than text -line = ggplot2::element_blank(), -axis.title = ggplot2::element_blank(), -axis.text = ggplot2::element_blank(), -axis.ticks = ggplot2::element_blank(), -panel.background = ggplot2::element_blank() -)) +data1[, categ[i1]] <- factor(data1[, categ[i1]]) # if already a factor, change nothing, if characters, levels according to alphabetical order } -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})))) -# ) +# 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,") FROM FUNCTION ", function.name, ": PLOT NOT SHOWN AS REQUESTED") +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[i3]])), 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(warn.print == TRUE & ! is.null(warn)){ -warning(warn, call. = FALSE) +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 + } -if(return == TRUE){ -output <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))) -output <- output$data -names(output)[1] <- "heatmap" -if( ! is.null(data2)){ -names(output)[2] <- "mask" +names(categ.class.order)[i3] <- categ[i3] } -return(list(data = output, axes = output$layout$panel_params[[1]], scale = c(limit1[1], midpoint1, limit1[2]), warn = warn)) } +}else{ +categ.class.order <- vector("list", length = length(categ)) +tempo.categ.class.order <- NULL +for(i2 in 1:length(categ.class.order)){ +categ.class.order[[i2]] <- levels(data1[, categ[i2]]) +names(categ.class.order)[i2] <- categ[i2] +tempo.categ.class.order <- c(tempo.categ.class.order, ifelse(i2 != 1, "\n", ""), categ.class.order[[i2]]) } - - -######## fun_gg_empty_graph() #### text to display for empty graphs - - - - - -# Check OK: clear to go Apollo -fun_gg_empty_graph <- function(text = NULL, text.size = 12, title = NULL, title.size = 8, lib.path = NULL){ -# AIM -# display an empty ggplot2 plot with a text in the middle of the window (for instance to specify that no plot can be drawn) -# ARGUMENTS -# text: character string of the message to display -# text.size: numeric value of the text size (in points) -# title: character string of the graph title -# title.size: numeric value of the title size (in points) -# lib.path: absolute path of the required packages, if not in the default folders -# REQUIRED PACKAGES -# ggplot2 -# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_check() -# fun_pack() -# RETURN -# an empty plot -# EXAMPLES -### simple example -# fun_gg_empty_graph(text = "NO GRAPH") -### white page -# fun_gg_empty_graph() -### all the arguments -# fun_gg_empty_graph(text = "NO GRAPH", text.size = 8, title = "GRAPH1", title.size = 10, lib.path = NULL) -# DEBUGGING -# text = "NO GRAPH" ; text.size = 12 ; title = "GRAPH1" ; title.size = 8 ; 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_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_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) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") THE categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR BOX ORDERING:\n", paste(tempo.categ.class.order, collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -# end required function checking -# 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)) -if( ! is.null(text)){ -tempo <- fun_check(data = text, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +# categ.class.order not NULL anymore (list) +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 } -tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -if( ! is.null(title)){ -tempo <- fun_check(data = title, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +# categ.legend.name not NULL anymore (character string) +# 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] } -tempo <- fun_check(data = title.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -if(any(arg.check) == TRUE){ -stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # +# 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) } -# 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 -# package checking -fun_pack(req.package = c("ggplot2"), lib.path = lib.path) -# end package checking -# main code -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()) -if( ! is.null(text)){ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(data = data.frame(x = 1, y = 1), ggplot2::aes(x = x, y = y, label = text), size = text.size)) +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))) } -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void()) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme( -plot.title = ggplot2::element_text(size = title.size) # stronger than text -)) -suppressWarnings(print(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))) +# end check the nature of color +# check the length of color +categ.len <- 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[categ.len]]))){ # here length(categ.color) is equal to the different number of categ +# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor +data1 <- data.frame(data1, categ.color = data1[, categ[categ.len]]) +data1$categ.color <- factor(data1$categ.color, labels = categ.color) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") IN ", categ[categ.len], " OF categ ARGUMENT, THE FOLLOWING COLORS:\n", paste(categ.color, collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[, categ[categ.len]])), collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +}else if(length(categ.color) == length(data1[, categ[categ.len]])){# 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[categ.len]]))) +data1 <- data.frame(data1, categ.color = categ.color) +tempo.check <- unique(data1[ , c(categ[categ.len], "categ.color")]) +if( ! (nrow(tempo.check) == length(unique(categ.color)) & nrow(tempo.check) == length(unique(data1[ , categ[categ.len]])))){ +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[categ.len], ":\n", paste(unique(mapply(FUN = "paste", data1[ ,categ[categ.len]], data1[ ,"categ.color"])), collapse = "\n")) +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +}else{ +# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor +categ.color <- unique(data1$categ.color[order(data1[, categ[categ.len]])]) # Modif to have length(categ.color) equal to the different number of categ (length(categ.color) == length(levels(data1[, categ[categ.len]]))) +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[categ.len], " AS:\n", paste(levels(factor(data1[, categ[categ.len]])), collapse = " "), "\n", paste(categ.color, collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } - - -################ Graphic extraction - - -######## fun_trim() #### display values from a quantitative variable and trim according to defined cut-offs - - -# Check OK: clear to go Apollo -fun_trim <- function(data, displayed.nb = NULL, single.value.display = FALSE, trim.method = "", trim.cutoffs = c(0.05, 0.975), interval.scale.disp = TRUE, down.space = 0.75, left.space = 0.75, up.space = 0.3, right.space = 0.25, orient = 1, dist.legend = 0.37, box.type = "l", amplif.label = 1.25, amplif.axis = 1.25, std.x.range = TRUE, std.y.range = TRUE, cex.pt = 0.2, col.box = hsv(0.55, 0.8, 0.8), x.nb.inter.tick = 4, y.nb.inter.tick = 0, tick.length = 1, sec.tick.length = 0.75, corner.text = "", amplif.legend = 1, magnific.corner.text = 0.75, trim.return = FALSE){ -# AIM -# trim and display values from a numeric vector or matrix -# plot 4 graphs: stripchart of values, stripchart of rank of values, hitogramme and normal QQPlot -# different kinds of intervals are displayed on the top of graphes to facilitate the analysis of the variable and a trimming setting -# the trimming interval chosen is displayed on top of graphs -# both trimmed and not trimmed values are returned in a list -# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_check() -# ARGUMENTS -# data: values to plot (either a numeric vector or a numeric matrix) -# displayed.nb: number of values displayed. If NULL, all the values are displayed. Otherwise, if the number of values is over displayed.nb, then displayed.nb values are displayed after random selection -# single.value.display: provide the 4 graphs if data is made of a single (potentially repeated value)? If FALSE, an empty graph is displayed if data is made of a single (potentially repeated value). And the return list is made of NULL compartments -# trim.method: Write "" if not required. write "mean.sd" if mean +/- sd has to be displayed as a trimming interval (only recommanded for normal distribution). Write "quantile" to display a trimming interval based on quantile cut-offs. No other possibility allowed. See trim.cutoffs below -# trim.cutoffs: 2 values cutoff for the trimming interval displayed, each value between 0 and 1. Not used if trim.method == "".The couple of values c(lower, upper) represents the lower and upper boundaries of the trimming interval (in proportion), which represent the interval of distribution kept (between 0 and 1). Example: trim.cutoffs = c(0.05, 0.975). What is strictly kept for the display is ]lower , upper[, boundaries excluded. Using the "mean.sd" method, 0.025 and 0.975 represent 95% CI which is mean +/- 1.96 * sd -# interval.scale.disp: display sd and quantiles intervals on top of graphs ? -# down.space: lower vertical margin (in inches, mai argument of par()) -# left.space: left horizontal margin (in inches, mai argument of par()) -# up.space: upper vertical margin between plot region and grapical window (in inches, mai argument of par()) -# right.space: right horizontal margin (in inches, mai argument of par()) -# orient: scale number orientation (las argument of par()). 0, always parallel to the axis; 1, always horizontal; 2, always perpendicular to the axis; 3, always vertical -# dist.legend: numeric value that moves axis legends away in inches (first number of mgp argument of par() but in inches thus / 0.2) -# box.type: bty argument of par(). Either "o", "l", "7", "c", "u", "]", the resulting box resembles the corresponding upper case letter. A value of "n" suppresses the box -# amplif.label: increase or decrease the size of the text in legends -# amplif.axis: increase or decrease the size of the scale numbers in axis -# std.x.range: standard range on the x-axis? TRUE (no range extend) or FALSE (4% range extend). Controls xaxs argument of par() (TRUE is xaxs = "i", FALSE is xaxs = "r") -# std.y.range: standard range on the y-axis? TRUE (no range extend) or FALSE (4% range extend). Controls yaxs argument of par() (TRUE is yaxs = "i", FALSE is yaxs = "r") -# cex.pt: size of points in stripcharts (in inches, thus cex.pt will be thereafter / 0.2) -# col.box: color of boxplot -# x.nb.inter.tick: number of secondary ticks between main ticks on x-axis (only if not log scale). Zero means non secondary ticks -# y.nb.inter.tick: number of secondary ticks between main ticks on y-axis (only if not log scale). Zero means non secondary ticks -# tick.length: length of the ticks (1 means complete the distance between the plot region and the axis numbers, 0.5 means half the length, etc. 0 means no tick -# sec.tick.length: length of the secondary ticks (1 means complete the distance between the plot region and the axis numbers, 0.5 means half the length, etc., 0 for no ticks) -# corner.text: text to add at the top right corner of the window -# amplif.legend: increase or decrease the size of the text of legend -# magnific.corner.text: increase or decrease the size of the text -# trim.return: return the trimmed and non trimmed values? NULL returned for trimmed and non trimmed values if trim.method == "" -# RETURN -# a list containing: -# $trim.method: correspond to trim.method above -# $trim.cutoffs: correspond to trim.cutoffs above -# $real.trim.cutoffs: the two boundary values (in the unit of the numeric vector or numeric matrix analyzed). NULL -# $trimmed.values: the values outside of the trimming interval as defined in trim.cutoffs above -# $kept.values: the values inside the trimming interval as defined in trim.cutoffs above -# EXAMPLES -# fun_trim(data = c(1:100, 1:10), displayed.nb = NULL, single.value.display = FALSE, trim.method = "mean.sd", trim.cutoffs = c(0.05, 0.975), interval.scale.disp = TRUE, down.space = 0.75, left.space = 0.75, up.space = 0.3, right.space = 0.25, orient = 1, dist.legend = 0.37, box.type = "l", amplif.label = 1.25, amplif.axis = 1.25, std.x.range = TRUE, std.y.range = TRUE, cex.pt = 0.2, col.box = hsv(0.55, 0.8, 0.8), x.nb.inter.tick = 4, y.nb.inter.tick = 0, tick.length = 0.5, sec.tick.length = 0.3, corner.text = "", amplif.legend = 1, magnific.corner.text = 0.75, trim.return = TRUE) -# DEBUGGING -# data = c(1:100, 1:10) ; displayed.nb = NULL ; single.value.display = FALSE ; trim.method = "quantile" ; trim.cutoffs = c(0.05, 0.975) ; interval.scale.disp = TRUE ; down.space = 1 ; left.space = 1 ; up.space = 0.5 ; right.space = 0.25 ; orient = 1 ; dist.legend = 0.5 ; box.type = "l" ; amplif.label = 1 ; amplif.axis = 1 ; std.x.range = TRUE ; std.y.range = TRUE ; cex.pt = 0.1 ; col.box = hsv(0.55, 0.8, 0.8) ; x.nb.inter.tick = 4 ; y.nb.inter.tick = 0 ; tick.length = 0.5 ; sec.tick.length = 0.3 ; corner.text = "" ; amplif.legend = 1 ; magnific.corner.text = 0.75 ; trim.return = TRUE # for function debugging -# function name -function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") -# end function name -# required function checking -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) +}else if(length(categ.color) == 1){ +# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # 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[categ.len]]))) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") categ.color ARGUMENT HAS LENGTH 1, MEANING THAT ALL THE DIFFERENT CLASSES OF ", categ[categ.len], "\n", paste(levels(factor(data1[, categ[categ.len]])), 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[categ.len], " COLUMN. HERE IT IS COLOR LENGTH ", length(categ.color), " VERSUS CATEG LENGTH ", length(data1[, categ[categ.len]]), " AND CATEG CLASS LENGTH ", length(unique(data1[, categ[categ.len]])), "\nPRESENCE OF NA COULD BE THE PROBLEM") +stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) } -# end required function checking -# argument checking -# argument checking without fun_check() -if( ! (all(class(data) == "numeric") | all(class(data) == "integer") | (all(class(data) == "matrix") & mode(data) == "numeric"))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": data ARGUMENT MUST BE A NUMERIC VECTOR OR NUMERIC MATRIX\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +}else{ +categ.len <- length(categ) # if only categ1, then colors for classes of categ1, if length(categ) == 2, then colors for classes of categ2 +# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor +categ.color <- fun_gg_palette(length(levels(data1[, categ[categ.len]]))) +data1 <- data.frame(data1, categ.color = data1[, categ[categ.len]]) +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[categ.len], " IN data1:\n", paste(categ.color, collapse = " "), "\n", paste(levels(data1[, categ[categ.len]]), collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -# end argument checking without fun_check() -# argument checking with fun_check() -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)) -if( ! is.null(displayed.nb)){ -tempo <- fun_check(data = displayed.nb, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -if(displayed.nb < 2){ -tempo.cat <- paste0("ERROR IN ", function.name, ": displayed.nb ARGUMENT MUST BE A SINGLE INTEGER VALUE GREATER THAN 1 AND NOT: ", paste(displayed.nb, collapse = " ")) -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +# 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. Do not use dot.categ %in% categ[length(categ)] -> error +# 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) } -tempo <- fun_check(data = single.value.display, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = trim.method, options = c("", "mean.sd", "quantile"), length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = trim.cutoffs, class = "vector", mode = "numeric", length = 2, prop = TRUE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = interval.scale.disp, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = down.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = left.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = up.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = right.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = orient, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = dist.legend, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = box.type, options = c("o", "l", "7", "c", "u", "]", "n"), length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = amplif.label, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = amplif.axis, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = std.x.range, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = std.y.range, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = cex.pt, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = col.box, class = "character", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = x.nb.inter.tick, class = "integer", length = 1, neg.values = FALSE, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = y.nb.inter.tick, class = "integer", length = 1, neg.values = FALSE, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = tick.length, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = sec.tick.length, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = corner.text, class = "character", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = amplif.legend, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = magnific.corner.text, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = trim.return, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -if(any(arg.check) == TRUE){ -stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # -} -# end argument checking with fun_check() -# 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 -# main code -if(class(data) == "matrix"){ -data <- as.vector(data) +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 (", ini.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 } -color.cut <- hsv(0.75, 1, 1) # color of interval selected -col.mean <- hsv(0.25, 1, 0.8) # color of interval using mean+/-sd -col.quantile <- "orange" # color of interval using quantiles -quantiles.selection <- c(0.01, 0.025, 0.05, 0.1, 0.25, 0.5, 0.75, 0.9, 0.95, 0.975, 0.99) # quantiles used in axis to help for choosing trimming cutoffs -if(single.value.display == FALSE & length(unique(data)) == 1){ -par(bty = "n", xaxt = "n", yaxt = "n", xpd = TRUE) -plot(1, pch = 16, col = "white", xlab = "", ylab = "") -text(x = 1, y = 1, paste0("No graphic displayed\nBecause data made of a single different value (", formatC(as.double(table(data))), ")"), cex = 2) -output <- list(trim.method = NULL, trim.cutoffs = NULL, real.trim.cutoffs = NULL, trimmed.values = NULL, kept.values = NULL) }else{ -output <- list(trim.method = trim.method, trim.cutoffs = trim.cutoffs, real.trim.cutoffs = NULL, trimmed.values = NULL, kept.values = NULL) -fun.rug <- function(sec.tick.length.f = sec.tick.length, x.nb.inter.tick.f = x.nb.inter.tick, y.nb.inter.tick.f = y.nb.inter.tick){ -if(x.nb.inter.tick.f > 0){ -inter.tick.unit <- (par("xaxp")[2] - par("xaxp")[1]) / par("xaxp")[3] -par.ini <- par()[c("xpd", "tcl")] -par(xpd = FALSE) -par(tcl = -par()$mgp[2] * sec.tick.length.f) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region) -suppressWarnings(rug(seq(par("xaxp")[1] - 10 * inter.tick.unit, par("xaxp")[2] + 10 * inter.tick.unit, by = inter.tick.unit / (1 + x.nb.inter.tick.f)), ticksize = NA, side = 1)) # ticksize = NA to allow the use of par()$tcl value -par(par.ini) -rm(par.ini) +if(all(dot.color == "same") & length(dot.color) == 1){ +dot.categ.class.order <- unlist(categ.class.order[length(categ)]) +data1[, dot.categ] <- factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") THE dot.categ.class.order SETTING IS NULL AND dot.color IS \"same\". ORDER OF categ.class.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))) +}else{ +dot.categ.class.order <- sort(levels(data1[, dot.categ])) +data1[, dot.categ] <- factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor +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))) } -if(y.nb.inter.tick.f > 0){ -inter.tick.unit <- (par("yaxp")[2] - par("yaxp")[1]) / par("yaxp")[3] -par.ini <- par()[c("xpd", "tcl")] -par(xpd = FALSE) -par(tcl = -par()$mgp[2] * sec.tick.length.f) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region) -suppressWarnings(rug(seq(par("yaxp")[1] - 10 * inter.tick.unit, par("yaxp")[2] + 10 * inter.tick.unit, by = inter.tick.unit / (1 + y.nb.inter.tick.f)), ticksize = NA, side = 2)) # ticksize = NA to allow the use of par()$tcl value -par(par.ini) -rm(par.ini) } +# dot.categ.class.order not NULL anymore (character string) if dot.categ is not NULL +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) } -fun.add.cut <- function(data.f, trim.method.f = trim.method, trim.cutoffs.f = trim.cutoffs, color.cut.f = color.cut, return.f = FALSE){ -# DEBUGGING -# data.f = data ; trim.method.f = "mean.sd"; trim.cutoffs.f = trim.cutoffs ; color.cut.f = color.cut ; return.f = TRUE -real.trim.cutoffs.f <- NULL -if(trim.method.f != ""){ -data.f <- sort(data.f) -par.ini <- par()$xpd -par(xpd = FALSE) -if(trim.method.f == "mean.sd"){ -real.trim.cutoffs.f <- qnorm(trim.cutoffs.f, mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)) -abline(v = qnorm(trim.cutoffs.f, mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), col = color.cut.f) -segments(qnorm(trim.cutoffs.f[1], mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), par()$usr[4] * 0.75, qnorm(trim.cutoffs.f[2], mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), par()$usr[4] * 0.75, col = color.cut.f) } -if(trim.method.f == "quantile"){ -real.trim.cutoffs.f <- quantile(data.f, probs = trim.cutoffs.f, type = 7) -abline(v = quantile(data.f, probs = trim.cutoffs.f, type = 7), col = color.cut.f) -segments(quantile(data.f, probs = trim.cutoffs.f[1], type = 7), par()$usr[4] * 0.75, quantile(data.f, probs = trim.cutoffs.f[2], type = 7), par()$usr[4] * 0.75, col = color.cut.f) +for(i3 in 1:length(categ)){ +if(identical(categ[i3], ini.dot.categ) & ! identical(unlist(categ.class.order[i3]), dot.categ.class.order) & identical(sort(unlist(categ.class.order[i3])), sort(dot.categ.class.order))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") THE dot.categ ARGUMENT SETTING IS PRESENT IN THE categ ARGUMENT SETTING, BUT ORDER OF THE CLASSES IS NOT THE SAME:\ncateg.class.order: ", paste(unlist(categ.class.order[i3]), 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))) } -par(par.ini) -if(return.f == TRUE){ -trimmed.values.f <- data.f[data.f <= real.trim.cutoffs.f[1] | data.f >= real.trim.cutoffs.f[2]] -kept.values.f <- data.f[data.f > real.trim.cutoffs.f[1] & data.f < real.trim.cutoffs.f[2]] } +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 -> ", dot.categ.legend.name, " WILL BE USED AS LEGEND TITLE OF DOTS") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} +# dot.categ.legend.name not NULL anymore (character string) }else{ -real.trim.cutoffs.f <- NULL -trimmed.values.f <- NULL -kept.values.f <- NULL +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))) } -if(return.f == TRUE){ -output <- list(trim.method = trim.method.f, trim.cutoffs = trim.cutoffs.f, real.trim.cutoffs = real.trim.cutoffs.f, trimmed.values = trimmed.values.f, kept.values = kept.values.f) -return(output) +# But dot.categ.class.order will be converted to NULL below (not now) } +# 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] } -fun.interval.scale.display <- function(data.f, col.quantile.f = col.quantile, quantiles.selection.f = quantiles.selection, col.mean.f = col.mean){ # intervals on top of graphs -par.ini <- par()[c("mgp", "xpd")] -par(mgp = c(0.25, 0.25, 0), xpd = NA) -axis(side = 3, at = c(par()$usr[1], par()$usr[2]), labels = rep("", 2), col = col.quantile.f, lwd.ticks = 0) -par(xpd = FALSE) -axis(side = 3, at = quantile(as.vector(data.f), probs = quantiles.selection.f, type = 7), labels = quantiles.selection.f, col.axis = col.quantile.f, col = col.quantile.f) -par(mgp = c(1.75, 1.75, 1.5), xpd = NA) -axis(side = 3, at = c(par()$usr[1], par()$usr[2]), labels = rep("", 2), col = col.mean.f, lwd.ticks = 0) -par(xpd = FALSE) -axis(side = 3, at = m + s * qnorm(quantiles.selection.f), labels = formatC(round(qnorm(quantiles.selection.f), 2)), col.axis = col.mean.f, col = col.mean.f, lwd.ticks = 1) -par(par.ini) +# 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) } -zone<-matrix(1:4, ncol=2) -layout(zone) -par(omi = c(0, 0, 1.5, 0), mai = c(down.space, left.space, up.space, right.space), las = orient, mgp = c(dist.legend / 0.2, 0.5, 0), xpd = FALSE, bty= box.type, cex.lab = amplif.label, cex.axis = amplif.axis, xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r")) -par(tcl = -par()$mgp[2] * tick.length) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region) -if(is.null(displayed.nb)){ -sampled.data <- as.vector(data) -if(corner.text == ""){ -corner.text <- paste0("ALL VALUES OF THE DATASET DISPLAYED") -}else{ -corner.text <- paste0(corner.text, "\nALL VALUES OF THE DATASET DISPLAYED") +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{ -if(length(as.vector(data)) > displayed.nb){ -sampled.data <- sample(as.vector(data), displayed.nb, replace = FALSE) -if(corner.text == ""){ -corner.text <- paste0("BEWARE: ONLY ", displayed.nb, " VALUES ARE DISPLAYED AMONG THE ", length(as.vector(data)), " VALUES OF THE DATASET ANALYZED") -}else{ -corner.text <- paste0(corner.text, "\nBEWARE: ONLY ", displayed.nb, " VALUES ARE DISPLAYED AMONG THE ", length(as.vector(data)), " VALUES OF THE DATASET ANALYZED") +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{ -sampled.data <- as.vector(data) -if(corner.text == ""){ -corner.text <- paste0("BEWARE: THE DISPLAYED NUMBER OF VALUES PARAMETER ", deparse(substitute(displayed.nb)), " HAS BEEN SET TO ", displayed.nb, " WHICH IS ABOVE THE NUMBER OF VALUES OF THE DATASET ANALYZED -> ALL VALUES DISPLAYED") +categ.len <- 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[categ.len]]))){ # here length(dot.color) is equal to the different number of categ +# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor +data1 <- data.frame(data1, dot.color = data1[, categ[categ.len]]) +data1$dot.color <- factor(data1$dot.color, labels = dot.color) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") IN ", categ[categ.len], " OF categ ARGUMENT, THE FOLLOWING COLORS:\n", paste(dot.color, collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[, categ[categ.len]])), collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +}else if(length(dot.color) == length(data1[, categ[categ.len]])){# 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[categ.len]]))) +data1 <- data.frame(data1, dot.color = dot.color) +}else if(length(dot.color) == 1 & ! all(dot.color == "same")){ +# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # 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[categ.len]]))) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") dot.color ARGUMENT HAS LENGTH 1, MEANING THAT ALL THE DIFFERENT CLASSES OF ", categ[categ.len], "\n", paste(levels(factor(data1[, categ[categ.len]])), 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{ -corner.text <- paste0(corner.text, "\nBEWARE: THE DISPLAYED NUMBER OF VALUES PARAMETER ", deparse(substitute(displayed.nb)), " HAS BEEN SET TO ", displayed.nb, " WHICH IS ABOVE THE NUMBER OF VALUES OF THE DATASET ANALYZED -> ALL VALUES DISPLAYED") +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[categ.len], " COLUMN. HERE IT IS COLOR LENGTH ", length(dot.color), " VERSUS CATEG LENGTH ", length(data1[, categ[categ.len]]), " AND CATEG CLASS LENGTH ", length(unique(data1[, categ[categ.len]])), "\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))) } -stripchart(sampled.data, method="jitter", jitter=0.4, vertical=FALSE, ylim=c(0.5, 1.5), group.names = "", xlab = "Value", ylab="", pch=1, cex = cex.pt / 0.2) -fun.rug(y.nb.inter.tick.f = 0) -boxplot(as.vector(data), horizontal=TRUE, add=TRUE, boxwex = 0.4, staplecol = col.box, whiskcol = col.box, medcol = col.box, boxcol = col.box, range = 0, whisklty = 1) -m <- mean(as.vector(data), na.rm = TRUE) -s <- sd(as.vector(data), na.rm = TRUE) -segments(m, 0.8, m, 1, lwd=2, col="red") # mean -segments(m -1.96 * s, 0.9, m + 1.96 * s, 0.9, lwd=1, col="red") # mean -graph.xlim <- par()$usr[1:2] # for hist() and qqnorm() below -if(interval.scale.disp == TRUE){ -fun.interval.scale.display(data.f = data) -if(corner.text == ""){ -corner.text <- paste0("MULTIPLYING FACTOR DISPLAYED (MEAN +/- SD) ON SCALES: ", paste(formatC(round(qnorm(quantiles.selection), 2))[-(1:(length(quantiles.selection) - 1) / 2)], collapse = ", "), "\nQUANTILES DISPLAYED ON SCALES: ", paste(quantiles.selection, collapse = ", ")) -}else{ -corner.text <- paste0(corner.text, "\nMULTIPLYING FACTOR DISPLAYED (MEAN +/- SD) ON SCALES: ", paste(formatC(round(qnorm(quantiles.selection), 2))[-(1:(length(quantiles.selection) - 1) / 2)], collapse = ", "), "\nQUANTILES DISPLAYED ON SCALES: ", paste(quantiles.selection, collapse = ", ")) +# 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 +if(is.null(dot.categ)){ +dot.categ.class.order <- NULL # because not used anyway } +# dot.categ.class.order either NULL if dot.categ is NULL (no legend displayed) or character string (potentially representing the diff classes of dot.categ) +# 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))) } -output.tempo <- fun.add.cut(data.f = data, return.f = TRUE) # to recover real.trim.cutoffs -if(trim.return == TRUE){ -output <- output.tempo -} -par(xpd = NA) -if(trim.method != ""){ -if(corner.text == ""){ -corner.text <- paste0("SELECTED CUT-OFFS (PROPORTION): ", paste(trim.cutoffs, collapse = ", "), "\nSELECTED CUT-OFFS: ", paste(output.tempo$real.trim.cutoffs, collapse = ", ")) -}else{ -corner.text <- paste0(corner.text, "\nSELECTED CUT-OFFS (PROPORTION): ", paste(trim.cutoffs, collapse = ", "), "\nSELECTED CUT-OFFS: ", paste(output.tempo$real.trim.cutoffs, collapse = ", ")) -} -if(interval.scale.disp == TRUE){ -legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- 1.96sd", paste0("Trimming interval: ", paste0(trim.cutoffs, collapse = " , ")), "Mean +/- sd multiplying factor", "Quantile"), yjust = 0, lty=1, col=c(col.box, "red", color.cut, col.mean, col.quantile), bty="n", cex = amplif.legend) -}else{ -legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- 1.96sd", paste0("Trimming interval: ", paste0(trim.cutoffs, collapse = " , "))), yjust = 0, lty=1, col=c(col.box, "red", color.cut), bty="n", cex = amplif.legend, y.intersp=1.25) -} -}else{ -if(interval.scale.disp == TRUE){ -legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- sd", "Mean +/- sd multiplying factor", "Quantile"), yjust = 0, lty=1, col=c(col.box, "red", col.mean, col.quantile), bty="n", cex = amplif.legend) -}else{ -legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- sd"), yjust = 0, lty=1, col=c(col.box, "red"), bty="n", cex = amplif.legend, y.intersp=1.25) -} +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) } -par(xpd = FALSE, xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r")) -hist(as.vector(data), main = "", breaks = seq(min(as.vector(data), na.rm = TRUE), max(as.vector(data), na.rm = TRUE), length.out = length(as.vector(data)) / 10), xlim = graph.xlim, xlab = "Value", ylab="Density", col = grey(0.25)) -abline(h = par()$usr[3]) -fun.rug() -if(interval.scale.disp == TRUE){ -fun.interval.scale.display(data.f = data) +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] } -fun.add.cut(data.f = data) -par(xaxs = ifelse(std.x.range, "i", "r")) -stripchart(rank(sampled.data), method="stack", vertical=FALSE, ylim=c(0.99, 1.3), group.names = "", xlab = "Rank of values", ylab="", pch=1, cex = cex.pt / 0.2) -fun.rug(y.nb.inter.tick.f = 0) -x.text <- par("usr")[2] + (par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1]) * (1 - par("plt")[2]) / 2 -y.text <- (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / ((par()$omd[4] / 2) * ((par("plt")[4] - par("plt")[3])))) * (1 - par("omd")[4])) # BEWARE. Here in "(par()$omd[4] / 2", division by two because there are 2 graphs staked on the y axis, and not one -par(xpd=NA) -text(x = x.text, y = y.text, paste0(corner.text), adj=c(1, 1.1), cex = magnific.corner.text) # text at the topright corner -par(xpd=FALSE) -par(xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r")) -qqnorm(as.vector(sampled.data), main = "", datax = TRUE, ylab = "Value", pch = 1, col = "red", cex = cex.pt / 0.2) -fun.rug() -if(diff(quantile(as.vector(data), probs = c(0.25, 0.75), na.rm = TRUE)) != 0){ # otherwise, error generated -qqline(as.vector(data), datax = TRUE) +# end integer colors into gg_palette } -if(interval.scale.disp == TRUE){ -fun.interval.scale.display(data.f = data) +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 y.log 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) } -fun.add.cut(data.f = data) } -if(trim.return == TRUE){ -return(output) } +# 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 -######## fun_segmentation() #### segment a dot cloud on a scatterplot and define the dots from another cloud outside the segmentation +# 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 -# Check OK: clear to go Apollo -fun_segmentation <- function(data1, x1, y1, x.range.split = NULL, x.step.factor = 10, y.range.split = NULL, y.step.factor = 10, error = 0, data2 = NULL, x2, y2, data2.pb.dot = "unknown", xy.cross.kind = "&", plot = FALSE, graph.in.file = FALSE, raster = TRUE, warn.print = FALSE, lib.path = NULL){ -# AIM -# if data1 is a data frame corresponding to the data set of a scatterplot (with a x column for x-axis values and a y column for the y-axis column), then fun_segmentation() delimits a frame around the dots cloud using a sliding window set by x.range.split and x.step.factor to frame the top and bottom part of the cloud, and set by y.range.split and y.step.factor to frame the left and right part of the cloud -# if a second data frame is provided, corresponding to the data set of a scatterplot (with a x column for x-axis values and a y column for the y-axis column), then fun_segmentation() defines the dots of this data frame, outside of the frame of the first data frame -# WARNINGS -# if dots from data2 look significant on the graph (outside the frame) but are not (not black on the last figure), this is probably because the frame is flat on the zero coordinate (no volume inside the frame at this position). Thus, no way to conclude that data2 dots here are significant. These dots are refered to as "unknown". The pb.dot argument deals with such dots -# dots that are sometimes inside and outside the frame, depending on the sliding window, are treated differently: they are removed. Such dots are neither classified as "signif", "non signif" or "unknown", but as "inconsistent" -# unknown dots are treated as finally significant, not significant, or unknown (data2.pb.dot argument) for each x-axis and y-axis separately. Then, the union or intersection of significant dots is performed (argument xy.cross.kind). See the example section -# ARGUMENTS -# data1: a dataframe containing a column of x-axis values and a column of y-axis values -# x1: character string of the data1 column name for x-axis (first column of data1 by default) -# y1: character string of the data1 column name for y-axis (second column of data1 by default) -# x.range.split: positive non null numeric value giving the number of interval on the x value range. if x.range is the range of the dots on the x-axis, then abs(diff(x.range) / x.range.split) gives the window size. Window size decreases when range.split increases. In unit of x-axis. Write NULL if not required. At least one of the x.range.split and y.range.split must be non NULL -# x.step.factor: positive non null numeric value giving the shift step of the window. If x.step.factor = 1, no overlap during the sliding (when the window slides from position n to position n+1, no overlap between the two positions). If x.step.factor = 2, 50% of overlap (when the window slides from position n to position n+1, the window on position n+1 overlap 50% of the window when it was on position n) -# y.range.split: same as x.range.split for the y-axis. At least one of the x.range.split and y.range.split must be non NULL -# y.step.factor: same as x.step.factor for the y-axis -# error: proportion (from 0 to 1) of false positives (i.e., proportion of dots from data1 outside of the frame). 0.05 means 5% of the dots from data1 outside of the frame -# data2: a dataframe containing a column of x-axis values and a column of y-axis values, for which outside dots of the data1 cloud has to be determined. Write NULL if not required -# x2: character string of the data1 column name for x-axis (first column of data1 by default) -# y2: character string of the data1 column name for y-axis (second column of data1 by default) -# data2.pb.dot: unknown dots are explain in the warning section above. If "signif", then the unknown dots are finally considered as significant (outside the frame). If "not.signif", then the unknown dots are finally considered as non significant (inside the frame). If "unknown", no conclusion are drawn from these dots. See the examples below -# xy.cross.kind: if data2 is non null and if both x.range.split and y.range.split are non null, which dots are finally significants? Write "&" for intersection of outside dots on x and on y. Write "|" for union of outside dots on x and on y. See the examples below -# plot: logical. Print graphs that check the frame? -# graph.in.file: logical. Graphs sent into a graphic device already opened? If FALSE, GUI are opened for each graph. If TRUE, no GUI are opended. The graphs are displayed on the current active graphic device. Ignored if plot is 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 region plot will be square to avoid a bug in fun_gg_point_rast(). If TRUE, solve the transparency problem with some GUI. Not considered if plot is FALSE -# 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. Ignored if plot is FALSE -# REQUIRED PACKAGES -# ggplot2 if plot is TRUE -# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_check() -# if plot is TRUE: -# fun_pack() -# fun_open() -# fun_gg_palette() -# fun_gg_scatter() -# fun_gg_empty_graph() -# fun_close() -# RETURN -# several graphs if plot is TRUE -# a list containing: -# $data1.removed.row.nb: which rows have been removed due to NA; NaN, -Inf or Inf detection in x1 or y1 columns (NULL if no row removed) -# $data1.removed.rows: removed rows (NULL if no row removed) -# $data2.removed.row.nb: which rows have been removed due to NA; NaN, -Inf or Inf detection in x2 or y2 columns (NULL if no row removed) -# $data2.removed.rows: removed rows (NULL if no row removed) -# $hframe: x and y coordinates of the bottom and top frames for frame plotting (frame1 for the left step and frame2 for the right step) -# $vframe: x and y coordinates of the left and right frames for frame plotting (frame1 for the down step and frame2 for the top step) -# $data1.signif.dot: the significant dots of data1 (i.e., dots outside the frame). A good segmentation should not have any data1.signif.dot -# $data1.non.signif.dot: the non significant dots of data1 (i.e., dots inside the frame) -# $data1.inconsistent.dot: see the warning section above -# $data2.signif.dot: the significant dots of data2 if non NULL (i.e., dots outside the frame) -# $data2.non.signif.dot: the non significant dots of data2 (i.e., dots inside the frame) -# $data2.unknown.dot: the problematic dots of data2 (i.e., data2 dots outside of the range of data1, or data2 dots in a sliding window without data1 dots). Is systematically NULL except if argument data2.pb.dot = "unknown" and some data2 dots are in such situation. Modifying the segmentation x.range.split, x.step.factor, y.range.split, y.step.factor arguments can solve this problem -# $data2.inconsistent.dot: see the warning section above -# $axes: the x-axis and y-axis info -# $warn: the warning messages. Use cat() for proper display. NULL if no warning -# EXAMPLES -# example explaining the unknown and inconsistent dots, and the cross -# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data1[5:7, 2] <- NA ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; data2[11:13, 1] <- Inf ; set.seed(NULL) ; fun_segmentation(data1 = data1, x1 = names(data1)[1], y1 = names(data1)[2], x.range.split = 20, x.step.factor = 10, y.range.split = 23, y.step.factor = 10, error = 0, data2 = data2, x2 = names(data2)[1], y2 = names(data2)[2], data2.pb.dot = "not.signif", xy.cross.kind = "|", plot = TRUE, graph.in.file = FALSE, raster = FALSE, lib.path = NULL) -# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; fun_segmentation(data1 = data1, x1 = names(data1)[1], y1 = names(data1)[2], x.range.split = NULL, x.step.factor = 10, y.range.split = 23, y.step.factor = 10, error = 0, data2 = data2, x2 = names(data2)[1], y2 = names(data2)[2], data2.pb.dot = "unknown", xy.cross.kind = "|", plot = TRUE, graph.in.file = FALSE, raster = FALSE, lib.path = NULL) -# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; fun_segmentation(data1 = data1, x1 = names(data1)[1], y1 = names(data1)[2], x.range.split = 20, x.step.factor = 10, y.range.split = NULL, y.step.factor = 10, error = 0, data2 = data2, x2 = names(data2)[1], y2 = names(data2)[2], data2.pb.dot = "unknown", xy.cross.kind = "&", plot = TRUE, graph.in.file = FALSE, raster = FALSE, lib.path = NULL) -# DEBUGGING -# set.seed(1) ; data1 = data.frame(x = rnorm(50), y = rnorm(50)) ; data1[5:7, 2] <- NA ; x1 = names(data1)[1] ; y1 = names(data1)[2] ; x.range.split = 5 ; x.step.factor = 10 ; y.range.split = 5 ; y.step.factor = 10 ; error = 0 ; data2 = data.frame(x = rnorm(50, 0, 2), y = rnorm(50, 0, 2)) ; set.seed(NULL) ; x2 = names(data2)[1] ; y2 = names(data2)[2] ; data2.pb.dot = "unknown" ; xy.cross.kind = "|" ; plot = TRUE ; graph.in.file = FALSE ; raster = FALSE ; warn.print = TRUE ; lib.path = NULL -# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; x1 = names(data1)[1] ; y1 = names(data1)[2] ; x.range.split = 20 ; x.step.factor = 10 ; y.range.split = 23 ; y.step.factor = 10 ; error = 0 ; x2 = names(data2)[1] ; y2 = names(data2)[2] ; data2.pb.dot = "not.signif" ; xy.cross.kind = "|" ; plot = TRUE ; graph.in.file = FALSE ; raster = FALSE ; warn.print = TRUE ; lib.path = NULL -# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; x1 = names(data1)[1] ; y1 = names(data1)[2] ; x.range.split = 20 ; x.step.factor = 10 ; y.range.split = NULL ; y.step.factor = 10 ; error = 0 ; x2 = names(data2)[1] ; y2 = names(data2)[2] ; data2.pb.dot = "unknown" ; xy.cross.kind = "&" ; plot = TRUE ; graph.in.file = FALSE ; raster = FALSE ; 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_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) +# 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"}, if( ! is.null(dot.color) & ! is.null(dot.categ)){if(dot.categ != ini.dot.categ){dot.categ}}, if( ! is.null(facet.categ)){facet.categ}) # dot.categ because can be a 3rd column of data1 +if(any(is.na(data1[, column.check]))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") NA DETECTED IN COLUMNS ", paste(column.check, collapse = " "), " OF data1 AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +for(i2 in 1:length(column.check)){ +if(any(is.na(data1[, column.check[i2]]))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") NA REMOVAL DUE TO COLUMN ", column.check[i2], " OF data1") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -# end required function checking -# argument checking -warn <- NULL -warn.count <- 0 -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 & length(data1) < 2){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": data1 ARGUMENT MUST BE A DATA FRAME OF AT LEAST 2 COLUMNS\n\n============\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) } -tempo <- fun_check(data = x1, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (x1 %in% names(data1))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x1 ARGUMENT MUST BE A COLUMN NAME OF data1\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & x1 %in% names(data1)){ -tempo <- fun_check(data = data1[, x1], data.name = "x1 COLUMN OF data1", class = "vector", mode = "numeric", na.contain = TRUE, 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){ +data1 <- data1[-removed.row.nb, ] +for(i3 in 1:length(column.check)){ +if(any( ! unique(removed.rows[, column.check[i3]]) %in% unique(data1[, column.check[i3]]))){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") IN COLUMN ", column.check[i3], " OF data1, THE FOLLOWING CLASSES HAVE DISAPPEARED AFTER NA REMOVAL (IF COLUMN USED IN THE PLOT, THIS CLASS WILL NOT BE DISPLAYED):\n", paste(unique(removed.rows[, column.check[i3]])[ ! unique(removed.rows[, column.check[i3]]) %in% unique(data1[, column.check[i3]])], collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -tempo <- fun_check(data = y1, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (y1 %in% names(data1))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y1 ARGUMENT MUST BE A COLUMN NAME OF data1\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & y1 %in% names(data1)){ -tempo <- fun_check(data = data1[, y1], data.name = "y1 COLUMN OF data1", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) } -if(is.null(x.range.split) & is.null(y.range.split)){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": AT LEAST ONE OF THE x.range.split AND y.range.split ARGUMENTS MUST BE NON NULL\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) } -if( ! is.null(x.range.split)){ -tempo <- fun_check(data = x.range.split, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & x.range.split < 1){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x.range.split ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +count.categ <- 0 +for(i2 in 1:length(column.check)){ +if(column.check[i2] %in% categ){ +count.categ <- count.categ + 1 } +if(column.check[i2] == categ[count.categ]){ +categ.class.order[count.categ] <- list(levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])]) # remove the absent color in the character vector +data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(categ.class.order[[count.categ]])) } -if( ! is.null(y.range.split)){ -tempo <- fun_check(data = y.range.split, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & y.range.split < 1){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y.range.split ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +if( ! is.null(dot.color) & ! is.null(dot.categ)){ # reminder : dot.categ cannot be a column name of categ anymore (because in that case dot.categ name is changed into "..._DOT" +if(column.check[i2] == ini.dot.categ){ +dot.categ.class.order <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector +data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.categ.class.order)) } } -tempo <- fun_check(data = x.step.factor, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & x.step.factor < 1){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x.step.factor ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) +if(column.check[i2] == "categ.color"){ +categ.color <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector +if(length(categ.color) == 1 & length(unlist(categ.class.order[length(categ)])) > 1){ # to deal with single color +categ.color <- rep(categ.color, length(unlist(categ.class.order[length(categ)]))) } -tempo <- fun_check(data = y.step.factor, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & y.step.factor < 1){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y.step.factor ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -tempo <- fun_check(data = error, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) -if( ! is.null(data2)){ -if(is.null(x2) | is.null(y2)){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x2 AND y2 ARGUMENTS CANNOT BE NULL IF data2 ARGUMENT IS NON NULL\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -} -tempo <- fun_check(data = data2, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & length(data2) < 2){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": data2 ARGUMENT MUST BE A DATA FRAME OF AT LEAST 2 COLUMNS\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(categ.color)) } -if( ! is.null(x2)){ -tempo <- fun_check(data = x2, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (x2 %in% names(data2))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x2 ARGUMENT MUST BE A COLUMN NAME OF data2\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & x2 %in% names(data2)){ -tempo <- fun_check(data = data2[, x2], data.name = "x2 COLUMN OF data2", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) +if(column.check[i2] == "dot.color"){ +dot.color <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector +if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color. If dot.categ.class.order == NULL (which is systematically the case if dot.categ == NULL), no rep(dot.color, length(dot.categ.class.order) +dot.color <- rep(dot.color, length(dot.categ.class.order)) } +data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.color)) } -if( ! is.null(y2)){ -tempo <- fun_check(data = y2, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & ! (y2 %in% names(data2))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y2 ARGUMENT MUST BE A COLUMN NAME OF data2\n\n================\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & y2 %in% names(data2)){ -tempo <- fun_check(data = data2[, y2], data.name = "y2 COLUMN OF data2", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) +if(column.check[i2] %in% facet.categ){ # works if facet.categ == NULL this method should keep the order of levels when removing some levels +tempo.levels <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(as.character(data1[, column.check[i2]]))] +data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = tempo.levels) } } +}else{ +removed.row.nb <- NULL +removed.rows <- NULL } -if( ! is.null(data2)){ -tempo <- fun_check(data = data2.pb.dot, options = c("signif", "not.signif", "unknown"), length = 1, fun.name = function.name) ; eval(ee) +# 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), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add added here to have the facets +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[1]), stroke = dot.border.size, size = dot.size, alpha = dot.alpha, shape = 21)) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(is.null(dot.color)){rep(NA, length(unique(data1[, categ[1]])))}else if(length(dot.color) == 1){rep(dot.color, length(unique(data1[, categ[1]])))}else{dot.color})) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[1]), coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf})) # fill because this is what is used with geom_box # to easily have the equivalent of the grouped boxs +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[1]])))}else{categ.color})) +# 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), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add added here to have the facets +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[2]), stroke = dot.border.size, size = dot.size, alpha = dot.alpha, shape = 21)) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(is.null(dot.color)){rep(NA, length(unique(data1[, categ[2]])))}else if(length(dot.color) == 1){rep(dot.color, length(unique(data1[, categ[2]])))}else{dot.color})) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[2]), coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf})) # fill because this is what is used with geom_box # to easily have the equivalent of the grouped boxs +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[2]])))}else{categ.color})) +# end per box dots coordinates recovery +}else{ +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") +stop(tempo.cat) } -if( ! (is.null(x.range.split)) & ! (is.null(y.range.split))){ -tempo <- fun_check(data = xy.cross.kind, options = c("&", "|"), length = 1, fun.name = function.name) ; eval(ee) +tempo <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))) +dot.coord <- tempo$data[[1]] +ini.box.coord <- tempo$data[[2]] +tempo.mean <- aggregate(x = dot.coord$y, by = list(dot.coord$group, dot.coord$PANEL), FUN = mean, na.rm = TRUE) +names(tempo.mean)[names(tempo.mean) == "x"] <- "MEAN" +names(tempo.mean)[names(tempo.mean) == "Group.1"] <- "BOX" +names(tempo.mean)[names(tempo.mean) == "Group.2"] <- "PANEL" +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"]}, +data1[order(data1$categ.check, data1[, y]), ][categ] # avoid the renaming below +) # 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( ! is.null(dot.categ)){ +dot.coord <- data.frame(dot.coord, data1[order(data1$categ.check, data1[, y]), ][dot.categ]) # avoid the renaming } -tempo <- fun_check(data = plot, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = warn.print, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & plot == TRUE){ -tempo <- fun_check(data = raster, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = graph.in.file, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & graph.in.file == TRUE & is.null(dev.list())){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \ngraph.in.file PARAMETER SET TO TRUE BUT NO ACTIVE GRAPHIC DEVICE DETECTED\n\n============\n\n") -text.check <- c(text.check, tempo.cat) -arg.check <- c(arg.check, TRUE) -}else if(tempo$problem == FALSE & graph.in.file == TRUE & ! is.null(dev.list())){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": GRAPHS PRINTED IN THE CURRENT DEVICE (TYPE ", toupper(names(dev.cur())), ")") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +if( ! is.null(facet.categ)){ +dot.coord <- data.frame(dot.coord, data1[order(data1$categ.check, data1[, y]), ][facet.categ]) # for facet panels +tempo.test <- NULL +for(i2 in 1:length(facet.categ)){ +tempo.test <- paste0(tempo.test, ".", formatC(as.numeric(dot.coord[, facet.categ[i2]]), width = nchar(max(as.numeric(dot.coord[, facet.categ[i2]]), na.rm = TRUE)), flag = "0")) # convert factor into numeric with leading zero for proper ranking # merge the formatC() to create a new factor. The convertion to integer should recreate the correct group number. Here as.numeric is used and not as.integer in case of numeric in facet.categ (because comes from add and not checked by fun_check, contrary to categ) } -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){ -if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA -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) +tempo.test <- as.integer(factor(tempo.test)) +if( ! identical(as.integer(dot.coord$PANEL), tempo.test)){ +tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": as.integer(dot.coord$PANEL) AND tempo.test MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n") +stop(tempo.cat) } } +if(dot.tidy == TRUE){ +dot.coord <- data.frame(dot.coord, tidy_group = if(length(categ) == 1){dot.coord[, categ]}else{paste(dot.coord[, categ[1]], dot.coord[, categ[2]], sep = ".")}) # for tidy dot plots } +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, tempo.mean$PANEL), ]$BOX, unique(dot.coord[order(dot.coord$group, dot.coord$PANEL), c("group", "PANEL")])$group)){ +tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (tempo.mean$BOX, tempo.mean$PANEL) AND (dot.coord$group, dot.coord$PANEL) 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, tempo.mean$PANEL), ], unique(dot.coord[order(dot.coord$group, dot.coord$PANEL), c(categ, if( ! is.null(dot.color) & ! is.null(dot.categ)){if(dot.categ != ini.dot.categ){dot.categ}}, if( ! is.null(facet.categ)){facet.categ}), drop = FALSE])) } -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 -# other required function checking -if(plot == TRUE){ -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) +# 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( ! fun_comp_2d(ini.box.coord[c("PANEL", "group")], tempo.mean[c("PANEL", "BOX")])$identical.content){ +tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": ini.box.coord[c(\"PANEL\", \"group\")] AND tempo.mean[c(\"PANEL\", \"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 } -if(length(utils::find("fun_open", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_open() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +# 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))) } -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) +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(length(utils::find("fun_gg_empty_graph", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_empty_graph() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") -stop(tempo.cat, call. = FALSE) +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) } -if(length(utils::find("fun_gg_scatter", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_scatter() FUNCTION IS MISSING IN THE R ENVIRONMENT\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 } -if(length(utils::find("fun_close", mode = "function")) == 0){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_close() FUNCTION IS MISSING IN THE R ENVIRONMENT\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) } +# 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), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add is directly put here to deal ith additional variable of data, like when using fact_grid. No problem if add is a theme, will be dealt below +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 -> article ARGUMENT WILL BE IGNORED") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +add.check <- FALSE } -# end other required function checking -# package checking -if(plot == TRUE){ -fun_pack(req.package = c("ggplot2"), lib.path = lib.path) } -# end package checking -# main code -# na and Inf detection and removal (done now to be sure of the correct length of categ) -data1.removed.row.nb <- NULL -data1.removed.rows <- NULL -data2.removed.row.nb <- NULL -data2.removed.rows <- NULL -if(any(is.na(data1[, c(x1, y1)])) | any(is.infinite(data1[, x1])) | any(is.infinite(data1[, y1]))){ -tempo.na <- unlist(lapply(lapply(c(data1[c(x1, y1)]), FUN = is.na), FUN = which)) -tempo.inf <- unlist(lapply(lapply(c(data1[c(x1, y1)]), FUN = is.infinite), FUN = which)) -data1.removed.row.nb <- sort(unique(c(tempo.na, tempo.inf))) -if(length(data1.removed.row.nb) > 0){ -data1.removed.rows <- data1[data1.removed.row.nb, ] -} -if(length(data1.removed.row.nb) == nrow(data1)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": AT LEAST ONE NA, NaN, -Inf OR Inf DETECTED IN EACH ROW OF data1. FUNCTION CANNOT BE USED ON EMPTY DATA FRAME\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(length(data1.removed.row.nb) > 0){ -data1 <- data1[-data1.removed.row.nb, ] +if(add.check == TRUE & article == 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), +legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend +axis.line.y.left = ggplot2::element_line(colour = "black"), # 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), +legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend +axis.line.y.left = ggplot2::element_line(colour = "black"), +axis.line.x.bottom = ggplot2::element_line(colour = "black"), +axis.text.x = 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)} +)) } -if(nrow(data1) == 0){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 1\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +}else if(add.check == TRUE & article == FALSE){ +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme( +text = ggplot2::element_text(size = text.size), +plot.title = ggplot2::element_text(size = title.text.size), # stronger than text +line = ggplot2::element_line(size = 0.5), +legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend +panel.background = ggplot2::element_rect(fill = "grey95"), +axis.line.y.left = ggplot2::element_line(colour = "black"), +axis.line.x.bottom = ggplot2::element_line(colour = "black"), +panel.grid.major.x = ggplot2::element_line(colour = "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)} +)) } -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x1, y1), collapse = " "), " OF data1 AND CORRESPONDING ROWS REMOVED (SEE $data1.removed.row.nb AND $data1.removed.rows)") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +# 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 = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color})')))) # will be recovered later again, when ylim will be considered +tempo.yx.ratio <- (tempo.graph.info$layout$panel_params[[1]]$y.range[2] - tempo.graph.info$layout$panel_params[[1]]$y.range[1]) / (tempo.graph.info$layout$panel_params[[1]]$x.range[2] - tempo.graph.info$layout$panel_params[[1]]$x.range[1]) +box.coord <- tempo.graph.info$data[[2]] # to have the summary statistics of the plot. Contrary to ini.box.plot, now integrates ylim Here because can be required for stat.disp when just box are plotted +box.coord <- box.coord[order(box.coord$group), ] +if(stat.disp.mean == TRUE){ # for mean display +if( ! identical(tempo.mean$BOX, box.coord$group)){ +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": tempo.mean$BOX AND box.coord$group DO NOT HAVE THE SAME VALUE ORDER\n\n============\n\n") +stop(tempo.cat) }else{ +box.coord <- data.frame(box.coord, tempo.mean) warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NO NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x1, y1), collapse = " "), " OF data1. NO ROW REMOVED") +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))) + } -if( ! is.null(data2)){ -if(any(is.na(data2[, c(x2, y2)])) | any(is.infinite(data2[, x2])) | any(is.infinite(data2[, y2]))){ -tempo.na <- unlist(lapply(lapply(c(data2[c(x2, y2)]), FUN = is.na), FUN = which)) -tempo.inf <- unlist(lapply(lapply(c(data2[c(x2, y2)]), FUN = is.infinite), FUN = which)) -data2.removed.row.nb <- sort(unique(c(tempo.na, tempo.inf))) -if(length(data2.removed.row.nb) > 0){ -data2.removed.rows <- data2[data2.removed.row.nb, ] } -if(length(data2.removed.row.nb) == nrow(data2)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": AT LEAST ONE NA, NaN, -Inf OR Inf DETECTED IN EACH ROW OF data2. FUNCTION CANNOT BE USED ON EMPTY DATA FRAME\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +# 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"], # already added above +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))) } -if(length(data2.removed.row.nb) > 0){ -data2 <- data2[-data2.removed.row.nb, ] } -if(nrow(data2) == 0){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +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", "PANEL", "group", "x")], by = c("PANEL", "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 = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in box.coord. Thus, no need to consider fill column +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) } -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x2, y2), collapse = " "), " OF data2 AND CORRESPONDING ROWS REMOVED (SEE $data2.removed.row.nb AND $data2.removed.rows)") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +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(data1[, categ[1]]))) # categ[1] is factor +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( +formatC(as.integer(data1[, categ[2]]), width = nchar(max(as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking +".", +formatC(as.integer(data1[, categ[1]]), width = nchar(max(as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking +))) # merge the 2 formatC() to create a new factor. The convertion to integer should recreate the correct group number +) +) # 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{ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NO NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x2, y2), collapse = " "), " OF data2. NO ROW REMOVED") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -print(warn) +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 = intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. BEWARE: I have replaced by = "group" by intersect("group", "group") because of an error due to wrong group group merging in dot.coord.rd3 +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 na and Inf detection and removal (done now to be sure of the correct length of categ) -# row annotation (dot number) -# data1 <- data1[ ! duplicated(data1[, c(x1, y1)]), ] # do not remove the dots that have same x and y values, because they will have different dot number -> not the same position on the matrices (so true for symmetric matrices) -data1 <- cbind(data1, DOT_NB = 1:nrow(data1)) -if( ! is.null(data2)){ -# data2 <- data2[ ! duplicated(data2[, c(x2, y2)]), ] # do not remove the dots that have same x and y values, because they will have different dot number -> not the same position on the matrices (so true for symmetric matrices) -data2 <- cbind(data2, DOT_NB = 1:nrow(data2)) +# end random dots } -# end row annotation (dot number) +# 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) -# Method using x unit interval -# may be create vector of each column to increase speed -x.data1.l <- NULL # x coord of the y upper and lower limits defined on the data1 cloud for left step line -x.data1.r <- NULL # x coord of the y upper and lower limits defined on the data1 cloud for right step line -y.data1.down.limit.l <- NULL # lower limit of the data1 cloud for left step line -y.data1.top.limit.l <- NULL # upper limit of the data1 cloud for left step line -y.data1.down.limit.r <- NULL # lower limit of the data1 cloud for right step line -y.data1.top.limit.r <- NULL # upper limit of the data1 cloud for left step line -if(any(data1[, x1] %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 x1 COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) + +# boxplot display before dot display if box.fill = TRUE +coord.names <- NULL +# creation of the data frame for (main box + legend) and data frame for means +if(box.notch == FALSE){ +for(i3 in 1:length(categ)){ +if(i3 == 1){ +tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE) +}else{ +tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE) } -x.range <- range(data1[, x1], 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(any(x.range %in% c(Inf, -Inf)))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED x.range CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") -stop(tempo.cat, call. = FALSE) } -if(any(data1[, y1] %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 y1 COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +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) +if( ! is.null(facet.categ)){ +for(i4 in 1:length(facet.categ)){ +tempo.polygon <- data.frame(tempo.polygon, c(t(stat[, c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE) +names(tempo.polygon)[length(names(tempo.polygon))] <- facet.categ[i4] } -y.range <- range(data1[, y1], 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(any(x.range %in% c(Inf, -Inf)))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED y.range CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") -stop(tempo.cat, call. = FALSE) } -x.range.plot <- range(data1[, x1], 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.range.plot <- range(data1[, y1], 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( ! is.null(data2)){ -if(any(data2[, x2] %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 x2 COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +}else{ +for(i3 in 1:length(categ)){ +if(i3 == 1){ +tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE) +}else{ +tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE) } -x.range.plot <- range(data1[, x1], data2[, x2], 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(any(data2[, y2] %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 y2 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.range.plot <- range(data1[, y1], data2[, y2], 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 +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) +if( ! is.null(facet.categ)){ +for(i4 in 1:length(facet.categ)){ +tempo.polygon <- data.frame(tempo.polygon, c(t(stat[, c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE) +names(tempo.polygon)[length(names(tempo.polygon))] <- facet.categ[i4] } -if(suppressWarnings(any(x.range.plot %in% c(Inf, -Inf)))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED x.range.plot CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 (AND data2?) ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") -stop(tempo.cat, call. = FALSE) } -if(suppressWarnings(any(y.range.plot %in% c(Inf, -Inf)))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED y.range.plot CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 (AND data2?) ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} -if( ! is.null(x.range.split)){ -# data.frame ordering to slide the window from small to big values + sliding window definition -data1 <- data1[order(data1[, x1], na.last = TRUE), ] -if( ! is.null(data2)){ -data2 <- data2[order(data2[, x2], na.last = TRUE), ] -} -x.win.size <- abs(diff(x.range) / x.range.split) # in unit of x-axis -step <- x.win.size / x.step.factor -# end data.frame ordering to slide the window from small to big values + sliding window definition -# x-axis sliding and y-axis limits of the data1 cloud -> y significant data2 -loop.nb <- ceiling((diff(x.range) - x.win.size) / step) # x.win.size + n * step covers the x range if x.win.size + n * step >= diff(x.range), thus if n >= (diff(x.range) - x.win.size) / step -y.outside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are upper or lower than the frame -y.inside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are not upper or lower than the frame -y.data1.median <- median(data1[, y1], na.rm = TRUE) # will be used for sliding windows without data1 in it -if( ! is.null(data2)){ -y.outside.data2.dot.nb <- integer() # vector that will contain the selected 1D coordinates (i.e., dots) of data2 that are upper or lower than the data1 frame -y.inside.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are not upper or lower than the data1 frame -y.unknown.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are problematic: data2 dots outside of the range of data1, or data2 dots in a sliding window without data1 dots -# recover data2 dots outside the range of data1 -if(any(data2[, x2] < x.range[1])){ -y.unknown.data2.dot.nb <- c(y.unknown.data2.dot.nb, data2$DOT_NB[data2[, x2] < x.range[1]]) -#tempo.warn & indicate the interval } -if(any(data2[, x2] > x.range[2])){ -y.unknown.data2.dot.nb <- c(y.unknown.data2.dot.nb, data2$DOT_NB[data2[, x2] > x.range[2]]) -#tempo.warn & indicate the interval -} -# end recover data2 dots outside the range of data1 -} -# loop.ini.time <- as.numeric(Sys.time()) -for(i1 in 0:(loop.nb + 1)){ -min.pos <- x.range[1] + step * i1 # lower position of the sliding window in data1 -max.pos <- min.pos + x.win.size # upper position of the sliding window in data1 -x.data1.l <- c(x.data1.l, min.pos, min.pos + step) # min.pos + step to make the steps -x.data1.r <- c(x.data1.r, max.pos, max.pos + step) # max.pos + step to make the steps -x.data1.dot.here <- data1[, x1] >= min.pos & data1[, x1] < max.pos # is there data1 dot present in the sliding window, considering the x axis? -if( ! is.null(data2)){ -x.data2.dot.here <- data2[, x2] >= min.pos & data2[, x2] < max.pos # is there data2 dot present in the sliding window, considering the x axis? +tempo.polygon$COLOR <- factor(tempo.polygon$COLOR, levels = unique(categ.color)) +if( ! is.null(categ.class.order)){ +for(i3 in 1:length(categ)){ +tempo.polygon[, categ[i3]] <- factor(tempo.polygon[, categ[i3]], levels = categ.class.order[[i3]]) } -# recover the data1 dots outside the frame -if(any(x.data1.dot.here == TRUE)){ -tempo.y.data1.top.limit <- quantile(data1[x.data1.dot.here, y1], probs = 1 - error, na.rm = TRUE) -tempo.y.data1.down.limit <- quantile(data1[x.data1.dot.here, y1], probs = 0 + error, na.rm = TRUE) -y.data1.top.limit.l <- c(y.data1.top.limit.l, tempo.y.data1.top.limit, tempo.y.data1.top.limit) -y.data1.down.limit.l <- c(y.data1.down.limit.l, tempo.y.data1.down.limit, tempo.y.data1.down.limit) -y.data1.top.limit.r <- c(y.data1.top.limit.r, tempo.y.data1.top.limit, tempo.y.data1.top.limit) -y.data1.down.limit.r <- c(y.data1.down.limit.r, tempo.y.data1.down.limit, tempo.y.data1.down.limit) -y.data1.dot.signif <- ( ! ((data1[, y1] <= tempo.y.data1.top.limit) & (data1[, y1] >= tempo.y.data1.down.limit))) & x.data1.dot.here # is there data1 dot present in the sliding window, above or below the data1 limits, considering the y axis? -y.data1.dot.not.signif <- x.data1.dot.here & ! y.data1.dot.signif -y.outside.data1.dot.nb <- c(y.outside.data1.dot.nb, data1$DOT_NB[y.data1.dot.signif]) # recover the row number of data1 -y.outside.data1.dot.nb <- unique(y.outside.data1.dot.nb) -y.inside.data1.dot.nb <- c(y.inside.data1.dot.nb, data1$DOT_NB[y.data1.dot.not.signif]) -y.inside.data1.dot.nb <- unique(y.inside.data1.dot.nb) -}else{ -y.data1.top.limit.l <- c(y.data1.top.limit.l, y.data1.median, y.data1.median) -y.data1.down.limit.l <- c(y.data1.down.limit.l, y.data1.median, y.data1.median) -y.data1.top.limit.r <- c(y.data1.top.limit.r, y.data1.median, y.data1.median) -y.data1.down.limit.r <- c(y.data1.down.limit.r, y.data1.median, y.data1.median) } -# end recover the data1 dots outside the frame -# recover the data2 dots outside the frame -if( ! is.null(data2)){ -if(any(x.data1.dot.here == TRUE) & any(x.data2.dot.here == TRUE)){ -y.data2.dot.signif <- ( ! ((data2[, y2] <= tempo.y.data1.top.limit) & (data2[, y2] >= tempo.y.data1.down.limit))) & x.data2.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the y axis? -y.data2.dot.not.signif <- x.data2.dot.here & ! y.data2.dot.signif -y.outside.data2.dot.nb <- c(y.outside.data2.dot.nb, data2$DOT_NB[y.data2.dot.signif]) -y.outside.data2.dot.nb <- unique(y.outside.data2.dot.nb) -y.inside.data2.dot.nb <- c(y.inside.data2.dot.nb, data2$DOT_NB[y.data2.dot.not.signif]) -y.inside.data2.dot.nb <- unique(y.inside.data2.dot.nb) -}else if(any(x.data1.dot.here == FALSE) & any(x.data2.dot.here == TRUE)){ # problem: data2 dots in the the window but no data1 dots to generates the quantiles -y.unknown.data2.dot.nb <- c(y.unknown.data2.dot.nb, data2$DOT_NB[x.data2.dot.here]) -y.unknown.data2.dot.nb <- unique(y.unknown.data2.dot.nb) -#tempo.warn & indicate the interval - - - +# modified name of dot.categ column (e.g., "Group1_DOT") must be included for boxplot using ridy dots +if( ! is.null(dot.color) & ! is.null(dot.categ)){ +if(dot.categ != ini.dot.categ){ +tempo.polygon <- data.frame(tempo.polygon, GROUPX = tempo.polygon[, ini.dot.categ]) +names(tempo.polygon)[names(tempo.polygon) == "GROUPX"] <- dot.categ -# tempo.warn <- paste0("FROM FUNCTION ", function.name, ": THE [", round(min.pos, 3), " ; ", round(max.pos, 3), "] INTERVAL DOES NOT CONTAIN data1 X VALUES BUT CONTAINS data2 X VALUES WHICH CANNOT BE EVALUATED.\nTHE CONCERNED data2 ROW NUMBERS ARE:\n", paste(which(x.data1.dot.here == FALSE & x.data2.dot.here == TRUE), collapse = "\n")) -# warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } } -# end recover the data2 dots outside the frame -# if(any(i1 == seq(1, loop.nb, 500))){ -# loop.fin.time <- as.numeric(Sys.time()) # time of process end -# cat(paste0("COMPUTATION TIME OF LOOP ", i1, " / ", loop.nb, ": ", as.character(lubridate::seconds_to_period(round(loop.fin.time - loop.ini.time))), "\n")) -# } +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) +if( ! is.null(facet.categ)){ +for(i3 in 1:length(facet.categ)){ +tempo.diamon.mean <- data.frame(tempo.diamon.mean, c(t(stat[, c(facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3])])), stringsAsFactors = TRUE) +names(tempo.diamon.mean)[length(names(tempo.diamon.mean))] <- facet.categ[i3] } -if(max.pos < x.range[2]){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE SLIDING WINDOW HAS NOT REACHED THE MAX VALUE OF data1 ON THE X-AXIS: ", max.pos, " VERSUS ", x.range[2], "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) } -y.incon.data1.dot.nb.final <- unique(c(y.outside.data1.dot.nb[y.outside.data1.dot.nb %in% y.inside.data1.dot.nb], y.inside.data1.dot.nb[y.inside.data1.dot.nb %in% y.outside.data1.dot.nb])) # inconsistent dots: if a row number of y.inside.data1.dot.nb is present in y.outside.data1.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list -y.outside.data1.dot.nb.final <- y.outside.data1.dot.nb[ ! (y.outside.data1.dot.nb %in% y.incon.data1.dot.nb.final)] # inconsistent dots removed from the outside list -y.inside.data1.dot.nb.final <- y.inside.data1.dot.nb[ ! (y.inside.data1.dot.nb %in% y.incon.data1.dot.nb.final)] # inconsistent dots removed from the inside list -if( ! is.null(data2)){ -# if some unknown dots are also inside, and/or outside, they are put in the inside and/or outside. Ok, because then the intersection between inside and outside is treated -> inconsistent dots -tempo.unknown.out <- y.unknown.data2.dot.nb[y.unknown.data2.dot.nb %in% y.outside.data2.dot.nb] -y.outside.data2.dot.nb <- unique(c(y.outside.data2.dot.nb, tempo.unknown.out)) # if a row number of y.unknown.data2.dot.nb is present in y.outside.data2.dot.nb, it is put into outside -tempo.unknown.in <- y.unknown.data2.dot.nb[y.unknown.data2.dot.nb %in% y.inside.data2.dot.nb] -y.inside.data2.dot.nb <- unique(c(y.inside.data2.dot.nb, tempo.unknown.in)) # if a row number of y.unknown.data2.dot.nb is present in y.inside.data2.dot.nb, it is put into inside -y.unknown.data2.dot.nb.final <- y.unknown.data2.dot.nb[ ! (y.unknown.data2.dot.nb %in% c(y.outside.data2.dot.nb, y.inside.data2.dot.nb))] # then dots also in inside and outside are remove from unknown -y.incon.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb[y.outside.data2.dot.nb %in% y.inside.data2.dot.nb], y.inside.data2.dot.nb[y.inside.data2.dot.nb %in% y.outside.data2.dot.nb])) # inconsistent dots: if a row number of y.inside.data2.dot.nb is present in y.outside.data2.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list -y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb[ ! (y.outside.data2.dot.nb %in% y.incon.data2.dot.nb.final)] # inconsistent dots removed from the outside list -y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb[ ! (y.inside.data2.dot.nb %in% y.incon.data2.dot.nb.final)] # inconsistent dots removed from the inside list +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") } -# end x-axis sliding and y-axis limits of the data1 cloud -> y significant data2 +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") } -# end Method using x unit interval +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 -# Method using y unit interval -y.data1.d <- NULL # y coord of the x upper and lower limits defined on the data1 cloud for down step line -y.data1.t <- NULL # y coord of the x upper and lower limits defined on the data1 cloud for top step line -x.data1.left.limit.d <- NULL # left limit of the data1 cloud for down step line -x.data1.right.limit.d <- NULL # right limit of the data1 cloud for down step line -x.data1.left.limit.t <- NULL # left limit of the data1 cloud for top step line -x.data1.right.limit.t <- NULL # right limit of the data1 cloud for top step line -if( ! is.null(y.range.split)){ -# data.frame ordering to slide the window from small to big values + sliding window definition -data1 <- data1[order(data1[, y1], na.last = TRUE), ] -if( ! is.null(data2)){ -data2 <- data2[order(data2[, y2], na.last = 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 } -y.win.size <- abs(diff(y.range) / y.range.split) # in unit of y-axis -step <- y.win.size / y.step.factor -# end data.frame ordering to slide the window from small to big values + sliding window definition -# y-axis sliding and x-axis limits of the data1 cloud -> x significant data2 -loop.nb <- ceiling((diff(y.range) - y.win.size) / step) # y.win.size + n * step covers the y range if y.win.size + n * step >= diff(y.range), thus if n >= (diff(y.range) - y.win.size) / step -x.outside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are upper or lower than the frame -x.inside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are not upper or lower than the frame -x.data1.median <- median(data1[, x1], na.rm = TRUE) # will be used for sliding window without data1 in it -if( ! is.null(data2)){ -x.outside.data2.dot.nb <- integer() # vector that will contain the selected 1D coordinates (i.e., dots) of data2 that are upper or lower than the data1 frame -x.inside.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are not upper or lower than the data1 frame -x.unknown.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are problematic: data2 dots outside of the range of data1, or data2 dots in a sliding window without data1 dots -# recover data2 dots outside the range of data1 -if(any(data2[, y2] < y.range[1])){ -x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[data2[, y2] < y.range[1]]) +}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 } -if(any(data2[, y2] > y.range[2])){ -x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[data2[, y2] > y.range[2]]) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = dot.categ.legend.name, values = rep(dot.alpha, length(dot.categ.class.order)), guide = ggplot2::guide_legend(override.aes = list(fill = dot.color, color = if(is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # 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 recover data2 dots outside the range of data1 +}else if(dot.tidy == TRUE){ +if(is.null(dot.categ)){ +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", group = "tidy_group"), +position = ggplot2::position_dodge(width = box.width), +binaxis = "y", +stackdir = "center", +alpha = dot.alpha, +fill = as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]), +stroke = dot.border.size, +color = if(is.null(dot.border.color)){as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"])}else{rep(dot.border.color, nrow(dot.coord))}, +show.legend = FALSE, # BEWARE: do not use show.legend = TRUE because it uses the arguments outside aes() as aesthetics (here color and fill). Thus I must find a way using ggplot2::scale_discrete_manual() +binwidth = (y.lim[2] - y.lim[1]) / dot.tidy.bin.nb +)) # very weird behavior of geom_dotplot, (1) because with aes group = (to avoid legend), the dot plotting is not good in term of coordinates, and (2) because data1 seems reorderer according to x = categ[1] before plotting. Thus, I have to use fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"] to have the good corresponding colors # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) +}else{ +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", alpha = categ[length(categ)]), +position = ggplot2::position_dodge(width = box.width), +binaxis = "y", +stackdir = "center", +fill = as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]), +stroke = dot.border.size, +color = if(is.null(dot.border.color)){as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"])}else{rep(dot.border.color, nrow(dot.coord))}, +# BEWARE: do not use show.legend = TRUE because it uses the arguments outside aes() as aesthetics (here color and fill). Thus I must find a way using ggplot2::scale_discrete_manual() +binwidth = (y.lim[2] - y.lim[1]) / dot.tidy.bin.nb +)) # very weird behavior of geom_dotplot, (1) because with aes group = (to avoid legend), the dot plotting is not good in term of coordinates, and (2) because data1 seems reorderer according to x = categ[1] before plotting. Thus, I have to use fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"] to have the good corresponding colors # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) +# 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 = "alpha", name = dot.categ.legend.name, values = rep(dot.alpha, length(dot.categ.class.order)), labels = dot.categ.class.order, guide = ggplot2::guide_legend(title = if(ini.dot.categ == categ[length(categ)]){dot.categ}else{ini.dot.categ}, override.aes = list(fill = dot.color, color = if(is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # 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 } -# loop.ini.time <- as.numeric(Sys.time()) -for(i1 in 0:(loop.nb + 1)){ -min.pos <- y.range[1] + step * i1 # lower position of the sliding window in data1 -max.pos <- min.pos + y.win.size # upper position of the sliding window in data1 -y.data1.d <- c(y.data1.d, min.pos, min.pos + step) # min.pos + step to make the steps -y.data1.t <- c(y.data1.t, max.pos, max.pos + step) # max.pos + step to make the steps -y.data1.dot.here <- data1[, y1] >= min.pos & data1[, y1] < max.pos # is there data1 dot present in the sliding window, considering the y axis? -if( ! is.null(data2)){ -y.data2.dot.here <- data2[, y2] >= min.pos & data2[, y2] < max.pos # is there data2 dot present in the sliding window, considering the y axis? +# 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))]] } -# recover the data1 dots outside the frame -if(any(y.data1.dot.here == TRUE)){ -tempo.x.data1.right.limit <- quantile(data1[y.data1.dot.here, x1], probs = 1 - error, na.rm = TRUE) -tempo.x.data1.left.limit <- quantile(data1[y.data1.dot.here, x1], probs = 0 + error, na.rm = TRUE) -x.data1.right.limit.d <- c(x.data1.right.limit.d, tempo.x.data1.right.limit, tempo.x.data1.right.limit) -x.data1.left.limit.d <- c(x.data1.left.limit.d, tempo.x.data1.left.limit, tempo.x.data1.left.limit) -x.data1.right.limit.t <- c(x.data1.right.limit.t, tempo.x.data1.right.limit, tempo.x.data1.right.limit) -x.data1.left.limit.t <- c(x.data1.left.limit.t, tempo.x.data1.left.limit, tempo.x.data1.left.limit) -x.data1.dot.signif <- ( ! ((data1[, x1] <= tempo.x.data1.right.limit) & (data1[, x1] >= tempo.x.data1.left.limit))) & y.data1.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the x axis? -x.data1.dot.not.signif <- y.data1.dot.here & ! x.data1.dot.signif -x.outside.data1.dot.nb <- c(x.outside.data1.dot.nb, data1$DOT_NB[x.data1.dot.signif]) # recover the row number of data1 -x.outside.data1.dot.nb <- unique(x.outside.data1.dot.nb) -x.inside.data1.dot.nb <- c(x.inside.data1.dot.nb, data1$DOT_NB[x.data1.dot.not.signif]) -x.inside.data1.dot.nb <- unique(x.inside.data1.dot.nb) +tempo.box.coord <- merge(box.coord, unique(dot.coord[, c("PANEL", "group", categ)]), by = c("PANEL", "group"), sort = FALSE) # add the categ in box.coord. BEWARE: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in box.coord. Thus, no need to consider fill column +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", "PANEL", "group", "x", categ)], by = c("PANEL", "group"), sort = FALSE) # send the coord of the boxs into the coord data.frame of the dots (in the column x.y).BEWARE: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in tempo.box.coord. Thus, no need to consider fill column +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(data1[, categ[1]]))) # categ[1] is factor +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( +formatC(as.integer(data1[, categ[2]]), width = nchar(max(as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking +".", +formatC(as.integer(data1[, categ[1]]), width = nchar(max(as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking +))) # merge the 2 formatC() to create a new factor. The convertion to integer should recreate the correct group number +) +) # 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{ -x.data1.right.limit.d <- c(x.data1.right.limit.d, x.data1.median, x.data1.median) -x.data1.left.limit.d <- c(x.data1.left.limit.d, x.data1.median, x.data1.median) -x.data1.right.limit.t <- c(x.data1.right.limit.t, x.data1.median, x.data1.median) -x.data1.left.limit.t <- c(x.data1.left.limit.t, x.data1.median, x.data1.median) +tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") +stop(tempo.cat) } -# end recover the data1 dots outside the frame -# recover the data2 dots outside the frame -if( ! is.null(data2)){ -if(any(y.data1.dot.here == TRUE) & any(y.data2.dot.here == TRUE)){ -x.data2.dot.signif <- ( ! ((data2[, x2] <= tempo.x.data1.right.limit) & (data2[, x2] >= tempo.x.data1.left.limit))) & y.data2.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the x axis? -x.data2.dot.not.signif <- y.data2.dot.here & ! x.data2.dot.signif -x.outside.data2.dot.nb <- c(x.outside.data2.dot.nb, data2$DOT_NB[x.data2.dot.signif]) -x.outside.data2.dot.nb <- unique(x.outside.data2.dot.nb) -x.inside.data2.dot.nb <- c(x.inside.data2.dot.nb, data2$DOT_NB[x.data2.dot.not.signif]) -x.inside.data2.dot.nb <- unique(x.inside.data2.dot.nb) -}else if(any(y.data1.dot.here == FALSE) & any(y.data2.dot.here == TRUE)){ # recover the data2 dots outside the range of the data1 cloud -x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[y.data2.dot.here]) -x.unknown.data2.dot.nb <- unique(x.unknown.data2.dot.nb) +dot.coord.tidy3 <- merge(dot.coord.tidy2, tempo.data1, by = intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. BEWARE: I have tested intersect("group", "group") instead of by = "group". May be come back to by = "group" in case of error. But I did this because of an error in dot.coord.rd3 above +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 -# tempo.warn <- paste0("FROM FUNCTION ", function.name, ": THE [", round(min.pos, 3), " ; ", round(max.pos, 3), "] INTERVAL DOES NOT CONTAIN data1 Y VALUES BUT CONTAINS data2 Y VALUES WHICH CANNOT BE EVALUATED.\nTHE CONCERNED data2 ROW NUMBERS ARE:\n", paste(which(y.data1.dot.here == FALSE & y.data2.dot.here == TRUE), collapse = "\n")) -# warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +# boxplot display (if box.fill = FALSE, otherwise, already plotted above) +if(box.fill == TRUE){ +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color})) #, guide = ggplot2::guide_legend(override.aes = list(fill = levels(tempo.polygon$COLOR), color = "black")))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = rep(hsv(0, 0, 0, alpha = box.alpha), length(unique(data1[, categ[length(categ)]]))))) # , guide = ggplot2::guide_legend(override.aes = list(color = "black", alpha = box.alpha)))) # 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") } -# end recover the data2 dots outside the frame -# if(any(i1 == seq(1, loop.nb, 500))){ -# loop.fin.time <- as.numeric(Sys.time()) # time of process end -# cat(paste0("COMPUTATION TIME OF LOOP ", i1, " / ", loop.nb, ": ", as.character(lubridate::seconds_to_period(round(loop.fin.time - loop.ini.time))), "\n")) -# } +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = rep(NA, length(unique(data1[, categ[length(categ)]]))))) #, guide = ggplot2::guide_legend(override.aes = list(color = categ.color)))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color}, guide = ggplot2::guide_legend(override.aes = list(alpha = if(plot == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){1}else{box.alpha})))) # , 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 +if(plot == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1 +# 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 +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -if(max.pos < y.range[2]){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE SLIDING WINDOW HAS NOT REACHED THE MAX VALUE OF data1 ON THE Y-AXIS: ", max.pos, " VERSUS ", y.range[2], "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) } -x.incon.data1.dot.nb.final <- unique(c(x.outside.data1.dot.nb[x.outside.data1.dot.nb %in% x.inside.data1.dot.nb], x.inside.data1.dot.nb[x.inside.data1.dot.nb %in% x.outside.data1.dot.nb])) # inconsistent dots: if a row number of x.inside.data1.dot.nb is present in x.outside.data1.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list -x.outside.data1.dot.nb.final <- x.outside.data1.dot.nb[ ! (x.outside.data1.dot.nb %in% x.incon.data1.dot.nb.final)] # inconsistent dots removed from the outside list -x.inside.data1.dot.nb.final <- x.inside.data1.dot.nb[ ! (x.inside.data1.dot.nb %in% x.incon.data1.dot.nb.final)] # inconsistent dots removed from the inside list -if( ! is.null(data2)){ -# if some unknown dots are also inside, and/or outside, they are put in the inside and/or outside. Ok, because then the intersection between inside and outside is treated -> inconsistent dots -tempo.unknown.out <- x.unknown.data2.dot.nb[x.unknown.data2.dot.nb %in% x.outside.data2.dot.nb] -x.outside.data2.dot.nb <- unique(c(x.outside.data2.dot.nb, tempo.unknown.out)) # if a row number of x.unknown.data2.dot.nb is present in x.outside.data2.dot.nb, it is put into outside -tempo.unknown.in <- x.unknown.data2.dot.nb[x.unknown.data2.dot.nb %in% x.inside.data2.dot.nb] -x.inside.data2.dot.nb <- unique(c(x.inside.data2.dot.nb, tempo.unknown.in)) # if a row number of x.unknown.data2.dot.nb is present in x.inside.data2.dot.nb, it is put into inside -x.unknown.data2.dot.nb.final <- x.unknown.data2.dot.nb[ ! (x.unknown.data2.dot.nb %in% c(x.outside.data2.dot.nb, x.inside.data2.dot.nb))] # then dots also in inside and outside are remove from unknown -x.incon.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb[x.outside.data2.dot.nb %in% x.inside.data2.dot.nb], x.inside.data2.dot.nb[x.inside.data2.dot.nb %in% x.outside.data2.dot.nb])) # inconsistent dots: if a row number of x.inside.data2.dot.nb is present in x.outside.data2.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list -x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb[ ! (x.outside.data2.dot.nb %in% x.incon.data2.dot.nb.final)] # inconsistent dots removed from the outside list -x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb[ ! (x.inside.data2.dot.nb %in% x.incon.data2.dot.nb.final)] # inconsistent dots removed from the inside list +# 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 +coord.names <- c(coord.names, "stat.display") +}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 } -# end y-axis sliding and x-axis limits of the data1 cloud -> x significant data2 +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) } -# end Method using y unit interval +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 +coord.names <- c(coord.names, "stat.display.positive", "stat.display.negative") +}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 -# recovering the frame coordinates -hframe = rbind( -data.frame( -x = if(is.null(x.data1.l)){NULL}else{x.data1.l}, -y = if(is.null(x.data1.l)){NULL}else{y.data1.down.limit.l}, -kind = if(is.null(x.data1.l)){NULL}else{"down.frame1"} -), -data.frame( -x = if(is.null(x.data1.r)){NULL}else{x.data1.r}, -y = if(is.null(x.data1.r)){NULL}else{y.data1.down.limit.r}, -kind = if(is.null(x.data1.r)){NULL}else{"down.frame2"} -), -data.frame( -x = if(is.null(x.data1.l)){NULL}else{x.data1.l}, -y = if(is.null(x.data1.l)){NULL}else{y.data1.top.limit.l}, -kind = if(is.null(x.data1.l)){NULL}else{"top.frame1"} -), -data.frame( -x = if(is.null(x.data1.r)){NULL}else{x.data1.r}, -y = if(is.null(x.data1.r)){NULL}else{y.data1.top.limit.r}, -kind = if(is.null(x.data1.r)){NULL}else{"top.frame2"} -) -) -vframe = rbind( -data.frame( -x = if(is.null(y.data1.d)){NULL}else{x.data1.left.limit.d}, -y = if(is.null(y.data1.d)){NULL}else{y.data1.d}, -kind = if(is.null(y.data1.d)){NULL}else{"left.frame1"} -), -data.frame( -x = if(is.null(y.data1.t)){NULL}else{x.data1.left.limit.t}, -y = if(is.null(y.data1.t)){NULL}else{y.data1.t}, -kind = if(is.null(y.data1.t)){NULL}else{"left.frame2"} -), -data.frame( -x = if(is.null(y.data1.d)){NULL}else{x.data1.right.limit.d}, -y = if(is.null(y.data1.d)){NULL}else{y.data1.d}, -kind = if(is.null(y.data1.d)){NULL}else{"right.frame1"} -), -data.frame( -x = if(is.null(y.data1.t)){NULL}else{x.data1.right.limit.t}, -y = if(is.null(y.data1.t)){NULL}else{y.data1.t}, -kind = if(is.null(y.data1.t)){NULL}else{"right.frame2"} -) -) -# end recovering the frame coordinates -# recovering the dot coordinates -data1.signif.dot <- NULL -data1.non.signif.dot <- NULL -data1.incon.dot <- NULL -data2.signif.dot <- NULL -data2.non.signif.dot <- NULL -data2.unknown.dot <- NULL -data2.incon.dot <- NULL -if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){ -# inconsistent dots recovery -if(length(unique(c(x.incon.data1.dot.nb.final, y.incon.data1.dot.nb.final))) > 0){ -data1.incon.dot <- data1[data1$DOT_NB %in% unique(c(x.incon.data1.dot.nb.final, y.incon.data1.dot.nb.final)), ] # if a dot in inconsistent in x or y -> classified as inconsistent (so unique() used) -# removal of the inconsistent dot in the other classifications -x.inside.data1.dot.nb.final <- x.inside.data1.dot.nb.final[ ! x.inside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] -y.inside.data1.dot.nb.final <- y.inside.data1.dot.nb.final[ ! y.inside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] -x.outside.data1.dot.nb.final <- x.outside.data1.dot.nb.final[ ! x.outside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] -y.outside.data1.dot.nb.final <- y.outside.data1.dot.nb.final[ ! y.outside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] -x.unknown.data1.dot.nb.final <- x.unknown.data1.dot.nb.final[ ! x.unknown.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] -y.unknown.data1.dot.nb.final <- y.unknown.data1.dot.nb.final[ ! y.unknown.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] -# end removal of the inconsistent dot in the other classifications -} -if( ! is.null(data2)){ -if(length(unique(c(x.incon.data2.dot.nb.final, y.incon.data2.dot.nb.final))) > 0){ -data2.incon.dot <- data2[data2$DOT_NB %in% unique(c(x.incon.data2.dot.nb.final, y.incon.data2.dot.nb.final)), ] -# removal of the inconsistent dot in the other classifications -x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] -y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] -x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] -y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] -x.unknown.data2.dot.nb.final <- x.unknown.data2.dot.nb.final[ ! x.unknown.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] -y.unknown.data2.dot.nb.final <- y.unknown.data2.dot.nb.final[ ! y.unknown.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] -# end removal of the inconsistent dot in the other classifications -} -} -# end inconsistent dots recovery -# unknown dots recovery -if( ! is.null(data2)){ -if(data2.pb.dot == "signif"){ -x.outside.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) -x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% x.unknown.data2.dot.nb.final] # remove x.unknown.data2.dot.nb.final from x.inside.data2.dot.nb.final -y.outside.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) -y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% y.unknown.data2.dot.nb.final] # remove y.unknown.data2.dot.nb.final from y.inside.data2.dot.nb.final -x.unknown.data2.dot.nb.final <- NULL -y.unknown.data2.dot.nb.final <- NULL -data2.unknown.dot <- NULL -}else if(data2.pb.dot == "not.signif"){ -x.inside.data2.dot.nb.final <- unique(c(x.inside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) -x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% x.unknown.data2.dot.nb.final] # remove x.unknown.data2.dot.nb.final from x.outside.data2.dot.nb.final -y.inside.data2.dot.nb.final <- unique(c(y.inside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) -y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% y.unknown.data2.dot.nb.final] # remove y.unknown.data2.dot.nb.final from y.outside.data2.dot.nb.final -x.unknown.data2.dot.nb.final <- NULL -y.unknown.data2.dot.nb.final <- NULL -data2.unknown.dot <- NULL -}else if(data2.pb.dot == "unknown"){ -if(length(unique(c(x.unknown.data2.dot.nb.final, y.unknown.data2.dot.nb.final))) > 0){ -data2.unknown.dot <- data2[data2$DOT_NB %in% unique(c(x.unknown.data2.dot.nb.final, y.unknown.data2.dot.nb.final)), ] # if a dot in unknown in x or y -> classified as unknown (so unique() used) -x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove x.unknown.data2.dot.nb.final from x.outside.data2.dot.nb.final -x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove x.unknown.data2.dot.nb.final from x.inside.data2.dot.nb.final -y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove y.unknown.data2.dot.nb.final from y.outside.data2.dot.nb.final -y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove y.unknown.data2.dot.nb.final from y.inside.data2.dot.nb.final +# 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]] +if(is.null(y.tick.nb) & y.log != "no"){ # integer main ticks for log2 and log10 +tempo.scale <- (as.integer(min(y.lim, na.rm = TRUE)) - 1):(as.integer(max(y.lim, na.rm = TRUE)) + 1) +}else{ +tempo.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{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 3\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +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 +# y.second.tick.positions: coordinates of secondary ticks (only if y.inter.tick.nb argument is non NULL or if y.log argument is different from "no") +y.second.tick.values <- NULL +if(y.log != "no"){ +# make a function from this +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, i.e., integer part of y.lim. Example recover 08 from 1e+08. Works for log2 +# 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 <- unique(as.vector(outer(2:10, ifelse(y.log == "log2", 2, 10)^((power10.exp[1] - ifelse(diff(y.lim.order) > 0, 1, -1)):(power10.exp[2] + ifelse(diff(y.lim.order) > 0, 1, -1)))))) # use log10(2:10) even if log2: it is to get log values between 0 and 1 +tempo.tick.pos <- sort(tempo.tick.pos, decreasing = ifelse(diff(y.lim.order) > 0, FALSE, TRUE)) +y.second.tick.values <- tempo.tick.pos +if(y.log == "log2"){ +tempo.tick.pos <- log2(tempo.tick.pos[tempo.tick.pos >= min(2^y.lim) & tempo.tick.pos <= max(2^y.lim)]) +}else if(y.log == "log10"){ +tempo.tick.pos <- log10(tempo.tick.pos[tempo.tick.pos >= min(10^y.lim) & tempo.tick.pos <= max(10^y.lim)]) } -# end unknown dots recovery -# sign and non sign dot recovery -if(xy.cross.kind == "|"){ # here the problem is to deal with significant dots depending on x and y. Thus I start with that, recover dots finally non significant in outside and put them in inside (when &), and remove from inside the dots in outside -if(length(unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final))) > 0){ -tempo.outside <- unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final)) # union so unique() used -tempo.inside <- unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)) -tempo.inside <- tempo.inside[ ! tempo.inside %in% tempo.outside] -data1.signif.dot <- data1[data1$DOT_NB %in% tempo.outside, ] -data1.non.signif.dot <- data1[data1$DOT_NB %in% tempo.inside, ] -}else{ -data1.non.signif.dot <- data1[unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it +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) } -}else if(xy.cross.kind == "&"){ -if(sum(x.outside.data1.dot.nb.final %in% y.outside.data1.dot.nb.final) > 0){ # that is intersection -tempo.outside <- unique(x.outside.data1.dot.nb.final[x.outside.data1.dot.nb.final %in% y.outside.data1.dot.nb.final]) # intersection -tempo.outside.removed <- unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final))[ ! unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final)) %in% tempo.outside] -tempo.inside <- unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)) -data1.signif.dot <- data1[data1$DOT_NB %in% tempo.outside, ] -data1.non.signif.dot <- data1[data1$DOT_NB %in% tempo.inside, ] -}else{ -data1.non.signif.dot <- data1[unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it +# 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)) +# } +coord.names <- c(coord.names, "y.second.tick.positions") +}else if(( ! is.null(y.inter.tick.nb)) & y.log == "no"){ +# if(y.inter.tick.nb > 0){ #inactivated because already checked before +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) +minor.tick.pos <- minor.tick.pos[minor.tick.pos >= min(y.lim) & minor.tick.pos <= max(y.lim)] +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{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 4\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +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) } -if( ! is.null(data2)){ -if(xy.cross.kind == "|"){ # here the problem is to deal with significant dots depending on x and y. Thus I start with that, recover dots finally non significant in outside and put them in inside (when &), and remove from inside the dots in outside -if(length(unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final))) > 0){ -tempo.outside <- unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final)) # union so unique() used -tempo.inside <- unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)) -tempo.inside <- tempo.inside[ ! tempo.inside %in% tempo.outside] -data2.signif.dot <- data2[data2$DOT_NB %in% tempo.outside, ] -data2.non.signif.dot <- data2[data2$DOT_NB %in% tempo.inside, ] -}else{ -data2.non.signif.dot <- data2[unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it +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) +minor.tick.pos <- minor.tick.pos[minor.tick.pos >= min(y.lim) & minor.tick.pos <= max(y.lim)] +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)) } -}else if(xy.cross.kind == "&"){ -if(sum(x.outside.data2.dot.nb.final %in% y.outside.data2.dot.nb.final) > 0){ # that is intersection -tempo.outside <- unique(x.outside.data2.dot.nb.final[x.outside.data2.dot.nb.final %in% y.outside.data2.dot.nb.final]) # intersection -tempo.outside.removed <- unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final))[ ! unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final)) %in% tempo.outside] -tempo.inside <- unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)) -data2.signif.dot <- data2[data2$DOT_NB %in% tempo.outside, ] -data2.non.signif.dot <- data2[data2$DOT_NB %in% tempo.inside, ] -}else{ -data2.non.signif.dot <- data2[unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it +y.second.tick.values <- minor.tick.pos +coord.names <- c(coord.names, "y.second.tick.positions") } +# end secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip()) +# end y scale management (cannot be before dot plot management) + + + + +# drawing +fin.plot <- eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))) +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(fin.plot))) +# 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{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 5\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +# 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 } -# end sign and non sign dot recovery -}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){ -# inconsistent dots recovery -if(length(y.incon.data1.dot.nb.final) > 0){ -data1.incon.dot <- data1[data1$DOT_NB %in% y.incon.data1.dot.nb.final, ] -} -if( ! is.null(data2)){ -if(length(y.incon.data2.dot.nb.final) > 0){ -data2.incon.dot <- data2[data2$DOT_NB %in% y.incon.data2.dot.nb.final, ] -} -}# end inconsistent dots recovery -# unknown dots recovery -if( ! is.null(data2)){ -if(data2.pb.dot == "signif"){ -y.outside.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) -}else if(data2.pb.dot == "not.signif"){ -y.inside.data2.dot.nb.final <- unique(c(y.inside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) -}else if(data2.pb.dot == "unknown"){ -if(length(y.unknown.data2.dot.nb.final) > 0){ -data2.unknown.dot <- data2[data2$DOT_NB %in% y.unknown.data2.dot.nb.final, ] -} -}else{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -} -# end unknown dots recovery -# sign and non sign dot recovery -if(length(y.outside.data1.dot.nb.final) > 0){ -data1.signif.dot <- data1[data1$DOT_NB %in% y.outside.data1.dot.nb.final, ] -} -if(length(y.inside.data1.dot.nb.final) > 0){ -data1.non.signif.dot <- data1[data1$DOT_NB %in% y.inside.data1.dot.nb.final, ] -} -if( ! is.null(data2)){ -if(length(y.outside.data2.dot.nb.final) > 0){ -data2.signif.dot <- data2[data2$DOT_NB %in% y.outside.data2.dot.nb.final, ] -} -if(length(y.inside.data2.dot.nb.final) > 0){ -data2.non.signif.dot <- data2[data2$DOT_NB %in% y.inside.data2.dot.nb.final, ] -} -} -# end sign and non sign dot recovery -}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){ -# inconsistent dots recovery -if(length(x.incon.data1.dot.nb.final) > 0){ -data1.incon.dot <- data1[data1$DOT_NB %in% x.incon.data1.dot.nb.final, ] -} -if( ! is.null(data2)){ -if(length(x.incon.data2.dot.nb.final) > 0){ -data2.incon.dot <- data2[data2$DOT_NB %in% x.incon.data2.dot.nb.final, ] -} -}# end inconsistent dots recovery -# unknown dots recovery -if( ! is.null(data2)){ -if(data2.pb.dot == "signif"){ -x.outside.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) -}else if(data2.pb.dot == "not.signif"){ -x.inside.data2.dot.nb.final <- unique(c(x.inside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) -}else if(data2.pb.dot == "unknown"){ -if(length(x.unknown.data2.dot.nb.final) > 0){ -data2.unknown.dot <- data2[data2$DOT_NB %in% x.unknown.data2.dot.nb.final, ] -} +if(return == TRUE){ +output <- ggplot2::ggplot_build(fin.plot) +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{ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -} -# end unknown dots recovery -# sign and non sign dot recovery -if(length(x.outside.data1.dot.nb.final) > 0){ -data1.signif.dot <- data1[data1$DOT_NB %in% x.outside.data1.dot.nb.final, ] -} -if(length(x.inside.data1.dot.nb.final) > 0){ -data1.non.signif.dot <- data1[data1$DOT_NB %in% x.inside.data1.dot.nb.final, ] -} -if( ! is.null(data2)){ -if(length(x.outside.data2.dot.nb.final) > 0){ -data2.signif.dot <- data2[data2$DOT_NB %in% x.outside.data2.dot.nb.final, ] -} -if(length(x.inside.data2.dot.nb.final) > 0){ -data2.non.signif.dot <- data2[data2$DOT_NB %in% x.inside.data2.dot.nb.final, ] -} -} -# end sign and non sign dot recovery -} -# end recovering the dot coordinates -# verif -if(any(data1.signif.dot$DOT_NB %in% data1.non.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", FUNCTION.NAME, ": CODE INCONSISTENCY 8\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data1.non.signif.dot$DOT_NB %in% data1.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", FUNCTION.NAME, ": CODE INCONSISTENCY 9\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data1.signif.dot$DOT_NB %in% data1.incon.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 10\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data1.incon.dot$DOT_NB %in% data1.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 11\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data1.non.signif.dot$DOT_NB %in% data1.incon.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 12\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data1.incon.dot$DOT_NB %in% data1.non.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 13\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if( ! is.null(data2)){ -if(any(data2.signif.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 14\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data2.non.signif.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 15\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data2.signif.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 16\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data2.unknown.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 17\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data2.signif.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 18\n\n============\n\n") -stop(tempo.cat, call. = FALSE) -} -if(any(data2.incon.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 19\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +names(output$data) <- coord.names } -if(any(data2.non.signif.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 20\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +output <- list(data = data1, stat = stat, removed.row.nb = removed.row.nb, removed.rows = removed.rows, plot = c(output$data, y.second.tick.values = list(y.second.tick.values)), panel = facet.categ, axes = output$layout$panel_params[[1]], warn = paste0("\n", warn, "\n\n")) +return(output) } -if(any(data2.unknown.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 21\n\n============\n\n") -stop(tempo.cat, call. = FALSE) +# end outputs +# end main code } -if(any(data2.non.signif.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 22\n\n============\n\n") -stop(tempo.cat, call. = FALSE) + + +######## fun_gg_prop() #### ggplot2 proportion barplot + + +######## fun_gg_dot() #### ggplot2 categorial dotplot + mean/median + + +######## fun_gg_violin() #### ggplot2 violins + + +######## fun_gg_line() #### ggplot2 lines + background dots and error bars + + +# DO NOT ERASE. COMPARE WITH BAR MEAN BEFORE AND RECOVER WHAT HAS BEEN MODIFIED + +fun_gg_line <- function(data1, y, categ, categ.class.order = NULL, categ.legend.name = NULL, categ.color = NULL, line.size = 1, 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 = FALSE, y.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, title = "", text.size = 12, text.angle = 0, classic = FALSE, grid = FALSE, return = FALSE, lib.path = NULL){ +# AIM +# 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 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 +# ylog: logical. Log scale for the y-axis? BEWARE: do not tranform the data, but just display ticks in a log scale manner. BEWARE: if TRUE, ylim must not contain null or negative values. In addition, will be automatically set to FALSE if vertical argument is set to FALSE, to prevent a bug in ggplot2 (see https://github.com/tidyverse/ggplot2/issues/881) +# y.tick.nb: number of desired values on the y-axis +# y.include.zero: logical. Does ylim range include 0? BEWARE: if ylog = TRUE, will be automately set to FALSE with a warning message +# 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. BEWARE with ylog = TRUE, the range result must not overlap zero or negative values +# 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 for x-axis legend. If NULL, character string of categ1 +# ylab: a character string y-axis legend. If NULL, character string of the y argument +# vertical: logical. Vertical bars? BEWARE: cannot have horizontal bars with a log axis, i.e., ylog = TRUE & vertical = FALSE (see ylog above) +# title: character string of the graph title +# text.size: numeric value of the text 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 +# return: logical. Return the graph parameters? +# lib.path: absolute path of the required packages, if not in the default folders } -if(any(data2.incon.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 23\n\n============\n\n") + + +######## fun_gg_heatmap() #### ggplot2 heatmap + overlaid mask if required + + +#test plot.margin = margin(up.space.mds, right.space.mds, down.space.mds, left.space.mds, "inches") to set the dim of the region plot ? +# if matrix is full of zero (or same value I guess), heatmap is complicate. Test it and error message + +# Check OK: clear to go Apollo +fun_gg_heatmap <- function(data1, legend.name1 = "", low.color1 = "blue", mid.color1 = "white", high.color1 = "red", limit1 = NULL, midpoint1 = NULL, data2 = NULL, color2 = "black", alpha2 = 0.5, invert2 = FALSE, text.size = 12, title = "", title.text.size = 12, show.scale = TRUE, rotate = FALSE, return = FALSE, plot = TRUE, add = NULL, warn.print = FALSE, lib.path = NULL){ +# AIM +# ggplot2 heatmap with the possibility to overlay a mask +# see also: +# draw : http://www.sthda.com/english/wiki/ggplot2-quick-correlation-matrix-heatmap-r-software-and-data-visualization +# same range scale : https://stackoverflow.com/questions/44655723/r-ggplot2-heatmap-fixed-scale-color-between-graphs +# for ggplot2 specifications, see: https://ggplot2.tidyverse.org/articles/ggplot2-specs.html +# ARGUMENTS +# data1: numeric matrix or data frame resulting from the conversion of the numeric matrix by reshape2::melt() +# legend.name1: character string of the data1 heatmap scale legend +# low.color1: character string of the color (i.e., "blue" or "#0000FF") of the lowest scale value +# mid.color1: same as low.color1 but for the middle scale value. If NULL, the middle color is the default color between low.color1 and high.color1. BEWARE: argument midpoint1 is not ignored, even if mid.color1 is NULL, meaning that the default mid color can still be controled +# high.color1: same as low.color1 but for the highest scale value +# limit1: 2 numeric values defining the lowest and higest color scale values. If NULL, take the range of data1 values +# midpoint1: single numeric value defining the value corresponding to the mid.color1 argument. A warning message is returned if midpoint1 does not correspond to the mean of limit1 values, because the color scale is not linear anymore. If NULL, takes the mean of limit1 values. Mean of data1, instead of mean of limit1, can be used here if required +# data2: binary mask matrix (made of 0 and 1) of same dimension as data1 or a data frame resulting from the conversion of the binary mask matrix by reshape2::melt(). Value 1 of data2 will correspond to color2 argument (value 0 will be NA color), and the opposite if invert2 argument is TRUE (inverted mask) +# color2: color of the 1 values of the binary mask matrix. The 0 values will be color NA +# alpha2: numeric value (from 0 to 1) of the mask transparency +# invert2: logical. Invert the mask (1 -> 0 and 0 -> 1)? +# text.size: numeric value of the size of the texts in scale +# title: character string of the graph title +# title.text.size: numeric value of the title size (in points) +# show.scale: logical. Show color scale? +# rotate: logical. Rotate the heatmap 90° clockwise? +# 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 +# reshape2 +# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_check() +# fun_pack() +# fun_round() +# RETURN +# a heatmap if plot argument is TRUE +# a list of the graph info if return argument is TRUE: +# $data: a list of the graphic info +# $axes: a list of the axes info +# $scale: the scale info (lowest, mid and highest values) +# $warn: the warning messages. Use cat() for proper display. NULL if no warning +# EXAMPLES +# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), title = "GRAPH 1") +# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), return = TRUE) +# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), legend.name1 = "VALUE", title = "GRAPH 1", text.size = 5, data2 = matrix(rep(c(1,0,0,0), 4), ncol = 4), invert2 = FALSE, return = TRUE) +# diagonal matrix +# fun_gg_heatmap(data1 = matrix(c(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), ncol = 4)) +# fun_gg_heatmap(data1 = reshape2::melt(matrix(c(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), ncol = 4))) +# error message +# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), data2 = matrix(rep(c(1,0,0,0), 5), ncol = 5)) +# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), data2 = reshape2::melt(matrix(rep(c(1,0,0,0), 4), ncol = 4))) +# fun_gg_heatmap(data1 = reshape2::melt(matrix(1:16, ncol = 4)), data2 = reshape2::melt(matrix(rep(c(1,0,0,0), 4), ncol = 4))) +#### 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) +# 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) +# 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)) +# 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) +# 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) +# 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) +# 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) +# 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) +# 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) +# 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()") +# 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) + + + + + +# DEBUGGING +# data1 = matrix(1:16, ncol = 4) ; legend.name1 = "" ; low.color1 = "blue" ; mid.color1 = "white" ; high.color1 = "red" ; limit1 = NULL ; midpoint1 = NULL ; data2 = matrix(rep(c(1,0,0,0), 4), ncol = 4) ; color2 = "black" ; alpha2 = 0.5 ; invert2 = FALSE ; text.size = 12 ; title = "" ; title.text.size = 12 ; show.scale = TRUE ; rotate = 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_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(any(data2.unknown.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 24\n\n============\n\n") +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(any(data2.incon.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){ -tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 25\n\n============\n\n") +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) } +# end required function checking +# no reserved words required for this function +# argument checking +warn <- NULL +warn.count <- 0 +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)) +if(all(is.matrix(data1))){ +tempo <- fun_check(data = data1, class = "matrix", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) +}else if(all(is.data.frame(data1))){ +tempo <- fun_check(data = data1, class = "data.frame", length = 3, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE){ +# structure of reshape2::melt() data frame +tempo <- fun_check(data = data1[, 1], typeof = "integer", fun.name = function.name) +tempo <- fun_check(data = data1[, 2], typeof = "integer", fun.name = function.name) +tempo <- fun_check(data = data1[, 3], mode = "numeric", na.contain = TRUE, fun.name = function.name) } -# end verif -# plot -# recovering the axes data whatever plot or not -if(is.null(data2)){ -axes <- fun_gg_scatter(data1 = list(data1), x = list(x1), y = list(y1), categ = list(NULL), color = list(fun_gg_palette(2)[2]), geom = list("geom_point"), alpha = list(0.5), x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, plot = FALSE, return = TRUE)$axes }else{ -axes <- fun_gg_scatter(data1 = list(data1, data2), x = list(x1, x2), y = list(y1, y2), categ = list(NULL, NULL), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1]), geom = list("geom_point", "geom_point"), alpha = list(0.5, 0.5), x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, plot = FALSE, return = TRUE)$axes -} -# end recovering the axes data whatever plot or not -if(plot == TRUE){ -# add a categ for plot legend -tempo.df.name <- c("data1", "data1.signif.dot", "data1.incon.dot", "data2", "data2.signif.dot", "data2.unknown.dot", "data2.incon.dot") -tempo.class.name <- c("data1", "data1", "data1", "data2", "data2", "data2", "data2") -for(i2 in 1:length(tempo.df.name)){ -if( ! is.null(get(tempo.df.name[i2]))){ -assign(tempo.df.name[i2], data.frame(get(tempo.df.name[i2]), kind = tempo.class.name[i2])) -} -} -# end add a categ for plot legend -if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) -} -tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe), x = list(x1, "x", "x"), y = list(y1, "y", "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) -} -if( ! is.null(data1.signif.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +tempo.cat <- paste0("ERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A NUMERIC MATRIX OR A DATA FRAME OUTPUT OF THE reshape::melt() FUNCTION\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.signif.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +tempo <- fun_check(data = legend.name1, class = "character", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = low.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (all(low.color1 %in% colors() | grepl(pattern = "^#", low.color1)))){ # check that all strings of low.color1 start by # +tempo.cat <- paste0("ERROR IN ", function.name, ": low.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +if( ! is.null(mid.color1)){ +tempo <- fun_check(data = mid.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (all(mid.color1 %in% colors() | grepl(pattern = "^#", mid.color1)))){ # check that all strings of mid.color1 start by # +tempo.cat <- paste0("ERROR IN ", function.name, ": mid.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS") } -if( ! is.null(data1.incon.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +tempo <- fun_check(data = high.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (all(high.color1 %in% colors() | grepl(pattern = "^#", high.color1)))){ # check that all strings of high.color1 start by # +tempo.cat <- paste0("ERROR IN ", function.name, ": high.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.incon.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +if( ! is.null(limit1)){ +tempo <- fun_check(data = limit1, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & any(limit1 %in% c(Inf, -Inf))){ +tempo.cat <- paste0("ERROR IN ", function.name, ": limit1 ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS") +if( ! is.null(midpoint1)){ +tempo <- fun_check(data = midpoint1, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) } if( ! is.null(data2)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) -} -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe , vframe), x = list(x1, x2, "x", "x"), y = list(y1, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) -} -if( ! is.null(data2.signif.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) -} -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) -} -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) -} -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS") +if(all(is.matrix(data2))){ +tempo <- fun_check(data = data2, class = "matrix", mode = "numeric", fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! all(unique(data2) %in% c(0,1))){ +tempo.cat <- paste0("ERROR IN ", function.name, ": MATRIX IN data2 MUST BE MADE OF 0 AND 1 ONLY (MASK MATRIX)\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & all(is.matrix(data1)) & ! identical(dim(data1), dim(data2))){ # matrix and matrix +tempo.cat <- paste0("ERROR IN ", function.name, ": MATRIX DIMENSION IN data2 MUST BE IDENTICAL AS MATRIX DIMENSION IN data1. HERE IT IS RESPECTIVELY:\n", paste(dim(data2), collapse = " "), "\n", paste(dim(data1), collapse = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & all(is.data.frame(data1)) & nrow(data1) != prod(dim(data2))){ # reshape2 and matrix +tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME IN data2 MUST HAVE ROW NUMBER EQUAL TO PRODUCT OF DIMENSIONS OF data1 MATRIX. HERE IT IS RESPECTIVELY:\n", paste(nrow(data1), collapse = " "), "\n", paste(prod(dim(data2)), collapse = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -if( ! is.null(data2.incon.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +}else if(all(is.data.frame(data2))){ +tempo <- fun_check(data = data2, class = "data.frame", length = 3, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE){ +# structure of reshape2::melt() data frame +tempo <- fun_check(data = data2[, 1], typeof = "integer", fun.name = function.name) +tempo <- fun_check(data = data2[, 2], typeof = "integer", fun.name = function.name) +tempo <- fun_check(data = data2[, 3], mode = "numeric", fun.name = function.name) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +if(tempo$problem == FALSE & ! all(unique(data2[, 3]) %in% c(0,1))){ +tempo.cat <- paste0("ERROR IN ", function.name, ": THIRD COLUMN OF DATA FRAME IN data2 MUST BE MADE OF 0 AND 1 ONLY (MASK DATA FRAME)\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & all(is.data.frame(data1)) & ! identical(dim(data1), dim(data2))){ # data frame and data frame +tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME DIMENSION IN data2 MUST BE IDENTICAL TO DATA FRAME DIMENSION IN data1. HERE IT IS RESPECTIVELY:\n", paste(dim(data2), collapse = " "), "\n", paste(dim(data1), collapse = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & all(is.matrix(data1)) & nrow(data2) != prod(dim(data1))){ # reshape2 and matrix +tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME IN data2 MUST HAVE ROW NUMBER EQUAL TO PRODUCT OF DIMENSION OF data1 MATRIX. HERE IT IS RESPECTIVELY:\n", paste(nrow(data2), collapse = " "), "\n", paste(prod(dim(data1)), collapse = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } }else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +tempo.cat <- paste0("ERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A NUMERIC MATRIX OR A DATA FRAME OUTPUT OF THE reshape::melt() FUNCTION\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS") } -if( ! is.null(data2.unknown.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +tempo <- fun_check(data = color2, class = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (all(color2 %in% colors() | grepl(pattern = "^#", color2)))){ # check that all strings of color2 start by # +tempo.cat <- paste0("ERROR IN ", function.name, ": color2 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) - -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +tempo <- fun_check(data = alpha2, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = invert2, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = title, class = "character", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = title.text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = show.scale, 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) } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 12, title = "DATA2 + DATA2 UNKNOWN DOTS") +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){ +if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA +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) } } -}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe), x = list(x1, "x"), y = list(y1, "y"), categ = list("kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -if( ! is.null(data1.signif.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = 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 +# package checking +fun_pack(req.package = c("reshape2", "ggplot2"), lib.path = lib.path) +# end package checking +# main code +if(all(is.matrix(data1))){ +data1 <- reshape2::melt(data1) # transform a matrix into a dataframe with 2 coordinates columns and the third intensity column } -tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +if(rotate == TRUE){ +data1[, 1] <- rev(data1[, 1]) } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +if(is.null(limit1)){ +if(any(data1[, 3] %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 THIRD COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS") +limit1 <- range(data1[, 3], 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 +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE limit1 ARGUMENT IS NULL -> RANGE OF data1 ARGUMENT HAS BEEN TAKEN: ", paste(fun_round(limit1), collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +if(suppressWarnings(any(limit1 %in% c(Inf, -Inf)))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED LIMIT CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } -if( ! is.null(data1.incon.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +if(is.null(midpoint1)){ +midpoint1 <- mean(limit1, na.rm = TRUE) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE midpoint1 ARGUMENT IS NULL -> MEAN OF limit1 ARGUMENT HAS BEEN TAKEN: ", paste(fun_round(midpoint1), collapse = " ")) +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +}else if(fun_round(midpoint1, 9) != fun_round(mean(limit1), 9)){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": THE midpoint1 ARGUMENT (", fun_round(mean(midpoint1), 9), ") DOES NOT CORRESPOND TO THE MEAN OF THE limit1 ARGUMENT (", fun_round(mean(limit1), 9), "). COLOR SCALE IS NOT LINEAR") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +if( ! is.null(data2)){ +if(all(is.matrix(data2))){ +data2 <- reshape2::melt(data2) # transform a matrix into a dataframe with 2 coordinates columns and the third intensity column } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS") +if(rotate == TRUE){ +data2[, 1] <- rev(data2[, 1]) +} +data2[, 3] <- factor(data2[, 3]) # to converte continuous scale into discrete scale } +tempo.gg.name <- "gg.indiv.plot." +tempo.gg.count <- 0 # to facilitate debugging +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_raster(data = data1, mapping = ggplot2::aes_string(x = names(data1)[ifelse(rotate == FALSE, 2, 1)], y = names(data1)[ifelse(rotate == FALSE, 1, 2)], fill = names(data1)[3]), show.legend = show.scale)) # 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_gradient2(low = low.color1, high = high.color1, mid = mid.color1, midpoint = midpoint1, limit = limit1, breaks = c(limit1[1], midpoint1, limit1[2]), labels = fun_round(c(limit1[1], midpoint1, limit1[2])), name = legend.name1)) if( ! is.null(data2)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_raster(data = data2, mapping = ggplot2::aes_string(x = names(data2)[ifelse(rotate == FALSE, 2, 1)], y = names(data2)[ifelse(rotate == FALSE, 1, 2)], alpha = names(data2)[3]), fill = color2, show.legend = FALSE)) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", values = if(invert2 == FALSE){c(0, alpha2)}else{c(alpha2, 0)}, guide = FALSE)) +# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_raster(data = data2, mapping = ggplot2::aes_string(x = names(data2)[ifelse(rotate == FALSE, 2, 1)], y = names(data2)[ifelse(rotate == FALSE, 1, 2)], group = names(data2)[3]), fill = data2[, 3], alpha = alpha2, show.legend = FALSE)) # BEWARE: this does not work if NA present, because geom_raster() has a tendency to complete empty spaces, and thus, behave differently than geom_tile(). See https://github.com/tidyverse/ggplot2/issues/3025 } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_fixed()) # x = y +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_y_reverse()) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title)) +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") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +add.check <- FALSE } -if( ! is.null(data2.signif.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +if(add.check == TRUE){ +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_classic(base_size = text.size)) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme( +text = ggplot2::element_text(size = text.size), +plot.title = ggplot2::element_text(size = title.text.size), # stronger than text +line = ggplot2::element_blank(), +axis.title = ggplot2::element_blank(), +axis.text = ggplot2::element_blank(), +axis.ticks = ggplot2::element_blank(), +panel.background = ggplot2::element_blank() +)) } +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})))) +# ) }else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) -} -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS") +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))) } -if( ! is.null(data2.incon.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +if(warn.print == TRUE & ! is.null(warn)){ +warning(warn, call. = FALSE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +if(return == TRUE){ +output <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))) +output <- output$data +names(output)[1] <- "heatmap" +if( ! is.null(data2)){ +names(output)[2] <- "mask" } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +return(list(data = output, axes = output$layout$panel_params[[1]], scale = c(limit1[1], midpoint1, limit1[2]), warn = warn)) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS") } -if( ! is.null(data2.unknown.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) + + +######## fun_gg_empty_graph() #### text to display for empty graphs + + + + + +# Check OK: clear to go Apollo +fun_gg_empty_graph <- function(text = NULL, text.size = 12, title = NULL, title.size = 8, lib.path = NULL){ +# AIM +# display an empty ggplot2 plot with a text in the middle of the window (for instance to specify that no plot can be drawn) +# ARGUMENTS +# text: character string of the message to display +# text.size: numeric value of the text size (in points) +# title: character string of the graph title +# title.size: numeric value of the title size (in points) +# lib.path: absolute path of the required packages, if not in the default folders +# REQUIRED PACKAGES +# ggplot2 +# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_check() +# fun_pack() +# RETURN +# an empty plot +# EXAMPLES +### simple example +# fun_gg_empty_graph(text = "NO GRAPH") +### white page +# fun_gg_empty_graph() +### all the arguments +# fun_gg_empty_graph(text = "NO GRAPH", text.size = 8, title = "GRAPH1", title.size = 10, lib.path = NULL) +# DEBUGGING +# text = "NO GRAPH" ; text.size = 12 ; title = "GRAPH1" ; title.size = 8 ; 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_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) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +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) } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +# end required function checking +# 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)) +if( ! is.null(text)){ +tempo <- fun_check(data = text, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 8, title = "DATA2 + DATA2 UNKNOWN DOTS") +tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +if( ! is.null(title)){ +tempo <- fun_check(data = title, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) } +tempo <- fun_check(data = title.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = 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 +# package checking +fun_pack(req.package = c("ggplot2"), lib.path = lib.path) +# end package checking +# main code +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()) +if( ! is.null(text)){ +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(data = data.frame(x = 1, y = 1), ggplot2::aes(x = x, y = y, label = text), size = text.size)) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe), x = list(x1, "x"), y = list(y1, "y"), categ = list("kind", "kind"), legend.name = list("DATASET", "VERT FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title)) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void()) +assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme( +plot.title = ggplot2::element_text(size = title.size) # stronger than text +)) +suppressWarnings(print(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))) } -if( ! is.null(data1.signif.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) + + +################ Graphic extraction + + +######## fun_trim() #### display values from a quantitative variable and trim according to defined cut-offs + + +# Check OK: clear to go Apollo +fun_trim <- function(data, displayed.nb = NULL, single.value.display = FALSE, trim.method = "", trim.cutoffs = c(0.05, 0.975), interval.scale.disp = TRUE, down.space = 0.75, left.space = 0.75, up.space = 0.3, right.space = 0.25, orient = 1, dist.legend = 0.37, box.type = "l", amplif.label = 1.25, amplif.axis = 1.25, std.x.range = TRUE, std.y.range = TRUE, cex.pt = 0.2, col.box = hsv(0.55, 0.8, 0.8), x.nb.inter.tick = 4, y.nb.inter.tick = 0, tick.length = 1, sec.tick.length = 0.75, corner.text = "", amplif.legend = 1, magnific.corner.text = 0.75, trim.return = FALSE){ +# AIM +# trim and display values from a numeric vector or matrix +# plot 4 graphs: stripchart of values, stripchart of rank of values, hitogramme and normal QQPlot +# different kinds of intervals are displayed on the top of graphes to facilitate the analysis of the variable and a trimming setting +# the trimming interval chosen is displayed on top of graphs +# both trimmed and not trimmed values are returned in a list +# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_check() +# ARGUMENTS +# data: values to plot (either a numeric vector or a numeric matrix) +# displayed.nb: number of values displayed. If NULL, all the values are displayed. Otherwise, if the number of values is over displayed.nb, then displayed.nb values are displayed after random selection +# single.value.display: provide the 4 graphs if data is made of a single (potentially repeated value)? If FALSE, an empty graph is displayed if data is made of a single (potentially repeated value). And the return list is made of NULL compartments +# trim.method: Write "" if not required. write "mean.sd" if mean +/- sd has to be displayed as a trimming interval (only recommanded for normal distribution). Write "quantile" to display a trimming interval based on quantile cut-offs. No other possibility allowed. See trim.cutoffs below +# trim.cutoffs: 2 values cutoff for the trimming interval displayed, each value between 0 and 1. Not used if trim.method == "".The couple of values c(lower, upper) represents the lower and upper boundaries of the trimming interval (in proportion), which represent the interval of distribution kept (between 0 and 1). Example: trim.cutoffs = c(0.05, 0.975). What is strictly kept for the display is ]lower , upper[, boundaries excluded. Using the "mean.sd" method, 0.025 and 0.975 represent 95% CI which is mean +/- 1.96 * sd +# interval.scale.disp: display sd and quantiles intervals on top of graphs ? +# down.space: lower vertical margin (in inches, mai argument of par()) +# left.space: left horizontal margin (in inches, mai argument of par()) +# up.space: upper vertical margin between plot region and grapical window (in inches, mai argument of par()) +# right.space: right horizontal margin (in inches, mai argument of par()) +# orient: scale number orientation (las argument of par()). 0, always parallel to the axis; 1, always horizontal; 2, always perpendicular to the axis; 3, always vertical +# dist.legend: numeric value that moves axis legends away in inches (first number of mgp argument of par() but in inches thus / 0.2) +# box.type: bty argument of par(). Either "o", "l", "7", "c", "u", "]", the resulting box resembles the corresponding upper case letter. A value of "n" suppresses the box +# amplif.label: increase or decrease the size of the text in legends +# amplif.axis: increase or decrease the size of the scale numbers in axis +# std.x.range: standard range on the x-axis? TRUE (no range extend) or FALSE (4% range extend). Controls xaxs argument of par() (TRUE is xaxs = "i", FALSE is xaxs = "r") +# std.y.range: standard range on the y-axis? TRUE (no range extend) or FALSE (4% range extend). Controls yaxs argument of par() (TRUE is yaxs = "i", FALSE is yaxs = "r") +# cex.pt: size of points in stripcharts (in inches, thus cex.pt will be thereafter / 0.2) +# col.box: color of boxplot +# x.nb.inter.tick: number of secondary ticks between main ticks on x-axis (only if not log scale). Zero means non secondary ticks +# y.nb.inter.tick: number of secondary ticks between main ticks on y-axis (only if not log scale). Zero means non secondary ticks +# tick.length: length of the ticks (1 means complete the distance between the plot region and the axis numbers, 0.5 means half the length, etc. 0 means no tick +# sec.tick.length: length of the secondary ticks (1 means complete the distance between the plot region and the axis numbers, 0.5 means half the length, etc., 0 for no ticks) +# corner.text: text to add at the top right corner of the window +# amplif.legend: increase or decrease the size of the text of legend +# magnific.corner.text: increase or decrease the size of the text +# trim.return: return the trimmed and non trimmed values? NULL returned for trimmed and non trimmed values if trim.method == "" +# RETURN +# a list containing: +# $trim.method: correspond to trim.method above +# $trim.cutoffs: correspond to trim.cutoffs above +# $real.trim.cutoffs: the two boundary values (in the unit of the numeric vector or numeric matrix analyzed). NULL +# $trimmed.values: the values outside of the trimming interval as defined in trim.cutoffs above +# $kept.values: the values inside the trimming interval as defined in trim.cutoffs above +# EXAMPLES +# fun_trim(data = c(1:100, 1:10), displayed.nb = NULL, single.value.display = FALSE, trim.method = "mean.sd", trim.cutoffs = c(0.05, 0.975), interval.scale.disp = TRUE, down.space = 0.75, left.space = 0.75, up.space = 0.3, right.space = 0.25, orient = 1, dist.legend = 0.37, box.type = "l", amplif.label = 1.25, amplif.axis = 1.25, std.x.range = TRUE, std.y.range = TRUE, cex.pt = 0.2, col.box = hsv(0.55, 0.8, 0.8), x.nb.inter.tick = 4, y.nb.inter.tick = 0, tick.length = 0.5, sec.tick.length = 0.3, corner.text = "", amplif.legend = 1, magnific.corner.text = 0.75, trim.return = TRUE) +# DEBUGGING +# data = c(1:100, 1:10) ; displayed.nb = NULL ; single.value.display = FALSE ; trim.method = "quantile" ; trim.cutoffs = c(0.05, 0.975) ; interval.scale.disp = TRUE ; down.space = 1 ; left.space = 1 ; up.space = 0.5 ; right.space = 0.25 ; orient = 1 ; dist.legend = 0.5 ; box.type = "l" ; amplif.label = 1 ; amplif.axis = 1 ; std.x.range = TRUE ; std.y.range = TRUE ; cex.pt = 0.1 ; col.box = hsv(0.55, 0.8, 0.8) ; x.nb.inter.tick = 4 ; y.nb.inter.tick = 0 ; tick.length = 0.5 ; sec.tick.length = 0.3 ; corner.text = "" ; amplif.legend = 1 ; magnific.corner.text = 0.75 ; trim.return = TRUE # for function debugging +# function name +function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") +# end function name +# required function checking +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) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "VERT FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +# end required function checking +# argument checking +# argument checking without fun_check() +if( ! (all(class(data) == "numeric") | all(class(data) == "integer") | (all(class(data) == "matrix") & mode(data) == "numeric"))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": data ARGUMENT MUST BE A NUMERIC VECTOR OR NUMERIC MATRIX\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } -}else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +# end argument checking without fun_check() +# argument checking with fun_check() +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)) +if( ! is.null(displayed.nb)){ +tempo <- fun_check(data = displayed.nb, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +if(displayed.nb < 2){ +tempo.cat <- paste0("ERROR IN ", function.name, ": displayed.nb ARGUMENT MUST BE A SINGLE INTEGER VALUE GREATER THAN 1 AND NOT: ", paste(displayed.nb, collapse = " ")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS") } -if( ! is.null(data1.incon.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +tempo <- fun_check(data = single.value.display, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = trim.method, options = c("", "mean.sd", "quantile"), length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = trim.cutoffs, class = "vector", mode = "numeric", length = 2, prop = TRUE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = interval.scale.disp, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = down.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = left.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = up.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = right.space, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = orient, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = dist.legend, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = box.type, options = c("o", "l", "7", "c", "u", "]", "n"), length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = amplif.label, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = amplif.axis, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = std.x.range, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = std.y.range, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = cex.pt, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = col.box, class = "character", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = x.nb.inter.tick, class = "integer", length = 1, neg.values = FALSE, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = y.nb.inter.tick, class = "integer", length = 1, neg.values = FALSE, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = tick.length, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = sec.tick.length, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = corner.text, class = "character", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = amplif.legend, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = magnific.corner.text, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = trim.return, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "VERT FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +# end argument checking with fun_check() +# 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 +# main code +if(class(data) == "matrix"){ +data <- as.vector(data) } +color.cut <- hsv(0.75, 1, 1) # color of interval selected +col.mean <- hsv(0.25, 1, 0.8) # color of interval using mean+/-sd +col.quantile <- "orange" # color of interval using quantiles +quantiles.selection <- c(0.01, 0.025, 0.05, 0.1, 0.25, 0.5, 0.75, 0.9, 0.95, 0.975, 0.99) # quantiles used in axis to help for choosing trimming cutoffs +if(single.value.display == FALSE & length(unique(data)) == 1){ +par(bty = "n", xaxt = "n", yaxt = "n", xpd = TRUE) +plot(1, pch = 16, col = "white", xlab = "", ylab = "") +text(x = 1, y = 1, paste0("No graphic displayed\nBecause data made of a single different value (", formatC(as.double(table(data))), ")"), cex = 2) +output <- list(trim.method = NULL, trim.cutoffs = NULL, real.trim.cutoffs = NULL, trimmed.values = NULL, kept.values = NULL) }else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +output <- list(trim.method = trim.method, trim.cutoffs = trim.cutoffs, real.trim.cutoffs = NULL, trimmed.values = NULL, kept.values = NULL) +fun.rug <- function(sec.tick.length.f = sec.tick.length, x.nb.inter.tick.f = x.nb.inter.tick, y.nb.inter.tick.f = y.nb.inter.tick){ +if(x.nb.inter.tick.f > 0){ +inter.tick.unit <- (par("xaxp")[2] - par("xaxp")[1]) / par("xaxp")[3] +par.ini <- par()[c("xpd", "tcl")] +par(xpd = FALSE) +par(tcl = -par()$mgp[2] * sec.tick.length.f) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region) +suppressWarnings(rug(seq(par("xaxp")[1] - 10 * inter.tick.unit, par("xaxp")[2] + 10 * inter.tick.unit, by = inter.tick.unit / (1 + x.nb.inter.tick.f)), ticksize = NA, side = 1)) # ticksize = NA to allow the use of par()$tcl value +par(par.ini) +rm(par.ini) } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS") +if(y.nb.inter.tick.f > 0){ +inter.tick.unit <- (par("yaxp")[2] - par("yaxp")[1]) / par("yaxp")[3] +par.ini <- par()[c("xpd", "tcl")] +par(xpd = FALSE) +par(tcl = -par()$mgp[2] * sec.tick.length.f) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region) +suppressWarnings(rug(seq(par("yaxp")[1] - 10 * inter.tick.unit, par("yaxp")[2] + 10 * inter.tick.unit, by = inter.tick.unit / (1 + y.nb.inter.tick.f)), ticksize = NA, side = 2)) # ticksize = NA to allow the use of par()$tcl value +par(par.ini) +rm(par.ini) } -if( ! is.null(data2)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, vframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +fun.add.cut <- function(data.f, trim.method.f = trim.method, trim.cutoffs.f = trim.cutoffs, color.cut.f = color.cut, return.f = FALSE){ +# DEBUGGING +# data.f = data ; trim.method.f = "mean.sd"; trim.cutoffs.f = trim.cutoffs ; color.cut.f = color.cut ; return.f = TRUE +real.trim.cutoffs.f <- NULL +if(trim.method.f != ""){ +data.f <- sort(data.f) +par.ini <- par()$xpd +par(xpd = FALSE) +if(trim.method.f == "mean.sd"){ +real.trim.cutoffs.f <- qnorm(trim.cutoffs.f, mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)) +abline(v = qnorm(trim.cutoffs.f, mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), col = color.cut.f) +segments(qnorm(trim.cutoffs.f[1], mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), par()$usr[4] * 0.75, qnorm(trim.cutoffs.f[2], mean(data.f, na.rm = TRUE), sd(data.f, na.rm = TRUE)), par()$usr[4] * 0.75, col = color.cut.f) } -if( ! is.null(data2.signif.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +if(trim.method.f == "quantile"){ +real.trim.cutoffs.f <- quantile(data.f, probs = trim.cutoffs.f, type = 7) +abline(v = quantile(data.f, probs = trim.cutoffs.f, type = 7), col = color.cut.f) +segments(quantile(data.f, probs = trim.cutoffs.f[1], type = 7), par()$usr[4] * 0.75, quantile(data.f, probs = trim.cutoffs.f[2], type = 7), par()$usr[4] * 0.75, col = color.cut.f) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +par(par.ini) +if(return.f == TRUE){ +trimmed.values.f <- data.f[data.f <= real.trim.cutoffs.f[1] | data.f >= real.trim.cutoffs.f[2]] +kept.values.f <- data.f[data.f > real.trim.cutoffs.f[1] & data.f < real.trim.cutoffs.f[2]] } }else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +real.trim.cutoffs.f <- NULL +trimmed.values.f <- NULL +kept.values.f <- NULL } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS") +if(return.f == TRUE){ +output <- list(trim.method = trim.method.f, trim.cutoffs = trim.cutoffs.f, real.trim.cutoffs = real.trim.cutoffs.f, trimmed.values = trimmed.values.f, kept.values = kept.values.f) +return(output) } -if( ! is.null(data2.incon.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) } -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +fun.interval.scale.display <- function(data.f, col.quantile.f = col.quantile, quantiles.selection.f = quantiles.selection, col.mean.f = col.mean){ # intervals on top of graphs +par.ini <- par()[c("mgp", "xpd")] +par(mgp = c(0.25, 0.25, 0), xpd = NA) +axis(side = 3, at = c(par()$usr[1], par()$usr[2]), labels = rep("", 2), col = col.quantile.f, lwd.ticks = 0) +par(xpd = FALSE) +axis(side = 3, at = quantile(as.vector(data.f), probs = quantiles.selection.f, type = 7), labels = quantiles.selection.f, col.axis = col.quantile.f, col = col.quantile.f) +par(mgp = c(1.75, 1.75, 1.5), xpd = NA) +axis(side = 3, at = c(par()$usr[1], par()$usr[2]), labels = rep("", 2), col = col.mean.f, lwd.ticks = 0) +par(xpd = FALSE) +axis(side = 3, at = m + s * qnorm(quantiles.selection.f), labels = formatC(round(qnorm(quantiles.selection.f), 2)), col.axis = col.mean.f, col = col.mean.f, lwd.ticks = 1) +par(par.ini) } +zone<-matrix(1:4, ncol=2) +layout(zone) +par(omi = c(0, 0, 1.5, 0), mai = c(down.space, left.space, up.space, right.space), las = orient, mgp = c(dist.legend / 0.2, 0.5, 0), xpd = FALSE, bty= box.type, cex.lab = amplif.label, cex.axis = amplif.axis, xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r")) +par(tcl = -par()$mgp[2] * tick.length) # tcl gives the length of the ticks as proportion of line text, knowing that mgp is in text lines. So the main ticks are a 0.5 of the distance of the axis numbers by default. The sign provides the side of the tick (negative for outside of the plot region) +if(is.null(displayed.nb)){ +sampled.data <- as.vector(data) +if(corner.text == ""){ +corner.text <- paste0("ALL VALUES OF THE DATASET DISPLAYED") }else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) -} -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS") -} -if( ! is.null(data2.unknown.dot)){ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) -} -tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) -if( ! is.null(tempo.graph$warn)){ -warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +corner.text <- paste0(corner.text, "\nALL VALUES OF THE DATASET DISPLAYED") } }else{ -if(graph.in.file == FALSE){ -fun_open(pdf.disp = FALSE) +if(length(as.vector(data)) > displayed.nb){ +sampled.data <- sample(as.vector(data), displayed.nb, replace = FALSE) +if(corner.text == ""){ +corner.text <- paste0("BEWARE: ONLY ", displayed.nb, " VALUES ARE DISPLAYED AMONG THE ", length(as.vector(data)), " VALUES OF THE DATASET ANALYZED") +}else{ +corner.text <- paste0(corner.text, "\nBEWARE: ONLY ", displayed.nb, " VALUES ARE DISPLAYED AMONG THE ", length(as.vector(data)), " VALUES OF THE DATASET ANALYZED") } -fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 8, title = "DATA2 + DATA2 UNKNOWN DOTS") +}else{ +sampled.data <- as.vector(data) +if(corner.text == ""){ +corner.text <- paste0("BEWARE: THE DISPLAYED NUMBER OF VALUES PARAMETER ", deparse(substitute(displayed.nb)), " HAS BEEN SET TO ", displayed.nb, " WHICH IS ABOVE THE NUMBER OF VALUES OF THE DATASET ANALYZED -> ALL VALUES DISPLAYED") +}else{ +corner.text <- paste0(corner.text, "\nBEWARE: THE DISPLAYED NUMBER OF VALUES PARAMETER ", deparse(substitute(displayed.nb)), " HAS BEEN SET TO ", displayed.nb, " WHICH IS ABOVE THE NUMBER OF VALUES OF THE DATASET ANALYZED -> ALL VALUES DISPLAYED") } } } +stripchart(sampled.data, method="jitter", jitter=0.4, vertical=FALSE, ylim=c(0.5, 1.5), group.names = "", xlab = "Value", ylab="", pch=1, cex = cex.pt / 0.2) +fun.rug(y.nb.inter.tick.f = 0) +boxplot(as.vector(data), horizontal=TRUE, add=TRUE, boxwex = 0.4, staplecol = col.box, whiskcol = col.box, medcol = col.box, boxcol = col.box, range = 0, whisklty = 1) +m <- mean(as.vector(data), na.rm = TRUE) +s <- sd(as.vector(data), na.rm = TRUE) +segments(m, 0.8, m, 1, lwd=2, col="red") # mean +segments(m -1.96 * s, 0.9, m + 1.96 * s, 0.9, lwd=1, col="red") # mean +graph.xlim <- par()$usr[1:2] # for hist() and qqnorm() below +if(interval.scale.disp == TRUE){ +fun.interval.scale.display(data.f = data) +if(corner.text == ""){ +corner.text <- paste0("MULTIPLYING FACTOR DISPLAYED (MEAN +/- SD) ON SCALES: ", paste(formatC(round(qnorm(quantiles.selection), 2))[-(1:(length(quantiles.selection) - 1) / 2)], collapse = ", "), "\nQUANTILES DISPLAYED ON SCALES: ", paste(quantiles.selection, collapse = ", ")) +}else{ +corner.text <- paste0(corner.text, "\nMULTIPLYING FACTOR DISPLAYED (MEAN +/- SD) ON SCALES: ", paste(formatC(round(qnorm(quantiles.selection), 2))[-(1:(length(quantiles.selection) - 1) / 2)], collapse = ", "), "\nQUANTILES DISPLAYED ON SCALES: ", paste(quantiles.selection, collapse = ", ")) } -# end plot -if(warn.print == TRUE & ! is.null(warn)){ -warning(warn, call. = FALSE) -cat("\n\n") } -tempo.list <- list(data1.removed.row.nb = data1.removed.row.nb, data1.removed.rows = data1.removed.rows, data2.removed.row.nb = data2.removed.row.nb, data2.removed.rows = data2.removed.rows, hframe = hframe, vframe = vframe, data1.signif.dot = data1.signif.dot, data1.non.signif.dot = data1.non.signif.dot, data1.inconsistent.dot = data1.incon.dot, data2.signif.dot = data2.signif.dot, data2.non.signif.dot = data2.non.signif.dot, data2.unknown.dot = data2.unknown.dot, data2.inconsistent.dot = data2.incon.dot, axes = axes, warn = warn) -return(tempo.list) +output.tempo <- fun.add.cut(data.f = data, return.f = TRUE) # to recover real.trim.cutoffs +if(trim.return == TRUE){ +output <- output.tempo } - - -################ Import - - -######## fun_pack() #### check if R packages are present and import into the working environment - - -# Check OK: clear to go Apollo -fun_pack <- function(req.package, load = FALSE, lib.path = NULL){ -# AIM -# check if the specified R packages are present in the computer and import them into the working environment -# ARGUMENTS -# req.package: character vector of package names to import -# req.package: logical. Load the package into the environement (using library())? -# lib.path: optional character vector specifying the absolute pathways of the directories containing some of the listed packages -# REQUIRED PACKAGES -# none -# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_check() -# RETURN -# nothing -# EXAMPLES -# fun_pack(req.package = "nopackage") -# fun_pack(req.package = "ggplot2") -# fun_pack(req.package = "ggplot2", lib.path = "blablabla") -# DEBUGGING -# req.package = "ggplot2" ; lib.path = "C:/Program Files/R/R-3.5.1/library" -# req.package = "serpentine" ; lib.path = "C:/users/gael/appdata/roaming/python/python36/site-packages" -# function name -function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") -# end function name -# required function checking -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) +par(xpd = NA) +if(trim.method != ""){ +if(corner.text == ""){ +corner.text <- paste0("SELECTED CUT-OFFS (PROPORTION): ", paste(trim.cutoffs, collapse = ", "), "\nSELECTED CUT-OFFS: ", paste(output.tempo$real.trim.cutoffs, collapse = ", ")) +}else{ +corner.text <- paste0(corner.text, "\nSELECTED CUT-OFFS (PROPORTION): ", paste(trim.cutoffs, collapse = ", "), "\nSELECTED CUT-OFFS: ", paste(output.tempo$real.trim.cutoffs, collapse = ", ")) } -# end required function checking -# 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 = req.package, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = load, class = "vector", mode = "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){ -if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA -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(interval.scale.disp == TRUE){ +legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- 1.96sd", paste0("Trimming interval: ", paste0(trim.cutoffs, collapse = " , ")), "Mean +/- sd multiplying factor", "Quantile"), yjust = 0, lty=1, col=c(col.box, "red", color.cut, col.mean, col.quantile), bty="n", cex = amplif.legend) +}else{ +legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- 1.96sd", paste0("Trimming interval: ", paste0(trim.cutoffs, collapse = " , "))), yjust = 0, lty=1, col=c(col.box, "red", color.cut), bty="n", cex = amplif.legend, y.intersp=1.25) } +}else{ +if(interval.scale.disp == TRUE){ +legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- sd", "Mean +/- sd multiplying factor", "Quantile"), yjust = 0, lty=1, col=c(col.box, "red", col.mean, col.quantile), bty="n", cex = amplif.legend) +}else{ +legend(x = (par("usr")[1] - ((par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1])) * par("plt")[1] - ((par("usr")[2] - par("usr")[1]) / (par("omd")[2] - par("omd")[1])) * par("omd")[1]), y = (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / (par("omd")[4] - par("omd")[3])) * (1 - par("omd")[4]) / 2), legend = c(c("min, Q1, Median, Q3, max"), "mean +/- sd"), yjust = 0, lty=1, col=c(col.box, "red"), bty="n", cex = amplif.legend, y.intersp=1.25) } } -if(any(arg.check) == TRUE){ -stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # +par(xpd = FALSE, xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r")) +hist(as.vector(data), main = "", breaks = seq(min(as.vector(data), na.rm = TRUE), max(as.vector(data), na.rm = TRUE), length.out = length(as.vector(data)) / 10), xlim = graph.xlim, xlab = "Value", ylab="Density", col = grey(0.25)) +abline(h = par()$usr[3]) +fun.rug() +if(interval.scale.disp == TRUE){ +fun.interval.scale.display(data.f = data) } -# 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 -# main code -if(is.null(lib.path)){ -lib.path <- .libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path)) -}else{ -.libPaths(new = sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. BEWARE: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path +fun.add.cut(data.f = data) +par(xaxs = ifelse(std.x.range, "i", "r")) +stripchart(rank(sampled.data), method="stack", vertical=FALSE, ylim=c(0.99, 1.3), group.names = "", xlab = "Rank of values", ylab="", pch=1, cex = cex.pt / 0.2) +fun.rug(y.nb.inter.tick.f = 0) +x.text <- par("usr")[2] + (par("usr")[2] - par("usr")[1]) / (par("plt")[2] - par("plt")[1]) * (1 - par("plt")[2]) / 2 +y.text <- (par("usr")[4] + ((par("usr")[4] - par("usr")[3]) / (par("plt")[4] - par("plt")[3])) * (1 - par("plt")[4]) + ((par("usr")[4] - par("usr")[3]) / ((par()$omd[4] / 2) * ((par("plt")[4] - par("plt")[3])))) * (1 - par("omd")[4])) # BEWARE. Here in "(par()$omd[4] / 2", division by two because there are 2 graphs staked on the y axis, and not one +par(xpd=NA) +text(x = x.text, y = y.text, paste0(corner.text), adj=c(1, 1.1), cex = magnific.corner.text) # text at the topright corner +par(xpd=FALSE) +par(xaxs = ifelse(std.x.range, "i", "r"), yaxs = ifelse(std.y.range, "i", "r")) +qqnorm(as.vector(sampled.data), main = "", datax = TRUE, ylab = "Value", pch = 1, col = "red", cex = cex.pt / 0.2) +fun.rug() +if(diff(quantile(as.vector(data), probs = c(0.25, 0.75), na.rm = TRUE)) != 0){ # otherwise, error generated +qqline(as.vector(data), datax = TRUE) } -for(i1 in 1:length(req.package)){ -if( ! req.package[i1] %in% rownames(utils::installed.packages(lib.loc = lib.path))){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i1], " MUST BE INSTALLED IN:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -}else{ -if(load == TRUE){ -suppressWarnings(suppressPackageStartupMessages(library(req.package[i1], lib.loc = lib.path, quietly = TRUE, character.only = TRUE))) +if(interval.scale.disp == TRUE){ +fun.interval.scale.display(data.f = data) } +fun.add.cut(data.f = data) } +if(trim.return == TRUE){ +return(output) } } -######## fun_python_pack() #### check if python packages are present +######## fun_segmentation() #### segment a dot cloud on a scatterplot and define the dots from another cloud outside the segmentation # Check OK: clear to go Apollo -fun_python_pack <- function(req.package, python.exec.path = NULL, lib.path = NULL, R.lib.path = NULL){ +fun_segmentation <- function(data1, x1, y1, x.range.split = NULL, x.step.factor = 10, y.range.split = NULL, y.step.factor = 10, error = 0, data2 = NULL, x2, y2, data2.pb.dot = "unknown", xy.cross.kind = "&", plot = FALSE, graph.in.file = FALSE, raster = TRUE, warn.print = FALSE, lib.path = NULL){ # AIM -# check if the specified python packages are present in the computer (no import) +# if data1 is a data frame corresponding to the data set of a scatterplot (with a x column for x-axis values and a y column for the y-axis column), then fun_segmentation() delimits a frame around the dots cloud using a sliding window set by x.range.split and x.step.factor to frame the top and bottom part of the cloud, and set by y.range.split and y.step.factor to frame the left and right part of the cloud +# if a second data frame is provided, corresponding to the data set of a scatterplot (with a x column for x-axis values and a y column for the y-axis column), then fun_segmentation() defines the dots of this data frame, outside of the frame of the first data frame # WARNINGS -# for python 3.7. Previous versions return an error "Error in sys$stdout$flush() : attempt to apply non-function" +# if dots from data2 look significant on the graph (outside the frame) but are not (not black on the last figure), this is probably because the frame is flat on the zero coordinate (no volume inside the frame at this position). Thus, no way to conclude that data2 dots here are significant. These dots are refered to as "unknown". The pb.dot argument deals with such dots +# dots that are sometimes inside and outside the frame, depending on the sliding window, are treated differently: they are removed. Such dots are neither classified as "signif", "non signif" or "unknown", but as "inconsistent" +# unknown dots are treated as finally significant, not significant, or unknown (data2.pb.dot argument) for each x-axis and y-axis separately. Then, the union or intersection of significant dots is performed (argument xy.cross.kind). See the example section # ARGUMENTS -# req.package: character vector of package names to import -# python.exec.path: optional character vector specifying the absolute pathways of the executable python file to use (associated to the packages to use). If NULL, the reticulate::import_from_path() function used in fun_python_pack() seeks for an available version of python.exe, and then uses python_config(python_version, required_module, python_versions). But might not be the correct one for the lib.path parameter specified. Thus, it is recommanded to do not leave NULL, notably when using computing clusters -# lib.path: optional character vector specifying the absolute pathways of the directories containing some of the listed packages in the req.package argument -# R.lib.path: absolute path of the reticulate packages, if not in the default folders +# data1: a dataframe containing a column of x-axis values and a column of y-axis values +# x1: character string of the data1 column name for x-axis (first column of data1 by default) +# y1: character string of the data1 column name for y-axis (second column of data1 by default) +# x.range.split: positive non null numeric value giving the number of interval on the x value range. if x.range is the range of the dots on the x-axis, then abs(diff(x.range) / x.range.split) gives the window size. Window size decreases when range.split increases. In unit of x-axis. Write NULL if not required. At least one of the x.range.split and y.range.split must be non NULL +# x.step.factor: positive non null numeric value giving the shift step of the window. If x.step.factor = 1, no overlap during the sliding (when the window slides from position n to position n+1, no overlap between the two positions). If x.step.factor = 2, 50% of overlap (when the window slides from position n to position n+1, the window on position n+1 overlap 50% of the window when it was on position n) +# y.range.split: same as x.range.split for the y-axis. At least one of the x.range.split and y.range.split must be non NULL +# y.step.factor: same as x.step.factor for the y-axis +# error: proportion (from 0 to 1) of false positives (i.e., proportion of dots from data1 outside of the frame). 0.05 means 5% of the dots from data1 outside of the frame +# data2: a dataframe containing a column of x-axis values and a column of y-axis values, for which outside dots of the data1 cloud has to be determined. Write NULL if not required +# x2: character string of the data1 column name for x-axis (first column of data1 by default) +# y2: character string of the data1 column name for y-axis (second column of data1 by default) +# data2.pb.dot: unknown dots are explain in the warning section above. If "signif", then the unknown dots are finally considered as significant (outside the frame). If "not.signif", then the unknown dots are finally considered as non significant (inside the frame). If "unknown", no conclusion are drawn from these dots. See the examples below +# xy.cross.kind: if data2 is non null and if both x.range.split and y.range.split are non null, which dots are finally significants? Write "&" for intersection of outside dots on x and on y. Write "|" for union of outside dots on x and on y. See the examples below +# plot: logical. Print graphs that check the frame? +# graph.in.file: logical. Graphs sent into a graphic device already opened? If FALSE, GUI are opened for each graph. If TRUE, no GUI are opended. The graphs are displayed on the current active graphic device. Ignored if plot is 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 region plot will be square to avoid a bug in fun_gg_point_rast(). If TRUE, solve the transparency problem with some GUI. Not considered if plot is FALSE +# 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. Ignored if plot is FALSE # REQUIRED PACKAGES -# reticulate +# ggplot2 if plot is TRUE # REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION # fun_check() +# if plot is TRUE: # fun_pack() +# fun_open() +# fun_gg_palette() +# fun_gg_scatter() +# fun_gg_empty_graph() +# fun_close() # RETURN -# nothing +# several graphs if plot is TRUE +# a list containing: +# $data1.removed.row.nb: which rows have been removed due to NA; NaN, -Inf or Inf detection in x1 or y1 columns (NULL if no row removed) +# $data1.removed.rows: removed rows (NULL if no row removed) +# $data2.removed.row.nb: which rows have been removed due to NA; NaN, -Inf or Inf detection in x2 or y2 columns (NULL if no row removed) +# $data2.removed.rows: removed rows (NULL if no row removed) +# $hframe: x and y coordinates of the bottom and top frames for frame plotting (frame1 for the left step and frame2 for the right step) +# $vframe: x and y coordinates of the left and right frames for frame plotting (frame1 for the down step and frame2 for the top step) +# $data1.signif.dot: the significant dots of data1 (i.e., dots outside the frame). A good segmentation should not have any data1.signif.dot +# $data1.non.signif.dot: the non significant dots of data1 (i.e., dots inside the frame) +# $data1.inconsistent.dot: see the warning section above +# $data2.signif.dot: the significant dots of data2 if non NULL (i.e., dots outside the frame) +# $data2.non.signif.dot: the non significant dots of data2 (i.e., dots inside the frame) +# $data2.unknown.dot: the problematic dots of data2 (i.e., data2 dots outside of the range of data1, or data2 dots in a sliding window without data1 dots). Is systematically NULL except if argument data2.pb.dot = "unknown" and some data2 dots are in such situation. Modifying the segmentation x.range.split, x.step.factor, y.range.split, y.step.factor arguments can solve this problem +# $data2.inconsistent.dot: see the warning section above +# $axes: the x-axis and y-axis info +# $warn: the warning messages. Use cat() for proper display. NULL if no warning # EXAMPLES -# example of error message -# fun_python_pack(req.package = "nopackage") -# example without error message (require the installation of the python serpentine package from https://github.com/koszullab/serpentine -# fun_python_pack(req.package = "serpentine", python.exec.path = "C:/ProgramData/Anaconda3/python.exe", lib.path = "c:/programdata/anaconda3/lib/site-packages/") -# another example of error message -# fun_python_pack(req.package = "serpentine", lib.path = "blablabla") +# example explaining the unknown and inconsistent dots, and the cross + +# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data1[5:7, 2] <- NA ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; data2[11:13, 1] <- Inf ; set.seed(NULL) ; fun_segmentation(data1 = data1, x1 = names(data1)[1], y1 = names(data1)[2], x.range.split = 20, x.step.factor = 10, y.range.split = 23, y.step.factor = 10, error = 0, data2 = data2, x2 = names(data2)[1], y2 = names(data2)[2], data2.pb.dot = "not.signif", xy.cross.kind = "|", plot = TRUE, graph.in.file = FALSE, raster = FALSE, lib.path = NULL) +# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; fun_segmentation(data1 = data1, x1 = names(data1)[1], y1 = names(data1)[2], x.range.split = NULL, x.step.factor = 10, y.range.split = 23, y.step.factor = 10, error = 0, data2 = data2, x2 = names(data2)[1], y2 = names(data2)[2], data2.pb.dot = "unknown", xy.cross.kind = "|", plot = TRUE, graph.in.file = FALSE, raster = FALSE, lib.path = NULL) +# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; fun_segmentation(data1 = data1, x1 = names(data1)[1], y1 = names(data1)[2], x.range.split = 20, x.step.factor = 10, y.range.split = NULL, y.step.factor = 10, error = 0, data2 = data2, x2 = names(data2)[1], y2 = names(data2)[2], data2.pb.dot = "unknown", xy.cross.kind = "&", plot = TRUE, graph.in.file = FALSE, raster = FALSE, lib.path = NULL) # DEBUGGING -# req.package = "serpentine" ; python.exec.path = "C:/ProgramData/Anaconda3/python.exe" ; lib.path = "c:/programdata/anaconda3/lib/site-packages/" ; R.lib.path = NULL -# req.package = "bad" ; lib.path = NULL ; R.lib.path = NULL +# set.seed(1) ; data1 = data.frame(x = rnorm(50), y = rnorm(50)) ; data1[5:7, 2] <- NA ; x1 = names(data1)[1] ; y1 = names(data1)[2] ; x.range.split = 5 ; x.step.factor = 10 ; y.range.split = 5 ; y.step.factor = 10 ; error = 0 ; data2 = data.frame(x = rnorm(50, 0, 2), y = rnorm(50, 0, 2)) ; set.seed(NULL) ; x2 = names(data2)[1] ; y2 = names(data2)[2] ; data2.pb.dot = "unknown" ; xy.cross.kind = "|" ; plot = TRUE ; graph.in.file = FALSE ; raster = FALSE ; warn.print = TRUE ; lib.path = NULL +# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; x1 = names(data1)[1] ; y1 = names(data1)[2] ; x.range.split = 20 ; x.step.factor = 10 ; y.range.split = 23 ; y.step.factor = 10 ; error = 0 ; x2 = names(data2)[1] ; y2 = names(data2)[2] ; data2.pb.dot = "not.signif" ; xy.cross.kind = "|" ; plot = TRUE ; graph.in.file = FALSE ; raster = FALSE ; warn.print = TRUE ; lib.path = NULL +# set.seed(1) ; data1 = data.frame(x = rnorm(500), y = rnorm(500)) ; data2 = data.frame(x = rnorm(500, 0, 2), y = rnorm(500, 0, 2)) ; set.seed(NULL) ; x1 = names(data1)[1] ; y1 = names(data1)[2] ; x.range.split = 20 ; x.step.factor = 10 ; y.range.split = NULL ; y.step.factor = 10 ; error = 0 ; x2 = names(data2)[1] ; y2 = names(data2)[2] ; data2.pb.dot = "unknown" ; xy.cross.kind = "&" ; plot = TRUE ; graph.in.file = FALSE ; raster = FALSE ; warn.print = TRUE ; lib.path = NULL # function name function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") # end function name @@ -7966,2094 +8424,1617 @@ 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_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) -} # end required function checking # argument checking +warn <- NULL +warn.count <- 0 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 = req.package, class = "character", fun.name = function.name) ; eval(ee) -if( ! is.null(python.exec.path)){ -tempo <- fun_check(data = python.exec.path, class = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE){ -if( ! all(file.exists(python.exec.path))){ # separation to avoid the problem of tempo$problem == FALSE and python.exec.path == NA -tempo.cat <- paste0("ERROR IN ", function.name, ": FILE PATH INDICATED IN THE python.exec.path ARGUMENT DOES NOT EXISTS:\n", paste(python.exec.path, collapse = "\n")) +tempo <- fun_check(data = data1, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & length(data1) < 2){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": data1 ARGUMENT MUST BE A DATA FRAME OF AT LEAST 2 COLUMNS\n\n============\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +} +tempo <- fun_check(data = x1, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (x1 %in% names(data1))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x1 ARGUMENT MUST BE A COLUMN NAME OF data1\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & x1 %in% names(data1)){ +tempo <- fun_check(data = data1[, x1], data.name = "x1 COLUMN OF data1", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) +} +tempo <- fun_check(data = y1, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (y1 %in% names(data1))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y1 ARGUMENT MUST BE A COLUMN NAME OF data1\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & y1 %in% names(data1)){ +tempo <- fun_check(data = data1[, y1], data.name = "y1 COLUMN OF data1", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) +} +if(is.null(x.range.split) & is.null(y.range.split)){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": AT LEAST ONE OF THE x.range.split AND y.range.split ARGUMENTS MUST BE NON NULL\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +} +if( ! is.null(x.range.split)){ +tempo <- fun_check(data = x.range.split, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & x.range.split < 1){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x.range.split ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } } -} -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){ -if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA -tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", paste(lib.path, collapse = "\n")) +if( ! is.null(y.range.split)){ +tempo <- fun_check(data = y.range.split, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & y.range.split < 1){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y.range.split ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } } +tempo <- fun_check(data = x.step.factor, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & x.step.factor < 1){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x.step.factor ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -if( ! is.null(R.lib.path)){ -tempo <- fun_check(data = R.lib.path, class = "character", fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE){ -if( ! all(dir.exists(R.lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and R.lib.path == NA -tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE R.lib.path ARGUMENT DOES NOT EXISTS:\n", paste(R.lib.path, collapse = "\n")) +tempo <- fun_check(data = y.step.factor, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & y.step.factor < 1){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y.step.factor ARGUMENT CANNOT BE LOWER THAN 1\n\n================\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) } +tempo <- fun_check(data = error, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee) +if( ! is.null(data2)){ +if(is.null(x2) | is.null(y2)){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x2 AND y2 ARGUMENTS CANNOT BE NULL IF data2 ARGUMENT IS NON NULL\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } +tempo <- fun_check(data = data2, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & length(data2) < 2){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": data2 ARGUMENT MUST BE A DATA FRAME OF AT LEAST 2 COLUMNS\n\n============\n\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) # +if( ! is.null(x2)){ +tempo <- fun_check(data = x2, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (x2 %in% names(data2))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": x2 ARGUMENT MUST BE A COLUMN NAME OF data2\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & x2 %in% names(data2)){ +tempo <- fun_check(data = data2[, x2], data.name = "x2 COLUMN OF data2", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) } -# 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 -# package checking -fun_pack(req.package = "reticulate", lib.path = R.lib.path) -# end package checking -# main code -if(is.null(python.exec.path)){ -python.exec.path <- reticulate::py_run_string(" -import sys ; -path_lib = sys.path -") # python string -python.exec.path <- python.exec.path$path_lib } -if(is.null(lib.path)){ -lib.path <- reticulate::py_run_string(" -import sys ; -path_lib = sys.path -") # python string -lib.path <- lib.path$path_lib +if( ! is.null(y2)){ +tempo <- fun_check(data = y2, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & ! (y2 %in% names(data2))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": y2 ARGUMENT MUST BE A COLUMN NAME OF data2\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & y2 %in% names(data2)){ +tempo <- fun_check(data = data2[, y2], data.name = "y2 COLUMN OF data2", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee) } -reticulate::use_python(Sys.which(python.exec.path), required = TRUE) # required to avoid the use of erratic python exec by reticulate::import_from_path() -for(i1 in 1:length(req.package)){ -tempo.try <- vector("list", length = length(lib.path)) -for(i2 in 1:length(lib.path)){ -tempo.try[[i2]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i1], path = lib.path[i2]), silent = TRUE)) -tempo.try[[i2]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i1], path = lib.path[i2]), silent = TRUE)) # done twice to avoid the error message about flushing present the first time but not the second time. see https://stackoverflow.com/questions/57357001/reticulate-1-13-error-in-sysstdoutflush-attempt-to-apply-non-function } -if(all(sapply(tempo.try, FUN = grepl, pattern = "[Ee]rror"))){ -print(tempo.try) -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i1], " MUST BE INSTALLED IN THE MENTIONNED DIRECTORY:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n") -stop(tempo.cat, call. = FALSE) -} # else{ -# suppressWarnings(suppressPackageStartupMessages(assign(req.package[i1], reticulate::import(req.package[i1])))) # not required because try() already evaluates -# } } +if( ! is.null(data2)){ +tempo <- fun_check(data = data2.pb.dot, options = c("signif", "not.signif", "unknown"), length = 1, fun.name = function.name) ; eval(ee) } - - -################ Print / Exporting results (text & tables) - - -######## fun_report() #### print string or data object into output file - - -# Check OK: clear to go Apollo -fun_report <- function(data, output = "results.txt", path = "C:/Users/Gael/Desktop/", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = TRUE, sep = 2){ -# AIM -# log file function: print a character string or a data object into a same output file -# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_check() -# ARGUMENTS -# data: object to print in the output file. If NULL, nothing is done, with no warning -# output: name of the output file -# path: location of the output file -# no.overwrite: (logical) if output file already exists, defines if the printing is appended (default TRUE) or if the output file content is erased before printing (FALSE) -# rownames.kept: (logical) defines whether row names have to be removed or not in small tables (less than length.rows rows) -# vector.cat (logical). If TRUE print a vector of length > 1 using cat() instead of capture.output(). Otherwise (default FALSE) the opposite -# noquote: (logical). If TRUE no quote are present for the characters -# sep: number of separating lines after printed data (must be integer) -# RETURN -# nothing -# EXAMPLES -# fun_report() -# fun_report(data = 1:3, output = "results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = FALSE, sep = 2) -# DEBUGGING -# data = 1:3 ; output = "results.txt" ; path = "C:/Users/Gael/Desktop" ; no.overwrite = TRUE ; rownames.kept = FALSE ; vector.cat = FALSE ; noquote = FALSE ; sep = 2 # for function debugging -# function name -function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") -# end function name -# required function checking -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( ! (is.null(x.range.split)) & ! (is.null(y.range.split))){ +tempo <- fun_check(data = xy.cross.kind, options = c("&", "|"), length = 1, fun.name = function.name) ; eval(ee) } -# end required function checking -# 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 = output, class = "character", length = 1, fun.name = function.name) ; eval(ee) -if(tempo$problem == FALSE & output == ""){ -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": output ARGUMENT AS \"\" DOES NOT CORRESPOND TO A VALID FILE NAME\n\n================\n\n") +tempo <- fun_check(data = plot, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = warn.print, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & plot == TRUE){ +tempo <- fun_check(data = raster, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = graph.in.file, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & graph.in.file == TRUE & is.null(dev.list())){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": \ngraph.in.file PARAMETER SET TO TRUE BUT NO ACTIVE GRAPHIC DEVICE DETECTED\n\n============\n\n") text.check <- c(text.check, tempo.cat) arg.check <- c(arg.check, TRUE) +}else if(tempo$problem == FALSE & graph.in.file == TRUE & ! is.null(dev.list())){ +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": GRAPHS PRINTED IN THE CURRENT DEVICE (TYPE ", toupper(names(dev.cur())), ")") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -tempo <- fun_check(data = path, class = "vector", mode = "character", 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){ -if( ! all(dir.exists(path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA -tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n", paste(path, collapse = "\n"),"\n\n================\n\n") +if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA +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) } } -tempo <- fun_check(data = no.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = rownames.kept, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = vector.cat, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = noquote, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = sep, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) +} +} if(any(arg.check) == TRUE){ stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -# end argument checking # 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() -# the 4 next lines are inactivated but kept because at a time, I might have a problem with data (solved with data = NULL). These 4 lines are just to know how to detect a missing argument. Important here because if data is not provided, print the code of the data function -# arg.user.list <- as.list(match.call(expand.dots=FALSE))[-1] # recover all the arguments provided by the function user (excluding the argument with defaults values not provided by the user. Thus, it is really the list indicated by the user) -# default.arg.list <- formals(fun = sys.function(sys.parent())) # list of all the arguments of the function with their default values (not the values of the user !). It seems that ls() as first line of the function provide the names of the arguments (empty, called, etc., or not) -# arg.without.default.value <- sapply(default.arg.list, is.symbol) & sapply(sapply(default.arg.list, as.character), identical, "") # logical to detect argument without default values (these are typeof "symbol" and class "name" and empty character -# if( ! all(names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list))){ # test that the arguments with no null values are provided by the user -# tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": VALUE REQUIRED FOR THESE ARGUMENTS WITH NO DEFAULTS VALUES: ", paste(names(default.arg.list)[arg.without.default.value][ ! names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list)], collapse = " "), "\n\n================\n\n") -#stop(tempo.cat, call. = FALSE) -# } # end argument checking +# other required function checking +if(plot == TRUE){ +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_open", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_open() 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_empty_graph", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_empty_graph() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} +if(length(utils::find("fun_gg_scatter", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_gg_scatter() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} +if(length(utils::find("fun_close", mode = "function")) == 0){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_close() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} +} +# end other required function checking +# package checking +if(plot == TRUE){ +fun_pack(req.package = c("ggplot2"), lib.path = lib.path) +} +# end package checking # main code -if( ! is.null(data)){ -if(all(class(data) %in% c("matrix", "data.frame", "table"))){ -if(rownames.kept == FALSE & all(class(data) == "data.frame") & nrow(data) != 0 & nrow(data) <= 4){ # for data frames with nrows <= 4 -rownames.output.tables <- "" -length.rows <- nrow(data) -for(i in 1:length.rows){ # replace the rownames of the first 4 rows by increasing number of spaces (because identical row names not allowed in data frames). This method cannot be extended to more rows as the printed data frame is shifted on the right because of "big empty rownames" -rownames.output.tables <- c(rownames.output.tables, paste0(rownames.output.tables[i]," ", collapse="")) +# na and Inf detection and removal (done now to be sure of the correct length of categ) +data1.removed.row.nb <- NULL +data1.removed.rows <- NULL +data2.removed.row.nb <- NULL +data2.removed.rows <- NULL +if(any(is.na(data1[, c(x1, y1)])) | any(is.infinite(data1[, x1])) | any(is.infinite(data1[, y1]))){ +tempo.na <- unlist(lapply(lapply(c(data1[c(x1, y1)]), FUN = is.na), FUN = which)) +tempo.inf <- unlist(lapply(lapply(c(data1[c(x1, y1)]), FUN = is.infinite), FUN = which)) +data1.removed.row.nb <- sort(unique(c(tempo.na, tempo.inf))) +if(length(data1.removed.row.nb) > 0){ +data1.removed.rows <- data1[data1.removed.row.nb, ] } -row.names(data) <- rownames.output.tables[1:length.rows] -}else if(rownames.kept == FALSE & all(class(data) %in% c("matrix", "table"))){ -rownames(data) <- rep("", nrow(data)) # identical row names allowed in matrices and tables +if(length(data1.removed.row.nb) == nrow(data1)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": AT LEAST ONE NA, NaN, -Inf OR Inf DETECTED IN EACH ROW OF data1. FUNCTION CANNOT BE USED ON EMPTY DATA FRAME\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -if(noquote == TRUE){ -utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite) +if(length(data1.removed.row.nb) > 0){ +data1 <- data1[-data1.removed.row.nb, ] +} +if(nrow(data1) == 0){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 1\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x1, y1), collapse = " "), " OF data1 AND CORRESPONDING ROWS REMOVED (SEE $data1.removed.row.nb AND $data1.removed.rows)") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) }else{ -utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NO NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x1, y1), collapse = " "), " OF data1. NO ROW REMOVED") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} +if( ! is.null(data2)){ +if(any(is.na(data2[, c(x2, y2)])) | any(is.infinite(data2[, x2])) | any(is.infinite(data2[, y2]))){ +tempo.na <- unlist(lapply(lapply(c(data2[c(x2, y2)]), FUN = is.na), FUN = which)) +tempo.inf <- unlist(lapply(lapply(c(data2[c(x2, y2)]), FUN = is.infinite), FUN = which)) +data2.removed.row.nb <- sort(unique(c(tempo.na, tempo.inf))) +if(length(data2.removed.row.nb) > 0){ +data2.removed.rows <- data2[data2.removed.row.nb, ] +} +if(length(data2.removed.row.nb) == nrow(data2)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": AT LEAST ONE NA, NaN, -Inf OR Inf DETECTED IN EACH ROW OF data2. FUNCTION CANNOT BE USED ON EMPTY DATA FRAME\n\n============\n\n") +stop(tempo.cat, call. = FALSE) +} +if(length(data2.removed.row.nb) > 0){ +data2 <- data2[-data2.removed.row.nb, ] } -}else if(is.vector(data) & all(class(data) != "list") & (length(data) == 1 | vector.cat == TRUE)){ -if(noquote == TRUE){ -cat(noquote(data), file= paste0(path, "/", output), append = no.overwrite) -}else{ -cat(data, file= paste0(path, "/", output), append = no.overwrite) +if(nrow(data2) == 0){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -}else{ # other (array, list, factor or vector with vector.cat = FALSE) -if(noquote == TRUE){ -utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite) +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x2, y2), collapse = " "), " OF data2 AND CORRESPONDING ROWS REMOVED (SEE $data2.removed.row.nb AND $data2.removed.rows)") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) }else{ -utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite) -} +warn.count <- warn.count + 1 +tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": NO NA, NaN, -Inf OR Inf DETECTED IN COLUMN ", paste(c(x2, y2), collapse = " "), " OF data2. NO ROW REMOVED") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +print(warn) } -sep.final <- paste0(rep("\n", sep), collapse = "") -write(sep.final, file= paste0(path, "/", output), append = TRUE) # add a sep } +# end na and Inf detection and removal (done now to be sure of the correct length of categ) +# row annotation (dot number) +# data1 <- data1[ ! duplicated(data1[, c(x1, y1)]), ] # do not remove the dots that have same x and y values, because they will have different dot number -> not the same position on the matrices (so true for symmetric matrices) +data1 <- cbind(data1, DOT_NB = 1:nrow(data1)) +if( ! is.null(data2)){ +# data2 <- data2[ ! duplicated(data2[, c(x2, y2)]), ] # do not remove the dots that have same x and y values, because they will have different dot number -> not the same position on the matrices (so true for symmetric matrices) +data2 <- cbind(data2, DOT_NB = 1:nrow(data2)) } +# end row annotation (dot number) -######## fun_get_message() #### return messages of an expression (that can be exported) -# Check OK: clear to go Apollo -fun_get_message <- function(data, kind = "error", header = TRUE, print.no = FALSE, text = NULL, env = NULL){ -# AIM -# evaluate an instruction written between "" and return the first of the error, or warning or standard (non error non warning) messages if ever exist -# using argument print.no = FALSE, return NULL if no message, which is convenient in some cases -# WARNING -# Only the first message is returned -# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_check() -# ARGUMENTS -# data: character string to evaluate -# kind: character string. Either "error" to get error messages, or "warning" to get warning messages, or "message" to get non error and non warning messages -# header: logical. Add a header in the returned message? -# print.no: logical. Print a message saying that no message reported? -# text: character string added to the output message (even if no message exists and print.no is TRUE). Inactivated if header is FALSE -# env: the name of an existing environment. NULL if not required -# RETURN -# the message or NULL if no message and print.no is FALSE -# EXAMPLES -# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "error", print.no = TRUE, text = "IN A") -# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "warning", print.no = TRUE, text = "IN A") -# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "message", print.no = TRUE, text = "IN A") -# fun_get_message(data = "wilcox.test()", kind = "error", print.no = TRUE, text = "IN A") -# fun_get_message(data = "sum(1)", kind = "error", print.no = TRUE, text = "IN A") -# fun_get_message(data = "message('ahah')", kind = "error", print.no = TRUE, text = "IN A") -# fun_get_message(data = "message('ahah')", kind = "message", print.no = TRUE, text = "IN A") -# fun_get_message(data = "ggplot2::ggplot(data = data.frame(X = 1:10), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()", kind = "message", print.no = TRUE, text = "IN FUNCTION 1") -# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; fun_get_message(data = 'fun_gg_boxplot(data = obs1, y = "Time", categ = "Group1")', kind = "message", print.no = TRUE, text = "IN FUNCTION 1") -# DEBUGGING -# data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging -# data = "sum(1)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging -# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; data = 'fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1")' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging -# data = "message('ahah')" ; kind = "error" ; header = TRUE ; print.no = TRUE ; text = "IN A" ; env = NULL -# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "message" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging -# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging -# function name -function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") -# end function name -# required function checking -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) -} -# end required function checking -# no need to use reserved words to avoid bugs, because it is local, and exists("tempo.warning", inherit = FALSE), never use the scope -# argument checking -# argument checking with fun_check() -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 = data, class = "character", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = kind, options = c("error", "warning", "message"), length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = print.no, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -tempo <- fun_check(data = header, class = "logical", length = 1, fun.name = function.name) ; eval(ee) -if( ! is.null(text)){ -tempo <- fun_check(data = text, class = "character", length = 1, fun.name = function.name) ; eval(ee) -} -if( ! is.null(env)){ -tempo <- fun_check(data = env, class = "environment", fun.name = function.name) ; eval(ee) # +# Method using x unit interval +# may be create vector of each column to increase speed +x.data1.l <- NULL # x coord of the y upper and lower limits defined on the data1 cloud for left step line +x.data1.r <- NULL # x coord of the y upper and lower limits defined on the data1 cloud for right step line +y.data1.down.limit.l <- NULL # lower limit of the data1 cloud for left step line +y.data1.top.limit.l <- NULL # upper limit of the data1 cloud for left step line +y.data1.down.limit.r <- NULL # lower limit of the data1 cloud for right step line +y.data1.top.limit.r <- NULL # upper limit of the data1 cloud for left step line +if(any(data1[, x1] %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 x1 COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -if(any(arg.check) == TRUE){ -stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # +x.range <- range(data1[, x1], 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(any(x.range %in% c(Inf, -Inf)))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED x.range CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } -# end argument checking with fun_check() -# 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 -# main code -pdf(file = NULL) # send plots into a NULL file, no pdf file created -window.nb <- dev.cur() -dev.set(window.nb) -# last warning cannot be used because suppressWarnings() does not modify last.warning present in the base evironment (created at first warning in a new R session), or warnings() # to reset the warning history : unlockBinding("last.warning", baseenv()) ; assign("last.warning", NULL, envir = baseenv()) -output <- NULL -tempo.error <- try(suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))), silent = TRUE) # get error message, not warning or messages -if(any(class(tempo.error) %in% c("gg", "ggplot"))){ -tempo.error <- try(suppressMessages(suppressWarnings(ggplot2::ggplot_build(tempo.error))), silent = TRUE)[1] +if(any(data1[, y1] %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 y1 COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -if(exists("tempo.error", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word -if( ! (all(class(tempo.error) == "try-error") & any(grepl(x = tempo.error, pattern = "^Error|^error|^ERROR")))){ # deal with NULL. Old code : if((length(tempo.error) > 0 & ! any(grepl(x = tempo.error, pattern = "^Error|^error|^ERROR"))) | (length(tempo.error) == 0) ){ but problem when tempo.error is a list but added this did not work: | ! all(class(tempo.error) == "character") -tempo.error <- NULL +y.range <- range(data1[, y1], 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(any(x.range %in% c(Inf, -Inf)))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED y.range CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } -}else{ -tempo.error <- NULL +x.range.plot <- range(data1[, x1], 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.range.plot <- range(data1[, y1], 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( ! is.null(data2)){ +if(any(data2[, x2] %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 x2 COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -if(kind == "error" & ! is.null(tempo.error)){ # -if(header == TRUE){ -tempo.error[1] <- gsub(x = tempo.error[1], pattern = "^Error i|^error i|^ERROR I", replacement = "I") -output <- paste0("ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.error[1]) # -}else{ -output <- tempo.error[1] # +x.range.plot <- range(data1[, x1], data2[, x2], 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(any(data2[, y2] %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 y2 COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE") +warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } -}else if(kind == "error" & is.null(tempo.error) & print.no == TRUE){ -output <- paste0("NO ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) -}else if(kind != "error" & ( ! is.null(tempo.error)) & print.no == TRUE){ -output <- paste0("NO ", ifelse(kind == "warning", "WARNING", "STANDARD (NON ERROR AND NON WARNING)"), " MESSAGE BECAUSE OF ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) -}else if(is.null(tempo.error)){ -fun.warning.capture <- function(expr){ -# from demo(error.catching) typed in the R console, coming from ?tryCatch -# see also http://mazamascience.com/WorkingWithData/?p=912 -# return a character string or NULL -# expr <- wilcox.test.default(c(1, 1, 3), c(1, 2, 4), paired = TRUE) -W <- NULL -w.handler <- function(w){ # warning handler -W <<- w # send to the above env, i.e., the inside of the fun.warning.capture function -invokeRestart("muffleWarning") # here w.handler() muffles all the warnings. See http://romainfrancois.blog.free.fr/index.php?post/2009/05/20/Disable-specific-warnings to muffle specific warnings and print others +y.range.plot <- range(data1[, y1], data2[, y2], 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 } -output <- list( -value = suppressMessages(withCallingHandlers(tryCatch(expr, error = function(e){e}), warning = w.handler)), # BEWARE: w.handler is a function written without (), like in other functions with FUN argument -warning = W # processed by w.handler() -) -return(if(is.null(output$warning)){NULL}else{as.character(output$warning)}) +if(suppressWarnings(any(x.range.plot %in% c(Inf, -Inf)))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED x.range.plot CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 (AND data2?) ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } -tempo.warn <- fun.warning.capture(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env})) -# warn.options.ini <- options()$warn ; options(warn = 1) ; tempo.warn <- utils::capture.output({tempo <- suppressMessages(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))}, type = "message") ; options(warn = warn.options.ini) # this recover warnings not messages and not errors but does not work in all enviroments -tempo.message <- utils::capture.output({ -tempo <- suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))) -if(any(class(tempo) %in% c("gg", "ggplot"))){ -tempo <- ggplot2::ggplot_build(tempo) -}else{ -tempo <- suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env})) +if(suppressWarnings(any(y.range.plot %in% c(Inf, -Inf)))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, " COMPUTED y.range.plot CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 (AND data2?) ARGUMENTS ARE NA OR Inf ONLY\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } -}, type = "message") # recover messages not warnings and not errors -if(kind == "warning" & ! is.null(tempo.warn)){ -if(length(tempo.warn) > 0){ # to avoid character(0) -if( ! any(sapply(tempo.warn, FUN = "grepl", pattern = "() FUNCTION:$"))){ -tempo.warn <- paste(unique(tempo.warn), collapse = "\n") # if FALSE, means that the tested data is a special function. If TRUE, means that the data is a standard function. In that case, the output of capture.output() is two strings per warning messages: if several warning messages -> identical first string, which is removed in next messages by unique() -}else{ -tempo.warn <- paste(tempo.warn, collapse = "\n") +if( ! is.null(x.range.split)){ +# data.frame ordering to slide the window from small to big values + sliding window definition +data1 <- data1[order(data1[, x1], na.last = TRUE), ] +if( ! is.null(data2)){ +data2 <- data2[order(data2[, x2], na.last = TRUE), ] } -if(header == TRUE){ -if(any(grepl(x = tempo.warn[[1]], pattern = "^simpleWarning i"))){ -tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I") +x.win.size <- abs(diff(x.range) / x.range.split) # in unit of x-axis +step <- x.win.size / x.step.factor +# end data.frame ordering to slide the window from small to big values + sliding window definition +# x-axis sliding and y-axis limits of the data1 cloud -> y significant data2 +loop.nb <- ceiling((diff(x.range) - x.win.size) / step) # x.win.size + n * step covers the x range if x.win.size + n * step >= diff(x.range), thus if n >= (diff(x.range) - x.win.size) / step +y.outside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are upper or lower than the frame +y.inside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are not upper or lower than the frame +y.data1.median <- median(data1[, y1], na.rm = TRUE) # will be used for sliding windows without data1 in it +if( ! is.null(data2)){ +y.outside.data2.dot.nb <- integer() # vector that will contain the selected 1D coordinates (i.e., dots) of data2 that are upper or lower than the data1 frame +y.inside.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are not upper or lower than the data1 frame +y.unknown.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are problematic: data2 dots outside of the range of data1, or data2 dots in a sliding window without data1 dots +# recover data2 dots outside the range of data1 +if(any(data2[, x2] < x.range[1])){ +y.unknown.data2.dot.nb <- c(y.unknown.data2.dot.nb, data2$DOT_NB[data2[, x2] < x.range[1]]) +#tempo.warn & indicate the interval } -if(any(grepl(x = tempo.warn[[1]], pattern = "^Warning i"))){ -tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I") +if(any(data2[, x2] > x.range[2])){ +y.unknown.data2.dot.nb <- c(y.unknown.data2.dot.nb, data2$DOT_NB[data2[, x2] > x.range[2]]) +#tempo.warn & indicate the interval } -output <- paste0("WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.warn) # -}else{ -output <- tempo.warn # +# end recover data2 dots outside the range of data1 } -}else if(print.no == TRUE){ -output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) +# loop.ini.time <- as.numeric(Sys.time()) +for(i1 in 0:(loop.nb + 1)){ +min.pos <- x.range[1] + step * i1 # lower position of the sliding window in data1 +max.pos <- min.pos + x.win.size # upper position of the sliding window in data1 +x.data1.l <- c(x.data1.l, min.pos, min.pos + step) # min.pos + step to make the steps +x.data1.r <- c(x.data1.r, max.pos, max.pos + step) # max.pos + step to make the steps +x.data1.dot.here <- data1[, x1] >= min.pos & data1[, x1] < max.pos # is there data1 dot present in the sliding window, considering the x axis? +if( ! is.null(data2)){ +x.data2.dot.here <- data2[, x2] >= min.pos & data2[, x2] < max.pos # is there data2 dot present in the sliding window, considering the x axis? } -}else if(kind == "warning" & is.null(tempo.warn) & print.no == TRUE){ -output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) -}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word -if(length(tempo.message) > 0){ # if something is returned by capture.ouptput() (only in this env) with a length more than 1 -if(header == TRUE){ -output <- paste0("STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.message) # +# recover the data1 dots outside the frame +if(any(x.data1.dot.here == TRUE)){ +tempo.y.data1.top.limit <- quantile(data1[x.data1.dot.here, y1], probs = 1 - error, na.rm = TRUE) +tempo.y.data1.down.limit <- quantile(data1[x.data1.dot.here, y1], probs = 0 + error, na.rm = TRUE) +y.data1.top.limit.l <- c(y.data1.top.limit.l, tempo.y.data1.top.limit, tempo.y.data1.top.limit) +y.data1.down.limit.l <- c(y.data1.down.limit.l, tempo.y.data1.down.limit, tempo.y.data1.down.limit) +y.data1.top.limit.r <- c(y.data1.top.limit.r, tempo.y.data1.top.limit, tempo.y.data1.top.limit) +y.data1.down.limit.r <- c(y.data1.down.limit.r, tempo.y.data1.down.limit, tempo.y.data1.down.limit) +y.data1.dot.signif <- ( ! ((data1[, y1] <= tempo.y.data1.top.limit) & (data1[, y1] >= tempo.y.data1.down.limit))) & x.data1.dot.here # is there data1 dot present in the sliding window, above or below the data1 limits, considering the y axis? +y.data1.dot.not.signif <- x.data1.dot.here & ! y.data1.dot.signif +y.outside.data1.dot.nb <- c(y.outside.data1.dot.nb, data1$DOT_NB[y.data1.dot.signif]) # recover the row number of data1 +y.outside.data1.dot.nb <- unique(y.outside.data1.dot.nb) +y.inside.data1.dot.nb <- c(y.inside.data1.dot.nb, data1$DOT_NB[y.data1.dot.not.signif]) +y.inside.data1.dot.nb <- unique(y.inside.data1.dot.nb) }else{ -output <- tempo.message # -} -}else if(print.no == TRUE){ -output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) -} -}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == FALSE & print.no == TRUE){ -output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) -} -} -invisible(dev.off(window.nb)) # end send plots into a NULL file -return(output) # do not use cat() because the idea is to reuse the message +y.data1.top.limit.l <- c(y.data1.top.limit.l, y.data1.median, y.data1.median) +y.data1.down.limit.l <- c(y.data1.down.limit.l, y.data1.median, y.data1.median) +y.data1.top.limit.r <- c(y.data1.top.limit.r, y.data1.median, y.data1.median) +y.data1.down.limit.r <- c(y.data1.down.limit.r, y.data1.median, y.data1.median) } +# end recover the data1 dots outside the frame +# recover the data2 dots outside the frame +if( ! is.null(data2)){ +if(any(x.data1.dot.here == TRUE) & any(x.data2.dot.here == TRUE)){ +y.data2.dot.signif <- ( ! ((data2[, y2] <= tempo.y.data1.top.limit) & (data2[, y2] >= tempo.y.data1.down.limit))) & x.data2.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the y axis? +y.data2.dot.not.signif <- x.data2.dot.here & ! y.data2.dot.signif +y.outside.data2.dot.nb <- c(y.outside.data2.dot.nb, data2$DOT_NB[y.data2.dot.signif]) +y.outside.data2.dot.nb <- unique(y.outside.data2.dot.nb) +y.inside.data2.dot.nb <- c(y.inside.data2.dot.nb, data2$DOT_NB[y.data2.dot.not.signif]) +y.inside.data2.dot.nb <- unique(y.inside.data2.dot.nb) +}else if(any(x.data1.dot.here == FALSE) & any(x.data2.dot.here == TRUE)){ # problem: data2 dots in the the window but no data1 dots to generates the quantiles +y.unknown.data2.dot.nb <- c(y.unknown.data2.dot.nb, data2$DOT_NB[x.data2.dot.here]) +y.unknown.data2.dot.nb <- unique(y.unknown.data2.dot.nb) +#tempo.warn & indicate the interval - - - - - - - - - - - - - - -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 = FALSE, -dot.tidy.bin.nb = 50, -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, -article = TRUE, -grid = FALSE, -return = FALSE, -plot = TRUE, -add = NULL, -warn.print = TRUE, -lib.path = NULL -){ -# AIM -# 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) -# Hinges are not computed like in the classical boxplot() function of R -# To have a single box, create a factor column with a single class and specify the name of this column in the 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 (i.e., as categ1, knowing that categ2 must also be specified in this situation). 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: dataframe containing one column of values (see y argument below) and one or two columns of categories (see categ argument below). Duplicated column names are not allowed -# y: character string of the data1 column name for y-axis (column containing numeric values). Numeric values will be split according to the classes of the column names indicated in the categ argument 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 be either 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: no empty classes allowed. To have a single box, create a factor column with a single class and specify the name of this column in the categ argument (here, 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 (i.e., as categ1, knowing that categ2 must also be specified in this situation) -# 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 color character 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 color character string for color of dots. -# If NULL, no dots plotted -# If "same", the dots will have the same colors as the respective boxplots -# Otherwise, colors will depend on the dot.categ argument. If dot.categ is NULL, then colors will be applied to each class of the last column name specified in categ. If dot.categ is non NULL, colors will be applied to each class of the column name specified in dot.categ. Color strings can be (1), (2) or (3) of categ.color argument, except that in the possibility (3), the rule "a single color per class of categ and a single class of categ per color", does not have to be respected (for instance, each dot can have a different color). See examples Put in example or leave here? -> Example: with categ = "Group1", dot.color = "red" and dot.categ = NULL, all the dots will be red, whatever the classes in Group1 column of data1, and no legend will be display for dots. With categ = c("Group1", "Group2"), dot.color = c("red", "blue") and dot.categ = NULL, the dots will be red for first class of Group2 and blue for the 2nd class of Group2, and no legend will be display for dots. With categ = c("Group1", "Group2"), dot.color = c("red", "blue") and dot.categ = "Group1", the dots will be red for first class of Group1 and blue for the 2nd class of Group1, and a legend will be display for dots -# dot.categ: optional single character string of a data1 column name (further refered to as categ3), which is associated to the dot.color argument to generate a legend for dots. If non NULL, then a legend will be created for the dots, in addition to the legend for the boxes. If NULL, no legend created and the colors of dot will depend on dot.color and categ arguments (see the explanation in dot.color) -# 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. BEWARE: change the true coordinates of dots that are aligned. Thus the gain in aestheticism is associated with a loss in precision that can be very important. If FALSE, dots are randomly spread, using the dot.jitter argument (see below) keeping the true dot coordinates -# 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. In other words, increase the number to have smaller dots. 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) -# 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 (i.e., main ticks) on the y-axis (n argument of the the cute::fun_scale() function). BEWARE: provide this number even if y.log is "log2" or "log10", which can be difficult to read (e.g., ..., 2^2, 2^2.5, 2^3, ...). If NULL and if y.log is "no", then the number of label values is set by ggplot2. If NULL and if y.log is "log2" or "log10", then the number of label values correspond to integer units between y.lim (e.g., ..., 2^1, 2^2, 2^3, ...) -# y.inter.tick.nb: number of desired secondary ticks between main ticks. Ignored if y.log is other than "no" (log scale plotted) -# 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 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 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) -# article: logical. If TRUE, use a article theme (article like). If FALSE, use a classic related ggplot theme. Use the add argument (add = "+ggplot2::theme_classic()" for the exact classic ggplot theme -# grid: logical. Draw horizontal lines in the background to better read the box values? Not considered if article == 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, facet, etc.). Ignored if NULL. -# BEWARE: (1) must start with "+" just after the simple or double opening quote (no space, end of line, carriage return, etc., allowed between the two characters), (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::". Example: "+ ggplot2::coord_flip() + ggplot2::theme_bw()" -# If the character string contains the "ggplot2::theme" string, then the article argument of fun_gg_boxplot() (see above) is ignored with a warning -# Handle the add 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. 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 (see below). if NULL, the function will use the R library default folders -# REQUIRED PACKAGES -# ggplot2 -# scales -# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION -# fun_comp_2d() -# fun_gg_just() -# fun_gg_palette() -# fun_name_change() -# fun_pack() -# fun_check() -# fun_round() -# fun_scale() -# RETURN -# a boxplot if plot argument is TRUE -# a list of the graph info if return argument is TRUE: -# $data: the initial data -# $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) -# $plot: the graphic box and dot coordinates -# $dots: dot coordinates -# $main.box: coordinates of boxes -# $median: median coordinates -# $sup.whisker: coordinates of top whiskers (y for base and y.end for extremities) -# $inf.whisker: coordinates of bottom whiskers (y for base and y.end for extremities) -# $sup.whisker.edge: coordinates of top whisker edges (x and xend) -# $inf.whisker.edge: coordinates of bottom whisker edges(x and xend) -# $mean: diamon mean coordinates (only if box.mean argument is TRUE) -# $stat.display.positive: coordinates of stat numbers when positive (only if stat.disp argument is TRUE) -# $stat.display.negative: coordinates of stat numbers when negative (only if stat.disp argument is TRUE) -# y.second.tick.positions: coordinates of secondary ticks (only if y.inter.tick.nb argument is non NULL or if y.log argument is different from "no") -# y.second.tick.values: values of secondary ticks. NULL except if y.inter.tick.nb argument is non NULL or if y.log argument is different from "no") -# $panel: the variable names used for the panels (NULL if no panels) -# $axes: the x-axis and y-axis info -# $warn: 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.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 = 50, 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, article = 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)) ; set.seed(NULL) ; obs1$Time[1:10] <- NA ; data1 = obs1 ; y = "Time" ; categ = c("Group1") ; categ.class.order = NULL ; 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 = "black" ; dot.categ = "Group1"; dot.categ.class.order = c("G", "H") ; dot.categ.legend.name = NULL ; dot.tidy = TRUE ; dot.tidy.bin.nb = 50 ; 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 ; article = 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)) ; set.seed(NULL) ; obs1$Time[1:10] <- NA ; 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 ; article = 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)) ; set.seed(NULL) ; 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 ; article = 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) +# tempo.warn <- paste0("FROM FUNCTION ", function.name, ": THE [", round(min.pos, 3), " ; ", round(max.pos, 3), "] INTERVAL DOES NOT CONTAIN data1 X VALUES BUT CONTAINS data2 X VALUES WHICH CANNOT BE EVALUATED.\nTHE CONCERNED data2 ROW NUMBERS ARE:\n", paste(which(x.data1.dot.here == FALSE & x.data2.dot.here == TRUE), collapse = "\n")) +# warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} +} +# end recover the data2 dots outside the frame +# if(any(i1 == seq(1, loop.nb, 500))){ +# loop.fin.time <- as.numeric(Sys.time()) # time of process end +# cat(paste0("COMPUTATION TIME OF LOOP ", i1, " / ", loop.nb, ": ", as.character(lubridate::seconds_to_period(round(loop.fin.time - loop.ini.time))), "\n")) +# } +} +if(max.pos < x.range[2]){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE SLIDING WINDOW HAS NOT REACHED THE MAX VALUE OF data1 ON THE X-AXIS: ", max.pos, " VERSUS ", x.range[2], "\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} +y.incon.data1.dot.nb.final <- unique(c(y.outside.data1.dot.nb[y.outside.data1.dot.nb %in% y.inside.data1.dot.nb], y.inside.data1.dot.nb[y.inside.data1.dot.nb %in% y.outside.data1.dot.nb])) # inconsistent dots: if a row number of y.inside.data1.dot.nb is present in y.outside.data1.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list +y.outside.data1.dot.nb.final <- y.outside.data1.dot.nb[ ! (y.outside.data1.dot.nb %in% y.incon.data1.dot.nb.final)] # inconsistent dots removed from the outside list +y.inside.data1.dot.nb.final <- y.inside.data1.dot.nb[ ! (y.inside.data1.dot.nb %in% y.incon.data1.dot.nb.final)] # inconsistent dots removed from the inside list +if( ! is.null(data2)){ +# if some unknown dots are also inside, and/or outside, they are put in the inside and/or outside. Ok, because then the intersection between inside and outside is treated -> inconsistent dots +tempo.unknown.out <- y.unknown.data2.dot.nb[y.unknown.data2.dot.nb %in% y.outside.data2.dot.nb] +y.outside.data2.dot.nb <- unique(c(y.outside.data2.dot.nb, tempo.unknown.out)) # if a row number of y.unknown.data2.dot.nb is present in y.outside.data2.dot.nb, it is put into outside +tempo.unknown.in <- y.unknown.data2.dot.nb[y.unknown.data2.dot.nb %in% y.inside.data2.dot.nb] +y.inside.data2.dot.nb <- unique(c(y.inside.data2.dot.nb, tempo.unknown.in)) # if a row number of y.unknown.data2.dot.nb is present in y.inside.data2.dot.nb, it is put into inside +y.unknown.data2.dot.nb.final <- y.unknown.data2.dot.nb[ ! (y.unknown.data2.dot.nb %in% c(y.outside.data2.dot.nb, y.inside.data2.dot.nb))] # then dots also in inside and outside are remove from unknown +y.incon.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb[y.outside.data2.dot.nb %in% y.inside.data2.dot.nb], y.inside.data2.dot.nb[y.inside.data2.dot.nb %in% y.outside.data2.dot.nb])) # inconsistent dots: if a row number of y.inside.data2.dot.nb is present in y.outside.data2.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list +y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb[ ! (y.outside.data2.dot.nb %in% y.incon.data2.dot.nb.final)] # inconsistent dots removed from the outside list +y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb[ ! (y.inside.data2.dot.nb %in% y.incon.data2.dot.nb.final)] # inconsistent dots removed from the inside list +} +# end x-axis sliding and y-axis limits of the data1 cloud -> y significant data2 } +# end Method using x unit interval + + + + +# Method using y unit interval +y.data1.d <- NULL # y coord of the x upper and lower limits defined on the data1 cloud for down step line +y.data1.t <- NULL # y coord of the x upper and lower limits defined on the data1 cloud for top step line +x.data1.left.limit.d <- NULL # left limit of the data1 cloud for down step line +x.data1.right.limit.d <- NULL # right limit of the data1 cloud for down step line +x.data1.left.limit.t <- NULL # left limit of the data1 cloud for top step line +x.data1.right.limit.t <- NULL # right limit of the data1 cloud for top step line +if( ! is.null(y.range.split)){ +# data.frame ordering to slide the window from small to big values + sliding window definition +data1 <- data1[order(data1[, y1], na.last = TRUE), ] +if( ! is.null(data2)){ +data2 <- data2[order(data2[, y2], na.last = TRUE), ] } -# end required function checking -# reserved words to avoid bugs (names of dataframe columns used in this function) -reserved.words <- c("categ.check", "categ.color", "dot.color", "dot.categ", "dot.max", "dot.min", "group", "PANEL", "group.check", "MEAN", "tempo.categ1", "tempo.categ2", "text.max.pos", "text.min.pos", "x", "x.y", "y", "y.check", "y_from.dot.max", "ymax", "tidy_group") -# end reserved words to avoid bugs (used in this function) -# argument primary 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) +y.win.size <- abs(diff(y.range) / y.range.split) # in unit of y-axis +step <- y.win.size / y.step.factor +# end data.frame ordering to slide the window from small to big values + sliding window definition +# y-axis sliding and x-axis limits of the data1 cloud -> x significant data2 +loop.nb <- ceiling((diff(y.range) - y.win.size) / step) # y.win.size + n * step covers the y range if y.win.size + n * step >= diff(y.range), thus if n >= (diff(y.range) - y.win.size) / step +x.outside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are upper or lower than the frame +x.inside.data1.dot.nb <- integer() # vector that will contain the selected rows numbers of data1 that are not upper or lower than the frame +x.data1.median <- median(data1[, x1], na.rm = TRUE) # will be used for sliding window without data1 in it +if( ! is.null(data2)){ +x.outside.data2.dot.nb <- integer() # vector that will contain the selected 1D coordinates (i.e., dots) of data2 that are upper or lower than the data1 frame +x.inside.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are not upper or lower than the data1 frame +x.unknown.data2.dot.nb <- integer() # vector that will contain the 1D coordinates (i.e., dots) of data2 that are problematic: data2 dots outside of the range of data1, or data2 dots in a sliding window without data1 dots +# recover data2 dots outside the range of data1 +if(any(data2[, y2] < y.range[1])){ +x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[data2[, y2] < y.range[1]]) } -if( ! is.null(categ.legend.name)){ -tempo <- fun_check(data = categ.legend.name, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) +if(any(data2[, y2] > y.range[2])){ +x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[data2[, y2] > y.range[2]]) } -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) +# end recover data2 dots outside the range of data1 +} +# loop.ini.time <- as.numeric(Sys.time()) +for(i1 in 0:(loop.nb + 1)){ +min.pos <- y.range[1] + step * i1 # lower position of the sliding window in data1 +max.pos <- min.pos + y.win.size # upper position of the sliding window in data1 +y.data1.d <- c(y.data1.d, min.pos, min.pos + step) # min.pos + step to make the steps +y.data1.t <- c(y.data1.t, max.pos, max.pos + step) # max.pos + step to make the steps +y.data1.dot.here <- data1[, y1] >= min.pos & data1[, y1] < max.pos # is there data1 dot present in the sliding window, considering the y axis? +if( ! is.null(data2)){ +y.data2.dot.here <- data2[, y2] >= min.pos & data2[, y2] < max.pos # is there data2 dot present in the sliding window, considering the y axis? +} +# recover the data1 dots outside the frame +if(any(y.data1.dot.here == TRUE)){ +tempo.x.data1.right.limit <- quantile(data1[y.data1.dot.here, x1], probs = 1 - error, na.rm = TRUE) +tempo.x.data1.left.limit <- quantile(data1[y.data1.dot.here, x1], probs = 0 + error, na.rm = TRUE) +x.data1.right.limit.d <- c(x.data1.right.limit.d, tempo.x.data1.right.limit, tempo.x.data1.right.limit) +x.data1.left.limit.d <- c(x.data1.left.limit.d, tempo.x.data1.left.limit, tempo.x.data1.left.limit) +x.data1.right.limit.t <- c(x.data1.right.limit.t, tempo.x.data1.right.limit, tempo.x.data1.right.limit) +x.data1.left.limit.t <- c(x.data1.left.limit.t, tempo.x.data1.left.limit, tempo.x.data1.left.limit) +x.data1.dot.signif <- ( ! ((data1[, x1] <= tempo.x.data1.right.limit) & (data1[, x1] >= tempo.x.data1.left.limit))) & y.data1.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the x axis? +x.data1.dot.not.signif <- y.data1.dot.here & ! x.data1.dot.signif +x.outside.data1.dot.nb <- c(x.outside.data1.dot.nb, data1$DOT_NB[x.data1.dot.signif]) # recover the row number of data1 +x.outside.data1.dot.nb <- unique(x.outside.data1.dot.nb) +x.inside.data1.dot.nb <- c(x.inside.data1.dot.nb, data1$DOT_NB[x.data1.dot.not.signif]) +x.inside.data1.dot.nb <- unique(x.inside.data1.dot.nb) +}else{ +x.data1.right.limit.d <- c(x.data1.right.limit.d, x.data1.median, x.data1.median) +x.data1.left.limit.d <- c(x.data1.left.limit.d, x.data1.median, x.data1.median) +x.data1.right.limit.t <- c(x.data1.right.limit.t, x.data1.median, x.data1.median) +x.data1.left.limit.t <- c(x.data1.left.limit.t, x.data1.median, x.data1.median) } +# end recover the data1 dots outside the frame +# recover the data2 dots outside the frame +if( ! is.null(data2)){ +if(any(y.data1.dot.here == TRUE) & any(y.data2.dot.here == TRUE)){ +x.data2.dot.signif <- ( ! ((data2[, x2] <= tempo.x.data1.right.limit) & (data2[, x2] >= tempo.x.data1.left.limit))) & y.data2.dot.here # is there data2 dot present in the sliding window, above or below the data1 limits, considering the x axis? +x.data2.dot.not.signif <- y.data2.dot.here & ! x.data2.dot.signif +x.outside.data2.dot.nb <- c(x.outside.data2.dot.nb, data2$DOT_NB[x.data2.dot.signif]) +x.outside.data2.dot.nb <- unique(x.outside.data2.dot.nb) +x.inside.data2.dot.nb <- c(x.inside.data2.dot.nb, data2$DOT_NB[x.data2.dot.not.signif]) +x.inside.data2.dot.nb <- unique(x.inside.data2.dot.nb) +}else if(any(y.data1.dot.here == FALSE) & any(y.data2.dot.here == TRUE)){ # recover the data2 dots outside the range of the data1 cloud +x.unknown.data2.dot.nb <- c(x.unknown.data2.dot.nb, data2$DOT_NB[y.data2.dot.here]) +x.unknown.data2.dot.nb <- unique(x.unknown.data2.dot.nb) + + + +# tempo.warn <- paste0("FROM FUNCTION ", function.name, ": THE [", round(min.pos, 3), " ; ", round(max.pos, 3), "] INTERVAL DOES NOT CONTAIN data1 Y VALUES BUT CONTAINS data2 Y VALUES WHICH CANNOT BE EVALUATED.\nTHE CONCERNED data2 ROW NUMBERS ARE:\n", paste(which(y.data1.dot.here == FALSE & y.data2.dot.here == TRUE), collapse = "\n")) +# warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) } } -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) +# end recover the data2 dots outside the frame +# if(any(i1 == seq(1, loop.nb, 500))){ +# loop.fin.time <- as.numeric(Sys.time()) # time of process end +# cat(paste0("COMPUTATION TIME OF LOOP ", i1, " / ", loop.nb, ": ", as.character(lubridate::seconds_to_period(round(loop.fin.time - loop.ini.time))), "\n")) +# } +} +if(max.pos < y.range[2]){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE SLIDING WINDOW HAS NOT REACHED THE MAX VALUE OF data1 ON THE Y-AXIS: ", max.pos, " VERSUS ", y.range[2], "\n\n================\n\n") +stop(tempo.cat, call. = FALSE) } +x.incon.data1.dot.nb.final <- unique(c(x.outside.data1.dot.nb[x.outside.data1.dot.nb %in% x.inside.data1.dot.nb], x.inside.data1.dot.nb[x.inside.data1.dot.nb %in% x.outside.data1.dot.nb])) # inconsistent dots: if a row number of x.inside.data1.dot.nb is present in x.outside.data1.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list +x.outside.data1.dot.nb.final <- x.outside.data1.dot.nb[ ! (x.outside.data1.dot.nb %in% x.incon.data1.dot.nb.final)] # inconsistent dots removed from the outside list +x.inside.data1.dot.nb.final <- x.inside.data1.dot.nb[ ! (x.inside.data1.dot.nb %in% x.incon.data1.dot.nb.final)] # inconsistent dots removed from the inside list +if( ! is.null(data2)){ +# if some unknown dots are also inside, and/or outside, they are put in the inside and/or outside. Ok, because then the intersection between inside and outside is treated -> inconsistent dots +tempo.unknown.out <- x.unknown.data2.dot.nb[x.unknown.data2.dot.nb %in% x.outside.data2.dot.nb] +x.outside.data2.dot.nb <- unique(c(x.outside.data2.dot.nb, tempo.unknown.out)) # if a row number of x.unknown.data2.dot.nb is present in x.outside.data2.dot.nb, it is put into outside +tempo.unknown.in <- x.unknown.data2.dot.nb[x.unknown.data2.dot.nb %in% x.inside.data2.dot.nb] +x.inside.data2.dot.nb <- unique(c(x.inside.data2.dot.nb, tempo.unknown.in)) # if a row number of x.unknown.data2.dot.nb is present in x.inside.data2.dot.nb, it is put into inside +x.unknown.data2.dot.nb.final <- x.unknown.data2.dot.nb[ ! (x.unknown.data2.dot.nb %in% c(x.outside.data2.dot.nb, x.inside.data2.dot.nb))] # then dots also in inside and outside are remove from unknown +x.incon.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb[x.outside.data2.dot.nb %in% x.inside.data2.dot.nb], x.inside.data2.dot.nb[x.inside.data2.dot.nb %in% x.outside.data2.dot.nb])) # inconsistent dots: if a row number of x.inside.data2.dot.nb is present in x.outside.data2.dot.nb (and vice versa), it means that during the sliding, a dot has been sometime inside, sometime outside -> removed from the outside list +x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb[ ! (x.outside.data2.dot.nb %in% x.incon.data2.dot.nb.final)] # inconsistent dots removed from the outside list +x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb[ ! (x.inside.data2.dot.nb %in% x.incon.data2.dot.nb.final)] # inconsistent dots removed from the inside list } +# end y-axis sliding and x-axis limits of the data1 cloud -> x significant data2 } -if( ! is.null(dot.categ)){ -tempo <- fun_check(data = dot.categ, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +# end Method using y unit interval + + + +# recovering the frame coordinates +hframe = rbind( +data.frame( +x = if(is.null(x.data1.l)){NULL}else{x.data1.l}, +y = if(is.null(x.data1.l)){NULL}else{y.data1.down.limit.l}, +kind = if(is.null(x.data1.l)){NULL}else{"down.frame1"} +), +data.frame( +x = if(is.null(x.data1.r)){NULL}else{x.data1.r}, +y = if(is.null(x.data1.r)){NULL}else{y.data1.down.limit.r}, +kind = if(is.null(x.data1.r)){NULL}else{"down.frame2"} +), +data.frame( +x = if(is.null(x.data1.l)){NULL}else{x.data1.l}, +y = if(is.null(x.data1.l)){NULL}else{y.data1.top.limit.l}, +kind = if(is.null(x.data1.l)){NULL}else{"top.frame1"} +), +data.frame( +x = if(is.null(x.data1.r)){NULL}else{x.data1.r}, +y = if(is.null(x.data1.r)){NULL}else{y.data1.top.limit.r}, +kind = if(is.null(x.data1.r)){NULL}else{"top.frame2"} +) +) +vframe = rbind( +data.frame( +x = if(is.null(y.data1.d)){NULL}else{x.data1.left.limit.d}, +y = if(is.null(y.data1.d)){NULL}else{y.data1.d}, +kind = if(is.null(y.data1.d)){NULL}else{"left.frame1"} +), +data.frame( +x = if(is.null(y.data1.t)){NULL}else{x.data1.left.limit.t}, +y = if(is.null(y.data1.t)){NULL}else{y.data1.t}, +kind = if(is.null(y.data1.t)){NULL}else{"left.frame2"} +), +data.frame( +x = if(is.null(y.data1.d)){NULL}else{x.data1.right.limit.d}, +y = if(is.null(y.data1.d)){NULL}else{y.data1.d}, +kind = if(is.null(y.data1.d)){NULL}else{"right.frame1"} +), +data.frame( +x = if(is.null(y.data1.t)){NULL}else{x.data1.right.limit.t}, +y = if(is.null(y.data1.t)){NULL}else{y.data1.t}, +kind = if(is.null(y.data1.t)){NULL}else{"right.frame2"} +) +) +# end recovering the frame coordinates +# recovering the dot coordinates +data1.signif.dot <- NULL +data1.non.signif.dot <- NULL +data1.incon.dot <- NULL +data2.signif.dot <- NULL +data2.non.signif.dot <- NULL +data2.unknown.dot <- NULL +data2.incon.dot <- NULL +if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){ +# inconsistent dots recovery +if(length(unique(c(x.incon.data1.dot.nb.final, y.incon.data1.dot.nb.final))) > 0){ +data1.incon.dot <- data1[data1$DOT_NB %in% unique(c(x.incon.data1.dot.nb.final, y.incon.data1.dot.nb.final)), ] # if a dot in inconsistent in x or y -> classified as inconsistent (so unique() used) +# removal of the inconsistent dot in the other classifications +x.inside.data1.dot.nb.final <- x.inside.data1.dot.nb.final[ ! x.inside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] +y.inside.data1.dot.nb.final <- y.inside.data1.dot.nb.final[ ! y.inside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] +x.outside.data1.dot.nb.final <- x.outside.data1.dot.nb.final[ ! x.outside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] +y.outside.data1.dot.nb.final <- y.outside.data1.dot.nb.final[ ! y.outside.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] +x.unknown.data1.dot.nb.final <- x.unknown.data1.dot.nb.final[ ! x.unknown.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] +y.unknown.data1.dot.nb.final <- y.unknown.data1.dot.nb.final[ ! y.unknown.data1.dot.nb.final %in% data1.incon.dot$DOT_NB] +# end removal of the inconsistent dot in the other classifications +} +if( ! is.null(data2)){ +if(length(unique(c(x.incon.data2.dot.nb.final, y.incon.data2.dot.nb.final))) > 0){ +data2.incon.dot <- data2[data2$DOT_NB %in% unique(c(x.incon.data2.dot.nb.final, y.incon.data2.dot.nb.final)), ] +# removal of the inconsistent dot in the other classifications +x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] +y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] +x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] +y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] +x.unknown.data2.dot.nb.final <- x.unknown.data2.dot.nb.final[ ! x.unknown.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] +y.unknown.data2.dot.nb.final <- y.unknown.data2.dot.nb.final[ ! y.unknown.data2.dot.nb.final %in% data2.incon.dot$DOT_NB] +# end removal of the inconsistent dot in the other classifications +} +} +# end inconsistent dots recovery +# unknown dots recovery +if( ! is.null(data2)){ +if(data2.pb.dot == "signif"){ +x.outside.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) +x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% x.unknown.data2.dot.nb.final] # remove x.unknown.data2.dot.nb.final from x.inside.data2.dot.nb.final +y.outside.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) +y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% y.unknown.data2.dot.nb.final] # remove y.unknown.data2.dot.nb.final from y.inside.data2.dot.nb.final +x.unknown.data2.dot.nb.final <- NULL +y.unknown.data2.dot.nb.final <- NULL +data2.unknown.dot <- NULL +}else if(data2.pb.dot == "not.signif"){ +x.inside.data2.dot.nb.final <- unique(c(x.inside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) +x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% x.unknown.data2.dot.nb.final] # remove x.unknown.data2.dot.nb.final from x.outside.data2.dot.nb.final +y.inside.data2.dot.nb.final <- unique(c(y.inside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) +y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% y.unknown.data2.dot.nb.final] # remove y.unknown.data2.dot.nb.final from y.outside.data2.dot.nb.final +x.unknown.data2.dot.nb.final <- NULL +y.unknown.data2.dot.nb.final <- NULL +data2.unknown.dot <- NULL +}else if(data2.pb.dot == "unknown"){ +if(length(unique(c(x.unknown.data2.dot.nb.final, y.unknown.data2.dot.nb.final))) > 0){ +data2.unknown.dot <- data2[data2$DOT_NB %in% unique(c(x.unknown.data2.dot.nb.final, y.unknown.data2.dot.nb.final)), ] # if a dot in unknown in x or y -> classified as unknown (so unique() used) +x.outside.data2.dot.nb.final <- x.outside.data2.dot.nb.final[ ! x.outside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove x.unknown.data2.dot.nb.final from x.outside.data2.dot.nb.final +x.inside.data2.dot.nb.final <- x.inside.data2.dot.nb.final[ ! x.inside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove x.unknown.data2.dot.nb.final from x.inside.data2.dot.nb.final +y.outside.data2.dot.nb.final <- y.outside.data2.dot.nb.final[ ! y.outside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove y.unknown.data2.dot.nb.final from y.outside.data2.dot.nb.final +y.inside.data2.dot.nb.final <- y.inside.data2.dot.nb.final[ ! y.inside.data2.dot.nb.final %in% data2.unknown.dot$DOT_NB] # remove y.unknown.data2.dot.nb.final from y.inside.data2.dot.nb.final } -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) +}else{ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 3\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -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) +# end unknown dots recovery +# sign and non sign dot recovery +if(xy.cross.kind == "|"){ # here the problem is to deal with significant dots depending on x and y. Thus I start with that, recover dots finally non significant in outside and put them in inside (when &), and remove from inside the dots in outside +if(length(unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final))) > 0){ +tempo.outside <- unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final)) # union so unique() used +tempo.inside <- unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)) +tempo.inside <- tempo.inside[ ! tempo.inside %in% tempo.outside] +data1.signif.dot <- data1[data1$DOT_NB %in% tempo.outside, ] +data1.non.signif.dot <- data1[data1$DOT_NB %in% tempo.inside, ] +}else{ +data1.non.signif.dot <- data1[unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it } +}else if(xy.cross.kind == "&"){ +if(sum(x.outside.data1.dot.nb.final %in% y.outside.data1.dot.nb.final) > 0){ # that is intersection +tempo.outside <- unique(x.outside.data1.dot.nb.final[x.outside.data1.dot.nb.final %in% y.outside.data1.dot.nb.final]) # intersection +tempo.outside.removed <- unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final))[ ! unique(c(x.outside.data1.dot.nb.final, y.outside.data1.dot.nb.final)) %in% tempo.outside] +tempo.inside <- unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)) +data1.signif.dot <- data1[data1$DOT_NB %in% tempo.outside, ] +data1.non.signif.dot <- data1[data1$DOT_NB %in% tempo.inside, ] +}else{ +data1.non.signif.dot <- data1[unique(c(x.inside.data1.dot.nb.final, y.inside.data1.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it } -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) +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 4\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } +if( ! is.null(data2)){ +if(xy.cross.kind == "|"){ # here the problem is to deal with significant dots depending on x and y. Thus I start with that, recover dots finally non significant in outside and put them in inside (when &), and remove from inside the dots in outside +if(length(unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final))) > 0){ +tempo.outside <- unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final)) # union so unique() used +tempo.inside <- unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)) +tempo.inside <- tempo.inside[ ! tempo.inside %in% tempo.outside] +data2.signif.dot <- data2[data2$DOT_NB %in% tempo.outside, ] +data2.non.signif.dot <- data2[data2$DOT_NB %in% tempo.inside, ] +}else{ +data2.non.signif.dot <- data2[unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it } -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 if(xy.cross.kind == "&"){ +if(sum(x.outside.data2.dot.nb.final %in% y.outside.data2.dot.nb.final) > 0){ # that is intersection +tempo.outside <- unique(x.outside.data2.dot.nb.final[x.outside.data2.dot.nb.final %in% y.outside.data2.dot.nb.final]) # intersection +tempo.outside.removed <- unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final))[ ! unique(c(x.outside.data2.dot.nb.final, y.outside.data2.dot.nb.final)) %in% tempo.outside] +tempo.inside <- unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)) +data2.signif.dot <- data2[data2$DOT_NB %in% tempo.outside, ] +data2.non.signif.dot <- data2[data2$DOT_NB %in% tempo.inside, ] }else{ -tempo <- fun_check(data = y.lab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee) +data2.non.signif.dot <- data2[unique(c(x.inside.data2.dot.nb.final, y.inside.data2.dot.nb.final)), ] # if no outside dots, I recover all the inside dots and that's it } +}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(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) } +# end sign and non sign dot recovery +}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){ +# inconsistent dots recovery +if(length(y.incon.data1.dot.nb.final) > 0){ +data1.incon.dot <- data1[data1$DOT_NB %in% y.incon.data1.dot.nb.final, ] } -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(data2)){ +if(length(y.incon.data2.dot.nb.final) > 0){ +data2.incon.dot <- data2[data2$DOT_NB %in% y.incon.data2.dot.nb.final, ] } +}# end inconsistent dots recovery +# unknown dots recovery +if( ! is.null(data2)){ +if(data2.pb.dot == "signif"){ +y.outside.data2.dot.nb.final <- unique(c(y.outside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) +}else if(data2.pb.dot == "not.signif"){ +y.inside.data2.dot.nb.final <- unique(c(y.inside.data2.dot.nb.final, y.unknown.data2.dot.nb.final)) +}else if(data2.pb.dot == "unknown"){ +if(length(y.unknown.data2.dot.nb.final) > 0){ +data2.unknown.dot <- data2[data2$DOT_NB %in% y.unknown.data2.dot.nb.final, ] } -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) +}else{ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } } -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) +# end unknown dots recovery +# sign and non sign dot recovery +if(length(y.outside.data1.dot.nb.final) > 0){ +data1.signif.dot <- data1[data1$DOT_NB %in% y.outside.data1.dot.nb.final, ] } -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 = article, 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) +if(length(y.inside.data1.dot.nb.final) > 0){ +data1.non.signif.dot <- data1[data1$DOT_NB %in% y.inside.data1.dot.nb.final, ] } +if( ! is.null(data2)){ +if(length(y.outside.data2.dot.nb.final) > 0){ +data2.signif.dot <- data2[data2$DOT_NB %in% y.outside.data2.dot.nb.final, ] } -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){ -if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA -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(length(y.inside.data2.dot.nb.final) > 0){ +data2.non.signif.dot <- data2[data2$DOT_NB %in% y.inside.data2.dot.nb.final, ] } } +# end sign and non sign dot recovery +}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){ +# inconsistent dots recovery +if(length(x.incon.data1.dot.nb.final) > 0){ +data1.incon.dot <- data1[data1$DOT_NB %in% x.incon.data1.dot.nb.final, ] } -if(any(arg.check) == TRUE){ -stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # +if( ! is.null(data2)){ +if(length(x.incon.data2.dot.nb.final) > 0){ +data2.incon.dot <- data2[data2$DOT_NB %in% x.incon.data2.dot.nb.final, ] } -# 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 primary 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) +}# end inconsistent dots recovery +# unknown dots recovery +if( ! is.null(data2)){ +if(data2.pb.dot == "signif"){ +x.outside.data2.dot.nb.final <- unique(c(x.outside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) +}else if(data2.pb.dot == "not.signif"){ +x.inside.data2.dot.nb.final <- unique(c(x.inside.data2.dot.nb.final, x.unknown.data2.dot.nb.final)) +}else if(data2.pb.dot == "unknown"){ +if(length(x.unknown.data2.dot.nb.final) > 0){ +data2.unknown.dot <- data2[data2$DOT_NB %in% x.unknown.data2.dot.nb.final, ] } -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) +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 7\n\n============\n\n") +stop(tempo.cat, 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") +# end unknown dots recovery +# sign and non sign dot recovery +if(length(x.outside.data1.dot.nb.final) > 0){ +data1.signif.dot <- data1[data1$DOT_NB %in% x.outside.data1.dot.nb.final, ] } +if(length(x.inside.data1.dot.nb.final) > 0){ +data1.non.signif.dot <- data1[data1$DOT_NB %in% x.inside.data1.dot.nb.final, ] } -tempo.output <- fun_name_change(names(data1), reserved.words) -for(i2 in 1:length(tempo.output$ini)){ # a loop to be sure to take the good ones -names(data1)[names(data1) == tempo.output$ini[i2]] <- tempo.output$post[i2] -if(any(y == tempo.output$ini[i2])){ -y[y == tempo.output$ini[i2]] <- tempo.output$post[i2] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN y ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i2], " HAS BEEN REPLACED BY ", tempo.output$post[i2], "\nBECAUSE RISK OF BUG AS SOME NAMES IN y ARGUMENT ARE RESERVED WORD USED BY THE ", function.name, " FUNCTION") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +if( ! is.null(data2)){ +if(length(x.outside.data2.dot.nb.final) > 0){ +data2.signif.dot <- data2[data2$DOT_NB %in% x.outside.data2.dot.nb.final, ] } -# BEWARE: names of y argument potentially replaced -if(any(categ == tempo.output$ini[i2])){ -categ[categ == tempo.output$ini[i2]] <- tempo.output$post[i2] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN categ ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i2], " HAS BEEN REPLACED BY ", tempo.output$post[i2], "\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(length(x.inside.data2.dot.nb.final) > 0){ +data2.non.signif.dot <- data2[data2$DOT_NB %in% x.inside.data2.dot.nb.final, ] } -# BEWARE: names of categ argument potentially replaced -if( ! is.null(dot.categ)){ -if(any(dot.categ == tempo.output$ini[i2])){ -dot.categ[dot.categ == tempo.output$ini[i2]] <- tempo.output$post[i2] -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN dot.categ ARGUMENT (COLUMN NAMES OF data1 ARGUMENT),\n", tempo.output$ini[i2], " HAS BEEN REPLACED BY ", tempo.output$post[i2], "\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 sign and non sign dot recovery } -# BEWARE: names of dot.categ argument potentially replaced +# end recovering the dot coordinates +# verif +if(any(data1.signif.dot$DOT_NB %in% data1.non.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", FUNCTION.NAME, ": CODE INCONSISTENCY 8\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -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))) -if( ! (is.null(add) | is.null(tempo.output$ini))){ -if(grepl(x = add, pattern = paste(tempo.output$ini, collapse = "|"))){ -tempo.cat <- paste0("ERROR IN ", function.name, ": DETECTION OF COLUMN NAMES OF data1 IN THE add ARGUMENT STRING, THAT CORRESPOND TO RESERVED STRINGS FOR ", function.name, "\nCOLUMN NAMES HAVE TO BE CHANGED\nTHE PROBLEMATIC COLUMN NAMES ARE SOME OF THESE NAMES:\n", paste(tempo.output$ini, collapse = " "), "\nIN THE DATA FRAME OF data1 AND IN THE STRING OF add ARGUMENT, TRY TO REPLACE NAMES BY:\n", paste(tempo.output$post, collapse = " "), "\n\nFOR INFORMATION, THE RESERVED WORDS ARE:\n", paste(reserved.words, collapse = "\n")) -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +if(any(data1.non.signif.dot$DOT_NB %in% data1.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", FUNCTION.NAME, ": CODE INCONSISTENCY 9\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } +if(any(data1.signif.dot$DOT_NB %in% data1.incon.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 10\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } +if(any(data1.incon.dot$DOT_NB %in% data1.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 11\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -# end reserved word checking -# management of add containing facet -facet.categ <- NULL -if( ! is.null(add)){ -facet.check <- TRUE -tempo <- unlist(strsplit(x = add, split = "\\+")) # -if(any(grepl(x = tempo, pattern = "ggplot2::facet_wrap"))){ -tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_wrap")]))) -facet.categ <- names(tempo1$params$facets) -tempo.text <- "facet_wrap" -facet.check <- FALSE -}else if(grepl(x = add, pattern = "ggplot2::facet_grid")){ -tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_grid")]))) -facet.categ <- c(names(tempo1$params$rows), names(tempo1$params$cols)) -tempo.text <- "facet_grid" -facet.check <- FALSE +if(any(data1.non.signif.dot$DOT_NB %in% data1.incon.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 12\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -if(facet.check == FALSE & ! all(facet.categ %in% names(data1))){ # BEWARE: all(facet.categ %in% names(data1)) is TRUE when facet.categ is NULL -tempo.cat <- paste0("ERROR IN ", function.name, ": DETECTION OF \"", tempo.text, "\" STRING IN THE add ARGUMENT BUT PROBLEM OF VARIABLE DETECTION (COLUMN NAMES OF data1)\nTHE DETECTED VARIABLES ARE:\n", paste(facet.categ, collapse = " "), "\nTHE data1 COLUMN NAMES ARE:\n", paste(names(data1), collapse = " "), "\nPLEASE REWRITE THE add STRING AND RERUN") -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +if(any(data1.incon.dot$DOT_NB %in% data1.non.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 13\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } +if( ! is.null(data2)){ +if(any(data2.signif.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 14\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -# end management of add containing facet -# 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))) +if(any(data2.non.signif.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 15\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -data1[, categ[i1]] <- factor(data1[, categ[i1]]) # if already a factor, change nothing, if characters, levels according to alphabetical order +if(any(data2.signif.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 16\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -# 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[i3]])), 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(data2.unknown.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 17\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -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 - +if(any(data2.signif.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 18\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -names(categ.class.order)[i3] <- categ[i3] +if(any(data2.incon.dot$DOT_NB %in% data2.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 19\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } +if(any(data2.non.signif.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 20\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -}else{ -categ.class.order <- vector("list", length = length(categ)) -tempo.categ.class.order <- NULL -for(i2 in 1:length(categ.class.order)){ -categ.class.order[[i2]] <- levels(data1[, categ[i2]]) -names(categ.class.order)[i2] <- categ[i2] -tempo.categ.class.order <- c(tempo.categ.class.order, ifelse(i2 != 1, "\n", ""), categ.class.order[[i2]]) +if(any(data2.unknown.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 21\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") THE categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR BOX ORDERING:\n", paste(tempo.categ.class.order, collapse = " ")) -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +if(any(data2.non.signif.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 22\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -# categ.class.order not NULL anymore (list) -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 +if(any(data2.incon.dot$DOT_NB %in% data2.non.signif.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 23\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -# categ.legend.name not NULL anymore (character string) -# 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] +if(any(data2.unknown.dot$DOT_NB %in% data2.incon.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 24\n\n============\n\n") +stop(tempo.cat, call. = FALSE) } -# 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(data2.incon.dot$DOT_NB %in% data2.unknown.dot$DOT_NB)){ +tempo.cat <- paste0("\n\n============\n\nERROR IN ", function.name, ": CODE INCONSISTENCY 25\n\n============\n\n") +stop(tempo.cat, 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 -categ.len <- 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[categ.len]]))){ # here length(categ.color) is equal to the different number of categ -# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor -data1 <- data.frame(data1, categ.color = data1[, categ[categ.len]]) -data1$categ.color <- factor(data1$categ.color, labels = categ.color) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN ", categ[categ.len], " OF categ ARGUMENT, THE FOLLOWING COLORS:\n", paste(categ.color, collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[, categ[categ.len]])), collapse = " ")) -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -}else if(length(categ.color) == length(data1[, categ[categ.len]])){# 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[categ.len]]))) -data1 <- data.frame(data1, categ.color = categ.color) -tempo.check <- unique(data1[ , c(categ[categ.len], "categ.color")]) -if( ! (nrow(tempo.check) == length(unique(categ.color)) & nrow(tempo.check) == length(unique(data1[ , categ[categ.len]])))){ -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[categ.len], ":\n", paste(unique(mapply(FUN = "paste", data1[ ,categ[categ.len]], data1[ ,"categ.color"])), collapse = "\n")) -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +# end verif +# plot +# recovering the axes data whatever plot or not +if(is.null(data2)){ +axes <- fun_gg_scatter(data1 = list(data1), x = list(x1), y = list(y1), categ = list(NULL), color = list(fun_gg_palette(2)[2]), geom = list("geom_point"), alpha = list(0.5), x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, plot = FALSE, return = TRUE)$axes }else{ -# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor -categ.color <- unique(data1$categ.color[order(data1[, categ[categ.len]])]) # Modif to have length(categ.color) equal to the different number of categ (length(categ.color) == length(levels(data1[, categ[categ.len]]))) -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[categ.len], " AS:\n", paste(levels(factor(data1[, categ[categ.len]])), collapse = " "), "\n", paste(categ.color, collapse = " ")) -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +axes <- fun_gg_scatter(data1 = list(data1, data2), x = list(x1, x2), y = list(y1, y2), categ = list(NULL, NULL), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1]), geom = list("geom_point", "geom_point"), alpha = list(0.5, 0.5), x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, plot = FALSE, return = TRUE)$axes } -}else if(length(categ.color) == 1){ -# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # 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[categ.len]]))) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") categ.color ARGUMENT HAS LENGTH 1, MEANING THAT ALL THE DIFFERENT CLASSES OF ", categ[categ.len], "\n", paste(levels(factor(data1[, categ[categ.len]])), 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[categ.len], " COLUMN. HERE IT IS COLOR LENGTH ", length(categ.color), " VERSUS CATEG LENGTH ", length(data1[, categ[categ.len]]), " AND CATEG CLASS LENGTH ", length(unique(data1[, categ[categ.len]])), "\nPRESENCE OF NA COULD BE THE PROBLEM") -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +# end recovering the axes data whatever plot or not +if(plot == TRUE){ +# add a categ for plot legend +tempo.df.name <- c("data1", "data1.signif.dot", "data1.incon.dot", "data2", "data2.signif.dot", "data2.unknown.dot", "data2.incon.dot") +tempo.class.name <- c("data1", "data1", "data1", "data2", "data2", "data2", "data2") +for(i2 in 1:length(tempo.df.name)){ +if( ! is.null(get(tempo.df.name[i2]))){ +assign(tempo.df.name[i2], data.frame(get(tempo.df.name[i2]), kind = tempo.class.name[i2])) } -}else{ -categ.len <- length(categ) # if only categ1, then colors for classes of categ1, if length(categ) == 2, then colors for classes of categ2 -# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor -categ.color <- fun_gg_palette(length(levels(data1[, categ[categ.len]]))) -data1 <- data.frame(data1, categ.color = data1[, categ[categ.len]]) -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[categ.len], " IN data1:\n", paste(categ.color, collapse = " "), "\n", paste(levels(data1[, categ[categ.len]]), 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. Do not use dot.categ %in% categ[length(categ)] -> error -# 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) +# end add a categ for plot legend +if(( ! is.null(x.range.split)) & ( ! is.null(y.range.split))){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = 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) +tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe), x = list(x1, "x", "x"), y = list(y1, "y", "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -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 (", ini.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 +if( ! is.null(data1.signif.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.signif.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } }else{ -if(all(dot.color == "same") & length(dot.color) == 1){ -dot.categ.class.order <- unlist(categ.class.order[length(categ)]) -data1[, dot.categ] <- factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") THE dot.categ.class.order SETTING IS NULL AND dot.color IS \"same\". ORDER OF categ.class.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))) -}else{ -dot.categ.class.order <- sort(levels(data1[, dot.categ])) -data1[, dot.categ] <- factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor -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))) +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS") } -# dot.categ.class.order not NULL anymore (character string) if dot.categ is not NULL -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( ! is.null(data1.incon.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, vframe, data1.incon.dot), x = list(x1, "x", "x", x1), y = list(y1, "y", "y", y1), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME" , "VERT FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -for(i3 in 1:length(categ)){ -if(identical(categ[i3], ini.dot.categ) & ! identical(unlist(categ.class.order[i3]), dot.categ.class.order) & identical(sort(unlist(categ.class.order[i3])), sort(dot.categ.class.order))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") THE dot.categ ARGUMENT SETTING IS PRESENT IN THE categ ARGUMENT SETTING, BUT ORDER OF THE CLASSES IS NOT THE SAME:\ncateg.class.order: ", paste(unlist(categ.class.order[i3]), 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))) +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS") } -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 -> ", dot.categ.legend.name, " WILL BE USED AS LEGEND TITLE OF DOTS") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +if( ! is.null(data2)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -# dot.categ.legend.name not NULL anymore (character string) -}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))) +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe , vframe), x = list(x1, x2, "x", "x"), y = list(y1, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -# But dot.categ.class.order will be converted to NULL below (not now) +if( ! is.null(data2.signif.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -# 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] +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -# 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) +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = 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))) +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS") } -# 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)) +if( ! is.null(data2.incon.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -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.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -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))) +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -# 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{ -categ.len <- 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[categ.len]]))){ # here length(dot.color) is equal to the different number of categ -# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # not required because sure that is is a factor -data1 <- data.frame(data1, dot.color = data1[, categ[categ.len]]) -data1$dot.color <- factor(data1$dot.color, labels = dot.color) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN ", categ[categ.len], " OF categ ARGUMENT, THE FOLLOWING COLORS:\n", paste(dot.color, collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[, categ[categ.len]])), collapse = " ")) -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -}else if(length(dot.color) == length(data1[, categ[categ.len]])){# 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[categ.len]]))) -data1 <- data.frame(data1, dot.color = dot.color) -}else if(length(dot.color) == 1 & ! all(dot.color == "same")){ -# data1[, categ[categ.len]] <- factor(data1[, categ[categ.len]]) # 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[categ.len]]))) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") dot.color ARGUMENT HAS LENGTH 1, MEANING THAT ALL THE DIFFERENT CLASSES OF ", categ[categ.len], "\n", paste(levels(factor(data1[, categ[categ.len]])), 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[categ.len], " COLUMN. HERE IT IS COLOR LENGTH ", length(dot.color), " VERSUS CATEG LENGTH ", length(data1[, categ[categ.len]]), " AND CATEG CLASS LENGTH ", length(unique(data1[, categ[categ.len]])), "\nPRESENCE OF NA COULD BE THE PROBLEM") -stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS") } -# 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 +if( ! is.null(data2.unknown.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -# 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))) +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe , vframe), x = list(x1, x2, x2, "x", "x"), y = list(y1, y2, y2, "y", "y"), categ = list("kind", "kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "HORIZ FRAME" , "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) + +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$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 -if(is.null(dot.categ)){ -dot.categ.class.order <- NULL # because not used anyway +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -# dot.categ.class.order either NULL if dot.categ is NULL (no legend displayed) or character string (potentially representing the diff classes of dot.categ) -# 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))) +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 12, title = "DATA2 + DATA2 UNKNOWN DOTS") } -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] +}else if(( ! is.null(x.range.split)) & is.null(y.range.split)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -# end integer colors into gg_palette +tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe), x = list(x1, "x"), y = list(y1, "y"), categ = list("kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -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 y.log 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(data1.signif.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = 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))) +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS") } -# 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"}, if( ! is.null(dot.color) & ! is.null(dot.categ)){if(dot.categ != ini.dot.categ){dot.categ}}, if( ! is.null(facet.categ)){facet.categ}) # dot.categ because can be a 3rd column of data1 -if(any(is.na(data1[, column.check]))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") NA DETECTED IN COLUMNS ", paste(column.check, collapse = " "), " OF data1 AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -for(i2 in 1:length(column.check)){ -if(any(is.na(data1[, column.check[i2]]))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") NA REMOVAL DUE TO COLUMN ", column.check[i2], " OF data1") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +if( ! is.null(data1.incon.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +tempo.graph <- fun_gg_scatter(data1 = list(data1, hframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "HORIZ FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +} +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS") } -removed.row.nb <- unlist(lapply(lapply(c(data1[column.check]), FUN = is.na), FUN = which)) -removed.rows <- data1[removed.row.nb, ] -column.check <- column.check[ ! column.check == y] # remove y to keep quali columns -if(length(removed.row.nb) != 0){ -data1 <- data1[-removed.row.nb, ] -for(i3 in 1:length(column.check)){ -if(any( ! unique(removed.rows[, column.check[i3]]) %in% unique(data1[, column.check[i3]]))){ -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") IN COLUMN ", column.check[i3], " OF data1, THE FOLLOWING CLASSES HAVE DISAPPEARED AFTER NA REMOVAL (IF COLUMN USED IN THE PLOT, THIS CLASS WILL NOT BE DISPLAYED):\n", paste(unique(removed.rows[, column.check[i3]])[ ! unique(removed.rows[, column.check[i3]]) %in% unique(data1[, column.check[i3]])], collapse = " ")) -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +if( ! is.null(data2)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, hframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } +if( ! is.null(data2.signif.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -count.categ <- 0 -for(i2 in 1:length(column.check)){ -if(column.check[i2] %in% categ){ -count.categ <- count.categ + 1 +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -if(column.check[i2] == categ[count.categ]){ -categ.class.order[count.categ] <- list(levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])]) # remove the absent color in the character vector -data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(categ.class.order[[count.categ]])) +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -if( ! is.null(dot.color) & ! is.null(dot.categ)){ # reminder : dot.categ cannot be a column name of categ anymore (because in that case dot.categ name is changed into "..._DOT" -if(column.check[i2] == ini.dot.categ){ -dot.categ.class.order <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector -data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.categ.class.order)) +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS") } +if( ! is.null(data2.incon.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -if(column.check[i2] == "categ.color"){ -categ.color <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector -if(length(categ.color) == 1 & length(unlist(categ.class.order[length(categ)])) > 1){ # to deal with single color -categ.color <- rep(categ.color, length(unlist(categ.class.order[length(categ)]))) +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(categ.color)) +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -if(column.check[i2] == "dot.color"){ -dot.color <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(data1[, column.check[i2]])] # remove the absent color in the character vector -if(length(dot.color) == 1 & length(dot.categ.class.order) > 1){ # to deal with single color. If dot.categ.class.order == NULL (which is systematically the case if dot.categ == NULL), no rep(dot.color, length(dot.categ.class.order) -dot.color <- rep(dot.color, length(dot.categ.class.order)) +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS") } -data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = unique(dot.color)) +if( ! is.null(data2.unknown.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -if(column.check[i2] %in% facet.categ){ # works if facet.categ == NULL this method should keep the order of levels when removing some levels -tempo.levels <- levels(data1[, column.check[i2]])[levels(data1[, column.check[i2]]) %in% unique(as.character(data1[, column.check[i2]]))] -data1[, column.check[i2]] <- factor(as.character(data1[, column.check[i2]]), levels = tempo.levels) +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, hframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "HORIZ FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.1, 0.15), v = c(0.75, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +} +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 8, title = "DATA2 + DATA2 UNKNOWN DOTS") +} +} +}else if(is.null(x.range.split) & ( ! is.null(y.range.split))){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe), x = list(x1, "x"), y = list(y1, "y"), categ = list("kind", "kind"), legend.name = list("DATASET", "VERT FRAME"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_path"), alpha = list(0.5, 0.5), title = "DATA1", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) +} +if( ! is.null(data1.signif.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.signif.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "VERT FRAME", "SIGNIF DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), "black"), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } }else{ -removed.row.nb <- NULL -removed.rows <- NULL +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA1 SIGNIFICANT DOTS") +} +if( ! is.null(data1.incon.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +tempo.graph <- fun_gg_scatter(data1 = list(data1, vframe, data1.incon.dot), x = list(x1, "x", x1), y = list(y1, "y", y1), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "VERT FRAME", "INCONSISTENT DOTS"), color = list(fun_gg_palette(2)[2], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2), fun_gg_palette(7)[6]), geom = list("geom_point", "geom_path", "geom_point"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA1 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -# 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), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add added here to have the facets -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[1]), stroke = dot.border.size, size = dot.size, alpha = dot.alpha, shape = 21)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(is.null(dot.color)){rep(NA, length(unique(data1[, categ[1]])))}else if(length(dot.color) == 1){rep(dot.color, length(unique(data1[, categ[1]])))}else{dot.color})) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[1]), coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf})) # fill because this is what is used with geom_box # to easily have the equivalent of the grouped boxs -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[1]])))}else{categ.color})) -# 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), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add added here to have the facets -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[2]), stroke = dot.border.size, size = dot.size, alpha = dot.alpha, shape = 21)) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(is.null(dot.color)){rep(NA, length(unique(data1[, categ[2]])))}else if(length(dot.color) == 1){rep(dot.color, length(unique(data1[, categ[2]])))}else{dot.color})) -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[2]), coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf})) # fill because this is what is used with geom_box # to easily have the equivalent of the grouped boxs -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[2]])))}else{categ.color})) -# end per box dots coordinates recovery }else{ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 2\n\n============\n\n") -stop(tempo.cat) +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -tempo <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))) -dot.coord <- tempo$data[[1]] -ini.box.coord <- tempo$data[[2]] -tempo.mean <- aggregate(x = dot.coord$y, by = list(dot.coord$group, dot.coord$PANEL), FUN = mean, na.rm = TRUE) -names(tempo.mean)[names(tempo.mean) == "x"] <- "MEAN" -names(tempo.mean)[names(tempo.mean) == "Group.1"] <- "BOX" -names(tempo.mean)[names(tempo.mean) == "Group.2"] <- "PANEL" -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"]}, -data1[order(data1$categ.check, data1[, y]), ][categ] # avoid the renaming below -) # 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( ! is.null(dot.categ)){ -dot.coord <- data.frame(dot.coord, data1[order(data1$categ.check, data1[, y]), ][dot.categ]) # avoid the renaming +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA1\nINCONSISTENT DOTS", text.size = 8, title = "DATA1 + DATA1 INCONSISTENT DOTS") } -if( ! is.null(facet.categ)){ -dot.coord <- data.frame(dot.coord, data1[order(data1$categ.check, data1[, y]), ][facet.categ]) # for facet panels -tempo.test <- NULL -for(i2 in 1:length(facet.categ)){ -tempo.test <- paste0(tempo.test, ".", formatC(as.numeric(dot.coord[, facet.categ[i2]]), width = nchar(max(as.numeric(dot.coord[, facet.categ[i2]]), na.rm = TRUE)), flag = "0")) # convert factor into numeric with leading zero for proper ranking # merge the formatC() to create a new factor. The convertion to integer should recreate the correct group number. Here as.numeric is used and not as.integer in case of numeric in facet.categ (because comes from add and not checked by fun_check, contrary to categ) +if( ! is.null(data2)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -tempo.test <- as.integer(factor(tempo.test)) -if( ! identical(as.integer(dot.coord$PANEL), tempo.test)){ -tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": as.integer(dot.coord$PANEL) AND tempo.test MUST BE IDENTICAL. CODE HAS TO BE MODIFIED\n\n================\n\n") -stop(tempo.cat) +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, vframe), x = list(x1, x2, "x"), y = list(y1, y2, "y"), categ = list("kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5), title = "DATA1 + DATA2", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } +if( ! is.null(data2.signif.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -if(dot.tidy == TRUE){ -dot.coord <- data.frame(dot.coord, tidy_group = if(length(categ) == 1){dot.coord[, categ]}else{paste(dot.coord[, categ[1]], dot.coord[, categ[2]], sep = ".")}) # for tidy dot plots +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.signif.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "SIGNIF DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], "black", rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -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, tempo.mean$PANEL), ]$BOX, unique(dot.coord[order(dot.coord$group, dot.coord$PANEL), c("group", "PANEL")])$group)){ -tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": (tempo.mean$BOX, tempo.mean$PANEL) AND (dot.coord$group, dot.coord$PANEL) 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, tempo.mean$PANEL), ], unique(dot.coord[order(dot.coord$group, dot.coord$PANEL), c(categ, if( ! is.null(dot.color) & ! is.null(dot.categ)){if(dot.categ != ini.dot.categ){dot.categ}}, if( ! is.null(facet.categ)){facet.categ}), drop = FALSE])) +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2 DOTS\nOUTSIDE THE FRAMES", text.size = 8, title = "DATA1 + DATA2 + DATA2 SIGNIFICANT DOTS") +} +if( ! is.null(data2.incon.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.incon.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "INCONSISTENT DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[6], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 INCONSISTENT DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -# 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( ! fun_comp_2d(ini.box.coord[c("PANEL", "group")], tempo.mean[c("PANEL", "BOX")])$identical.content){ -tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR IN ", function.name, ": ini.box.coord[c(\"PANEL\", \"group\")] AND tempo.mean[c(\"PANEL\", \"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 +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) } -# 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))) +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nINCONSISTENT DOTS", text.size = 8, title = "DATA2 + DATA2 INCONSISTENT DOTS") } -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( ! is.null(data2.unknown.dot)){ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = FALSE) +} +tempo.graph <- fun_gg_scatter(data1 = list(data1, data2, data2.unknown.dot, vframe), x = list(x1, x2, x2, "x"), y = list(y1, y2, y2, "y"), categ = list("kind", "kind", "kind", "kind"), legend.name = list("DATASET", "DATASET", "UNKNOWN DOTS", "VERT FRAME"), color = list(fun_gg_palette(2)[2], fun_gg_palette(2)[1], fun_gg_palette(7)[5], rep(hsv(h = c(0.5, 0.6), v = c(0.9, 1)), 2)), geom = list("geom_point", "geom_point", "geom_point", "geom_path"), alpha = list(0.5, 0.5, 0.5, 0.5), title = "DATA1 + DATA2 + DATA2 UNKNOWN DOTS", x.lim = x.range.plot, y.lim = y.range.plot, raster = raster, return = TRUE) +if( ! is.null(tempo.graph$warn)){ +warn <- paste0(ifelse(is.null(warn), tempo.graph$warn, paste0(warn, "\n", tempo.graph$warn))) } -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) +}else{ +if(graph.in.file == FALSE){ +fun_open(pdf.disp = 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 +fun_gg_empty_graph(text = "NO PLOT\nBECAUSE\nNO DATA2\nUNKNOWN DOTS", text.size = 8, title = "DATA2 + DATA2 UNKNOWN DOTS") } -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), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add is directly put here to deal ith additional variable of data, like when using fact_grid. No problem if add is a theme, will be dealt below -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 -> article ARGUMENT WILL BE IGNORED") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) -add.check <- FALSE } } -if(add.check == TRUE & article == 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), -legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend -axis.line.y.left = ggplot2::element_line(colour = "black"), # 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), -legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend -axis.line.y.left = ggplot2::element_line(colour = "black"), -axis.line.x.bottom = ggplot2::element_line(colour = "black"), -axis.text.x = 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 plot +if(warn.print == TRUE & ! is.null(warn)){ +warning(warn, call. = FALSE) +cat("\n\n") } -}else if(add.check == TRUE & article == FALSE){ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme( -text = ggplot2::element_text(size = text.size), -plot.title = ggplot2::element_text(size = title.text.size), # stronger than text -line = ggplot2::element_line(size = 0.5), -legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend -panel.background = ggplot2::element_rect(fill = "grey95"), -axis.line.y.left = ggplot2::element_line(colour = "black"), -axis.line.x.bottom = ggplot2::element_line(colour = "black"), -panel.grid.major.x = ggplot2::element_line(colour = "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)} -)) +tempo.list <- list(data1.removed.row.nb = data1.removed.row.nb, data1.removed.rows = data1.removed.rows, data2.removed.row.nb = data2.removed.row.nb, data2.removed.rows = data2.removed.rows, hframe = hframe, vframe = vframe, data1.signif.dot = data1.signif.dot, data1.non.signif.dot = data1.non.signif.dot, data1.inconsistent.dot = data1.incon.dot, data2.signif.dot = data2.signif.dot, data2.non.signif.dot = data2.non.signif.dot, data2.unknown.dot = data2.unknown.dot, data2.inconsistent.dot = data2.incon.dot, axes = axes, warn = warn) +return(tempo.list) } -# 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 +################ Import -# x coordinates management (for random plotting and for stat display) -# boxs -tempo.graph.info <- ggplot2::ggplot_build(eval(parse(text = paste0(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), ' + ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[length(categ)]), position = ggplot2::position_dodge(width = NULL), width = box.width, notch = box.notch, coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf}) + ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color})')))) # will be recovered later again, when ylim will be considered -tempo.yx.ratio <- (tempo.graph.info$layout$panel_params[[1]]$y.range[2] - tempo.graph.info$layout$panel_params[[1]]$y.range[1]) / (tempo.graph.info$layout$panel_params[[1]]$x.range[2] - tempo.graph.info$layout$panel_params[[1]]$x.range[1]) -box.coord <- tempo.graph.info$data[[2]] # to have the summary statistics of the plot. Contrary to ini.box.plot, now integrates ylim Here because can be required for stat.disp when just box are plotted -box.coord <- box.coord[order(box.coord$group), ] -if(stat.disp.mean == TRUE){ # for mean display -if( ! identical(tempo.mean$BOX, box.coord$group)){ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": tempo.mean$BOX AND box.coord$group DO NOT HAVE THE SAME VALUE ORDER\n\n============\n\n") -stop(tempo.cat) -}else{ -box.coord <- data.frame(box.coord, tempo.mean) -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") MEAN VALUES INSTEAD OF MEDIAN VALUES DISPLAYED") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +######## fun_pack() #### check if R packages are present and import into the working environment + +# Check OK: clear to go Apollo +fun_pack <- function(req.package, load = FALSE, lib.path = NULL){ +# AIM +# check if the specified R packages are present in the computer and import them into the working environment +# ARGUMENTS +# req.package: character vector of package names to import +# req.package: logical. Load the package into the environement (using library())? +# lib.path: optional character vector specifying the absolute pathways of the directories containing some of the listed packages +# REQUIRED PACKAGES +# none +# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_check() +# RETURN +# nothing +# EXAMPLES +# fun_pack(req.package = "nopackage") +# fun_pack(req.package = "ggplot2") +# fun_pack(req.package = "ggplot2", lib.path = "blablabla") +# DEBUGGING +# req.package = "ggplot2" ; lib.path = "C:/Program Files/R/R-3.5.1/library" +# req.package = "serpentine" ; lib.path = "C:/users/gael/appdata/roaming/python/python36/site-packages" +# function name +function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") +# end function name +# required function checking +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) } +# end required function checking +# 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 = req.package, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = load, class = "vector", mode = "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){ +if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA +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) } -# 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"], # already added above -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", "PANEL", "group", "x")], by = c("PANEL", "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 = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in box.coord. Thus, no need to consider fill column -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) +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), 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 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(data1[, categ[1]]))) # categ[1] is factor -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( -formatC(as.integer(data1[, categ[2]]), width = nchar(max(as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking -".", -formatC(as.integer(data1[, categ[1]]), width = nchar(max(as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking -))) # merge the 2 formatC() to create a new factor. The convertion to integer should recreate the correct group number -) -) # 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")) +# 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 +# main code +if(is.null(lib.path)){ +lib.path <- .libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path)) }else{ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 6\n\n============\n\n") -stop(tempo.cat) +.libPaths(new = sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. BEWARE: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path +} +for(i1 in 1:length(req.package)){ +if( ! req.package[i1] %in% rownames(utils::installed.packages(lib.loc = lib.path))){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i1], " MUST BE INSTALLED IN:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +}else{ +if(load == TRUE){ +suppressWarnings(suppressPackageStartupMessages(library(req.package[i1], lib.loc = lib.path, quietly = TRUE, character.only = TRUE))) } -dot.coord.rd3 <- merge(dot.coord.rd2, tempo.data1, by = intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. BEWARE: I have replaced by = "group" by intersect("group", "group") because of an error due to wrong group group merging in dot.coord.rd3 -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) - +######## fun_python_pack() #### check if python packages are present -# boxplot display before dot display if box.fill = TRUE -coord.names <- NULL -# creation of the data frame for (main box + legend) and data frame for means -if(box.notch == FALSE){ -for(i3 in 1:length(categ)){ -if(i3 == 1){ -tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE) -}else{ -tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE) -} +# Check OK: clear to go Apollo +fun_python_pack <- function(req.package, python.exec.path = NULL, lib.path = NULL, R.lib.path = NULL){ +# AIM +# check if the specified python packages are present in the computer (no import) +# WARNINGS +# for python 3.7. Previous versions return an error "Error in sys$stdout$flush() : attempt to apply non-function" +# ARGUMENTS +# req.package: character vector of package names to import +# python.exec.path: optional character vector specifying the absolute pathways of the executable python file to use (associated to the packages to use). If NULL, the reticulate::import_from_path() function used in fun_python_pack() seeks for an available version of python.exe, and then uses python_config(python_version, required_module, python_versions). But might not be the correct one for the lib.path parameter specified. Thus, it is recommanded to do not leave NULL, notably when using computing clusters +# lib.path: optional character vector specifying the absolute pathways of the directories containing some of the listed packages in the req.package argument +# R.lib.path: absolute path of the reticulate packages, if not in the default folders +# REQUIRED PACKAGES +# reticulate +# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_check() +# fun_pack() +# RETURN +# nothing +# EXAMPLES +# example of error message +# fun_python_pack(req.package = "nopackage") +# example without error message (require the installation of the python serpentine package from https://github.com/koszullab/serpentine +# fun_python_pack(req.package = "serpentine", python.exec.path = "C:/ProgramData/Anaconda3/python.exe", lib.path = "c:/programdata/anaconda3/lib/site-packages/") +# another example of error message +# fun_python_pack(req.package = "serpentine", lib.path = "blablabla") +# DEBUGGING +# req.package = "serpentine" ; python.exec.path = "C:/ProgramData/Anaconda3/python.exe" ; lib.path = "c:/programdata/anaconda3/lib/site-packages/" ; R.lib.path = NULL +# req.package = "bad" ; lib.path = NULL ; R.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_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) } -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) -if( ! is.null(facet.categ)){ -for(i4 in 1:length(facet.categ)){ -tempo.polygon <- data.frame(tempo.polygon, c(t(stat[, c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE) -names(tempo.polygon)[length(names(tempo.polygon))] <- facet.categ[i4] +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) } +# end required function checking +# 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 = req.package, class = "character", fun.name = function.name) ; eval(ee) +if( ! is.null(python.exec.path)){ +tempo <- fun_check(data = python.exec.path, class = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE){ +if( ! all(file.exists(python.exec.path))){ # separation to avoid the problem of tempo$problem == FALSE and python.exec.path == NA +tempo.cat <- paste0("ERROR IN ", function.name, ": FILE PATH INDICATED IN THE python.exec.path ARGUMENT DOES NOT EXISTS:\n", paste(python.exec.path, collapse = "\n")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -}else{ -for(i3 in 1:length(categ)){ -if(i3 == 1){ -tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE) -}else{ -tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE) } } -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) -if( ! is.null(facet.categ)){ -for(i4 in 1:length(facet.categ)){ -tempo.polygon <- data.frame(tempo.polygon, c(t(stat[, c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE) -names(tempo.polygon)[length(names(tempo.polygon))] <- facet.categ[i4] +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){ +if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA +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) } } } -tempo.polygon$COLOR <- factor(tempo.polygon$COLOR, levels = unique(categ.color)) -if( ! is.null(categ.class.order)){ -for(i3 in 1:length(categ)){ -tempo.polygon[, categ[i3]] <- factor(tempo.polygon[, categ[i3]], levels = categ.class.order[[i3]]) +if( ! is.null(R.lib.path)){ +tempo <- fun_check(data = R.lib.path, class = "character", fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE){ +if( ! all(dir.exists(R.lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and R.lib.path == NA +tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE R.lib.path ARGUMENT DOES NOT EXISTS:\n", paste(R.lib.path, collapse = "\n")) +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } } -# modified name of dot.categ column (e.g., "Group1_DOT") must be included for boxplot using ridy dots -if( ! is.null(dot.color) & ! is.null(dot.categ)){ -if(dot.categ != ini.dot.categ){ -tempo.polygon <- data.frame(tempo.polygon, GROUPX = tempo.polygon[, ini.dot.categ]) -names(tempo.polygon)[names(tempo.polygon) == "GROUPX"] <- dot.categ - } +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -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) -if( ! is.null(facet.categ)){ -for(i3 in 1:length(facet.categ)){ -tempo.diamon.mean <- data.frame(tempo.diamon.mean, c(t(stat[, c(facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3])])), stringsAsFactors = TRUE) -names(tempo.diamon.mean)[length(names(tempo.diamon.mean))] <- facet.categ[i3] +# 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 +# package checking +fun_pack(req.package = "reticulate", lib.path = R.lib.path) +# end package checking +# main code +if(is.null(python.exec.path)){ +python.exec.path <- reticulate::py_run_string(" +import sys ; +path_lib = sys.path +") # python string +python.exec.path <- python.exec.path$path_lib } +if(is.null(lib.path)){ +lib.path <- reticulate::py_run_string(" +import sys ; +path_lib = sys.path +") # python string +lib.path <- lib.path$path_lib } -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") +reticulate::use_python(Sys.which(python.exec.path), required = TRUE) # required to avoid the use of erratic python exec by reticulate::import_from_path() +for(i1 in 1:length(req.package)){ +tempo.try <- vector("list", length = length(lib.path)) +for(i2 in 1:length(lib.path)){ +tempo.try[[i2]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i1], path = lib.path[i2]), silent = TRUE)) +tempo.try[[i2]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i1], path = lib.path[i2]), silent = TRUE)) # done twice to avoid the error message about flushing present the first time but not the second time. see https://stackoverflow.com/questions/57357001/reticulate-1-13-error-in-sysstdoutflush-attempt-to-apply-non-function } -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") +if(all(sapply(tempo.try, FUN = grepl, pattern = "[Ee]rror"))){ +print(tempo.try) +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i1], " MUST BE INSTALLED IN THE MENTIONNED DIRECTORY:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n") +stop(tempo.cat, call. = FALSE) +} # else{ +# suppressWarnings(suppressPackageStartupMessages(assign(req.package[i1], reticulate::import(req.package[i1])))) # not required because try() already evaluates +# } } -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 +################ Print / Exporting results (text & tables) +######## fun_report() #### print string or data object into output file -# 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.categ.class.order)), guide = ggplot2::guide_legend(override.aes = list(fill = dot.color, color = if(is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # 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){ -if(is.null(dot.categ)){ -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", group = "tidy_group"), -position = ggplot2::position_dodge(width = box.width), -binaxis = "y", -stackdir = "center", -alpha = dot.alpha, -fill = as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]), -stroke = dot.border.size, -color = if(is.null(dot.border.color)){as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"])}else{rep(dot.border.color, nrow(dot.coord))}, -show.legend = FALSE, # BEWARE: do not use show.legend = TRUE because it uses the arguments outside aes() as aesthetics (here color and fill). Thus I must find a way using ggplot2::scale_discrete_manual() -binwidth = (y.lim[2] - y.lim[1]) / dot.tidy.bin.nb -)) # very weird behavior of geom_dotplot, (1) because with aes group = (to avoid legend), the dot plotting is not good in term of coordinates, and (2) because data1 seems reorderer according to x = categ[1] before plotting. Thus, I have to use fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"] to have the good corresponding colors # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -}else{ -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", alpha = categ[length(categ)]), -position = ggplot2::position_dodge(width = box.width), -binaxis = "y", -stackdir = "center", -fill = as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"]), -stroke = dot.border.size, -color = if(is.null(dot.border.color)){as.character(dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"])}else{rep(dot.border.color, nrow(dot.coord))}, -# BEWARE: do not use show.legend = TRUE because it uses the arguments outside aes() as aesthetics (here color and fill). Thus I must find a way using ggplot2::scale_discrete_manual() -binwidth = (y.lim[2] - y.lim[1]) / dot.tidy.bin.nb -)) # very weird behavior of geom_dotplot, (1) because with aes group = (to avoid legend), the dot plotting is not good in term of coordinates, and (2) because data1 seems reorderer according to x = categ[1] before plotting. Thus, I have to use fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"] to have the good corresponding colors # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.) -# 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 = "alpha", name = dot.categ.legend.name, values = rep(dot.alpha, length(dot.categ.class.order)), labels = dot.categ.class.order, guide = ggplot2::guide_legend(title = if(ini.dot.categ == categ[length(categ)]){dot.categ}else{ini.dot.categ}, override.aes = list(fill = dot.color, color = if(is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # 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 +# Check OK: clear to go Apollo +fun_report <- function(data, output = "results.txt", path = "C:/Users/Gael/Desktop/", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = TRUE, sep = 2){ +# AIM +# log file function: print a character string or a data object into a same output file +# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_check() +# ARGUMENTS +# data: object to print in the output file. If NULL, nothing is done, with no warning +# output: name of the output file +# path: location of the output file +# no.overwrite: (logical) if output file already exists, defines if the printing is appended (default TRUE) or if the output file content is erased before printing (FALSE) +# rownames.kept: (logical) defines whether row names have to be removed or not in small tables (less than length.rows rows) +# vector.cat (logical). If TRUE print a vector of length > 1 using cat() instead of capture.output(). Otherwise (default FALSE) the opposite +# noquote: (logical). If TRUE no quote are present for the characters +# sep: number of separating lines after printed data (must be integer) +# RETURN +# nothing +# EXAMPLES +# fun_report() +# fun_report(data = 1:3, output = "results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = FALSE, sep = 2) +# DEBUGGING +# data = 1:3 ; output = "results.txt" ; path = "C:/Users/Gael/Desktop" ; no.overwrite = TRUE ; rownames.kept = FALSE ; vector.cat = FALSE ; noquote = FALSE ; sep = 2 # for function debugging +# function name +function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") +# end function name +# required function checking +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) } -# 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))]] +# end required function checking +# 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 = output, class = "character", length = 1, fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE & output == ""){ +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": output ARGUMENT AS \"\" DOES NOT CORRESPOND TO A VALID FILE NAME\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -tempo.box.coord <- merge(box.coord, unique(dot.coord[, c("PANEL", "group", categ)]), by = c("PANEL", "group"), sort = FALSE) # add the categ in box.coord. BEWARE: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in box.coord. Thus, no need to consider fill column -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) +tempo <- fun_check(data = path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee) +if(tempo$problem == FALSE){ +if( ! all(dir.exists(path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA +tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n", paste(path, collapse = "\n"),"\n\n================\n\n") +text.check <- c(text.check, tempo.cat) +arg.check <- c(arg.check, TRUE) } -dot.coord.tidy2 <- merge(dot.coord.tidy1, tempo.box.coord[c("fill", "PANEL", "group", "x", categ)], by = c("PANEL", "group"), sort = FALSE) # send the coord of the boxs into the coord data.frame of the dots (in the column x.y).BEWARE: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in tempo.box.coord. Thus, no need to consider fill column -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(data1[, categ[1]]))) # categ[1] is factor -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( -formatC(as.integer(data1[, categ[2]]), width = nchar(max(as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking -".", -formatC(as.integer(data1[, categ[1]]), width = nchar(max(as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking -))) # merge the 2 formatC() to create a new factor. The convertion to integer should recreate the correct group number -) -) # 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) +tempo <- fun_check(data = no.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = rownames.kept, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = vector.cat, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = noquote, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = sep, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee) +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -dot.coord.tidy3 <- merge(dot.coord.tidy2, tempo.data1, by = intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. BEWARE: I have tested intersect("group", "group") instead of by = "group". May be come back to by = "group" in case of error. But I did this because of an error in dot.coord.rd3 above -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 argument checking +# 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() +# the 4 next lines are inactivated but kept because at a time, I might have a problem with data (solved with data = NULL). These 4 lines are just to know how to detect a missing argument. Important here because if data is not provided, print the code of the data function +# arg.user.list <- as.list(match.call(expand.dots=FALSE))[-1] # recover all the arguments provided by the function user (excluding the argument with defaults values not provided by the user. Thus, it is really the list indicated by the user) +# default.arg.list <- formals(fun = sys.function(sys.parent())) # list of all the arguments of the function with their default values (not the values of the user !). It seems that ls() as first line of the function provide the names of the arguments (empty, called, etc., or not) +# arg.without.default.value <- sapply(default.arg.list, is.symbol) & sapply(sapply(default.arg.list, as.character), identical, "") # logical to detect argument without default values (these are typeof "symbol" and class "name" and empty character +# if( ! all(names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list))){ # test that the arguments with no null values are provided by the user +# tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": VALUE REQUIRED FOR THESE ARGUMENTS WITH NO DEFAULTS VALUES: ", paste(names(default.arg.list)[arg.without.default.value][ ! names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list)], collapse = " "), "\n\n================\n\n") +#stop(tempo.cat, call. = FALSE) +# } +# end argument checking +# main code +if( ! is.null(data)){ +if(all(class(data) %in% c("matrix", "data.frame", "table"))){ +if(rownames.kept == FALSE & all(class(data) == "data.frame") & nrow(data) != 0 & nrow(data) <= 4){ # for data frames with nrows <= 4 +rownames.output.tables <- "" +length.rows <- nrow(data) +for(i in 1:length.rows){ # replace the rownames of the first 4 rows by increasing number of spaces (because identical row names not allowed in data frames). This method cannot be extended to more rows as the printed data frame is shifted on the right because of "big empty rownames" +rownames.output.tables <- c(rownames.output.tables, paste0(rownames.output.tables[i]," ", collapse="")) } -# end coordinates of tidy dots +row.names(data) <- rownames.output.tables[1:length.rows] +}else if(rownames.kept == FALSE & all(class(data) %in% c("matrix", "table"))){ +rownames(data) <- rep("", nrow(data)) # identical row names allowed in matrices and tables } -coord.names <- c(coord.names, "dots") +if(noquote == TRUE){ +utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite) +}else{ +utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite) } -# end dot display - - - -# boxplot display (if box.fill = FALSE, otherwise, already plotted above) -if(box.fill == TRUE){ -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color})) #, guide = ggplot2::guide_legend(override.aes = list(fill = levels(tempo.polygon$COLOR), color = "black")))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = rep(hsv(0, 0, 0, alpha = box.alpha), length(unique(data1[, categ[length(categ)]]))))) # , guide = ggplot2::guide_legend(override.aes = list(color = "black", alpha = box.alpha)))) # 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 if(is.vector(data) & all(class(data) != "list") & (length(data) == 1 | vector.cat == TRUE)){ +if(noquote == TRUE){ +cat(noquote(data), file= paste0(path, "/", output), append = no.overwrite) }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") +cat(data, file= paste0(path, "/", output), append = no.overwrite) } -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") +}else{ # other (array, list, factor or vector with vector.cat = FALSE) +if(noquote == TRUE){ +utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite) +}else{ +utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite) } -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = categ.legend.name, values = rep(NA, length(unique(data1[, categ[length(categ)]]))))) #, guide = ggplot2::guide_legend(override.aes = list(color = categ.color)))) # values are the values of color (which is the border color in geom_box. BEWARE: values = categ.color takes the numbers to make the colors if categ.color is a factor -assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = categ.legend.name, values = if(length(categ.color) == 1){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color}, guide = ggplot2::guide_legend(override.aes = list(alpha = if(plot == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){1}else{box.alpha})))) # , 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 -if(plot == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0 & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1 -# 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 -warn.count <- warn.count + 1 -tempo.warn <- paste0("(", warn.count,") FROM FUNCTION ", function.name, ": GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)") -warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn))) +} +sep.final <- paste0(rep("\n", sep), collapse = "") +write(sep.final, file= paste0(path, "/", output), append = TRUE) # add a sep } } -# end boxplot display (if box.fill = FALSE, otherwise, already plotted above) +######## fun_get_message() #### return messages of an expression (that can be exported) -# 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 -coord.names <- c(coord.names, "stat.display") -}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) +# Check OK: clear to go Apollo +fun_get_message <- function(data, kind = "error", header = TRUE, print.no = FALSE, text = NULL, env = NULL){ +# AIM +# evaluate an instruction written between "" and return the first of the error, or warning or standard (non error non warning) messages if ever exist +# using argument print.no = FALSE, return NULL if no message, which is convenient in some cases +# WARNING +# Only the first message is returned +# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION +# fun_check() +# ARGUMENTS +# data: character string to evaluate +# kind: character string. Either "error" to get error messages, or "warning" to get warning messages, or "message" to get non error and non warning messages +# header: logical. Add a header in the returned message? +# print.no: logical. Print a message saying that no message reported? +# text: character string added to the output message (even if no message exists and print.no is TRUE). Inactivated if header is FALSE +# env: the name of an existing environment. NULL if not required +# RETURN +# the message or NULL if no message and print.no is FALSE +# EXAMPLES +# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "error", print.no = TRUE, text = "IN A") +# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "warning", print.no = TRUE, text = "IN A") +# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "message", print.no = TRUE, text = "IN A") +# fun_get_message(data = "wilcox.test()", kind = "error", print.no = TRUE, text = "IN A") +# fun_get_message(data = "sum(1)", kind = "error", print.no = TRUE, text = "IN A") +# fun_get_message(data = "message('ahah')", kind = "error", print.no = TRUE, text = "IN A") +# fun_get_message(data = "message('ahah')", kind = "message", print.no = TRUE, text = "IN A") +# fun_get_message(data = "ggplot2::ggplot(data = data.frame(X = 1:10), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()", kind = "message", print.no = TRUE, text = "IN FUNCTION 1") +# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; fun_get_message(data = 'fun_gg_boxplot(data = obs1, y = "Time", categ = "Group1")', kind = "message", print.no = TRUE, text = "IN FUNCTION 1") +# DEBUGGING +# data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging +# data = "sum(1)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging +# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; data = 'fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1")' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging +# data = "message('ahah')" ; kind = "error" ; header = TRUE ; print.no = TRUE ; text = "IN A" ; env = NULL +# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "message" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging +# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging +# function name +function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()") +# end function name +# required function checking +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) } -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 required function checking +# no need to use reserved words to avoid bugs, because it is local, and exists("tempo.warning", inherit = FALSE), never use the scope +# argument checking +# argument checking with fun_check() +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 = data, class = "character", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = kind, options = c("error", "warning", "message"), length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = print.no, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +tempo <- fun_check(data = header, class = "logical", length = 1, fun.name = function.name) ; eval(ee) +if( ! is.null(text)){ +tempo <- fun_check(data = text, class = "character", length = 1, fun.name = function.name) ; eval(ee) } +if( ! is.null(env)){ +tempo <- fun_check(data = env, class = "environment", fun.name = function.name) ; eval(ee) # } -# 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 +if(any(arg.check) == TRUE){ +stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # } -# end stat display -coord.names <- c(coord.names, "stat.display.positive", "stat.display.negative") -}else{ -tempo.cat <- paste0("\n\n============\n\nINTERNAL CODE ERROR IN ", function.name, ": CODE INCONSISTENCY 9\n\n============\n\n") -stop(tempo.cat) +# end argument checking with fun_check() +# 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 +# main code +pdf(file = NULL) # send plots into a NULL file, no pdf file created +window.nb <- dev.cur() +dev.set(window.nb) +# last warning cannot be used because suppressWarnings() does not modify last.warning present in the base evironment (created at first warning in a new R session), or warnings() # to reset the warning history : unlockBinding("last.warning", baseenv()) ; assign("last.warning", NULL, envir = baseenv()) +output <- NULL +tempo.error <- try(suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))), silent = TRUE) # get error message, not warning or messages +if(any(class(tempo.error) %in% c("gg", "ggplot"))){ +tempo.error <- try(suppressMessages(suppressWarnings(ggplot2::ggplot_build(tempo.error))), silent = TRUE)[1] } +if(exists("tempo.error", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word +if( ! (all(class(tempo.error) == "try-error") & any(grepl(x = tempo.error, pattern = "^Error|^error|^ERROR")))){ # deal with NULL. Old code : if((length(tempo.error) > 0 & ! any(grepl(x = tempo.error, pattern = "^Error|^error|^ERROR"))) | (length(tempo.error) == 0) ){ but problem when tempo.error is a list but added this did not work: | ! all(class(tempo.error) == "character") +tempo.error <- NULL } -# 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]] -if(is.null(y.tick.nb) & y.log != "no"){ # integer main ticks for log2 and log10 -tempo.scale <- (as.integer(min(y.lim, na.rm = TRUE)) - 1):(as.integer(max(y.lim, na.rm = TRUE)) + 1) }else{ -tempo.scale <- fun_scale(lim = y.lim, n = ifelse(is.null(y.tick.nb), length(tempo.coord$y.major_source), y.tick.nb)) +tempo.error <- NULL } -# 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 +if(kind == "error" & ! is.null(tempo.error)){ # +if(header == TRUE){ +tempo.error[1] <- gsub(x = tempo.error[1], pattern = "^Error i|^error i|^ERROR I", replacement = "I") +output <- paste0("ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.error[1]) # }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 +output <- tempo.error[1] # } -# 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 -# y.second.tick.positions: coordinates of secondary ticks (only if y.inter.tick.nb argument is non NULL or if y.log argument is different from "no") -y.second.tick.values <- NULL -if(y.log != "no"){ -# make a function from this -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, i.e., integer part of y.lim. Example recover 08 from 1e+08. Works for log2 -# 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 <- unique(as.vector(outer(2:10, ifelse(y.log == "log2", 2, 10)^((power10.exp[1] - ifelse(diff(y.lim.order) > 0, 1, -1)):(power10.exp[2] + ifelse(diff(y.lim.order) > 0, 1, -1)))))) # use log10(2:10) even if log2: it is to get log values between 0 and 1 -tempo.tick.pos <- sort(tempo.tick.pos, decreasing = ifelse(diff(y.lim.order) > 0, FALSE, TRUE)) -y.second.tick.values <- tempo.tick.pos -if(y.log == "log2"){ -tempo.tick.pos <- log2(tempo.tick.pos[tempo.tick.pos >= min(2^y.lim) & tempo.tick.pos <= max(2^y.lim)]) -}else if(y.log == "log10"){ -tempo.tick.pos <- log10(tempo.tick.pos[tempo.tick.pos >= min(10^y.lim) & tempo.tick.pos <= max(10^y.lim)]) +}else if(kind == "error" & is.null(tempo.error) & print.no == TRUE){ +output <- paste0("NO ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) +}else if(kind != "error" & ( ! is.null(tempo.error)) & print.no == TRUE){ +output <- paste0("NO ", ifelse(kind == "warning", "WARNING", "STANDARD (NON ERROR AND NON WARNING)"), " MESSAGE BECAUSE OF ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) +}else if(is.null(tempo.error)){ +fun.warning.capture <- function(expr){ +# from demo(error.catching) typed in the R console, coming from ?tryCatch +# see also http://mazamascience.com/WorkingWithData/?p=912 +# return a character string or NULL +# expr <- wilcox.test.default(c(1, 1, 3), c(1, 2, 4), paired = TRUE) +W <- NULL +w.handler <- function(w){ # warning handler +W <<- w # send to the above env, i.e., the inside of the fun.warning.capture function +invokeRestart("muffleWarning") # here w.handler() muffles all the warnings. See http://romainfrancois.blog.free.fr/index.php?post/2009/05/20/Disable-specific-warnings to muffle specific warnings and print others } -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) +output <- list( +value = suppressMessages(withCallingHandlers(tryCatch(expr, error = function(e){e}), warning = w.handler)), # BEWARE: w.handler is a function written without (), like in other functions with FUN argument +warning = W # processed by w.handler() +) +return(if(is.null(output$warning)){NULL}else{as.character(output$warning)}) } -# 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)) -# } -coord.names <- c(coord.names, "y.second.tick.positions") -}else if(( ! is.null(y.inter.tick.nb)) & y.log == "no"){ -# if(y.inter.tick.nb > 0){ #inactivated because already checked before -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) +tempo.warn <- fun.warning.capture(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env})) +# warn.options.ini <- options()$warn ; options(warn = 1) ; tempo.warn <- utils::capture.output({tempo <- suppressMessages(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))}, type = "message") ; options(warn = warn.options.ini) # this recover warnings not messages and not errors but does not work in all enviroments +tempo.message <- utils::capture.output({ +tempo <- suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))) +if(any(class(tempo) %in% c("gg", "ggplot"))){ +tempo <- ggplot2::ggplot_build(tempo) +}else{ +tempo <- suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env})) } -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) -minor.tick.pos <- minor.tick.pos[minor.tick.pos >= min(y.lim) & minor.tick.pos <= max(y.lim)] -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)) +}, type = "message") # recover messages not warnings and not errors +if(kind == "warning" & ! is.null(tempo.warn)){ +if(length(tempo.warn) > 0){ # to avoid character(0) +if( ! any(sapply(tempo.warn, FUN = "grepl", pattern = "() FUNCTION:$"))){ +tempo.warn <- paste(unique(tempo.warn), collapse = "\n") # if FALSE, means that the tested data is a special function. If TRUE, means that the data is a standard function. In that case, the output of capture.output() is two strings per warning messages: if several warning messages -> identical first string, which is removed in next messages by unique() }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) +tempo.warn <- paste(tempo.warn, collapse = "\n") } -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) -minor.tick.pos <- minor.tick.pos[minor.tick.pos >= min(y.lim) & minor.tick.pos <= max(y.lim)] -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)) +if(header == TRUE){ +if(any(grepl(x = tempo.warn[[1]], pattern = "^simpleWarning i"))){ +tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I") } -y.second.tick.values <- minor.tick.pos -coord.names <- c(coord.names, "y.second.tick.positions") +if(any(grepl(x = tempo.warn[[1]], pattern = "^Warning i"))){ +tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I") } -# end secondary ticks (after ggplot2::coord_cartesian() or ggplot2::coord_flip()) -# end y scale management (cannot be before dot plot management) - - - - -# drawing -fin.plot <- eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))) -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(fin.plot))) -# suppressMessages(suppressWarnings(print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add})))))) +output <- paste0("WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.warn) # }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))) +output <- 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 +}else if(print.no == TRUE){ +output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) } -if(return == TRUE){ -output <- ggplot2::ggplot_build(fin.plot) -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 if(kind == "warning" & is.null(tempo.warn) & print.no == TRUE){ +output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) +}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word +if(length(tempo.message) > 0){ # if something is returned by capture.ouptput() (only in this env) with a length more than 1 +if(header == TRUE){ +output <- paste0("STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.message) # }else{ -names(output$data) <- coord.names +output <- tempo.message # } -output <- list(data = data1, stat = stat, removed.row.nb = removed.row.nb, removed.rows = removed.rows, plot = c(output$data, y.second.tick.values = list(y.second.tick.values)), panel = facet.categ, axes = output$layout$panel_params[[1]], warn = paste0("\n", warn, "\n\n")) -return(output) +}else if(print.no == TRUE){ +output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) } -# end outputs -# end main code +}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == FALSE & print.no == TRUE){ +output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text) +} +} +invisible(dev.off(window.nb)) # end send plots into a NULL file +return(output) # do not use cat() because the idea is to reuse the message } diff --git a/cute_little_R_functions.docx b/cute_little_R_functions.docx index 85a7837d7abcff2147a1f0390f5d20c77bd7de9e..91f025aed20d3ef4b6eebc94c71fada7e5dd0d22 100644 Binary files a/cute_little_R_functions.docx and b/cute_little_R_functions.docx differ