Add transformation methods

NAMESPACE

@@ -17,6 +17,7 @@ S3method(quantile,CompositionMatrix)
 S3method(scale,CompositionMatrix)
 S3method(split,CompositionMatrix)
 S3method(split,LogRatio)
+S3method(weights,LogRatio)
 export(color)
 export(palette_color_continuous)
 export(palette_color_discrete)
@@ -77,6 +78,7 @@ exportMethods(transform_lr)
 exportMethods(transform_plr)
 exportMethods(univariate_ilr)
 exportMethods(variation)
+exportMethods(weights)
 import(arkhe)
 importFrom(MASS,cov.rob)
 importFrom(arkhe,remove_NA)

NEWS.md

@@ -2,10 +2,17 @@
 ## New classes and methods
 * Add `condense()` to compute compositional mean of data subsets.
 * Add `pip()` to compute proportionality index of parts.
-* Add `show()` methods for `LogRatio-class` objects.
+* Add `show()` methods for `LogRatio` objects.
+* Add transformation methods for `LogRatio` objects (clr <-> alr, clr -> ilr, alr -> ilr).
+
+## Enhancements
+* Add example datasets.
+* Allow proportional sizing of faceted barplot.
 
 ## Breaking changes
 * `[` always returns a `CompositionMatrix` object by default, even if only one row/column is accessed.
+* Remove `samples` slot in all classes.
+* Remove `as_features()`.
 * Rewrite `plot()` method for `OutlierIndex` object.
 
 # nexus 0.2.0

R/AllGenerics.R

