better X/Y selection in chart.nls and autoplot.nls

Merge branch 'main' of github.com:SciViews/modelit # Conflicts: # NEWS.md
SciViews · Nov 23, 2024 · 5090a05 · 5090a05
2 parents 6291384 + 94ac67b
commit 5090a05
Show file tree

Hide file tree

Showing 12 changed files with 82 additions and 77 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -2,6 +2,8 @@
 
 -   Better selection of X and Y variables in `chart.nls()` and `autoplot.nls()`.
 
+-   Bug correction in `tabularise()` for **lm** and **glm** object. Managing a conflict between `auto.labs=` and `equation=`.
+
 # modelit 1.4.5
 
 -   Remotes SciViews/equatiomatic instead of datalorax/equatiomatic for correct compilation on R-Universe (no remote dependency required to yonicd/texPreview).

diff --git a/R/tabularise.anova.R b/R/tabularise.anova.R
@@ -48,9 +48,9 @@ env = parent.frame()) {
 
   # Extract labels of data or origdata
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(x = NULL, labs = labs)
+    labs <- tabularise:::.labels2(x = NULL, labs = labs)
   }
 
   # Turn an object into a tidy tibble
@@ -198,9 +198,9 @@ kind = "ft", env = parent.frame()) {
 
   # Extract labels
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(NULL, labs = labs)
+    labs <- tabularise:::.labels2(NULL, labs = labs)
   }
 
   # Turn an object into a tidy tibble

diff --git a/R/tabularise.glm.R b/R/tabularise.glm.R
@@ -60,9 +60,9 @@ lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame())
   # co <- as.data.frame(rbind(coef(data)))
 
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(x = data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(x = NULL, labs = labs)
+    labs <- tabularise:::.labels2(x = NULL, labs = labs)
   }
 
   # Create the flextable object
