From c00da7d387fc6c865b401a1efbf5c8bc51e6f5e6 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 18:34:14 +0200 Subject: [PATCH] simplified point/shape subsetting --- NAMESPACE | 1 - R/PointFrame.R | 60 ----------------------------------- R/ShapeFrame.R | 48 ++++++++++++++++++++-------- man/PointFrame.Rd | 18 ----------- man/ShapeFrame.Rd | 25 ++++++++++----- tests/testthat/test-methods.R | 4 +-- 6 files changed, 53 insertions(+), 103 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 181cfcfe..c4a4d487 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -177,7 +177,6 @@ importFrom(methods,setClassUnion) importFrom(methods,setReplaceMethod) importFrom(reticulate,import) importFrom(rlang,"!!") -importFrom(rlang,":=") importFrom(rlang,.data) importFrom(sf,"st_geometry<-") importFrom(sf,st_as_sf) diff --git a/R/PointFrame.R b/R/PointFrame.R index 32912474..8814632f 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -86,66 +86,6 @@ setMethod("[[", "PointFrame", \(x, i, ...) { #' @exportMethod $ setMethod("$", "PointFrame", \(x, name) do.call(`[[`, list(x, name))) -# sub ---- - -#' @rdname PointFrame -#' @export -setMethod("[", c("PointFrame", "missing", "ANY"), - \(x, i, j, ...) x[seq_len(nrow(x)), j]) - -#' @rdname PointFrame -#' @export -setMethod("[", c("PointFrame", "ANY", "missing"), - \(x, i, j, ...) x[i, seq_len(ncol(x))]) - -#' @rdname PointFrame -#' @export -setMethod("[", c("PointFrame", "missing", "missing"), - \(x, i, j, ...) x[seq_len(nrow(x)), seq_len(ncol(x))]) - -#' @rdname PointFrame -#' @export -setMethod("[", c("PointFrame", "ANY", "character"), \(x, i, j, ...) { - stopifnot(all(j %in% names(x))) - x[i, match(j, names(x))] -}) - -#' @export -#' @rdname PointFrame -setMethod("[", c("PointFrame", "logical", "ANY"), \(x, i, j, ...) { - if (isTRUE(i)) return(x[, j]) - if (isFALSE(i)) return(x[0, j]) - stopifnot(length(i) != length(x)) - x[seq_len(nrow(x))[i], j] -}) - -#' @rdname PointFrame -#' @importFrom dplyr mutate filter select all_of -#' @export -setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { - i <- seq_len(nrow(x))[i] - j <- seq_len(ncol(x))[j] - cn <- make.unique(c(names(x), "rn"))[ncol(x) + 1] - x@data <- x@data |> - mutate(!!cn := row_number()) |> - filter(.data[[cn]] %in% i) |> - select(-all_of(cn)) |> - select(all_of(j)) - # # TODO: this worked having assumed indices are unique; - # # they may not be, so subsetting on a query doesn't work - # .i <- `__null_dask_index__` <- NULL # R CMD check - # i <- seq_len(nrow(x))[i] - # x@data <- data(x) |> - # mutate(.i=1+`__null_dask_index__`) |> - # filter(.i %in% i) |> - # select(-.i) - # # make sure this is kept in any case - # ndi <- "__null_dask_index__" - # ndi <- match(ndi, colnames(x@data), nomatch=0) - # x@data <- x@data |> select(all_of(c(j, ndi))) - return(x) -}) - #' @rdname PointFrame #' @importFrom BiocGenerics as.data.frame #' @export diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index 81fbaf6d..9adca156 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -111,31 +111,51 @@ setMethod("geom_type", "ShapeFrame", \(x) { #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "missing", "ANY"), - \(x, i, j, ...) x[seq_len(nrow(x)), j]) +setMethod("[", c("sdFrame", "missing", "missing"), + \(x, i, j, ...) x[TRUE, TRUE]) +#' @rdname ShapeFrame +#' @export +setMethod("[", c("sdFrame", "missing", "ANY"), + \(x, i, j, ...) x[seq_len(nrow(x)), j]) + #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "ANY", "missing"), +setMethod("[", c("sdFrame", "ANY", "missing"), \(x, i, j, ...) x[i, seq_len(ncol(x))]) +#' @export #' @rdname ShapeFrame +setMethod("[", c("sdFrame", "logical", "ANY"), \(x, i, j, ...) { + if (isTRUE(i)) return(x[, j]) + if (isFALSE(i)) return(x[0, j]) + stopifnot(length(i) != nrow(x)) + x[seq_len(nrow(x))[i], j] +}) + #' @export -setMethod("[", c("ShapeFrame", "missing", "missing"), - \(x, i, j, ...) x[seq_len(nrow(x)), seq_len(ncol(x))]) +#' @rdname ShapeFrame +setMethod("[", c("sdFrame", "ANY", "logical"), \(x, i, j, ...) { + if (isTRUE(j)) return(x[i, ]) + if (isFALSE(j)) return(x[i, 0]) + stopifnot(length(j) != ncol(x)) + x[i, seq_len(nrow(x))[j]] +}) #' @rdname ShapeFrame -#' @importFrom dplyr mutate filter select all_of row_number -#' @importFrom rlang .data !! := #' @export -setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { - i <- seq_len(nrow(x))[i] - j <- seq_len(ncol(x))[j] - cn <- make.unique(c(names(x), "rn"))[ncol(x) + 1] +setMethod("[", c("sdFrame", "ANY", "character"), \(x, i, j, ...) { + stopifnot(all(j %in% names(x))) + x[i, match(j, names(x))] +}) + +#' @rdname ShapeFrame +#' @importFrom dplyr row_number select all_of +#' @export +setMethod("[", c("sdFrame", "numeric", "numeric"), \(x, i, j, ...) { + if (any(i < 0)) stop("negative row-subsetting not supported") x@data <- x@data |> - mutate(!!cn := row_number()) |> - filter(.data[[cn]] %in% i) |> - select(-all_of(cn)) |> + filter(row_number() %in% i) |> select(all_of(j)) return(x) }) diff --git a/man/PointFrame.Rd b/man/PointFrame.Rd index a88b90bf..c389a776 100644 --- a/man/PointFrame.Rd +++ b/man/PointFrame.Rd @@ -7,12 +7,6 @@ \alias{length,PointFrame-method} \alias{[[,PointFrame,ANY,ANY-method} \alias{$,PointFrame-method} -\alias{[,PointFrame,missing,ANY,ANY-method} -\alias{[,PointFrame,ANY,missing,ANY-method} -\alias{[,PointFrame,missing,missing,ANY-method} -\alias{[,PointFrame,ANY,character,ANY-method} -\alias{[,PointFrame,logical,ANY,ANY-method} -\alias{[,PointFrame,numeric,numeric,ANY-method} \alias{as.data.frame,PointFrame-method} \title{The `PointFrame` class} \usage{ @@ -28,18 +22,6 @@ PointFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \S4method{$}{PointFrame}(x, name) -\S4method{[}{PointFrame,missing,ANY,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{[}{PointFrame,ANY,missing,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{[}{PointFrame,missing,missing,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{[}{PointFrame,ANY,character,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{[}{PointFrame,logical,ANY,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{[}{PointFrame,numeric,numeric,ANY}(x, i, j, ..., drop = TRUE) - \S4method{as.data.frame}{PointFrame}(x) } \arguments{ diff --git a/man/ShapeFrame.Rd b/man/ShapeFrame.Rd index 26ea7c52..ccc30008 100644 --- a/man/ShapeFrame.Rd +++ b/man/ShapeFrame.Rd @@ -10,10 +10,13 @@ \alias{.DollarNames.ShapeFrame} \alias{$,ShapeFrame-method} \alias{geom_type,ShapeFrame-method} -\alias{[,ShapeFrame,missing,ANY,ANY-method} -\alias{[,ShapeFrame,ANY,missing,ANY-method} -\alias{[,ShapeFrame,missing,missing,ANY-method} -\alias{[,ShapeFrame,numeric,numeric,ANY-method} +\alias{[,sdFrame,missing,missing,ANY-method} +\alias{[,sdFrame,missing,ANY,ANY-method} +\alias{[,sdFrame,ANY,missing,ANY-method} +\alias{[,sdFrame,logical,ANY,ANY-method} +\alias{[,sdFrame,ANY,logical,ANY-method} +\alias{[,sdFrame,ANY,character,ANY-method} +\alias{[,sdFrame,numeric,numeric,ANY-method} \title{The `ShapeFrame` class} \usage{ ShapeFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) @@ -32,13 +35,19 @@ ShapeFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \S4method{geom_type}{ShapeFrame}(x) -\S4method{[}{ShapeFrame,missing,ANY,ANY}(x, i, j, ..., drop = TRUE) +\S4method{[}{sdFrame,missing,missing,ANY}(x, i, j, ..., drop = TRUE) -\S4method{[}{ShapeFrame,ANY,missing,ANY}(x, i, j, ..., drop = TRUE) +\S4method{[}{sdFrame,missing,ANY,ANY}(x, i, j, ..., drop = TRUE) -\S4method{[}{ShapeFrame,missing,missing,ANY}(x, i, j, ..., drop = TRUE) +\S4method{[}{sdFrame,ANY,missing,ANY}(x, i, j, ..., drop = TRUE) -\S4method{[}{ShapeFrame,numeric,numeric,ANY}(x, i, j, ..., drop = TRUE) +\S4method{[}{sdFrame,logical,ANY,ANY}(x, i, j, ..., drop = TRUE) + +\S4method{[}{sdFrame,ANY,logical,ANY}(x, i, j, ..., drop = TRUE) + +\S4method{[}{sdFrame,ANY,character,ANY}(x, i, j, ..., drop = TRUE) + +\S4method{[}{sdFrame,numeric,numeric,ANY}(x, i, j, ..., drop = TRUE) } \arguments{ \item{data}{\code{duckspatial_df} for on-disk representation, diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 09c4898a..43f50e74 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -163,6 +163,7 @@ test_that("$", { test_that("[,Shape/PointFrame", { y <- shape(x) + expect_error(y[-1,]) # one index subsets in vector-like fashion expect_equal(dim(y[1]), c(1, ncol(y))) # two indices subset in array-like fashion @@ -170,9 +171,9 @@ test_that("[,Shape/PointFrame", { expect_equal(ncol(y[,1]), 1) # no i expect_equal(dim(y[1,1]), c(1,1)) # both expect_identical(dim(y[,]), dim(y)) # none - expect_equal(nrow(y[-1,]), nrow(y)-1) # neg y <- point(x) + expect_error(y[-1,]) # one index subsets in vector-like fashion expect_equal(dim(y[1]), c(1, ncol(y))) # two indices subset in array-like fashion @@ -180,7 +181,6 @@ test_that("[,Shape/PointFrame", { expect_equal(ncol(y[,1]), 2) # no i (preserve geometry) expect_equal(dim(y[1,1]), c(1,2)) # both expect_identical(dim(y[,]), dim(y)) # none - expect_equal(nrow(y[-1,]), nrow(y)-1) # neg }) test_that("[,LabelArray", {