Switch ome_zarr class from S3 to S4

NAMESPACE

@@ -1,21 +1,24 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method("[",ome_zarr)
 S3method(dimnames,ome_zarr)
 S3method(plot,ome_zarr)
-S3method(print,ome_zarr)
-export(extract_levels)
 export(ome_read)
 export(ome_validate)
 export(ome_write)
+export(print.ome_zarr)
 exportMethods(ome_write)
+exportMethods(print)
+exportMethods(show)
+import(methods)
 importFrom(EBImage,Image)
 importFrom(EBImage,imageData)
 importFrom(EBImage,resize)
 importFrom(Rarr,read_zarr_array)
 importFrom(Rarr,read_zarr_attributes)
+importFrom(S4Vectors,SimpleList)
 importFrom(ZarrArray,ZarrArray)
 importFrom(cli,cli_abort)
+importFrom(methods,show)
 importFrom(stats,setNames)
 importFrom(utils,head)
 importFrom(utils,tail)

R/AllClasses.R

@@ -0,0 +1,21 @@
+#' @importFrom S4Vectors SimpleList
+setClass(
+  Class = "ome_zarr",
+  contains = "SimpleList",
+  prototype = prototype(elementType = "array")
+)
+
+#' @importFrom utils head
+#' @export
+setMethod("print", "ome_zarr", function(x, level = 1, ...) {
+  cat(
+    "Multiscale OME-Zarr ",
+    x@metadata$type,
+    " (v",
+    x@metadata$version,
+    ") object.\n",
+    sep = ""
+  )
+  cat(sprintf("Scale: %d/%d", level, length(x)), "\n")
+  print(head(x[[level]], rep_len(5, length(dim(x[[level]]))), ...))
+})

R/get_dim_names.R

@@ -14,5 +14,5 @@
 
 #' @export
 dimnames.ome_zarr <- function(x) {
-  attr(x, "dim_names")
+  x@metadata$dim_names
 }

R/print.R → R/methods.R

@@ -3,12 +3,19 @@
 print.ome_zarr <- function(x, level = 1, ...) {
   cat(
     "Multiscale OME-Zarr ",
-    attr(x, "type"),
+    x@metadata$type,
     " (v",
-    attr(x, "version"),
+    x@metadata$version,
     ") object.\n",
     sep = ""
   )
   cat(sprintf("Scale: %d/%d", level, length(x)), "\n")
   print(head(x[[level]], rep_len(5, length(dim(x[[level]]))), ...))
+  invisible(x)
 }
+
+#' @importFrom methods show
+#' @export
+setMethod("show", "ome_zarr", function(object) {
+  print.ome_zarr(object, level = 1)
+})

R/ome_read.R

@@ -54,7 +54,7 @@ ome_read <- function(path, s3_client = NULL, lazy = TRUE, validate = TRUE) {
     img
   })
 
-  x <- mapply(
+  mapply(
     function(img, scale) {
       attr(img, "scale") <- scale
       img
@@ -64,13 +64,9 @@ ome_read <- function(path, s3_client = NULL, lazy = TRUE, validate = TRUE) {
       unlist(x$coordinateTransformations[[1]]$scale)
     }),
     SIMPLIFY = FALSE
-  )
-  class(x) <- "ome_zarr"
-  attr(x, "type") <- type
-  attr(x, "version") <- ome_version
-  if (!is.null(dim_names)) {
-    attr(x, "dim_names") <- dim_names
-  }
-
-  x
+  ) |>
+    new(
+      "ome_zarr",
+      metadata = list(version = ome_version, type = type, dim_names = dim_names)
+    )
 }

R/romeo-package.R

@@ -2,6 +2,7 @@
 "_PACKAGE"
 
 ## usethis namespace: start
+#' @import methods
 ## usethis namespace: end
 
 ## mockable bindings: start

tests/testthat/test-read.R

@@ -19,14 +19,12 @@ test_that("parse ome version", {
 
     # image
     x <- ome_read(td)
-    # TODO: why S3 ?
-    expect_s3_class(x, "ome_zarr")
-    expect_equal(attr(x, "type"), "image")
+    expect_s4_class(x, "ome_zarr")
+    expect_identical(x@metadata$type, "image")
 
     # labels
     x <- ome_read(file.path(td, "labels/blobs"))
-    # TODO: why S3 ?
-    expect_s3_class(x, "ome_zarr")
-    expect_equal(attr(x, "type"), "label")
+    expect_s4_class(x, "ome_zarr")
+    expect_identical(x@metadata$type, "label")
   }
 })

tests/testthat/test-write-image.R

@@ -85,7 +85,7 @@ test_that("writing 0.4 and 0.5 works", {
     )
 
     # check type
-    expect_equal(attr(ome_img, "type"), "image")
+    expect_identical(ome_img@metadata$type, "image")
 
     # zarr exists
     expect_true(zarr_exists(td))

tests/testthat/test-write-label.R

@@ -26,7 +26,7 @@ test_that("writing 0.4 and 0.5 labels works", {
     )
 
     # check type
-    expect_equal(attr(ome_label, "type"), "label")
+    expect_identical(ome_label@metadata$type, "label")
 
     # type is logical in this example
     expect_equal(type(ome_label[[1]]), "logical")