Merge pull request #13 from UchidaMizuki/keep-class-#12

Keep class #12

DESCRIPTION

@@ -31,7 +31,7 @@ Suggests:
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 Depends: 
-    R (>= 2.10)
+    R (>= 4.4)
 URL: https://github.com/UchidaMizuki/dibble,
     https://uchidamizuki.github.io/dibble/
 BugReports: https://github.com/UchidaMizuki/dibble/issues

NAMESPACE

@@ -3,9 +3,6 @@
 S3method("!",ddf_col)
 S3method("!",tbl_ddf)
 S3method("$",tbl_ddf)
-S3method("%*%",ddf_col)
-S3method("%*%",default)
-S3method("%*%",tbl_ddf)
 S3method("[",tbl_ddf)
 S3method("[[",tbl_ddf)
 S3method("diag<-",ddf_col)
@@ -115,7 +112,6 @@ S3method(zeros,array)
 S3method(zeros,ddf_col)
 S3method(zeros,default)
 S3method(zeros,tbl_ddf)
-export("%*%")
 export("diag<-")
 export(apply)
 export(as_dibble)

R/apply.R

@@ -59,6 +59,8 @@ apply.ddf_col <- function(X, MARGIN, FUN, ...) {
     MARGIN <- vec_match(MARGIN, names(dim_names))
   }
 
+  class <- class(X)
   X <- apply(as.array(X), MARGIN, FUN, ...)
-  new_ddf_col(X, dim_names[MARGIN])
+  new_ddf_col(X, dim_names[MARGIN],
+              class = class)
 }

R/broadcast.R

@@ -50,19 +50,23 @@ broadcast.default <- function(x,
 #' @rdname broadcast
 #' @export
 broadcast.ddf_col <- function(x, dim_names, ...) {
+  class <- class(x)
   brdcst_dim_names <- broadcast_dim_names(x, dim_names)
   x <- broadcast_dibble(x, brdcst_dim_names$broadcast)
 
-  new_ddf_col(x, brdcst_dim_names$new_dim_names)
+  new_ddf_col(x, brdcst_dim_names$new_dim_names,
+              class = class)
 }
 
 #' @rdname broadcast
 #' @export
 broadcast.tbl_ddf <- function(x, dim_names, ...) {
+  class <- class(x)
   brdcst_dim_names <- broadcast_dim_names(x, dim_names)
   x <- broadcast_dibble(x, brdcst_dim_names$broadcast)
 
-  new_tbl_ddf(x, brdcst_dim_names$new_dim_names)
+  new_tbl_ddf(x, brdcst_dim_names$new_dim_names,
+              class = class)
 }
 
 broadcast_dibble <- function(x, brdcst) {

R/ddf_col.R

@@ -1,7 +1,8 @@
-new_ddf_col <- function(x, dim_names) {
+new_ddf_col <- function(x, dim_names,
+                        class = character()) {
   structure(x,
             dim_names = dim_names,
-            class = "ddf_col")
+            class = c(setdiff(class, "ddf_col"), "ddf_col"))
 }
 
 as_ddf_col <- function(x, ...) {

R/dibble-package.R

@@ -1,3 +1,8 @@
+#' @keywords internal
+"_PACKAGE"
+
+## usethis namespace: start
 #' @import rlang
 #' @import vctrs
+## usethis namespace: end
 NULL

R/dibble.R

@@ -52,7 +52,7 @@ dibble <- function(...,
                           x
                         }
                       })
-  args <- vec_c(!!!args)
+  args <- list_unchop(args)
 
   if (!is_named(args)) {
     stopifnot(
@@ -236,15 +236,18 @@ aperm_dibble <- function(a, perm, ...) {
     }
   }
 
+  class <- class(a)
   if (is_ddf_col(a)) {
     a <- aperm(as.array(a), perm, ...)
-    new_ddf_col(a, new_dim_names)
+    new_ddf_col(a, new_dim_names,
+                class = class)
   } else {
     a <- purrr::modify(undibble(a),
                        function(x) {
                          aperm(x, perm, ...)
                        })
-    new_tbl_ddf(a, new_dim_names)
+    new_tbl_ddf(a, new_dim_names,
+                class = class)
   }
 }
 
@@ -280,17 +283,20 @@ slice_dibble <- function(.data, ...) {
                            })
   names(dim_names) <- axes
 
