Skip to content

Commit

Permalink
Accommodate Array objects from the arrow package
Browse files Browse the repository at this point in the history 
See Bioconductor/DelayedArray#114 for more
information.
  • Loading branch information
@hpages
hpages committed Mar 3, 2024
1 parent bace321 commit 59b8f4e
Show file tree
Hide file tree
Showing 4 changed files with 180 additions and 7 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ Description: The S4Arrays package defines the Array virtual class to be
biocViews: Infrastructure, DataRepresentation
URL: https://bioconductor.org/packages/S4Arrays
BugReports: https://github.com/Bioconductor/S4Arrays/issues
Version: 1.2.0
Version: 1.2.1
License: Artistic-2.0
Encoding: UTF-8
Authors@R: person("Hervé", "Pagès", role=c("aut", "cre"),
Expand Down
26 changes: 26 additions & 0 deletions R/Array-class.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -78,6 +78,19 @@ setMethod("[[", "Array",

.from_Array_to_matrix <- function(x)
{
if (!isS4(x)) {
## The arrow package does not define any as.matrix method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array in the extract_array.R
## file for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" S3 as.matrix method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.matrix(x))
}
}
x_dim <- dim(x)
if (sum(x_dim != 1L) > 2L)
stop(wmsg(class(x), " object has more than 2 effective dimensions ",
Expand All @@ -100,6 +113,19 @@ setMethod("as.matrix", "Array", .from_Array_to_matrix)
### t() will work out-of-the-box on any Array derivative that supports aperm().
t.Array <- function(x)
{
if (!isS4(x)) {
## The arrow package does not define any t method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array in the extract_array.R
## file for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" S3 t method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::t(x))
}
}
if (length(dim(x)) != 2L)
stop(wmsg("the ", class(x), " object to transpose ",
"must have exactly 2 dimensions"))
Expand Down
5 changes: 5 additions & 0 deletions R/dim-tuning-utils.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -91,6 +91,11 @@ tune_dimnames <- function(dimnames, dim_tuner)
### only if 'x' has at most one effective dimension.
.drop_Array <- function(x)
{
if (!isS4(x)) {
## Avoid S4 dispatch on Array objects that are not S4 objects (e.g.
## Array objects from the arrow package).
return(base::drop(x))
}
is_effective <- dim(x) != 1L
if (sum(is_effective) <= 1L)
return(drop(as.array(x))) # ordinary vector
Expand Down
154 changes: 148 additions & 6 deletions R/extract_array.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -188,6 +188,18 @@ extract_array_by_Nindex <- function(x, Nindex)
### object back into an ordinary array.
.from_Array_to_array <- function(x, drop=FALSE)
{
if (!isS4(x)) {
## The arrow package does not define any as.array method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array below for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" S3 as.array method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.array(x))
}
}
if (!isTRUEorFALSE(drop))
stop("'drop' must be TRUE or FALSE")
index <- vector("list", length=length(dim(x)))
Expand All @@ -211,39 +223,169 @@ setMethod("as.array", "Array", .from_Array_to_array)

### S3/S4 combo for as.data.frame.Array
as.data.frame.Array <- function(x, row.names=NULL, optional=FALSE, ...)
{
if (!isS4(x)) {
## The arrow package does not define any as.data.frame method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array below for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.data.frame S3 method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.data.frame(x, row.names=row.names,
optional=optional, ...))
}
}
as.data.frame(as.array(x, drop=TRUE),
row.names=row.names, optional=optional, ...)
}
setMethod("as.data.frame", "Array", as.data.frame.Array)

### S3/S4 combo for as.vector.Array
### Note that without the hack below this method breaks as.vector() on an
### Array object (R6 object) from the arrow package. See
### https://github.com/Bioconductor/DelayedArray/issues/114 for the details.
as.vector.Array <- function(x, mode="any")
{
if (!isS4(x)) {
## Ugly hack to accomodate Array objects (R6 objects) from the arrow
## package. For these objects, class() returns the following:
## > library(arrow)
## > my_array <- Array$create(1:10)
## > class(my_array)
## [1] "Array" "ArrowDatum" "ArrowObject" "R6"
## Note that the arrow package does NOT define the as.vector.Arrow
## method. Instead it defines the as.vector.ArrowDatum method which
## is what we must call here. However, we don't call
## arrow:::as.vector.ArrowDatum explicitly to avoid introducing a
## dependency on the arrow package, and also to make the hack a little
## bit more generic.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.vector S3 method (will be as.vector.ArrowDatum
## if 'x' is an arrow::Array object).
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.vector(x, mode))
}
}
ans <- as.array(x, drop=TRUE)
as.vector(ans, mode=mode)
}
setMethod("as.vector", "Array", as.vector.Array)

