clean up smoothness

DESCRIPTION

@@ -33,7 +33,8 @@ Imports:
     tidyr,
     GpGp,
     cli,
-    progress
+    progress,
+    glue
 RoxygenNote: 7.3.1
 Depends: 
     R (>= 2.10)

NAMESPACE

@@ -1,5 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(print,smoothness_res)
+S3method(tbl_sum,smoothness_res)
 export("%>%")
 export(add_anchor)
 export(add_anno)
@@ -58,6 +60,7 @@ importFrom(magrittr,"%>%")
 importFrom(progress,progress_bar)
 importFrom(rlang,.data)
 importFrom(rlang,`:=`)
+importFrom(tibble,tbl_sum)
 importFrom(tidyr,unnest)
 importFrom(tourr,basis_random)
 importFrom(tourr,interpolate)

R/calc-smoothness.R

@@ -7,18 +7,26 @@
 #' @param best a matrix, the theoretical best projection matrix, used to calculate
 #' projection distance with the simulated random bases.
 #' @param data matrix, the data to be projected
-#' @inheritParams GpGp::fit_model
 #' @param other_gp_params list, other parameters to be passed to \code{GpGp::fit_model}
+#' @param verbose logical, whether to print optimisation progression when
+#' fitting the Gaussian process
+ #' @inheritParams GpGp::fit_model
+#' @inheritParams base::format
+#' @inheritParams base::print
+#' @examples
+#' library(tourr)
+#' calc_smoothness("holes", data = pipe1000)
+#'
 #' @rdname optim
 #' @export
 calc_smoothness <- function(idx, data = sine1000, n_basis = 300, n = 6, d = 2,
                             best = matrix(c(0, 0, 0, 0, 1, 0,
                                             0, 0, 0, 0, 0, 1), nrow = 6),
                             start_parms = c(0.001, 0.5, 2, 2),
-                            other_gp_params = NULL
-                            ){
+                            other_gp_params = NULL, verbose = FALSE){
 
   # sample basis
+  cli::cli_inform("sample random bases ...")
   idx <- dplyr::sym(idx)
   set.seed(123)
   seed <- sample(1: 10000, size = n_basis)
@@ -29,19 +37,49 @@ calc_smoothness <- function(idx, data = sine1000, n_basis = 300, n = 6, d = 2,
                   index_val = get(idx)()(as.matrix(data) %*% basis))
 
   # construct gp
+  cli::cli_inform("fit the gaussian process ...")
+  if (verbose) {silent <- FALSE} else {silent <- TRUE}
   gp_params <- list(y = basis_df$index_val, locs = basis_df$proj_dist,
                     X = as.matrix(rep(1,nrow(basis_df))),
                     start_parms = start_parms, covfun_name = "matern_isotropic",
+                    silent = silent,
                     other_gp_params
                     )
   fit <- do.call("fit_model", gp_params)
-  cov_params <- tibble::as_tibble_row(fit$covparms, .name_repair = "unique")
+
+  cov_params <- suppressMessages(tibble::as_tibble_row(fit$covparms, .name_repair = "unique"))
   colnames(cov_params) <- c("variance", "range", "smoothness", "nugget", "convergence")
   cov_params <-  cov_params |> dplyr::mutate(convergence = fit$conv, idx = as.character(idx))
 
   # return
-  list(basis_df = basis_df, gp_res = list(fit), measure = cov_params)
+  res <- tibble::as_tibble(cov_params)
+  attr(res, "basis_df") <- basis_df |> dplyr::ungroup()
+  attr(res, "gp_res") <- fit
+  attr(res, "data") <- tibble::as_tibble(data)
+  attr(res, "best_basis") <- best
+
+  class(res) <- c("smoothness_res", class(res))
+  return(res)
 }
 
 
 globalVariables(c("basis", "sine1000"))
+
+
+#' @rdname optim
+#' @export
+print.smoothness_res <- function(x, width = NULL, ...){
+  writeLines(format(x, width = width, ...))
+}
+
+#' @importFrom tibble tbl_sum
+#' @rdname optim
+#' @export
+tbl_sum.smoothness_res <- function(x){
+
+  cli::cli_rule()
+  dim <- attr(x, "basis_df")$basis[[1]] |> dim()
+  line <- glue::glue("No. of basis = ", nrow(attr(x, "basis_df")),
+                     ", bases [", dim[1], " x ", dim[2], "]")
+  c("Smoothness" = line)
+}

_pkgdown.yml

@@ -46,7 +46,7 @@ reference:
   contents:
   - starts_with("boa")
   - starts_with("holes")
-- title: Calculate optimisation features
+- title: Calculate projection pursuit optimisation properties
   contents:
   - starts_with("calc")
 - title: Miscellaneous

docs/pkgdown.yml

@@ -2,7 +2,7 @@ pandoc: 3.1.1
 pkgdown: 2.0.8
 pkgdown_sha: ~
 articles: {}
-last_built: 2024-06-04T22:06Z
+last_built: 2024-06-14T18:54Z
 urls:
   reference: https://huizezhang-sherry.github.io/ferrn/reference
   article: https://huizezhang-sherry.github.io/ferrn/articles