+  class <- class(.data)
   if (is_ddf_col(.data)) {
     new_ddf_col(exec(`[`, .data, !!!locs,
                      drop = FALSE),
-                dim_names = dim_names)
+                dim_names = dim_names,
+                class = class)
   } else if (is_tbl_ddf(.data)) {
     new_tbl_ddf(purrr::modify(undibble(.data),
                               function(x) {
                                 exec(`[`, x, !!!locs,
                                      drop = FALSE)
                               }),
-                dim_names = dim_names)
+                dim_names = dim_names,
+                class = class)
   }
 }
 
@@ -393,9 +399,10 @@ find_index <- function(x, names) {
   } else {
     stopifnot(is_call(x))
 
-    out <- purrr::map(x[-1L], find_index,
-                      names = names)
-    vec_c(!!!out)
+    out <- purrr::map(as.list(x[-1L]),
+                      \(x) find_index(x,
+                                      names = names))
+    list_unchop(out)
   }
 }
 

R/dim_names.R

@@ -57,12 +57,12 @@ is_dim_names <- function(x) {
 }
 
 union_dim_names <- function(x) {
-  x <- vec_c(!!!x)
+  x <- list_unchop(x)
   nms <- names(x)
   nms_unique <- unique(nms)
   out <- purrr::map(nms_unique,
                     function(nm_unique) {
-                      unique(vec_c(!!!unname(x[nms == nm_unique])))
+                      unique(list_unchop(unname(x[nms == nm_unique])))
                     })
   names(out) <- nms_unique
   out

R/extremes.R

@@ -49,14 +49,16 @@ pmax.tbl_ddf <- function(...,
 
 pmax_dibble <- function(..., na.rm) {
   args <- list2(...)
+  class <- class(args[[1]])
   dim_names <- union_dim_names(purrr::map(args, dimnames))
   args <- purrr::modify(args,
                         function(x) {
                           as.array(broadcast(x, dim_names))
                         })
 
-  new_ddf_col(exec(base::pmax, !!!args),
-              dim_names)
+  new_ddf_col(exec(base::pmax, !!!args, na.rm = na.rm),
+              dim_names,
+              class = setdiff(class, "tbl_ddf"))
 }
 
 #' @rdname extremes
@@ -92,12 +94,14 @@ pmin.tbl_ddf <- function(...,
 
 pmin_dibble <- function(..., na.rm) {
   args <- list2(...)
+  class <- class(args[[1]])
   dim_names <- union_dim_names(purrr::map(args, dimnames))
   args <- purrr::modify(args,
                         function(x) {
                           as.array(broadcast(x, dim_names))
                         })
 
-  new_ddf_col(exec(base::pmin, !!!args),
-              dim_names)
+  new_ddf_col(exec(base::pmin, !!!args, na.rm = na.rm),
+              dim_names,
+              class = setdiff(class, "tbl_ddf"))
 }

R/ifelse.R

@@ -36,11 +36,13 @@ ifelse.tbl_ddf <- function(test, yes, no, ...) {
 #' @rdname ifelse
 #' @export
 ifelse.ddf_col <- function(test, yes, no, ...) {
+  class <- class(test)
   dim_names <- union_dim_names(list(dimnames(test), dimnames(yes), dimnames(no)))
   test <- as.array(broadcast(test, dim_names))
   yes <- as.array(broadcast(yes, dim_names))
   no <- as.array(broadcast(no, dim_names))
 
   new_ddf_col(ifelse(test, yes, no),
-              dim_names)
+              dim_names,
+              class = class)
 }

R/matrix.R

@@ -1,84 +1,15 @@
-#' Matrix Multiplication
-#'
-#' Multiplies two matrices, if they are conformable.
-#'
-#' `%*%` overrides [`base::%*%`] to make it generic. The default method
-#' calls the base version.
-#'
-#' @param x Numeric or complex dibble, matrices or vectors.
-#' @param y Numeric or complex dibble, matrices or vectors.
-#'
-#' @return A dibble if x or y is a dibble of a matrix. A scalar numeric if both
-#' x and y are dibbles of vectors. See [`base::%*%`] for the return value of the
-#' default method.
-#'
-#' @seealso [`base::%*%`]
-#'
-#' @export
-`%*%` <- function(x, y) {
-  UseMethod("%*%")
-}
-
-#' @export
-`%*%.default` <- function(x, y) {
-  base::`%*%`(x, y)
-}
-
-#' @export
-`%*%.tbl_ddf` <- function(x, y) {
-  matmult_dibble(x, y)
-}
-
-#' @export
-`%*%.ddf_col` <- function(x, y) {
-  matmult_dibble(x, y)
-}
-
-matmult_dibble <- function(x, y) {
-  x <- as_ddf_col(x)
-  y <- as_ddf_col(y)
-
-  dim_names_x <- dimnames(x)
-  dim_names_y <- dimnames(y)
-
-  if (vec_size(dim_names_x) == 1L) {
-    x <- as.vector(x)
-    dim_names_x <- NULL
-  } else {
-    x <- as.matrix(x)
-    dim_names_x <- dim_names_x[1L]
-  }
-
-  if (vec_size(dim_names_y) == 1L) {
-    y <- as.vector(y)
-    dim_names_y <- NULL
-  } else {
-    y <- as.matrix(y)
-    dim_names_y <- dim_names_y[2L]
-  }
-
-  new_dim_names <- purrr::compact(c(dim_names_x, dim_names_y))
-
-  out <- x %*% y
-
-  if (vec_is_empty(new_dim_names)) {
-    as.vector(out)
-  } else {
-    dim(out) <- list_sizes_unnamed(new_dim_names)
-    new_ddf_col(out, new_dim_names)
-  }
-}
-
 #' @export
 t.tbl_ddf <- function(x) {
   new_tbl_ddf(purrr::modify(undibble(x), t),
-              rev(dimnames(x)))
+              rev(dimnames(x)),
+              class = class(x))
 }
 
 #' @export
 t.ddf_col <- function(x) {
   new_ddf_col(t(undibble(x)),
-              rev(dimnames(x)))
+              rev(dimnames(x)),
+              class = class(x))
 }
 
 #' @export
@@ -94,8 +25,10 @@ solve.tbl_ddf <- function(a, b, ...) {
 solve.ddf_col <- function(a, b, ...) {
   if (is_missing(b)) {
     dim_names <- dimnames(a)
+    class <- class(a)
     a <- undibble(a)
-    new_ddf_col(unname(solve(a)), rev(dim_names))
+    new_ddf_col(unname(solve(a)), rev(dim_names),
+                class = class)
   } else {
     NextMethod()
   }
@@ -185,7 +118,8 @@ diag.ddf_col <- function(x, axes, ...) {
     names(new_dim_names) <- axes
   }
   new_ddf_col(diag(as.array(x), ...),
-              new_dim_names)
+              new_dim_names,
+              class = class(x))
 }
 
 #' @rdname diag
@@ -220,9 +154,11 @@ diag.ddf_col <- function(x, axes, ...) {
     is.null(dim_names_value) || is_scalar_list(dim_names_value)
   )
 
+  class <- class(x)
   x <- as.array(x)
   diag(x) <- as.vector(broadcast(value, dim_names[1L]))
-  new_ddf_col(x, dim_names)
+  new_ddf_col(x, dim_names,
+              class = class)
 }
 
 #' Basic matrices and arrays

