From 89a005fa650718e720e893768e83c974b3cd5ede Mon Sep 17 00:00:00 2001 From: thomaz Date: Thu, 16 Jul 2026 10:24:58 +0200 Subject: [PATCH 1/4] Improve docs --- DESCRIPTION | 1 + R/AllGenerics.R | 44 ++++++++++++++----- R/LinkMap-methods.R | 6 +++ R/data.R | 2 + R/select_path.R | 23 ++++++---- R/stack.R | 15 +++---- R/weave.R | 5 +-- man/{as.LinkMap-generic.Rd => as.LinkMap.Rd} | 3 ++ ...ltiFactor-generic.Rd => as.MultiFactor.Rd} | 5 ++- man/as.data.frame.LinkMap.Rd | 4 ++ man/as.matrix.LinkMap.Rd | 5 +++ man/{nlevels-generic.Rd => nlevels.Rd} | 0 man/select_path-generic.Rd | 33 ++++++++++++++ man/{select_path.Rd => select_path-method.Rd} | 22 +++------- ...{stack.MultiFactor.Rd => stack-methods.Rd} | 18 ++++---- man/weave-generic.Rd | 14 +++--- man/weave-methods.Rd | 3 +- 17 files changed, 136 insertions(+), 67 deletions(-) rename man/{as.LinkMap-generic.Rd => as.LinkMap.Rd} (93%) rename man/{as.MultiFactor-generic.Rd => as.MultiFactor.Rd} (88%) rename man/{nlevels-generic.Rd => nlevels.Rd} (100%) create mode 100644 man/select_path-generic.Rd rename man/{select_path.Rd => select_path-method.Rd} (77%) rename man/{stack.MultiFactor.Rd => stack-methods.Rd} (71%) diff --git a/DESCRIPTION b/DESCRIPTION index 74771a4..ea0ee1f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,6 +29,7 @@ Suggests: ggplot2, ragg, systemfonts, + doclisting, knitr, rmarkdown, testthat (>= 3.0.0) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 1ac1f40..2053599 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -1,10 +1,11 @@ #' Convert common classes to LinkMap #' @export -#' @rdname as.LinkMap-generic +#' @rdname as.LinkMap #' @name as.LinkMap #' @param x input object #' @param ... additional arguments #' @seealso [as.LinkMap-methods] +#' @returns a `LinkMap` #' @examples #' # Available methods: #' as.LinkMap @@ -13,7 +14,7 @@ as.LinkMap <- S7::new_generic("as.LinkMap", "x") #' The Number of Levels of an Object #' @name nlevels -#' @rdname nlevels-generic +#' @rdname nlevels #' @description #' Return the number of levels which its argument has. Extends `base::nlevels`. #' @param x an object, such as a `LinkMap`, `MultiFactor` or `factor`. @@ -31,11 +32,12 @@ S7::method(nlevels, S7::class_any) <- base::nlevels #' Convert common classes to MultiFactor #' @export -#' @rdname as.MultiFactor-generic +#' @rdname as.MultiFactor #' @name as.MultiFactor #' @param x input object #' @param ... additional arguments -#' @seealso [as.LinkMap-methods] +#' @returns a `MultiFactor`. +#' @seealso [as.LinkMap] #' @examples #' # Available methods: #' as.MultiFactor @@ -43,21 +45,43 @@ S7::method(nlevels, S7::class_any) <- base::nlevels #' as.MultiFactor <- S7::new_generic("as.MultiFactor", "x") -#' Convert common classes to MultiFactor -#' @export +#' Weave a path through an object #' @rdname weave-generic -#' @name weave +#' @name weave-generic +#' @description `weave()` is an S7 generic that finds a path through a +#' relational object with methods available for the following classes: +#' `r doclisting::methods_list("weave")` +#' #' @param x input object #' @param .path either a `formula` or a `character vector` of length 2 with the #' names of the desired combination of feature types. #' @param ... additional arguments #' @importFrom S7 S7_dispatch -#' @examples -#' # Available methods: -#' weave +#' @export #' weave <- S7::new_generic("weave", "x", function(x, .path, ...) { S7::S7_dispatch() }) +#' Weave a path through an object +#' @name select_path-generic +#' @rdname select_path-generic +#' @description `select_path()` is an S7 generic that finds and returns a path +#' through a relational object, with methods available for the following +#' classes: +#' `r doclisting::methods_list("select_path")` +#' @param x input object +#' @param .path either a `formula` or a `character vector` of length 2 with the +#' names of the desired combination of feature types. +#' @param ... additional arguments +#' @export +#' @importFrom S7 S7_dispatch +#' @returns a (list of) character vector(s). +#' @examples +#' # Available methods: +#' select_path +#' +select_path <- S7::new_generic("select_path", "x", function(x, .path, ...) { + S7::S7_dispatch() +}) diff --git a/R/LinkMap-methods.R b/R/LinkMap-methods.R index 73897c9..892a619 100644 --- a/R/LinkMap-methods.R +++ b/R/LinkMap-methods.R @@ -109,6 +109,9 @@ S7::method(levels, LinkMap) <- function(x) x@levels #' @returns a sparse biadjacency `Matrix` with #' @export #' @seealso [Matrix::sparseMatrix()] +#' @examples +#' x <- randomLinkMap() +#' as.matrix(x) #' `as.matrix.MultiFactor::LinkMap` <- function( x, terms = colnames(x), @@ -137,6 +140,9 @@ S7::method(levels, LinkMap) <- function(x) x@levels #' @param row.names,optional,... For compatibility, not currently used. #' @importFrom S7 S7_data #' @returns a `data.frame` +#' @examples +#' x <- randomLinkMap() +#' as.data.frame(x) #' @export #' `as.data.frame.MultiFactor::LinkMap` <- function( diff --git a/R/data.R b/R/data.R index fe75c4c..432a953 100644 --- a/R/data.R +++ b/R/data.R @@ -8,6 +8,7 @@ #' prefix. #' @source `trade_goods`: Curated using the `emo` package. #' @usage data("trade_goods", package = "MultiFactor") +#' @keywords datasets #' "trade_goods" @@ -19,5 +20,6 @@ #' vignette. #' @source `playing_cards`: Manual input. #' @usage data("playing_cards", package = "MultiFactor") +#' @keywords datasets #' "playing_cards" diff --git a/R/select_path.R b/R/select_path.R index 544d732..843de0a 100644 --- a/R/select_path.R +++ b/R/select_path.R @@ -1,11 +1,14 @@ #' Define a path through a MultiFactor object. -#' @rdname select_path -#' @name select_path -#' @inheritParams weave-methods +#' @name select_path-method +#' @rdname select_path-method +#' @param x input object +#' @param .path either a `formula` or a `character vector` of length 2 with the +#' names of the desired combination of feature types. +#' @param include,exclude,exact `Character vectors` Should feature types be +#' included or excluded from the available paths? Exact allows for exact +#' path definition. #' @param as.edges `Boolean scalar` Whether to return names of edges or nodes #' (Default) in the path. -#' @returns a list of character vectors. -#' @importFrom igraph as_ids #' @examples #' #' # Generate pair of random linkage input #' a2b <- data.frame( @@ -22,10 +25,14 @@ #' #' # Inspect a path between data types #' select_path(x, b ~ c) -#' @export #' -select_path <- function( - x, .path, include = NULL, exclude = NULL, exact = NULL, as.edges = FALSE +NULL + +#' @importFrom igraph as_ids +#' +S7::method(select_path, MultiFactor) <- function( + x, .path, ..., + include = NULL, exclude = NULL, exact = NULL, as.edges = FALSE ) { path_check <- .check_path(.path) .path_check_valid_weave(path_check) diff --git a/R/stack.R b/R/stack.R index e976cfa..105bbd7 100644 --- a/R/stack.R +++ b/R/stack.R @@ -1,9 +1,7 @@ #' Combine levels across several LinkMaps in a MultiFactor -#' @name stack -#' @rdname stack.MultiFactor -#' @description -#' Generates a new `LinkMap` object by cross-referencing the elements of a -#' given `MultiFactor`. Elements can be merged by including several names, +#' @name stack-methods +#' @rdname stack-methods +#' @description Generates a new `LinkMap` object by merging levels by name, #' separated by the plus (`+`) sign. See examples. #' @param x a `MultiFactor` #' @param .path a `formula` of length 2 with with levels to be merged separated @@ -13,22 +11,23 @@ #' @param ... Additional arguments (unused.) #' @param out.format `Character scalar`. One of `'LinkMap'`, `'matrix'`. #' @returns a `LinkMap` or `sparse Matrix`. +#' @importFrom utils stack #' @examples +#' # Only necessary in example code +#' require(utils) +#' #' x <- randomMultiFactor() #' # Merge variables with "+" operator, new names get concatenated with ".": #' stack(x, b ~ c + d) #' NULL -#' @export -#' S7::method(stack, MultiFactor) <- function( x, .path, out.format = c("LinkMap", "matrix"), ... ) `stack.MultiFactor::MultiFactor`(x, .path, out.format, ...) #' @importFrom utils stack #' @export -#' @rdname stack.MultiFactor #' `stack.MultiFactor::MultiFactor` <- function( x, .path, out.format = c("LinkMap", "matrix"), ... diff --git a/R/weave.R b/R/weave.R index d69dd77..4d1c673 100644 --- a/R/weave.R +++ b/R/weave.R @@ -3,8 +3,7 @@ #' @rdname weave-methods #' @description #' Generates a new `LinkMap` object by cross-referencing the elements of a -#' given `MultiFactor`. Elements can be merged by including several names, -#' separated by the plus (`+`) sign. See examples. +#' given `MultiFactor`. #' @param x a `MultiFactor` #' @param .path Either a `formula` or a `character vector` of length 2 with the #' names of the desired combination of feature types. @@ -23,8 +22,6 @@ #' NULL -#' @export -#' S7::method(weave, MultiFactor) <- function( x, .path, out.format = c("LinkMap", "matrix"), include = NULL, exclude = NULL, exact = NULL diff --git a/man/as.LinkMap-generic.Rd b/man/as.LinkMap.Rd similarity index 93% rename from man/as.LinkMap-generic.Rd rename to man/as.LinkMap.Rd index 5d8d887..0656115 100644 --- a/man/as.LinkMap-generic.Rd +++ b/man/as.LinkMap.Rd @@ -11,6 +11,9 @@ as.LinkMap(x, ...) \item{...}{additional arguments} } +\value{ +a \code{LinkMap} +} \description{ Convert common classes to LinkMap } diff --git a/man/as.MultiFactor-generic.Rd b/man/as.MultiFactor.Rd similarity index 88% rename from man/as.MultiFactor-generic.Rd rename to man/as.MultiFactor.Rd index a4f9301..6bed29d 100644 --- a/man/as.MultiFactor-generic.Rd +++ b/man/as.MultiFactor.Rd @@ -11,6 +11,9 @@ as.MultiFactor(x, ...) \item{...}{additional arguments} } +\value{ +a \code{MultiFactor}. +} \description{ Convert common classes to MultiFactor } @@ -21,5 +24,5 @@ as.MultiFactor } \seealso{ -\link{as.LinkMap-methods} +\link{as.LinkMap} } diff --git a/man/as.data.frame.LinkMap.Rd b/man/as.data.frame.LinkMap.Rd index 1c3a5dc..957aceb 100644 --- a/man/as.data.frame.LinkMap.Rd +++ b/man/as.data.frame.LinkMap.Rd @@ -20,3 +20,7 @@ a \code{data.frame} Convert a LinkMap to a data.frame Convert a LinkMap back to a regular data.frame. Metadata is included. } +\examples{ +x <- randomLinkMap() +as.data.frame(x) +} diff --git a/man/as.matrix.LinkMap.Rd b/man/as.matrix.LinkMap.Rd index 4f81e61..aa41edc 100644 --- a/man/as.matrix.LinkMap.Rd +++ b/man/as.matrix.LinkMap.Rd @@ -39,6 +39,11 @@ a sparse biadjacency \code{Matrix} with \description{ Convert a LinkMap to a sparse matrix. Convert a LinkMap to a sparse matrix object from the \code{Matrix} package. +} +\examples{ +x <- randomLinkMap() +as.matrix(x) + } \seealso{ \code{\link[Matrix:sparseMatrix]{Matrix::sparseMatrix()}} diff --git a/man/nlevels-generic.Rd b/man/nlevels.Rd similarity index 100% rename from man/nlevels-generic.Rd rename to man/nlevels.Rd diff --git a/man/select_path-generic.Rd b/man/select_path-generic.Rd new file mode 100644 index 0000000..a98dcb3 --- /dev/null +++ b/man/select_path-generic.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R +\name{select_path-generic} +\alias{select_path-generic} +\alias{select_path} +\title{Weave a path through an object} +\usage{ +select_path(x, .path, ...) +} +\arguments{ +\item{x}{input object} + +\item{.path}{either a \code{formula} or a \verb{character vector} of length 2 with the +names of the desired combination of feature types.} + +\item{...}{additional arguments} +} +\value{ +a (list of) character vector(s). +} +\description{ +\code{select_path()} is an S7 generic that finds and returns a path +through a relational object, with methods available for the following +classes: +\itemize{ +\item \code{MultiFactor::MultiFactor} +} +} +\examples{ +# Available methods: +select_path + +} diff --git a/man/select_path.Rd b/man/select_path-method.Rd similarity index 77% rename from man/select_path.Rd rename to man/select_path-method.Rd index 0ad24ef..931bc28 100644 --- a/man/select_path.Rd +++ b/man/select_path-method.Rd @@ -1,22 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/select_path.R -\name{select_path} -\alias{select_path} +\name{select_path-method} +\alias{select_path-method} \title{Define a path through a MultiFactor object.} -\usage{ -select_path( - x, - .path, - include = NULL, - exclude = NULL, - exact = NULL, - as.edges = FALSE -) -} \arguments{ -\item{x}{a \code{MultiFactor}} +\item{x}{input object} -\item{.path}{Either a \code{formula} or a \verb{character vector} of length 2 with the +\item{.path}{either a \code{formula} or a \verb{character vector} of length 2 with the names of the desired combination of feature types.} \item{include, exclude, exact}{\verb{Character vectors} Should feature types be @@ -26,9 +16,6 @@ path definition.} \item{as.edges}{\verb{Boolean scalar} Whether to return names of edges or nodes (Default) in the path.} } -\value{ -a list of character vectors. -} \description{ Define a path through a MultiFactor object. } @@ -48,4 +35,5 @@ x <- MultiFactor(list(a2b, a2c)) # Inspect a path between data types select_path(x, b ~ c) + } diff --git a/man/stack.MultiFactor.Rd b/man/stack-methods.Rd similarity index 71% rename from man/stack.MultiFactor.Rd rename to man/stack-methods.Rd index a007d88..fe52c5e 100644 --- a/man/stack.MultiFactor.Rd +++ b/man/stack-methods.Rd @@ -1,12 +1,8 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/stack.R -\name{stack} -\alias{stack} -\alias{stack.MultiFactor::MultiFactor} +\name{stack-methods} +\alias{stack-methods} \title{Combine levels across several LinkMaps in a MultiFactor} -\usage{ -\method{stack}{`MultiFactor::MultiFactor`}(x, .path, out.format = c("LinkMap", "matrix"), ...) -} \arguments{ \item{x}{a \code{MultiFactor}} @@ -15,19 +11,21 @@ by the plus (\code{+}) sign. Optionally, a list with two character vectors, signifying the variables to be combined at the left and right hand side, respectively.} -\item{out.format}{\verb{Character scalar}. One of \code{'LinkMap'}, \code{'matrix'}.} - \item{...}{Additional arguments (unused.)} + +\item{out.format}{\verb{Character scalar}. One of \code{'LinkMap'}, \code{'matrix'}.} } \value{ a \code{LinkMap} or \verb{sparse Matrix}. } \description{ -Generates a new \code{LinkMap} object by cross-referencing the elements of a -given \code{MultiFactor}. Elements can be merged by including several names, +Generates a new \code{LinkMap} object by merging levels by name, separated by the plus (\code{+}) sign. See examples. } \examples{ +# Only necessary in example code +require(utils) + x <- randomMultiFactor() # Merge variables with "+" operator, new names get concatenated with ".": stack(x, b ~ c + d) diff --git a/man/weave-generic.Rd b/man/weave-generic.Rd index 10d1632..140762b 100644 --- a/man/weave-generic.Rd +++ b/man/weave-generic.Rd @@ -1,8 +1,9 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R -\name{weave} +\name{weave-generic} +\alias{weave-generic} \alias{weave} -\title{Convert common classes to MultiFactor} +\title{Weave a path through an object} \usage{ weave(x, .path, ...) } @@ -15,10 +16,9 @@ names of the desired combination of feature types.} \item{...}{additional arguments} } \description{ -Convert common classes to MultiFactor +\code{weave()} is an S7 generic that finds a path through a +relational object with methods available for the following classes: +\itemize{ +\item \code{MultiFactor::MultiFactor} } -\examples{ -# Available methods: -weave - } diff --git a/man/weave-methods.Rd b/man/weave-methods.Rd index 9b42f68..67618b8 100644 --- a/man/weave-methods.Rd +++ b/man/weave-methods.Rd @@ -20,8 +20,7 @@ a \code{LinkMap} or \verb{sparse Matrix}. } \description{ Generates a new \code{LinkMap} object by cross-referencing the elements of a -given \code{MultiFactor}. Elements can be merged by including several names, -separated by the plus (\code{+}) sign. See examples. +given \code{MultiFactor}. } \examples{ # Generate a random MultiFactor From 35a56464918ab2c94dc425b431bb046e50014e7f Mon Sep 17 00:00:00 2001 From: thomaz Date: Fri, 17 Jul 2026 15:28:16 +0200 Subject: [PATCH 2/4] Implemented factor_path class, finished harmonishing path handling. Simplified internals. --- NAMESPACE | 11 +- R/AllClasses.R | 57 ++++++- R/AllGenerics.R | 32 +++- R/LinkMap-methods.R | 8 - R/as.LinkMap.R | 2 +- R/augment-subset.R | 59 +++++-- R/factor_path-methods.R | 51 ++++++ R/path-utils.R | 69 ++------ R/select_path.R | 128 +++++++-------- R/stack.R | 42 +++-- R/subgroup_apply.R | 127 --------------- R/tidy.R | 43 ----- R/weave-coverage.R | 85 ++++++---- R/weave.R | 117 ++++++-------- R/weave_apply.R | 151 ++++++++++++++++++ R/weave_to_tbl.R | 59 +++++++ man/as.MultiFactor.Rd | 1 - man/factor_path-class.Rd | 35 ++++ man/factor_path-methods.Rd | 26 +++ ..._path-method.Rd => select_path-methods.Rd} | 14 +- man/subgroup_apply.Rd | 51 ------ man/weave-generic.Rd | 8 + man/weave_apply-generic.Rd | 37 +++++ man/weave_apply-methods.Rd | 52 ++++++ man/{subgroup_to_tbl.Rd => weave_to_tbl.Rd} | 28 ++-- pkgdown/_pkgdown.yml | 12 +- tests/testthat/test-weave-formula-utils.R | 8 - vignettes/MultiFactor.Rmd | 19 +-- 28 files changed, 796 insertions(+), 536 deletions(-) create mode 100644 R/factor_path-methods.R delete mode 100644 R/subgroup_apply.R delete mode 100644 R/tidy.R create mode 100644 R/weave_apply.R create mode 100644 R/weave_to_tbl.R create mode 100644 man/factor_path-class.Rd create mode 100644 man/factor_path-methods.Rd rename man/{select_path-method.Rd => select_path-methods.Rd} (71%) delete mode 100644 man/subgroup_apply.Rd create mode 100644 man/weave_apply-generic.Rd create mode 100644 man/weave_apply-methods.Rd rename man/{subgroup_to_tbl.Rd => weave_to_tbl.Rd} (58%) delete mode 100644 tests/testthat/test-weave-formula-utils.R diff --git a/NAMESPACE b/NAMESPACE index f54389c..db46495 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,13 +12,16 @@ S3method(as.matrix,"MultiFactor::LinkMap") S3method(augment,"MultiFactor::MultiFactor") S3method(c,"MultiFactor::MultiFactor") S3method(stack,"MultiFactor::MultiFactor") +S3method(subset,"MultiFactor::LinkMap") S3method(subset,"MultiFactor::MultiFactor") +S3method(terms,"MultiFactor::factor_path") S3method(unique,"MultiFactor::LinkMap") export(LinkMap) export(MultiFactor) export(as.LinkMap) export(as.MultiFactor) export(draw_cards) +export(factor_path) export(mf_as_graph_df) export(nlevels) export(poker_scores) @@ -26,11 +29,11 @@ export(randomLinkMap) export(randomMultiFactor) export(read_adjacency_list) export(select_path) -export(subgroup_apply) -export(subgroup_to_tbl) export(trade_posts) export(weave) +export(weave_apply) export(weave_coverage) +export(weave_to_tbl) if (getRversion() < "4.3.0") importFrom("S7", "@") import(S7) importFrom(Matrix,colSums) @@ -42,7 +45,10 @@ importFrom(Matrix,which) importFrom(S7,"prop<-") importFrom(S7,S7_data) importFrom(S7,S7_dispatch) +importFrom(S7,class_character) importFrom(S7,new_class) +importFrom(S7,new_generic) +importFrom(S7,new_object) importFrom(S7,new_property) importFrom(forcats,lvls_expand) importFrom(forcats,lvls_union) @@ -66,6 +72,7 @@ importFrom(rlang,f_lhs) importFrom(rlang,f_rhs) importFrom(rlang,is_missing) importFrom(stats,reformulate) +importFrom(stats,terms) importFrom(utils,count.fields) importFrom(utils,data) importFrom(utils,download.file) diff --git a/R/AllClasses.R b/R/AllClasses.R index eb17682..90e4e10 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -182,7 +182,62 @@ MultiFactor <- S7::new_class( ) -##### LinkMap utils ---- + +#' factor_path S7 class +#' @name factor_path +#' @rdname factor_path-class +#' @description +#' `factor_path` is an S7 class to standardize the various ways in which paths +#' that can be specified across the `MultiFactor` package. This class is mostly +#' for internal use. +#' +#' @param x `Character vector` of length two; `c(, )`. +#' @param include `List of character vectors`. Which elements are included in +#' the path? Length of the list indicates number of paths. +#' @param exclude `Character vector`. Which elements are excluded from the path? +#' @param exact `Logical`. Should the path be followed as is? +#' (i.e., no pathfinding required) +#' @returns a `factor_path` object. +#' @importFrom S7 new_class new_property class_character new_object +#' @examples +#' factor_path(x = c("a", "c"), include = list("b")) +#' @export +#' +factor_path <- S7::new_class( + "factor_path", + package = "MultiFactor", + parent = S7::class_character, + properties = list( + include = S7::new_property( + class = S7::class_list, default = list(character()) + ), + exclude = S7::new_property( + class = S7::class_character, default = character() + ), + exact = S7::new_property( + class = S7::class_logical, default = FALSE + ) + ), + constructor = function( + x, include = list(character()), exclude = character(), exact = FALSE + ) { + stopifnot( + "factor_path input must be length 2." = length(x) == 2L, + "factor_path input must be a character vector." = is.character(x) + ) + S7::new_object( + .parent = x, include = include, exclude = exclude, exact = exact + ) + }, + validator = function(self) { + if(length(S7::S7_data(self)) != 2L) { + "factor_path must have length of two. " + } + } +) + + +##### LinkMap utils --]-- .check_input_df <- function(x) { if(! is.data.frame(x) ) { diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 2053599..02e3881 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -42,7 +42,6 @@ S7::method(nlevels, S7::class_any) <- base::nlevels #' # Available methods: #' as.MultiFactor #' -#' as.MultiFactor <- S7::new_generic("as.MultiFactor", "x") #' Weave a path through an object @@ -56,13 +55,44 @@ as.MultiFactor <- S7::new_generic("as.MultiFactor", "x") #' @param .path either a `formula` or a `character vector` of length 2 with the #' names of the desired combination of feature types. #' @param ... additional arguments +#' @returns a `LinkMap` or `matrix`. #' @importFrom S7 S7_dispatch #' @export +#' @examples +#' # Available methods: +#' weave #' weave <- S7::new_generic("weave", "x", function(x, .path, ...) { S7::S7_dispatch() }) +#' Index a table and apply arbitrary code to it +#' @rdname weave_apply-generic +#' @name weave_apply-generic +#' @description `weave_apply()` is an S7 generic that finds a path through a +#' relational object and evaluates provided code to each corresponding +#' subset of an input table. It is available for the following classes: +#' `r doclisting::methods_list("weave_apply")` +#' +#' @param .x input relational object to dispatch on. +#' @param .path either a `formula` or a `character vector` of length 2 with the +#' names of the desired combination of feature types. +#' @param .data an R object, such as tabular data. +#' @param .fun the function to be applied to each subgroup of `.x`. +#' @param ... Optional arguments to `.fun` +#' @importFrom S7 S7_dispatch new_generic +#' @export +#' @returns a list containing the results of `.fun`. +#' @examples +#' # Available methods: +#' weave_apply +#' +weave_apply <- S7::new_generic( + "weave_apply", + ".x", + function(.x, .path, .data, .fun = NULL, ...) {S7::S7_dispatch()} +) + #' Weave a path through an object #' @name select_path-generic #' @rdname select_path-generic diff --git a/R/LinkMap-methods.R b/R/LinkMap-methods.R index 892a619..20d7a6c 100644 --- a/R/LinkMap-methods.R +++ b/R/LinkMap-methods.R @@ -154,14 +154,6 @@ S7::method(levels, LinkMap) <- function(x) x@levels ##### LinkMap utils -#' @noRd -.formula2name <- function(.path) { - var_list <- .path_parse_formula(.path) - var_vctr <- vapply(var_list, paste, collapse = ".", FUN.VALUE = character(1L)) - var_name <- paste(var_vctr, collapse = "2") - return(var_name) -} - .colnames2name <- function(x) paste(x, collapse = "2") .linkmap2name <- function(x) paste(names(x), collapse = "2") diff --git a/R/as.LinkMap.R b/R/as.LinkMap.R index 08065ef..9ad445c 100644 --- a/R/as.LinkMap.R +++ b/R/as.LinkMap.R @@ -50,7 +50,7 @@ S7::method(as.LinkMap, S7::class_data.frame) <- function( x, edge.names = NULL ){ if( NCOL(x) >= 3L ) { - metadata <- x[, -seq_len(2L)] + metadata <- x[, -seq_len(2L), drop = FALSE] x <- x[, seq_len(2L)] } else { metadata <- data.frame(row.names = seq_len(NROW(x))) diff --git a/R/augment-subset.R b/R/augment-subset.R index bcf1795..8e54e89 100644 --- a/R/augment-subset.R +++ b/R/augment-subset.R @@ -26,32 +26,59 @@ #' NULL + + #' @export -#' @aliases subset.MultiFactor #' `subset.MultiFactor::MultiFactor` <- function( - x, subset = NULL, by_path = TRUE, drop.unmatched = TRUE, ... + x, .path, .drop.unmatched = FALSE, ... ) { - if(drop.unmatched) x <- .trimMultiFactor(x) - if(is.null(subset)) return(x) - if(by_path){ - subset <- unlist(.path_parse(subset)) - stopifnot("Argument `subset` must be length 2 if by_path` is TRUE" = - length(subset) == 2L) - subset <- termSeq(subset, x) - # Determine required ids in order, keep relevant elements of MultiFactor - return(subsetByPath(x, subset)) - } else `[`(x, subset) + if(.drop.unmatched) x <- .trimMultiFactor(x) + + path_check <- .check_path(.path) + .path_check_valid_subset(path_check) + path_list <- .path_to_std_list(.path, path_check) + + path_list <- .path_to_std_list(.path, path_check) + + full_path <- unlist(as.list(.select_std_path(x, path_list)), FALSE, FALSE) + + x <- .subset_by_path(x, full_path) + return(x) } #' @export #' +`subset.MultiFactor::LinkMap` <- function(x, subset = NULL, ...) { + df <- as.data.frame(x) + if( is.null(subset) ) { + if("complete" %in% colnames(df)) { + i <- df[["complete"]] } else { + i <- rep_len(TRUE, NCOL(df)) + } + } else { + e <- substitute(subset) + i <- eval(e, df, enclos = parent.frame()) + } + res <- x[i] + return(res) +} + +.path_check_valid_subset <- function(path_check) { + if(path_check[["complex"]]) { + stop( + "subset() '.path' cannot contain '+'.", + "Use `stack()` to prepare input." + ) + } + } + method(subset, MultiFactor) <- function( - x, subset = NULL, by_path = TRUE, drop.unmatched = TRUE, ... - ) `subset.MultiFactor::MultiFactor`( - x, subset, by_path, drop.unmatched, ... - ) + x, .path, .drop.unmatched = FALSE, ... + ) `subset.MultiFactor::MultiFactor`( + x, .path, .drop.unmatched + ) #' @importFrom generics augment diff --git a/R/factor_path-methods.R b/R/factor_path-methods.R new file mode 100644 index 0000000..b74b4e2 --- /dev/null +++ b/R/factor_path-methods.R @@ -0,0 +1,51 @@ +#' Methods for factor_path S7 class +#' @name factor_path-methods +#' @rdname factor_path-methods +#' @examples +#' # Setup +#' +#' set.seed(2612) +#' tp <- trade_posts() +#' x <- select_path(tp, fruit ~ furniture) +#' +#' # Basic properties +#' length(x) +#' terms(x) +#' +#' @param x,object `factor_path` on which the method should be applied. +#' @returns A `factor_path` +NULL + +S7::method(length, factor_path) <- function(x) lengths(x@include) + 2L + +#' @importFrom stats terms +S7::method(terms, factor_path) <- + function(x, ...) `terms.MultiFactor::factor_path`(x) + +#' @export +`terms.MultiFactor::factor_path` <- function(x, ...) S7::S7_data(x) + +#' @export +#' +S7::method(as.list, factor_path) <- function(x, ...) { + terms <- terms(x) + lapply(x@include, function(x) c(terms[1L], x, terms[2L])) +} + +S7::method(print, factor_path) <- function(x,...) { + terms <- terms(x) + from <- terms[1L] + to <- terms[2L] + p <- lapply(x@include, function(x) c(from, x, to)) + cat( + "A ", paste(setdiff(class(x), "character"), collapse = " "), + " from `", from, "` to `", to, "`", + sep = "" + ) + if(length(p) == 1L) { + cat(":\n") + } else { + cat(" with ", length(p), " sub-paths:\n", sep = "") + } + print(p) +} diff --git a/R/path-utils.R b/R/path-utils.R index 0993d57..602406f 100644 --- a/R/path-utils.R +++ b/R/path-utils.R @@ -2,7 +2,7 @@ #' @returns a named list with three variables. See details. #' @details #' `info` - How long is the provided path? `minimal` or `detailed`. -#' `complex` - `Logical`. Are the variables `ordinary` or concatenated with "+" `complex`. +#' `complex` - `Logical`. are steps concatenated with "+"? #' `class`- .path class. `character`, `list`, `formula` or `data.frame`. #' #' @noRd @@ -49,50 +49,23 @@ return(res) } -.std_path_to_list <- function(x, .path, check) switch( +.path_to_std_list <- function(.path, check) switch( check[["class"]], - "character" = res <- as.list(.path), - "data.frame" = res <- .path_df_to_list(.path), - "formula" = res <- as.list(.cut_fm_by_tildes(.path)), - "list" = res <- .path + "character" = as.list(.path), + "data.frame" = .path_df_to_list(.path), + "formula" = as.list(.cut_fm_by_tildes(.path)), + "list" = .path ) -.select_std_path <- function(x, std_path) { - terms <- unlist(std_path[c(1L, length(std_path))], FALSE, FALSE) - include <- unlist(std_path[-c(1, length(std_path))], FALSE, FALSE) - if(!length(include)) { include <- NULL } - full_path <- .select_path( x, terms, include ) +.path_df_to_list <- function(x) as.list( c(x[[1L]], x[[2L]][NROW(x)]) ) - return(full_path) -} - - -#' @param std_path Takes a std list form and splits it by " + " for stack(). -#' @returns a std list with split variables. +#' @importFrom rlang as_label #' @noRd -#' -.parse_stack_std_path <- function(std_path) unlist( - lapply(std_path, strsplit, split = " + ", fixed = TRUE), FALSE, FALSE +#' @returns a character vector of length >= 2L. +.cut_fm_by_tildes <- function(x) unlist( + strsplit(rlang::as_label(x), " ~ ", fixed = TRUE) ) - -.path_df_to_list <- function(x) as.list(c(x[[1L]], x[[2L]][NROW(x)])) - - -.path_ordinary_to_full <- function(x, .path) { - if(inherits(.path, "formula")) { - all_terms <- .cut_fm_by_tildes(.path) - } else { - all_terms <- .path - } - terms <- all_terms[c(1L, length(all_terms))] - include <- all_terms[-c(1, length(all_terms))] - if(!length(include)) { include <- NULL} - full_path <- .select_path( x, terms, include) - return(full_path) -} - - #' Standardize terms #' @returns a length 2 character vector of y, x. #' @noRd @@ -125,26 +98,6 @@ } -#' @importFrom rlang as_label -#' @noRd -#' @returns a character vector of length >= 2L. -.cut_fm_by_tildes <- function(x) unlist( - strsplit(rlang::as_label(x), " ~ ", fixed = TRUE) - ) - - - -#' @importFrom stats reformulate -#' @noRd -#' @returns a list of step-wise formulae. -.path_prep_fm_detailed <- function(.path) { - all_terms <- .cut_fm_by_tildes(.path) - lapply( - seq_len(length(all_terms) -1L), - function(i) stats::reformulate(all_terms[i+1L], all_terms[i]) - ) -} - diff --git a/R/select_path.R b/R/select_path.R index 843de0a..030627a 100644 --- a/R/select_path.R +++ b/R/select_path.R @@ -1,14 +1,10 @@ #' Define a path through a MultiFactor object. -#' @name select_path-method -#' @rdname select_path-method +#' @name select_path-methods +#' @rdname select_path-methods #' @param x input object #' @param .path either a `formula` or a `character vector` of length 2 with the #' names of the desired combination of feature types. -#' @param include,exclude,exact `Character vectors` Should feature types be -#' included or excluded from the available paths? Exact allows for exact -#' path definition. -#' @param as.edges `Boolean scalar` Whether to return names of edges or nodes -#' (Default) in the path. +#' @returns a `factor_path` object. #' @examples #' #' # Generate pair of random linkage input #' a2b <- data.frame( @@ -31,21 +27,60 @@ NULL #' @importFrom igraph as_ids #' S7::method(select_path, MultiFactor) <- function( - x, .path, ..., - include = NULL, exclude = NULL, exact = NULL, as.edges = FALSE + x, .path, ... ) { path_check <- .check_path(.path) - .path_check_valid_weave(path_check) + .path_check_valid_select(path_check) + path_list <- .path_to_std_list(.path, path_check) - path_list <- .std_path_to_list(x, .path, path_check) - paths <- .select_std_path(x, path_list) + paths <- .select_std_path(x, path_list) + return(paths) +} - #paths <- .select_path(x, .path_parse(.path), include, exclude, exact) +.path_check_valid_select <- function(path_check) { + if(path_check[["complex"]]) { + stop( + "`weave_select()` '.path' cannot contain '+'.", + "Use `stack()` to prepare input." + ) + } +} - if( as.edges ) paths <- lapply(paths, .V_path_as_E_path) - return(paths) +.select_std_path <- function(x, std_path) { + terms <- unlist(std_path[c(1L, length(std_path))], FALSE, FALSE) + include <- unlist(std_path[-c(1, length(std_path))], FALSE, FALSE) + if(!length(include)) { include <- NULL } + full_path <- .select_path( x, terms, include ) + i <- lapply(full_path, function(ii) ii[-c(1L, length(ii))]) + + res <- factor_path(terms, include = i, exclude = character(), exact = TRUE) + + return(res) + +} + +.std_path_as_factor_path <- function(x, exact = TRUE) { + ll <- length(x) + if( ll == 2L ) { + res <- factor_path(unlist(x), list(character()), character(), exact) + } else { + include <- list(x[-c(1L, ll)]) + x <- unlist(x[ c(1L, ll)]) + res <- factor_path(x, include, character(), exact) + } + return(res) } +# TODO delete if new .select_std_path is fine +# .select_std_path <- function(x, std_path) { +# terms <- unlist(std_path[c(1L, length(std_path))], FALSE, FALSE) +# include <- unlist(std_path[-c(1, length(std_path))], FALSE, FALSE) +# if(!length(include)) { include <- NULL } +# full_path <- .select_path( x, terms, include ) +# +# return(full_path) +# } + .select_path <- function( x, terms, include = NULL, exclude = NULL, exact = NULL ) { @@ -62,6 +97,12 @@ S7::method(select_path, MultiFactor) <- function( return(paths) } +.apply_shortest_ps <- function(terms, g) { + igraph::all_shortest_paths( + g, from = terms[1], to = terms[2] + )[["vpaths"]] +} + .subset_paths <- function(g, include, exclude, exact) { # Defenses if( length(dupes <- intersect(include, exclude)) != 0L ) stop( @@ -181,20 +222,6 @@ S7::method(select_path, MultiFactor) <- function( -.apply_shortest_ps <- function(terms, g) { - igraph::all_shortest_paths( - g, from = terms[1], to = terms[2] - )[["vpaths"]] -} - - - - - - -.weave_ordinary_terms_df <- function(df, x, out.format) .weave_ordinary_terms( - x, c(df), out.format -) # Utilities ---- @@ -204,7 +231,7 @@ S7::method(select_path, MultiFactor) <- function( # returns a Character vector of the ids to walk in order. #' @importFrom igraph shortest_paths graph_from_data_frame #' -termSeq <- function(terms, x) { +.term_seq <- function(terms, x) { stopifnot( "both terms must be found as colnames in 'x'" = all( terms %in% colnames(x) @@ -226,7 +253,7 @@ termSeq <- function(terms, x) { #' traversed. #' @noRd #' -stepSeq <- function(term_list, d) vapply( +.step_seq <- function(term_list, d) vapply( term_list, FUN = rowsWithCol, d = d, @@ -255,48 +282,13 @@ rowsWithCol <- function(d, id, names = TRUE) { return(rowInds) } -subsetByPath <- function(link, all_terms) { +.subset_by_path <- function(link, all_terms) { term_list <- lapply( seq_len(length(all_terms) - 1L), FUN = function(x) all_terms[c(x, x + 1L)] ) - steps <- stepSeq(term_list, link@map) + steps <- .step_seq(term_list, link@map) link <- link[steps] return(link) } -#' Generate dictionary Matrix from link input -#' @param link `MultiFactor` -#' @param all_terms `Character vector` of all path terms in sequence. -#' `termSeq(x, y, link)` -#' @importMethodsFrom Matrix %&% -#' @noRd -#' -.weave_to_dictionary_matrix <- function(link, all_terms) { - term_list <- lapply( - seq_len(length(all_terms) - 1L), - FUN = function(x) all_terms[c(x, x + 1L)] - ) - steps <- stepSeq(term_list, link@map) - lv_len <- nlevels(link, use.names = TRUE) - - # Handle simple case of one link df first, return sparse matrix. - if (length(steps) == 1L) { - return(`as.matrix.MultiFactor::LinkMap`( - x = S7::S7_data(link)[[steps]], - terms = all_terms, - dims = lv_len[all_terms] - )) - } - lv_list <- lapply(term_list, function(x) lv_len[x]) - # Otherwise, make a list of matrices to Reduce to final dictionary - mat_list <- mapply( - FUN = `as.matrix.MultiFactor::LinkMap`, - x = S7::S7_data(link)[steps], - terms = term_list, - dims = lv_list - ) - Reduce(Matrix::`%&%`, mat_list) -} - - diff --git a/R/stack.R b/R/stack.R index 105bbd7..35cc1d8 100644 --- a/R/stack.R +++ b/R/stack.R @@ -36,11 +36,11 @@ S7::method(stack, MultiFactor) <- function( # Handle .path arg path_check <- .check_path(.path) .path_check_valid_stack(path_check) - path_list <- .std_path_to_list(x, .path, path_check) + path_list <- .path_to_std_list(.path, path_check) - terms <- .parse_stack_std_path(path_list) + terms <- .stack_parse_std_path(path_list) - res <- .stack_terms(x, terms, out.format = "LinkMap") + res <- .stack_terms(x, terms) if(out.format == "matrix") { res <- `as.matrix.MultiFactor::LinkMap`(res) } @@ -58,16 +58,36 @@ S7::method(stack, MultiFactor) <- function( ) } -.stack_terms <- function(x, terms, out.format) { +#' @param std_path Takes a std list form and splits it by " + " for stack(). +#' @returns a std list with split variables. +#' @noRd +#' +.stack_parse_std_path <- function(std_path) unlist( + lapply(std_path, strsplit, split = " + ", fixed = TRUE), FALSE, FALSE +) + +.stack_terms <- function(x, terms) { res <- apply( - expand.grid(terms), 1L, .weave_ordinary_terms_df, - x = x, out.format = out.format, simplify = FALSE + expand.grid(terms), 1L, .stack_weave_terms_df, + x = x, simplify = FALSE ) - if(out.format == "LinkMap") { - cn <- vapply(lapply(terms, unique), paste, collapse = ".", "") - res <- do.call( rbind.data.frame, lapply(res, `colnames<-`, cn) ) - res <- LinkMap(res) - } + cn <- vapply(lapply(terms, unique), paste, collapse = ".", "") + res <- do.call( rbind.data.frame, lapply(res, `colnames<-`, cn) ) + res <- LinkMap(res) return(res) } +.stack_weave_terms_df <- function(df, x) .stack_weave_terms( + x, c(df) +) + +.stack_weave_terms <- function(x, terms) { + # Determine required ids in order, only keep relevant elements of link. + all_terms <- .select_path(x, terms, NULL, NULL, NULL) + res <- lapply(all_terms, .weave_full_path, x = x, out.format = "LinkMap") + res <- do.call( + rbind.data.frame, + c(res, make.row.names = FALSE, stringsAsFactors = TRUE) + ) + return(res) +} diff --git a/R/subgroup_apply.R b/R/subgroup_apply.R deleted file mode 100644 index 93cd527..0000000 --- a/R/subgroup_apply.R +++ /dev/null @@ -1,127 +0,0 @@ -#' Index a table and apply arbitrary code to it -#' @name subgroup_apply -#' @rdname subgroup_apply -#' @description -#' `subgroup_apply` can run arbitrary code specified by `FUN` across any number -#' of row-based subsets of table `X`. Mimics lapply. -#' @param X `A table`. A `data.frame`, `matrix`, other object with rows and -#' columns. -#' @param LINK a `MultiFactor` object. -#' @param BY either a `formula` or a `character vector`` of length 2 with the -#' names of the desired combination of feature types. -#' @param FUN A function, passed to lapply. -#' @param ... Additional arguments passed to lapply call. -#' @param INDEX `Character scalar` Where in `X` can the target feature names be -#' found. (Default: "row.names") -#' @returns a `Named list` of desired output. -#' @examples -#' -#' # Prepare data -#' -#' link <- trade_posts() -#' -#' # Generate small example feature table 'x'. -#' n <- nlevels(link)[["clothing"]] -#' x <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) -#' -#' #' # Ensure rownames correspond to the second (RHS) variable in the formula. -#' x <- as.data.frame(x, row.names = levels(link)$clothing) -#' -#' # Apply arbitrary code to x based on group membership -#' subgroup_apply(x, link, BY = fruit ~ clothing, FUN = function(x) colSums(x)) -#' -#' @seealso [weave()] [LinkMap()] [MultiFactor()] -#' @export -#' -subgroup_apply <- function( X, LINK, BY, FUN = NULL, ..., INDEX = "row.names" ) { - IDX <- .splitLinkMap( - .index_tbl_by(X, LINK, BY, INDEX) - ) - - # Mimic tapply behaviour; Leaving FUN = NULL returns the index itself. - if(is.null(FUN)) return(IDX) else FUN <- match.fun(FUN) - - # Apply FUN over each subset of X indexed by IDX - lapply(X = IDX, FUN = function(iii) FUN(X[iii, ]), ...) -} - -#' Index a table -#' @name .index_tbl_by -#' @rdname index_tbl -#' @description -#' `.index_tbl()` is a utility function that flexibly takes a table as input and -#' returns a special `LinkMap` object that has (1) row names and (2) -#' corresponding row indices of that table as columns. -#' -#' @param type `Character scalar` Specifies name of the feature type, will be -#' used as name of the first column in output. -#' @param .i `Character scalar` column with features. Defaults to `rownames(X)` -#' @noRd -#' @examples -#' # Any table can be a indexed into a LinkMap: -#' .index_tbl(mtcars) -#' -.index_tbl <- function( - X, type = deparse1(substitute(X)), .i = "row.names", ... - ) { - if (.i == "row.names") { row.index <- rownames(X) } else row.index <- X[[.i]] - - res <- data.frame( row.index, seq_len(NROW(X)) ) - - colnames(res) <- c(type, "row.index") - as.LinkMap(res) -} - -#' Index a table -#' @name .index_tbl_by -#' @rdname index_tbl -#' @description -#' `.index_tbl_by()` finds row indices for input table `x`, based on a -#' user-defined path through a MultiFactor (`link` arg). -#' -#' @param link a `MultiFactor` object. -#' @param .path either a `formula` or a `character vector`` of length 2 with the -#' names of the desired combination of feature types. -#' @noRd -#' @examples -#' # Utilities -#' .index_tbl_by(x, link, ec ~ ko) -#' -.index_tbl_by <- function(X, link, .path, .i = "row.names", ...) { - # Ensure link is a MultiFactor - link <- MultiFactor(link) - - terms <- .path_parse(.path) - X <- .index_tbl(X, type = terms[[2L]], .i = .i) - terms[[2L]] <- colnames(X)[[2L]] - X <- MultiFactor(X) - - X <- `c.MultiFactor::MultiFactor`(link, X) - - weave(X, .path, ...) - -} - -#' @noRd -.splitLinkMap <- function(x, drop = TRUE) split.default( - as.integer(x[[2L]]), x[[1L]], drop - ) - -#' Take the coverage .data arg and return a character vector. -#' @noRd -#' -.data_coverage_to_vector <- function(.data, .i = "row.names") { - if( !length(.data) ) { - res <- NULL - } else if( is.character(.data) ) { - res <- .data - } else { - if( .i == "row.names") { - res <- row.names(.data) - } else { - res <- .data[[.i]] - } - } - return(res) -} - diff --git a/R/tidy.R b/R/tidy.R deleted file mode 100644 index be9006d..0000000 --- a/R/tidy.R +++ /dev/null @@ -1,43 +0,0 @@ -#' Expand a table based on possibly overlapping group membership. -#' @name subgroup_to_tbl -#' @description -#' Expand a table into a tidy table suitable for tidyverse-stype operations. -#' @param x `A table`. A `data.frame`, `matrix`, other object with rows and -#' columns. Should have a `cbind` method. -#' @param link a `MultiFactor`. -#' @param .path either a `formula` or a `character vector`` of length 2 with the -#' names of the desired combination of feature types. -#' @param .index `Character scalar` Column to look for feature IDs to link. -#' Default: "row.names". -#' @returns An expanded table `x`, with an added first column containing -#' subgroups. -#' @importFrom Matrix which -#' @examples -#' # Prepare data -#' link <- trade_posts() -#' -#' # Generate small example feature table 'x'. -#' n <- nlevels(link)[["clothing"]] -#' x <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) -#' -#' #' # Ensure rownames correspond to the second (RHS) variable in the formula. -#' x <- as.data.frame(x, row.names = levels(link)$clothing) -#' -#' # Apply arbitrary code to x based on group membership -#' subgroup_to_tbl(x, link, .path = fruit ~ clothing) -#' -#' @export -#' -subgroup_to_tbl <- function(x, link, .path, .index = "row.names") { - out <- S7::S7_data( .index_tbl_by(x, link, .path, .index) ) - class(out) <- "data.frame" - out[[2L]] <- as.integer(out[[2L]]) - xcol <- if(.index == "row.names") row.names(x) else x[[.index]] - - subgroup <- data.frame(y = out[1L], x = xcol[out[[2L]]], check.rows = FALSE) - colnames(subgroup) <- if(inherits(.path, "formula")) all.vars(.path) else .path - - out <- data.frame(subgroup, x[out[[2L]], ]) - row.names(out) <- NULL - out -} diff --git a/R/weave-coverage.R b/R/weave-coverage.R index 738ad31..a3a855d 100644 --- a/R/weave-coverage.R +++ b/R/weave-coverage.R @@ -46,30 +46,27 @@ weave_coverage <- function( several.ok = TRUE ) out.format <- match.arg(out.format, c("LinkMap", "matrix")) + .data <- .data_coverage_to_vector(.data, .data_column) path_check <- .check_path(.path) .path_check_valid_coverage(path_check) - path_list <- .std_path_to_list(x, .path, path_check) - full_path <- .select_std_path(x, path_list)[[1L]] + path_list <- .path_to_std_list(.path, path_check) + full_path <- as.list(.select_std_path(x, path_list)) - stopifnot( - "weave_coverage() '.path' must be 2 or 3 steps long." = - length(full_path) %in% c(2L, 3L) + res <- lapply( + full_path, + .weave_coverage_factor_path, + x = x, .data = .data, metric = metric ) - x <- subsetByPath(x, full_path) - .data <- .data_coverage_to_vector(.data, .data_column) - if( length(full_path) == 2L ) { - res <- .weave_coverage_two(x, full_path, .data, metric, out.format) - } else if( length(full_path) == 3L ) { - res <- .weave_coverage_three(x, full_path, .data, metric, out.format) + res <- do.call(rbind.data.frame, res) + res <- as.LinkMap(res) + if(out.format == "matrix") { + res <- `as.matrix.MultiFactor::LinkMap`(res) } - return(res) - - } .path_check_valid_coverage <- function(path_check) { @@ -79,6 +76,26 @@ weave_coverage <- function( } } +.weave_coverage_factor_path <- function( + x, full_path, .data, metric +) { + stopifnot( + "weave_coverage() '.path' must be 2 or 3 steps long." = + length(full_path) %in% c(2L, 3L) + ) + x <- .subset_by_path(x, full_path) + + if( length(full_path) == 2L ) { + res <- .weave_coverage_two(x, full_path, .data, metric) + } else if( length(full_path) == 3L ) { + res <- .weave_coverage_three(x, full_path, .data, metric) + } + return(res) +} + + +#' @importFrom stats reformulate +#' .weave_contingency_params <- function(x) { shared <- do.call(intersect, unname(lapply(x, names))) stopifnot( "LinkMaps must share exactly one column" = length(shared) == 1L ) @@ -91,7 +108,7 @@ weave_coverage <- function( # Ensure order if(names(full)[2L] == shared) full <- full[,c(2L, 1L)] - to_from <- weave(x, reformulate(to, from)) + to_from <- weave(x, stats::reformulate(to, from)) hits <- weave( MultiFactor(list( to_from, seen )), @@ -106,6 +123,8 @@ weave_coverage <- function( data.frame(q, m, n, k) } +#' @importFrom stats reformulate +#' .char_contingency_params <- function(x, observed, set) { stopifnot("'observed' must be a named list" = length(names(observed)) == 1L) @@ -115,11 +134,11 @@ weave_coverage <- function( "Both set and observed must be found in 'x'" = all(c(shared, set) %in% colnames(x)) ) - full <- weave(x, reformulate(to, shared)) + full <- weave(x, stats::reformulate(to, shared)) hits <- full[full[[shared]] %in% observed[[1L]] ,] - q <- tapply(X = hits, INDEX = reformulate(to), FUN = NROW) - m <- tapply(X = full, INDEX = reformulate(to), FUN = NROW) + q <- tapply(X = hits, INDEX = stats::reformulate(to), FUN = NROW) + m <- tapply(X = full, INDEX = stats::reformulate(to), FUN = NROW) n <- nlevels(full)[[to]] - m k <- length( unique(hits[[1L]]) ) @@ -155,7 +174,7 @@ weave_coverage <- function( #' x.cpt@metadata #' .weave_coverage_three <- function( - x, all_terms, .data, metric, out.format + x, all_terms, .data, metric ) { # All steps in order from <- all_terms[[1L]] @@ -184,20 +203,20 @@ weave_coverage <- function( complete = obs_set == tot_set ) - if( out.format == "LinkMap" ) { - res <- .res_weave_matrix_to_LinkMap(res, levels(x)[c(from, to)]) - metadata <- metadata[as.integer(res[[to]]), metric] - res <- LinkMap(res, metadata) - } else if (out.format == "matrix") { - res@x <- metadata[as.integer(res[[to]]), metric] - } + res <- .res_weave_matrix_to_LinkMap(res, levels(x)[c(from, to)]) + metadata <- metadata[as.integer(res[[to]]), metric] + res <- cbind.data.frame(res, metadata) + + row.names(res) <- NULL + return(res) } #' @importFrom Matrix colSums +#' @importFrom stats reformulate #' .weave_coverage_two <- function( - x, all_terms, .data, metric, out.format + x, all_terms, .data, metric ) { set_unit <- all_terms[[1L]] set_full <- all_terms[[2L]] @@ -209,9 +228,9 @@ weave_coverage <- function( obs <- bg } tot_set <- pmax.int( - c(tapply(bg, INDEX = reformulate(set_full), FUN = NROW)), 1L + c(tapply(bg, INDEX = stats::reformulate(set_full), FUN = NROW)), 1L ) - obs_set <- c(tapply(obs, INDEX = reformulate(set_full), FUN = NROW)) + obs_set <- c(tapply(obs, INDEX = stats::reformulate(set_full), FUN = NROW)) val <- data.frame( count = obs_set, size = tot_set, @@ -220,11 +239,9 @@ weave_coverage <- function( )[metric] metadata <- val[match(bg[[set_full]], row.names(val)), , drop = FALSE] - row.names(metadata) <- NULL - res <- LinkMap(x.lm, metadata) + res <- cbind.data.frame(x.lm, metadata) + + row.names(res) <- NULL - if( out.format == "matrix" ) { - res <- `as.matrix.MultiFactor::LinkMap`(res, value_id = metric[[1L]]) - } return(res) } diff --git a/R/weave.R b/R/weave.R index 4d1c673..57eee4f 100644 --- a/R/weave.R +++ b/R/weave.R @@ -27,18 +27,19 @@ S7::method(weave, MultiFactor) <- function( include = NULL, exclude = NULL, exact = NULL ) { out.format <- match.arg(out.format, c("LinkMap", "matrix")) - lv_list <- levels(x) path_check <- .check_path(.path) .path_check_valid_weave(path_check) + path_list <- .path_to_std_list(.path, path_check) - path_list <- .std_path_to_list(x, .path, path_check) - full_path <- .select_std_path(x, path_list)[[1L]] - # full_path <- .path_ordinary_to_full(x, .path)[[1L]] - res <- .weave_full_path(x, full_path, out.format) + full_path <- as.list(.select_std_path(x, path_list)) - if( out.format == "LinkMap" ) { - res <- LinkMap(res) + res <- lapply(full_path, .weave_full_path, x = x, out.format = "LinkMap") + res <- do.call( rbind.data.frame, res ) + res <- LinkMap(res) + + if(out.format == "matrix") { + res <- `as.matrix.MultiFactor::LinkMap`(res) } return(res) @@ -46,68 +47,58 @@ S7::method(weave, MultiFactor) <- function( .path_check_valid_weave <- function(path_check) { if(path_check[["complex"]]) { - stop("weave() '.path' cannot contain '+'. Use stack() to prepare input.") + stop("weave() '.path' cannot contain '+'. Use `stack()` to prepare input.") } } - - -weave_along_path <- function(x, path, out.format = "LinkMap") { - # tolerate single path result in list - if(length(path) == 1L) path <- path[[1L]] - stopifnot( - "'path' must be a character vector of steps to take, in order." = - is.character(path) - ) - stopifnot( - "All entries in 'path' must be found in colnames(x)." = - all( path %in% colnames(x) ) - ) - res <- .weave_full_path(x, path, out.format) - # Remove duplicates - if(out.format == "LinkMap") { - res <- res[ !duplicated(res[, seq_len(2L)]), ] - } - res -} - - -.weave_ordinary_terms <- function(x, terms, out.format) { - lv_list <- levels(x) - # Determine required ids in order, only keep relevant elements of link. - all_terms <- .select_path(x, terms, include = NULL, exclude = NULL, exact = NULL) - res <- lapply(all_terms, .weave_full_path, x = x, out.format = "LinkMap") - res <- do.call( - rbind.data.frame, - c(res, make.row.names = FALSE, stringsAsFactors = TRUE) - ) - if( out.format == "matrix" ) { - res <- Matrix::sparseMatrix( - i = as.numeric(res[[terms[1L]]]), j = as.numeric(res[[terms[2L]]]), - dims = lengths(lv_list[terms]), dimnames = lv_list[terms] - ) - } - return(res) -} - - .weave_full_path <- function(x, all_terms, out.format) { - x <- subsetByPath(x, all_terms) + x <- .subset_by_path(x, all_terms) terms <- all_terms[c(1L, length(all_terms))] + # Construct dictionary res <- .weave_to_dictionary_matrix(x, all_terms) - # Check if we're done - if(out.format == "matrix") { - dimnames(res) <- levels(x)[terms] - return(res) - } - # Otherwise, make a LinkMap + # make a LinkMap-shaped data.frame res <- .res_weave_matrix_to_LinkMap(res, levels(x)[terms]) return(res) } +#' Generate dictionary Matrix from link input +#' @param link `MultiFactor` +#' @param all_terms `Character vector` of all path terms in sequence. +#' `.term_seq(x, y, link)` +#' @importMethodsFrom Matrix %&% +#' @noRd +#' +.weave_to_dictionary_matrix <- function(link, all_terms) { + term_list <- lapply( + seq_len(length(all_terms) - 1L), + FUN = function(x) all_terms[c(x, x + 1L)] + ) + steps <- .step_seq(term_list, link@map) + lv_len <- nlevels(link, use.names = TRUE) + + # Handle simple case of one link df first, return sparse matrix. + if (length(steps) == 1L) { + return(`as.matrix.MultiFactor::LinkMap`( + x = S7::S7_data(link)[[steps]], + terms = all_terms, + dims = lv_len[all_terms] + )) + } + lv_list <- lapply(term_list, function(x) lv_len[x]) + # Otherwise, make a list of matrices to Reduce to final dictionary + mat_list <- mapply( + FUN = `as.matrix.MultiFactor::LinkMap`, + x = S7::S7_data(link)[steps], + terms = term_list, + dims = lv_list + ) + Reduce(Matrix::`%&%`, mat_list) +} + + #' @importFrom Matrix which #' .res_weave_matrix_to_LinkMap <- function(res, lvs) { @@ -120,17 +111,3 @@ weave_along_path <- function(x, path, out.format = "LinkMap") { colnames(res) <- names(lvs) return(res) } - -.weave_paths_terms <- function(x, terms) { - stopifnot( - "both terms must be found as colnames in 'x'" = all( - terms %in% colnames(x) - ) - ) - g <- igraph::graph_from_data_frame( - d = .all_names_in_list_mf(x), - directed = FALSE - ) - igraph::all_shortest_paths( - g, from = terms[1], to = terms[2])[["vpaths"]] -} diff --git a/R/weave_apply.R b/R/weave_apply.R new file mode 100644 index 0000000..b414516 --- /dev/null +++ b/R/weave_apply.R @@ -0,0 +1,151 @@ +#' Index a table by a MultiFactor and apply arbitrary code to it +#' @name weave_apply-methods +#' @rdname weave_apply-methods +#' @description +#' `weave_apply` can run arbitrary code specified by `FUN` across any number +#' of row-based subsets of table `.data`. Mimics lapply. +#' @param .x a `MultiFactor` object. +#' @param .path either a `formula` or a `character vector`` of length 2 with the +#' names of the desired combination of feature types. +#' @param .data `A table`. A `data.frame`, `matrix`, other object with rows and +#' columns. +#' @param .fun A function, passed to lapply. +#' @param ... Additional arguments passed to lapply call. +#' @param .index `Character scalar` Where in `.x` can the target feature names be +#' found. (Default: "row.names") +#' @returns a `Named list` of desired output. +#' @examples +#' +#' # Prepare data +#' x <- trade_posts() +#' +#' # Generate small example feature table 'df'. +#' n <- nlevels(x)[["clothing"]] +#' df <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) +#' +#' #' # Ensure rownames correspond to the second (RHS) variable in the formula. +#' df <- as.data.frame(df, row.names = levels(x)$clothing) +#' +#' # Apply arbitrary code to x based on group membership +#' weave_apply( +#' x, +#' .path = fruit ~ clothing, +#' .data = df, +#' .fun = function(x) colSums(x) +#' ) +#' +#' @seealso [weave()] [lapply()] [LinkMap()] [MultiFactor()] +#' +NULL + +S7::method(weave_apply, MultiFactor) <- function( + .x, .path, .data, .fun = NULL, ..., .index = "row.names" +) { + path_check <- .check_path(.path) + + .path_check_valid_weave_apply(path_check) + + path_list <- .path_to_std_list(.path, path_check) + + IDX <- .splitLinkMap(.index_tbl_by_path_list(.x, path_list, .data, .index)) + + # Mimic tapply behaviour; Leaving FUN = NULL returns the index itself. + if(is.null(.fun)) { + res <- IDX + } else { + FUN <- match.fun(.fun) + # Apply FUN over each subset of X indexed by IDX + res <- lapply(X = IDX, FUN = function(iii) FUN(.data[iii, ]), ...) + } + return(res) +} + +.path_check_valid_weave_apply <- function(path_check) { + if(path_check[["complex"]]) { + stop( + "`weave_apply()` '.path' cannot contain '+'.", + "Use `stack()` to prepare input." + ) + } +} + +#' Index a table +#' @name .index_tbl_by_path_list +#' @rdname index_tbl +#' @description +#' `.index_tbl_by_path_list()` finds row indices for input table `.data`, +#' based on a user-defined path through a MultiFactor. +#' @noRd +#' @examples +#' # Utilities +#' .index_tbl_by_path_list(link, ec ~ ko, .data) +#' +.index_tbl_by_path_list <- function( + .x, path_list, .data, .i = "row.names", ... + ) { + + .data <- .index_tbl(.data, type = path_list[[2L]], .i = .i) + path_list[[2L]] <- colnames(.data)[[2L]] + .data <- MultiFactor(.data) + + .x <- `c.MultiFactor::MultiFactor`(.x, .data) + + weave(.x, path_list, ...) + +} + + +#' Index a table +#' @name .index_tbl_by_path_list +#' @rdname index_tbl +#' @description +#' `.index_tbl()` is a utility function that flexibly takes a table as input and +#' returns a special `LinkMap` object that has (1) row names and (2) +#' corresponding row indices of that table as columns. +#' +#' @param type `Character scalar` Specifies name of the feature type, will be +#' used as name of the first column in output. +#' @param .i `Character scalar` column with features. Defaults to `rownames(X)` +#' @noRd +#' @examples +#' # Any table can be a indexed into a LinkMap: +#' .index_tbl(mtcars) +#' +.index_tbl <- function( + .data, type = deparse1(substitute(.data)), .i = "row.names" + ) { + if( .i == "row.names" ) { + row.index <- rownames(.data) + } else { + row.index <- .data[[.i]] + } + res <- data.frame( row.index, seq_len(NROW(.data)) ) + + colnames(res) <- c(type, "row.index") + as.LinkMap(res) +} + + +#' @noRd +.splitLinkMap <- function(x, drop = TRUE) split.default( + as.integer(x[[2L]]), x[[1L]], drop + ) + +#' Take the coverage .data arg and return a character vector. +#' @noRd +#' +.data_coverage_to_vector <- function(.data, .i = "row.names") { + if( !length(.data) ) { + res <- NULL + } else if( is.character(.data) ) { + res <- .data + } else { + if( .i == "row.names") { + res <- row.names(.data) + } else { + res <- .data[[.i]] + } + } + return(res) +} + diff --git a/R/weave_to_tbl.R b/R/weave_to_tbl.R new file mode 100644 index 0000000..d396f3d --- /dev/null +++ b/R/weave_to_tbl.R @@ -0,0 +1,59 @@ +#' Expand a table based on possibly overlapping group membership. +#' @name weave_to_tbl +#' @description +#' Expand a table into a tidy table suitable for tidyverse-stype operations. +#' @param x a `MultiFactor`. +#' @param .data `A table`. A `data.frame`, `matrix`, other object with rows and +#' columns. Should have a `cbind` method. +#' @param .path either a `formula` or a `character vector`` of length 2 with the +#' names of the desired combination of feature types. +#' @param .index `Character scalar` Column to look for feature IDs to link. +#' Default: "row.names". +#' @returns An expanded table `x`, with an added first column containing +#' subgroups. +#' @importFrom Matrix which +#' @examples +#' # Prepare data +#' x <- trade_posts() +#' +#' # Generate small example feature table 'df'. +#' n <- nlevels(x)[["clothing"]] +#' df <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) +#' +#' #' # Ensure rownames correspond to the second (RHS) variable in the formula. +#' df <- as.data.frame(df, row.names = levels(x)$clothing) +#' +#' # Apply arbitrary code to x based on group membership +#' weave_to_tbl(x, .path = fruit ~ clothing, .data = df) +#' +#' @export +#' +weave_to_tbl <- function(x, .path, .data, .index = "row.names") { + path_check <- .check_path(.path) + + .path_check_valid_weave_to_tbl(path_check) + + path_list <- .path_to_std_list(.path, path_check) + + out <- .index_tbl_by_path_list(x, path_list, .data, .index) + out <- `class<-`(S7::S7_data(out), "data.frame") + + out[[2L]] <- as.integer(out[[2L]]) + xcol <- if(.index == "row.names") row.names(.data) else .data[[.index]] + + subgroup <- data.frame(y = out[1L], x = xcol[out[[2L]]], check.rows = FALSE) + colnames(subgroup) <- terms(.std_path_as_factor_path(path_list)) + + out <- data.frame(subgroup, .data[out[[2L]], ]) + row.names(out) <- NULL + return(out) +} + +.path_check_valid_weave_to_tbl <- function(path_check) { + if(path_check[["complex"]]) { + stop( + "`weave_to_tbl()` '.path' cannot contain '+'.", + "Use `stack()` to prepare input." + ) + } +} diff --git a/man/as.MultiFactor.Rd b/man/as.MultiFactor.Rd index 6bed29d..8bd61db 100644 --- a/man/as.MultiFactor.Rd +++ b/man/as.MultiFactor.Rd @@ -21,7 +21,6 @@ Convert common classes to MultiFactor # Available methods: as.MultiFactor - } \seealso{ \link{as.LinkMap} diff --git a/man/factor_path-class.Rd b/man/factor_path-class.Rd new file mode 100644 index 0000000..39a4c06 --- /dev/null +++ b/man/factor_path-class.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllClasses.R +\name{factor_path} +\alias{factor_path} +\title{factor_path S7 class} +\usage{ +factor_path( + x, + include = list(character()), + exclude = character(), + exact = FALSE +) +} +\arguments{ +\item{x}{\verb{Character vector} of length two; \verb{c(, )}.} + +\item{include}{\verb{List of character vectors}. Which elements are included in +the path? Length of the list indicates number of paths.} + +\item{exclude}{\verb{Character vector}. Which elements are excluded from the path?} + +\item{exact}{\code{Logical}. Should the path be followed as is? +(i.e., no pathfinding required)} +} +\value{ +a \code{factor_path} object. +} +\description{ +\code{factor_path} is an S7 class to standardize the various ways in which paths +that can be specified across the \code{MultiFactor} package. This class is mostly +for internal use. +} +\examples{ +factor_path(x = c("a", "c"), include = list("b")) +} diff --git a/man/factor_path-methods.Rd b/man/factor_path-methods.Rd new file mode 100644 index 0000000..1c5d6fa --- /dev/null +++ b/man/factor_path-methods.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/factor_path-methods.R +\name{factor_path-methods} +\alias{factor_path-methods} +\title{Methods for factor_path S7 class} +\arguments{ +\item{x, object}{\code{factor_path} on which the method should be applied.} +} +\value{ +A \code{factor_path} +} +\description{ +Methods for factor_path S7 class +} +\examples{ +# Setup + +set.seed(2612) +tp <- trade_posts() +x <- select_path(tp, fruit ~ furniture) + +# Basic properties +length(x) +terms(x) + +} diff --git a/man/select_path-method.Rd b/man/select_path-methods.Rd similarity index 71% rename from man/select_path-method.Rd rename to man/select_path-methods.Rd index 931bc28..2596ead 100644 --- a/man/select_path-method.Rd +++ b/man/select_path-methods.Rd @@ -1,20 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/select_path.R -\name{select_path-method} -\alias{select_path-method} +\name{select_path-methods} +\alias{select_path-methods} \title{Define a path through a MultiFactor object.} \arguments{ \item{x}{input object} \item{.path}{either a \code{formula} or a \verb{character vector} of length 2 with the names of the desired combination of feature types.} - -\item{include, exclude, exact}{\verb{Character vectors} Should feature types be -included or excluded from the available paths? Exact allows for exact -path definition.} - -\item{as.edges}{\verb{Boolean scalar} Whether to return names of edges or nodes -(Default) in the path.} +} +\value{ +a \code{factor_path} object. } \description{ Define a path through a MultiFactor object. diff --git a/man/subgroup_apply.Rd b/man/subgroup_apply.Rd deleted file mode 100644 index 67cd088..0000000 --- a/man/subgroup_apply.Rd +++ /dev/null @@ -1,51 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/subgroup_apply.R -\name{subgroup_apply} -\alias{subgroup_apply} -\title{Index a table and apply arbitrary code to it} -\usage{ -subgroup_apply(X, LINK, BY, FUN = NULL, ..., INDEX = "row.names") -} -\arguments{ -\item{X}{\verb{A table}. A \code{data.frame}, \code{matrix}, other object with rows and -columns.} - -\item{LINK}{a \code{MultiFactor} object.} - -\item{BY}{either a \code{formula} or a `character vector`` of length 2 with the -names of the desired combination of feature types.} - -\item{FUN}{A function, passed to lapply.} - -\item{...}{Additional arguments passed to lapply call.} - -\item{INDEX}{\verb{Character scalar} Where in \code{X} can the target feature names be -found. (Default: "row.names")} -} -\value{ -a \verb{Named list} of desired output. -} -\description{ -\code{subgroup_apply} can run arbitrary code specified by \code{FUN} across any number -of row-based subsets of table \code{X}. Mimics lapply. -} -\examples{ - -# Prepare data - -link <- trade_posts() - -# Generate small example feature table 'x'. -n <- nlevels(link)[["clothing"]] -x <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) - -#' # Ensure rownames correspond to the second (RHS) variable in the formula. -x <- as.data.frame(x, row.names = levels(link)$clothing) - -# Apply arbitrary code to x based on group membership -subgroup_apply(x, link, BY = fruit ~ clothing, FUN = function(x) colSums(x)) - -} -\seealso{ -\code{\link[=weave]{weave()}} \code{\link[=LinkMap]{LinkMap()}} \code{\link[=MultiFactor]{MultiFactor()}} -} diff --git a/man/weave-generic.Rd b/man/weave-generic.Rd index 140762b..909242c 100644 --- a/man/weave-generic.Rd +++ b/man/weave-generic.Rd @@ -15,6 +15,9 @@ names of the desired combination of feature types.} \item{...}{additional arguments} } +\value{ +a \code{LinkMap} or \code{matrix}. +} \description{ \code{weave()} is an S7 generic that finds a path through a relational object with methods available for the following classes: @@ -22,3 +25,8 @@ relational object with methods available for the following classes: \item \code{MultiFactor::MultiFactor} } } +\examples{ +# Available methods: +weave + +} diff --git a/man/weave_apply-generic.Rd b/man/weave_apply-generic.Rd new file mode 100644 index 0000000..991b821 --- /dev/null +++ b/man/weave_apply-generic.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R +\name{weave_apply-generic} +\alias{weave_apply-generic} +\alias{weave_apply} +\title{Index a table and apply arbitrary code to it} +\usage{ +weave_apply(.x, .path, .data, .fun = NULL, ...) +} +\arguments{ +\item{.x}{input relational object to dispatch on.} + +\item{.path}{either a \code{formula} or a \verb{character vector} of length 2 with the +names of the desired combination of feature types.} + +\item{.data}{an R object, such as tabular data.} + +\item{.fun}{the function to be applied to each subgroup of \code{.x}.} + +\item{...}{Optional arguments to \code{.fun}} +} +\value{ +a list containing the results of \code{.fun}. +} +\description{ +\code{weave_apply()} is an S7 generic that finds a path through a +relational object and evaluates provided code to each corresponding +subset of an input table. It is available for the following classes: +\itemize{ +\item \code{MultiFactor::MultiFactor} +} +} +\examples{ +# Available methods: +weave_apply + +} diff --git a/man/weave_apply-methods.Rd b/man/weave_apply-methods.Rd new file mode 100644 index 0000000..16243e5 --- /dev/null +++ b/man/weave_apply-methods.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/weave_apply.R +\name{weave_apply-methods} +\alias{weave_apply-methods} +\title{Index a table by a MultiFactor and apply arbitrary code to it} +\arguments{ +\item{.x}{a \code{MultiFactor} object.} + +\item{.path}{either a \code{formula} or a `character vector`` of length 2 with the +names of the desired combination of feature types.} + +\item{.data}{\verb{A table}. A \code{data.frame}, \code{matrix}, other object with rows and +columns.} + +\item{.fun}{A function, passed to lapply.} + +\item{...}{Additional arguments passed to lapply call.} + +\item{.index}{\verb{Character scalar} Where in \code{.x} can the target feature names be +found. (Default: "row.names")} +} +\value{ +a \verb{Named list} of desired output. +} +\description{ +\code{weave_apply} can run arbitrary code specified by \code{FUN} across any number +of row-based subsets of table \code{.data}. Mimics lapply. +} +\examples{ + +# Prepare data +x <- trade_posts() + +# Generate small example feature table 'df'. +n <- nlevels(x)[["clothing"]] +df <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) + +#' # Ensure rownames correspond to the second (RHS) variable in the formula. +df <- as.data.frame(df, row.names = levels(x)$clothing) + +# Apply arbitrary code to x based on group membership +weave_apply( + x, + .path = fruit ~ clothing, + .data = df, + .fun = function(x) colSums(x) +) + +} +\seealso{ +\code{\link[=weave]{weave()}} \code{\link[=lapply]{lapply()}} \code{\link[=LinkMap]{LinkMap()}} \code{\link[=MultiFactor]{MultiFactor()}} +} diff --git a/man/subgroup_to_tbl.Rd b/man/weave_to_tbl.Rd similarity index 58% rename from man/subgroup_to_tbl.Rd rename to man/weave_to_tbl.Rd index 2c09656..191b29f 100644 --- a/man/subgroup_to_tbl.Rd +++ b/man/weave_to_tbl.Rd @@ -1,20 +1,20 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tidy.R -\name{subgroup_to_tbl} -\alias{subgroup_to_tbl} +% Please edit documentation in R/weave_to_tbl.R +\name{weave_to_tbl} +\alias{weave_to_tbl} \title{Expand a table based on possibly overlapping group membership.} \usage{ -subgroup_to_tbl(x, link, .path, .index = "row.names") +weave_to_tbl(x, .path, .data, .index = "row.names") } \arguments{ -\item{x}{\verb{A table}. A \code{data.frame}, \code{matrix}, other object with rows and -columns. Should have a \code{cbind} method.} - -\item{link}{a \code{MultiFactor}.} +\item{x}{a \code{MultiFactor}.} \item{.path}{either a \code{formula} or a `character vector`` of length 2 with the names of the desired combination of feature types.} +\item{.data}{\verb{A table}. A \code{data.frame}, \code{matrix}, other object with rows and +columns. Should have a \code{cbind} method.} + \item{.index}{\verb{Character scalar} Column to look for feature IDs to link. Default: "row.names".} } @@ -27,16 +27,16 @@ Expand a table into a tidy table suitable for tidyverse-stype operations. } \examples{ # Prepare data -link <- trade_posts() +x <- trade_posts() -# Generate small example feature table 'x'. -n <- nlevels(link)[["clothing"]] -x <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) +# Generate small example feature table 'df'. +n <- nlevels(x)[["clothing"]] +df <- replicate(10, rbinom(n, rbinom(n, 100, runif(n)), runif(n))) #' # Ensure rownames correspond to the second (RHS) variable in the formula. -x <- as.data.frame(x, row.names = levels(link)$clothing) +df <- as.data.frame(df, row.names = levels(x)$clothing) # Apply arbitrary code to x based on group membership -subgroup_to_tbl(x, link, .path = fruit ~ clothing) +weave_to_tbl(x, .path = fruit ~ clothing, .data = df) } diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 1ef19ea..477bc7b 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -20,10 +20,10 @@ reference: - weave - weave-methods - weave_coverage - - stack - - select_path - - subgroup_apply - - subgroup_to_tbl + - stack-methods + - weave_apply + - weave_apply-methods + - weave_to_tbl - title: Classes - contents: - MultiFactor @@ -32,6 +32,10 @@ reference: - LinkMap - LinkMap-methods - nlevels + - factor_path + - factor_path-methods + - select_path + - select_path-methods - title: Converters - contents: - as.MultiFactor diff --git a/tests/testthat/test-weave-formula-utils.R b/tests/testthat/test-weave-formula-utils.R deleted file mode 100644 index 02b5e04..0000000 --- a/tests/testthat/test-weave-formula-utils.R +++ /dev/null @@ -1,8 +0,0 @@ -test_that("Detailed formula parsing works", { - f <- a ~ b + c ~ d + e + f ~ g - res <- lapply(.path_prep_fm_detailed(f), deparse1) - expect_identical( - res, list("a ~ b + c", "b + c ~ d + e + f", "d + e + f ~ g") - ) - -}) diff --git a/vignettes/MultiFactor.Rmd b/vignettes/MultiFactor.Rmd index f02eb4a..a3ef79b 100644 --- a/vignettes/MultiFactor.Rmd +++ b/vignettes/MultiFactor.Rmd @@ -300,20 +300,21 @@ rownames(clothing_table) <- levels(tp)$clothing clothing_table ``` -## subgroup_apply -`subgroup_apply` allows us to run arbitrary code on subsets of a table, based on +## weave_apply +`weave_apply` allows us to run arbitrary code on subsets of a table, based on groupings on the left hand of the formula: ```{r 'subgroup-apply'} -subgroup_apply( - X = clothing_table, LINK = tp, BY = fruit ~ clothing, FUN = as.data.frame +weave_apply( + .x = tp, .path = fruit ~ clothing, + .data = clothing_table, .fun = as.data.frame ) # More complex example: # For all subgroups of clothing corresponding to one particular fruit, if that # group has more than two rows (types of clothing), fit a statistical model. # -subgroup_apply( - clothing_table, tp, fruit ~ clothing, FUN = function(x) { +weave_apply( + tp, fruit ~ clothing, clothing_table, function(x) { if( NROW(x) <= 2 ) return( NULL ) # else: summary( lm(V1 ~ V2, data = x) ) @@ -321,11 +322,11 @@ subgroup_apply( ) ``` -## Compatibility with the tidyverse: `subgroup_to_tbl` -For those who prefer to use `tidyverse`, `subgroup_to_tbl()` returns a tidy +## Compatibility with the tidyverse: `weave_to_tbl` +For those who prefer to use `tidyverse`, `weave_to_tbl()` returns a tidy wide-format table, ready to be grouped based on the first two columns. ```{r 'subgroup-tbl'} -subgroup_to_tbl(clothing_table, tp, fruit ~ clothing) +weave_to_tbl(tp, .path = fruit ~ clothing, .data = clothing_table) ``` ## Reading and parsing adjaceny list-formatted files From 4baa3e1e2e94304f87e8feaef38038aa910ab1d2 Mon Sep 17 00:00:00 2001 From: thomaz Date: Fri, 17 Jul 2026 15:36:09 +0200 Subject: [PATCH 3/4] move doclisting from suggests to imports --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ea0ee1f..0c85af3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -18,7 +18,8 @@ Imports: generics, Matrix, forcats, - igraph + igraph, + doclisting License: GPL-3 LazyData: false Encoding: UTF-8 @@ -29,7 +30,6 @@ Suggests: ggplot2, ragg, systemfonts, - doclisting, knitr, rmarkdown, testthat (>= 3.0.0) From 4c55be44e0f919888b62aab003817de9663dcd7f Mon Sep 17 00:00:00 2001 From: thomaz Date: Fri, 17 Jul 2026 15:40:51 +0200 Subject: [PATCH 4/4] Drop doclisting from imports --- DESCRIPTION | 3 +-- R/AllGenerics.R | 11 ++++------- man/select_path-generic.Rd | 6 +----- man/weave-generic.Rd | 5 +---- man/weave_apply-generic.Rd | 5 +---- 5 files changed, 8 insertions(+), 22 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0c85af3..74771a4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -18,8 +18,7 @@ Imports: generics, Matrix, forcats, - igraph, - doclisting + igraph License: GPL-3 LazyData: false Encoding: UTF-8 diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 02e3881..4f62b18 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -48,8 +48,7 @@ as.MultiFactor <- S7::new_generic("as.MultiFactor", "x") #' @rdname weave-generic #' @name weave-generic #' @description `weave()` is an S7 generic that finds a path through a -#' relational object with methods available for the following classes: -#' `r doclisting::methods_list("weave")` +#' relational object. #' #' @param x input object #' @param .path either a `formula` or a `character vector` of length 2 with the @@ -71,8 +70,7 @@ weave <- S7::new_generic("weave", "x", function(x, .path, ...) { #' @name weave_apply-generic #' @description `weave_apply()` is an S7 generic that finds a path through a #' relational object and evaluates provided code to each corresponding -#' subset of an input table. It is available for the following classes: -#' `r doclisting::methods_list("weave_apply")` +#' subset of an input table. #' #' @param .x input relational object to dispatch on. #' @param .path either a `formula` or a `character vector` of length 2 with the @@ -97,9 +95,8 @@ weave_apply <- S7::new_generic( #' @name select_path-generic #' @rdname select_path-generic #' @description `select_path()` is an S7 generic that finds and returns a path -#' through a relational object, with methods available for the following -#' classes: -#' `r doclisting::methods_list("select_path")` +#' through a relational object. +#' #' @param x input object #' @param .path either a `formula` or a `character vector` of length 2 with the #' names of the desired combination of feature types. diff --git a/man/select_path-generic.Rd b/man/select_path-generic.Rd index a98dcb3..96e4ab6 100644 --- a/man/select_path-generic.Rd +++ b/man/select_path-generic.Rd @@ -20,11 +20,7 @@ a (list of) character vector(s). } \description{ \code{select_path()} is an S7 generic that finds and returns a path -through a relational object, with methods available for the following -classes: -\itemize{ -\item \code{MultiFactor::MultiFactor} -} +through a relational object. } \examples{ # Available methods: diff --git a/man/weave-generic.Rd b/man/weave-generic.Rd index 909242c..025a347 100644 --- a/man/weave-generic.Rd +++ b/man/weave-generic.Rd @@ -20,10 +20,7 @@ a \code{LinkMap} or \code{matrix}. } \description{ \code{weave()} is an S7 generic that finds a path through a -relational object with methods available for the following classes: -\itemize{ -\item \code{MultiFactor::MultiFactor} -} +relational object. } \examples{ # Available methods: diff --git a/man/weave_apply-generic.Rd b/man/weave_apply-generic.Rd index 991b821..d7b90c4 100644 --- a/man/weave_apply-generic.Rd +++ b/man/weave_apply-generic.Rd @@ -25,10 +25,7 @@ a list containing the results of \code{.fun}. \description{ \code{weave_apply()} is an S7 generic that finds a path through a relational object and evaluates provided code to each corresponding -subset of an input table. It is available for the following classes: -\itemize{ -\item \code{MultiFactor::MultiFactor} -} +subset of an input table. } \examples{ # Available methods: