From 4e49ad19a78d0ad0a1df1ff15ce6e431c02c0dd4 Mon Sep 17 00:00:00 2001 From: "Pedro J. Aphalo" Date: Tue, 14 May 2024 16:13:10 +0300 Subject: [PATCH 1/3] Implement trimming values in x_label funcitons We attempt to rescue values that are very close to the boundary of P, R, R^2, etc. Not tested. --- R/utilities-labels.R | 90 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 70 insertions(+), 20 deletions(-) diff --git a/R/utilities-labels.R b/R/utilities-labels.R index 6edfa05..4afcfc7 100644 --- a/R/utilities-labels.R +++ b/R/utilities-labels.R @@ -260,10 +260,7 @@ p_value_label <- function(value, stopifnot(length(value) <= 1L, "Negative value of 'digits'" = digits > 0) - if (length(value) == 0 || is.na(value) || is.nan(value)) { - return(NA_character_) - } - + # we accept and trim slightly off-range values if (value < 0 && value > -1e-12) { value <- 0 } else if (value > 1 && value < 1 + 1e-12) { @@ -273,12 +270,21 @@ p_value_label <- function(value, value <- NA_real_ } + if (length(value) == 0 || is.na(value) || is.nan(value)) { + return(NA_character_) + } + if (digits < 2) { warning("'digits < 2' Likely information loss!") } p.value <- value - if (is.na(subscript) | !is.character(subscript) | length(subscript) != 1L) { + if (is.null(subscript) | is.na(subscript) | + !is.character(subscript) | length(subscript) != 1L) { + subscript <- "" + } + if (is.null(superscript) | is.na(superscript) | + !is.character(superscript) | length(superscript) != 1L) { subscript <- "" } @@ -324,10 +330,10 @@ p_value_label <- function(value, paste(paste(ifelse(small.p, "_p_", "_P_"), ifelse(subscript != "", paste("", subscript, "", sep = ""), - character()), + ""), ifelse(superscript != "", paste("", superscript, "", sep = ""), - character()), + ""), sep = ""), ifelse(p.value < 10^(-digits), sprintf_dm("\"%.*f\"", digits, 10^(-digits), @@ -597,15 +603,21 @@ r_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + # we accept and trim slightly off-range values if (method == "pearson") { - stopifnot(length(value) == 1L, - "Out of range R" = is.na(value) || abs(value) <= 1, - "Negative value of 'digits'" = digits > 0) - } else { - stopifnot(length(value) == 1L, - "Negative value of 'digits'" = digits > 0) + if (value < -1 && value > -1 - 1e-12) { + value <- 0 + } else if (value > 1 && value < 1 + 1e-12) { + value <- 1 + } else if (value < 1 || value > 1) { + warning("Out of range P-value replaced by 'NA'") + value <- NA_real_ + } } + stopifnot(length(value) == 1L, + "Negative value of 'digits'" = digits > 0) + if (digits < 2) { warning("'digits < 2' Likely information loss!") } @@ -631,7 +643,7 @@ r_label <- function(value, } else if (method == "spearman") { "italic(rho)" } else { - character(0) + method } if (abs(r.value) < 10^(-digits) & r.value != 0) { @@ -652,7 +664,7 @@ r_label <- function(value, } else if (method == "spearman") { ifelse(output.type == "text", "rho", "\rho") } else { - character(0) + method } if (abs(r.value) < 10^(-digits) & r.value != 0) { @@ -673,7 +685,7 @@ r_label <- function(value, } else if (method == "spearman") { "_τ_" } else { - character(0) + method } if (abs(r.value) < 10^(-digits) & r.value != 0) { @@ -692,6 +704,7 @@ r_label <- function(value, #' @examples #' rr_label(value = 0.95, digits = 2, output.type = "expression") #' rr_label(value = 0.0001, digits = 2, output.type = "expression") +#' rr_label(value = 1e-17, digits = Inf, output.type = "expression") #' #' @export #' @@ -702,9 +715,19 @@ rr_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + # we accept and trim slightly off-range values + if (value < 0 && value > -1e-12) { + value <- 0 + } else if (value > 1 && value < 1 + 1e-12) { + value <- 1 + } else if (value < 0 || value > 1) { + warning("Out of range P-value replaced by 'NA'") + value <- NA_real_ + } + stopifnot(length(value) == 1L, - "Out of range R^2" = is.na(value) | (value >= 0 & value <= 1), - "Negative value of 'digits'" = digits > 0) + "Negative value of 'digits'" = digits > 0) + if (digits < 2) { warning("'digits < 2' Likely information loss!") } @@ -765,6 +788,15 @@ adj_rr_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + # we accept and trim slightly off-range values + # adjusted R^2 can have values < 0! + if (value > 1 && value < 1 + 1e-12) { + value <- 1 + } else if (value > 1) { + warning("Out of range adjusted R^2-value replaced by 'NA'") + value <- NA_real_ + } + stopifnot(length(value) == 1L, "Negative value of 'digits'" = digits > 0) if (digits < 2) { @@ -823,8 +855,17 @@ rr_ci_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + # we accept and trim slightly off-range values + if (value[1] < 0 && value[1] > -1e-12) { + value[1] <- 0 + } else if (value[2] > 1 && value[2] < 1 + 1e-12) { + value[2] <- 1 + } else if (any(value < 0 | value > 1)) { + warning("Out of range R^2-value replaced by 'NA'") + value[value < 0 | value > 1] <- NA_real_ + } + stopifnot(length(value) == 2L, - "Out of range R^2-value" = all(is.na(value) | (value >= 0 & value <= 1)), "Negative value of 'digits'" = digits > 0) if (digits < 2) { warning("'digits < 2' Likely information loss!") @@ -886,8 +927,17 @@ r_ci_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + # we accept and trim slightly off-range values + if (value[1] < -1 && value[1] > -1 - 1e-12) { + value <- 0 + } else if (value[2] > 1 && value[2] < 1 + 1e-12) { + value <- 1 + } else if (any(value < -1 || value > 1)) { + warning("Out of range P-value replaced by 'NA'") + value[value < -1 || value > 1] <- NA_real_ + } + stopifnot(length(value) == 2L, - "Out of range R-value" = all(is.na(value) | (value >= -1 & value <= 1)), "Negative value of 'digits'" = digits > 0) if (digits < 2) { warning("'digits < 2' Likely information loss!") From bac0c316daf42261dfc1c21af1a6f952784e1888 Mon Sep 17 00:00:00 2001 From: Pedro Aphalo Date: Tue, 14 May 2024 20:37:31 +0300 Subject: [PATCH 2/3] Test, fix bugs, tidy up code for argument validation Tested good --- R/utilities-labels.R | 160 ++++++++++++++++++++++++++----------------- 1 file changed, 97 insertions(+), 63 deletions(-) diff --git a/R/utilities-labels.R b/R/utilities-labels.R index 4afcfc7..32ff793 100644 --- a/R/utilities-labels.R +++ b/R/utilities-labels.R @@ -135,12 +135,13 @@ plain_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { - stopifnot(length(value) == 1L) - - if (is.na(value) || is.nan(value)) { + if (length(value) == 0 || any(is.na(value) | is.nan(value))) { return(NA_character_) } + stopifnot(length(value) == 1L, + "Negative value of 'digits'" = digits >= 0) + if (is.integer(value)) { value.char <- as.character(value) } else { @@ -171,12 +172,13 @@ italic_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { - stopifnot(length(value) == 1L) - - if (is.na(value) || is.nan(value)) { + if (length(value) == 0 || is.na(value) || is.nan(value)) { return(NA_character_) } + stopifnot(length(value) == 1L, + "Negative value of 'digits'" = digits >= 0) + if (is.integer(value)) { value.char <- as.character(value) } else { @@ -207,12 +209,13 @@ bold_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { - stopifnot(length(value) == 1L) - - if (is.na(value) || is.nan(value)) { + if (length(value) == 0 || is.na(value) || is.nan(value)) { return(NA_character_) } + stopifnot(length(value) == 1L, + "Negative value of 'digits'" = digits >= 0) + if (is.integer(value)) { value.char <- as.character(value) } else { @@ -257,8 +260,12 @@ p_value_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { - stopifnot(length(value) <= 1L, - "Negative value of 'digits'" = digits > 0) + if (length(value) == 0 || is.na(value) || is.nan(value)) { + return(NA_character_) + } + + stopifnot(length(value) == 1L, + "Negative value of 'digits'" = digits >= 0) # we accept and trim slightly off-range values if (value < 0 && value > -1e-12) { @@ -266,11 +273,7 @@ p_value_label <- function(value, } else if (value > 1 && value < 1 + 1e-12) { value <- 1 } else if (value < 0 || value > 1) { - warning("Out of range P-value replaced by 'NA'") - value <- NA_real_ - } - - if (length(value) == 0 || is.na(value) || is.nan(value)) { + warning("Out of range P-value (", value, ") replaced by NA") return(NA_character_) } @@ -368,14 +371,22 @@ f_value_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + if (length(value) == 0 || is.na(value) || is.nan(value)) { + return(NA_character_) + } + stopifnot(length(value) == 1L, - "Out of range F-value" = is.na(value) | value >= 0) - f.value <- value + "Negative value of 'digits'" = digits >= 0) - if (is.na(f.value) || is.nan(f.value)) { + if (value < 0 && value > -1e-12) { + value <- 0 + } else if (value < 0) { + warning("Out of range F-value (", value, ") replaced by NA") return(NA_character_) } + f.value <- value + if (is.null(df1) || is.null(df2)) { return(italic_label(value = f.value, value.name = "F", @@ -430,13 +441,13 @@ t_value_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { - stopifnot(length(value) == 1L) - t.value <- value - - if (is.na(t.value) || is.nan(t.value)) { + if (length(value) == 0 || is.na(value) || is.nan(value)) { return(NA_character_) } + stopifnot(length(value) == 1L) + t.value <- value + if (is.null(df)) { return(italic_label(value = t.value, value.name = "t", @@ -523,6 +534,7 @@ var_value_label <- function(value, fixed = FALSE, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + value.name <- if (output.type == "expression") { "sigma^2" } else if (output.type %in% c("latex", "tex", "tikz")) { @@ -546,6 +558,7 @@ sd_value_label <- function(value, fixed = FALSE, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + value.name <- if (output.type == "expression") { "sigma" } else if (output.type %in% c("latex", "tex", "tikz")) { @@ -603,20 +616,25 @@ r_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + if (length(value) == 0 || is.na(value) || is.nan(value)) { + return(NA_character_) + } + + stopifnot(length(value) == 1L, + "Negative value of 'digits'" = digits >= 0) + # we accept and trim slightly off-range values if (method == "pearson") { if (value < -1 && value > -1 - 1e-12) { - value <- 0 + value <- -1 } else if (value > 1 && value < 1 + 1e-12) { value <- 1 - } else if (value < 1 || value > 1) { - warning("Out of range P-value replaced by 'NA'") - value <- NA_real_ + } else if (value < -1 || value > 1) { + warning("Out of range R-value (", value, ") replaced by 'NA'") + return(NA_character_) } } - stopifnot(length(value) == 1L, - "Negative value of 'digits'" = digits > 0) if (digits < 2) { warning("'digits < 2' Likely information loss!") @@ -715,28 +733,28 @@ rr_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + if (length(value) == 0 || is.na(value) || is.nan(value)) { + return(NA_character_) + } + + stopifnot(length(value) <= 1L, + "Negative value of 'digits'" = digits >= 0) + # we accept and trim slightly off-range values if (value < 0 && value > -1e-12) { value <- 0 } else if (value > 1 && value < 1 + 1e-12) { value <- 1 } else if (value < 0 || value > 1) { - warning("Out of range P-value replaced by 'NA'") - value <- NA_real_ + warning("Out of range R^2-value (", value, ") replaced by 'NA'") + return(NA_character_) } - stopifnot(length(value) == 1L, - "Negative value of 'digits'" = digits > 0) - if (digits < 2) { warning("'digits < 2' Likely information loss!") } rr.value <- value - if (is.na(rr.value) || is.nan(rr.value)) { - return(NA_character_) - } - rr.value.char <- value2char(value = rr.value, digits = digits, output.type = output.type, @@ -788,26 +806,27 @@ adj_rr_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + if (length(value) == 0 || is.na(value) || is.nan(value)) { + return(NA_character_) + } + + stopifnot(length(value) == 1L, + "Negative value of 'digits'" = digits >= 0) + # we accept and trim slightly off-range values # adjusted R^2 can have values < 0! if (value > 1 && value < 1 + 1e-12) { value <- 1 } else if (value > 1) { - warning("Out of range adjusted R^2-value replaced by 'NA'") - value <- NA_real_ + warning("Out of range adjusted R^2-value (", value, ") replaced by 'NA'") + return(NA_character_) } - stopifnot(length(value) == 1L, - "Negative value of 'digits'" = digits > 0) if (digits < 2) { warning("'digits < 2' Likely information loss!") } adj.rr.value <- value - if (is.na(adj.rr.value) || is.nan(adj.rr.value)) { - return(NA_character_) - } - adj.rr.value.char <- value2char(value = adj.rr.value, digits = digits, output.type = output.type, @@ -855,18 +874,30 @@ rr_ci_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + if (length(value) == 0 || any(is.na(value) | is.nan(value))) { + return(NA_character_) + } + + stopifnot("A CI label needs 'value' of length two" = length(value) == 2L, + "Negative value of 'digits'" = digits >= 0) + + if (is.unsorted(value)) { + warning("Found unsorted CI limits; sorting them") + value <- sort(value) + } + # we accept and trim slightly off-range values if (value[1] < 0 && value[1] > -1e-12) { value[1] <- 0 } else if (value[2] > 1 && value[2] < 1 + 1e-12) { value[2] <- 1 } else if (any(value < 0 | value > 1)) { - warning("Out of range R^2-value replaced by 'NA'") + warning("Out of range R^2-values (", value, ") replaced by 'NA's") value[value < 0 | value > 1] <- NA_real_ } stopifnot(length(value) == 2L, - "Negative value of 'digits'" = digits > 0) + "Negative value of 'digits'" = digits >= 0) if (digits < 2) { warning("'digits < 2' Likely information loss!") } @@ -876,10 +907,6 @@ rr_ci_label <- function(value, range.sep <- c("." = ", ", "," = "; ")[decimal.mark] } - if (any(is.na(rr.ci.value) | is.nan(rr.ci.value))) { - return(NA_character_) - } - rr.ci.char <- character(2) rr.ci.char[1] <- value2char(value = rr.ci.value[1], digits = digits, @@ -914,6 +941,7 @@ rr_ci_label <- function(value, #' r_ci_label(value = c(-0.3, 0.4), conf.level = 0.95) #' r_ci_label(value = c(-0.3, 0.4), conf.level = 0.95, output.type = "text") #' r_ci_label(value = c(-0.3, 0.4), conf.level = 0.95, range.sep = ",") +#' r_ci_label(value = c(-1.0, 0.4), conf.level = 0.95, range.sep = ",") #' #' @export #' @@ -927,31 +955,37 @@ r_ci_label <- function(value, output.type = "expression", decimal.mark = getOption("OutDec", default = ".")) { + if (length(value) == 0 || any(is.na(value) | is.nan(value))) { + return(NA_character_) + } + + stopifnot("A CI label needs a 'value' of length two" = length(value) == 2L, + "Negative value of 'digits'" = digits >= 0) + + if (is.unsorted(value)) { + warning("Found unsorted CI limits; sorting them") + value <- sort(value) + } + # we accept and trim slightly off-range values if (value[1] < -1 && value[1] > -1 - 1e-12) { - value <- 0 + value <- -1 } else if (value[2] > 1 && value[2] < 1 + 1e-12) { value <- 1 - } else if (any(value < -1 || value > 1)) { - warning("Out of range P-value replaced by 'NA'") - value[value < -1 || value > 1] <- NA_real_ + } else if (any(value < -1 | value > 1)) { + warning("Out of range R-values (", value, ") replaced by 'NA's") + value[value < -1 | value > 1] <- NA_real_ } - stopifnot(length(value) == 2L, - "Negative value of 'digits'" = digits > 0) if (digits < 2) { warning("'digits < 2' Likely information loss!") } - r.ci.value <- sort(value) + r.ci.value <- value if (is.null(range.sep)) { range.sep <- c("." = ", ", "," = "; ")[decimal.mark] } - if (any(is.na(r.ci.value) | is.nan(r.ci.value))) { - return(NA_character_) - } - r.ci.char <- character(2) r.ci.char[1] <- value2char(value = r.ci.value[1], digits = digits, From b16915cdc90ef35ac2e358316cd1afdc42b1db0a Mon Sep 17 00:00:00 2001 From: Pedro Aphalo Date: Tue, 14 May 2024 22:06:42 +0300 Subject: [PATCH 3/3] NEWS, documentation --- DESCRIPTION | 4 ++-- NEWS.md | 6 +++--- man/plain_label.Rd | 2 ++ 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1422c47..76c6703 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: ggpmisc Type: Package Title: Miscellaneous Extensions to 'ggplot2' -Version: 0.5.6.9001 -Date: 2024-05-13 +Version: 0.5.6.9002 +Date: 2024-05-14 Authors@R: c( person("Pedro J.", "Aphalo", email = "pedro.aphalo@helsinki.fi", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-3385-972X")), diff --git a/NEWS.md b/NEWS.md index c99deb1..374e53e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,9 +7,9 @@ editor_options: # ggpmisc 0.6.0 - Support decreasing-power order of polynomial terms in `stat_poly_eq()`, `stat_quant_eq()` and `stat_ma_eq()`. -- Return new `qtl.label` for quantiles, separately from `grp.label`, which now works as in the other statistics based on a pseudo aesthetic. **This is a code breaking change affecting some plots.** -- Small visual changes in the formatting labels also affect some plots as the default number of digits was increased in a few cases. New utility functions used in `stat_poly_eq()`, `stat_ma_eq()`, `stat_quant_eq()`, `stat_correlation()`, and `stat_multcomp()`. -- Export new utility functions used for formatting parameter estimates into character strings. +- Return new `qtl.label` for quantiles, separately from `grp.label`, which now works as in the other statistics, only based on a pseudo aesthetic. **This is a code breaking change affecting some plots.** +- Statistics `stat_poly_eq()`, `stat_ma_eq()`, `stat_quant_eq()`, `stat_correlation()`, and `stat_multcomp()` where in part rewritten, introducing small visual changes in the formatting of labels, including changes in the default number of digits. +- Export new utility functions, used internally for formatting parameter estimates into character strings. # ggpmisc 0.5.6 diff --git a/man/plain_label.Rd b/man/plain_label.Rd index c099894..b791061 100644 --- a/man/plain_label.Rd +++ b/man/plain_label.Rd @@ -217,6 +217,7 @@ r_label(value = 0.95, digits = 2, method = "spearman") rr_label(value = 0.95, digits = 2, output.type = "expression") rr_label(value = 0.0001, digits = 2, output.type = "expression") +rr_label(value = 1e-17, digits = Inf, output.type = "expression") adj_rr_label(value = 0.95, digits = 2, output.type = "expression") adj_rr_label(value = 0.0001, digits = 2, output.type = "expression") @@ -228,6 +229,7 @@ rr_ci_label(value = c(0.3, 0.4), conf.level = 0.95, range.sep = ",") r_ci_label(value = c(-0.3, 0.4), conf.level = 0.95) r_ci_label(value = c(-0.3, 0.4), conf.level = 0.95, output.type = "text") r_ci_label(value = c(-0.3, 0.4), conf.level = 0.95, range.sep = ",") +r_ci_label(value = c(-1.0, 0.4), conf.level = 0.95, range.sep = ",") } \seealso{