From 78bdee81e2c33634c007cbc2f5405eaf8f722a67 Mon Sep 17 00:00:00 2001 From: nfrerebeau Date: Wed, 18 Dec 2024 15:50:26 +0100 Subject: [PATCH] Redesign the internal mechanism for grouping data --- NAMESPACE | 19 +- NEWS.md | 6 + R/AllClasses.R | 133 +++++-- R/AllGenerics.R | 349 ++++++++++-------- R/aggregate.R | 34 +- R/barplot.R | 25 +- R/coerce.R | 72 ++-- R/condense.R | 54 +-- R/describe.R | 93 +++-- R/group.R | 286 ++++++++++---- R/mutators.R | 28 +- R/nexus-internal.R | 6 - R/nexus-package.R | 4 +- R/outliers.R | 14 +- R/pca.R | 9 +- R/plot.R | 48 +-- R/simplex.R | 12 +- R/split.R | 47 ++- R/subset.R | 13 +- R/transform_alr.R | 32 +- R/transform_clr.R | 32 +- R/transform_ilr.R | 42 ++- R/transform_inverse.R | 57 ++- R/transform_lr.R | 16 +- R/transform_plr.R | 16 +- R/validate.R | 25 +- README.Rmd | 2 +- README.md | 4 +- inst/examples/ex-group.R | 18 + inst/examples/ex-groups.R | 8 - inst/examples/ex-outliers.R | 2 +- inst/examples/ex-split.R | 12 +- inst/tinytest/_snaps/coerce.rds | Bin 1404 -> 0 bytes inst/tinytest/_snaps/coerce_group.rds | Bin 0 -> 1400 bytes inst/tinytest/_snaps/coerce_nogroup.rds | Bin 0 -> 1337 bytes inst/tinytest/_snaps/condense.rds | Bin 490 -> 499 bytes inst/tinytest/_snaps/detect_outlier.rds | Bin 702 -> 658 bytes inst/tinytest/_snaps/margin.rds | Bin 940 -> 898 bytes .../_snaps/missing_multiplicative.rds | Bin 481 -> 439 bytes inst/tinytest/_snaps/scale.rds | Bin 1505 -> 1457 bytes inst/tinytest/_snaps/transform_alr.rds | Bin 1261 -> 1215 bytes inst/tinytest/_snaps/transform_clr.rds | Bin 1442 -> 1406 bytes inst/tinytest/_snaps/transform_ilr.rds | Bin 1357 -> 1320 bytes inst/tinytest/_snaps/transform_lr.rds | Bin 2402 -> 2365 bytes inst/tinytest/_snaps/transform_plr.rds | Bin 1348 -> 1311 bytes inst/tinytest/_snaps/zero_multiplicative.rds | Bin 487 -> 445 bytes inst/tinytest/test_coerce.R | 5 - inst/tinytest/test_condense.R | 5 +- inst/tinytest/test_group.R | 25 ++ inst/tinytest/test_mutators.R | 19 - inst/tinytest/test_plot.R | 12 +- inst/tinytest/test_replace.R | 2 + man/CompositionMatrix-class.Rd | 10 +- man/GroupedComposition-class.Rd | 57 +++ man/GroupedLogRatio-class.Rd | 64 ++++ man/LogRatio-class.Rd | 8 +- man/LogicalMatrix-class.Rd | 31 -- man/NumericMatrix-class.Rd | 6 +- man/OutlierIndex-class.Rd | 8 +- man/ReferenceGroups-class.Rd | 53 +++ man/aggregate.Rd | 6 +- man/as_graph.Rd | 4 +- man/barplot.Rd | 8 +- man/bind.Rd | 14 +- man/condense.Rd | 11 +- man/describe.Rd | 3 + man/detect_outlier.Rd | 2 +- man/extract.Rd | 47 --- man/figures/README-lra-2.png | Bin 13531 -> 13621 bytes man/group.Rd | 95 +++++ man/group_extract.Rd | 58 +++ man/group_metadata.Rd | 134 +++++++ man/{split.Rd => group_split.Rd} | 50 ++- man/groups.Rd | 95 ----- man/hist.Rd | 4 +- man/is_grouped.Rd | 28 ++ man/mutators.Rd | 1 - man/nexus-package.Rd | 4 +- man/pairs.Rd | 67 ++++ man/plot.Rd | 82 ++-- man/plot_logratio.Rd | 100 ----- man/plot_outlier.Rd | 9 +- man/subset.Rd | 4 +- man/totals.Rd | 1 - man/transform_alr.Rd | 6 + man/transform_clr.Rd | 6 + man/transform_ilr.Rd | 12 + man/transform_inverse.Rd | 9 + man/transform_lr.Rd | 3 + man/transform_plr.Rd | 3 + pkgdown/_pkgdown.yml | 3 + vignettes/groups.Rmd | 91 +++++ vignettes/nexus.Rmd | 94 +---- 93 files changed, 1901 insertions(+), 976 deletions(-) create mode 100644 inst/examples/ex-group.R delete mode 100644 inst/examples/ex-groups.R delete mode 100644 inst/tinytest/_snaps/coerce.rds create mode 100644 inst/tinytest/_snaps/coerce_group.rds create mode 100644 inst/tinytest/_snaps/coerce_nogroup.rds create mode 100644 inst/tinytest/test_group.R create mode 100644 man/GroupedComposition-class.Rd create mode 100644 man/GroupedLogRatio-class.Rd delete mode 100644 man/LogicalMatrix-class.Rd create mode 100644 man/ReferenceGroups-class.Rd delete mode 100644 man/extract.Rd create mode 100644 man/group.Rd create mode 100644 man/group_extract.Rd create mode 100644 man/group_metadata.Rd rename man/{split.Rd => group_split.Rd} (56%) delete mode 100644 man/groups.Rd create mode 100644 man/is_grouped.Rd create mode 100644 man/pairs.Rd delete mode 100644 man/plot_logratio.Rd create mode 100644 vignettes/groups.Rmd diff --git a/NAMESPACE b/NAMESPACE index 9808e3f..4b4e63b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,10 @@ # Generated by roxygen2: do not edit by hand S3method(aggregate,CompositionMatrix) +S3method(aggregate,GroupedComposition) S3method(as.data.frame,CompositionMatrix) +S3method(as.data.frame,GroupedComposition) +S3method(as.data.frame,GroupedLogRatio) S3method(as.data.frame,LogRatio) S3method(as.data.frame,OutlierIndex) S3method(barplot,CompositionMatrix) @@ -13,6 +16,7 @@ S3method(mahalanobis,CompositionMatrix) S3method(mahalanobis,ILR) S3method(mean,CompositionMatrix) S3method(plot,CompositionMatrix) +S3method(plot,GroupedComposition) S3method(plot,LogRatio) S3method(plot,OutlierIndex) S3method(quantile,CompositionMatrix) @@ -23,6 +27,7 @@ S3method(weights,ALR) S3method(weights,LR) S3method(weights,LogRatio) export(color) +export(is_grouped) export(palette_color_continuous) export(palette_color_discrete) export(palette_color_picker) @@ -38,9 +43,9 @@ exportMethods("%power%") exportMethods("[") exportMethods("[<-") exportMethods("[[<-") -exportMethods("groups<-") exportMethods("totals<-") exportMethods(aggregate) +exportMethods(all_assigned) exportMethods(any_assigned) exportMethods(as_amounts) exportMethods(as_composition) @@ -52,8 +57,15 @@ exportMethods(covariance) exportMethods(describe) exportMethods(detect_outlier) exportMethods(dist) -exportMethods(extract) -exportMethods(groups) +exportMethods(group) +exportMethods(group_extract) +exportMethods(group_indices) +exportMethods(group_length) +exportMethods(group_levels) +exportMethods(group_names) +exportMethods(group_rows) +exportMethods(group_size) +exportMethods(group_split) exportMethods(hist) exportMethods(is_assigned) exportMethods(is_element_major) @@ -86,6 +98,7 @@ exportMethods(transform_ilr) exportMethods(transform_inverse) exportMethods(transform_lr) exportMethods(transform_plr) +exportMethods(ungroup) exportMethods(univariate_ilr) exportMethods(variance) exportMethods(variance_total) diff --git a/NEWS.md b/NEWS.md index 4cb948c..851702a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,11 @@ # nexus 0.3.0.9000 +## New classes and methods +* Add `ReferenceGroups`, `GroupedComposition` and `GroupedLogRatio` classes to represent grouped data. +* Add `group()`, `ungroup()`, `group_levels()`, `group_names()`, `group_indices()`, `group_rows()`, `group_length()`, `group_size()`, `group_extract()`, `group_split()` and `is_grouped()` to work with grouped data. +* Add `transform_lr()`, `transform_clr()`, `transform_alr()`, `transform_ilr()`, `transform_plr()` and `transform_inverse()` methods for `GroupedComposition` and `GroupedLogRatio` objects. + ## Breaking changes +* Redesign the internal mechanism for grouping data. * `hist()` now produces a single histogram. # nexus 0.3.0 diff --git a/R/AllClasses.R b/R/AllClasses.R index 72c26c8..63b9669 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -8,36 +8,43 @@ setOldClass("dist") ## (for 'i' in x[i], x[i, ], x[, i], etc.) setClassUnion("index", members = c("logical", "numeric", "character")) -# CompositionMatrix ============================================================ -#' Numeric Matrix +# ReferenceGroups ============================================================== +#' Grouped Data #' -#' S4 classes that represent a \eqn{m \times p}{m x p} numeric matrix. -#' @slot .Data A \eqn{m \times p}{m x p} `numeric` [`matrix`]. -#' @note -#' This class inherits from [`matrix`]. +#' A virtual S4 class to represent reference groups. +#' @slot group_indices An [`integer`] vector to store the group that each value +#' belongs to. +#' @slot group_levels A [`character`] vector to store the values of the grouping +#' variables. +#' @example inst/examples/ex-matrix.R #' @author N. Frerebeau #' @family classes #' @docType class -#' @aliases NumericMatrix-class +#' @aliases ReferenceGroups-class #' @keywords internal -.NumericMatrix <- setClass( - Class = "NumericMatrix", - contains = "matrix" +.ReferenceGroups <- setClass( + Class = "ReferenceGroups", + slots = c( + group_indices = "integer", + group_levels = "character" + ), + contains = c("VIRTUAL") ) -#' Logical Matrix +# CompositionMatrix ============================================================ +#' Numeric Matrix #' -#' S4 classes that represent a \eqn{m \times p}{m x p} logical matrix. -#' @slot .Data A \eqn{m \times p}{m x p} `logical` [`matrix`]. +#' S4 classes that represent a \eqn{m \times p}{m x p} numeric matrix. +#' @slot .Data A \eqn{m \times p}{m x p} `numeric` [`matrix`]. #' @note #' This class inherits from [`matrix`]. #' @author N. Frerebeau #' @family classes #' @docType class -#' @aliases LogicalMatrix-class +#' @aliases NumericMatrix-class #' @keywords internal -.LogicalMatrix <- setClass( - Class = "LogicalMatrix", +.NumericMatrix <- setClass( + Class = "NumericMatrix", contains = "matrix" ) @@ -46,7 +53,6 @@ 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 groups A [`factor`] vector to store the group names. #' @section Coerce: #' In the code snippets below, `x` is a `CompositionMatrix` object. #' \describe{ @@ -58,7 +64,7 @@ setClassUnion("index", members = c("logical", "numeric", "character")) #' \item{`x[i, j]`}{Extract parts of a matrix (see [`[`][subset]).} #' } #' @note -#' This class inherits from [`matrix`]. +#' This class inherits from [`NumericMatrix-class`]. #' @seealso [as_composition()] #' @example inst/examples/ex-matrix.R #' @author N. Frerebeau @@ -69,19 +75,40 @@ setClassUnion("index", members = c("logical", "numeric", "character")) .CompositionMatrix <- setClass( Class = "CompositionMatrix", slots = c( - totals = "numeric", - groups = "factor" + totals = "numeric" ), contains = c("NumericMatrix") ) +#' Grouped Compositional Matrix +#' +#' An S4 class to represent grouped compositional data. +#' @section Coerce: +#' In the code snippets below, `x` is a `GroupedComposition` object. +#' \describe{ +#' \item{`as.data.frame(x)`}{Coerces to a [`data.frame`].} +#' } +#' @note +#' This class inherits from [`CompositionMatrix-class`] and +#' [`ReferenceGroups-class`]. +#' @seealso [as_composition()] +#' @example inst/examples/ex-matrix.R +#' @author N. Frerebeau +#' @family classes +#' @docType class +#' @aliases GroupedComposition-class +#' @keywords internal +.GroupedComposition <- setClass( + Class = "GroupedComposition", + contains = c("CompositionMatrix", "ReferenceGroups") +) + # Transformations ============================================================== #' Log-Ratio Matrix #' #' 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 groups A [`factor`] vector to store the group names. #' @slot parts A [`character`] vector to store the original 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,8 +134,6 @@ setClassUnion("index", members = c("logical", "numeric", "character")) Class = "LogRatio", slots = c( totals = "numeric", - groups = "factor", - parts = "character", ratio = "character", order = "integer", @@ -153,12 +178,71 @@ setClassUnion("index", members = c("logical", "numeric", "character")) contains = "ILR" ) +#' Grouped Log-Ratio Matrix +#' +#' An S4 class to represent grouped log-ratio. +#' @section Coerce: +#' In the code snippets below, `x` is a `GroupedLogRatio` object. +#' \describe{ +#' \item{`as.data.frame(x)`}{Coerces to a [`data.frame`].} +#' } +#' @note +#' This class inherits from [`LogRatio-class`] and +#' [`ReferenceGroups-class`]. +#' @example inst/examples/ex-matrix.R +#' @author N. Frerebeau +#' @family classes +#' @docType class +#' @name GroupedLogRatio-class +#' @rdname GroupedLogRatio-class +#' @keywords internal +NULL + +#' @rdname GroupedLogRatio-class +#' @aliases GroupedLR-class +.GroupedLR <- setClass( + Class = "GroupedLR", + contains = c("LR", "ReferenceGroups") +) + +#' @rdname GroupedLogRatio-class +#' @aliases GroupedCLR-class +.GroupedCLR <- setClass( + Class = "GroupedCLR", + contains = c("CLR", "ReferenceGroups") +) + +#' @rdname GroupedLogRatio-class +#' @aliases GroupedALR-class +.GroupedALR <- setClass( + Class = "GroupedALR", + contains = c("ALR", "ReferenceGroups") +) + +#' @rdname GroupedLogRatio-class +#' @aliases GroupedILR-class +.GroupedILR <- setClass( + Class = "GroupedILR", + contains = c("ILR", "ReferenceGroups") +) + +#' @rdname GroupedLogRatio-class +#' @aliases GroupedPLR-class +.GroupedPLR <- setClass( + Class = "GroupedPLR", + contains = c("PLR", "ReferenceGroups") +) + +setClassUnion( + name = "GroupedLogRatio", + members = c("GroupedLR", "GroupedCLR", "GroupedALR", "GroupedILR", "GroupedPLR") +) + # OutlierIndex ================================================================= #' Outliers #' #' An S4 class to store the result of outlier detection. #' @slot samples A [`character`] vector to store the sample identifiers. -#' @slot groups A [`factor`] vector to store the group names. #' @slot standard A [`numeric`] matrix giving the standard squared Mahalanobis #' distances. #' @slot robust A [`numeric`] matrix giving the robust squared Mahalanobis @@ -180,7 +264,6 @@ setClassUnion("index", members = c("logical", "numeric", "character")) Class = "OutlierIndex", slots = c( samples = "character", - groups = "factor", standard = "numeric", robust = "numeric", limit = "numeric", diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 65ca4f6..3551377 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -183,6 +183,54 @@ setGeneric( ) # Extract ====================================================================== + + +## Subset ---------------------------------------------------------------------- +#' Extract or Replace Parts of an Object +#' +#' Operators acting on objects to extract or replace parts. +#' @param x An object from which to extract element(s) or in which to replace +#' element(s). +#' @param i,j Indices specifying elements to extract or replace. Indices are +#' [`numeric`], [`integer`] or [`character`] vectors or empty (missing) or +#' `NULL`. Numeric values are coerced to [`integer`] as by [as.integer()]. +#' Character vectors will be matched to the name of the elements. +#' An empty index (a comma separated blank) indicates that all entries in that +#' dimension are selected. +#' @param value A possible value for the element(s) of `x`. +#' @param drop A [`logical`] scalar: should the result be coerced to +#' the lowest possible dimension? This only works for extracting elements, +#' not for the replacement. Defaults to `FALSE`. +#' @param ... Currently not used. +# @section Subcomposition: +# If `drop` is `FALSE`, subsetting some of the possible components of a +# [`CompositionMatrix-class`] object will produce a closed *subcomposition* +# (see examples). +#' @return +#' A subsetted object of the same sort as `x`. +#' @example inst/examples/ex-subset.R +#' @author N. Frerebeau +#' @docType methods +#' @family subsetting methods +#' @name subset +#' @rdname subset +NULL + +#' Combine Two Composition Matrices +#' +#' @param x,y A [`CompositionMatrix-class`] object. +#' @details +#' `rbind2()` combine by rows. +#' @return +#' A [`CompositionMatrix-class`] objects. +#' @example inst/examples/ex-split.R +#' @author N. Frerebeau +#' @docType methods +#' @family subsetting methods +#' @name bind +#' @rdname bind +NULL + ## Mutators -------------------------------------------------------------------- #' Get or Set Parts of an Object #' @@ -224,55 +272,172 @@ setGeneric( def = function(object, value) standardGeneric("totals<-") ) +#' Matrix Transpose +#' +#' @param x A [`CompositionMatrix-class`] object. +#' @return +#' A `matrix`, with dim and dimnames constructed appropriately from those of `x`. +#' @note +#' Implemented only to ensure that `t()` always returns a base `matrix`. +#' @example inst/examples/ex-subset.R +#' @author N. Frerebeau +#' @docType methods +# @family mutators +#' @keywords internal +#' @name t +#' @rdname t +NULL + +# Groups ======================================================================= #' Working With Groups #' -#' Retrieves or defines the (reference) groups to which the observations belong. -#' @param object An object from which to get or set `groups`. -#' @param value A possible value for the `groups` of `x` (typically, a -#' [`character`] vector). -#' If `value` is a [`list`], [`interaction(value)`][interaction()] defines the -#' grouping. +#' Define or remove the (reference) groups to which the observations belong. +#' @param object An \R object (typically, a [`CompositionMatrix-class`] object). +#' @param by A possible value for the groups of `object` (typically, a +#' [`character`] vector). If `value` is a [`list`], +#' [`interaction(by)`][interaction()] defines the grouping. +#' @param add A [`logical`] scalar. If `TRUE`, add to existing groups. +#' @param verbose A [`logical`] scalar: should \R report extra information +#' on progress? +#' @param ... Further parameters to be passed to internal methods. #' @details -#' Missing values (`NA`) or empty strings (`""`) can be used to specify that a -#' sample does not belong to any group. +#' Missing values (`NA`) can be used to specify that a sample does not belong +#' to any group. #' @return -#' * `groups() <- value` returns an object of the same sort as `x` with the new -#' group names assigned. -#' * `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-groups.R +#' * `group()` returns a grouped object of the same sort as `object`. +#' * `ungroup()` returns an ungrouped object of the same sort as `object`. +#' @example inst/examples/ex-group.R #' @author N. Frerebeau #' @docType methods -#' @family mutators -#' @aliases groups-method +#' @family grouping methods +#' @aliases group-method setGeneric( - name = "groups", - def = function(object) standardGeneric("groups") + name = "group", + def = function(object, ...) standardGeneric("group") ) -#' @rdname groups +#' @rdname group setGeneric( - name = "groups<-", - def = function(object, value) standardGeneric("groups<-") + name = "ungroup", + def = function(object, ...) standardGeneric("ungroup") ) -#' @rdname groups -#' @aliases any_assigned-method +#' Grouping Metadata +#' +#' Retrieve the (reference) groups to which the observations belong. +#' @param object A [grouped][group()] \R object. +#' @example inst/examples/ex-group.R +#' @author N. Frerebeau +#' @docType methods +#' @family grouping methods +#' @name group_metadata +#' @rdname group_metadata +NULL + +#' @rdname group_metadata +#' @aliases group_levels-method setGeneric( - name = "any_assigned", - def = function(object) standardGeneric("any_assigned") + name = "group_levels", + def = function(object) standardGeneric("group_levels") +) + +#' @rdname group_metadata +#' @aliases group_names-method +setGeneric( + name = "group_names", + def = function(object) standardGeneric("group_names") +) + +#' @rdname group_metadata +#' @aliases group_rows-method +setGeneric( + name = "group_rows", + def = function(object) standardGeneric("group_rows") +) + +#' @rdname group_metadata +#' @aliases group_length-method +setGeneric( + name = "group_length", + def = function(object) standardGeneric("group_length") +) + +#' @rdname group_metadata +#' @aliases group_size-method +setGeneric( + name = "group_size", + def = function(object) standardGeneric("group_size") ) -#' @rdname groups +#' @rdname group_metadata +#' @aliases group_indices-method +setGeneric( + name = "group_indices", + def = function(object) standardGeneric("group_indices") +) + +#' @rdname group_metadata #' @aliases is_assigned-method setGeneric( name = "is_assigned", def = function(object) standardGeneric("is_assigned") ) +#' @rdname group_metadata +#' @aliases any_assigned-method +setGeneric( + name = "any_assigned", + def = function(object) standardGeneric("any_assigned") +) + +#' @rdname group_metadata +#' @aliases any_assigned-method +setGeneric( + name = "all_assigned", + def = function(object) standardGeneric("all_assigned") +) + +#' Divide into Groups +#' +#' Divides a compositional matrix by groups. +#' @param object,x A [`CompositionMatrix-class`] object. +#' @param by A `vector` or a list of grouping elements, each as long as the +#' variables in `object` (see [group()]). +#' @param f A 'factor' in the sense that [`as.factor(f)`][as.factor()] defines +#' the grouping, or a list of such factors in which case their interaction is +#' used for the grouping (see [base::split()]). +#' @param drop A [`logical`] scalar: should levels that do not occur be dropped? +#' @param ... Currently not used. +#' @return +#' A `list` of [`CompositionMatrix-class`] objects. +#' @example inst/examples/ex-split.R +#' @author N. Frerebeau +#' @docType methods +#' @family grouping methods +#' @aliases group_split-method +setGeneric( + name = "group_split", + def = function(object, ...) standardGeneric("group_split") +) + +#' Group-based Subset +#' +#' @param object A [`GroupedComposition-class`] object. +#' @param which A [`character`] vector specifying the [groups][group()] of +#' `object` to extract. +#' @param ... Currently not used. +#' @return +#' A [`CompositionMatrix-class`] object. +#' @example inst/examples/ex-group.R +#' @author N. Frerebeau +#' @docType methods +#' @family grouping methods +#' @aliases group_extract-method +setGeneric( + name = "group_extract", + def = function(object, ...) standardGeneric("group_extract") +) + # Tools ======================================================================== #' Chemical Elements and Oxides #' @@ -339,105 +504,6 @@ setGeneric( valueClass = "logical" ) -## Subset ---------------------------------------------------------------------- -#' Extract or Replace Parts of an Object -#' -#' Operators acting on objects to extract or replace parts. -#' @param x An object from which to extract element(s) or in which to replace -#' element(s). -#' @param i,j Indices specifying elements to extract or replace. Indices are -#' [`numeric`], [`integer`] or [`character`] vectors or empty (missing) or -#' `NULL`. Numeric values are coerced to [`integer`] as by [as.integer()]. -#' Character vectors will be matched to the name of the elements. -#' An empty index (a comma separated blank) indicates that all entries in that -#' dimension are selected. -#' @param value A possible value for the element(s) of `x`. -#' @param drop A [`logical`] scalar: should the result be coerced to -#' the lowest possible dimension? This only works for extracting elements, -#' not for the replacement. Defaults to `FALSE`. -#' @param ... Currently not used. -# @section Subcomposition: -# If `drop` is `FALSE`, subsetting some of the possible components of a -# [`CompositionMatrix-class`] object will produce a closed *subcomposition* -# (see examples). -#' @return -#' A subsetted object of the same sort as `x`. -#' @example inst/examples/ex-subset.R -#' @author N. Frerebeau -#' @docType methods -#' @family subsetting methods -#' @name subset -#' @rdname subset -NULL - -#' Group-based Subset -#' -#' @param object A [`CompositionMatrix-class`] object. -#' @param name A [`character`] vector specifying the [group][groups()] of -#' `object` to extract. -#' @param ... Currently not used. -#' @return -#' A [`CompositionMatrix-class`] object. -#' @example inst/examples/ex-groups.R -#' @author N. Frerebeau -#' @docType methods -#' @family subsetting methods -#' @aliases extract-method -setGeneric( - name = "extract", - def = function(object, ...) standardGeneric("extract") -) - -#' Divide into Groups -#' -#' Divides the compositional matrix `x` into the groups defined by `f`. -#' @param x A [`CompositionMatrix-class`] object. -#' @param f A 'factor' in the sense that [`as.factor(f)`][as.factor()] defines -#' the grouping, or a list of such factors in which case their interaction is -#' used for the grouping (see [base::split()]). -#' @param drop A [`logical`] scalar: should levels that do not occur be dropped? -#' @param ... Currently not used. -#' @return -#' A `list` of [`CompositionMatrix-class`] objects. -#' @example inst/examples/ex-split.R -#' @author N. Frerebeau -#' @docType methods -#' @family subsetting methods -#' @name split -#' @rdname split -NULL - -#' Combine Two Composition Matrices -#' -#' @param x,y A [`CompositionMatrix-class`] object. -#' @details -#' `rbind2()` combine by rows. -#' @return -#' A [`CompositionMatrix-class`] objects. -#' @example inst/examples/ex-split.R -#' @author N. Frerebeau -#' @docType methods -#' @family subsetting methods -#' @name bind -#' @rdname bind -NULL - -#' Matrix Transpose -#' -#' @param x A [`CompositionMatrix-class`] object. -#' @return -#' A `matrix`, with dim and dimnames constructed appropriately from those of `x`. -#' @note -#' Implemented only to ensure that `t()` always returns a base `matrix`. -#' @example inst/examples/ex-subset.R -#' @author N. Frerebeau -#' @docType methods -# @family mutators -#' @keywords internal -#' @name t -#' @rdname t -NULL - # Log-Ratio ==================================================================== ## LR -------------------------------------------------------------------------- #' Pairwise Log-Ratios (LR) @@ -690,8 +756,7 @@ setGeneric( #' returns the result. #' @param x A [`CompositionMatrix-class`] object. #' @param by A `vector` or a list of grouping elements, each as long as the -#' variables in `x`. The elements are coerced to factors before use -#' (in the sense that [`interaction(by)`][interaction()] defines the grouping). +#' variables in `x` (see [group()]). #' @param FUN A [`function`] to compute the summary statistics. #' @param simplify A [`logical`] scalar: should the results be simplified to a #' matrix if possible? @@ -751,8 +816,9 @@ NULL #' Splits the data into subsets and computes compositional mean for each. #' @param x A [`CompositionMatrix-class`] object. #' @param by A `vector` or a list of grouping elements, each as long as the -#' variables in `x`. The elements are coerced to factors before use -#' (in the sense that [`interaction(by)`][interaction()] defines the grouping). +#' variables in `x` (see [group()]). +#' @param verbose A [`logical`] scalar: should \R report extra information +#' on progress? #' @param ... Further arguments to be passed to [mean()]. #' @return A [`CompositionMatrix-class`] object. #' @seealso [mean()], [aggregate()] @@ -1038,8 +1104,6 @@ NULL #' #' Displays a compositional bar chart. #' @param height A [`CompositionMatrix-class`] object. -#' @param by A `vector` of grouping elements, as long as the variables in -#' `height`. #' @param order_columns A [`logical`] scalar: should should columns be reorderd? #' @param order_rows An [`integer`] vector giving the index of the column to be #' used for the ordering of the data. @@ -1111,7 +1175,6 @@ NULL #' #' Displays a matrix of ternary plots. #' @param x A [`CompositionMatrix-class`] object. -#' @param by A `vector` of grouping elements, as long as the variables in `x`. #' @param color A palette [`function`] that when called with a single #' argument returns a `character` vector of colors. #' @param symbol A palette [`function`] that when called with a single @@ -1125,8 +1188,8 @@ NULL #' @author N. Frerebeau #' @docType methods #' @family plot methods -#' @name plot -#' @rdname plot +#' @name pairs +#' @rdname pairs NULL ## Density --------------------------------------------------------------------- @@ -1134,10 +1197,9 @@ NULL #' #' Displays a density plot. #' @param x A [`LogRatio-class`] object. -#' @param by A `vector` of grouping elements, as long as the variables in -#' `x`. If set, a matrix of panels defined by `groups` will be drawn. #' @param color A palette [`function`] that when called with a single -#' argument returns a `character` vector of colors. +#' argument returns a `character` vector of colors (only used if `x` +#' [is grouped][group()]). #' @param rug A [`logical`] scalar: should a *rug* representation (1-d plot) of #' the data be added to the plot? #' @param ticksize A length-one [`numeric`] vector giving the length of the @@ -1166,8 +1228,8 @@ NULL #' @author N. Frerebeau #' @docType methods #' @family plot methods -#' @name plot_logratio -#' @rdname plot_logratio +#' @name plot +#' @rdname plot NULL ## Graph ----------------------------------------------------------------------- @@ -1382,9 +1444,6 @@ setGeneric( #' Any unambiguous substring can be given. #' @param robust A [`logical`] scalar: should robust Mahalanobis distances be #' displayed? Only used if `type` is "`dotchart`". -#' @param colors A vector of colors or a `function` that when called with a -#' single argument (an integer specifying the number of colors) returns a -#' vector of colors. Will be mapped to the group names. #' @param symbols A lenth-three vector of symbol specification for non-outliers #' and outliers (resp.). #' @param xlim A length-two [`numeric`] vector giving the x limits of the plot. @@ -1409,7 +1468,7 @@ setGeneric( #' @param legend A [`list`] of additional arguments to be passed to #' [graphics::legend()]; names of the list are used as argument names. #' If `NULL`, no legend is displayed. -#' @param ... Further [graphical parameters][graphics::par()]. +#' @param ... Further parameters to be passed to [graphics::points()]. #' @return #' `plot()` is called for its side-effects: is results in a graphic being #' displayed (invisibly return `x`). diff --git a/R/aggregate.R b/R/aggregate.R index b3a697e..bd7a51e 100644 --- a/R/aggregate.R +++ b/R/aggregate.R @@ -7,23 +7,25 @@ NULL #' @method aggregate CompositionMatrix aggregate.CompositionMatrix <- function(x, by, FUN, ..., simplify = TRUE, drop = TRUE) { - m <- nrow(x) + x <- group(x, by = by, drop_levels = drop) + aggregate(x, FUN, ..., simplify = simplify) +} - ## Grouping - index <- as_groups(by) - if (nlevels(index) == 0 || nlevels(index) == m) { - warning("Nothing to group by.", call. = FALSE) - return(x) - } +#' @export +#' @rdname aggregate +#' @aliases aggregate,CompositionMatrix-method +setMethod("aggregate", "CompositionMatrix", aggregate.CompositionMatrix) - aggr <- tapply( - X = seq_len(m), - INDEX = index, +#' @export +#' @method aggregate GroupedComposition +aggregate.GroupedComposition <- function(x, FUN, ..., simplify = TRUE) { + ## Grouping + aggr <- lapply( + X = group_rows(x), FUN = function(i, data, fun, ...) fun(data[i, , drop = FALSE], ...), data = x, fun = FUN, - ..., - simplify = FALSE + ... ) has_dim <- vapply( @@ -33,10 +35,12 @@ aggregate.CompositionMatrix <- function(x, by, FUN, ..., ) if (any(has_dim) || !simplify) return(aggr) - do.call(rbind, aggr) + aggr <- do.call(rbind, aggr) + rownames(aggr) <- group_levels(x) + aggr } #' @export #' @rdname aggregate -#' @aliases aggregate,CompositionMatrix-method -setMethod("aggregate", "CompositionMatrix", aggregate.CompositionMatrix) +#' @aliases aggregate,GroupedComposition-method +setMethod("aggregate", "GroupedComposition", aggregate.GroupedComposition) diff --git a/R/barplot.R b/R/barplot.R index 1ba786a..a038b85 100644 --- a/R/barplot.R +++ b/R/barplot.R @@ -6,7 +6,6 @@ NULL #' @export #' @method barplot CompositionMatrix barplot.CompositionMatrix <- function(height, ..., - by = groups(height), order_columns = FALSE, order_rows = NULL, decreasing = TRUE, space = 0.2, offset = 0.025, @@ -18,7 +17,7 @@ barplot.CompositionMatrix <- function(height, ..., } ## Prepare data - xy <- prepare_barplot(height, groups = by, order_columns = order_columns, + xy <- prepare_barplot(height, order_columns = order_columns, order_rows = order_rows, decreasing = decreasing, offset = offset) parts <- factor(xy$data$column, levels = colnames(height)) @@ -99,27 +98,20 @@ barplot.CompositionMatrix <- function(height, ..., #' @aliases barplot,CompositionMatrix-method setMethod("barplot", c(height = "CompositionMatrix"), barplot.CompositionMatrix) -prepare_barplot <- function(x, groups = NULL, - order_rows = NULL, order_columns = FALSE, +prepare_barplot <- function(x, order_rows = NULL, order_columns = FALSE, decreasing = TRUE, offset = 0.025) { - ## Prepare groups - n <- nrow(x) - grp <- as_groups(groups, drop_na = FALSE) - if (nlevels(grp) == 0 || nlevels(grp) == n) grp <- rep("", n) - ## Relative frequencies + n <- nrow(x) x <- x / rowSums(x) ## Validation - stopifnot(methods::is(x, "CompositionMatrix")) - arkhe::assert_length(grp, n) + stopifnot(is_coda(x)) ## Row order if (!is.null(order_rows)) { j <- x[, order_rows, drop = TRUE] i <- order(j, decreasing = decreasing) x <- x[i, , drop = FALSE] - grp <- grp[i] } ## Columns order @@ -131,7 +123,10 @@ prepare_barplot <- function(x, groups = NULL, } ## Grouping - spl <- split(x = x, f = grp) + if (!is_grouped(x)) { + x <- group(x, by = rep(NA, n), verbose = FALSE) + } + spl <- group_split(x) z <- do.call(rbind, spl) ## Build a long table @@ -150,8 +145,8 @@ prepare_barplot <- function(x, groups = NULL, data$y <- as.vector(n + 1 - as.numeric(row)) / n # Reverse levels order ## Offset - n_grp <- length(spl) - n_spl <- tapply(X = grp, INDEX = grp, FUN = length) + n_grp <- group_length(x) + n_spl <- group_size(x) offset <- rev(seq_len(n_grp)) * offset - offset data$y <- data$y + rep(offset, n_spl)[as.numeric(row)] diff --git a/R/coerce.R b/R/coerce.R index 6dd7121..24683d7 100644 --- a/R/coerce.R +++ b/R/coerce.R @@ -31,8 +31,7 @@ setMethod( totals <- rowSums(from, na.rm = TRUE) from <- from / totals - grp <- as_groups(rep(NA, nrow(from))) - .CompositionMatrix(from, totals = unname(totals), groups = grp) + .CompositionMatrix(from, totals = unname(totals)) } ) @@ -49,20 +48,14 @@ setMethod( 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_groups(grp) - ## Remove non-numeric columns if (is.null(parts)) { parts <- arkhe::detect(from, f = is.double, margin = 2) # Logical - if (verbose) { + if (isTRUE(verbose)) { n <- sum(parts) - what <- ngettext(n, "part", "parts") + what <- ngettext(n, "Found %g part (%s)", "Found %g parts (%s)") cols <- paste0(colnames(from)[parts], collapse = ", ") - msg <- "Found %g %s (%s)." - message(sprintf(msg, n, what, cols)) + message(sprintf(what, n, cols)) } } else { if (is.numeric(parts)) parts <- seq_len(ncol(from)) %in% parts @@ -76,7 +69,12 @@ setMethod( totals <- rowSums(coda, na.rm = TRUE) coda <- coda / totals - .CompositionMatrix(coda, totals = unname(totals), groups = grp) + z <- .CompositionMatrix(coda, totals = unname(totals)) + if (is.null(groups)) return(z) + + ## Group names + grp <- from[, groups, drop = FALSE] + group(z, by = grp, verbose = verbose) } ) @@ -93,46 +91,40 @@ setMethod( ) # To data.frame ================================================================ -# @export -# @rdname augment -# @aliases augment,CompositionMatrix-method -# setMethod( -# f = "augment", -# signature = c(x = "CompositionMatrix"), -# definition = function(x) { -# data.frame( -# .group = groups(x), -# x -# ) -# } -# ) - -# @export -# @rdname augment -# @aliases augment,LogRatio-method -# setMethod( -# f = "augment", -# signature = c(x = "LogRatio"), -# definition = function(x) { -# data.frame( -# .group = groups(x), -# x -# ) -# } -# ) - #' @method as.data.frame CompositionMatrix #' @export as.data.frame.CompositionMatrix <- function(x, ...) { as.data.frame(methods::as(x, "matrix"), row.names = rownames(x)) } +#' @method as.data.frame GroupedComposition +#' @export +as.data.frame.GroupedComposition <- function(x, ..., group_var = ".group") { + z <- data.frame( + methods::as(x, "matrix"), + row.names = rownames(x) + ) + z[[group_var]] <- group_names(x) + z +} + #' @method as.data.frame LogRatio #' @export as.data.frame.LogRatio <- function(x, ...) { as.data.frame(methods::as(x, "matrix"), row.names = rownames(x)) } +#' @method as.data.frame GroupedLogRatio +#' @export +as.data.frame.GroupedLogRatio <- function(x, ..., group_var = ".group") { + z <- data.frame( + methods::as(x, "matrix"), + row.names = rownames(x) + ) + z[[group_var]] <- group_names(x) + z +} + #' @method as.data.frame OutlierIndex #' @export as.data.frame.OutlierIndex <- function(x, ...) { diff --git a/R/condense.R b/R/condense.R index 1aba536..4677c26 100644 --- a/R/condense.R +++ b/R/condense.R @@ -7,36 +7,36 @@ NULL #' @aliases condense,CompositionMatrix-method setMethod( f = "condense", - signature = c("CompositionMatrix"), - definition = function(x, by = groups(x), ...) { - m <- nrow(x) + signature = "CompositionMatrix", + definition = function(x, by, verbose = getOption("nexus.verbose"), ...) { + x <- group(x, by = by) + methods::callGeneric(x = x, verbose = verbose, ...) + } +) +#' @export +#' @rdname condense +#' @aliases condense,GroupedComposition-method +setMethod( + f = "condense", + signature = "GroupedComposition", + definition = function(x, by = NULL, verbose = getOption("nexus.verbose"), ...) { ## Grouping - index <- as_groups(by) - if (nlevels(index) == 0 || nlevels(index) == m) { - warning("Nothing to group by.", call. = FALSE) - return(x) - } - - z <- tapply( - X = seq_len(m), - INDEX = index, - FUN = function(i, data, ...) { - mean(data[i, , drop = FALSE], ...) - }, - data = x, - ..., - simplify = FALSE - ) - z <- do.call(rbind, z) + grp <- group_factor(x) + if (!is.null(by)) x <- group(x, by = by, verbose = verbose) - tot <- tapply(X = totals(x), INDEX = index, FUN = mean, simplify = TRUE) - grp <- groups(x) + ## Compute mean + z <- aggregate(x, FUN = mean, ..., simplify = TRUE) + tot <- tapply(X = totals(x), INDEX = group_factor(x), FUN = mean) - if (nlevels(grp) > 0) grp <- flatten_chr(x = grp, by = index) - else grp <- rep(NA, nlevels(index)) - - rownames(z) <- levels(index) - .CompositionMatrix(z, totals = as.numeric(tot), groups = as_groups(grp)) + z <- .CompositionMatrix(z, totals = as.numeric(tot)) + group(z, by = flatten_chr(x = grp, by = group_factor(x)), verbose = verbose) } ) + +flatten_chr <- function(x, by) { + x <- as.character(x) + z <- tapply(X = x, INDEX = by, FUN = unique, simplify = FALSE) + z <- vapply(X = z, FUN = paste0, FUN.VALUE = character(1), collapse = ":") + z +} diff --git a/R/describe.R b/R/describe.R index aa6a687..be2fe1b 100644 --- a/R/describe.R +++ b/R/describe.R @@ -12,48 +12,75 @@ setMethod( ## Dimensions m <- nrow(x) p <- ncol(x) + rows <- sprintf(ngettext(m, "%d composition", "%d compositions"), m) + cols <- sprintf(ngettext(p, "with %d part", "with %d parts"), p) + msg_tbl <- sprintf("%s %s:", rows, cols) - rows <- ngettext(m, "composition", "compositions") - cols <- ngettext(p, "part", "parts") + ## Message + cat(msg_tbl) + .describe(x) - msg_tbl <- sprintf("%d %s with %d %s:", m, rows, p, cols) - - ## Missing values - m_NA <- sum(arkhe::detect(x, f = is.na, margin = 1)) - p_NA <- sum(arkhe::detect(x, f = is.na, margin = 2)) - - rows_NA <- ngettext(m_NA, "composition", "compositions") - cols_NA <- ngettext(p_NA, "part", "parts") - - pc <- arkhe::label_percent(c(m_NA / m, p_NA / p), digits = 1, trim = TRUE) - pc_NA <- sprintf(" (%s)", pc) - - msg_row_NA <- sprintf("%d %s%s containing missing values.", m_NA, rows_NA, pc_NA[[1]]) - msg_col_NA <- sprintf("%d %s%s containing missing values.", p_NA, cols_NA, pc_NA[[2]]) + invisible(x) + } +) - ## Constant columns - p_var <- sum(arkhe::detect(x, f = function(x) is_unique(x), margin = 2)) - cols_var <- ngettext(p_var, "part", "parts") - msg_col_var <- sprintf("%d %s with no variance.", p_var, cols_var) +#' @export +#' @rdname describe +#' @aliases describe,GroupedComposition-method +setMethod( + f = "describe", + signature = c(x = "GroupedComposition"), + definition = function(x) { + ## Dimensions + m <- nrow(x) + p <- ncol(x) - ## Sparsity - spa <- arkhe::sparsity(x, count = FALSE) - msg_spa <- sprintf("%s of values are zero.", label_percent(spa, digits = 1)) + rows <- sprintf(ngettext(m, "%d composition", "%d compositions"), m) + cols <- sprintf(ngettext(p, "with %d part", "with %d parts"), p) + msg_tbl <- sprintf("%s %s:", rows, cols) ## Groups - groups <- 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")) + i <- group_length(x) + ls_grp <- paste0(dQuote(group_levels(x)), collapse = ", ") + msg_grp <- sprintf(ngettext(i, "%d group", "%d groups"), i) + msg_grp <- sprintf("%s: %s.", msg_grp, ls_grp) + + j <- sum(!is_assigned(x)) + msg_ung <- sprintf(ngettext(j, "%d unassigned sample.", "%d unassigned samples."), j) 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* ") + .describe(x) invisible(x) } ) + +.describe <- function(x) { + m <- nrow(x) + p <- ncol(x) + + ## Missing values + m_NA <- sum(arkhe::detect(x, f = is.na, margin = 1)) + p_NA <- sum(arkhe::detect(x, f = is.na, margin = 2)) + + rows_NA <- ngettext(m_NA, "composition", "compositions") + cols_NA <- ngettext(p_NA, "part", "parts") + + pc <- arkhe::label_percent(c(m_NA / m, p_NA / p), digits = 1, trim = TRUE) + pc_NA <- sprintf(" (%s)", pc) + + msg_row_NA <- sprintf("%d %s%s containing missing values.", m_NA, rows_NA, pc_NA[[1]]) + msg_col_NA <- sprintf("%d %s%s containing missing values.", p_NA, cols_NA, pc_NA[[2]]) + + ## Constant columns + p_var <- sum(arkhe::detect(x, f = function(x) is_unique(x), margin = 2)) + cols_var <- ngettext(p_var, "%d part with no variance.", "%d parts with no variance.") + msg_col_var <- sprintf(cols_var, p_var) + + ## Sparsity + spa <- arkhe::sparsity(x, count = FALSE) + msg_spa <- sprintf("%s of values are zero.", label_percent(spa, digits = 1)) + + cat("\nData checking:", msg_spa, msg_col_var, sep = "\n* ") + cat("\nMissing values:", msg_row_NA, msg_col_NA, sep = "\n* ") +} diff --git a/R/group.R b/R/group.R index 4189a9d..c619afa 100644 --- a/R/group.R +++ b/R/group.R @@ -3,21 +3,21 @@ NULL #' @export -#' @rdname extract -#' @aliases extract,CompositionMatrix-method +#' @rdname group_extract +#' @aliases group_extract,GroupedComposition-method setMethod( - f = "extract", - signature = c("CompositionMatrix"), - definition = function(object, name) { + f = "group_extract", + signature = c("GroupedComposition"), + definition = function(object, which) { ## Validation - arkhe::assert_type(name, "character") + arkhe::assert_type(which, "character") if (!any_assigned(object)) stop("No group is defined.", call. = FALSE) - ok <- groups(object) %in% name + ok <- group_names(object) %in% which if (!any(ok)) { - g <- ngettext(length(name), "group", "groups") - msg <- "No sample belongs to the %s %s." - message(sprintf(msg, g, paste0(dQuote(name), collapse = ", "))) + msg <- ngettext(length(which), "No sample belongs to the group: %s.", + "No sample belongs to the groups: %s.") + message(sprintf(msg, paste0(dQuote(which), collapse = ", "))) return(object) } @@ -26,88 +26,238 @@ setMethod( ) # Groups ======================================================================= -as_groups <- function(x, drop_levels = TRUE, drop_na = TRUE) { - if (!is.factor(x)) { - if (!is.list(x)) x <- list(x) - x <- rapply( - object = x, - f = function(x) { - x[x == ""] <- NA - x - }, - classes = "character", - how = "replace" - ) - x <- interaction(x, sep = "_") - } +#' Compute Groups +#' +#' @param x A ([`list`] of) [`factors`] for which interaction is to be computed. +#' @param drop_levels A [`logical`] scalar: should unused factor levels be +#' dropped? +#' @param allow_na A [`logical`] scalar: should `NA` be considered an extra +#' level? +#' @return A [`factor`] vector. +#' @keywords internal +#' @noRd +compute_groups <- function(x, drop_levels = TRUE, allow_na = TRUE) { + if (!is.list(x)) x <- list(x) + x <- interaction(x, sep = "_") if (drop_levels) x <- droplevels(x) - if (!drop_na) x <- addNA(x, ifany = TRUE) + if (allow_na) x <- addNA(x, ifany = TRUE) + x } -in_groups <- function(x) { - !is.na(x) & x != "" -} #' @export -#' @rdname groups -#' @aliases is_assigned,CompositionMatrix-method -setMethod("is_assigned", "CompositionMatrix", function(object) in_groups(groups(object))) +#' @rdname group +#' @aliases group,CompositionMatrix-method +setMethod( + f = "group", + signature = "CompositionMatrix", + definition = function(object, by, verbose = getOption("nexus.verbose"), ...) { + ## Compute groups + by <- compute_groups(by, ...) + + ## Validation + arkhe::assert_length(by, nrow(object)) + if (nlevels(by) == 0) { + stop("Nothing to group by.", call. = FALSE) + } + if (isTRUE(verbose)) { + if (nlevels(by) == nrow(object)) { + message("As many groups as individuals.") + } + + n <- nlevels(by) + what <- ngettext(n, "Found %g group (%s)", "Found %g groups (%s)") + grp <- paste0(levels(by), collapse = ", ") + message(sprintf(what, n, grp)) + } + + .GroupedComposition( + object, + group_indices = as.integer(by), + group_levels = levels(by) + ) + } +) #' @export -#' @rdname groups -#' @aliases is_assigned,LogRatio-method -setMethod("is_assigned", "LogRatio", function(object) in_groups(groups(object))) +#' @rdname group +#' @aliases group,GroupedComposition-method +setMethod( + f = "group", + signature = "GroupedComposition", + definition = function(object, by, add = FALSE, + verbose = getOption("nexus.verbose"), ...) { + ## Compute groups + if (isTRUE(add)) { + if (!is.list(by)) by <- list(by) + by <- c(list(group_factor(object)), by) + } + methods::callNextMethod(object, by = by, verbose = verbose, ...) + } +) #' @export -#' @rdname groups -#' @aliases any_assigned,CompositionMatrix-method -setMethod("any_assigned", "CompositionMatrix", function(object) any(is_assigned(object))) +#' @rdname group +#' @aliases ungroup,GroupedComposition-method +setMethod( + f = "ungroup", + signature = "GroupedComposition", + definition = function(object) { + methods::as(object, "CompositionMatrix", strict = TRUE) + } +) #' @export -#' @rdname groups -#' @aliases any_assigned,LogRatio-method -setMethod("any_assigned", "LogRatio", function(object) any(is_assigned(object))) +#' @rdname group +#' @aliases ungroup,GroupedLR-method +setMethod( + f = "ungroup", + signature = "GroupedLR", + definition = function(object) { + methods::as(object, "LR", strict = TRUE) + } +) #' @export -#' @rdname groups -#' @aliases groups,CompositionMatrix-method -setMethod("groups", "CompositionMatrix", function(object) object@groups) +#' @rdname group +#' @aliases ungroup,GroupedCLR-method +setMethod( + f = "ungroup", + signature = "GroupedCLR", + definition = function(object) { + methods::as(object, "CLR", strict = TRUE) + } +) #' @export -#' @rdname groups -#' @aliases groups,LogRatio-method -setMethod("groups", "LogRatio", function(object) object@groups) +#' @rdname group +#' @aliases ungroup,GroupedALR-method +setMethod( + f = "ungroup", + signature = "GroupedALR", + definition = function(object) { + methods::as(object, "ALR", strict = TRUE) + } +) #' @export -#' @rdname groups -#' @aliases groups,OutlierIndex-method -setMethod("groups", "OutlierIndex", function(object) object@groups) +#' @rdname group +#' @aliases ungroup,GroupedILR-method +setMethod( + f = "ungroup", + signature = "GroupedILR", + definition = function(object) { + methods::as(object, "ILR", strict = TRUE) + } +) #' @export -#' @rdname groups -#' @aliases groups,CompositionMatrix,ANY-method +#' @rdname group +#' @aliases ungroup,GroupedPLR-method setMethod( - f = "groups<-", - signature = c(object = "CompositionMatrix", value = "ANY"), - definition = function(object, value) { - if (is.null(value)) value <- rep(NA_character_, nrow(object)) - value <- as_groups(value) - object@groups <- value - methods::validObject(object) - object + f = "ungroup", + signature = "GroupedPLR", + definition = function(object) { + methods::as(object, "PLR", strict = TRUE) } ) +# Metadata ===================================================================== #' @export -#' @rdname groups -#' @aliases groups,CompositionMatrix,list-method +#' @describeIn group_metadata returns a [`character`] vector giving the group +#' names. +#' @aliases group_levels,ReferenceGroups-method setMethod( - f = "groups<-", - signature = c(object = "CompositionMatrix", value = "list"), - definition = function(object, value) { - value <- as_groups(value) - object@groups <- value - methods::validObject(object) - object + f = "group_levels", + signature = "ReferenceGroups", + definition = function(object) object@group_levels +) + +#' @export +#' @describeIn group_metadata returns a [`character`] vector giving the name of +#' the group that each observation belongs to. +#' @aliases group_names,ReferenceGroups-method +setMethod( + f = "group_names", + signature = "ReferenceGroups", + definition = function(object) group_levels(object)[group_indices(object)] +) + +group_factor <- function(object) { + factor( + x = group_names(object), + levels = group_levels(object), + exclude = NULL + ) +} + +#' @export +#' @describeIn group_metadata returns an [`integer`] vector giving the group +#' that each value belongs to. +#' @aliases group_indices,ReferenceGroups-method +setMethod( + f = "group_indices", + signature = "ReferenceGroups", + definition = function(object) object@group_indices +) + +#' @export +#' @describeIn group_metadata returns a `list` of [`integer`] vectors giving the +#' observation that each group contains. +#' @aliases group_rows,ReferenceGroups-method +setMethod( + f = "group_rows", + signature = "ReferenceGroups", + definition = function(object) { + i <- group_factor(object) + split(seq_along(i), f = i) } ) + +#' @export +#' @describeIn group_metadata gives the total number of groups. +#' @aliases group_length,ReferenceGroups-method +setMethod( + f = "group_length", + signature = "ReferenceGroups", + definition = function(object) length(group_levels(object)) +) + +#' @export +#' @describeIn group_metadata gives the size of each group. +#' @aliases group_size,ReferenceGroups-method +setMethod( + f = "group_size", + signature = "ReferenceGroups", + definition = function(object) lengths(group_rows(object)) +) + +#' @export +#' @describeIn group_metadata returns a [`logical`] vector specifying whether or +#' not an observation belongs to a group. +#' @aliases is_assigned,ReferenceGroups-method +setMethod( + f = "is_assigned", + signature = "ReferenceGroups", + definition = function(object) !is.na(group_names(object)) +) + +#' @export +#' @describeIn group_metadata returns an [`logical`] scalar specifying if any +#' observation belongs to a group. +#' @aliases any_assigned,ReferenceGroups-method +setMethod( + f = "any_assigned", + signature = "ReferenceGroups", + definition = function(object) any(is_assigned(object)) +) + +#' @export +#' @describeIn group_metadata returns an [`logical`] scalar specifying if all +#' observations belong to a group. +#' @aliases all_assigned,ReferenceGroups-method +setMethod( + f = "all_assigned", + signature = "ReferenceGroups", + definition = function(object) all(is_assigned(object)) +) diff --git a/R/mutators.R b/R/mutators.R index a5c4f97..8b29d34 100644 --- a/R/mutators.R +++ b/R/mutators.R @@ -4,14 +4,26 @@ NULL # Not exported get_transformation <- function(x) { - switch( - class(x), - LR = "Pairwise Log-Ratio", - CLR = "Centered Log-Ratio", - ALR = "Additive Log-Ratio", - ILR = "Isometric Log-Ratio", - PLR = "Pivot Log-Ratio" - ) + if (methods::is(x, "LR")) return("Pairwise Log-Ratio") + if (methods::is(x, "CLR")) return("Centered Log-Ratio") + if (methods::is(x, "ALR")) return("Additive Log-Ratio") + if (methods::is(x, "ILR")) return("Isometric Log-Ratio") + if (methods::is(x, "PLR")) return("Pivot Log-Ratio") +} + +is_coda <- function(object) { + methods::is(object, "CompositionMatrix") +} + +#' Check if an Object is Grouped +#' +#' @param object An \R object. +#' @return A [`logical`] scalar. +#' @author N. Frerebeau +#' @family grouping methods +#' @export +is_grouped <- function(object) { + methods::is(object, "ReferenceGroups") } # Getter ======================================================================= diff --git a/R/nexus-internal.R b/R/nexus-internal.R index 557ad5f..ce19de6 100644 --- a/R/nexus-internal.R +++ b/R/nexus-internal.R @@ -15,12 +15,6 @@ make_names <- function(x, n = length(x), prefix = "X") { x } -flatten_chr <- function(x, by) { - z <- tapply(X = x, INDEX = by, FUN = unique, simplify = FALSE) - z <- vapply(X = z, FUN = paste0, FUN.VALUE = character(1), collapse = ":") - z -} - #' Plotting Dimensions of Character Strings #' #' Convert string length in inch to number of (margin) lines. diff --git a/R/nexus-package.R b/R/nexus-package.R index 2415b01..456c2ad 100644 --- a/R/nexus-package.R +++ b/R/nexus-package.R @@ -8,9 +8,9 @@ #' } #' #' @section Package options: -#' `nexus` uses the following [options()] to configure behavior: +#' \pkg{nexus} uses the following [options()] to configure behavior: #' * `nexus.verbose`: a [`logical`] scalar. Should \R report extra information -#' on progress? Defaults to `TRUE`. +#' on progress? Defaults to [interactive()]. #' #' @author #' **Full list of authors and contributors** (alphabetic order) diff --git a/R/outliers.R b/R/outliers.R index ef6841a..77755e2 100644 --- a/R/outliers.R +++ b/R/outliers.R @@ -61,9 +61,8 @@ setMethod( ## Threshold limit <- sqrt(stats::qchisq(p = quantile, df = p)) - .OutlierIndex( + z <- .OutlierIndex( samples = rownames(z), - groups = groups(z), standard = sqrt(dc), robust = sqrt(dr), limit = limit, @@ -92,7 +91,6 @@ setMethod( plot.OutlierIndex <- function(x, ..., type = c("dotchart", "distance"), robust = TRUE, - colors = color("discreterainbow"), symbols = c(16, 1, 3), xlim = NULL, ylim = NULL, xlab = NULL, ylab = NULL, @@ -104,7 +102,6 @@ plot.OutlierIndex <- function(x, ..., ## Get data dc <- x@standard dr <- x@robust - grp <- x@groups dof <- x@dof limit <- x@limit n <- length(dc) @@ -121,11 +118,8 @@ plot.OutlierIndex <- function(x, ..., if (robust || type == "distance") shape[dr > limit] <- symbols[[3L]] if (!robust || type == "distance") shape[dc > limit] <- symbols[[2L]] - col <- rep("black", length(grp)) - if (nlevels(grp) > 0) col <- khroma::palette_color_discrete(colors)(grp) - cy <- if (robust) dr else dc - dlab <- sprintf("%s Mahalanobis distance", ifelse(robust, "Robust", "Standard")) + dlab <- ifelse(robust, "Robust Mahalanobis distance", "Standard Mahalanobis distance") ylab <- ylab %||% dlab if (type == "dotchart") { @@ -133,7 +127,7 @@ plot.OutlierIndex <- function(x, ..., cx <- seq_along(dc) xlab <- xlab %||% "Index" panel <- function() { - graphics::points(x = cx, y = cy, pch = shape, col = col) + graphics::points(x = cx, y = cy, pch = shape, ...) graphics::abline(h = limit, lty = 1) } } @@ -144,7 +138,7 @@ plot.OutlierIndex <- function(x, ..., xlab <- xlab %||% "Standard Mahalanobis distance" ylab <- ylab %||% "Robust Mahalanobis distance" panel <- function() { - graphics::points(x = cx, y = cy, pch = shape, col = col) + graphics::points(x = cx, y = cy, pch = shape, ...) graphics::abline(h = limit, lty = 1) graphics::abline(v = limit, lty = 1) graphics::abline(a = 0, b = 1, lty = 2, col = "darkgrey") diff --git a/R/pca.R b/R/pca.R index c350807..8a3ac33 100644 --- a/R/pca.R +++ b/R/pca.R @@ -28,10 +28,11 @@ setMethod( definition = function(object, center = TRUE, scale = FALSE, rank = NULL, sup_row = NULL, sup_col = NULL, weight_row = NULL, weight_col = NULL) { - x <- methods::callNextMethod(object = object, center = center, scale = scale, - rank = rank, sup_row = sup_row, sup_col = sup_col, - weight_row = weight_row, weight_col = weight_col) - if (any_assigned(object)) x@rows@groups <- as.character(groups(object)) + x <- methods::callNextMethod(object, center = center, scale = scale, + rank = rank, sup_row = sup_row, + sup_col = sup_col, weight_row = weight_row, + weight_col = weight_col) + if (is_grouped(object)) x@rows@groups <- group_names(object) x } ) diff --git a/R/plot.R b/R/plot.R index 8ea92d6..a36a2df 100644 --- a/R/plot.R +++ b/R/plot.R @@ -5,35 +5,38 @@ NULL # CompositionMatrix ============================================================ #' @export #' @method plot CompositionMatrix -plot.CompositionMatrix <- function(x, ..., by = groups(x), margin = NULL, +plot.CompositionMatrix <- function(x, margin = NULL, ...) { + isopleuros::ternary_pairs(x, margin = margin, ...) + invisible(x) +} + +#' @export +#' @rdname pairs +#' @aliases plot,CompositionMatrix,missing-method +setMethod("plot", c(x = "CompositionMatrix", y = "missing"), plot.CompositionMatrix) + +#' @export +#' @method plot GroupedComposition +plot.GroupedComposition <- function(x, ..., margin = NULL, color = palette_color_discrete(), symbol = palette_shape()) { - m <- nrow(x) - - ## Grouping - grp <- as_groups(by, drop_na = TRUE) - if (nlevels(grp) == 0 || nlevels(grp) == m) { - col <- list(...)$col %||% graphics::par("col") - pch <- list(...)$pch %||% graphics::par("pch") - } else { - arkhe::assert_length(grp, m) - col <- color(grp) - pch <- symbol(grp) - } + ## Aesthetics + col <- color(group_names(x)) + pch <- symbol(group_names(x)) isopleuros::ternary_pairs(x, margin = margin, col = col, pch = pch, ...) invisible(x) } #' @export -#' @rdname plot -#' @aliases plot,CompositionMatrix,missing-method -setMethod("plot", c(x = "CompositionMatrix", y = "missing"), plot.CompositionMatrix) +#' @rdname pairs +#' @aliases plot,GroupedComposition,missing-method +setMethod("plot", c(x = "GroupedComposition", y = "missing"), plot.GroupedComposition) # LogRatio ===================================================================== #' @export #' @method plot LogRatio -plot.LogRatio <- function(x, ..., by = groups(x), +plot.LogRatio <- function(x, ..., color = palette_color_discrete(), rug = TRUE, ticksize = 0.05, ncol = NULL, flip = FALSE, @@ -50,15 +53,12 @@ plot.LogRatio <- function(x, ..., by = groups(x), nrow <- ceiling(p / ncol) ## Grouping - by <- as_groups(by, drop_na = TRUE) - if (nlevels(by) == 0 || nlevels(by) == m) { - by <- rep("", m) + if (!is_grouped(x)) { grp <- list(x) border <- list(...)$border %||% graphics::par("col") } else { - arkhe::assert_length(by, m) - grp <- split(x, f = by) - border <- color(by) + grp <- group_split(x) + border <- color(group_names(x)) } k <- length(grp) @@ -171,6 +171,6 @@ plot.LogRatio <- function(x, ..., by = groups(x), } #' @export -#' @rdname plot_logratio +#' @rdname plot #' @aliases plot,LogRatio,missing-method setMethod("plot", c(x = "LogRatio", y = "missing"), plot.LogRatio) diff --git a/R/simplex.R b/R/simplex.R index 6f9ef42..ce0fcc3 100644 --- a/R/simplex.R +++ b/R/simplex.R @@ -41,7 +41,11 @@ setMethod( z <- x * y z <- as_composition(z) rownames(z) <- rownames(x) - groups(z) <- groups(x) + + if (is_grouped(x)) { + x@group_indices <- group_indices(x) + x@group_levels <- group_levels(x) + } z } @@ -95,7 +99,11 @@ setMethod( z <- x ^ y z <- as_composition(z) rownames(z) <- rownames(x) - groups(z) <- groups(x) + + if (is_grouped(x)) { + x@group_indices <- group_indices(x) + x@group_levels <- group_levels(x) + } z } diff --git a/R/split.R b/R/split.R index 7d0dc1f..cfb7bbb 100644 --- a/R/split.R +++ b/R/split.R @@ -3,6 +3,46 @@ NULL # Split ======================================================================== +#' @export +#' @rdname group_split +#' @aliases group_split,CompositionMatrix-method +setMethod( + f = "group_split", + signature = "CompositionMatrix", + definition = function(object, by, ...) { + x <- group(object, by = by, ...) + methods::callGeneric(object = x) + } +) + +#' @export +#' @rdname group_split +#' @aliases group_split,GroupedComposition-method +setMethod( + f = "group_split", + signature = "GroupedComposition", + definition = function(object, ...) { + lapply( + X = group_rows(object), + FUN = function(ind) ungroup(object[ind, , drop = FALSE]) + ) + } +) + +#' @export +#' @rdname group_split +#' @aliases group_split,GroupedLogRatio-method +setMethod( + f = "group_split", + signature = "GroupedLogRatio", + definition = function(object, ...) { + lapply( + X = group_rows(object), + FUN = function(ind) object[ind, , drop = FALSE] + ) + } +) + #' @export #' @method split CompositionMatrix split.CompositionMatrix <- function(x, f, drop = FALSE, ...) { @@ -13,7 +53,7 @@ split.CompositionMatrix <- function(x, f, drop = FALSE, ...) { } #' @export -#' @rdname split +#' @rdname group_split #' @aliases split,CompositionMatrix-method setMethod("split", "CompositionMatrix", split.CompositionMatrix) @@ -27,7 +67,7 @@ split.LogRatio <- function(x, f, drop = FALSE, ...) { } #' @export -#' @rdname split +#' @rdname group_split #' @aliases split,LogRatio-method setMethod("split", "LogRatio", split.LogRatio) @@ -53,8 +93,7 @@ setMethod( .CompositionMatrix( z, - totals = c(totals(x), totals(y)), - groups = c(groups(x), groups(y)) + totals = c(totals(x), totals(y)) ) } ) diff --git a/R/subset.R b/R/subset.R index f1f40eb..cb00380 100644 --- a/R/subset.R +++ b/R/subset.R @@ -12,7 +12,6 @@ NULL if (missing(i)) i <- seq_len(nrow(x)) if (is.character(i)) i <- match(i, dimnames(x)[1L]) totals <- totals(x)[i] - groups <- groups(x)[i] ## Columns if (missing(j)) j <- seq_len(ncol(x)) @@ -28,7 +27,17 @@ NULL # z <- z / tot # } - methods::initialize(x, z, totals = totals, groups = groups) + if (is_grouped(x)) { + g <- droplevels(group_factor(x)[i]) + methods::initialize( + x, z, + totals = totals, + group_indices = as.integer(g), + group_levels = levels(g) + ) + } else { + methods::initialize(x, z, totals = totals) + } } wrong_dimensions <- function(i, j) { diff --git a/R/transform_alr.R b/R/transform_alr.R index a7716ba..24c9e26 100644 --- a/R/transform_alr.R +++ b/R/transform_alr.R @@ -42,12 +42,24 @@ setMethod( order = order(ordering), base = base, weights = weights, - totals = totals(object), - groups = groups(object) + totals = totals(object) ) } ) +#' @export +#' @rdname transform_alr +#' @aliases transform_alr,GroupedComposition-method +setMethod( + f = "transform_alr", + signature = c(object = "GroupedComposition"), + definition = function(object, j = ncol(object), weights = FALSE) { + z <- methods::callNextMethod() + .GroupedALR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) + #' @export #' @rdname transform_alr #' @aliases transform_alr,CLR-method @@ -77,8 +89,20 @@ setMethod( order = order(ordering), base = base, weights = object@weights, - totals = totals(object), - groups = groups(object) + totals = totals(object) ) } ) + +#' @export +#' @rdname transform_alr +#' @aliases transform_alr,GroupedCLR-method +setMethod( + f = "transform_alr", + signature = c(object = "GroupedCLR"), + definition = function(object, j = ncol(object), weights = FALSE) { + z <- methods::callNextMethod() + .GroupedALR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) diff --git a/R/transform_clr.R b/R/transform_clr.R index f1042d0..ec2f84b 100644 --- a/R/transform_clr.R +++ b/R/transform_clr.R @@ -29,12 +29,24 @@ setMethod( order = seq_len(D), base = base, weights = weights, - totals = totals(object), - groups = groups(object) + totals = totals(object) ) } ) +#' @export +#' @rdname transform_clr +#' @aliases transform_clr,GroupedComposition-method +setMethod( + f = "transform_clr", + signature = c(object = "GroupedComposition"), + definition = function(object, weights = FALSE) { + z <- methods::callNextMethod() + .GroupedCLR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) + #' @export #' @rdname transform_clr #' @aliases transform_clr,ALR-method @@ -56,8 +68,20 @@ setMethod( order = seq_len(D), base = base, weights = w, - totals = totals(object), - groups = groups(object) + totals = totals(object) ) } ) + +#' @export +#' @rdname transform_clr +#' @aliases transform_clr,GroupedALR-method +setMethod( + f = "transform_clr", + signature = c(object = "GroupedALR"), + definition = function(object) { + z <- methods::callNextMethod() + .GroupedCLR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) diff --git a/R/transform_ilr.R b/R/transform_ilr.R index 546d0bc..ae6d57e 100644 --- a/R/transform_ilr.R +++ b/R/transform_ilr.R @@ -36,6 +36,19 @@ setMethod( } ) +#' @export +#' @rdname transform_ilr +#' @aliases transform_ilr,GroupedComposition,missing-method +setMethod( + f = "transform_ilr", + signature = c(object = "GroupedComposition"), + definition = function(object) { + z <- methods::callNextMethod() + .GroupedILR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) + #' @export #' @rdname transform_ilr #' @aliases transform_ilr,CLR,missing-method @@ -50,6 +63,19 @@ setMethod( } ) +#' @export +#' @rdname transform_ilr +#' @aliases transform_ilr,GroupedCLR,missing-method +setMethod( + f = "transform_ilr", + signature = c(object = "GroupedCLR"), + definition = function(object) { + z <- methods::callNextMethod() + .GroupedILR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) + #' @export #' @rdname transform_ilr #' @aliases transform_ilr,ALR,missing-method @@ -62,6 +88,19 @@ setMethod( } ) +#' @export +#' @rdname transform_ilr +#' @aliases transform_ilr,GroupedALR,missing-method +setMethod( + f = "transform_ilr", + signature = c(object = "GroupedALR"), + definition = function(object) { + z <- methods::callNextMethod() + .GroupedILR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) + .transform_ilr <- function(object, base, weights) { D <- ncol(object) seq_parts <- seq_len(D - 1) @@ -89,8 +128,7 @@ setMethod( order = seq_len(D), base = base, weights = weights, - totals = totals(object), - groups = groups(object) + totals = totals(object) ) } diff --git a/R/transform_inverse.R b/R/transform_inverse.R index 8aa1317..28f6c62 100644 --- a/R/transform_inverse.R +++ b/R/transform_inverse.R @@ -16,11 +16,20 @@ setMethod( y <- y / rowSums(y) dimnames(y) <- list(rownames(object), object@parts) - .CompositionMatrix( - y, - totals = totals(object), - groups = groups(object) - ) + .CompositionMatrix(y, totals = totals(object)) + } +) + +#' @export +#' @rdname transform_inverse +#' @aliases transform_inverse,GroupedCLR,missing-method +setMethod( + f = "transform_inverse", + signature = c(object = "GroupedCLR", origin = "missing"), + definition = function(object) { + z <- methods::callNextMethod() + .GroupedComposition(z, group_indices = group_indices(object), + group_levels = group_levels(object)) } ) @@ -40,11 +49,20 @@ setMethod( dimnames(y) <- list(rownames(object), object@parts) y <- y[, object@order] - .CompositionMatrix( - y, - totals = totals(object), - groups = groups(object) - ) + .CompositionMatrix(y, totals = totals(object)) + } +) + +#' @export +#' @rdname transform_inverse +#' @aliases transform_inverse,GroupedALR,missing-method +setMethod( + f = "transform_inverse", + signature = c(object = "GroupedALR", origin = "missing"), + definition = function(object) { + z <- methods::callNextMethod() + .GroupedComposition(z, group_indices = group_indices(object), + group_levels = group_levels(object)) } ) @@ -63,11 +81,20 @@ setMethod( dimnames(y) <- list(rownames(object), object@parts) y <- y[, object@order] - .CompositionMatrix( - y, - totals = totals(object), - groups = groups(object) - ) + .CompositionMatrix(y, totals = totals(object)) + } +) + +#' @export +#' @rdname transform_inverse +#' @aliases transform_inverse,GroupedILR,missing-method +setMethod( + f = "transform_inverse", + signature = c(object = "GroupedILR", origin = "missing"), + definition = function(object) { + z <- methods::callNextMethod() + .GroupedComposition(z, group_indices = group_indices(object), + group_levels = group_levels(object)) } ) diff --git a/R/transform_lr.R b/R/transform_lr.R index cfa3151..182c1df 100644 --- a/R/transform_lr.R +++ b/R/transform_lr.R @@ -37,8 +37,20 @@ setMethod( ratio = ratio, order = seq_len(J), weights = weights, - totals = totals(object), - groups = groups(object) + totals = totals(object) ) } ) + +#' @export +#' @rdname transform_lr +#' @aliases transform_lr,GroupedComposition-method +setMethod( + f = "transform_lr", + signature = c(object = "GroupedComposition"), + definition = function(object, weights = FALSE) { + z <- methods::callNextMethod() + .GroupedLR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) diff --git a/R/transform_plr.R b/R/transform_plr.R index e62455b..2259375 100644 --- a/R/transform_plr.R +++ b/R/transform_plr.R @@ -48,8 +48,20 @@ setMethod( order = order(ordering), base = H, weights = rep(1 / J, J), - totals = totals(object), - groups = groups(object) + totals = totals(object) ) } ) + +#' @export +#' @rdname transform_plr +#' @aliases transform_plr,GroupedComposition-method +setMethod( + f = "transform_plr", + signature = c(object = "GroupedComposition"), + definition = function(object, pivot = 1) { + z <- methods::callNextMethod() + .GroupedPLR(z, group_indices = group_indices(object), + group_levels = group_levels(object)) + } +) diff --git a/R/validate.R b/R/validate.R index 30de0da..9828f19 100644 --- a/R/validate.R +++ b/R/validate.R @@ -2,6 +2,21 @@ #' @include AllClasses.R NULL +# ReferenceGroups ============================================================== +# setValidity( +# Class = "ReferenceGroups", +# method = function(object) { +# ## Get data +# group_indices <- object@group_indices +# group_levels <- object@group_levels +# +# cnd <- list( +# arkhe::validate() +# ) +# arkhe::check_class(object, cnd) +# } +# ) + # NumericMatrix ================================================================ setValidity( Class = "NumericMatrix", @@ -18,11 +33,9 @@ setValidity( ## Get data n <- nrow(object) totals <- object@totals - groups <- object@groups cnd <- list( - arkhe::validate(arkhe::assert_length(totals, n, empty = FALSE)), - arkhe::validate(arkhe::assert_length(groups, n, empty = FALSE)), + arkhe::validate(arkhe::assert_length(totals, n)), arkhe::validate(arkhe::assert_positive(object, strict = FALSE, na.rm = TRUE)) ) arkhe::check_class(object, cnd) @@ -41,7 +54,6 @@ setValidity( weights <- object@weights totals <- object@totals - groups <- object@groups n <- nrow(object) m <- length(parts) @@ -49,9 +61,8 @@ setValidity( cnd <- list( arkhe::validate(arkhe::assert_missing(object)), arkhe::validate(arkhe::assert_infinite(object)), - arkhe::validate(arkhe::assert_length(totals, n, empty = FALSE)), - arkhe::validate(arkhe::assert_length(groups, n, empty = FALSE)), - arkhe::validate(arkhe::assert_length(order, m, empty = FALSE)) + arkhe::validate(arkhe::assert_length(totals, n)), + arkhe::validate(arkhe::assert_length(order, m)) ) arkhe::check_class(object, cnd) } diff --git a/README.Rmd b/README.Rmd index 02c6545..eae8656 100644 --- a/README.Rmd +++ b/README.Rmd @@ -97,7 +97,7 @@ data("bronze", package = "folio") coda <- as_composition(bronze, parts = 4:11) ## Use dynasties as groups -groups(coda) <- bronze$dynasty +coda <- group(coda, by = bronze$dynasty) ``` ```{r barplot, fig.width=5, fig.height=7} diff --git a/README.md b/README.md index 646b8a1..4317f93 100644 --- a/README.md +++ b/README.md @@ -68,7 +68,7 @@ To cite nexus in publications use: Frerebeau N, Philippe A (2024). *nexus: Sourcing Archaeological Materials by Chemical Composition*. Université Bordeaux Montaigne, Pessac, France. -, R package version 0.3.0, +, R package version 0.3.0.9000, . This package is a part of the tesselle project @@ -119,7 +119,7 @@ data("bronze", package = "folio") coda <- as_composition(bronze, parts = 4:11) ## Use dynasties as groups -groups(coda) <- bronze$dynasty +coda <- group(coda, by = bronze$dynasty) ``` ``` r diff --git a/inst/examples/ex-group.R b/inst/examples/ex-group.R new file mode 100644 index 0000000..f468fbf --- /dev/null +++ b/inst/examples/ex-group.R @@ -0,0 +1,18 @@ +## Data from Aitchison 1986 +data("slides") + +## Coerce to compositional data +coda <- as_composition(slides, groups = 2) + +## Grouping metadata +group_levels(coda) + +group_names(coda) + +group_indices(coda) + +group_rows(coda) + +group_length(coda) + +group_size(coda) diff --git a/inst/examples/ex-groups.R b/inst/examples/ex-groups.R deleted file mode 100644 index 5353364..0000000 --- a/inst/examples/ex-groups.R +++ /dev/null @@ -1,8 +0,0 @@ -## Data from Aitchison 1986 -data("slides") -head(slides) - -## Coerce to compositional data -coda <- as_composition(slides, groups = 2) - -groups(coda) diff --git a/inst/examples/ex-outliers.R b/inst/examples/ex-outliers.R index e8579cb..02ae908 100644 --- a/inst/examples/ex-outliers.R +++ b/inst/examples/ex-outliers.R @@ -10,6 +10,6 @@ plot(out, type = "dotchart") plot(out, type = "distance") ## Detect outliers according to CJ -ref <- extract(coda, "CJ") +ref <- group_extract(coda, "CJ") out <- detect_outlier(coda, reference = ref, method = "mcd") plot(out, type = "dotchart") diff --git a/inst/examples/ex-split.R b/inst/examples/ex-split.R index 90f5e94..acb0fc5 100644 --- a/inst/examples/ex-split.R +++ b/inst/examples/ex-split.R @@ -11,12 +11,14 @@ X <- data.frame( Y <- as_composition(X) ## Split by group -## /!\ Unassigned samples are discarded ! /!\ +## /!\ Unassigned samples (NA) are discarded ! /!\ (s1 <- split(Y, f = X$groups)) -## Split by group -## Keep unassigned samples, see help(factor) -(s2 <- split(Y, f = factor(X$groups, exclude = NULL))) +## Better to use grouped matrix +(s2 <- group_split(Y, by = X$groups)) + +Z <- as_composition(X, groups = 2) +(s3 <- group_split(Z)) ## Bind by rows -do.call(rbind, s2) +do.call(rbind, s3) diff --git a/inst/tinytest/_snaps/coerce.rds b/inst/tinytest/_snaps/coerce.rds deleted file mode 100644 index b3de970159e559dce12bb70a484e7063a36010ee..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1404 zcmV-?1%vt@iwFP!0000019enuR8&R@c2%v{Vm{ zSFf3=$9KVTd(2^CtRFbep8R;Ib~`u%#{E8dv<)1zw)^`OaI9Z2sbhp2+qvXx${u7a z0%xWS3U5|{oj$c~b1K-Ej(%l@m;n2s?jLg_Q^4MG_3O5fE#NrS7&(2O4eZyBG)9Eh zf;OLnzD7k$d9Lr0h>xZ|1_B$o|WtX&#<-aa}Evz&(Vd9XYd?o z`s+;YCGgZQ%Z}2x!M*=-%eIRW@X)72<{k%caH4LvHyGSMoJfz(SO*tg?+GajT?AeU zO9(s@t{B!u$-z72&edy%=fNv8ETcd0&UP4Aj7R~`(`MCU@*#Mb^6mTy+!xBH^md>zu?HXMl=j8v@kG&x|K>KLR(CMWPk$(FmoEn3X91gQN%G4vGzD!1tV#YhL(+CwGnp+len^|2wZ^I%fg zd9Zb4C6&j&3tyr>>|jR?(zik#eXE4O#6iu0obXxAZBWCO=S`^pHac{v|43*YbN69H zRVy?opF9YUw!(q9YNnE~OZA4a_~&@2ww8I5($rwfd};jdTlKJg^Tgw(j_Xjn|NgL3 z$Lu(6%~w^ymVFvv(>nhf?7COl)G%3t<8boNO?&he*ONh)&0MrcV6C{_Zc(>FDci<% zP=WH^g8Wt>{@hw(4oMA?Wxz(1M=|nKys~(YFhC7fi#p7r9swH>pTc@#dy9M@j#G^C zC`CL<45>#g<7GJhr)Xb^{FWBKd`|eb2(0KHmoe9%=mD5f9n5H7$nujx3H`S&_+vVj zbNtLZPTmui*CC!XuVYOPS9=0~9_8H|&kqXs92RG`SMj{lZ`le=8*rXnd@c`chvIR3 z`tpmzdLzo0^TYK+hx~JTH9F6&sffQ3)g>$UySfjDK7uTCzOS7c)W|=#&q8_h)}t2Z ziR+2vx;}NQ_2H+%{Lm^8`1{fCuTbDG7{ol#A87LFWiUM%@hEx*`j`Y5Nh6VGpb_(M zkD8etz&>m<(*^99nRcK3k?`Jk?bYw#*X~$mJj1RA`^Wo`U+HnKpT3{nGx%_Eed76M znNvWTbaa-Y!KeVx< zVGIwYJdEYxR36HB7{|kS9wzXRk0#}#N%?3}KAMz|Cgr0^WvC*7T$A)BqQJNo?Sk_) z$^ufEr_rjA<{)Prw)e diff --git a/inst/tinytest/_snaps/coerce_group.rds b/inst/tinytest/_snaps/coerce_group.rds new file mode 100644 index 0000000000000000000000000000000000000000..39569ed45e875412d080185a84c1593f075acc24 GIT binary patch literal 1400 zcmV-;1&8_{iwFP!0000019en=R1{SdpWWq4LfTAG%rHnYGgKBAup?dx#mrXG^#ekY zWnI}p*bjDBNs)kP1x1C5R6cU?qYfTFPHAN-q@MmjOWE0--IcUcB1LZg7w}~TdKry>L-z5XJe%^%6;Vx|FRIDj~kiGyM z8FDDRSq*mP)V9qjU|&4))n&daupjFAAtxdk?5$V7Y7g21)TyS3sdH>#zjmZ4Jh%=h z(b+kZ7Ig#FJC`WEeI2N!rBMyTT7mlO zouxB#7uLH^|FLOwuLIoeAsfbv2ZO7t`(kLuR&cN62Dpc=?U;3ND7cT#XFY@aK=Yqx zaxQ_pVM$gb=>pgO%dOikO2N&X4w`)&Jb?*@-JU>jeSab?Dt#SXc%wI{Ja_?kq#Pk| zkGo=87pVZxq&ruynVtua+_Z%Gz%!FFFB_f=?tfb}kM$41&6aQHkKnpc@xEnQIp*OS z6YeAzB!Oq-&X(1!M+CcfSKX*ePyx+~Eo*?T+Mw7wI{@g{|2e&N={Rteunl<$=uJsA zC4P}W&%HTk*o-Jt&_O^jL zy?J?!<~Yz(Ql(i6C%7aF*_HskKOma9LO|yf-M<(?fvqE0+7bK$G@?E>=5`%S3^@4!lJBjAhw3BB<#|>X)gXL4r;9Bp2Sow*fL%oyZcrHY~MWoxTW(t)a}1N^wcps zj$8X>bzsRp61cR^{|dYAl{Gg`Byk*G|CwcvvGRHn7_!)l_6V$%w>wI-ZBWLwaUE2m zytg2~m54vTmKFr11jy52Bg&%~`6*smyhr4x1#5{mq(nO$HX=TS4XW*}ihVdvG0LM1 z@hCN=94#3u$MHWwauxDhR{Y92(K`~bqI+Dqwj)=W7&;)U}l@4k3qDBN?{H>0Ck;GK5MmT%dB^W@|6d0;yfkLS~$ zUo74?qkMTkd_N4xKfkX<=lL}S@i(KoWafNZ|G|()kcrOsx6^_a`RCTsU8 zo=9)#SGPJZekA6HR)Sz2WP%V8KExpQfnGu8G0R|Pvg%M~`g@u9ne}E>u8BeH!yP(3 z&5wK7rl%3yn4Wr{`;oBhz4qC?&@aq5H(-B&-81;`alPVsWjQ!I zUvDuiCv_`GwZ?=>63Q72oZ_cU$y27!Q>O30*^fw2ACX+mY7JL(DQDBSCr*sUNQO}i zMw2m;dwKO$=c-JMJF)bC$|1AZP?{A<`aFZ)M4Cyx&g+=JL8V@$%GMwr*qcsMU}4EU z@v;wKu9Hrc#})8JR2V5&NJLDD6Hwv=lsEw;PCzNgC>EnQjN&nx!e3-%^dtdB3s5G& z7y(Wepj?2l0*n)2ya0u0G9j8wh$a)F$%JS!A(~8%D&o)oT}F#4-@Fz{fqA4lU$4$3 zbsD63&XB9hCiQ*oLruvd^=8t{TMWvxnAG~!g2G>KP#G;6-aJsJ*YO&rWB&nI_)?&l G2><{Tkf=NW literal 0 HcmV?d00001 diff --git a/inst/tinytest/_snaps/coerce_nogroup.rds b/inst/tinytest/_snaps/coerce_nogroup.rds new file mode 100644 index 0000000000000000000000000000000000000000..2916ccf7e94c2c558d729bc934d11743db28f409 GIT binary patch literal 1337 zcmV-91;+XxiwFP!0000019en;R1{?tpIx33(rSv241*vuLuGLRJL1()%xDGQ5K0WR zx`VI}c2_q=Vu=<|RHz8#k&BNyczm4F%2Y@_{ehOUvpc&hVW-H0qN!+@9Pv>z%QxT1 zdi>7J`F{8D-TS-uelw{71VMNa-ri!u%ZG)8&+=u7k#U5`D~J^iLwj|@TZJpMK)-s; z$UM3W^z8{p$cbX0&z<^sq^cHZ-|*k3jkf^JTKm3F1bTDw)b243>}Qv6C>uy$0=5hp z6x^%=D|@PDTMAfLjDKad4++-8eLv=eC4#l>>en5C+krma95yS-0@iCsn?r-@ffk)h zn!daj=>A1S@$KtCuPTmg9Nh-=-=BmWTYLko;a8fp;zeMS+wL?!=mA@3icB6B3|5ZL z{M}gZJoD$)iTyTkb_ADB5f2APPjBbAj2+-y<6ht#wXti#p;6#GwwQ|y&Vwy~oz1xf z&c>Bl5tIWQ2QIhObV|UN3p35gux% zmLz~{{I1sZZAS&ach=pgj3C=!>k57;XUJIKCRU}l@oX%l*Yso!^bX@5I7(_7xJ zR-6E4W~wAhZU=|gGHxWm9Pp1~uMjXfh4(wdXs~nzNxFhYKogo{Q*O_pxxp8}(w#ZC zJoa7q63tfG&l6B@sb3|iqm7MdsAeGppJ4o%sQ z2SOsva4@Et>m=+}yrD1pITotTWv;oYO0ZxE6!W@ zRaJm#KLzfxF8l_&@0GMPO`~ugUjMmaueRcP0%)?hi}n!A6}P)g%62Gmk8u-Jpt`rC zxD|*$zZV+=Q~YJ=um#mogyIyfDcURYRf5^13^pmpz!t=(ppmR?lkdlQiclRTh)1z5 z<(O%b4Cnt8$(1N>Nzu#aMQ?k78QtSD?iv&hfD!e#p5Idte?96;X3lpFAC7zondtmbKP4zpd|u8(bqw~S9@mNciS(Kw zeXIB2M`3*wL(t5@sETpf$JANRO9X}<0s z+nhAQz2>CecYjD&_S^^UJB7V3np@BCtHbfJ9QZ4{&Oc>;%I_I`_`DwZJgW4`&Lwqh zkz&ac$`J|bJdIjM=_$2JPU`b1qsJ*f4Vk@;T&rN=ljnR?3ZsGR*kccWf41E!GEc$T zUO+vUxcfe67cY&%NQzN3Ml&#yVHAT=EJkq{&EyBYG-|p4qXZ}wV6*^d2v8=#7y-r# zFiwC%HmQ(JDrA!i*`z`?sgO-7LmlzsZ=cpc=Ib{iDIkx^&R1vWQYr<~Jg3Pe*HY@i v>7k)yQEEM<=RJny8Fbm|^@74rts%7r1@9i9Qmc3kJF))(BgbK1xCj6M6ljsT literal 0 HcmV?d00001 diff --git a/inst/tinytest/_snaps/condense.rds b/inst/tinytest/_snaps/condense.rds index 55f1bad351d9a28f6ab047493a8effdcde0cecb3..615f982537a8b5b005a6571368c6e037b433b932 100644 GIT binary patch delta 189 zcmV;u07C!j1M>rr6cS=!W(6`CSVKeHbS;2l!axoOu_iA8e}QTRKCc7P110Bc@iZfY^qBo3$`TVZKpQArh)$CaCzT$G=jlbM$a72z(( zNlecK3MCd7LxtFrGV@C^OJFKEb4!bp^UDwd?D++Wg{7%5^r3Glt r<1ETA*F$z9A7!3}xENv*Opq%ju_RG1tq5odkoOM&7d1D&!~y^SC`L%^ delta 180 zcmV;l089V#1L^~i6cS`$W(6`CSVKeHbS;2l!axo?u_iA8e;F89n1JdT8CV!NLHhC% zb5o0f3;}RpLj>6hOB0Jqs-Qfs+|1;n{N$X>yi}+NcR@~KdL~dPvA7s2#GaIyUy@k@ zQ^A>ATAZ9;h7e%SFGwsbO@%4v%FEA#iJ&B-1JiM@1yoN=N^#rowUaO<8`B?Z46!Z zUneD;u1+ejzwxi`sMj)P`xka^dEK=q**~3HSQ374qx}beG0(pae?sgZzYzPt)~;gz zws-Oh@#_)x?`Gva7ijdie|G(SXOZ|3`{z3fj~!_cw136zveR$dO8Xb~tU@p6#@N3+ zK6&$58T8m9Er%LsTHN5Z2Av`0WG{t{2#w$c7{nZb8)-HG-;3vPx@y2fb#*Gv6Ch0J>guJ&w2rUe!D zmu|Yn964!e|MQte(~E@__Mactxwd7u*xwQ;loj1_!2WUkf-8W75_eJe{=4C0Xg4EYwSN>H%i*Z&}IL1 zQo`x#qyqaJ|LTr+mPU{_zX34{Yr!_HTP9 zuMoc;VgGJc-gALQfBR?G-**;?AF+SFqwv^~20{B*+%7x)wym^(Vb3b`a&C^#FwGE5a|F`@ y!7W7CW`wZK2w|HM!Zss>ZAJ*&j7*^+!VDE+bb>KlU<@r#zybiLLqPLC1pol)T1=_{ delta 238 zcmV6ai$h6^jA|U||BLFO#JLF@JrTUX)*20Q4m@C@dr!fCQ~Ex(jkr z%TmGNEP%y*tjRfv#V|>@mbAp=lKdhd>mNip>wjQ8BC8N|&d)8#FU~B<%+K>pEGf#Y zKr@%UATc>RF+CN{WY)aYiqc|)!EgxI21k(t?G)6E@5KL19(+t5hM=&iAOoVMl2-}Ph owizL8GeX#Ags{!X6dEGTP$5Pq7{dj|&;kW40AJB9e5 ymJys~3}>0ZS*CE78JuMfXIa2mmQWj*VIt0nFqT^?jOCXIaw`D8TNa9v0ssJduRgv2 delta 187 zcmV;s07U<{1K|UZ6ai$B70Uz`CZPY3u>N5P7CxLpaL_&N7CxOyDOh pQ#i{E&N7FyEZ{6ls13|85$8l0%Pkeg@=FA{6#z>hcy$y5008qlP%{7k diff --git a/inst/tinytest/_snaps/scale.rds b/inst/tinytest/_snaps/scale.rds index 8f7d6cd7e033102fae73ea335942a73e3fc4a17c..2e078c8c8913e4396a80afd24f5c5ce5c46c3e17 100644 GIT binary patch literal 1457 zcmV;i1y1@OiwFP!0000016|a6G?Zx^2k8q#uXSRBX6WxtEB$qyqtcl?5o^-0#;+ zV?oq(Dst1_S_nLjk~@;L&}LCjO{oikz^-E1l;$nH~#I6AunxAyijjP{yY7?sBaM9=U{RPl~i=6RZfXYRvDdomZzX}`E{T{wVdGurFlsyo0v;N-<2 zt%hKBu~u679*D^%ZxTc2Kopals?j!t)0|Hs5y5n{z8{VX?PH^Vt$OLUqNnIMwd2iI z_Z*0w8_4z}YKWp{oJ*Ls0XeaUO%!t%;<>ozirMK1@GXo}$(Ae8=SX&s>UKnGqQvp0 zlQFIm|2d*x(TA!VTT+f}c!i|WXwl57K|I@)73ZHJK`*sqWOPU$B|cW41Ga4edyn6W zA$2M$%mCHx=cPhOr-puAqh0v*3cW57!Tc4CIOG5zvU*MJB>n?^yiYou`}Onu7ea^MxKtbtqKalwkWg2NI>bb>}l!c=AYD zNwxPNb`R$nIGDDh^~MFsx>63#M#Ur__{JA6o?Ws$SpN$BX6l49tG+|`AN%bNHud4< zE2sFjJEdR@1b)=Dl^~PLd3v%X77y944`+Y$#AD`CgJDY%?$a+l>nsXEwHoJc|Hg+% zk6YsqE2KbN(mnd|`^gYKkF{R5I~3*fO%2Gr)!+-yZuB2~i4x;;>`t)|jgh18lJYfi z=bC-^@^>!iXj}Kd$i)Kf#s{?K8}7ih1wQ-AQ|wWps=&0~+>c_n^gY^tnV_ChlxK0m z2E|dj`oCv}B5%@%!|8vl+E~EIXtTKr2Umur|H5 zq6D|}w>!+corJn9-C3*=G8)y^dw-^#gGiEL71ON^;mBz1;*nf%?R!`rrmhgIczC&S zdNf*2R=Q0aGDFKlgPr$!U2ywe>g6As;~>1~>+M)F1>A$K?piiiP`Z;rk22QAt+&CW z>|qZS#BYgDik}8PgT`p~s6kQA)RztO{2+3%_I47-p}EZEz0PE3X%3G*_!De!BRTHK zVc!{OAI$GdoLdO?`{sPo3nH$l#`_64T-4IMzde73hIXCk{m*G>s9|4-ESePq{?2(N zURKw^kG-GR1rJmN8bue7)zMT?@MK!IIz&eL1HI`!1cGz`5C{qcMZ)B(vKPtK^> zw1RMGNfm1J0)=iYG4A{t_P}nTG8)t_DrggvQBUTG%}Il(8unI+Naz9AG2;bEuM;(4 zWg1a8N71k_scc8EBlxGgHMvbh@OTMj`w)T#GZoW0)`7U~r6JHV`~lTzZ_jMoRRX?w z41MTwJox&5+Z7a7fY)WWKA0szt!BV`jch$sZ>Oj3N?m}u$-Ych~jG}ASd4l8L3iJgu`YIj+7LNohn|K2~o-{1T9eV*U* z`F@|@^L@5WArJ^8f~>3zfkYM~f$X})!N8m#LsAmI>_=n1?k2e|BI-$zem$kx$j*J( ztD4G&u<>}r<~>#5J0GI7CaR&?sMbEYCJ20slI2e>oJYE>HloH)fnpPg;k|J@Vm)X0_t>o-W3MJ^H9l8gyJT(1J@DBQ8_dh``IJ zP}~AN2n&m@X|SK5G>K1i3A=!@>LaC@E>u)g-5IG*=b$O|XQyq8`q5-afAwp5E4Yz1 zuDPVu;LpleOD*1wPKy5Pgy7i_#vD#jX&%Cf+z&zFfj+o5HXIe)!$I#_<-+ZG&(M0@ z>-9CKbadL*Q7lK45M`fsCSGGB(pd-eWiuAxdFO+xh9|0KJCFgp;ejMaS=ZE%r6` z;N^f#Tyte182$e5wai7hz|DPj>@EwBIj;^}e(!=O%w;;m#zH*wx!Bj17ld-9-1^>4 zk8vt?jTK8kLuWz9==<*!Ab8F)UA`+A#q$kxDAlXM6P(`UJNOa>dS^IoodPsOjJ{3G zQbpx;%di!19njjm{?P&lBedv6s?FE+!u5sjp~cCTC{dJQnr`Vu{<>4U)&JB-EiEt8 z=%^X;qqMYtyAX`buihOv^+z0>lMA!%oe4yv;ywE7NK(aeic7@F=_+V zeeRVM;I_7>)x0~2sJW!2!5*QYL1}~ANBS8EMQJ869qJH_j8-if$pF{#0o&QY5q!JH zR~n{A6nard##j{98>xN|?{$`4Jk5S;gLvo4qd?mkB+HM6TI+`;gP(o@In zH-V#^VP|B=ZH-Hen+6_(&S-M3KwkRPmv!^JA#^Zxv+0aQQ<1}%rh=_F58dy431+x? zIQHNHj~Qqg%<4&)lLO9JQx@q35my!Cy!p9YRMFkOIeU_h7R~6r&*`bC;GB!d(})3Y z$GieplN;c%9wxNI872M;qO&Q=Xw1%jI;}$)!Ufv>U8md$1X-f^zRM6~2@2y4!6zVC z{7@8+@ny~NzA(w|!?+C}|^;}fVSb4ep zgDomH+Y$CJEkngzf5AF-Cn|pld1SFj4s}ZBWz>m>QA^3~q>=_vHtZ%J9{&Jb>$Df7 zxoxNjDN>2LHHx}LiA7$4*5IA!P~|ofQC%Hh6pA3!8Oj^XHuc9HR~5dR?)NB9eRFdA z&I0hLF+M|A;=t4X%OX3!1l8>p8v@xPRH^!nsa&3ma!;R>ohb`Zqu{}0M|gtkEU1ei z#!Nn?e;6YoRD4R(crG;K#nb;iChs7~H`4c0o>d6{wUWJq=;0Ga$tQkvZzdy5OdmeG zlRt|8V2MFqTreT@ zVBc}u%r8}=@~Lt@+lh`;3DG2EBq3u7nMlY~LS_;&m(YrdQgx&nN|7o>niP$sXe>n& zDVj>rOp4}Gl&aCBYBZ@DO{zwds?nrsG?OnGA%9ttv73OE6JS39t0rLec&h&a^|Cup}eBgk6v5Xb2;k zj%>0^yn{6nje0alq-l`Epj#!#7^xz(@o47!DhXLkla?e^k|D$@YK8TRkp5Qf{xX|t zXZla?%$@tW_k8a?_uO-jzZOD>ju;FYqBBWEOyB)nb9angX1}iAD|`t&WF(q*_o3rXSC0zwat*xXU9W9jmx5*Q zV7KDXVfcPt)ZmJTaY+?{rMiWa1;asj zwmtJ^Tv;vTgCJo;mLu-*4zo6j`4CG#+j}rs^AkK>RiUq&^#h)8ka3-|8F=XJ-o)qL zCiuZ4K{+$e4^M2>bWPZ2i3f6QGSY__1ez0iZ!*sUsZr1w_*?@|TS!js-53E=TUfh0 z4Y&lOEFdRkrUMo|qT%W-GkBRk`*b>Y#u4>jkMsZXH#`zdH{8EDfY5E%Xgn{`fPV86 zX%{(K1XJylxJ4&l@3^QN@2WRP`r4Emj|A{hPQoaFnz;>s!ZA~y=b z`1WT8+%`VU=U1{itV&@#^gyI``7pks9yn(8W-^RMv}_MEL@-}5_I1?eA&`9Qi;~Pc zK>DyKwD2nzJWzO!lbTutV($Qv%&(e2Q-QXFTSXwDYiDYQUV)_|5DB)t1yx#B#QMVo z7Ry=}%pB@L^7zir^xKj6iM>gk$j%HF+AM1QatlEALX!Ah5CaDDFZUlRPQWQm`%;U} zA?Uhwc3qD#A4am=*~xvAAj?q~?QXpW{prppy4btmj|ZdWmFZnDRVXzXJ#`Jn_~NT+ z?)LZwJ0q_E2zVA<($pNsf`xELuGgm{uwa@b4QkDU7rggv!b7ugw{es42i@^dmsr_; zqcNGF)neaE*10g`&-1u9NrRc4PO~XDP4NBG&E0x7S@2YfYSxBU!^4fY#hVH}q2VV# zHeDAH^xpUj*NvaR^LH1X~=_4|Ln&NCDkzKweI}3UzT7hLHLG`zA-Fr z^U<4V^MqbQ3o{F@iy|Kgk%fbh8e$+#c_HybBFI6T?DAy;vNKd9>cS`?FFckcd4U-? z9ze_Oe;@tl^X2Wo?pKMDd5jk$ln1FRpR6pZIVr$d0WJ#QC}5B3NijTONYu(n48=P; zS?*DwGleb`ax7mvC@O|8h*`-FbJ_6MC>PPu>zQI4=EVv~vpi25@C5qD1}gT|^s2hm z^sDJq^^{J2ceR&@`hD`)$e7TQN?dD>3qpdA3Kd_FiN(vAFZj1n^*xV-^J2+EXu7W~ z(w#iLRoxxq9SP$FlP`&0RWc(5@o}+#b3F~Rh9Y?p0=Z3ZB^3EagB3f?&00w;CGAj> zjgoAY#8#4>lI)eVQ*n7WYby$^DP&Q&gF+h$Z7F0^Xh)$vg_JiI<&8yoV^Q8%ls6XT djb)2et09o81`1s$zc`OP1Z__Wt_L|DJR1edoLgON0=CNYV@uTpAHKY>m*#6PXcH=|5uJs`Bf$J$f8> z9%|c`UbPMnZe1E2SobyV3XPIQN~hop;Vr+Fg;BV3j!GX8O5kR{z%r*&b37Ju*2=9q z4eQ>*{zu}v;5)sl)vtOO_e}S$&DxuZujIAb*Mzp=fzJ;%Tx}S|eWecSV-*zES{L;d zcE#YK#;l7;C8wbPBq=kpy>M&DX16)=_p$cVRqK=%ALD_FGF$8H?{V)kozOdn#GP;6 zPJI$$k8j+OlydXKaqoN!zm(N3_q>YOU$=1cYy|qU?yqEXJ3;eJ z7~1L71lpU$aYbMH;QK}Uebdv6K^+pQ(uG%2s6Wc1W4;PBgjJSR+zA*f29;#q8&F~C zN=@HDVYRM)#BteK(A>T96LC2K-}AJuRxNgfkp}0};dzCid#XwOHim?bf}`#0kEGzV zbF0&f_akVzv~OCgofsZw2MCmHeW1&oq*`8o3fePPZf_ARh2L*HDlN}wf&L<`{i9u{ zpj)gyxjVoUpBH527Xk&3w;nrpA&CzoQZHffCl6u7VW&2xJ|CWn-gTG8W#e0R=j`6Q zl?>IX<&EcSl@#YR4m<3Y2b~e3z-xUR7+m5#ly=b`U*B`#mW_KhJkX-5DRGr>bLM6B ztfC;O`7vBTSR;zKoqX_&-932n_DHv!Y=e3tsk^EsADSa_?$#WugpS~82NwK12K_0D z*FtUWV01yKO>aXG+@9_1=q&Uxybpv(4&5hah(s1lBZ)V~(~A{7na4bOk|vT#3YkJA zO{9rwFrL?1G(P_KH9}v&jDNe|^pvr3S<)8zlmv4ZJSF|}Ur*Bvq>_&$w_cw}|8lgPc3@(9GKaD-Gad0AB;FF!dxCDK^O_JduX7@pf5Z zz?Cfeu;}aZf+Lw+EMaoB8c&HaJYN|RfnF>;a)T&QLYtYgn}K`L-wrUbze;badzJoG zI#WHXV{$iphS+9e&PJcAW2S2d`U*;^j9E36fa?HHWS%18+j9Uj=!6c_(ob}BzGfu7)fBH z#YXZp(h@`R{%)=;y0OS-aS@B|EPAjgU~w^vo-DG__-r&j8;#FKiwFP!000001I?5PP?JX#$3F;>qG&0Jt+8^d6iWpRhcF(iLKW}ZhNIYo z1O>TDB8LJ6OC1%c2xvhpRIJDlJW#+|C=c;yEuc=3fJ(SYI08vHBFNPQNWM1HnRcAc zwBO9m`+e{2?tk~a-KEXMFpPj{X=!2vq8u^e-aYG=I$#=vIr5)KH0V~Ia{iPf>YEW` zc5-(j>hdrD(z4_R>VK4fR>0Ik1BLaJ*isIX#W?#fy<39%i6N=`D^?>>@@6xegqKKk zhusl@{fu76Rk-IhtV4YpDvU!&qi8T7D$d84fdpeMUGX2RLOsSkrG^>NNV1v!iHz|r z>X_y0-DwnphPOYy@Pi}*$(YPtGkz&YqPnBi=EC_%EYh<&nRpRNh!Ojqk5;4p#LR*u zX%Uh&>`bmbV~fOPWABW7VTmMlrziG??MEUZ-NyW$F?u0!;u>|wLJQ~S``%Bvs3BTA ztnIc8^&QfP*v>9Ng4XV4ed{nJIZ$ z-bFbcUW)qMFPTXP1<+>X%q0Z?JoUVnyEA4KR0i4UFHTtf270A%;7W8ob6m-b#6Tpb}rysdB}A%KLZ=yS&%i}$|(qc0n)moPfWRD zknY|+WMWr>q(6EDrEM}o{OgkT`RB6A2&tY;fhI0cy-iT6&En*$hPOl94Et2dK29uItg9A+qkq~B?e8p#4JL&o^*}nk?U{@E~)jrc|EG&D;YO zGO2uUOdXe^+dXt-hy zk43WBD4!1at?*$aDMtjohK%EO7B}J9%&2W4Z8^~O;IN=PK>{MJjh$()^`PC7S;fj{ z!qZwe9c_~oXg7)%4=`>(+fNhz10xJ*mwsh&Bx3-CqlM4xR=WY;#MRU|{(EITFiidc zV3-D`h3P0B1g4L_+{~6Yg`1*y7u34U-~@8$er!1@9tz4DS8Ve8&n;~@P4T_yc(q*; zgXqB=#U}M8Q!wS!SgV9}N^nwwvl2d5pDCEm@d^A_W(o{uvV!H%J6#@SV2)Rye-Pb^ zv)?Cx!)AT17S&?V*{o^b>`DKW9ml3hNLWLjN&u4l*-rIQEJ1rhK76v=sB<#Q=i$*m zv;WurQ~T1G!0^LPoNnW4Y1a;A`5ZXNQJ#1rQcm?ZR=s*&ess2c5>357I0;T$cB#wB zD|v{1fHi$$RKo*UVTaj&vAnnBS2lp|&r-xl(_2vtq)f*(U6!ecsv;W|*{aA+MfNIM zt|A8&IVu`ztaa@k01CF>F6<4F;YE)c}imOp^HLBekUOsI6 McccSVqa_Id04Qg(fdBvi literal 1442 zcmV;T1zq|diwFP!000001I?5PP?JX#fd7z03!=3ITd{Jg6iWpRhcF(iLKW}ZhNIYo z1O$Ol5-tS_mO3g>5zvBIs92F9c%Xo_P#)sZT0os5hf26fI07Ub5#(wDB!8Q6rX8o9 zc4zi~-@otezPE4RE=>c&Fd{}G5ilZIh8TI@-VMuaF#>Up>?a%zI+rG$J86gdW<(jE z*b|RBeM`SIE4q&QALgDBFiB`2zfLE*n2V%Q4!+Co6rp}{Q1XGYHAs}W#n>|L1rpun zw1;6oqgOFyE;;q<6n+w?TKYURop)Z=ru8Wqga; zXL);c=m(+U9goicAPz%PCUf_UUrLdv_DH3PZ~^KS%{4y}e*uZfVf&wrR-*p+^t=Q~ z0g~45N~}3;g?dZI-WmDA42f$`P3#LffJ8#NrO90b^jvJu)9;FgX6}vmJ)ZDTedNrL z)>~54cZd+SgHwbAEnQ7o79mLFx$#9-X)uV@wGO}6odh*{^LE8$Yon17)>67t0(v;S zTjyA4G3s-hudnT51)pnOou%4vm21GVH1@4X z4!^k=nzXkry!bc@YF(mVNFp?$ZXzc(A}<3{wk_&T=V4HI^j`4Q>JX?Ent$q?s|8Ih z7j_am3!vr-OFi{!1~f+BCi2Q{p#7w6r(iz=1aAv(X-5lzXEes@(lr19?Gh!o{T$ri zu6yO1N)sqa)h1`BiJ>YlxS>`^1EE8J_pQ5iP))lMxIotdsxrJQLj6skQm6cEcKTi@ zqj3^fwI)NeI!#*PwbV5>7WmJ0@H#U^z)vmRnJHmH%SHP_t*;M4 zvs!o(_AU*24^hSn-HJfuVijkhl>;qDH!_d+cthRl$a~@QuS0XSB{6|w3k`WX$LlYf zz$1|~I>M_Re#?IlPRSBMj~?TgwdoCbsu8h0s5J{Z?*|G>ov~6H*_*Gi2Yu19vDVa zliha$M#9wP4+7K6S0-l5x_nqi{w}DP%;2)QbRUk4{pXT4oFZ>;I$w2{ zo&oGYf7vdH@?7Xd%0B;gSB=1j6~vm%^W4|OM|St2a}-MD6c4&PmmMIZaaD7FdH`2p zPM#hltW&^x1=uUVK>;7Dt`tD$da?hJmDmAHmOR)VY^vH6iaG9VUw_$74tV)-IjqlB zv?KkEYn2=4MtX|YHSv2S1;op=0SNo}b5hgJF z?vkgwYAMVNW_fuYuyyKvco$>_hhM5C)tk`63BT? zL~qF+9Y4A+ORl3#M=zhKGp$#1T&^Ulk}Q>Er6g-5*(hm+l5CY^rwHD0xdo2PairpC wiK7*c);QYWxB^F89C2?{+#415M#a5Rac@-I8`b&^?;AG$JD){~Dd!0Q0Im?C2mk;8 diff --git a/inst/tinytest/_snaps/transform_ilr.rds b/inst/tinytest/_snaps/transform_ilr.rds index 0351138bc7cad65c4129550f311b1c271e184487..666e9da280f674bc934e2a8b679f067f3afa54b6 100644 GIT binary patch literal 1320 zcmV+@1=so?iwFP!000001I3ejP*X<~hc^!-5us>l0V|GJt)WJN1Ocn`5?+Q5Ra9y* zqiBF22to*fBI77pADy;Zq1Yn6DuT2MVuAYB6SSpKDMAqNL4g1XF+vij*o^346Owzc z#&$Z>f4Va}zi-c;J!kjqZtQr35Dn4kR7A5gA+q}@CSpz?qR^a7gG6ZEX}=R?H$k^P z(b(+b1o}%OrL^`)P;%GzMIF2X=k=S9uDT|NZvKqnZTF>cGjxx5<_QKo&Ybj~(lY@D zH!=Du(-he0_lJ(U&h`OShw8FxL=jexXGRZqr191xs?I%C_0jxtCCdIO%N$9&E%>w~919g&Z)9WmY7j5ljbIM~mU1D7YgQ!I1vo>E5A_67^nQipH@Z4 zQ0nj;nR!=Kax*@pRKheI3R}7DL=!@2z9515=%+KkG%Z84~8?=pw z`CwR5q@JpEg~1C?&ZHig00TYY9uv~`z`*DwL+BDI^j%!es_sk&m0@(N{^}iQHBRk~ zE907fA6*r!8?S+Bks}+b%2VFsCx+Xsi2H8)W zZXBXQ+u{!g1wmpMteN%oAC*OLzg`~8YC8>gukma0cy7>JzM}5%$vZF<#qCHQ-UPkR zJADN4?a-T-TNvcO7nG~6Y4*9UfZvZfmNp0v!UKkVj^b7zsO3pZCLeT$4v!1DKQ=L- zr}{|d)#l02v)jKpC+``khAUhiRkNXgdUfJ%3L75n4LDX%9tZk5=Jl$+cu?JH7#BC2 z1KowUx13ov1yrvIjU5YEpghkkhlwm`i9EZlW_=>ue&|_qZ|O8Jv@gsq>xzZ;Was_} z-C7vZC3SV4hzI?$&K7U>moRWDwIV5V8Ypfr>`cvZgMmY>5rvx-FyM35VfPQwp!uxG zJ?NYkv@JW@j0H2Ghc9oORJQ_@2F=!rrv`*f9|s`{q9dmHBPFJ6Fo~n7o6YW~PPcIx zC(V!w)3Qut{$TFGE74f{-!=BheslY;>upYHCl*Si=0iH02Ua76heHSsp*V!$5N;bu zB9x|NSR>JKBa7$djR&!3@z^0=-gqdcdB_g+^2S3tSPbkiFYi}^XGju75)g4nAW1N_$fA4gzx2g*edq$Or9n-s*><)JTmha7`kVp zcX7oAEo#{>4A+PT_ey#1 zX?0n$WZ6w_&-czf_ndRjy{9n_2!c=%8jXTb=@=sPkD|lp1R@lwGxm`HEj#UZBAJcQ zWlS(Pxj2LI;&2JIEdtcs^}Ue?F2gzF<|C`GDxr%%V`$qwIot@@EuDFs0guury{Gn! zhk;Fu-ilNedg}ebBd)W3K(k1>B+(%o>f)!Dcb0d6VUtYUS`rNUxLotxGtHne3ud{g z+Q8Hjs}Y}TMhpB@oJIx$Ez5pmczezTEngZ|oKg&i6F~t-*E2!;r)tgzCHtUjvCHL} z{9I^yci4IEmdl`RQnc;r42FA^xr`g^DKN6D)00~f01u-gxY-&R+8w%o8K0wtp}jSm zMTQ^+WkpD3>EbuwX?9yI%^3!4EFxv?=tdqQ1Q_MksmhHbZ>762lqbIK^!ebri zBlQcI&f67~UqAlFC^Vzmw|$cXnW5YY@tV4|^`NW^ub=gm0xhkhma5$lxYIY$zK~Z0k9HUf*Pd`t*aghb>W>m&P-C-W%Q+GrE$VF4gQaSWqSi!35NCS;&WUKMYZD=u1 z?TIQm3%8@@I1X1vL!X^=b(yaYbQivzygMlzdfzH)IO*C0{m0g*5H<}A`RQr8+)x-` zKWV&v&<`;${1GbDY$c$U!B8qgPyXLwTDjJhQUZ~d(zM* z=y}%RBZzB*o}BE0Apbp}UVT-!*L5ZQe$=U?UU&fRGwiceHv>Vd6fd28U;?yzoX`HT zkpbORhtsb#O@{6~|E8>*r=S@scX?RFhQ8@l33(JYJlqp-G`}nsjJ3>bmA!GGxmiCh zb~XpP3T|yVy?hF2UK5(z7qCEmj#&m1S^L3=#^oK&-s~@-|71$JIDHzZZY}Ic$#R4KgDv3&n^n;7bHy?5hbYi} zR_GpdRuB5-9j)g48PLsFHcYBr32KvWYxxrsg3#=+KA|8qglTD{gyapFaKffV?T$^F zjmbEY>;Ay zTbrCF&k&{CtkU9y8KNNnZAu@#ikENQ{u5DhVv-#1RXTcYv_*>lNm|{|EhTyWc~K)Gm)l0bE+s{nD6)Bo z^fXa+X2vTrVqpI-X~GR6%i8N>*;_WckFDGBeF@?a#3jg&pm_xO6BIyDAVKr-IxbA(2a>ABpow^d~WZ#6S|sXdE&chm6J{qjAV+95Nbb9`a&q*$Ie>2#AUZh>8gO PELHvsY<}W`1qlEE@9~`4 diff --git a/inst/tinytest/_snaps/transform_lr.rds b/inst/tinytest/_snaps/transform_lr.rds index f6d9b5dda94dd6cc7a526a60138be62f3e937090..2180d7b0053b60f866b4361fdc04efef510fd65a 100644 GIT binary patch literal 2365 zcmV-D3BvXtiwFP!000001I3noIF#ug#~(9ZN{3XosEyJKt0tK=Y}D_O@>UybmQ;F~ z#vrDVx7vygMWx!1oRlc4GpE){*|ylakub<=y~Ij+9j_TLGnko%Wf{*o&bh90UFV;@ zuj{#fpZjJn|bwNmZ? zKd#|ec!nDc`fYHqFZco4>HB?mv(+HarLyC`b3X8O62*3OGE~^u-=}bA!idvTHRH@M z5H1JX+urTyi8!&&Ci4^Y%(2XhIv)u|@pa3d(VIc^{gvWhi$6g>SD%-fo&y4nr2gye z9xzlA^)l%0W0ZhcCp4pVpw7w1SjXQH1gE#Th0Y8CQTlx?jp%IXwGdic#wY@R@w*U- z(=w>8XK|IT?Sx*vnKmcBUIWdsCTAo0inyYW%;BbGD@bZnLvQP3K;{aHk(4ZgQTs+w zsKZydQgLD9=ZOZm;_3z+16mbMTFtV>LxWLC#FMU1+83ZMZ?LQ0`y;O5t7oHEWCBCU zdvDG5w8fR9`cF0_>!N}$_1CcYvCw4MW*?dq41I=8e!9vORA#y(hVh~gS6^~OYJ12V zS2kSI8dDVyZ7ws?&`v{W(Hed%(bb0DS$z7yg=a9@oV|>mnS-l5*OG*tYla^854uat z55w^L*m94WbvTCakMCH04=gAj(y7=&;rXaYJlr)5}PZiV7|6_$0$1|JzS3 zxEBbYr+oPR=^YTB_VYdxK!u?lQHdZzIA$K}FtbGnk|_O@ZIT5zR{J`Xv!WOVBU>HI zUFJeh#p1XSM<;dVUa61|48c5WS>GV3E1kuHH zL9-lELBv_0YUWxG!#n5xzA@nfNbC+M1EmOtTURN%v$w-=X0+Bq8XF{$3Oaphdq5mq zHRrU<9)vgFROK#w2(laW0N)3uAp3b?^BG0xvW@<*sYC)FF)%&7#0f=^BU2%&F zKOvJ2NJnUQt5Z3Z+_jz`38RmGJQ z&hYNeY(&G(Pah_pEkn)fUbY3fWXSr$C`4N~6-i?QuimbY#ntJ80*lxvoP;V)aa6XW z^4$@8!`%OY+N}2k>y!4ObCF_w(p?J>R+hH7Tu8?i8`)b!t7=f%08M7?OM)K5K5gq_ zCWsT#sHJP~K#%t>jvBWe-BaG*y>>1Wx(*i@`Yggge7`%{cS#$x{pgIHqLhK)?Je)5 zn_EzG(xt88;Yq-A+MOtL$;7dN{p(xw5}}Q(7NzFRg^^n*k+oC{(pA^y%sF@u@q~p^ z1B)ln_P*#1`4tB>nJvpqG&KZi@tVgj@i##DsV(Fu4<%?xNNGH9`veNh{yO~DMJuSx zzc9N_*9$tM?P#G5{UD50PTW}d2pS`;j#tvm;bV0dH!ZRn29gBJy3Ra;Zg<{;2)hmF zIqmGV>nI=k{8F>?f{a1R#;qN`>jbI(DS=1fHTcBXWWx52Mzy-xx?j}>KxRl<$@45< zob(u+uNway_^u55@_rHwerY)r_Hr4jI+s^F&*U<+3b2g7d8fnM`LB2jleWRLG8Yo$R8rL@~$@dFf+gSs=G#X*H@%=>4l523|j_T?47jl#f*z*%%HU68Gy z&+9GT4(}GNF<4`5C9el+`0;2{`8N_2AC`L5f|(1#?=pisuGXTee_Es*HCliK5HstG z1b5UIU;}Iljs!FZ#`b6~3<(Wv1cOZI-CNpddxM;Vr91-j2LVv%;y9-zJ_zyiuYBaS zI)iwJD(&Xn7O2%@UlB8Zkmnovj~>jX=gM+0P7OQ8#sc+*qp+3SE6`og8oiWW2K-SD z?ekCyOynU3y{Fz@?#iw~qP1^&UN(@ISB_^py zBVkVuOSRPz@iSbOSI+Z;x_3DJcS{cR9(P)w+qno@GFAoT*2kfr?p}&EH5*19=BhnQ z^9tcZ?NybxntIq|LvK5W&BN1Qp@*x#)7&fzLXXz%ObLGy53j40OguN9gI_+|z)@;2 zgPvRW-|t`?g!az5kqxGGP`cs8Th7k!(F=VQj$wZ%l#D1yH3Vtss`J^l%bGQ)p-gI5 zkll`Iy=U}&c7PAvY-)P-@pq`^UP(=NcQmy6^_+A|SP5a@cNtd`Dr)1@k3=Rw4R2$PebRMkTzO64p+rU5ub7nfYn3ojk0=Zq`_N;U z0;Y(~9RKjUA38i{)W)81xAxehIxR#w&^M654j7~H9|CQB*F-}8a_cHi7;pdY{As6D zI>PV|96zMScxTe7U@3>qaFPwD6-F`QmQ9PD(p5ReI^^jUD8Fh-!27ep z*Z-HDerhJ05iqt0N#kFfr0q`A)y5Lw!|-HHR%&WChxKhxz<=4@jImdR!#Ke+Fl5MYc>J1RY zHyw${bcbR8jgAh5-$N&3KW`651M*#~yKcJ_fIv4%V$UE!m94{VDt{J?IX~1e$qEP2 z3b4EG(}^BPk{WEY-a_9ztL*4+qM$gTVfiCQD~P|lQ2J}>TNvaUl%!?kf^cr~;N?zF z7%7W>8hrCUN<{2qS~0rN;OuLn8{h=OliS_HW`%+{lT06xmqCl0mTKWvJA7 zIn*|?`IJk$pkIHM?Xl0+LTjAq=_mmiC;Q4BuUfT(v_38Dx^5<9t)v>uNMaawXcmV# zeu`5{i<&=5GQ`Pinsg26HMr^;wjCZ8g32Nv^t{zM3k~_hJ&itZ@VPvFTm52F7)jZ8 zZH|{6t`^uAP22l{6V7(-_t!FX%Vaz<7zKI5^rH2h2}^m)A2TWWC# zMqkBMde*JSF?@eQ*P2@(J&`n6Ow|W*-VDbs8y%1|#g(@_jRKjt$nu773JeRrdfSG3 zgXnSU>)#*V0MSW*AHP5vjO>g~0x`ldi#W$wZ6c6H8>DWRF2u3=U&6R6OJO*w-Ko-b zKJ-;Bi4S#h2HBDO&A+;K!<#P#esk2?3^JC<67JT$AbTERFIT+;Qq3c}{VvBrd~SX4 zY{xVZa~GFi!}&NCTITLvnGJ)fTE4Xw{UD93IR8Y#2dPJhM)k3iF!s#>2PZ2N zT!rhpS)y$MBZk$_BU=zrkI^9KMbuaj>Uw^I&Z!~s+K!OzA0C3CWwcFIIyN}@=AO9l z;c}2W_@g@ohAj#E@l zmE4@wj7D7^-c34Pfm$`a?F#cqko~c7sE%G5lEnpGyxtgxYchm|mT}RzDyllcov{N| z?upzN?(q-QVY4^HK=liBCQ4$Udeag_)#YujXESheGiO^^O&v-fqRVY~s?cXNpkq_Y z0!d;zt$f`L==0gl)!=ucTWb4z*Ue`^&!Ivi-^Cb6Zuh3}mUckL4=&gVY6S>iT=Pl3 zx)rr1f4eOrA{k1Y_aup2vv6!^|AsdGB; zu6iF_E}Hxu1a3@+%0X2a{={k|{ONL3b0)ujf$4c@7h;)z^T~i0A3iHtl)N1tRk+eg zbKc;jmtS4@Nv{Q@t7N?a4(EDm7hydLU`I?OI99;zRn8ix>%2D{%M(d*mxllLhS61 z6FtyCpe=ByI1NEP>0POV<3H*E-u{r(mDv0O0l z+lSsTwD*K+o{vAu9_?JFZpA=7KX*O$ZgfX^3%`pnXbV9l)L+iov(|y^c$j`;o(uF2 zKddf$!AJ6EH{b*F0VueWqBVHG84Z;bT`6`-hQXoJ(p}kil=*?mb4RQ{#>{*aby=wQ zEz2*0*Yy`?ywK9e-aqI?_ozig#xrzx&DUC6;2I=bj`y5qc79crqO z*%#(?qI#d110Q@TfL;zQqxR@aRClYauD3S^+Wq^EyC<%Kj>c1+#?B0==6{wwc-$8? zW=5BLd#;8m0mr9;uLV{0@tS^7iBMOvDc2$SGBmHcB=n@vP|hDpP2@r+O!4}EkLeL`*oWEg@;vuX;-j!Q%s}Pj)Dll7D~K1Mpt0%Ze$0R% zr8(ujQpHLMTa;j}gsn>0Hhrf6X3#<2`<>L4ZDVD;g+OZpw-UHbiCYMRErh`q!oZr) zS`*r>#{UrtFTjI6aoRp?vR#!Enk?QSKSe6`ALIrFvi+yck`FKg+3$54@AQ*$44Z6e z60S9waOnScN#s?1T(Mk}D2vKCMqHX{wo`s*9AO{y@(xno914`YYuL;GO-^n@nQ-~9 z#a7+nJl%of%)U%7_Oz~`aM@o42mVPwGZmMe%RI!Mm|O5Z_=$x&N)L7>Q$(Ah^;2Xz zMH{AwK1F6zWIjcoD2r)lvW`F#0%-)UC(x9@4Fu8&G$YWQK*Af1@J1uN(Fkue!W)h7 UM%(aL^*J{72ahZsdWa1G06h+%0ssI2 diff --git a/inst/tinytest/_snaps/transform_plr.rds b/inst/tinytest/_snaps/transform_plr.rds index 72e9a52af6120541ffa13b503d2bdcf0e75fef75..086a68b1670da4ebdd601c54bc0aba39e3d55559 100644 GIT binary patch literal 1311 zcmV+)1>pK0iwFP!000001I3ejOjBnRz;9d1LtE1ESj3T8BOr{T^df>$Ie?%H@i7EN zvZ)0sFtk+KJ>2HNF&#l!7&AV|0?b7QOa=o)*`yzW;Dd+MY&;aPAP~w!3PPc?j@?3g zuQba{_Rnr|bAIQ1=R4>7&iPKnA`HVAn28A;V=xKCnBifY-Mldx!;(;9U|L~n!LO-= z$(20cu~-F+p580n-*^ht%W_r(bJxT4%7S~fX$7Eh2_CjNiNRFBx=L%WY#5tB?v9%6 zpt7t;X5FrZ7saC;2`()#DRyPqcGtqR`t@z4SDiswk)uuGia-@~x-RPh2PV8^zvReV zV5moZBcF8$v>}&h>9`Cu7WClmZDF9|vbQ`cWx{wz=rPCRoiMJvP%++@1yhgjHJ&MH z0nInN8X{Khfbkk1hxX2DnE2ydTOCdVLj)nqT^L zc^V6z`;6_3w$j40%6D_m-Wi3dCpYh#Bsrjw+o=t8$JFSiH{W?{=!h>vTa2gmZiim> z{_iIiU4iFOpJ{2#Ye;c{ zqVC)l7R&!UOwL|Tj{cGhN_Sd#{OSs%x&GVbuooh@F&z?R-_wDVlCoa6J^NtdwJp4* za!=@gv^$+EErj-O#l<`Ft>BrYBJ=1$5t>rxL&S>j(15IAc--kJ^dv?@Q&kEKw5dHB zHzYu3Nf~5VZa~e}`0*3%Vlh^_OL>|;NE?0+_x1z6I>!YfIQ&4+-c=dSUB$Cg3xGXlL6#DE~U!84|BDpBe=}D;r zbnhBV>ubyeg~E1eHUfXKZzFCESpI!PU*qcL>L-sopi&W5Lm8f{jb_V1p>-K62 zK$zW-fDXfEi!|GMAkmQ1lANvgXfN2lnGG(Q9Q8(@l5N=WXHz@B&@*CJVx}z+grgUQ(HaN+?Fb6O&?uNd!FAcg(P08J&1o zEQprwj~7WL!XrkjCQ$;3P;X<;+2`e7*nC$RzBcnU0o6h|@1r|{*(|YL=W7EaxsLT{ zv=cS`yEFuV;mS`2BSMPM{i8nyW_s8gOU&qlA#Syp#q&WA7D{73(tjW?=V0>sW~7(% z=cUbJ)VpTRwSv40Sr@a9gz>R)Qp4kB!kxJ{mHjGd+?D7<0tpd>&Uwkm*clRPoQ~*F zf*@9?e;nj?k?`XWB>!+cb7DG0g2O`HnzjBax{Y@Fb$Sq=B%CAEZwPG!TXY`7=3aL(wFWJMy$ VibRqXiCm+r^4~vlp~OQ7002#Di7wJvR7!| zlg_wg$+DZgcfNbhx%ZrR?maKs4#O}8#$?hk28%$96&1PC%O9gL?1@P{jH<0{1(oG6 zJdYnZkf?_K!kff#R^FU2-Vzv{cj``6`YF(Rg!MWf#9$fT&ae8C+wWqAe}PYl}7!_`ObJHU{i@|QfN z2lTY*t`xFUzz}|tmVqllZ%YqrT@wjf9%t3VVipWGMeLosuNek4$IAvgj=;#HJ9XLT zZiD`t4Ykqp*TG+EzkJPR0DALnR*r{(YG=iKOrk;hl>GG(r)@B04Q>b*L2)nDMgI-)O-VK|GYx37hE z&erdT?9Rip*v||!)-1jdu`eRLvO6& z&s6zB=fjN|JVg;Sek(n@uFw&l%FD9$B#6<7t`MTBNhMF)>?XBgH50AOweajB2jYZsB63 zkSK&Ha)OKv#tqzzO^p9tM(d9o$G=@~`IU(>$u24Jl?-DoxM{@ezkVz;ND=K8P1M=p z75TB^QiO7|kzA4>j8jNt1ii3ymkMPHvpdVAq%Ai?kQr8(A=nHdmOIIWie!mtC#Fd` zZTSNCApQz|Fh9h@q_QPcQxw*O;-x8zm=Y6<%_XvUkum=#*yIH?8|>pGJEX+NZA}&{ zG)9RI28@2qT#;S)YhWMkQIp`D-uIiBxa$p%6|cO55I&3 G2><|kBcNLV diff --git a/inst/tinytest/_snaps/zero_multiplicative.rds b/inst/tinytest/_snaps/zero_multiplicative.rds index b9e58bb63a36fcf2bb4beb037066178c3e43546c..259a6a1859dfc11bf2f3f096125a7fb18bb6060a 100644 GIT binary patch delta 145 zcmV;C0B-;11HA)~6aiw970m^J9%f)*k>^@`XtuB>=Oh*bEnyNs5)^dK&n?I=&Me8y z&+|toGJttbV#_#c{j4xo4Q5_3~Qa>7tQ3xNF%k!K1v zgtLs`EMqv!1kN&rv&`Tub2!Ta&a#Bszzh>{PK2@CQeiB=M37qnt1>8)k^%q#9XdaP delta 188 zcmV;t07L)11Lp&f6ai$B70m@$n1KFck>^@}=(eO6<(C!!ZD9tvg|h)j5W?st=fGNwGoRe4#lZ0zYOH3}wF9NduL6o!p2ZjT(3PI=m+=Be#%#zIfJm18UqRa|3 zbJ+_Lld}`kQ_)Oj%}cE)Ek+m&m*4;fcwS;|Do9Qk8tMYzkcY@K1slRyMsSufoMi$h qXPLrTW^k4{oMi!LSwd}KhKV>Q!dPypFqU5;$gKc7>y|bY0{{SLqf= "4.4.0") { ilr <- transform_ilr(coda) - plot_ratio <- function() plot(ilr, by = NULL, ncol = 2) + plot_ratio <- function() plot(ilr, ncol = 2) expect_snapshot_plot(plot_ratio, "plot_ratio") - plot_ratio <- function() plot(ilr, by = rep(1:5, 5), ncol = 2) + gilr <- transform_ilr(group(coda, by = rep(1:5, 5))) + + plot_ratio <- function() plot(gilr, ncol = 2) expect_snapshot_plot(plot_ratio, "plot_ratio_group") } } diff --git a/inst/tinytest/test_replace.R b/inst/tinytest/test_replace.R index 76a4252..019ae9e 100644 --- a/inst/tinytest/test_replace.R +++ b/inst/tinytest/test_replace.R @@ -1,3 +1,5 @@ +Sys.setlocale("LC_MESSAGES", 'en_GB.UTF-8') # Force locale + # Replace zeros ================================================================ X <- data.frame( Ca = c(7.72, 0, 3.11, 7.19, 7.41, 5, 0, 1, 4.51), diff --git a/man/CompositionMatrix-class.Rd b/man/CompositionMatrix-class.Rd index 472d157..19e3520 100644 --- a/man/CompositionMatrix-class.Rd +++ b/man/CompositionMatrix-class.Rd @@ -13,12 +13,10 @@ An S4 class to represent compositional data. \describe{ \item{\code{totals}}{A \code{\link{numeric}} vector to store the absolute row sums (before the closure of the compositions).} - -\item{\code{groups}}{A \code{\link{factor}} vector to store the group names.} }} \note{ -This class inherits from \code{\link{matrix}}. +This class inherits from \code{\linkS4class{NumericMatrix}}. } \section{Coerce}{ @@ -59,10 +57,12 @@ colnames(coda) # Get the column names \code{\link[=as_composition]{as_composition()}} Other classes: +\code{\link{GroupedComposition-class}}, +\code{\link{GroupedLogRatio-class}}, \code{\link{LogRatio-class}}, -\code{\link{LogicalMatrix-class}}, \code{\link{NumericMatrix-class}}, -\code{\link{OutlierIndex-class}} +\code{\link{OutlierIndex-class}}, +\code{\link{ReferenceGroups-class}} } \author{ N. Frerebeau diff --git a/man/GroupedComposition-class.Rd b/man/GroupedComposition-class.Rd new file mode 100644 index 0000000..0293c6f --- /dev/null +++ b/man/GroupedComposition-class.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllClasses.R +\docType{class} +\name{GroupedComposition-class} +\alias{GroupedComposition-class} +\alias{.GroupedComposition} +\title{Grouped Compositional Matrix} +\description{ +An S4 class to represent grouped compositional data. +} +\note{ +This class inherits from \code{\linkS4class{CompositionMatrix}} and +\code{\linkS4class{ReferenceGroups}}. +} +\section{Coerce}{ + +In the code snippets below, \code{x} is a \code{GroupedComposition} object. +\describe{ +\item{\code{as.data.frame(x)}}{Coerces to a \code{\link{data.frame}}.} +} +} + +\examples{ +## Data from Aitchison 1986 +data("hongite") + +## Coerce to compositional data +coda <- as_composition(hongite) + +## codaccess +dim(coda) # Get the matrix dimensions +row(coda) # Get the row indexes +col(coda, as.factor = TRUE) # Get the column indexes +nrow(coda) # Get the number of rows +ncol(coda) # Get the number of columns +dimnames(coda) # Get the dimension names +rownames(coda) <- LETTERS[1:25] # Set the row names +rownames(coda) # Get the rownames +colnames(coda) <- letters[21:25] # Set the column names +colnames(coda) # Get the column names +} +\seealso{ +\code{\link[=as_composition]{as_composition()}} + +Other classes: +\code{\link{CompositionMatrix-class}}, +\code{\link{GroupedLogRatio-class}}, +\code{\link{LogRatio-class}}, +\code{\link{NumericMatrix-class}}, +\code{\link{OutlierIndex-class}}, +\code{\link{ReferenceGroups-class}} +} +\author{ +N. Frerebeau +} +\concept{classes} +\keyword{internal} diff --git a/man/GroupedLogRatio-class.Rd b/man/GroupedLogRatio-class.Rd new file mode 100644 index 0000000..f836673 --- /dev/null +++ b/man/GroupedLogRatio-class.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllClasses.R +\docType{class} +\name{GroupedLogRatio-class} +\alias{GroupedLogRatio-class} +\alias{GroupedLR-class} +\alias{.GroupedLR} +\alias{GroupedCLR-class} +\alias{.GroupedCLR} +\alias{GroupedALR-class} +\alias{.GroupedALR} +\alias{GroupedILR-class} +\alias{.GroupedILR} +\alias{GroupedPLR-class} +\alias{.GroupedPLR} +\title{Grouped Log-Ratio Matrix} +\description{ +An S4 class to represent grouped log-ratio. +} +\note{ +This class inherits from \code{\linkS4class{LogRatio}} and +\code{\linkS4class{ReferenceGroups}}. +} +\section{Coerce}{ + +In the code snippets below, \code{x} is a \code{GroupedLogRatio} object. +\describe{ +\item{\code{as.data.frame(x)}}{Coerces to a \code{\link{data.frame}}.} +} +} + +\examples{ +## Data from Aitchison 1986 +data("hongite") + +## Coerce to compositional data +coda <- as_composition(hongite) + +## codaccess +dim(coda) # Get the matrix dimensions +row(coda) # Get the row indexes +col(coda, as.factor = TRUE) # Get the column indexes +nrow(coda) # Get the number of rows +ncol(coda) # Get the number of columns +dimnames(coda) # Get the dimension names +rownames(coda) <- LETTERS[1:25] # Set the row names +rownames(coda) # Get the rownames +colnames(coda) <- letters[21:25] # Set the column names +colnames(coda) # Get the column names +} +\seealso{ +Other classes: +\code{\link{CompositionMatrix-class}}, +\code{\link{GroupedComposition-class}}, +\code{\link{LogRatio-class}}, +\code{\link{NumericMatrix-class}}, +\code{\link{OutlierIndex-class}}, +\code{\link{ReferenceGroups-class}} +} +\author{ +N. Frerebeau +} +\concept{classes} +\keyword{internal} diff --git a/man/LogRatio-class.Rd b/man/LogRatio-class.Rd index f1b5588..a192326 100644 --- a/man/LogRatio-class.Rd +++ b/man/LogRatio-class.Rd @@ -24,8 +24,6 @@ S4 classes to represent log-ratio data transformations. \item{\code{totals}}{A \code{\link{numeric}} vector to store the absolute row sums (before the closure of the compositions).} -\item{\code{groups}}{A \code{\link{factor}} vector to store the group names.} - \item{\code{parts}}{A \code{\link{character}} vector to store the original part names.} \item{\code{ratio}}{A \code{\link{character}} vector to store the ratio names.} @@ -56,9 +54,11 @@ In the code snippets below, \code{x} is a \code{LogRatio} object. Other classes: \code{\link{CompositionMatrix-class}}, -\code{\link{LogicalMatrix-class}}, +\code{\link{GroupedComposition-class}}, +\code{\link{GroupedLogRatio-class}}, \code{\link{NumericMatrix-class}}, -\code{\link{OutlierIndex-class}} +\code{\link{OutlierIndex-class}}, +\code{\link{ReferenceGroups-class}} } \author{ N. Frerebeau diff --git a/man/LogicalMatrix-class.Rd b/man/LogicalMatrix-class.Rd deleted file mode 100644 index 56736d6..0000000 --- a/man/LogicalMatrix-class.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllClasses.R -\docType{class} -\name{LogicalMatrix-class} -\alias{LogicalMatrix-class} -\alias{.LogicalMatrix} -\title{Logical Matrix} -\description{ -S4 classes that represent a \eqn{m \times p}{m x p} logical matrix. -} -\section{Slots}{ - -\describe{ -\item{\code{.Data}}{A \eqn{m \times p}{m x p} \code{logical} \code{\link{matrix}}.} -}} - -\note{ -This class inherits from \code{\link{matrix}}. -} -\seealso{ -Other classes: -\code{\link{CompositionMatrix-class}}, -\code{\link{LogRatio-class}}, -\code{\link{NumericMatrix-class}}, -\code{\link{OutlierIndex-class}} -} -\author{ -N. Frerebeau -} -\concept{classes} -\keyword{internal} diff --git a/man/NumericMatrix-class.Rd b/man/NumericMatrix-class.Rd index ed41813..931389d 100644 --- a/man/NumericMatrix-class.Rd +++ b/man/NumericMatrix-class.Rd @@ -20,9 +20,11 @@ This class inherits from \code{\link{matrix}}. \seealso{ Other classes: \code{\link{CompositionMatrix-class}}, +\code{\link{GroupedComposition-class}}, +\code{\link{GroupedLogRatio-class}}, \code{\link{LogRatio-class}}, -\code{\link{LogicalMatrix-class}}, -\code{\link{OutlierIndex-class}} +\code{\link{OutlierIndex-class}}, +\code{\link{ReferenceGroups-class}} } \author{ N. Frerebeau diff --git a/man/OutlierIndex-class.Rd b/man/OutlierIndex-class.Rd index 1a371ac..04cea52 100644 --- a/man/OutlierIndex-class.Rd +++ b/man/OutlierIndex-class.Rd @@ -13,8 +13,6 @@ An S4 class to store the result of outlier detection. \describe{ \item{\code{samples}}{A \code{\link{character}} vector to store the sample identifiers.} -\item{\code{groups}}{A \code{\link{factor}} vector to store the group names.} - \item{\code{standard}}{A \code{\link{numeric}} matrix giving the standard squared Mahalanobis distances.} @@ -38,9 +36,11 @@ In the code snippets below, \code{x} is an \code{OutlierIndex} object. \seealso{ Other classes: \code{\link{CompositionMatrix-class}}, +\code{\link{GroupedComposition-class}}, +\code{\link{GroupedLogRatio-class}}, \code{\link{LogRatio-class}}, -\code{\link{LogicalMatrix-class}}, -\code{\link{NumericMatrix-class}} +\code{\link{NumericMatrix-class}}, +\code{\link{ReferenceGroups-class}} } \author{ N. Frerebeau diff --git a/man/ReferenceGroups-class.Rd b/man/ReferenceGroups-class.Rd new file mode 100644 index 0000000..fc71d26 --- /dev/null +++ b/man/ReferenceGroups-class.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllClasses.R +\docType{class} +\name{ReferenceGroups-class} +\alias{ReferenceGroups-class} +\alias{.ReferenceGroups} +\title{Grouped Data} +\description{ +A virtual S4 class to represent reference groups. +} +\section{Slots}{ + +\describe{ +\item{\code{group_indices}}{An \code{\link{integer}} vector to store the group that each value +belongs to.} + +\item{\code{group_levels}}{A \code{\link{character}} vector to store the values of the grouping +variables.} +}} + +\examples{ +## Data from Aitchison 1986 +data("hongite") + +## Coerce to compositional data +coda <- as_composition(hongite) + +## codaccess +dim(coda) # Get the matrix dimensions +row(coda) # Get the row indexes +col(coda, as.factor = TRUE) # Get the column indexes +nrow(coda) # Get the number of rows +ncol(coda) # Get the number of columns +dimnames(coda) # Get the dimension names +rownames(coda) <- LETTERS[1:25] # Set the row names +rownames(coda) # Get the rownames +colnames(coda) <- letters[21:25] # Set the column names +colnames(coda) # Get the column names +} +\seealso{ +Other classes: +\code{\link{CompositionMatrix-class}}, +\code{\link{GroupedComposition-class}}, +\code{\link{GroupedLogRatio-class}}, +\code{\link{LogRatio-class}}, +\code{\link{NumericMatrix-class}}, +\code{\link{OutlierIndex-class}} +} +\author{ +N. Frerebeau +} +\concept{classes} +\keyword{internal} diff --git a/man/aggregate.Rd b/man/aggregate.Rd index 316b26a..e02ae85 100644 --- a/man/aggregate.Rd +++ b/man/aggregate.Rd @@ -4,16 +4,18 @@ \name{aggregate} \alias{aggregate} \alias{aggregate,CompositionMatrix-method} +\alias{aggregate,GroupedComposition-method} \title{Compute Summary Statistics of Data Subsets} \usage{ \S4method{aggregate}{CompositionMatrix}(x, by, FUN, ..., simplify = TRUE, drop = TRUE) + +\S4method{aggregate}{GroupedComposition}(x, FUN, ..., simplify = TRUE) } \arguments{ \item{x}{A \code{\linkS4class{CompositionMatrix}} object.} \item{by}{A \code{vector} or a list of grouping elements, each as long as the -variables in \code{x}. The elements are coerced to factors before use -(in the sense that \code{\link[=interaction]{interaction(by)}} defines the grouping).} +variables in \code{x} (see \code{\link[=group]{group()}}).} \item{FUN}{A \code{\link{function}} to compute the summary statistics.} diff --git a/man/as_graph.Rd b/man/as_graph.Rd index 29912ee..d846bc4 100644 --- a/man/as_graph.Rd +++ b/man/as_graph.Rd @@ -64,8 +64,8 @@ plot(plr_graph) Other plot methods: \code{\link{barplot}()}, \code{\link{hist}()}, -\code{\link{plot}()}, -\code{\link{plot_logratio}} +\code{\link{pairs}()}, +\code{\link{plot}()} } \author{ N. Frerebeau diff --git a/man/barplot.Rd b/man/barplot.Rd index 805fd0d..1fbfd0d 100644 --- a/man/barplot.Rd +++ b/man/barplot.Rd @@ -9,7 +9,6 @@ \S4method{barplot}{CompositionMatrix}( height, ..., - by = groups(height), order_columns = FALSE, order_rows = NULL, decreasing = TRUE, @@ -26,9 +25,6 @@ \item{...}{Further graphical parameters.} -\item{by}{A \code{vector} of grouping elements, as long as the variables in -\code{height}.} - \item{order_columns}{A \code{\link{logical}} scalar: should should columns be reorderd?} \item{order_rows}{An \code{\link{integer}} vector giving the index of the column to be @@ -87,8 +83,8 @@ barplot(minor, order_columns = TRUE) Other plot methods: \code{\link{as_graph}()}, \code{\link{hist}()}, -\code{\link{plot}()}, -\code{\link{plot_logratio}} +\code{\link{pairs}()}, +\code{\link{plot}()} } \author{ N. Frerebeau diff --git a/man/bind.Rd b/man/bind.Rd index 29cfe43..6369536 100644 --- a/man/bind.Rd +++ b/man/bind.Rd @@ -34,20 +34,20 @@ X <- data.frame( Y <- as_composition(X) ## Split by group -## /!\ Unassigned samples are discarded ! /!\ +## /!\ Unassigned samples (NA) are discarded ! /!\ (s1 <- split(Y, f = X$groups)) -## Split by group -## Keep unassigned samples, see help(factor) -(s2 <- split(Y, f = factor(X$groups, exclude = NULL))) +## Better to use grouped matrix +(s2 <- group_split(Y, by = X$groups)) + +Z <- as_composition(X, groups = 2) +(s3 <- group_split(Z)) ## Bind by rows -do.call(rbind, s2) +do.call(rbind, s3) } \seealso{ Other subsetting methods: -\code{\link{extract}()}, -\code{\link{split}()}, \code{\link{subset}()} } \author{ diff --git a/man/condense.Rd b/man/condense.Rd index d42399c..54fe5f2 100644 --- a/man/condense.Rd +++ b/man/condense.Rd @@ -5,11 +5,14 @@ \alias{condense} \alias{condense-method} \alias{condense,CompositionMatrix-method} +\alias{condense,GroupedComposition-method} \title{Compositional Mean of Data Subsets} \usage{ condense(x, ...) -\S4method{condense}{CompositionMatrix}(x, by = groups(x), ...) +\S4method{condense}{CompositionMatrix}(x, by, verbose = getOption("nexus.verbose"), ...) + +\S4method{condense}{GroupedComposition}(x, by = NULL, verbose = getOption("nexus.verbose"), ...) } \arguments{ \item{x}{A \code{\linkS4class{CompositionMatrix}} object.} @@ -17,8 +20,10 @@ condense(x, ...) \item{...}{Further arguments to be passed to \code{\link[=mean]{mean()}}.} \item{by}{A \code{vector} or a list of grouping elements, each as long as the -variables in \code{x}. The elements are coerced to factors before use -(in the sense that \code{\link[=interaction]{interaction(by)}} defines the grouping).} +variables in \code{x} (see \code{\link[=group]{group()}}).} + +\item{verbose}{A \code{\link{logical}} scalar: should \R report extra information +on progress?} } \value{ A \code{\linkS4class{CompositionMatrix}} object. diff --git a/man/describe.Rd b/man/describe.Rd index 5646069..ba4b15b 100644 --- a/man/describe.Rd +++ b/man/describe.Rd @@ -4,9 +4,12 @@ \name{describe} \alias{describe} \alias{describe,CompositionMatrix-method} +\alias{describe,GroupedComposition-method} \title{Data Description} \usage{ \S4method{describe}{CompositionMatrix}(x) + +\S4method{describe}{GroupedComposition}(x) } \arguments{ \item{x}{A \code{\linkS4class{CompositionMatrix}} object.} diff --git a/man/detect_outlier.Rd b/man/detect_outlier.Rd index d419a6b..ce28e23 100644 --- a/man/detect_outlier.Rd +++ b/man/detect_outlier.Rd @@ -91,7 +91,7 @@ plot(out, type = "dotchart") plot(out, type = "distance") ## Detect outliers according to CJ -ref <- extract(coda, "CJ") +ref <- group_extract(coda, "CJ") out <- detect_outlier(coda, reference = ref, method = "mcd") plot(out, type = "dotchart") } diff --git a/man/extract.Rd b/man/extract.Rd deleted file mode 100644 index 678a70c..0000000 --- a/man/extract.Rd +++ /dev/null @@ -1,47 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/group.R -\docType{methods} -\name{extract} -\alias{extract} -\alias{extract-method} -\alias{extract,CompositionMatrix-method} -\title{Group-based Subset} -\usage{ -extract(object, ...) - -\S4method{extract}{CompositionMatrix}(object, name) -} -\arguments{ -\item{object}{A \code{\linkS4class{CompositionMatrix}} object.} - -\item{...}{Currently not used.} - -\item{name}{A \code{\link{character}} vector specifying the \link[=groups]{group} of -\code{object} to extract.} -} -\value{ -A \code{\linkS4class{CompositionMatrix}} object. -} -\description{ -Group-based Subset -} -\examples{ -## Data from Aitchison 1986 -data("slides") -head(slides) - -## Coerce to compositional data -coda <- as_composition(slides, groups = 2) - -groups(coda) -} -\seealso{ -Other subsetting methods: -\code{\link{bind}}, -\code{\link{split}()}, -\code{\link{subset}()} -} -\author{ -N. Frerebeau -} -\concept{subsetting methods} diff --git a/man/figures/README-lra-2.png b/man/figures/README-lra-2.png index 775f651d995ab68f787a768e32f374ba6ca77560..ed3396247220126f5901e0b53928b9cb8758ea60 100644 GIT binary patch delta 12432 zcmZ{K1yqz#*Df)@0P27!h|)+3A_CGeDk6=fFobj{Ak851!XTowbTcXq(w!>O64KHk z-Q94{==c5qU3aa^TCAD#zUS=y>^x`A-XqqfHU(;g5S8rtdHJYL*3||4v~CtAB1%rT zC=~t|$6Ia8oQO{*j3=1AZ!=l%&T^$Pi8eDadJ-}+Kgcq#T!B%RvOE)g7!bhXSVDGX zxF`H@mEBs{HlmZgT3n#D&Io$p8qv||zatxdXf`Ks8DHkv&2fA@HF}CG@QW~_`-DiJ zZW%Qu!HD;Q693OX1H?l_&w${0n7{hyaf5pIuz0bLOU2?v)>LEe1=+X3_~S}`Si!xs zrV8XF0W2-NS0cCqn>F(cu@5;#BpGa$6qZJSL=zyhUW|AAo%Uaj+%3LaFpN5q zA(8`3^w^Z}!D=#bsxon2g||_`6^PJk$ubbYMbW1ug=!Wjs3*awZ%QJn$_;5)2@7vh zL*+gr*9o+?X!Ab{@c{c_(=%*zLpY}`e%qR63M{@3@L8D4e>I`RtVEGZ>+_gdD3x8*ad(J zf$lz7W&dHU46v_nV<8fn1j=`8z??PfjSwXAGw2`5TC99mETz8??gdRrZ@I<475Up( zj@u8+JsP~RO~um|fF=b+pZl7Zj~fgh2IO>MC>dkWnEoq&Il9|a`F0%DKkBQEd^apr z{%JtFJBu%Y>L2l|CA;`e{}#lcq3+Sg5x7C0RkYG1JyHfA8Eou9d!5Ds!||su_@Y^ zcpXk~0dB)1T;B!MPYA5Sj?lY)1jV5LDLO%7p*eS7NJ^b#1U1Kq7k9D5xHrD?NU0+3{)=o6`e zS^;q2PQT(wPB|)CMrC+_pM4TSRPA{<{qw&8!;|`yd&2*SUoF`dp8Ll%7?XU7i(mAw z!&?3H&8uns^A~x*t7K>%=$rr<{OJ@?!wP>4xZ9$;r3(*&xPZ!sx3KF${Nn%UEjLb- z4z2uE`6uP>*i(z&NF^Sxc$u_Kb*ZR8R3`g1P8e`ix@PWkM~=O?JS z;JYN4>ks;j=ai*%o)?w`qI19mNVDV*5>X~79n!Y*n8zxNXJX)$+_;jw86zGQ0K<#! z)=7_Llw-T3*xniog2{%tfT+Jau%4~qM1-5a{ujFF{xB)B^qC9NcB=j^Je7r>gGycP z93P%dltW$>^V-cL-z>xLBF2UZOVl4mqMXpl6cX^$wgTNA&8sSJBnH9gNs&3M;N{nM zvp*ApDrJ8se|g1dy&=Lp-@s($@>IXOr#-aT&M~8;$1CBQ_OSR})AsJ`6eVI8D4ktG z!+gwry#|NspD8=J#e1W>S3-EEGr#5@5$%l#rz#&G_s3Lqy}|YyzrikJ)^vq(r=B!_ z!xZS4msNPYx$$AWqiJNckW1a&4NKgIB^hOw*KHiT8}w7Bg5J?*u9$BOQ@ zqs8i`+%;rzs_&L-oS9Mf7k9rccK*sju_um@2W=1fG?=!1(nTp=G&(Na9c?!K`IPm% zJynvQ;!$^PTLno`W?s9&^P6tIJbqLqEhmkZxAR_`EzJJmb)-w_mq6m4-w%9B^rV*>hx;@ofduvwZwuRJ@(Iltq`u7|-PlmR1!*{M!?;Ws)U~kxTj(ELVpuFGH zOcS+7mQXL1)x=$H%TE*86IgG-njm6!&;JWkSu{y(DF+@j4Oh_Ky+E6L(kH6S%|v5i zKs&lmwQozxzHs=6D2RYLho$Ut(U^M51`BC+DepJfX$j+Jk;i(G;TuQ$5xK)u1aJkv za1vz|W2(2dDjeom4DT?QOra?(S$@|#ePO`ooU`1>#iA$ij*ME;9X(I>`ia>4$DO%{ zJn>W{a0MvsNWyB4f|{RhIq}bdRtL3hA&WUhq{1$`o8+k(8x-W#R9Qa5P2BMwBwO{@ ze0A-Eb8;K#r-z9dze5uy64gMM_LF&t{W$pr<*@c;5v9-x)QT2@Jth09^KNi@`TAo> z?DQEw5B z>@0GE-rT0QIZvhNXh{)(azS@nUmpzL4^G_L$#4N1MfP%Ic`JY6R9C~ez~+({IH9Nq zW91r@^gWw|POS}?IHPP}ubpbp9qF>hE_wt=AvI+N=c41`%f!!KajNuQFT;lru>J=n zx>VkQP5Yv@J!z*G;Mu+pI+Uw6CQjvy?kx745ra)e6cI1=JCXXsnI>Q=F^_Dnw^r~K z{l%58KgfrBvNvr@na(4%Ejv_gp+BICdqfuB+Y~e>WwjSa8?&neQb{Q0wj=6+5r;Kz z*qJl#co9oNZ+-&F74p(9b_K|&rBwFyZ7k9>mNTE~lERk+Cfx2E1z6@Y`t4YTqdy4_A?_`Z@1<73JW>={PYQ!KR!V(zsN!&`v3$SD zBmg%qD$OvC5fgU4*^`nCY&trR)HpNk+dW@#lm-icoZ!hZt(`t<;sGfgZY?xD52`$fw^-BhB~Sr^lw&%DEE=a|A4BSZA~ZUOd<7YQjk4vU zSBew7{1_-gWTeGA``u&61`l)eqw3pHKC|ahasAG@>CC~G_WJRo%B`fXem$Pe_3ubEZaa@nbQMj?p_s}0 z&Rf^o@?>W|f0u(K_e+&=Ma3S zs<*gOK_49*!T)78iG1pHOoniMh=wNEZEqkgrE=E8`O5B~9Vm=Mk9FI^CR-@m)=nPH zw~|?NF#qmhzdz79b%hd;Wk(G2qq>M}xpXuSzjKg5)hP>J=-S_HhRv;SuJl3PVZGmU zY7aTey_qr*iE!Tj&6R1=T9xb60Usjm6zymtc8upWXP@CVmEf>-`)m#ug9a{6_!42e z+>-lNr7`P6C5YNgrAk7IEg@0$We{uP$jj|$UQ}{;o#v(6FX;5PnNli1T!2Vi?9YSr zA<5?Iajj1r*EJ4=B>BxA$E$Ouxi4I4uA<;C=Nu_^S!ca9a+SjI;dEb)FNn7}Wd6|d zcH0o=#i3sz_I%=LQF|jl3VI&6*y)#_9HpZ@KjBvFOo!gvMsLRD zvlfqa~7)S97Zqr>efO>)?7d_x_t6r^!iIcR6z z@8{wNht`p7uVAn0S-zFe9|@4PbEWU=B$h`vC~F8~M5Fj`-(>DT-7-DBbm!6|Dv*q3 zB^GQIUstqj+POKZ0tjq^v@x5A^*c4-Y?qZtVtW?2KPWPKukoFlXNEIsE9y&zCG~dj zcM_m{h1!GH{NqL@mOq|D#6&Yx^8y+E&1q%{70wlCkoclt2A(m4I!{Ml)IRy<-etd+ z!hb$V<1K|-i3!=Py4(^@UG->wk(op2<6=dSKux?b9+23Cp>LqCU6>W6aHE)dH7_~b zR-V_ut7%7rDKqBeWt!W3%t;PM=#J%CoBYR3u49ps7k4Q7AjRbB=A7QHi}i7@YwBB! z#Ho4@gE7M3=nv=#I;07ANiuYaoo1Z`{eIEY=JWz3gaEJZGn5GKyrEGwPdelIsbIs9 zP@=qop%@1VKy#rH>ir#P=|$Cg_Y^H=I%-aum1toR3$my>vOB}l8k&~t7@%bc;#m1S ze>VsP4I-}rxyUev=O5IERa_I1-79J2wjnO*V_MF>+mw%oo zfWeop8o3U-o3z$@xc4S(eTblaf03%kJxbYx0H$?lWfj=8nXiM2Fdly}d|T^f!>(m8 zJWI?`{q*Hd;-E~oqlKa=b-kman)>Xq0XTmUmULV?zvY!(xu_~f8OBp9w0D9B*K4}R zWl)JW%$8UjV?*d&%UyiE`EtZ;W;$Czmy$ve581vjGUDZAH~H#KpT;8|WqD_b$)3Q8 zNbIb_#KZI(3)ggk?j!?i#nRZ&=$%4cxDyz@a$NS~{>W+&r0CB+oy>wL(5 zr}u3>89p+JE?i0zAwfE9DR6q<{>}1j#9Fk1tjrs;!JTdg;`3$Z%m_jTBCT!gJSNL! z@da05T}OO=a<;4tY&NAN_Q07nXP=*XN4;(>pNpMTPu%;y5{HEAN$UyoR-=gS+5Ys%1>H&GO(;UaItyP zHX$;*n$AhScMJjE?>c&6+J~_uVc*+RegT#jr8XG%jJM zv@dT2-4nyMja88S5>_XBOMDJhT~{6mL@)$;!xb0vQ37+y^jAWn z@w?Dq>tV(KZ~dQRbKDkr==#bcYG;Lv43iz+CvEl;RvGp=qRYyrJt-I(e6G%pHnktQ zG>a6)Hby3LCV?Kd7Aa4t2?SC(1x%5FHml4xSawSrpGz#fZ_k$hkaivVaCW5}{ zkd)zvb5ZF)!R)d+s~F8u5;mudd*r)bb!&57{~(WjI}BMZmBs9^f7Zdk$X$zqjx<_W zm}Dz;7r9*d{gu>zq*@gEyXjc0tVTy4Bw>FW*lQojySW_L@5~$x-$i!MT}*I&WrCPZ zrR8(?c<6SdQNh9#5Zekx)KK((%TFC+I_@03ScKL6eA`}Fb^U^dE8}LFd7;1=3)}gP z{Q&o*)MMhE@#vnq(qsH+b9A?B@;If+e(eKQ4rD3|lV3pW%;hWm85u1m9vOpkckYTV zNOv-v7-zMPJ+~wQ@lM&kj`iz$*wI@b@P-ysC$QIfgKt>cY%CIzcsYj*724bwY_pA7 zIfg`$0p1k>aq&}MV$D~EmACA_u*s^vu766oqkWi1vb?At<73OgWv`vHl%Z*54U`gE z!bvZQJp6o8^-`^6LE-aUQtg4c>6rBX$YUd#Qwl7+g{V4q^Mkp`^)ShUxgH6${-FCw zduv?Y_L%hCm6FmCA>#21`?K^I6eUGQY>eoSpZ7eUL0%zdssmwMyh-cW+;fdH;6A_2pV~i2(0EmX_QmZ$%mf zZEN#Bv6pkEkTyC9w`0a{uXofcS?2r3Vbd<&i%{OZ@HjP=W#OKAu7O=2S(hbGoZ4<( z5A9ej9hBBu1;pBG6V(0L^wGhUzvJAfu*fiFUYloa>{%#}Rrk-`Rv~p4!>}oqgr7iKXPis8d#WA_kde?lF?3UUl3vUan_+cn@+5#W8Y_T2OO zlSj2|!GZQyu1nvRr`9N#Nb~fuj?bFR#CMEiUEpb!`_TDrJ%W!@gK=B{UiN{4&!{H)yWxf*pW z>56RT&2gV^vdAgXAIQZCy(~^#U`bxyR_$)q~!jfPsdQF+OBJGvsLkDa>0*m zFCN7l2&}*)k6tQ;-R!TOmX=$X*B+rRp4g9;73ZKsXnGOdq7xrtJJo$n8Kyuulw@Kk z5}g$HAzqM+U#iHWcIeHIMXol~EI;C{H16`NJrfEz|E|<+0A17@FWy)+5431{yObmH ztzf5v<+vic)*oXou$>pDnas5P6qdS#xA)0ZbVNHnO-WVh-SZdcCn^dZEkC8wnYYJT z3$Z@oA+ghN#8 zo(GjNMqhgRMdx};rs;Je!w-WyBd+$SY*{Al!$q~pG0@U|U+maA@5rl~m=P-COA+;H zrJh3_$h5MjA^f-Kg|h{@TzlEsP8Zc-sW0%3%^e8suS?pUaCRBcGjgH}8aduLCn`Ng zo|3f4h2JHs;#Zkz^H93E0sZ0jh=xuxiC2QF!rAn#-`2(`eWOY~O3c!IMLw@F znPWu;K`Y-8f2W(X8S{R~My*TS<&Cb9YrhY^J)tz^vv<_mckQt0x9h90TkXEoQ0nI5 zX>Qlhfhv1}RycAjO+C3gdIQixF$hX?+JQ;aq4^c7LHIj7Yk zWwS{2{qoPhif)>R9o^-sZ}UkyS-G3K`ulf4owT_?<>{?D1G96+q0)@eWLEHd@lVYO z|DWZH*1e4+-}61)GV9R#UKa$ADPM$M?GlzowpOnZb&#viDUVO2 zFCk~ko{}9I4w1CEckjS2=Cs5&RO&#iKcImlF2mLBw{h6jxwZti)KCdh1>)f72@BJR zF*;3~z$9#1tIi)03m3cKK9p&T&Wm5d44u%Y5OcZUJ5(hfYk3xa#NJoM*ky{^AFqDg zva~)rVA=hujQR=dxN%qW@bZfknv@Z1u?)XJSC~H@+KiXhi4J@M(mPYO8ioObV??O+yu>Dx>sH zDP9MiouzUseZA4YF~jPg>s%#OvJ1+-iyI#ec;k(Kb1Z1tEKk2sk$s*zxC`}vyNBw= z6pnFUip=BW{QXOUX!gpGk9BjD$aU#Lb%zE8Ot`6JGYWe-SXOdODIH_I{yEy|qU9y3bX zySUlLNMyEk<;AH#WB4AFIS7qM`(W(82)#J0>U-C@_qEJT(P>1|t;07vksiHDIzxb; zOkwe`cCYNh6=!!h^YJ6Q)(7-2Zy5_ zFw~S=`~CtW3jETo>)1B&lf-dD!;d$!PVtX)zq;{AemX-mQ+&;BYA{Eh%Xw00%CFj| zrocR#dRUj7QorntKwP}$NE!+RrV5Ds!v5Ry?-^_bTknpxWtHtJAHFD?u1LtC>U+(g zIlI4Bj@x1nyia!zkD(`g;6^qMu;AoL6;~ORp_pxFa53 zK+_|y^6)IY>#JA{k$BZA{#o2zDnB0B>|=QXBMJ|XvP=FUQuER^2@|q`t2^#5hl+Li z#>FdSKOc~)<{dq;H%<@`-W9igtdAuaxazE+<~!%Rrd#qW^Gw-#>#Fp1XD+OX0TMdU zoXL-j1XQ7|0wF0mLW!>`-IM9c3B$t52}{odcY}oV7&Ogwo?l?#zixr)bVM4Ve&Xsr zZjMFg%60=Ogkl8;kqBOQW=^iEKy>K_9ksg}wM+^)DR|kLlod{~^PaIYk$o z(v+p=&IAfw^P{nKHQ9b74B*~yPQnTj&7`*bSFy`%t12iDLi`8^S3u*t(@AtMLT#qr z;!4FgIa_aFY^EOJzO!?3Dce-raXMG7LK_w zBbX2walm6Atrqnu%fO4D=U=@zoJ31L^k6jeZ}o246ymE3>WW{yJh}w9iV?B-i*M=K zNKt^B*&Q;4&fuy?M*U8=2m#+j65i&q;c=N86p^I25^6fcVbVmHB4bq^cF!YF8u-Kk zeA9y>+wT}$!hhmJ=&8s%iffYZGl0^f8{jb*Z*kq3jU3z%U1R42v+!VPCW+WTp%6p) zN4*L+!2D<%%k39Y{YkGvM@FqF6+8u>1D==bBHiF;fP;w=gCmZ=Tgfpt~>I2jPAAlw_2rob3)hDEg zq+t`tZ=0p}g&6UWhdwq_*MY=Aogf4rl)mH!lc&Jsi5ZS(8;^GZw)7p~+d-?_8E72@ z4BTN05NT!mL8jBQr;LEVCX!T_aW6eme1H8N>y~-@-@wO^;^6G|BUU zhQG5Q^g?(`*|PnrL94)>R^Mz-y0ReaR~TT>JIjsYzXNTcsoOxlTq3p%5=685wmBI5 z#0j@inrRy$dG(IgPk8|FCLl)1 z25+JsHRu@d1LdM1)rOc28$EExchw6Mo-)H@#7l=!pW@^c6`$4%)FFrbv6}9GknM$O z4=tTuBui6hI*%hzz`K%V)TVyZo6de?1-&B~Aegdzg!SCA(10w8p(HUpb&mwy{FNLG zEdiIEcRb_FF9|T}lt{H@ZE`^L4MpV1_*i`ZcV^D3c>vY-_hTVjAwGl@ef9-uk5>QC z6TV`~WGsZ3N5kr)jeuXi?DEZiTA(Ka)FutwYc746R~v_w@-xl)568cBKEi-z@~7wt z6oEM3U~JWTy4D-O=U5(tFf==N7|5c&ggg!VBreW4MNfE(DbpyNp)k%39t4aAYXjud zapYOl88q3-d+T|CCo(}uoqag%fv*!3oO-9j7Nx!3C@w0@J|(h#?HW_af2y`0oxXPB zsqq~Cm5kH9%hVh$gBU~f^84i?BxFzZ27|4 zxcVlZPO8O^-YdxQBWJaWPW_o{!2Vk<;%a_NRC&aW>f?^ed&`b`_vesWte8G#7gh#bk7Od_!9uKO1}J65$XtJS~&D2K_veqS0Bi)st-O* zruyBcn9Nm)q7JLYeh0e>-7@<5q!%9zQjNs-5taJogclQC;p0)|ZgSP)2#oeeD}@;E zFVwgHKb2Rvd8C?fs+<>4Oaz6TT2Z!T%d^>xPHT1i$~((#&}3aog=BCgmS7&KCG~ud zWu4+Dk_jpFU0>~daz4aI7q|d188|Iby;JOXpvH}v$N4I;N$E?F*mi(hw%sWoQ>e$a zWcVA_L`eGR;CyD271_Fo6ox&;O>0bnX+_6Ne-$Tw0Alup1(6-jQ1`(N{)hlc7y_;0 zYvEWh)bCgDzRdOmEY3iR=1LsxSU1_jHMmIQLMk&K?f;AdGmNCTuyAl?FMPs zKWhG8uSwuKfikdves-LyY=wNo1MVr^?i;NUKRPEj&c8r{A->a2hy~7f(ag(gb>CMG zOgIM_C~*l&aewP};RrbB2|q~MnQCTrT+9kH3B=p!3aM|pw##^{3`cxEt!s(G++5hp%K>?9+{mVb2t z+IhIqgBN$3)8;^6)~`d2;<)`R)a}AJNJ_8(?3DBr;-#BEzyBx zYUvyhU|(c^_2ocQ^uAz!$oasqDY{Nk12zTHAYhH?$Iy}bML-A_kuRGU&x-pbU}=|S zYTY^JA04XVAh2!Vq8MrxCk_Vr4Z`Q-Wd66G*@B@@B#G8#Gs=6VQT*_8vn>XJtBMlns;P@q<_t|d z1GNor>d3H?cf2(ZGC|#n?G8{t3futL9P_||KnDWky%Xtwt;5!@Nq{T_vtuZsLj@H4 zRRJEz@40YXHr&VY8xM42vH7dT>zHs2!Z*1<8Cg#ss;N7kYgN{mW|9F(7l60?O@^BI z7=kFXnD|I!Dop*5g0@0F5&-+LL0j0_A@$F1vj5UbqcLha+7L$j z9TMal#;;X%%?8fNfEmZRA12vhcnSu);UqGZ#gEQ+& zu>7>}6ct9j&<2=%XL1VKwz&aDj(p?t@{S{?iSchi*J0+*5o5;6>Q^B*d$G%}-q1z= zly?OxrOSZT`|8A$iooDY=e!h7>nSlnlXun>SKy4R_u~Rxq1gfI`rk2kbDm> zMG@IL?hpS)76;qmPj;5Ad`t+L347l(6d6{lU3+?iXKs#NcK(0hQUON{oP*RM)9o?l_S1^1|~fs$Uu z{o0NN`QQ)oR-rii;bmR1`@dbT3R=w_{ki@&^eb?m=PDO#HdCBFHp|N*g)hJtV=dfK z6j$6;<<*aUHO`w;xp2Ll-FK;l7F>@ba`taQ-aGH+XJSi8ky%V2r#N)BMLKK-n@~mc z8il-QN)6$JrC|&`*#exjCHbK`#Z&C_r-H=DEE%VKL> z)wmZLw?QYG5B7gsO8?+mQ2+J0f&;_W-#1|-xaL&MzqU!xb1HphXV$q)zaPzFl*ia5 z>dl;g7xHQ~SXg$$NQou!Q!0yXq#6hO zm|W9KFd-^<_6@iVJ7}^2t*cC#c1)RZGHPQoY63pkDscJ+4W5L^4j5*M9ZPgtA0tX~ zXK2BXw1#bkXCBX)svDDhYno0bIoK;CD{&4!TIWTer#5*WQOCy+(ZNR!QH5dh)+q08 zkd%|q5jR5HjG8ipN@yxOzcZDVn!ALv_B25UBm9i%VnITMo}`$T`|peCTC|&~6)Sc9ZPd zV?45W*440bh}<_Ihi(JzU2kvT;}mLwrI~8PLn6@B~|)rlEDo9riLy zCBpA{hCKPTGW!gDHHLg|9~c&^+k-?`E4Af20)W$3E4N%7XB00Gs&UdpHs5;2gwMHP zXq{1Gpjp0zABsnp`{7b?kaq>VZRYBoFuW^*d{%K#O>Mn$KM)|XMVr0TTmdTlzb1e# zEak`YFNzWfFX5ZXueXgYPmlH^Uc?uA3VNtdG{C^Zx3?x zKW!AmQ)lPQ$7$ioe@+19wbtrB9$#;HlNaY*SUV=2!2^2OBfCcYNQR7zfF!~JW&|x6 zNB?;i;W$~8M|@b%wwJK`{7*-vF8{@ub{m1H)H2(l4lgymXZ5ToQIT$cmqWFBe9V%u z_J)l($74Sip_a7@_1U>+zVEkOO*Y7Hq$}u#$T565-l?MP@wlICeNAxZCUaTd-mY|d z%?}Az>A!1xi)zW1ZNg9~I%PC75Swl{6nT_bwx>ZCDwx7%?-9hN`z_%TB8t(#wfJ;x zT`&61g^?6*tcMzri-C?WUA~ikrTiK#-z|45Z*~333EmL@_>Kr+;hW)TQ+R6-n_nRb z-G2GGw?Us55v<>ro6~`p_EvC{`I%1Oz%->A{bz+=LPXB2GvW%=5e8HJ?PmF<~`Qv9bmGWaC0K`E(QdTc>{mu;U$Q+^a_({8@V#L< zvnxOIzUs}d^nbxg>K&JuHlNY&td#5pSKSI^<5ILsOc}{Djv0(Xybc#t8y`|RRC(V(%#5Y0}>cev>;RlE1q0ztaz@NOV%EP?-&oKW7_Uo*E delta 12341 zcmZ8{by!s26F0HQA|N0oUD72jk}Dz|BHi8HAzWM#mF|vJx|NnxQc@ae>F)0Lu72P5 z`8_ZHaPK{HK4)gm#Mv`bZ98rAMHL+&lD<3>nbG`JllHB~>#eRoQ5EO#hDl-&Kj1{|?gP^$(-Lqafo*>H5jUFVgRkm&+QBql#f;tND1Ixi11 zV_kg0pktVO?di4^9$)+Q7j8^yxX2ITDtvUf?vJ71u9Y2yI4mE>qU+^f=i|&P?|*+t z6Oz!`;u`q+?h$^x{JziNyof}R=nTu91K!I9D4CvLLj}#WQb2%z?Bu~D1yr7KU39&h z8jlsPY@KGs;cE5}z*ryIoiJPLN%Ol(CQsjai%^H}c5u5~$(?qxPd7v@kAIsx^4$io zAh;x;Y)+qVC#U0gl7P-GpDXFFNB?~;N0`kyON5u+d^^K{7NLWLYuT%h3mFSogGAeX98*K4-q%>LShfBka*oeBq3S6692$AIsm8EI-j^eg!(b`vK&aG zdCv!G;21h}W_I)sJW_Ohrm0epR+6z(xg8yj3JBs`+2!cO5M10ia{P35l zA8W8XD0dD0UvS8Lm=RxJ=+ku2jvh85SXHzM{({3vt9p|(+mWIsAdUcp4EJ*j-;qGX zYULZq9@HKJ5y+a(TA+Fx0Wt+22=e^xAoo{#EI~Zo!DG0<+oun~ef({BJ?t|655*WG zv}tdw5^?|7vBa*#`jC zLWe&p>Ko80f<^%v2qYErhOhDG)L;L9Xie?DBQX9CP}1+<&U?f;2yt1e7BLds*$%zwnEZ`93nn3bX|}?lYhedPwv{%p2UWU)pG(O=wdeM|=e| z{~CS5ci)3r&WdOM0GX_(ol5`NIV#qrTYT@~KW>1QBni|OEtiyLl?v`aAUmkhl#0VaaonJ*mR#nM9OyGRGr$3w#UiwxYdbQb zjhy;$yD#d^E6d7p7qnGaR%4np<-iL{80G_pW&L7IQ4y~Pr+(>yP3H^6I-u1C6CCGM zy_g%Y2eu|DR$KHqG7*eQkvv%KF;E8U%qpchE-1U_p2wr9?1hz-RLoH3^}Bk$kJ;%* z7xvRjp-(SZc^7fa9vR_l{fSFyj+`N0mxcK2w8FkP4L*{(TZ?hEG92wUUgl+ zm-92F4M+Ip>>PTU7-S`BD(D7ryd$jodD&q#P<}Hp7`D_Ynwh;#X?M^xwu2S?1fB`i zV{_VbT$>Y4E$-XzPOKs^vf^Ul#JiNE>6Q9PlTtHqRJ+c7lcw+Jv#M@$<7xB{9>xlPEjSMS zDKnlws$Doq;s#@FIxiMPk{9ZR}ee)ojj)jKEJFzr}c@?;5HqHDa(4Q>)YsWxDr#1K1XK5R@5*V*dQSJwHh(D z2HW!qhe7At#XgBvQK{&Y{w%Ebin)hJ;41hKelN5MqqK%}e#dQ#;r!{a*qTj46}&H| zUonznhcK?%#~K$(&N4uJ>`k~Ob5|OAs>qpaaEIg55*V$Oqcne7%zcuM0YmTj1~020 zI6UPutv=K*%T5&HfPj&y8t@rxSk*epBdfceyol~lg5p91UgnpViUC9IsDSn~{Ewun z6y;a%12V76ks&bNkFCJwDIIJ^Fp~10`kydD<#X#r*N;&qVkcxWnQu10vrfXM@4?O? zhyD4|&sq*qzYpNCMV(>&lPoqSUQ(_^1}-F5Edo)lTvaw1u3Z8sE6`e_sK;Sud^XT) zh3KC#LaIVa!8H8xL!~X6^H6(p7w0pN52!HQeShpQ`6X1{VO;xuuyht!%i(@1|mn4Stbm@~$M! znj{H2&c6rdY8sfto~12&aT;K}d9jTK0df~*2D^57Dq}D>y^?*NU4hyRL=p)wv7qv_=c_-T)pmW66Z z)Oza1GUKk+(F;4}mP7B$+ihy!S0h7>n|q*eQ$B+MmJz~J?ADi+Z+?Whz0v}>dhJ~V z@}Gd5_8T_ZfZC!y3K3@JO*_P(aLrW;E@?`74IZsR^AHr}ylczFX?ErJI1*iRt1=!0pVL{k-2xqSi#g{FHncP*ZLI+rwU0oORLV88>|NEUTG z1_edq-N)lPl`rfS!bmZPdJFMJLV~-( zm#ISVKux`*u5v4jA*>(fA~=ReMH}FqHP+2h&bXz7>rVyI5?m(svc?u5t;^Lpo7^&_IFb&C;gu z%uUThh9T`%m6UF!5ObDyYN79ytDOy?RNxkC93hgnhx~az4QEjw4nIs&F?8v?$ zd0A%2fdW@691fEh)jvxDrRJsx?*#PkyQ!Hjy>{(s9xV& zHMp~loK6_7tP3Ou5k5AtnJO97;;~+Tc)Kb(1?1!>3Gq`xd5rQ)S=av$4DnErFG(f&K$8gH>r6O4*=-LuiWw3Y zLPg=u7~R2%8!^E5+|XC8(nSY2u$_Z|Q7_a-RjZP=C0yTTr$o1^!B@T}r|R%q1lecF zLE1?l8|SX1>n5S7@qM=Csz)fT)Lz>iaBeakzh@L{Cyicgpo9YYKQ| zR^!1-ZKO~BMXhX}ajWiVCYaT@$Um)F3jXRUjK<`QcuL+bqmwUz?WU&No^MZ(N84Vr zoOm+Tf1$uCSX8?Y{xVeiM0zJZK`VYCjnjL)c2MF%%9!g`bdcMfUme1!mqa~VjStra z$ZlWtMEdZ=^FPbEVG_Q(Q391y3JxuC7zXTn{tOPd zmpGAx?vebSL)c4gYG`-CPSoy_#sV#okCiJ0Z#G!bVi^p1>hF6uW4MyzC1K10ToPAO zzRc@xPn8Ba)$$JatBB4=J+r_QwzuSb7-&EDD72o$6QdGjh;F<-TN>4za~fLC!$LcaMU^C34>?4pVQ+MN%>WF$Ef)uDkOdf%ll7pV7ReD?UEIvDGf zS6#|FW-YM6DJ8TL?h)&I>MB7bkg`MUu8t3%yLz$`$Twl&aES3ai=NiB(rLV7qRCbZ4UEUL{uKAjaqA(Gn{@|hRj^M!eq zOgAK`1c}30;{B;Y4ytc5Qu~#jG4R2zlwZ3U&(BQ0zLSUFBRt{DCHN&SB%jJE@!z?~ zm${Gw?^4G5#OUTCFHfSF9gUuv*-b0w*Q19{}j5VhNV!rvap1db3YB$6M#ou)Y z3k|3NyDKL%2Nw#wsg+*aNZ+yak4lsJYrKcoXN0t)$N2P z@y$v&4VPe1hU!Y89JAra`E}BgJssgHhs=3NUZ0P1mTuY<2NQPRqQ9&5j5#|Vo8WNj zMT0d+kV`J^?hpjbvo+0nU%viHPb+;PoMPh$@Vr;lY|pXy8m9IvxsijH59ZborFtn> z>v5?vBh@)oAvs8bn|9*uEwqA2`E~Bs<$U?Nj-EC&xiAi$bfj0MNhWRftJxXho-Vn> z5tQ{}ua2~R<8gw^M4-6d@UxmBYGa*5%#*8G=j$H5@Ei$gHZ-+@55in>1a2==IV_#y zfDhuKZ|06aXd4ERh!cqXIzOo-hBv#kl}==M-TkzU7u{clVW(bRO!VwU7u^BEu+TtI z^O?jY$rjsBF4hd*IxugvZ;$&j>lHZY(60YT%r$e=ynPj*`=p>dSw4HUsp&jd$Qn59 zebf{d09A!7r|b2#C-d@j^iqEzJU&YUmYhW851HM0wAn{u4c{F9TDzQG@$scER%@PR zU$0u@m-zO|>N3uWAUe*+k%wW%wCp!MBH03*yZLFdtt^qIWnJi}ww@;RnJ?Kz@fE|= zo)3mY_P5UO#jk$+LSNE`w6m{DQ}ehS;8|P^fF_%&FI8`x1+JHv3Q37RPufr z9Z*$Id^lN#;dNU3_vUnAI*~=u(=xkN67!^acMv%>akV@FW5o{{^Ved84_OnT_0nYT zl4u%c?g+x1$}V*``Z8gW!{!E%W%J!o9G$*S0xU-!4E6{@=yt&3NLyEkgzZa^L*3u1 z!dpVGZmo#t8|!)$tYY6o60`s-B#V~bFH9@w^UkxCuUo&6wz$k;=2cmAmkzLtzpj~1 zv(ta&dx+pXVs8ncFF4N6hyLXDUBbq<7}e{kYkx`baY@ab2cv;I7cG{%%OOV4 zo$@&J@>KTMQkn*7iTl}NR+i?*Sh*=$qn)V@0sgP23&Hn#3TnfNztt2Lm$WJla+4b# z9hW?F%WP(CJaRE}(4n`6<(zf9C8_V8)nQQ8RxO56q?O|=S7{QX9)#-5^971&)oIN2 z2c;l_;u*D*YMLb@-GMCA5>C62>FQ_e{)c?aY;)V*1oI0bGBi=jWu1<0$J zr;BbeHOaqcTCKLb{V-uF5W#NNioI(6g)MG;(b`U+F6_{nC!cwS2EV+ptKXs#bT&(*~l4xU6;0A;$2w=jd-r>-J4*Q`*+(X zV|fx0M5r4HZ}MPl7jgRD2#=YW$!w@UO2du`)A~iXD@}91a_q!9&1F7i!*s=M>y~}& z-t~f*MBH%L7?3&gF^BcmZ@DuxkTNQS9VL3qmHm5$WBKpl_?wdX1E+UBy6?AFI8T8)<|9&Cch+LEo=misvlIJcd)&xl% ze4#g!BVdYKy+2jtCAeaEO}K)Q(qj85<91XFlA{V_=rxyZvK3ZxIQ=4RB z>|Ngf_zDj~5Jrr(n(-AMy(d}mQPvqWu@E?LO|>fxe&kMozk|B%_gIM2AZ(Mpp*vf) zm_$Pcth{bXR--a`;{4B15FEeN zNjV$g?zyw7n-T>Rs0s_{i>Pf)LeUD2l%M_Eiwu?S?T*eA{w8T7czAXq&gm7qySo*4 zJIaBkW`lASbIrM1-b07QBS8N!wlf#Vu_*Z+OM3o9N^8agQ(0UelN1sB2@#={AU5q9 zvx>Uax~nZ*vOpJ+A@9ILG%DclOdv;g$z8!bAhuEGN`UWy;&)hzCwg)nMphUX7q@8F z(8Bh5wq^bqJMD3F>$7CuJKALvChK1!y_sU}?^aRK-*;=-lu{4=E*vH4<+02KmR=_1 zwL4AaT^N;-kqu`$(h^y(I#xUv7@C2be<97?&e|#Mh z(w{l5$fQc0D4H#BnVllY2*Dg3L$&gMZSsWt8DFqtz3DVPGDZ|5YjZRAU!HzpposgN6| z;W?Au$0;?HnpV7iWxy5J#qg2J^m5O9f|{CLoR_d_dHy8#@{ARo(r84~H_A`?;GIYD zuDWB`hRSuMU|~Z*U3Kw~G;B$sK8SzCc)G^fs2bCrEw(ScVv3NDS3{9V!n7&tx?ap4 z%My$)8(mwPL>rY4CejBa2sz2_T@uFQkTU@No%y!g>b7ASh}^=YWgknA0P<`zMjK2xF^4A`;KV|=ZaSoBq6A1UX34B zee_C2*3&$3?W0%5V=dp}O_D>j@$X#y$FgP{f!F(n*sMelkK8VQjf?8Do_LIH<77%rJ&`bYT91qW`dP7lR9&c?Z z3F`yECK>A)^TI}ja_51xfz@V9M8D)9?yKfF*4~M*Bvv_x@^VY)AXY=xc?RL;;~Czw z15C#qUB6{d1_vF^0(P-exA~j+`*!S&1UB}#P<%=b%rMFTht0s=OO=30Z7Ta>3^6yU zs8IA=_WSZR)v|5+f}X}xE{qQtm5bD8zQiJc9K_iR%+VDh45%(agkLI+M&_~>fAzGA zW+%#McGIHwGfMMQ{XvIr&aLXSrHqAJyFD!3 zwbSmPqU%3ttQg~TeIG8rPxHPSRI$U=tKkx>FBbVyD#pv-u-5FOn(#XN)^oH`GEf2t zCVNHWt;cl#Sz|u0lYi23ckk6VAJuQ9dmRbXR=0<|2;SE40=z~}LX4e1I%IEl?>#ro zqM#Qb%NNM~6@>_Hq#_&CmHQ4|1c~ZEqKt>0z@#tlR{|lYfQoSga?A_j_-)&?qHDB!xLPp&5rr1_m3V{_263>Q`=)C@GAt}n@rS!H(%AhMjbOnU>7MqcHj?JrL%%sm?E2JT$OmSGyrd%-^#694GK@ZQUaryOl(1nCLNH(m@S%s=9^ zKbknX2@ql|n{C-gK_T#vdjV7DQbk?6|4g6+76$X;n6cKp%i}+Zby9prtm;yR5RriH zb1{PItl)61-n9;-`He+BSE9prmZ!sK=I}N1>&xDtqHXJ-9}Jdlfa2h!_#?ZpZwS=m z#ir}IJKu4f`Dzb3IP{8YL9;flI`iB5jX2to$yZr@i!3L## zdZg__9#|qKns21{ZqpYCIY=Qz80^RPqlDZxJMi9+XAzC@|oV5a8zAXD3`WdnW`#aC;PXoi z#(Wtgi;~T6ac>cTy89ZecSv`d0&)*x(Hfdpe)NFu#ao2^Z>lJ)ta|WvH5}ZYNWACO z&S1%yt@9AE5})HKS-t-UtkdG0E%tgB>eR?tx#EL2k2dhnx^)l0i_0SjW6Nnh!B}e$ zcw5AiiK)SwK1>C^p}~2X(Et9gSiLD=Y?OjBg7tr5w?hP50SPq@2qA~`O@=Fz!V5_d zUvay`&n357s(K#9=u5DDSEM4u)3BHB-9T?uf43}v8 zoS_Qp#)JW2VXZ$oq)Fi?(goEU4gu+uK)PaZR#vC+zN`gpfh^@Z+;$-$5b@l_*ZpD9 zJ1y`Q)g%U!vnyfl{#dI&sF`GNi{`@gd#c2KAm2_Fo3>%q&NLv-I6QVK=)GCt1uyur z3TGQ@ZLyfmD*%_;28Ah?`3&gRVM5uM?xd=n@$l7E19rrQ$nHK7fz)~6RZb_-{5$bg- zuwGU$x@CFcG=jL^r;EKm!v_|q(3rtB2_PPh$R(tqux@U#3>{8NxY|N0(zr&K@b?}) zMS)4()AHT+oa6a|2@k=i_^fy_ai0~Oxa*@zjH!tY;-7;;+}7Wczt=#%wXb*h0WSJ~ zFfj7I*`ZPcyu--1#Q6M=yTflk zctOKKHX)!4PxFuh)2mUdGq&{3Q@!HUr-f;q*z!8(pIz9>nbceADerao35yACJlT8n zh&B@O?_l`}@cKS*{gc#!AKOk+mAmX%)95hrhi^N9`=2Mz2daI)SGuhk-#NerdFR6V z7OCJXP=<9mn~#kdljD^__91sQlv$V>lZ07nJtFtQ2wo0~+N3oa;IDo=+u#-K6!I>b{9aesME5!>$$5Hxyl9{+RNGLNS?y)PluhU z4f+9a|MFgG{LwZ9PjGyDetp)OtW(eQ^iox15JH0`b*jH+thIx{U8>(l&nfh&tn6z0 z=V5kw8l5aPv)pkPeD$EdWEJoC#srH{dCgNtUhQvV!UoTz2Kt-%uY1k}@XWXhzJqp* zmnP9G0-t1sjPRT;M{e-L=SYVttJXmp4P!h+BQbTpOXS{b(CwbnBg1cXj2F}r4d&3L zsfV<&)1@Rsp{e}8Q`wLX#VYok%Mt+n?^7J6M)!vsAl(bf1jevnbue7xzES{Xc>o4~ z+57U%d*)F;7{F)i`|`KsLwjCxJjo~^2c|xQuJW&^{o6$DElH|URQBB)Yo#m5n4Dx< z#*9J&CxOv$T;hUzj^_~=Vz4?yt%W;AxUqL^7eKHNe_d*>T?E1a($aAOEEgO(|K@SA z2**EVb;mA)fgqq?3GJnn7L8!b`6#laM(Isj(Ty+^6w z@+=9_;7fX)uQdyo03ImK8}2y;8{4ZUFb-3Lag+=G@X!+a*9Es3ST5>4e*Sg9=Ms28 zk(zVIIesy68R?;_USOF@N>x%dKZfjvXAd6^cA9;a0naXOiYx}|;Km4o=R3-EQ3m%! zWVo;&4Lfu7bzevNrusH>fg0yE`y3Ah3Wj+pFmewad(6>+X)V_@AI#Ug=Yz@nSg?$q z16Z5XCvZnRI6l4N1i&EjRS(Pwxt5cSQV7uFej{{uN--E8Gx+lD;e%~(w=Hvi?R2B=I`PzZ#zXo?t{xk{zNVpMO^e3 zD&Fu7*;cmU3Kbk#9vp!%B6C=<7tRWj5+ICEue&5SDMFh4KzC5$>wlT7QBoDrp%-K4 z{r(Rs98JlyN}2fcU$g>{dnfLwN+ga*n3C|3`GZJ$?tl6fV3=FHBdLK=igoF553RQNSe~|)dRGaPoSfS zIlMksLhe91(h|kJ&uJQ`Lcq5fFlxk3-RdbTf&AjDub%w$>dl;E@8(~>C85K7yhTWf z>@L*!JwQubEU1kiP^X4-Mn8+g&2iD6=V!z128EQ%?|G{ zue>6u;-8l;Q;x>yC-ZlC?~~|xK*s`2?t7H0TX%@NNxxNKm&koh84pRJwoe--96Q7$Pc;%Q3$P44M>w* zfZ!QD`x+PMn?HjzUy$&hpy}|c5%AlOUyhO|M%KSa(8`*_Fb&VvHa@gfASmwfZ={>p z*x?gFROIBlZboirWmM!M8SwBj#|5mc~xLKbs#tlWv(EOVD zY@sKb@c0K=_(#X7kKDMrZVwQvMB{*4g2-tK9j*c_rR|2f`Ob0x^@X-hb0il2s61_f z32i}wq-q=3IQSM3@)n_q2E#>%l|ta;_u#r1c!fqA>)`n{jyM0yqSR2v&3yoFG$3%GR5RX3Ir2tO)e0i zZ2U{`WP*DOvAi&!YYfHq5HKglf0is)=qlRYhyHnLidUuaFNiYwccsg2<|61lArWdsR2~Nub=*Fxtc8!5k=eoqWkPSFWMplOH@nX z$KR@hgeD3rz|QPW(JlyYUB>IerT47$e+X20t#RlW4+_aeDA9h#%*EH%cJbf_o(|f#sjgqVNLcBsew^Ke3H5!!R2BWVn5+0k-l!l|ZyQ7peP$1HX_EhL< zc%OaVic&HKF>{NSch5ut_SQczZiq(~>|-VY3J5F}s0CR?#J6mt@AS3m46gMB`>MUPyoLyD~3Io5H1nT zIaQ7)z77af)BiT_{Y$TZtvk&wuDkJTuz6Qp>$!jCgh+E6*Jd;toE%0Rf1Vib&k37! zbUZf5lFKC3r`T-S^%1OGA?@O`YXRiNp?BwhzEE@%@-@+<_^^k0OW{LpAx_L2ug)Ub z)<^Z0`)ORb@xeBuO}WY@r;I&T8X*6AImUPRPd2kDo}ZD?!=kN6I$+xsyf$w6B1IE} z>WS8z;v?lAh*;ffR&~?X;B`|+vEH50xx!)P5zv#B1nh@}#!t+be++130`Nzn0RfBL ze(BK`N_a`wY;I9j1VJ~$FMY0LUq?k;l>UlWEI07m^m$(MZj+Zs6CD=uM`rLAuYh&9 zn!Q{j@j{y;Lt{>djVh^jPeGzCDs7)PW!`43jB6wKjdpgt#h*{;AZIi%=5DdfJ;82w z^2Uub+~K4{h1!n#`HSajK*a^#xJdanSPqB}zrv%7ilBR3Ox#;11qGEL0dJleyLxf) zQ39~IwxgNRTax}2OEDp6aQ>skR$?)r_RjaY;Rn51x&Q(?FBN)8?7wrUi~MJf+Wm2T zZGF35iY0W!#xn{H4D1YkneOe067QyFaniTp8N%z)$}yNX7bo?QMTM0bFMp<$*jG~j z!1dBz7=QG>_}=FIU34#T8ztILc#!Jglpi;yG>Yw|-V&0k3M|4DqYEAHNID2E<4hnb bBzH6&b;cwfuSw=nz&|-@ + %\VignetteIndexEntry{Working with Groups} + %\VignetteEngine{knitr::knitr} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +```{r setup} +## Install extra packages (if needed) +# install.packages("folio") + +library(nexus) +``` + +Provenance studies typically rely on two approaches, which can be used together: + +* Identification of groups among the artifacts being studied, based on mineralogical or geochemical criteria (*clustering*). +* Comparison with so-called reference groups, i.e. known geological sources or archaeological contexts (*classification*). + +When coercing a `data.frame` to a `CompositionMatrix` object, **nexus** allows to specify whether an observation belongs to a specific group (or not): + +```{r} +## Data from Wood and Liu 2023 +data("bronze", package = "folio") + +## Use the third column (dynasties) for grouping +coda <- as_composition(bronze, groups = 3) +``` + +`groups(x)` and `groups(x) <- value` allow to retrieve or set groups of an existing `CompositionMatrix`. Missing values (`NA`) or empty strings can be used to specify that a sample does not belong to any group. + +Once groups have been defined, they can be used by further methods (e.g. plotting). +Note that for better readability, you can `select` only some of the parts (e.g. major elements): + +```{r barplot, fig.width=7, fig.height=7, out.width='100%'} +## Select major elements +major <- coda[, is_element_major(coda)] + +## Compositional bar plot +barplot(major, order_rows = "Cu", space = 0) +``` + +```{r mean, eval=FALSE} +## Compositional mean by artefact +coda <- condense(coda, by = list(bronze$dynasty, bronze$reference)) +``` + +# Multivariate Analysis +## Log-Ratio Analysis + +```{r pca, fig.width=7, fig.height=7, out.width='50%', fig.show='hold'} +## CLR +clr <- transform_clr(coda, weights = TRUE) + +## PCA +lra <- pca(clr) + +## Visualize results +viz_individuals(lra, color = c("#004488", "#DDAA33", "#BB5566")) +viz_hull(x = lra, border = c("#004488", "#DDAA33", "#BB5566")) + +viz_variables(lra) +``` + +# References + +Aitchison, J. (1986). *The Statistical Analysis of Compositional Data. Monographs on Statistics and Applied Probability*. Londres, UK ; New York, USA: Chapman and Hall. + +Egozcue, J. J., Pawlowsky-Glahn, V., Mateu-Figueras, G. and Barceló-Vidal, C. (2003). Isometric Logratio Transformations for Compositional Data Analysis. *Mathematical Geology*, 35(3): 279-300. DOI: [10.1023/A:1023818214614](https://doi.org/10.1023/A:1023818214614). + +Greenacre, M. (2021). Compositional Data Analysis. *Annual Review of Statistics and Its Application*, 8(1): 271-299. DOI: [10.1146/annurev-statistics-042720-124436](https://doi.org/10.1146/annurev-statistics-042720-124436). + +Hron, K., Filzmoser, P., de Caritat, P., Fišerová, E. and Gardlo, A. (2017). Weighted Pivot Coordinates for Compositional Data and Their Application to Geochemical Mapping. *Mathematical Geosciences*, 49(6): 797-814. DOI : [10.1007/s11004-017-9684-z](https://doi.org/10.1007/s11004-017-9684-z). + +Weigand, P. C., Harbottle, G. and Sayre, E. (1977). Turquoise Sources and Source Analysisis: Mesoamerica and the Southwestern U.S.A. In J. Ericson & T. K. Earle (Eds.), *Exchange Systems in Prehistory*, 15-34. New York, NY: Academic Press. diff --git a/vignettes/nexus.Rmd b/vignettes/nexus.Rmd index 92e267c..d8d99e5 100644 --- a/vignettes/nexus.Rmd +++ b/vignettes/nexus.Rmd @@ -66,7 +66,7 @@ counts <- as_amounts(coda) all.equal(hongite, as.data.frame(counts)) ``` -The `parts` argument of the function `as_composition()` is used to define the columns to be used as the compositional part. If `parts` is `NULL` (the default), all non-integer numeric columns (i.e. of type `double`) are used. In the case of a `data.frame` coercion, additional columns are removed. +The `parts` argument of the function `as_composition()` is used to define the columns to be used as the compositional part. If `parts` is `NULL` (the default), all `numeric` columns are used. In the case of a `data.frame` coercion, additional columns are removed. ```{r} ## Create a data.frame @@ -82,40 +82,6 @@ X <- data.frame( Y <- as_composition(X) ``` -# Working with (reference) groups - -Provenance studies typically rely on two approaches, which can be used together: - -* Identification of groups among the artifacts being studied, based on mineralogical or geochemical criteria (*clustering*). -* Comparison with so-called reference groups, i.e. known geological sources or archaeological contexts (*classification*). - -When coercing a `data.frame` to a `CompositionMatrix` object, **nexus** allows to specify whether an observation belongs to a specific group (or not): - -```{r} -## Data from Wood and Liu 2023 -data("bronze", package = "folio") - -## Use the third column (dynasties) for grouping -coda <- as_composition(bronze, groups = 3) -``` - -`groups(x)` and `groups(x) <- value` allow to retrieve or set groups of an existing `CompositionMatrix`. Missing values (`NA`) or empty strings can be used to specify that a sample does not belong to any group. - -Once groups have been defined, they can be used by further methods (e.g. plotting). -Note that for better readability, you can `select` only some of the parts (e.g. major elements): - -```{r barplot, fig.width=7, fig.height=7, out.width='100%'} -## Compositional bar plot -barplot(coda, select = is_element_major(coda), order_rows = "Cu", space = 0) -``` - -# Descriptive statistics - -```{r mean, eval=FALSE} -## Compositional mean by artefact -coda <- condense(coda, by = list(bronze$dynasty, bronze$reference)) -``` - # Log-ratio transformations The package provides the following (inverse) transformations: centered log ratio (*CLR*, Aitchison 1986), additive log ratio (*ALR*, Aitchison 1986), isometric log ratio (*ILR*, Egozcue et al. 2003) and pivot log-ratio (*PLR*, Hron et al. 2017). @@ -130,64 +96,6 @@ back <- transform_inverse(clr) all.equal(back, coda) ``` -# Multivariate Analysis - -```{r} -## Assume that about a third of the samples does not belong to any group -grp <- groups(coda) -grp[sample(length(grp), size = 100)] <- NA - -## Set groups -groups(coda) <- grp - -## Retrieve groups -# groups(coda) -``` - -## Log-Ratio Analysis - -```{r pca, fig.width=7, fig.height=7, out.width='50%', fig.show='hold'} -## CLR -clr <- transform_clr(coda, weights = TRUE) - -## PCA -lra <- pca(clr) - -## Visualize results -viz_individuals(lra, color = c("#004488", "#DDAA33", "#BB5566")) -viz_hull(x = lra, border = c("#004488", "#DDAA33", "#BB5566")) - -viz_variables(lra) -``` - -## MANOVA - -The log-transformed data can be assigned to a new column, allowing us to keep working with the data in the context of the original `data.frame`: - -```{r manova} -## ILR -ilr <- transform_ilr(coda) - -bronze$ilr <- ilr - -## MANOVA -fit <- manova(ilr ~ groups(ilr), data = bronze) -summary(fit) -``` - -The MANOVA results suggest that there are statistically significant differences between groups. - -## Linear Discriminant Analysis - -```{r lda, fig.width=7, fig.height=7, out.width='100%'} -## LDA -discr <- MASS::lda(groups(ilr) ~ ilr, data = bronze) -plot(discr) - -## Back transform results -transform_inverse(discr$means, origin = ilr) -``` - # References Aitchison, J. (1986). *The Statistical Analysis of Compositional Data. Monographs on Statistics and Applied Probability*. Londres, UK ; New York, USA: Chapman and Hall.