add parameter to control output class

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ripserr
 Title: Calculate Persistent Homology with Ripser-Based Engines
-Version: 1.0.0
+Version: 1.0.0.0001
 Authors@R:
     c(person(given = "Raoul R.",
              family = "Wadhwa",
@@ -79,7 +79,8 @@ Depends: R (>= 3.5.0)
 Imports: 
     Rcpp (>= 1.0),
     stats (>= 3.0),
-    utils (>= 3.0)
+    utils (>= 3.0),
+    phutil
 Suggests: 
     covr (>= 3.5),
     knitr (>= 1.29),

NAMESPACE

@@ -25,6 +25,7 @@ export(vietoris_rips.matrix)
 export(vietoris_rips.numeric)
 export(vietoris_rips.ts)
 importFrom(Rcpp,sourceCpp)
+importFrom(phutil,as_persistence)
 importFrom(utils,head)
 importFrom(utils,tail)
 useDynLib(ripserr)

NEWS.md

@@ -1,3 +1,10 @@
+# next version
+
+## output class
+
+The new `return_class` parameter allows the user to specify whether to output persistence data in the legacy `'PHom'` class or the `'persistence'` class from {phutil}.
+It defaults to `'PHom'` but will switch to `'persistence'` when the `'PHom'` class is deprecated in a future version.
+
 # ripserr 1.0.0
 
 This major version replaces an outdated version of the Ripser C++ library with its current version.

R/PHom.R

@@ -128,6 +128,8 @@ valid_colval <- function(df, val, val_name) {
 #' # print feature details to confirm accuracy
 #' print.data.frame(df_phom)
 PHom <- function(x, dim_col = 1, birth_col = 2, death_col = 3) {
+  # deprecate_PHom()
+
   ## basic parameter checks (column nums/names are valid, etc.)
   if (!is.data.frame(x)) {
     x <- as.data.frame(x)
@@ -201,6 +203,8 @@ as.PHom <- function(x, dim_col = 1, birth_col = 2, death_col = 3) {
 #' # confirm that persistence data is NOT valid
 #' is.PHom(df)
 is.PHom <- function(x) {
+  # deprecate_PHom()
+
   # use validate to implement checks
   return(
     validate_PHom(x = x, error = FALSE)
@@ -309,3 +313,11 @@ tail.PHom <- function(x, ...) {
   x <- as.data.frame(x)
   tail(x, ...)
 }
+
+# deprecate_PHom <- function() {
+#   lifecycle::deprecate_soft(
+#     "1.0.0",
+#     I("'PHom' class"),
+#     with = I("'persistence' from the {phutil} package")
+#   )
+# }

R/cubical.R

@@ -18,22 +18,23 @@
 #' @param ... other relevant parameters
 #' @rdname cubical
 #' @export cubical
-#' @return `PHom` object
+#' @return `"PHom"` or `"persistence"` object
 #' @examples 
 #' 
 #' # 2-dim example
 #' dataset <- rnorm(10 ^ 2)
 #' dim(dataset) <- rep(10, 2)
-#' cubical_hom2 <- cubical(dataset)
+#' ( cubical_hom2 <- cubical(dataset) )
 #' 
 #' # 3-dim example
 #' dataset <- rnorm(8 ^ 3)
 #' dim(dataset) <- rep(8, 3)
-#' cubical_hom3 <- cubical(dataset)
+#' ( cubical_hom3 <- cubical(dataset) )
 #' 
 #' # 4-dim example
 #' dataset <- rnorm(5 ^ 4)
 #' dim(dataset) <- rep(5, 4)
+#' ( cubical_hom4 <- cubical(dataset) )
 # Notes:
 # - figure out format from `dataset`
 # - return_format will be "df" (opinionated) w/ additional "PHom" S3 class
@@ -47,9 +48,18 @@ cubical <- function(dataset, ...) {
 #' @param threshold maximum simplicial complex diameter to explore
 #' @param method either `"lj"` (for Link Join) or `"cp"` (for Compute Pairs);
 #'   see Kaji et al. (2020) <https://arxiv.org/abs/2005.12692> for details
+#' @param return_class class of output object; either `"PHom"` (default; legacy)
+#'   or `"persistence"` (from the
+#'   **[phutil](https://cran.r-project.org/package=phutil)** package)
 #' @export cubical.array
 #' @export
-cubical.array <- function(dataset, threshold = 9999, method = "lj", ...) {
+cubical.array <- function(
+    dataset,
+    threshold = 9999,
+    method = "lj",
+    return_class = c("PHom", "persistence"),
+    ...
+) {
   # ensure valid arguments passed
   validate_params_cub(threshold = threshold,
                       method = method)
@@ -103,7 +113,16 @@ cubical.array <- function(dataset, threshold = 9999, method = "lj", ...) {
   }
 
   # convert data frame to a PHom object
-  ans <- new_PHom(ans)
+  ans <- switch(
+    match.arg(return_class),
+    PHom = new_PHom(ans),
+    persistence = as_persistence(
+      ans,
+      engine = "ripserr::cubical",
+      filtration = "cubical",
+      parameters = list(threshold = threshold, method = method)
+    )
+  )
 
   # return
   return(ans)
@@ -125,4 +144,4 @@ cubical.matrix <- function(dataset, ...) {
 
   # return
   return(ans)
-}
+}

R/vietoris_rips.R

@@ -27,11 +27,12 @@
 #' <doi:10.1527/tjsai.D-G72>. Persistent homology of the resulting matrix is
 #' then calculated.
 #'
+#' @importFrom phutil as_persistence
 #' @param dataset object on which to calculate persistent homology
 #' @param ... other relevant parameters
 #' @rdname vietoris_rips
 #' @export vietoris_rips
-#' @return `PHom` object
+#' @return `"PHom"` or `"persistence"` object
 #' @examples
 #'
 #' # create a 2-d point cloud of a circle (100 points)
@@ -40,7 +41,7 @@
 #' pt.cloud <- cbind(cos(rand.angle), sin(rand.angle))
 #'
 #' # calculate persistent homology (num.pts by 3 numeric matrix)
-#' pers.hom <- vietoris_rips(pt.cloud)
+#' ( pers.hom <- vietoris_rips(pt.cloud) )
 # Notes:
 # - figure out format from `dataset`
 # - return_format will be "df" (opinionated) w/ additional "PHom" S3 class
@@ -62,13 +63,16 @@ vietoris_rips.data.frame <- function(dataset, ...) {
   return(ans)
 }
 
+#' @rdname vietoris_rips
 #' @param max_dim maximum dimension of persistent homology features to be
 #'   calculated
 #' @param dim deprecated; passed to `max_dim` or ignored if `max_dim` is
 #'   specified
 #' @param threshold maximum simplicial complex diameter to explore
 #' @param p prime field in which to calculate persistent homology
-#' @rdname vietoris_rips
+#' @param return_class class of output object; either `"PHom"` (default; legacy)
+#'   or `"persistence"` (from the
+#'   **[phutil](https://cran.r-project.org/package=phutil)** package)
 #' @export vietoris_rips.matrix
 #' @export
 vietoris_rips.matrix <- function(
@@ -77,11 +81,23 @@ vietoris_rips.matrix <- function(
     threshold = -1,
     p = 2L,
     dim = NULL,
+    return_class = c("PHom", "persistence"),
     ...
 ) {
 
   # shortcut for special case (only 1 row should return empty PHom)
-  if (nrow(dataset) == 1L) return(new_PHom())
+  if (nrow(dataset) == 1L) {
+    return(switch(
+      match.arg(return_class),
+      PHom = new_PHom(),
+      persistence = as_persistence(
+        matrix(NA_real_, nrow = 0L, ncol = 3L),
+        engine = "ripserr::vietoris_rips",
+        filtration = "Vietoris-Rips",
+        parameters = list(max_dim = max_dim, threshold = threshold, p = p)
+      )
+    ))
+  }
 
   # handle `dim` if passed
   if (! is.null(dim)) {
@@ -111,7 +127,16 @@ vietoris_rips.matrix <- function(
   ans <- ripser_cpp_dist(dataset, max_dim, threshold, 1., p)
 
   # coerce to 'PHom' class
-  ans <- new_PHom(ripser_ans_to_df(ans))
+  ans <- switch(
+    match.arg(return_class),
+    PHom = new_PHom(ripser_ans_to_df(ans)),
+    persistence = as_persistence(
+      ans,
+      engine = "ripserr::vietoris_rips",
+      filtration = "Vietoris-Rips",
+      parameters = list(max_dim = max_dim, threshold = threshold, p = p)
+    )
+  )
 
   # return
   return(ans)
@@ -126,6 +151,7 @@ vietoris_rips.dist <- function(
     threshold = -1,
     p = 2L,
     dim = NULL,
+    return_class = c("PHom", "persistence"),
     ...
 ) {
 
@@ -157,18 +183,26 @@ vietoris_rips.dist <- function(
   ans <- ripser_cpp_dist(dataset, max_dim, threshold, 1., p)
 
   # coerce to 'PHom' class
-  ans <- new_PHom(ripser_ans_to_df(ans))
+  ans <- switch(
+    match.arg(return_class),
+    PHom = new_PHom(ripser_ans_to_df(ans)),
+    persistence = as_persistence(
+      ans,
+      engine = "ripserr::vietoris_rips",
+      filtration = "Vietoris-Rips",
+      parameters = list(max_dim = max_dim, threshold = threshold, p = p)
+    )
+  )
 
   # return
   return(ans)
 }
 
-#' @aliases vietoris_rips.numeric vietoris_rips.ts
+#' @rdname vietoris_rips
 #' @param data_dim desired end data dimension
 #' @param dim_lag time series lag factor between dimensions
 #' @param sample_lag time series lag factor between samples (rows)
 #' @param method currently only allows `"qa"` (quasi-attractor method)
-#' @rdname vietoris_rips
 #' @export vietoris_rips.numeric
 #' @export
 vietoris_rips.numeric <- function(

tests/testthat/test-cubical-2dim.R

@@ -54,4 +54,14 @@ test_that("2-dim cubical returns same values as validated tests", {
   # check means of births and deaths to ensure close enough
   expect_equal(mean(test_output$birth), mean(output_data$birth), tolerance = 0.025)
   expect_equal(mean(test_output$death), mean(output_data$death), tolerance = 0.025)
-})
+})
+
+test_that("specified class is returned", {
+  # calculate 'PHom' object
+  expect_s3_class(cubical(test_data, return_class = "PHom"),
+                  "PHom")
+
+  # calculate 'persistence' object
+  expect_s3_class(cubical(test_data, return_class = "persistence"),
+                  "persistence")
+})