Allow to center and scale data

NAMESPACE

@@ -60,3 +60,4 @@ importFrom(methods,setMethod)
 importFrom(stats,as.dist)
 importFrom(stats,optim)
 importFrom(utils,combn)
+importFrom(utils,modifyList)

NEWS.md

@@ -1,4 +1,6 @@
 # isopleuros 1.1.0.9000
+## Enhancements
+* Allow to center and scale data before plotting.
 
 # isopleuros 1.1.0
 ## New classes and methods

R/AllGenerics.R

@@ -10,6 +10,9 @@
 #'  of a set of points.
 #'  If `y` and `z` are missing, an attempt is made to interpret `x` in a
 #'  suitable way (see [grDevices::xyz.coords()]).
+#' @param center A [`logical`] scalar or a [`numeric`] vector giving the center.
+#' @param scale A [`logical`] scalar or a length-one [`numeric`] vector giving a
+#'  scaling factor.
 #' @param xlab,ylab,zlab A [`character`] string specifying the names for the x,
 #'  y and z variables to be extracted.
 #' @param missing A [`logical`] scalar: should [missing values][NA] be replaced
@@ -21,6 +24,9 @@
 #'  \tabular{ll}{
 #'   `x` \tab A [`numeric`] vector of x values. \cr
 #'   `y` \tab A [`numeric`] vector of y values. \cr
+#'   `z` \tab A [`numeric`] vector of z values. \cr
+#'   `center` \tab A [`numeric`] vector giving the center. \cr
+#'   `scale` \tab A [`numeric`] vector giving the scale factor. \cr
 #'  }
 #' @example inst/examples/ex-coordinates.R
 #' @author N. Frerebeau