@@ -184,6 +184,21 @@ setGeneric(
 
 # Extract ======================================================================
 ## Mutators --------------------------------------------------------------------
+#' Get or Set Parts of an Object
+#'
+#' Getters and setters to retrieve or set parts of an object.
+#' @param object An object from which to get or set element(s).
+# @param value A possible value for the element(s) of `x`.
+#' @param ... Currently not used.
+# @example inst/examples/ex-mutators.R
+#' @author N. Frerebeau
+#' @docType methods
+#' @family mutators
+#' @name mutators
+#' @rdname mutators
+#' @aliases get set
+NULL
+
 #' Working With Groups
 #'
 #' Retrieves or defines the groups to which the observations belong.
@@ -365,7 +380,7 @@ setGeneric(
 #'
 #' Computes CLR transformation.
 #' @param object A [`CompositionMatrix-class`] object.
-#' @param weights A [`logical`] scalar: sould a varying weight be used. If
+#' @param weights A [`logical`] scalar: should a varying weight be used. If
 #'  `FALSE` (the default), equally-weighted parts are used. Alternatively, a
 #'  positive [`numeric`] vector of weights can be specified.
 #' @param ... Currently not used.

R/mutators.R

@@ -14,6 +14,18 @@ get_transformation <- function(x) {
   )
 }
 
+# Getter =======================================================================
+#' @export
+#' @method weights LogRatio
+weights.LogRatio <- function(object, ...) {
+  object@weights
+}
+
+#' @export
+#' @rdname mutators
+#' @aliases weights,LogRatio-method
+setMethod("weights", "LogRatio", weights.LogRatio)
+
 # Groups =======================================================================
 has_groups <- function(x) {
   length(x) > 0 && !all(is.na(x))

R/transform_alr.R

@@ -3,6 +3,13 @@
 NULL
 
 # ALR ==========================================================================
+alr_base <- function(D) {
+  V <- diag(1, nrow = D, ncol = D - 1)
+  V[D, ] <- -1
+
+  V
+}
+
 #' @export
 #' @rdname transform_alr
 #' @aliases transform_alr,CompositionMatrix-method
@@ -19,15 +26,52 @@ setMethod(
     parts <- parts[ordering]
     z <- object[, ordering, drop = FALSE]
 
-    base <- diag(1, nrow = D, ncol = D - 1)
-    base[D, ] <- -1
+    base <- alr_base(D)
 
     alr <- log(z, base = exp(1)) %*% base
     rownames(alr) <- rownames(object)
     colnames(alr) <- paste(parts[-D], parts[D], sep = "_")
 
     w <- rep(1 / D, D)
-    w <- w[-D] * w[D]
+    w <- w[-1] * w[1]
+
+    .ALR(
+      alr,
+      parts = parts,
+      ratio = colnames(alr),
+      order = order(ordering),
+      base = base,
+      weights = w,
+      totals = get_totals(object),
+      groups = get_groups(object)
+    )
+  }
+)
+
+#' @export
+#' @rdname transform_alr
+#' @aliases transform_alr,CLR-method
+setMethod(
+  f = "transform_alr",
+  signature = c(object = "CLR"),
+  definition = function(object, j = ncol(object)) {
+    D <- ncol(object)
+    parts <- object@parts
+
+    ## Reorder
+    j <- if (is.character(j)) which(parts == j) else as.integer(j)
+    ordering <- c(which(j != seq_len(D)), j)
+    parts <- parts[ordering]
+    z <- object[, ordering, drop = FALSE]
+
+    base <- alr_base(D)
+
+    alr <- z %*% base
+    rownames(alr) <- rownames(object)
+    colnames(alr) <- paste(parts[-D], parts[D], sep = "_")
+
+    w <- rep(1 / D, D)
+    w <- w[-1] * w[1]
 
     .ALR(
       alr,

R/transform_clr.R

@@ -3,32 +3,63 @@
 NULL
 
 # CLR ==========================================================================
+clr_base <- function(D, weights = rep(1 / D, D)) {
+  diag(D) - matrix(data = weights, nrow = D, ncol = D)
+}
+
 #' @export
 #' @rdname transform_clr
 #' @aliases transform_clr,CompositionMatrix-method
 setMethod(
   f = "transform_clr",
   signature = c(object = "CompositionMatrix"),
   definition = function(object, weights = FALSE) {
-    J <- ncol(object)
+    D <- ncol(object)
     parts <- colnames(object)
 
-    w <- if (any(weights)) colMeans(object) else rep(1 / J, J)
+    w <- if (isTRUE(weights)) colMeans(object) else rep(1 / D, D)
     if (is.numeric(weights)) {
-      arkhe::assert_length(weights, J)
+      arkhe::assert_length(weights, D)
       arkhe::assert_positive(weights, strict = FALSE)
       w <- weights / sum(weights) # Sum up to 1
     }
 
-    base <- diag(J) - matrix(data = w, nrow = J, ncol = J)
+    base <- clr_base(D, weights = w)
     clr <- log(object, base = exp(1)) %*% base
     dimnames(clr) <- dimnames(object)
 
     .CLR(
       clr,
       parts = parts,
       ratio = parts,
-      order = seq_len(J),
+      order = seq_len(D),
+      base = base,
+      weights = unname(w),
+      totals = get_totals(object),
+      groups = get_groups(object)
+    )
+  }
+)
+
+#' @export
+#' @rdname transform_clr
+#' @aliases transform_clr,ALR-method
+setMethod(
+  f = "transform_clr",
+  signature = c(object = "ALR"),
+  definition = function(object) {
+    D <- ncol(object) + 1
+    w <- rep(1 / D, D)
+
+    base <- clr_base(D, weights = w)
+    clr <- object %*% base[-D, ]
+    dimnames(clr) <- list(rownames(object), object@parts)
+
+    .CLR(
+      clr,
+      parts = object@parts,
+      ratio = object@parts,
+      order = seq_len(D),
       base = base,
       weights = w,
       totals = get_totals(object),

R/transform_ilr.R

@@ -42,38 +42,67 @@ setMethod(
   f = "transform_ilr",
   signature = c(object = "CompositionMatrix", base = "matrix"),
   definition = function(object, base) {
-    D <- ncol(object)
-    seq_parts <- seq_len(D - 1)
-    parts <- colnames(object)
-
-    ## Rotated and centered values
-    y <- log(object, base = exp(1))
-    ilr <- y %*% base
+    .transform_ilr(object, base)
+  }
+)
 
-    ratio <- vapply(
-      X = seq_parts,
-      FUN = function(i, k) {
-        paste(paste0(k[seq_len(i)], collapse = "-"), k[i + 1], sep = "_")
-      },
-      FUN.VALUE = character(1),
-      k = parts
-    )
-    colnames(ilr) <- paste0("Z", seq_parts)
-    rownames(ilr) <- rownames(object)
+#' @export
+#' @rdname transform_ilr
+#' @aliases transform_ilr,CLR,missing-method
+setMethod(
+  f = "transform_ilr",
+  signature = c(object = "CLR", base = "missing"),
+  definition = function(object, base) {
+    base <- ilr_base(D = ncol(object), method = "basic")
+    object@.Data <- exp(object@.Data)
+    .transform_ilr(object, base)
+  }
+)
 
-    .ILR(
-      ilr,
-      parts = parts,
-      ratio = ratio,
-      order = seq_len(D),
-      base = base,
-      weights = rep(1 / D, D),
-      totals = get_totals(object),
-      groups = get_groups(object)
-    )
+#' @export
+#' @rdname transform_ilr
+#' @aliases transform_ilr,ALR,missing-method
+setMethod(
+  f = "transform_ilr",
+  signature = c(object = "ALR", base = "missing"),
+  definition = function(object, base) {
+    object <- transform_clr(object)
+    methods::callGeneric(object)
   }
 )
 
+.transform_ilr <- function(object, base) {
+  D <- ncol(object)
+  seq_parts <- seq_len(D - 1)
+  parts <- colnames(object)
+
+  ## Rotated and centered values
+  y <- log(object, base = exp(1))
+  ilr <- y %*% base
+
+  ratio <- vapply(
+    X = seq_parts,
+    FUN = function(i, k) {
+      paste(paste0(k[seq_len(i)], collapse = "-"), k[i + 1], sep = "_")
+    },
+    FUN.VALUE = character(1),
+    k = parts
+  )
+  colnames(ilr) <- paste0("Z", seq_parts)
+  rownames(ilr) <- rownames(object)
+
+  .ILR(
+    ilr,
+    parts = parts,
+    ratio = ratio,
+    order = seq_len(D),
+    base = base,
+    weights = rep(1 / D, D),
+    totals = get_totals(object),
+    groups = get_groups(object)
+  )
+}
+
 # Univariate ILR ===============================================================
 #' @export
 #' @rdname univariate_ilr

inst/tinytest/test_packages.R

@@ -0,0 +1,33 @@
+# Test against other packages ==================================================
+if (at_home()) {
+  data("hongite")
+  coda <- as_composition(hongite)
+
+  lr <- transform_lr(coda)
+  clr <- transform_clr(coda, weights = FALSE)
+  wclr <- transform_clr(coda, weights = TRUE)
+  alr <- transform_alr(coda, j = 2)
+  ilr <- transform_ilr(coda)
+  plr <- transform_plr(coda)
+
+  if (requireNamespace("compositions", quietly = TRUE)) {
+    expect_equivalent(clr@.Data, as.matrix(compositions::clr(compositions::acomp(coda))))
+    expect_equivalent(alr@.Data, as.matrix(compositions::alr(compositions::acomp(coda), ivar = 2)))
+    expect_equivalent(ilr@.Data, as.matrix(compositions::ilr(compositions::acomp(coda))))
+    expect_equivalent(covariance(coda, center = TRUE), compositions::var(compositions::acomp(coda), robust = FALSE))
+    expect_equivalent(variation(coda), compositions::variation(compositions::acomp(coda), robust = FALSE))
+    expect_equivalent(dist(coda), compositions::dist(compositions::acomp(coda)))
+  }
+  if (requireNamespace("robCompositions", quietly = TRUE)) {
+    expect_equivalent(clr@.Data, as.matrix(robCompositions::cenLR(coda@.Data)$x.clr))
+    expect_equivalent(alr@.Data, as.matrix(robCompositions::addLR(coda@.Data, ivar = 2)$x.alr))
+    expect_equivalent(plr@.Data, as.matrix(robCompositions::pivotCoord(coda@.Data)))
+    expect_equivalent(dist(coda), robCompositions::aDist(coda@.Data))
+  }
+  if (requireNamespace("easyCODA", quietly = TRUE)) {
+    expect_equivalent(clr@.Data, easyCODA::CLR(coda@.Data, weight = FALSE)$LR)
+    expect_equivalent(wclr@.Data, easyCODA::CLR(coda@.Data, weight = TRUE)$LR)
+    expect_equivalent(alr@.Data, easyCODA::ALR(coda@.Data, denom = 2, weight = FALSE)$LR)
+    expect_equivalent(lr@.Data, easyCODA::LR(coda@.Data, weight = FALSE)$LR)
+  }
+}