Partially undo 6316554

NAMESPACE

@@ -32,12 +32,13 @@ exportMethods("%power%")
 exportMethods("[")
 exportMethods("[<-")
 exportMethods("[[<-")
+exportMethods("set_groups<-")
 exportMethods("set_totals<-")
 exportMethods(aggregate)
+exportMethods(any_assigned)
 exportMethods(as_amounts)
 exportMethods(as_composition)
 exportMethods(as_graph)
-exportMethods(augment)
 exportMethods(barplot)
 exportMethods(closure)
 exportMethods(condense)
@@ -47,6 +48,7 @@ exportMethods(dist)
 exportMethods(get_groups)
 exportMethods(get_totals)
 exportMethods(hist)
+exportMethods(is_assigned)
 exportMethods(mahalanobis)
 exportMethods(margin)
 exportMethods(mean)
@@ -120,5 +122,4 @@ importFrom(utils,tail)
 importMethodsFrom(arkhe,describe)
 importMethodsFrom(arkhe,replace_NA)
 importMethodsFrom(arkhe,replace_zero)
-importMethodsFrom(dimensio,augment)
 importMethodsFrom(dimensio,pca)

R/AllClasses.R

@@ -46,7 +46,7 @@ setClassUnion("index", members = c("logical", "numeric", "character"))
 #' An S4 class to represent compositional data.
 #' @slot totals A [`numeric`] vector to store the absolute row sums (before
 #'  the closure of the compositions).
-#' @slot extra A [`list`] of extra variables.
+#' @slot groups A [`character`] vector to store the group names.
 #' @section Coerce:
 #'  In the code snippets below, `x` is a `CompositionMatrix` object.
 #'  \describe{
@@ -70,7 +70,7 @@ setClassUnion("index", members = c("logical", "numeric", "character"))
   Class = "CompositionMatrix",
   slots = c(
     totals = "numeric",
-    extra = "list"
+    groups = "character"
   ),
   contains = c("NumericMatrix")
 )
@@ -81,7 +81,7 @@ setClassUnion("index", members = c("logical", "numeric", "character"))
 #' S4 classes to represent log-ratio data transformations.
 #' @slot totals A [`numeric`] vector to store the absolute row sums (before
 #'  the closure of the compositions).
-#' @slot extra A [`list`] of extra variables.
+#' @slot groups A [`character`] vector to store the group names.
 #' @slot parts A [`character`] vector to store the part names.
 #' @slot ratio A [`character`] vector to store the ratio names.
 #' @slot order An [`integer`] vector to store the original ordering of the