@@ -69,6 +75,8 @@ setGeneric(
 #' @param x,y,z A [`numeric`] vector giving the x, y and z ternary coordinates
 #'  of a set of points. If `y` and `z` are missing, an attempt is made to
 #'  interpret `x` in a suitable way (see [grDevices::xyz.coords()]).
+#' @param center A [`logical`] scalar: should the data be centered?
+#' @param scale A [`logical`] scalar: should the data be scaled?
 #' @param xlim A length-two [`numeric`] vector giving the `x` limits in the
 #'  range \eqn{[0,1]}.
 #' @param ylim A length-two [`numeric`] vector giving the `y` limits in the
@@ -93,7 +101,14 @@ setGeneric(
 #'  arguments to this function.
 #' @return
 #'  `ternary_plot()` is called it for its side-effects: it results in a graphic
-#'  being displayed. Invisibly returns `x`.
+#'  being displayed. Invisibly returns a [`list`] with the components:
+#'  \tabular{ll}{
+#'   `x` \tab A [`numeric`] vector of x values. \cr
+#'   `y` \tab A [`numeric`] vector of y values. \cr
+#'   `z` \tab A [`numeric`] vector of z values. \cr
+#'   `center` \tab A [`numeric`] vector giving the center. \cr
+#'   `scale` \tab A [`numeric`] vector giving the scale factor. \cr
+#'  }
 #' @example inst/examples/ex-plot.R
 #' @author N. Frerebeau
 #' @docType methods
@@ -112,6 +127,10 @@ setGeneric(
 #'  grid in `x`, `y` and `z` direction.
 #' @param secondary An [`integer`] specifying the number of cells of the
 #'  secondary grid in `x`, `y` and `z` direction.
+#' @param center A [`numeric`] vector giving the center. If `NULL`
+#'  (the default), data are assumed not centered.
+#' @param scale A [`numeric`] vector giving the scale factor. If `NULL`
+#'  (the default), data are assumed not scaled.
 #' @param col.primary,col.secondary A [`character`] string specifying the color
 #'  of the grid lines.
 #' @param lty.primary,lty.secondary A [`character`] string or [`numeric`]
@@ -140,6 +159,10 @@ NULL
 #'  placed at the tickpoints. If this is not `logical`, `at` should also be
 #'  supplied and of the same length.
 #' @param tick A [`logical`] scalar: should tickmarks and an axis line be drawn?
+#' @param center A [`numeric`] vector giving the center. If `NULL`
+#'  (the default), data are assumed not centered.
+#' @param scale A [`numeric`] vector giving the scale factor. If `NULL`
+#'  (the default), data are assumed not scaled.
 #' @param font font for text. Defaults to `par("font.axis")`.
 #' @param lty A [`character`] string or [`numeric`] value specifying the line
 #'  type for both the axis line and the tick marks.
@@ -320,13 +343,23 @@ setGeneric(
 #' @param x,y,z A [`numeric`] vector giving the x, y and z ternary coordinates
 #'  of a set of points. If `y` and `z` are missing, an attempt is made to
 #'  interpret `x` in a suitable way (see [grDevices::xyz.coords()]).
+#' @param center A [`logical`] scalar: should the data be centered?
+#' @param scale A [`logical`] scalar: should the data be scaled?
 #' @param type A [`character`] string indicating the type of plotting; actually
 #'  any of the types as in [graphics::plot.default()].
 #' @param ... Further graphical parameters (see [graphics::par()]) may also be
 #'  supplied as arguments, particularly, plotting character, `pch`, character
 #'  expansion, `cex` and color, `col`.
 #' @return
-#'  `ternary_points()` is called it for its side-effects.
+#'  `ternary_points()` is called it for its side-effects. Invisibly returns
+#'  a [`list`] with the components:
+#'  \tabular{ll}{
+#'   `x` \tab A [`numeric`] vector of x values. \cr
+#'   `y` \tab A [`numeric`] vector of y values. \cr
+#'   `z` \tab A [`numeric`] vector of z values. \cr
+#'   `center` \tab A [`numeric`] vector giving the center. \cr
+#'   `scale` \tab A [`numeric`] vector giving the scale factor. \cr
+#'  }
 #' @seealso [graphics::points()]
 #' @example inst/examples/ex-points.R
 #' @author N. Frerebeau

R/coordinates.R

@@ -9,7 +9,8 @@ NULL
 setMethod(
   f = "coordinates_ternary",
   signature = c(x = "numeric", y = "numeric", z = "numeric"),
-  definition = function(x, y, z, missing = getOption("isopleuros.missing")) {
+  definition = function(x, y, z, center = FALSE, scale = FALSE,
+                        missing = getOption("isopleuros.missing")) {
     ## Validation
     n <- length(x)
     assert_length(y, n)
@@ -36,13 +37,14 @@ setMethod(
       stop("Positive values are expected.", call. = FALSE)
     }
 
-    x <- x / total
-    y <- y / total
-    z <- z / total
+    coord <- matrix(data = c(x, y, z), ncol = 3) / total
+    coord <- scale(coord, center = center, scale = scale)
 
     list(
-      x = y + z / 2,
-      y = z * sqrt(3) / 2
+      x = coord$y + coord$z / 2,
+      y = coord$z * sqrt(3) / 2,
+      center = coord$center,
+      scale = coord$scale
     )
   }
 )
@@ -54,9 +56,11 @@ setMethod(
   f = "coordinates_ternary",
   signature = c(x = "ANY", y = "missing", z = "missing"),
   definition = function(x, xlab = NULL, ylab = NULL, zlab = NULL,
+                        center = FALSE, scale = FALSE,
                         missing = getOption("isopleuros.missing")) {
     xyz <- grDevices::xyz.coords(x, xlab = xlab, ylab = ylab, zlab = zlab)
-    methods::callGeneric(x = xyz$x, y = xyz$y, z = xyz$z, missing = missing)
+    methods::callGeneric(x = xyz$x, y = xyz$y, z = xyz$z,
+                         center = center, scale = scale, missing = missing)
   }
 )
 
@@ -96,6 +100,77 @@ setMethod(
   }
 )
 
+# Scale ========================================================================
+#' Center and Scale
+#'
+#' @param x A three-columns [`matrix`].
+#' @param center A [`logical`] scalar or a [`numeric`] vector giving the center.
+#' @param scale A [`logical`] scalar or a length-one [`numeric`] vector giving a
+#'  scaling factor.
+#' @return
+#'  A [`list`] with the components:
+#'  \tabular{ll}{
+#'   `x` \tab A [`numeric`] vector of x values. \cr
+#'   `y` \tab A [`numeric`] vector of y values. \cr
+#'   `z` \tab A [`numeric`] vector of z values. \cr
+#'   `center` \tab A [`numeric`] vector giving the center. \cr
+#'   `scale` \tab A [`numeric`] vector giving the scale factor. \cr
+#'  }
+#' @keywords internal
+#' @noRd
+scale <- function(x, center = TRUE, scale = TRUE) {
+  y <- x
+  if (!isFALSE(center) && !is.null(center)) {
+    if (isTRUE(center)) {
+      center <- apply(X = x, MARGIN = 2, FUN = gmean, simplify = TRUE)
+      center <- center / sum(center)
+    }
+    assert_length(center, NCOL(x))
+
+    y <- t(t(y) / center)
+    y <- y / rowSums(y)
+  } else {
+    center <- rep(1, NCOL(x))
+  }
+
+  if (!isFALSE(scale) && !is.null(scale)) {
+    if (isTRUE(scale)) {
+      scale <- sqrt(mean(diag(stats::cov(clr(x)))))
+    }
+    assert_length(scale, 1)
+
+    y <- y^(1 / scale)
+    y <- y / rowSums(y)
+  } else {
+    scale <- 1
+  }
+
+  list(
+    x = y[, 1],
+    y = y[, 2],
+    z = y[, 3],
+    center = center,
+    scale = scale
+  )
+}
+
+#' Geometric Mean
+#'
+#' @param x A [`numeric`] vector.
+#' @param trim A length-one [`numeric`] vector specifying the fraction (0 to 0.5)
+#'  of observations to be trimmed from each end of `x` before the mean is
+#'  computed.
+#' @param na.rm A [`logical`] scalar: should `NA` values be stripped before the
+#'  computation proceeds?
+#' @return A [`numeric`] vector.
+#' @keywords internal
+#' @noRd
+gmean <- function(x, trim = 0, na.rm = FALSE) {
+  if (na.rm) x <- x[is.finite(x)]
+  x <- x[x > 0]
+  exp(mean(log(x), trim = trim))
+}
+
 # Centered Log-Ratios ==========================================================
 #' Centered Log-Ratios (CLR)
 #'

R/isopleuros-package.R

@@ -43,6 +43,6 @@
 #' @importFrom grDevices as.graphicsAnnot as.raster chull colorRampPalette
 #' contourLines dev.flush dev.hold hcl.colors xyz.coords
 #' @importFrom methods setGeneric setMethod .valueClassTest
-#' @importFrom utils combn
+#' @importFrom utils combn modifyList
 #' @importFrom stats as.dist optim
 NULL

R/ternary_axes.R

@@ -5,6 +5,8 @@ NULL
 #' @export
 #' @rdname ternary_axis
 ternary_axis <- function(side, at = NULL, labels = TRUE, tick = TRUE,
+                         center = getOption("isopleuros.center"),
+                         scale = getOption("isopleuros.scale"),
                          font = NA, lty = "solid",
                          lwd = 1, lwd.ticks = lwd,
                          col = NULL, col.ticks = NULL, ...) {
@@ -19,25 +21,28 @@ ternary_axis <- function(side, at = NULL, labels = TRUE, tick = TRUE,
   ## Ticks and labels position
   if (is.null(at)) {
     at <- seq(from = 0, to = 1, length.out = graphics::par("xaxp")[3L] + 1)
-    at <- at[-c(1, length(at))]
+    at <- at[!(at == 0 | at == 1)]
   }
 
   axis_degree <- c(120, 240, 0)[side]
   axis_radian <- c(0, 2 * pi / 3, 4 * pi / 3)[side]
 
-  tick_start <- matrix(c(at, rep(0, length(at))), ncol = 2)
-  tick_start <- rotate(t(tick_start), theta = axis_radian)
+  pos <- matrix(data = 0, nrow = length(at), ncol = 3)
+  pos[, side] <- at
+  pos[, c(2, 3, 1)[side]] <- 1 - at
+  pos <- coordinates_ternary(pos, center = center, scale = scale)
 
   h <- abs(tcl * graphics::strheight("1", cex = 1))
   dx <- sin(pi / 6) * h
   dy <- cos(pi / 6) * h
-  tick_end <- matrix(c(at + dx, rep(-dy, length(at))), ncol = 2)
-  tick_end <- rotate(t(tick_end), theta = axis_radian)
+  tick_start <- matrix(c(pos$x, pos$y), ncol = 2)
+  tick_end <- matrix(c(pos$x + dx * c(1, 1, -2)[side],
+                       pos$y + dy * c(-1, 1, 0)[side]), ncol = 2)
 
   ## Labels
-  if (labels) {
+  if (!isFALSE(labels)) {
     if (length(labels) != length(at)) labels <- round(at * 100)
-    graphics::text(x = tick_end, label = rev(labels), srt = axis_degree,
+    graphics::text(x = tick_end, label = labels, srt = axis_degree,
                    cex = cex, col = col, font = font, adj = c(1, 0.5))
   }
 

R/ternary_grid.R

@@ -5,43 +5,73 @@ NULL
 #' @export
 #' @rdname ternary_grid
 ternary_grid <- function(primary = NULL, secondary = NULL,
+                         center = getOption("isopleuros.center"),
+                         scale = getOption("isopleuros.scale"),
                          col.primary = "darkgray", col.secondary = "lightgray",
                          lty.primary = "dashed", lty.secondary = "dotted",
                          lwd.primary = 1, lwd.secondary = lwd.primary) {
 
   ## Primary grid
-  if (is.null(primary) || (!is.na(primary) && primary >= 1)) {
+  if (is.null(primary) || (!anyNA(primary) && length(primary) == 1 && primary >= 1)) {
     if (is.null(primary)) primary <- graphics::par("xaxp")[3L]
     i <- seq(from = 0, to = 1, length.out = primary + 1)
-    .ternary_grid(i, col = col.primary, lty = lty.primary, lwd = lwd.primary)
+    .ternary_grid(i, center = center, scale = scale,
+                  col = col.primary, lty = lty.primary, lwd = lwd.primary)
   }
 
   ## Secondary grid
-  if (!is.null(secondary) && !is.na(secondary) && secondary > primary) {
+  if (!is.null(secondary) && !is.na(secondary) && length(secondary) == 1 && secondary > primary) {
     i <- seq(from = 0, to = 1, length.out = secondary + 1)
-    .ternary_grid(i, col = col.secondary, lty = lty.secondary, lwd = lwd.secondary)
+    .ternary_grid(i, center = center, scale = scale,
+                  col = col.secondary, lty = lty.secondary, lwd = lwd.secondary)
   }
 
   invisible()
 }
 
-.ternary_grid <- function(x, col = "lightgray", lty = "dotted", lwd = 1) {
-  x <- x[-c(1, length(x))]
-  for(i in x) {
-    graphics::segments(
-      x0 = 1 - i, x1 = (1 - i) / 2,
-      y0 = 0,     y1 = c(1 - i) * .top,
-      lty = lty, lwd = lwd, col = col
-    )
-    graphics::segments(
-      x0 = 1 - i, x1 = 1 - i + i / 2,
-      y0 = 0,     y1 = i * .top,
-      lty = lty, lwd = lwd, col = col
-    )
-    graphics::segments(
-      x0 = i / 2,    x1 = 1 - i + i / 2,
-      y0 = i * .top, y1 = i * .top,
-      lty = lty, lwd = lwd, col = col
-    )
+.ternary_grid <- function(x, center = NULL, scale = NULL,
+                          col = "lightgray", lty = "dotted", lwd = 1, n = 100) {
+  ## Reset values if needed
+  if (!is.null(center) && all(center == 1)) center <- NULL
+  if (!is.null(scale) && scale == 1) scale <- NULL
+
+  x <- x[!(x == 0 | x == 1)]
+  if (is.null(scale)) {
+    for (i in x) {
+      start <- matrix(data = c(i, 0, 1 - i, 1 - i, i, 0, 0, 1 - i, i), ncol = 3)
+      end <- matrix(data = c(i, 1 - i, 0, 0, i, 1 - i, 1 - i, 0, i), ncol = 3)
+
+      start <- coordinates_ternary(start, center = center)
+      end <- coordinates_ternary(end, center = center)
+
+      graphics::segments(
+        x0 = start$x, x1 = end$x,
+        y0 = start$y, y1 = end$y,
+        lty = lty, lwd = lwd, col = col
+      )
+    }
+  } else {
+    for (i in x) {
+      start <- matrix(data = c(i, 0, 1 - i, 1 - i, i, 0, 0, 1 - i, i), ncol = 3)
+      end <- matrix(data = c(i, 1 - i, 0, 0, i, 1 - i, 1 - i, 0, i), ncol = 3)
+      start <- coordinates_ternary(start)
+      end <- coordinates_ternary(end)
+
+      mapply(
+        FUN = function(x_from, x_to, y_from, y_to, n, center, scale) {
+          x <- seq(x_from, x_to, length.out = n)
+          y <- seq(y_from, y_to, length.out = n)
+          z <- coordinates_cartesian(x, y)
+          zz <- coordinates_ternary(z, center = center, scale = scale)
+          graphics::lines(
+            zz,
+            lty = lty, lwd = lwd, col = col
+          )
+        },
+        x_from = start$x, x_to = end$x,
+        y_from = start$y, y_to = end$y,
+        MoreArgs = list(n = 100, center = center, scale = scale)
+      )
+    }
   }
 }

R/ternary_lines.R

@@ -11,7 +11,8 @@ setMethod(
   definition = function(x, y, z, type = "l", ...) {
     coords <- coordinates_ternary(x, y, z)
     graphics::lines(x = coords, type = type, ...)
-    invisible(data.frame(x = x, y = y, z = z))
+
+    invisible(list(x = coords$x, y = coords$y, z = coords$z))
   }
 )
 
@@ -23,6 +24,7 @@ setMethod(
   signature = c(x = "ANY", y = "missing", z = "missing"),
   definition = function(x, type = "l", ...) {
     xyz <- grDevices::xyz.coords(x)
-    methods::callGeneric(x = xyz$x, y = xyz$y, z = xyz$z, type = type, ...)
+    pt <- methods::callGeneric(x = xyz$x, y = xyz$y, z = xyz$z, type = type, ...)
+    invisible(pt)
   }
 )