### S3/S4 combo for as.logical.Array
as.logical.Array <- function(x, ...) as.vector(x, mode="logical", ...)
as.logical.Array <- function(x, ...)
{
if (!isS4(x)) {
## The arrow package does not define any as.logical method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array above for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.logical S3 method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.logical(x, ...))
}
}
as.vector(x, mode="logical", ...)
}
setMethod("as.logical", "Array", as.logical.Array)

### S3/S4 combo for as.integer.Array
as.integer.Array <- function(x, ...) as.vector(x, mode="integer", ...)
as.integer.Array <- function(x, ...)
{
if (!isS4(x)) {
## Ugly hack to accomodate Array objects (R6 objects) from the arrow
## package. See as.vector.Array above for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.integer S3 method (will be
## arrow:::as.integer.ArrowDatum if 'x' is an arrow::Array object).
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.integer(x, ...))
}
}
as.vector(x, mode="integer", ...)
}
setMethod("as.integer", "Array", as.integer.Array)

### S3/S4 combo for as.numeric.Array
as.numeric.Array <- function(x, ...) as.vector(x, mode="numeric", ...)
as.numeric.Array <- function(x, ...)
{
if (!isS4(x)) {
## The arrow package does not define any as.numeric method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array above for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.numeric S3 method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.numeric(x, ...))
}
}
as.vector(x, mode="numeric", ...)
}
setMethod("as.numeric", "Array", as.numeric.Array)

### S3/S4 combo for as.complex.Array
as.complex.Array <- function(x, ...) as.vector(x, mode="complex", ...)
as.complex.Array <- function(x, ...)
{
if (!isS4(x)) {
## The arrow package does not define any as.complex method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array above for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.complex S3 method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.complex(x, ...))
}
}
as.vector(x, mode="complex", ...)
}
setMethod("as.complex", "Array", as.complex.Array)

### S3/S4 combo for as.character.Array
as.character.Array <- function(x, ...) as.vector(x, mode="character", ...)
as.character.Array <- function(x, ...)
{
if (!isS4(x)) {
## Ugly hack to accomodate Array objects (R6 objects) from the arrow
## package. See as.vector.Array above for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.character S3 method (will be
## as.character.ArrowDatum if 'x' is an arrow::Array object).
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.character(x, ...))
}
}
as.vector(x, mode="character", ...)
}
setMethod("as.character", "Array", as.character.Array)

### S3/S4 combo for as.raw.Array
as.raw.Array <- function(x) as.vector(x, mode="raw")
as.raw.Array <- function(x)
{
if (!isS4(x)) {
## The arrow package does not define any as.raw method for
## arrow::Array objects (or their ancestors) at the moment, so this is
## a preventive hack only. See as.vector.Array above for the details.
x_class <- class(x)
if (length(x_class) >= 2L) {
## Call "next" as.raw S3 method.
class(x) <- tail(x_class, n=-1L)
on.exit(class(x) <- x_class)
return(base::as.raw(x))
}
}
as.vector(x, mode="raw")
}
setMethod("as.raw", "Array", as.raw.Array)

0 comments on commit 59b8f4e

Please sign in to comment.