add basis dimension and option to turn on significance stars to the o…

…utput; part of #214

R/overview.R

@@ -11,7 +11,7 @@
 #' @param parametric logical; include the model parametric terms in the
 #'   overview?
 #' @param random_effects tests of fully penalized smooth terms (those with a
-#'   zero-dimensaionl null space, e.g. random effects) are computationally
+#'   zero-dimensional null space, e.g. random effects) are computationally
 #'   expensive and for large data sets producing these p values can take a
 #'   very long time. If `random_effects = FALSE`, the tests of the expensive
 #'   terms will be skipped.
@@ -25,16 +25,17 @@
 #'   matrix of the parameter estimates is used.
 #' @param accuracy numeric; accuracy with which to report p values, with p
 #'   values below this value displayed as `"< accuracy"`.
+#' @param stars logical; should significance stars be added to the output?
 #'
 #' @export
 #' @rdname overview
 #' @importFrom dplyr %>% select
 #' @importFrom tibble rownames_to_column as_tibble add_column
 #' @importFrom tidyselect matches
 #' @importFrom rlang set_names .data
-#' 
+#'
 #' @examples
-#' 
+#'
 #' load_mgcv()
 #' \dontshow{
 #' op <- options(pillar.sigfig = 3, cli.unicode = FALSE)
@@ -49,34 +50,47 @@
 `overview.gam` <- function(model, parametric = TRUE, random_effects = TRUE,
                            dispersion = NULL, frequentist = FALSE,
                            accuracy = 0.001,
+                           stars = FALSE,
                            ...) {
     smry <- summary(model, dispersion = dispersion, re.test = random_effects,
                     freq = frequentist)
-    nms <- c("term", "type", "edf", "statistic", "p.value")
+    nms <- c("term", "type", "k", "edf", "statistic", "p.value")
 
     # smooth terms
     types <- vapply(model$smooth, smooth_type, character(1))
+    dfs <- vapply(model$smooth, basis_dim, double(1))
     out <- as.data.frame(smry$s.table) %>%
       rownames_to_column() %>%
       as_tibble() %>%
       select(!matches("Ref.df")) %>%
-      add_column(type = types, .after = 1L)
+      add_column(type = types, k = dfs, .after = 1L)
 
     # parametric terms
     para <- NULL
     if (isTRUE(parametric) && ! is.null(smry$pTerms.table)) {
+        nr <- nrow(smry$pTerms.table)
         para <- as.data.frame(smry$pTerms.table) %>%
           rownames_to_column() %>%
           as_tibble() %>%
           rename(edf = "df") %>%
-          add_column(type = rep("parametric", nrow(smry$pTerms.table)),
-                     .after = 1L)
+          add_column(type = rep("parametric", nr), k = rep(NA_real_, nr),
+            .after = 1L)
         out <- bind_rows(para, out)
     }
-
     out <- set_names(out, nms)
 
-    out <- mutate(out, p.value = format.pval(.data$p.value, eps = accuracy))
+    if (stars) {
+      sstars <- symnum(out$p.value, corr = FALSE, na = FALSE,
+        cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
+        symbols = c("***", "**", "*", ".", " "))
+      out <- mutate(out,
+        #p = .data$p.value,
+        p.value = format.pval(.data$p.value, eps = accuracy),
+        stars = sstars) # not sure why as.character(sstars) is wrong here "***"
+      attr(out, "legend") <- attr(sstars, "legend")
+    } else {
+      out <- mutate(out, p.value = format.pval(.data$p.value, eps = accuracy))
+    }
 
     class(out) <- append(class(out), values = "overview", after = 0)
     out
@@ -114,8 +128,22 @@
   c("Big Additive Model" = pluralize("with {nrow(x)} term{?s}"))
 }
 
-#' @export
 #' @importFrom cli style_dim
+#' @exportS3Method tbl_format_header overview
 tbl_format_header.overview <- function(x, setup, ...) {
     style_dim("\n", names(setup$tbl_sum), " ", setup$tbl_sum, "\n")
 }
+
+#' @importFrom pillar style_subtle tbl_format_footer
+#' @exportS3Method tbl_format_footer overview
+`tbl_format_footer.overview` <- function(x, setup, ...) {
+    default_footer <- NextMethod()
+    star_leg <- attr(x, "legend")
+    out <- if (!is.null(star_leg)) {
+      leg_footer <- style_subtle(paste0("\n# ", star_leg))
+      c(default_footer, leg_footer)
+    } else {
+      default_footer
+    }
+    out
+}