@@ -76,7 +76,7 @@ lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame())
     if (!is.null(labs)) {
       equa <- equation(data, swap_var_names =  labs, ...)
     } else {
-      equa <- equation(data, ...)
+      equa <- equation(data, auto.labs = FALSE,...)
     }
 
     ft <- .add_header(ft, data = data, info_lang = info_lang, header = header,
@@ -216,9 +216,9 @@ env = parent.frame()) {
 
   # Extract labels of data or origdata
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(x = data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(x = NULL, labs = labs)
+    labs <- tabularise:::.labels2(x = NULL, labs = labs)
   }
 
   # Turn an object into a tidy tibble
@@ -251,7 +251,7 @@ env = parent.frame()) {
     if (!is.null(labs)) {
       equa <- equation(data, swap_var_names =  labs, ...)
     } else {
-      equa <- equation(data, ...)
+      equa <- equation(data, auto.labs = FALSE, ...)
     }
 
     ft <- .add_header(ft, data = data, info_lang = info_lang, header = header,
@@ -348,9 +348,9 @@ tabularise_glance.glm <- function(data, header = TRUE, title = NULL,
 
   # Extract labels off data or origdata
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(x = data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(x = NULL, labs = labs)
+    labs <- tabularise:::.labels2(x = NULL, labs = labs)
   }
 
   # Turn an object into a tidy tibble
@@ -370,7 +370,7 @@ tabularise_glance.glm <- function(data, header = TRUE, title = NULL,
     if (!is.null(labs)) {
       equa <- equation(data, swap_var_names =  labs, ...)
     } else {
-      equa <- equation(data, ...)
+      equa <- equation(data, auto.labs = FALSE, ...)
     }
 
     ft <- .add_header(ft, data = data, info_lang = info_lang, header = header,

diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R
@@ -58,9 +58,9 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL,
   # co <- as.data.frame(rbind(coef(data)))
 
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(x = data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(x = NULL, labs = labs)
+    labs <- tabularise:::.labels2(x = NULL, labs = labs)
   }
 
   # Create the flextable object
@@ -73,7 +73,7 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL,
     if (!is.null(labs)) {
       equa <- equation(data, swap_var_names =  labs, ...)
     } else {
-      equa <- equation(data, ...)
+      equa <- equation(data, auto.labs = FALSE, ...)
     }
 
     ft <- .add_header(ft, data = data, info_lang = info_lang, header = header,
@@ -192,9 +192,9 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL,
 
   # Extract labels off data or origdata
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(x = data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(x = NULL, labs = labs)
+    labs <- tabularise:::.labels2(x = NULL, labs = labs)
   }
 
   # Turn an object into a tidy tibble
@@ -224,7 +224,7 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL,
     if (!is.null(labs)) {
       equa <- equation(data, swap_var_names =  labs, ...)
     } else {
-      equa <- equation(data, ...)
+      equa <- equation(data, auto.labs = FALSE, ...)
     }
 
     ft <- .add_header(ft, data = data, info_lang = info_lang, header = header,
@@ -317,9 +317,9 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL,
 
   # Extract labels of data or origdata
   if (isTRUE(auto.labs)) {
-    labs <- .labels2(x = data, origdata = origdata, labs = labs)
+    labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs)
   } else {
-    labs <- .labels2(x = NULL, labs = labs)
+    labs <- tabularise:::.labels2(x = NULL, labs = labs)
   }
 
   # Turn an object into a tidy tibble
@@ -339,7 +339,7 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL,
     if (!is.null(labs)) {
       equa <- equation(data, swap_var_names = labs, ...)
     } else {
-      equa <- equation(data, ...)
+      equa <- equation(data, auto.labs = FALSE, ...)
     }
 
     ft <- .add_header(ft, data = data, info_lang = info_lang, header = header,

diff --git a/R/utils.R b/R/utils.R
@@ -25,48 +25,48 @@ align = "right", ...) {
 
 # TODO: this is duplicated in tabularise -> export from there and reuse here!
 # Extract labels and units
-.labels <- function(x, units = TRUE, ...) {
-  labels <- sapply(x, data.io::label, units = units)
-
-  if (any(labels != "")) {
-    # Use a \n before labels and the units
-    if (isTRUE(units))
-      labels <- sub(" +\\[([^]]+)\\]$", "\n [\\1]", labels)
-    # set names if empty
-    labels[labels == ""] <- names(x)[labels == ""]
-    # Specific case for I() using in a formula
-    labels[grepl("^I\\(.*\\)$", names(labels))] <- names(labels)[grepl("^I\\(.*\\)$", names(labels))]
-  }
-
-  if (all(labels == ""))
-    labels <- NULL
-
-  labels
-}
-
-.labels2 <- function(x, origdata = NULL, labs = NULL) {
-
-  #labs_auto <- NULL
-  if (is.null(origdata)) {
-    labs_auto <- .labels(x$model)
-  } else {
-    labs_auto <- .labels(origdata)
-  }
-
-  if (!is.null(labs)) {
-    if (!is.character(labs))
-      stop("labs is not character vector")
-    if (is.null(names(labs)))
-      stop("labs must be named character vector")
-    if (any(names(labs) %in% ""))
-      stop("all element must be named")
-    labs_res <- c(labs, labs_auto[!names(labs_auto) %in% names(labs)])
-  } else {
-    labs_res <- labs_auto
-  }
-
-  labs_res
-}
+# .labels <- function(x, units = TRUE, ...) {
+#   labels <- sapply(x, data.io::label, units = units)
+#
+#   if (any(labels != "")) {
+#     # Use a \n before labels and the units
+#     if (isTRUE(units))
+#       labels <- sub(" +\\[([^]]+)\\]$", "\n [\\1]", labels)
+#     # set names if empty
+#     labels[labels == ""] <- names(x)[labels == ""]
+#     # Specific case for I() using in a formula
+#     labels[grepl("^I\\(.*\\)$", names(labels))] <- names(labels)[grepl("^I\\(.*\\)$", names(labels))]
+#   }
+#
+#   if (all(labels == ""))
+#     labels <- NULL
+#
+#   labels
+# }
+
+# .labels2 <- function(x, origdata = NULL, labs = NULL) {
+#
+#   #labs_auto <- NULL
+#   if (is.null(origdata)) {
+#     labs_auto <- .labels(x$model)
+#   } else {
+#     labs_auto <- .labels(origdata)
+#   }
+#
+#   if (!is.null(labs)) {
+#     if (!is.character(labs))
+#       stop("labs is not character vector")
+#     if (is.null(names(labs)))
+#       stop("labs must be named character vector")
+#     if (any(names(labs) %in% ""))
+#       stop("all element must be named")
+#     labs_res <- c(labs, labs_auto[!names(labs_auto) %in% names(labs)])
+#   } else {
+#     labs_res <- labs_auto
+#   }
+#
+#   labs_res
+# }
 
 # Retrieve model parameters
 .params_equa <- function(x, intercept = "alpha", greek = "beta") {

diff --git a/README.Rmd b/README.Rmd
@@ -60,15 +60,13 @@ trees_lm <- lm(Volume ~ Girth + I(Girth^2), data = trees)
 summary(trees_lm)
 ```
 
-
-<!-- This produces an error !
 Here is the summary of the model, using `tabularise()`:
 
-``{r}
+```{r, eval=FALSE}
 summary(trees_lm) |> tabularise()
-``
+```
 
--->
+<img src="man/figures/README-tabularise-chunk.png" width="80%"/>
 
 The model can be viewed using `chart()`:
 

diff --git a/README.md b/README.md
@@ -96,28 +96,29 @@ summary(trees_lm)
 #> F-statistic: 350.5 on 2 and 28 DF,  p-value: < 2.2e-16
 ```
 
-<!-- This produces an error !
 Here is the summary of the model, using `tabularise()`:
-&#10;``{r}
+
+``` r
 summary(trees_lm) |> tabularise()
-``
-&#10;-->
+```
+
+<img src="man/figures/README-tabularise-chunk.png" width="80%"/>
 
 The model can be viewed using `chart()`:
 
 ``` r
 chart(trees_lm)
 ```
 
-<img src="man/figures/README-unnamed-chunk-6-1.png" width="80%" />
+<img src="man/figures/README-unnamed-chunk-7-1.png" width="80%" />
 
 Residual analysis plots can also be carried out with `chart()`.
 
 ``` r
 chart$residuals(trees_lm)
 ```
 
-<img src="man/figures/README-unnamed-chunk-7-1.png" width="80%" />
+<img src="man/figures/README-unnamed-chunk-8-1.png" width="80%" />
 
 For further examples, please, refer to the help pages at
 <https://www.sciviews.org/modelit/>.

diff --git a/TODO.md b/TODO.md
@@ -1,8 +1,12 @@
 # modelit To Do list
 
--   `tabularise()` for **merMod** and **summary.merMod** objects (< `lme4::glmer()`)
+-   Using labels with `equation.nls()`
 
--   `tabularise()` for **anova** and **aov** => rework and decide where to place these ({inferit}, {modelit}, elsewhere...?) + `car::Anova()`. Also, there is no proper `tabularise_default()` method for **aov** objects
+-   Propose specific tables with `tabularise()` for **lm**, **nls**, **glm** objects, etc. with {tinytable} in addition to {flextable}
+
+-   `tabularise()` for **merMod** and **summary.merMod** objects (\< `lme4::glmer()`)
+
+-   `tabularise()` for **anova** and **aov** =\> rework and decide where to place these ({inferit}, {modelit}, elsewhere...?) + `car::Anova()`. Also, there is no proper `tabularise_default()` method for **aov** objects
 
 -   `chart()` for **lm** with categorical variables
 

diff --git a/man/figures/README-tabularise-chunk.png b/man/figures/README-tabularise-chunk.png
diff --git a/man/figures/README-unnamed-chunk-6-1.png b/man/figures/README-unnamed-chunk-6-1.png
diff --git a/man/figures/README-unnamed-chunk-7-1.png b/man/figures/README-unnamed-chunk-7-1.png
diff --git a/man/figures/README-unnamed-chunk-8-1.png b/man/figures/README-unnamed-chunk-8-1.png