@@ -107,7 +107,7 @@ setClassUnion("index", members = c("logical", "numeric", "character"))
   Class = "LogRatio",
   slots = c(
     totals = "numeric",
-    extra = "list",
+    groups = "character",
 
     parts = "character",
     ratio = "character",

R/AllGenerics.R

@@ -10,7 +10,6 @@ setGeneric("mahalanobis", package = "stats")
 #' @importMethodsFrom arkhe describe
 #' @importMethodsFrom arkhe replace_NA
 #' @importMethodsFrom arkhe replace_zero
-#' @importMethodsFrom dimensio augment
 #' @importMethodsFrom dimensio pca
 NULL
 
@@ -22,6 +21,8 @@ NULL
 #' @param parts A `vector` giving the index of the column to be used a
 #'  compositional parts. If `NULL` (the default), all [`double`] columns will be
 #'  used.
+#' @param groups An [`integer`] giving the index of the column to be used to
+#'  group the samples. If `NULL` (the default), no grouping is stored.
 #' @param verbose A [`logical`] scalar: should \R report extra information
 #'  on progress?
 #' @param ... Currently not used.
@@ -55,21 +56,6 @@ setGeneric(
   valueClass = "matrix"
 )
 
-#' Augment Data with Extra Columns
-#'
-#' Adds columns from the original data.
-#' @param x A [`CompositionMatrix-class`] or [`LogRatio-class`] object.
-#' @param ... Currently not used.
-#' @return
-#'  A [`data.frame`].
-#' @example inst/examples/ex-augment.R
-#' @author N. Frerebeau
-#' @docType methods
-#' @family compositional data tools
-#' @name augment
-#' @rdname augment
-NULL
-
 #' Data Description
 #'
 #' Describes an object.
@@ -202,9 +188,15 @@ setGeneric(
 #'
 #' Retrieves or defines the groups to which the observations belong.
 #' @param x An object from which to get or set `groups`.
-# @param value A possible value for the `groups` of `x`.
+#' @param value A possible value for the `groups` of `x`.
 #' @return
+#'  * `set_groups()` returns an object of the same sort as `x` with the new
+#'    group names assigned.
 #'  * `get_groups()` returns a [`character`] vector giving the group names of `x`.
+#'  * `any_assigned()` returns a [`logical`] scalar specifying whether or not `x`
+#'    has groups.
+#'  * `is_assigned()` returns a [`logical`] vector specifying whether or not an
+#'    observation belongs to a group.
 #' @example inst/examples/ex-mutators.R
 #' @author N. Frerebeau
 #' @docType methods
@@ -213,13 +205,34 @@ setGeneric(
 #' @rdname groups
 NULL
 
+#' @rdname groups
+#' @aliases any_assigned-method
+setGeneric(
+  name = "any_assigned",
+  def = function(x) standardGeneric("any_assigned")
+)
+
+#' @rdname groups
+#' @aliases is_assigned-method
+setGeneric(
+  name = "is_assigned",
+  def = function(x) standardGeneric("is_assigned")
+)
+
 #' @rdname groups
 #' @aliases get_groups-method
 setGeneric(
   name = "get_groups",
   def = function(x) standardGeneric("get_groups")
 )
 
+#' @rdname groups
+#' @aliases set_groups-method
+setGeneric(
+  name = "set_groups<-",
+  def = function(x, value) standardGeneric("set_groups<-")
+)
+
 #' Row Sums
 #'
 #' Retrieves or defines the row sums (before closure).
@@ -621,8 +634,6 @@ NULL
 #' @param x A [`CompositionMatrix-class`] object.
 #' @param by A `vector` of grouping elements, as long as the variables in `x`
 #'  (in the sense that [`as.factor(by)`][as.factor()] defines the grouping).
-#'  If a single `character` string is passed, it must be the name of a
-#'  categorical variable from the original dataset.
 #' @param ... Further arguments to be passed to [mean()].
 #' @return A [`CompositionMatrix-class`] object.
 #' @seealso [mean()], [aggregate()]
@@ -881,9 +892,7 @@ NULL
 #' Displays a compositional bar chart.
 #' @param height A [`CompositionMatrix-class`] object.
 #' @param groups A `vector` of grouping elements, as long as the variables in
-#'  `height`. If a single `character` string is passed, it must be the name of a
-#'  categorical variable from the original dataset.
-#'  If set, a matrix of panels defined by `groups` will be drawn.
+#'  `height`. If set, a matrix of panels defined by `groups` will be drawn.
 #' @param order An [`integer`] vector giving the index of the column to be used
 #'  for the ordering of the data.
 #' @param decreasing A [`logical`] scalar: should the sort order be increasing
@@ -955,8 +964,7 @@ NULL
 #' Displays a matrix of ternary plots.
 #' @param x A [`CompositionMatrix-class`] object.
 #' @param groups A `vector` of grouping elements, as long as the variables in
-#'  `x`. If a single `character` string is passed, it must be the name of a
-#'  categorical variable from the original dataset.
+#'  `x`.
 #' @param palette_color A palette [`function`] that when called with a single
 #'  argument (`groups`) returns a `character` vector of colors.
 #' @param palette_symbol A palette [`function`] that when called with a single
@@ -980,9 +988,7 @@ NULL
 #' Displays a density plot.
 #' @param x A [`LogRatio-class`] object.
 #' @param groups A `vector` of grouping elements, as long as the variables in
-#'  `x`. If a single `character` string is passed, it must be the name of a
-#'  categorical variable from the original dataset.
-#'  If set, a matrix of panels defined by `groups` will be drawn.
+#'  `x`. If set, a matrix of panels defined by `groups` will be drawn.
 #' @param palette_color A palette [`function`] that when called with a single
 #'  argument (`groups`) returns a `character` vector of colors.
 #' @param rug A [`logical`] scalar: should a *rug* representation (1-d plot) of
@@ -1159,8 +1165,7 @@ NULL
 #'  with larger (squared) Mahalanobis distance are considered as potential
 #'  outliers.
 #' @param groups A `vector` of grouping elements, as long as the variables in
-#'  `object`. If a single `character` string is passed, it must be the name of a
-#'  categorical variable from the original dataset.
+#'  `object`.
 #' @details
 #'  An outlier can be defined as having a very large Mahalanobis distance from
 #'  all observations. In this way, a certain proportion of the observations can

R/barplot.R

@@ -5,7 +5,7 @@ NULL
 # CompositionMatrix ============================================================
 #' @export
 #' @method barplot CompositionMatrix
-barplot.CompositionMatrix <- function(height, ..., groups = NULL,
+barplot.CompositionMatrix <- function(height, ..., groups = get_groups(height),
                                       order = NULL, decreasing = FALSE,
                                       horiz = TRUE,
                                       xlab = NULL, ylab = NULL,
@@ -36,8 +36,7 @@ barplot.CompositionMatrix <- function(height, ..., groups = NULL,
   y_side <- if (horiz) 2 else 1
 
   ## Grouping
-  groups <- get_variable(height, which = groups)
-  if (!is.null(groups) && !all(is.na(groups))) {
+  if (has_groups(groups)) {
     arkhe::assert_length(groups, nrow(z))
     groups <- groups[ordering]
 

R/coerce.R

@@ -31,7 +31,8 @@ setMethod(
     totals <- rowSums(from, na.rm = TRUE)
     from <- from / totals
 
-    .CompositionMatrix(from, totals = unname(totals))
+    grp <- rep(NA_character_, nrow(from))
+    .CompositionMatrix(from, totals = unname(totals), groups = grp)
   }
 )
 
@@ -41,13 +42,21 @@ setMethod(
 setMethod(
   f = "as_composition",
   signature = c(from = "data.frame"),
-  definition = function(from, parts = NULL,
+  definition = function(from, parts = NULL, groups = NULL,
                         verbose = getOption("nexus.verbose")) {
     ## Clean row/column names
     lab <- make_names(x = NULL, n = nrow(from), prefix = "S")
     rownames(from) <- if (has_rownames(from)) rownames(from) else lab
     colnames(from) <- make_names(x = colnames(from), n = ncol(from), prefix = "V")
 
+    ## Group names
+    grp <- rep(NA_character_, nrow(from))
+    if (!is.null(groups)) {
+      grp <- from[, groups, drop = FALSE]
+      grp <- as.character(interaction(grp, sep = "_"))
+      grp[grp == ""] <- NA_character_
+    }
+
     ## Remove non-numeric columns
     if (is.null(parts)) {
       parts <- arkhe::detect(from, f = is.double, margin = 2) # Logical
@@ -63,15 +72,14 @@ setMethod(
       if (is.character(parts)) parts <- colnames(from) %in% parts
     }
     coda <- from[, parts, drop = FALSE]
-    extra <- from[, !parts, drop = FALSE]
     arkhe::assert_filled(coda)
 
     ## Build matrix
     coda <- data.matrix(coda, rownames.force = NA)
     totals <- rowSums(coda, na.rm = TRUE)
     coda <- coda / totals
 
-    .CompositionMatrix(coda, totals = unname(totals), extra = as.list(extra))
+    .CompositionMatrix(coda, totals = unname(totals), groups = grp)
   }
 )
 
@@ -87,37 +95,6 @@ setMethod(
   }
 )
 
-# To features ==================================================================
-#' @export
-#' @rdname augment
-#' @aliases augment,CompositionMatrix-method
-setMethod(
-  f = "augment",
-  signature = c(x = "CompositionMatrix"),
-  definition = function(x, ...) {
-    if (has_extra(x)) {
-      data.frame(get_extra(x), x)
-    } else {
-      as.data.frame(x)
-    }
-  }
-)
-
-#' @export
-#' @rdname augment
-#' @aliases augment,LogRatio-method
-setMethod(
-  f = "augment",
-  signature = c(x = "LogRatio"),
-  definition = function(x, ...) {
-    if (has_extra(x)) {
-      data.frame(get_extra(x), x)
-    } else {
-      as.data.frame(x)
-    }
-  }
-)
-
 # To data.frame ================================================================
 #' @method as.data.frame CompositionMatrix
 #' @export

R/condense.R

@@ -8,11 +8,10 @@ NULL
 setMethod(
   f = "condense",
   signature = c("CompositionMatrix"),
-  definition = function(x, by, ...) {
+  definition = function(x, by = get_groups(x), ...) {
     m <- nrow(x)
 
     ## Grouping
-    by <- get_variable(x, which = by)
     arkhe::assert_length(by, m)
     by <- as.factor(by)
 
@@ -29,8 +28,9 @@ setMethod(
     z <- do.call(rbind, z)
 
     tot <- tapply(X = get_totals(x), INDEX = by, FUN = mean, simplify = TRUE)
+    grp <- flatten_chr(x = get_groups(x), by = by)
 
     rownames(z) <- levels(by)
-    .CompositionMatrix(z, totals = as.numeric(tot))
+    .CompositionMatrix(z, totals = as.numeric(tot), groups = grp)
   }
 )

R/describe.R

@@ -40,7 +40,17 @@ setMethod(
     spa <- arkhe::sparsity(x, count = FALSE)
     msg_spa <- sprintf("%s of values are zero.", label_percent(spa, digits = 1))
 
-    cat(msg_tbl, sep = "\n* ")
+    ## Groups
+    groups <- get_groups(x)
+    grp <- unique(groups[!is.na(groups)])
+    n_grp <- length(grp)
+    n_ung <- sum(is.na(groups))
+    ls_grp <- if (n_grp == 0) "" else paste0(": ", paste0(dQuote(grp), collapse = ", "))
+    msg_grp <- sprintf("%d %s%s.", n_grp, ngettext(n_grp, "group", "groups"),
+                       ls_grp)
+    msg_ung <- sprintf("%d unassigned %s.", n_ung, ngettext(n_ung, "sample", "samples"))
+
+    cat(msg_tbl, msg_grp, msg_ung, sep = "\n* ")
     cat("\nData checking:", msg_spa, msg_col_var, sep = "\n* ")
     cat("\nMissing values:", msg_row_NA, msg_col_NA, sep = "\n* ")