Use utils in stat_correlation(), tested good

DESCRIPTION

@@ -2,7 +2,7 @@ Package: ggpmisc
 Type: Package
 Title: Miscellaneous Extensions to 'ggplot2'
 Version: 0.5.6.9001
-Date: 2024-05-11
+Date: 2024-05-13
 Authors@R:
     c(
     person("Pedro J.", "Aphalo", email = "pedro.aphalo@helsinki.fi", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-3385-972X")),

NAMESPACE

@@ -37,6 +37,7 @@ export(outcome2factor)
 export(p_value_label)
 export(plain_label)
 export(poly2character)
+export(r_ci_label)
 export(r_label)
 export(rr_ci_label)
 export(rr_label)

NEWS.md

@@ -6,10 +6,10 @@ editor_options:
 
 # ggpmisc 0.6.0
 
--   Export functions used for formatting parameter estimates into character strings.
 -   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.
+-   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.
 
 # ggpmisc 0.5.6
 

R/stat-poly-eq.R

@@ -772,6 +772,8 @@ poly_eq_compute_group_fun <- function(data,
         ) {
       rr.confint.low <- rr.confint.high <- NA_real_
     } else {
+      # error handler needs to be added as ci_rsquared() will call stop on non-convergence
+      # or alternatively implement a non-stop version of ci_rsquared()
       rr.confint <-
         confintr::ci_rsquared(x = f.value,
                               df1 = f.df1,

R/utilities-labels.R

@@ -257,9 +257,22 @@ p_value_label <- function(value,
                           output.type = "expression",
                           decimal.mark = getOption("OutDec", default = ".")) {
 
-  stopifnot(length(value) == 1L,
-            "Out of range P-value" = is.na(value) | (value >= 0 & value <= 1),
+  stopifnot(length(value) <= 1L,
             "Negative value of 'digits'" = digits > 0)
+
+  if (length(value) == 0 || is.na(value) || is.nan(value)) {
+    return(NA_character_)
+  }
+
+  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_
+  }
+
   if (digits < 2) {
     warning("'digits < 2' Likely information loss!")
   }
@@ -269,10 +282,6 @@ p_value_label <- function(value,
     subscript <- ""
   }
 
-  if (is.na(p.value) || is.nan(p.value)) {
-    return(NA_character_)
-  }
-
   p.value.char <- value2char(value = p.value,
                              digits = digits,
                              output.type = output.type,
@@ -857,3 +866,66 @@ rr_ci_label <- function(value,
           range.brackets[1], rr.ci.char, range.brackets[2], sep = "")
   }
 }
+
+#' @rdname plain_label
+#'
+#' @examples
+#' 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 = ",")
+#'
+#' @export
+#'
+r_ci_label <- function(value,
+                       conf.level,
+                       small.r = FALSE,
+                       range.brackets = c("[", "]"),
+                       range.sep = NULL,
+                       digits = 2,
+                       fixed = TRUE,
+                       output.type = "expression",
+                       decimal.mark = getOption("OutDec", default = ".")) {
+
+  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!")
+  }
+  r.ci.value <- sort(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,
+                              output.type = "text",
+                              decimal.mark = decimal.mark,
+                              fixed = fixed)
+  r.ci.char[2] <- value2char(value = r.ci.value[2],
+                              digits = digits,
+                              output.type = "text",
+                              decimal.mark = decimal.mark,
+                              fixed = TRUE)
+  r.ci.char <- paste(r.ci.char[1], r.ci.char[2], sep = range.sep)
+  if (as.logical((conf.level * 100) %% 1)) {
+    conf.level.digits = 1L
+  } else {
+    conf.level.digits = 0L
+  }
+  conf.level.char <- as.character(conf.level * 100)
+
+  if (output.type == "expression") {
+    paste("\"", conf.level.char, "% CI ",
+          range.brackets[1], r.ci.char, range.brackets[2], "\"", sep = "")
+  } else if (output.type %in% c("latex", "tex", "text", "tikz", "markdown")) {
+    paste(conf.level.char, "% CI ",
+          range.brackets[1], r.ci.char, range.brackets[2], sep = "")
+  }
+}

test/mising-equation/missing-equation-issue60.R

@@ -0,0 +1,15 @@
+library(tidyverse)
+library(ggpmisc)
+
+test_df <- readRDS("test/mising-equation/ggpmisc_stat_poly_eq_df.rds")
+
+test_df %>%
+  subset(grp == "E") %>%
+  ggplot(aes(x = ref1, y = ref2, colour = grp)) +
+  geom_point() +
+  geom_smooth(method="lm" , color="black", fill='grey', se=TRUE, alpha = 0.5, linewidth =0.5) +
+  stat_poly_eq(use_label("eq"), label.x.npc = 0.055, label.y.npc = 0.88, color = "black",
+               coef.keep.zeros = FALSE) +
+  geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "blue", alpha =0.5) +
+  theme_bw() +
+  facet_wrap(~grp)