R/methods.R

@@ -6,6 +6,7 @@ Ops_dibble <- function(e1, e2) {
     is_ddf_col_e1 <- is_ddf_col(e1)
   }
 
+  class <- class(e1)
   if (is_missing(e2)) {
     new_dim_names <- dimnames(e1)
   } else {
@@ -35,7 +36,45 @@ Ops_dibble <- function(e1, e2) {
     }
   }
 
-  new_ddf_col(NextMethod(), new_dim_names)
+  new_ddf_col(NextMethod(), new_dim_names,
+              class = class)
+}
+
+matrixOps_dibble <- function(e1, e2) {
+  e1 <- as_ddf_col(e1)
+  e2 <- as_ddf_col(e2)
+
+  class <- class(e1)
+  dim_names_x <- dimnames(e1)
+  dim_names_y <- dimnames(e2)
+
+  if (vec_size(dim_names_x) == 1L) {
+    e1 <- as.vector(e1)
+    dim_names_x <- NULL
+  } else {
+    e1 <- as.matrix(e1)
+    dim_names_x <- dim_names_x[1L]
+  }
+
+  if (vec_size(dim_names_y) == 1L) {
+    e2 <- as.vector(e2)
+    dim_names_y <- NULL
+  } else {
+    e2 <- as.matrix(e2)
+    dim_names_y <- dim_names_y[2L]
+  }
+
+  new_dim_names <- purrr::compact(c(dim_names_x, dim_names_y))
+
+  out <- NextMethod()
+
+  if (vec_is_empty(new_dim_names)) {
+    as.vector(out)
+  } else {
+    dim(out) <- list_sizes_unnamed(new_dim_names)
+    new_ddf_col(out, new_dim_names,
+                class = class)
+  }
 }
 
 methods_dibble <- function(x, ...) {