Updates for compatibility with Huber-group-EMBL/romeo

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: ImageArray
 Type: Package
 Title: A framework for on-disk and in-memory image arrays
-Version: 1.1.6
+Version: 1.1.7
 Authors@R: c(
     person("Artür", "Manukyan", 
 		     role=c("aut", "cre"),

NAMESPACE

@@ -7,11 +7,12 @@ export(ImageArray)
 export(createImageArray)
 export(getImageInfo)
 export(writeImageArray)
+exportClasses(ImageArray)
 exportMethods("[")
 exportMethods("[[")
 exportMethods("[[<-")
-exportMethods("axes<-")
 exportMethods("path<-")
+exportMethods("scales<-")
 exportMethods(affine)
 exportMethods(aperm)
 exportMethods(axes)
@@ -29,7 +30,6 @@ exportMethods(realize)
 exportMethods(resolution)
 exportMethods(rotate)
 exportMethods(scale)
-exportMethods(scales)
 exportMethods(series)
 exportMethods(translation)
 exportMethods(type)
@@ -75,7 +75,8 @@ importFrom(methods,
   setClassUnion,
   setOldClass,
   slot,
-  slotNames
+  slotNames,
+  validObject
 )
 importFrom(rhdf5,
   h5createFile,

NEWS.md

@@ -1,3 +1,14 @@
+# ImageArray 1.1.7
+
+## New features
+
+* Compatibility with https://github.com/Huber-group-EMBL/romeo
+* `ImageArray` class is now exported.
+* `axes` slot is dropped from `ImageArray` class and now parsed from 
+  names(scales(object)[[1]]) (which can still be parsed from `axes(object)` 
+  as usual).
+* scales of pyramid axes are now inverted, e.g. 1, 0.5, 0.125 are now 1, 2, 4. 
+
 # ImageArray 1.1.6
 
 ## New features

R/AllClasses.R

@@ -6,8 +6,6 @@ NULL
 # magick classes
 setOldClass("magick-image")
 setOldClass("bitmap")
-setClassUnion(c("magick_class"), 
-              c("magick-image", "bitmap"))
 
 # array and matrix classes
 setClassUnion("matrix_array_Array", 
@@ -18,11 +16,26 @@ setClassUnion("matrix_array_Array",
   contains="SimpleList",
   prototype=prototype(elementType="matrix_array_Array"))
 
+#' @title ImageArray class
+#'
+#' @description
+#' An S4 container for a multi-resolution (pyramidal) image, holding the
+#' pyramid levels together with their scales. Objects are created with
+#' \code{\link{ImageArray}}.
+#'
+#' @slot levels an \code{ImageList} of pyramid levels, ordered from the
+#'   highest to the lowest resolution
+#' @slot scales a list of named numeric vectors, one per level, where values
+#'   are the scales of these axes. The names of these vectors define the axes
+#'   of the object, hence they are a subset of \code{c("c", "y", "x", "z", "t")}
+#'   and are shared, in the same order, by all levels. See
+#'   \url{https://ngff.openmicroscopy.org/} for more information.
+#'
+#' @exportClass ImageArray
 .ImageArray <- setClass(
   Class = "ImageArray",
   slots = c(
     levels = "ImageList",
-    axes = "character",
     scales = "list"
   )
 )

R/AllGenerics.R

@@ -6,6 +6,8 @@ NULL
 setGeneric("createImageList", 
            function(image, ...) standardGeneric("createImageList"))
 setGeneric("scales", function(object, ...) standardGeneric("scales"))
+setGeneric("scales<-", 
+           function(object, ..., value) standardGeneric("scales<-"))
 setGeneric("axes", function(object, ...) standardGeneric("axes"))
 setGeneric("axes<-", function(object, ..., value) standardGeneric("axes<-"))
 setGeneric("read_image", 

R/ImageArray.R

@@ -47,6 +47,8 @@
 #' axes<-,ImageArray-method
 #' scales
 #' scales,ImageArray-method
+#' scales<-
+#' scales<-,ImageArray-method
 #' realize
 #' realize,ImageArray-method
 #' as.raster
@@ -185,20 +187,50 @@ setMethod("length", signature = "ImageArray", function(x) length(x@levels))
 
 #' @describeIn ImageArray-methods get axes metadata of the ImageArray object
 #' @exportMethod axes
-setMethod("axes", "ImageArray", function(object) object@axes)
+setMethod("axes", "ImageArray", function(object)
+  .get_axes_from_scales(scales(object)))
 
-#' @describeIn ImageArray-methods get axes metadata of the ImageArray object
-#' @exportMethod axes<-
-setMethod("axes<-", "ImageArray", function(object, ..., value){
-  value <- .check_axes(object[[1]], axes = value)
-  object@axes <- value
+#' @describeIn ImageArray-methods replace axes metadata of the ImageArray
+#' object, the replacement can only be a permutation of the existing axes
+setReplaceMethod("axes", "ImageArray", function(object, ..., value){
+  ax <- axes(object)
+
+  # check axes, should be a permutation
+  if(!is.character(value) || length(value) != length(ax) ||
+     anyDuplicated(value) || !setequal(value, ax))
+    stop("axes can only be replaced by a permutation of the existing axes: ",
+         paste(ax, collapse = ","), "!")
+
+  # update axes
+  scales(object) <- lapply(scales(object), \(.) .[value])
   object
 })
 
 #' @describeIn ImageArray-methods get scales metadata of the ImageArray object
-#' @exportMethod scales
 setMethod("scales", "ImageArray", function(object) object@scales)
 
+#' @describeIn ImageArray-methods replace scales metadata of the ImageArray
+#' object, each vector should be named by a permutation of the existing axes
+#' @importFrom methods validObject
+#' @exportMethod scales<-
+setReplaceMethod("scales", "ImageArray", function(object, ..., value) {
+  if(!is.list(value)) stop("scales must be a list!")
+
+  # the axes of an ImageArray object can only be permuted, all remaining
+  # checks are done by the validity of the class below
+  ax <- axes(object)
+  for(s in value){
+    if(is.null(names(s)) || length(s) != length(ax) ||
+       anyDuplicated(names(s)) || !setequal(names(s), ax))
+      stop("names of each vector in scales should be a permutation of ",
+           "the existing axes: ", paste(ax, collapse = ","), "!")
+  }
+
+  object@scales <- value
+  methods::validObject(object)
+  object
+})
+
 ####
 # Create/Write ####
 ####
@@ -369,8 +401,8 @@ createListFromEBImage <- function(
       if (verbose) .img_create_msg(dim_image, i)
       cur_image <- EBImage::resize(
         cur_image,
-        w = dim_image["x"]*scales[[i]]["x"],
-        h = dim_image["y"]*scales[[i]]["y"]
+        w = dim_image["x"]/scales[[i]]["x"],
+        h = dim_image["y"]/scales[[i]]["y"]
       )
       cur_img <- aperm(cur_image, perm = img_perm_backward)
       image_list[[i]] <-
@@ -412,7 +444,10 @@ createListFromList <- function(image,
 }
 
 #' @noRd
-setMethod("createImageList", "magick_class", createListFromMagick)
+setMethod("createImageList", "magick-image", createListFromMagick)
+
+#' @noRd
+setMethod("createImageList", "bitmap", createListFromMagick)
 
 #' @noRd
 setMethod("createImageList", "Image", createListFromEBImage)
@@ -452,8 +487,8 @@ setMethod("createImageList", "list", createListFromList)
 #'  typical an integer starting from 1.
 #' @param verbose verbose
 #'
-#' @name ImageArray
-#' @rdname ImageArray
+#' @name ImageArray-constructor
+#' @rdname ImageArray-constructor
 #' 
 #' @aliases 
 #' createImageArray
@@ -528,12 +563,11 @@ ImageArray <- function(
   S4Vectors::new2(
     "ImageArray", 
     levels = image$levels,
-    axes = image$axes,
     scales = scales
   )
 }
 
-#' @describeIn ImageArray deprecated function
+#' @describeIn ImageArray-constructor deprecated function
 #' @export
 createImageArray <- function(
     image,
@@ -832,7 +866,7 @@ setMethod("read_image",
 #' @keywords internal
 #' @noRd
 .magick_resize_scale <- function(dim_img, scales){
-  paste0(paste(round(dim_img*scales[c("x", "y")]), collapse = "x"),"!")
+  paste0(paste(round(dim_img/scales[c("x", "y")]), collapse = "x"),"!")
 }
 
 
@@ -849,7 +883,7 @@ setMethod("read_image",
     if(length(d) != length(axes)) stop(msg)
     d <- setNames(d, axes)
     sc <- .TEMPLATE_SCALES[axes]
-    sc[scaled_axes] <- d[scaled_axes]/first_dim[scaled_axes]
+    sc[scaled_axes] <- first_dim[scaled_axes]/d[scaled_axes]
     sc
   })
 }
@@ -861,7 +895,7 @@ setMethod("read_image",
     stop("axes should have at least x and y dimensions!")
   lapply(seq_len(n.levels), \(i){
     ax <- .TEMPLATE_SCALES[axes]
-    ax[c("x", "y")] <- ax[c("x", "y")] / 2^(i-1)
+    ax[c("x", "y")] <- ax[c("x", "y")] * 2^(i-1)
     ax
   })
 }

R/Validity.R

@@ -1,32 +1,36 @@
 .validate_ImageArray <- function(object) {
 
+  # check scales vs levels, this is done first since the axes are
+  # given by the names of the scales
+  sc <- scales(object)
+  if(length(sc) != length(object@levels))
+    stop("scales should be of the same length as levels!")
+
   # check default axes
   ax <- axes(object)
-  if (!all(ax %in% .AXES)) {
-    stop("The axes of the ImageArray object should be a subset of ",  
+  if (!all(ax %in% .AXES))
+    stop("The axes of the ImageArray object should be a subset of ",
          deparse(.AXES))
-  }
-
-  # check scales
-  sc <- scales(object)
+
+  # check duplicate axes
+  ind_dup <- which(table(ax) > 1)
+  if (length(ind_dup))
+    stop("Duplicated axes are detected: ",
+         paste(names(ind_dup), collapse = ","))
+
+  # check scales, all levels should carry the same axes in the same order
   for(s in sc){
-    if(!all(names(s) %in% ax)) stop("scale names do not match axes")
-    if(!all(is.numeric(s) & is.finite(s))) 
+    if(!identical(names(s), ax)) stop("scale names do not match axes")
+    if(!all(is.numeric(s) & is.finite(s)))
       stop("scale entries are not numeric")
   }
 
   # check all dim vs axes
   all_length <- vapply(object@levels, function(x) length(dim(x)), integer(1))
-  if (!all(all_length == length(ax))) {
+  if (!all(all_length == length(ax)))
     stop(
       "The number of dimensions of all levels should match the number of axes."
     )
-  }
-
-  # check all dim vs scales
-  all_dim <- lapply(object@levels, function(x) dim(x))
-  if(length(sc) != length(all_dim))
-    stop("scales should be of the same length as levels!")
 
   TRUE
 }

R/manipulation.R

@@ -74,8 +74,8 @@ setMethod("crop", signature = "ImageArray", function(object, index) {
       lapply(seq_along(index[scaled_axes]), function(j) {
         ind <- index[scaled_axes][[j]]
         ind <- c(
-          floor(ind[1] * cur_scale[scaled_axes][j]),
-          ceiling(ind[length(ind)] * cur_scale[scaled_axes][j])
+          floor(ind[1] / cur_scale[scaled_axes][j]),
+          ceiling(ind[length(ind)] / cur_scale[scaled_axes][j])
         )
         seq(max(ind[1], 1), min(ind[2], selected_dim[j]))
       })

R/transformations.R

@@ -556,9 +556,9 @@ setMethod("affine",
             scl <- scales(x)
             for (i in seq_along(x@levels)) {
               sc <- scl[[i]][selected_axes]
-              m <- solve(diag(c(1/sc, 1))) %*% m %*% diag(1/sc) 
+              m <- solve(diag(c(sc, 1))) %*% m %*% diag(sc) 
               if(!is.null(output.dim)){
-                cur_output.dim <- output.dim * sc
+                cur_output.dim <- output.dim / sc
               } else {
                 cur_output.dim <- output.dim
               }
@@ -663,7 +663,7 @@ setMethod("scale",
             .check_outputdim(output.dim)
             for (i in seq_along(x@levels)) {
               sc <- scl[[i]][selected_axes]
-              cur_output.dim <- output.dim * sc
+              cur_output.dim <- output.dim / sc
               x[[i]] <- .scale_transform(
                 x[[i]],
                 output.dim = cur_output.dim,