From 6fecafcf39239cfb6a645e90df022ce0c198efe2 Mon Sep 17 00:00:00 2001 From: Your Name Date: Thu, 27 Jul 2023 13:31:44 -0400 Subject: [PATCH 01/83] add label sequence generator --- R/labels.R | 88 ++++++++++++++++++++++++++++++++++++ tests/testthat/test-labels.R | 8 ++++ 2 files changed, 96 insertions(+) create mode 100644 R/labels.R create mode 100644 tests/testthat/test-labels.R diff --git a/R/labels.R b/R/labels.R new file mode 100644 index 00000000..b7bd8825 --- /dev/null +++ b/R/labels.R @@ -0,0 +1,88 @@ +#' Generate a sequence of labels with custom formatting options +#' +#' @param from An integer specifying the starting value (inclusive) of the sequence. +#' @param to An integer specifying the ending value (inclusive) of the sequence. +#' @param by An integer specifying the increment between values in the sequence. +#' @param length An integer specifying the desired length of the sequence. +#' @param prefix A character string to be prepended to the labels. +#' @param suffix A character string to be appended to the labels. +#' @param sep_prefix A character string used to separate the prefix from the labels. +#' @param sep_suffix A character string used to separate the suffix from the labels. +#' @param leading_zero A logical value indicating whether to add leading zeros to the labels. +#' If integer, then pad based on the number supplied. +#' +#' @return A character vector containing the labels generated from the sequence. +#' +#' @examples +#' # Example usage of the function +#' label_seq_to_length(to = 10, length = 5, by = 2) +#' @name label_seq +NULL + +#' @rdname label_seq +#' @export +label_seq_from_to <- function(from = 1L, to = 1L, by = 1L, + prefix = "", suffix = "", + sep_prefix = "", sep_suffix = "", + leading_zero = TRUE) { + + levels <- seq(from = from, to = to, by = by) + label_form(levels, leading_zero, + prefix, suffix, + sep_prefix, sep_suffix) +} + +#' @rdname label_seq +#' @export +label_seq_from_length <- function(from = 1L, length = 1L, by = 1L, + prefix = "", suffix = "", + sep_prefix = "", sep_suffix = "", + leading_zero = TRUE) { + + levels <- seq(from = from, by = by, length.out = length) + label_form(levels, leading_zero, + prefix, suffix, + sep_prefix, sep_suffix) +} + +#' @rdname label_seq +#' @export +label_seq_to_length <- function(to = 1L, length = 1L, by = 1L, + prefix = "", suffix = "", + sep_prefix = "", sep_suffix = "", + leading_zero = TRUE) { + + levels <- seq(to = to, by = by, length.out = length) + label_form(levels, leading_zero, + prefix, suffix, + sep_prefix, sep_suffix) +} + +#' @rdname label_seq +#' @export +label_seq_length <- function(length = 1L, + prefix = "", suffix = "", + sep_prefix = "", sep_suffix = "", + leading_zero = TRUE) { + + levels <- seq_len(length) + label_form(levels, leading_zero, + prefix, suffix, + sep_prefix, sep_suffix) +} + + + + + +label_form <- function(levels, leading_zero, + prefix, suffix, + sep_prefix, sep_suffix) { + form <- ifelse(is.numeric(leading_zero), + paste0("%s%s%.", leading_zero, "d%s%s"), + ifelse(leading_zero, + paste0("%s%s%.", ndigits(max(levels)), "d%s%s"), + "%s%s%d%s%s")) + + sprintf(form, prefix, sep_prefix, levels, sep_suffix, suffix) +} diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R new file mode 100644 index 00000000..b8c0c85e --- /dev/null +++ b/tests/testthat/test-labels.R @@ -0,0 +1,8 @@ +test_that("label works", { + expect_equal(label_seq_from_to(from = 8, to = 10, by = 2), c("08", "10")) + expect_equal(label_seq_from_to(from = 8, to = 10, leading_zero = 3), c("008", "009", "010")) + expect_equal(label_seq_from_length(from = 8, length = 3, prefix = "P", sep_prefix = "-"), c("P-08", "P-09", "P-10")) + expect_equal(label_seq_to_length(to = 10, length = 3, suffix = "P", sep_suffix = "-"), c("08-P", "09-P", "10-P")) + expect_equal(label_seq_length(length = 3, prefix = "P", sep_prefix = "-"), c("P-1", "P-2", "P-3")) + +}) From 03a00fe4196164ae6deedf0a65ceffc359d8e560 Mon Sep 17 00:00:00 2001 From: Your Name Date: Thu, 27 Jul 2023 14:49:48 -0400 Subject: [PATCH 02/83] factor generator --- R/labels.R | 33 ++++++++++++++++++++++++++++++--- 1 file changed, 30 insertions(+), 3 deletions(-) diff --git a/R/labels.R b/R/labels.R index b7bd8825..445055e9 100644 --- a/R/labels.R +++ b/R/labels.R @@ -1,5 +1,8 @@ #' Generate a sequence of labels with custom formatting options #' +#' These can be handy for generating pseudo labels for the levels or +#' factor names using `fct_generator` +#' #' @param from An integer specifying the starting value (inclusive) of the sequence. #' @param to An integer specifying the ending value (inclusive) of the sequence. #' @param by An integer specifying the increment between values in the sequence. @@ -14,8 +17,9 @@ #' @return A character vector containing the labels generated from the sequence. #' #' @examples -#' # Example usage of the function #' label_seq_to_length(to = 10, length = 5, by = 2) +#' label_seq_from_to(from = 8, to = 10, leading_zero = 3) +#' label_seq_length(10, leading_zero = FALSE) #' @name label_seq NULL @@ -73,8 +77,6 @@ label_seq_length <- function(length = 1L, - - label_form <- function(levels, leading_zero, prefix, suffix, sep_prefix, sep_suffix) { @@ -86,3 +88,28 @@ label_form <- function(levels, leading_zero, sprintf(form, prefix, sep_prefix, levels, sep_suffix, suffix) } + + +#' Factor name generator +#' +#' Generate a factor with custom levels and repetitions. +#' +#' This function creates a factor with custom labels and specified repetitions for each label. +#' +#' @param labels A character vector specifying the custom labels for the factor levels. +#' @param nlevels An integer or a vector of integers indicating the number of repetitions for each label. +#' If a single integer is provided, it is recycled to match the length of \code{labels}. +#' If a vector is provided, it should have the same length as \code{labels}. +#' +#' @return A factor with custom levels and repetitions. +#' +#' @examples +#' # Example usage of the function +#' fct_generator(labels = c("A", "B", "C"), nlevels = 3) +#' +#' @export +fct_generator <- function(labels, nlevels) { + nlevels <- as.list(vctrs::vec_recycle(nlevels, length(labels))) + names(nlevels) <- labels + structure(nlevels, class = "fct_names") +} From aa5f5b6e9703165724f5001020ccd40a846b7cf2 Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 28 Jul 2023 17:21:39 -0400 Subject: [PATCH 03/83] separation in doc for allot functions --- R/allot.R | 39 +++++++++++++++++------- man/allot.Rd | 75 ---------------------------------------------- man/allot_table.Rd | 18 +++++++++++ man/allot_trts.Rd | 50 +++++++++++++++++++++++++++++++ man/allot_units.Rd | 46 ++++++++++++++++++++++++++++ 5 files changed, 143 insertions(+), 85 deletions(-) delete mode 100644 man/allot.Rd create mode 100644 man/allot_table.Rd create mode 100644 man/allot_trts.Rd create mode 100644 man/allot_units.Rd diff --git a/R/allot.R b/R/allot.R index 07bdb2e8..3c0a3c2c 100644 --- a/R/allot.R +++ b/R/allot.R @@ -1,9 +1,9 @@ -#' Define the possible allocation of treatments to units +#' Define allotment of treatments to units #' #' @description -#' This function adds the edges between variable nodes to -#' specify the mapping of units to treatment. This function -#' does not actually assign specific treatment levels onto actual units. +#' This function adds the edges between factor nodes to describe the +#' high-level relationship between factors. +#' This function does not actually assign edges between level nodes. #' #' @param ... One-sided or two-sided formula. If the input is a one-sided formula #' then the whole treatment is applied to the specified unit. @@ -20,11 +20,7 @@ #' pest ~ block) #' #' @return Return an edibble design. -#' @name allot #' @seealso assign -NULL - -#' @rdname allot #' @export allot_trts <- function(.edibble, ..., .record = TRUE) { @@ -75,7 +71,26 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { } -#' @rdname allot + +#' Define allotment of units to nested units +#' +#' @description +#' This function adds the edges between factor nodes to describe the +#' high-level relationship between factors. +#' This function does not actually assign edges between level nodes. +#' +#' @param ... A two-sided formula. +#' @inheritParams assign +#' @inheritParams set_units +#' @family user-facing functions +#' @examples +#' design() %>% +#' set_units(block = 10, +#' plot = 20) %>% +#' allot_units(block ~ plot) +#' +#' @return Return an edibble design. +#' @seealso assign #' @export allot_units <- function(.edibble, ..., .record = TRUE) { not_edibble(.edibble) @@ -145,7 +160,11 @@ allot_units <- function(.edibble, ..., .record = TRUE) { } -#' @rdname allot +#' Allot treatments to units and serve table +#' +#' This function is a short hand that combines `allot_trts()`, `assign_trts()` +#' and `serve_table()`. +#' #' @export allot_table <- function(.edibble, ..., order = "random", seed = NULL, constrain = nesting_structure(.edibble)) { diff --git a/man/allot.Rd b/man/allot.Rd deleted file mode 100644 index 13065c7f..00000000 --- a/man/allot.Rd +++ /dev/null @@ -1,75 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/allot.R -\name{allot} -\alias{allot} -\alias{allot_trts} -\alias{allot_units} -\alias{allot_table} -\title{Define the possible allocation of treatments to units} -\usage{ -allot_trts(.edibble, ..., .record = TRUE) - -allot_units(.edibble, ..., .record = TRUE) - -allot_table( - .edibble, - ..., - order = "random", - seed = NULL, - constrain = nesting_structure(.edibble) -) -} -\arguments{ -\item{.edibble}{An edibble design (\code{edbl_design}), an edibble data frame (\code{edbl_table}) or an -object that contains the edibble data frame in the attribute -\code{design}.} - -\item{...}{One-sided or two-sided formula. If the input is a one-sided formula -then the whole treatment is applied to the specified unit.} - -\item{.record}{Whether to record the step.} - -\item{order}{A character vector signifying the apportion of treatments to units. -The value should be either "random", "systematic", "systematic-random" or a class name corresponding to the algorithm for order_trts(). -"random" allocates the treatment randomly to units based on specified allotment with restrictions -implied by unit structure. -"systematic" allocates the treatment in a systematic order to units. -"systematic-random" allocates the treatment in a systematic order to units but -where it is not possible to divide treatments equally (as the number of units are not divisible -by the number of levels of the treatment factor), then the extras are chosen randomly.} - -\item{seed}{A scalar value used to set the seed so that the result is reproducible.} - -\item{constrain}{The nesting structure for units.} -} -\value{ -Return an edibble design. -} -\description{ -This function adds the edges between variable nodes to -specify the mapping of units to treatment. This function -does not actually assign specific treatment levels onto actual units. -} -\examples{ -design() \%>\% - set_units(block = 10, - plot = nested_in(block, 3)) \%>\% - set_trts(treat = c("A", "B", "C"), - pest = c("a", "b")) \%>\% - allot_trts(treat ~ plot, - pest ~ block) - -} -\seealso{ -assign - -Other user-facing functions: -\code{\link{design}()}, -\code{\link{expect_rcrds}()}, -\code{\link{export_design}()}, -\code{\link{serve_table}()}, -\code{\link{set_rcrds}()}, -\code{\link{set_trts}()}, -\code{\link{set_units}()} -} -\concept{user-facing functions} diff --git a/man/allot_table.Rd b/man/allot_table.Rd new file mode 100644 index 00000000..05b8a67d --- /dev/null +++ b/man/allot_table.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/allot.R +\name{allot_table} +\alias{allot_table} +\title{Allot treatments to units and serve table} +\usage{ +allot_table( + .edibble, + ..., + order = "random", + seed = NULL, + constrain = nesting_structure(.edibble) +) +} +\description{ +This function is a short hand that combines \code{allot_trts()}, \code{assign_trts()} +and \code{serve_table()}. +} diff --git a/man/allot_trts.Rd b/man/allot_trts.Rd new file mode 100644 index 00000000..11899414 --- /dev/null +++ b/man/allot_trts.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/allot.R +\name{allot_trts} +\alias{allot_trts} +\title{Define allotment of treatments to units} +\usage{ +allot_trts(.edibble, ..., .record = TRUE) +} +\arguments{ +\item{.edibble}{An edibble design (\code{edbl_design}), an edibble data frame (\code{edbl_table}) or an +object that contains the edibble data frame in the attribute +\code{design}.} + +\item{...}{One-sided or two-sided formula. If the input is a one-sided formula +then the whole treatment is applied to the specified unit.} + +\item{.record}{Whether to record the step.} +} +\value{ +Return an edibble design. +} +\description{ +This function adds the edges between factor nodes to describe the +high-level relationship between factors. +This function does not actually assign edges between level nodes. +} +\examples{ +design() \%>\% + set_units(block = 10, + plot = nested_in(block, 3)) \%>\% + set_trts(treat = c("A", "B", "C"), + pest = c("a", "b")) \%>\% + allot_trts(treat ~ plot, + pest ~ block) + +} +\seealso{ +assign + +Other user-facing functions: +\code{\link{allot_units}()}, +\code{\link{design}()}, +\code{\link{expect_rcrds}()}, +\code{\link{export_design}()}, +\code{\link{serve_table}()}, +\code{\link{set_rcrds}()}, +\code{\link{set_trts}()}, +\code{\link{set_units}()} +} +\concept{user-facing functions} diff --git a/man/allot_units.Rd b/man/allot_units.Rd new file mode 100644 index 00000000..56a47df4 --- /dev/null +++ b/man/allot_units.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/allot.R +\name{allot_units} +\alias{allot_units} +\title{Define allotment of units to nested units} +\usage{ +allot_units(.edibble, ..., .record = TRUE) +} +\arguments{ +\item{.edibble}{An edibble design (\code{edbl_design}), an edibble data frame (\code{edbl_table}) or an +object that contains the edibble data frame in the attribute +\code{design}.} + +\item{...}{A two-sided formula.} + +\item{.record}{Whether to record the step.} +} +\value{ +Return an edibble design. +} +\description{ +This function adds the edges between factor nodes to describe the +high-level relationship between factors. +This function does not actually assign edges between level nodes. +} +\examples{ +design() \%>\% + set_units(block = 10, + plot = 20) \%>\% + allot_units(block ~ plot) + +} +\seealso{ +assign + +Other user-facing functions: +\code{\link{allot_trts}()}, +\code{\link{design}()}, +\code{\link{expect_rcrds}()}, +\code{\link{export_design}()}, +\code{\link{serve_table}()}, +\code{\link{set_rcrds}()}, +\code{\link{set_trts}()}, +\code{\link{set_units}()} +} +\concept{user-facing functions} From 5a2ecc50cfd30d8c7aa896818cd77fe321d11904 Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 28 Jul 2023 17:21:54 -0400 Subject: [PATCH 04/83] clean up attrs R --- R/attrs.R | 31 +++++++++---------------------- 1 file changed, 9 insertions(+), 22 deletions(-) diff --git a/R/attrs.R b/R/attrs.R index 648904b2..8679d7fd 100644 --- a/R/attrs.R +++ b/R/attrs.R @@ -7,7 +7,6 @@ #' in the factor. #' @param label A string that denotes the long name of the factor. #' @param description The text description of the factor. -#' @param unit_of_measure A string denoting the unit of measurement if applicable. #' @param class An optional subclass. #' @param ... A name-value pair of attributes. The value must be a scalar and #' attributed to the whole factor (not individual levels). @@ -19,16 +18,15 @@ #' @return An `edbl_lvls` object. #' @export fct_attrs <- function(levels = NULL, - label = NULL, - description = NULL, - unit_of_measure = NULL, - class = NULL, - ...) { + label = NULL, + description = NULL, + n = NULL, + class = NULL, + ...) { class(levels) <- c(class, class(levels)) attr(levels, "label") <- label attr(levels, "description") <- description - attr(levels, "unit_of_measure") <- unit_of_measure dots <- dots_list(..., .named = TRUE, .homonyms = "keep", .ignore_empty = "all") dots_names <- names(dots) for(i in seq_along(dots)) { @@ -60,20 +58,9 @@ fct_attrs <- function(levels = NULL, #' @return An edbl_lvls object. #' @export lvl_attrs <- function(levels = NULL, - labels = NULL, - prefix = "", - suffix = "", - sep = edibble_labels_opt("sep"), - include_leading_zero = edibble_labels_opt("leading_zero"), - data = NULL, ...) { - form <- ifelse(vec_is(levels, numeric(), 1), - ifelse(include_leading_zero, - paste0("%s%s%.", ndigits(max(levels)), "d%s"), - "%s%s%d%s"), - "%s%s%s%s") - name <- sprintf(form, prefix, sep, levels, suffix) - labels <- labels %||% name - new_rcrd(c(list2(name = name, label = labels, ...), data), class = "edbl_lvls") + data = NULL, ...) { + + new_rcrd(c(list2(value = levels, ...), data), class = "edbl_lvls") } #' @export @@ -83,7 +70,7 @@ format.edbl_lvls <- function(x, ...) { #' @export levels.edbl_lvls <- function(x, ...) { - lvl_data(x)$name + lvl_data(x)$value } From 1082e49b36aa8cb8e23902001d4ed572d4107b9f Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 28 Jul 2023 17:22:18 -0400 Subject: [PATCH 05/83] rename initialise to empty --- R/design.R | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/R/design.R b/R/design.R index e2f6d597..6babbf4b 100644 --- a/R/design.R +++ b/R/design.R @@ -20,7 +20,7 @@ design <- function(name = NULL, .record = TRUE, seed = NULL, kitchen = Kitchen) if(.record) record_step() save_seed(seed) structure(list(name = name, - graph = initialise_edibble_graph(), + graph = empty_edibble_graph(), kitchen = kitchen), class = c("edbl_design", "edbl")) } @@ -34,16 +34,26 @@ redesign <- function(.data, name = NULL, .record = TRUE, seed = NULL, kitchen = # initialise graph structure ----------------------------------------------- -initialise_edibble_graph <- function() { - fnodes <- data.frame(id = integer(), name = character(), class = character(), stringsAsFactors = FALSE) - lnodes <- data.frame(idvar = integer(), id = integer(), name = character(), stringsAsFactors = FALSE) - edges <- data.frame(from = integer(), to = integer(), - alloc = integer(), type = character(), - stringsAsFactors = FALSE) - structure(list(nodes = fnodes, - edges = edges, +empty_edibble_graph <- function() { + fnodes <- tibble::tibble(id = integer(), + role = character(), + name = character(), + attrs = list()) + lnodes <- list() + fedges <- tibble::tibble(from = integer(), to = integer(), + type = character(), group = integer(), + attrs = list()) + ledges <- tibble::tibble(from = integer(), to = integer(), + attrs = list()) + structure(list(factors = list(nodes = fnodes, + edges = fedges), levels = list(nodes = lnodes, - edges = edges)), + edges = ledges)), class = "edbl_graph") } +new_lnode <- function(ids, vals, data) { + tibble::tibble(id = ids, + value = vals, + attrs = data) +} From b21df1ca3b78f7d3477a0335218b58d6a67a902b Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 28 Jul 2023 17:22:33 -0400 Subject: [PATCH 06/83] suggestion of new functions commented --- R/fcts.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/fcts.R b/R/fcts.R index 330b89d3..9e92f6f7 100644 --- a/R/fcts.R +++ b/R/fcts.R @@ -187,3 +187,5 @@ vec_cast.edbl_trt.character <- function(x, to, ...) as.character(x) vec_cast.character.edbl_trt <- function(x, to, ...) x +# ADDME add_units(exist = TRUE), reset_units(exist = FALSE) + From 9f9a96723501c9c41a147c2bfcb314630b58b829 Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 28 Jul 2023 17:22:45 -0400 Subject: [PATCH 07/83] update label maker --- R/labels.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/R/labels.R b/R/labels.R index 445055e9..33931cbb 100644 --- a/R/labels.R +++ b/R/labels.R @@ -28,7 +28,7 @@ NULL label_seq_from_to <- function(from = 1L, to = 1L, by = 1L, prefix = "", suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE) { + leading_zero = edibble_labels_opt("leading_zero")) { levels <- seq(from = from, to = to, by = by) label_form(levels, leading_zero, @@ -41,7 +41,7 @@ label_seq_from_to <- function(from = 1L, to = 1L, by = 1L, label_seq_from_length <- function(from = 1L, length = 1L, by = 1L, prefix = "", suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE) { + leading_zero = edibble_labels_opt("leading_zero")) { levels <- seq(from = from, by = by, length.out = length) label_form(levels, leading_zero, @@ -54,7 +54,7 @@ label_seq_from_length <- function(from = 1L, length = 1L, by = 1L, label_seq_to_length <- function(to = 1L, length = 1L, by = 1L, prefix = "", suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE) { + leading_zero = edibble_labels_opt("leading_zero")) { levels <- seq(to = to, by = by, length.out = length) label_form(levels, leading_zero, @@ -67,7 +67,7 @@ label_seq_to_length <- function(to = 1L, length = 1L, by = 1L, label_seq_length <- function(length = 1L, prefix = "", suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE) { + leading_zero = edibble_labels_opt("leading_zero")) { levels <- seq_len(length) label_form(levels, leading_zero, @@ -109,7 +109,7 @@ label_form <- function(levels, leading_zero, #' #' @export fct_generator <- function(labels, nlevels) { - nlevels <- as.list(vctrs::vec_recycle(nlevels, length(labels))) - names(nlevels) <- labels - structure(nlevels, class = "fct_names") + lvl_list <- as.list(vctrs::vec_recycle(nlevels, length(labels))) + names(lvl_list) <- labels + structure(lvl_list, class = "fct_names") } From 6da742d51767e1e9d12fd36b83023d83c4b640f0 Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 28 Jul 2023 17:23:05 -0400 Subject: [PATCH 08/83] update to kitchen --- R/kitchen.R | 299 ++++++++++++++++++++++++++-------------------------- R/utils.R | 16 +-- 2 files changed, 159 insertions(+), 156 deletions(-) diff --git a/R/kitchen.R b/R/kitchen.R index 4dd4e5be..dc6e6708 100644 --- a/R/kitchen.R +++ b/R/kitchen.R @@ -5,7 +5,7 @@ #' The Kitchen contains a set of operations to manipulate the nodes and edges of #' the edibble design object. #' -#' @param class The class for the vertex/node. +#' @param role The role for the vertex/node. #' @param data The nodes data #' @param name The name of the vertex. #' @param id The id of the corresponding node. @@ -28,44 +28,49 @@ Kitchen <- R6::R6Class("Kitchen", #' @description - #' Get the id based on either the name of the factor node or - #' the class. - fct_id = function(name = NULL, class = NULL) { + #' Get the id based on either the name of the factor node. + #' If none supplied then it will give all. + fct_id_by_name = function(name = NULL) { fnodes <- self$fct_nodes - if(is_null(class)) { - name_to_id <- pull(fnodes, id, name) - name <- name %||% names(name_to_id) - unname(name_to_id[as.character(name)]) - } else { - fnodes[fnodes$class %in% class, "id"] - } + name_to_id <- pull(fnodes, id, name) + name <- name %||% names(name_to_id) + unname(name_to_id[as.character(name)]) }, #' @description - #' Get the id based on name of level node - lvl_id = function(name = NULL, class = NULL) { + #' Get all ids associated with a role. + fct_id_by_role = function(role = NULL) { fnodes <- self$fct_nodes + fnodes[fnodes$role %in% role, "id"] + }, + + #' @description + #' Get the id based on name of level node. + #' If no name provided, all names returned. + #' FIXME + lvl_id_by_name = function(name = NULL) { lnodes <- self$lvl_nodes - if(is_null(class)) { - name_to_id <- pull(self$lvl_nodes, id, name) - name <- name %||% names(name_to_id) - unname(name_to_id[as.character(name)]) + name_to_id <- pull(self$lvl_nodes, id, name) + name <- name %||% names(name_to_id) + unname(name_to_id[as.character(name)]) + if(is_null(role)) { + } else { - ids <- fnodes[fnodes$class %in% class, "id"] + ids <- fnodes[fnodes$role %in% role, "id"] lnodes[lnodes$idvar %in% ids, "id"] } }, #' @description - #' Get the factor names based on id or class - fct_names = function(id = NULL, class = NULL) { - private$var_names(self$fct_nodes, id, class) + #' Get the factor names based on id or role + fct_names = function(id = NULL, role = NULL) { + private$var_names(self$fct_nodes, id, role) }, #' @description - #' Get the level names based on id or class - lvl_names = function(id = NULL, class = NULL) { - private$var_names(self$lvl_nodes, id, class) + #' Get the level names based on id or role + lvl_names = function(id = NULL, role = NULL) { + private$var_names(self$lvl_nodes, id, role) }, #' @description @@ -76,8 +81,14 @@ Kitchen <- R6::R6Class("Kitchen", #' @description #' Given node data, append the level nodes - append_lvl_nodes = function(data) { - self$lvl_nodes <- rbind_(self$lvl_nodes, data) + append_lvl_nodes = function(data, fid = NULL) { + lnodes <- self$lvl_nodes + if(is.null(lnodes[[as.character(fid)]])) { + lnodes[[as.character(fid)]] <- new_lnode(data$id, data$value, data$attrs) + } else { + lnodes[[as.character(fid)]] <- rbind_(lnodes[[as.character(fid)]], data) + } + self$lvl_nodes <- lnodes }, #' @description @@ -93,70 +104,70 @@ Kitchen <- R6::R6Class("Kitchen", }, #' @description - #' Get the class of the vertex given the factor id - fct_class = function(id = NULL) { + #' Get the role of the vertex given the factor id + fct_role = function(id = NULL) { nodes <- self$fct_nodes - id_to_class_fct <- pull(nodes, class, id) + id_to_role_fct <- pull(nodes, role, id) ids_fct <- id %||% nodes$id - unname(id_to_class_fct[as.character(ids_fct)]) + unname(id_to_role_fct[as.character(ids_fct)]) }, #' @description - #' Get the class of the vertex given the level id - lvl_class = function(id = NULL) { + #' Get the role of the vertex given the level id + lvl_role = function(id = NULL) { nodes <- self$lvl_nodes - id_to_class_fct <- pull(nodes, class, id) + id_to_role_fct <- pull(nodes, role, id) ids_fct <- id %||% nodes$id - unname(id_to_class_fct[as.character(ids_fct)]) + unname(id_to_role_fct[as.character(ids_fct)]) }, #' @description - #' Get the factor child ids. If `class` is - #' supplied then the child has to fit `class` - fct_child = function(id = NULL, class = NULL) { + #' Get the factor child ids. If `role` is + #' supplied then the child has to fit `role` + fct_child = function(id = NULL, role = NULL) { edges <- subset(self$fct_edges, !type %in% c("depends", "cross")) child_ids <- edges$to parent_ids <- edges$from - child_ids[parent_ids %in% id & child_ids %in% self$fct_id(class = class)] + child_ids[parent_ids %in% id & child_ids %in% self$fct_id_by_role(role = role)] }, #' @description #' Get the level child ids - lvl_child = function(id = NULL, class = NULL) { + lvl_child = function(id = NULL, role = NULL) { edges <- self$lvl_edges child_ids <- edges$to parent_ids <- edges$from - child_ids[parent_ids %in% id & child_ids %in% self$lvl_id(class = class)] + child_ids[parent_ids %in% id & child_ids %in% self$lvl_id(role = role)] }, #' @description #' Get the factor parent ids - fct_parent = function(id = NULL, class = NULL) { + fct_parent = function(id = NULL, role = NULL) { edges <- subset(self$fct_edges, !type %in% c("depends", "cross")) - class_ids <- self$fct_id(class = class) + role_ids <- self$fct_id_by_role(role = role) parent_ids <- edges$from child_ids <- edges$to - parent_ids[child_ids %in% id & parent_ids %in% class_ids & child_ids %in% class_ids] + parent_ids[child_ids %in% id & parent_ids %in% role_ids & child_ids %in% role_ids] }, #' @description #' Get the level parent ids - lvl_parent = function(id = NULL, class = NULL) { + lvl_parent = function(id = NULL, role = NULL) { edges <- self$lvl_edges - class_ids <- self$lvl_id(class = class) + role_ids <- self$lvl_id(role = role) parent_ids <- edges$from child_ids <- edges$to - parent_ids[child_ids %in% id & parent_ids %in% class_ids & child_ids %in% class_ids] + parent_ids[child_ids %in% id & parent_ids %in% role_ids & child_ids %in% role_ids] }, #' @description #' Get the factor ancestor ids - fct_ancestor = function(id = NULL, class = NULL) { + fct_ancestor = function(id = NULL, role = NULL) { out <- unique(id) - parent_ids <- self$fct_parent(id = id, class = class) + parent_ids <- self$fct_parent(id = id, role = role) if(!is_empty(parent_ids)) { - out <- unique(c(out, self$fct_ancestor(id = parent_ids, class = class))) + out <- unique(c(out, self$fct_ancestor(id = parent_ids, role = role))) } out }, @@ -164,11 +175,11 @@ Kitchen <- R6::R6Class("Kitchen", #' @description #' Get the level ancestor ids - lvl_ancestor = function(id = NULL, class = NULL) { + lvl_ancestor = function(id = NULL, role = NULL) { out <- id - parent_ids <- self$lvl_parent(id = id, class = class) + parent_ids <- self$lvl_parent(id = id, role = role) if(!is_empty(parent_ids)) { - out <- c(out, self$lvl_ancestor(id = parent_ids, class = class)) + out <- c(out, self$lvl_ancestor(id = parent_ids, role = role)) } out }, @@ -176,26 +187,24 @@ Kitchen <- R6::R6Class("Kitchen", #' @description #' Get the levels for each factor fct_levels = function(id = NULL, name = NULL) { - qid <- id %||% self$fct_id(name) + qid <- id %||% self$fct_id_by_name(name) lnodes <- self$lvl_nodes - out <- lnodes[lnodes$idvar %in% qid, ] - out$var <- self$fct_names(out$idvar) - split(out$name, out$var) + lnodes[as.character(qid)] }, #' @description #' Setup the node and edge data - setup_data = function(fresh, name, class) { + setup_data = function(fresh, name, role) { setup_data_internal <- private$next_method("setup_data", class(fresh)) - setup_data_internal(fresh, name, class) + setup_data_internal(fresh, name, role) }, #' @description #' Add the anatomy structure - add_anatomy = function(fresh, name, class) { - if(class=="edbl_unit") { + add_anatomy = function(fresh, name, role) { + if(role=="edbl_unit") { if(is.null(self$design$anatomy)) { self$design$anatomy <- as.formula(paste0("~", name)) } else { @@ -210,11 +219,11 @@ Kitchen <- R6::R6Class("Kitchen", #' @description - #' One of `name`, `id` or `class` is defined to check if it exists. - #' If more than one of the arguments `name`, `id` and `class` are supplied, then + #' One of `name`, `id` or `role` is defined to check if it exists. + #' If more than one of the arguments `name`, `id` and `role` are supplied, then #' the intersection of it will be checked. #' @param abort A logical value to indicate whether to abort if it doesn't exist. - fct_exists = function(name = NULL, id = NULL, class = NULL, abort = TRUE) { + fct_exists = function(name = NULL, id = NULL, role = NULL, abort = TRUE) { exist <- TRUE abort_missing <- function(vars = NULL, msg = NULL) { @@ -231,38 +240,38 @@ Kitchen <- R6::R6Class("Kitchen", fnodes <- self$fct_nodes # at least one node exists - if(is_null(name) & is_null(id) & is_null(class)) { + if(is_null(name) & is_null(id) & is_null(role)) { exist <- nrow(fnodes) > 0 abort_missing(msg = "There are no factor nodes.") - } else if(!is_null(name) & is_null(id) & is_null(class)) { + } else if(!is_null(name) & is_null(id) & is_null(role)) { vexist <- name %in% fnodes$name exist <- all(vexist) abort_missing(vars = name[!vexist]) - } else if(is_null(name) & !is_null(id) & is_null(class)) { + } else if(is_null(name) & !is_null(id) & is_null(role)) { vexist <- id %in% fnodes$id exist <- all(vexist) abort_missing(vars = id[!vexist]) - } else if(is_null(name) & is_null(id) & !is_null(class)) { - exist <- any(class %in% fnodes$class) - abort_missing(msg = sprintf("There are no factors with class%s", - .combine_words(paste0("`", class, "`")))) + } else if(is_null(name) & is_null(id) & !is_null(role)) { + exist <- any(role %in% fnodes$role) + abort_missing(msg = sprintf("There are no factors with role%s", + .combine_words(paste0("`", role, "`")))) - } else if(is_null(name) & !is_null(id) & !is_null(class)) { - sclass <- fnodes[match(id, fnodes$id), "class"] - vexist <- sclass == class + } else if(is_null(name) & !is_null(id) & !is_null(role)) { + srole <- fnodes[match(id, fnodes$id), "role"] + vexist <- srole == role exist <- all(vexist) abort_missing(vars = id[!vexist]) - } else if(!is_null(name) & is_null(id) & !is_null(class)) { - sclass <- fnodes[match(name, fnodes$name), "class"] - vexist <- sclass == class + } else if(!is_null(name) & is_null(id) & !is_null(role)) { + srole <- fnodes[match(name, fnodes$name), "role"] + vexist <- srole == role exist <- all(vexist) abort_missing(vars = name[!vexist]) - } else if(!is_null(name) & !is_null(id) & is_null(class)) { + } else if(!is_null(name) & !is_null(id) & is_null(role)) { sid <- fnodes[match(name, fnodes$name), "id"] vexist <- sid == id exist <- all(vexist) @@ -270,7 +279,7 @@ Kitchen <- R6::R6Class("Kitchen", } else { snodes <- fnodes[match(name, fnodes$name), ] - vexist <- snodes$id == id & snodes$class == class + vexist <- snodes$id == id & snodes$role == role exist <- all(vexist) abort_missing(vars = name[!vexist]) } @@ -281,19 +290,19 @@ Kitchen <- R6::R6Class("Kitchen", #' @description #' Check if treatment exists. trts_exists = function(abort = TRUE) { - self$fct_exists(class = "edbl_trt", abort = abort) + self$fct_exists(role = "edbl_trt", abort = abort) }, #' @description #' Check if unit exists. units_exists = function(abort = TRUE) { - self$fct_exists(class = "edbl_unit", abort = abort) + self$fct_exists(role = "edbl_unit", abort = abort) }, #' @description #' Check if record exists. rcrds_exists = function(abort = TRUE) { - self$fct_exists(class = "edbl_rcrd", abort = abort) + self$fct_exists(role = "edbl_rcrd", abort = abort) } ), @@ -303,8 +312,8 @@ Kitchen <- R6::R6Class("Kitchen", #' @field fct_nodes #' Get the factor nodes fct_nodes = function(data) { - if(missing(data)) return(self$design$graph$nodes) - else self$design$graph$nodes <- data + if(missing(data)) return(self$design$graph$factors$nodes) + else self$design$graph$factors$nodes <- data }, #' @field lvl_nodes @@ -312,7 +321,6 @@ Kitchen <- R6::R6Class("Kitchen", lvl_nodes = function(data) { if(missing(data)) { nodes <- self$design$graph$levels$nodes - nodes$var <- self$fct_names(id = nodes$idvar) return(nodes) } else self$design$graph$levels$nodes <- data @@ -322,12 +330,12 @@ Kitchen <- R6::R6Class("Kitchen", #' Get the factor edges fct_edges = function(data) { if(missing(data)) { - edges <- self$design$graph$edges + edges <- self$design$graph$factors$edges edges$var_from <- self$fct_names(id = edges$from) edges$var_to <- self$fct_names(id = edges$to) return(edges) } else { - self$design$graph$edges <- data + self$design$graph$factors$edges <- data } }, @@ -358,28 +366,18 @@ Kitchen <- R6::R6Class("Kitchen", #' Get the number of nodes in level graph lvl_n = function(value) { if (missing(value)) { - nrow(self$lvl_nodes) + sum(lengths(self$lvl_nodes_list)) } else { stop("Can't set `$lvl_n`.") } }, - #' @field fct_last_id - #' Get the last factor id. - fct_last_id = function() { - ifelse(self$fct_n, max(self$fct_id()), 0L) - }, - #' @field lvl_last_id - #' Get the last level id. - lvl_last_id = function() { - ifelse(self$lvl_n, max(self$lvl_id()), 0L) - }, #' @field fct_leaves #' Get the leave factor ids. fct_leaves = function() { - uids <- self$fct_id(class = "edbl_unit") + uids <- self$fct_id_by_role("edbl_unit") has_child <- map_lgl(uids, function(id) length(intersect(self$fct_child(id), uids)) > 0) uids[!has_child] }, @@ -387,37 +385,37 @@ Kitchen <- R6::R6Class("Kitchen", #' @field rcrd_ids #' Get the ids for all edbl_rcrd factors. rcrd_ids = function() { - self$fct_id(class = "edbl_rcrd") + self$fct_id_by_role("edbl_rcrd") }, #' @field unit_ids #' Get the ids for all edbl_unit factors. unit_ids = function() { - self$fct_id(class = "edbl_unit") + self$fct_id_by_role("edbl_unit") }, #' @field trt_ids #' Get the ids for all edbl_trt factors. trt_ids = function() { - self$fct_id(class = "edbl_trt") + self$fct_id_by_role("edbl_trt") }, #' @field trt_names #' Get the node labels for treatments trt_names = function() { - private$var_names(self$fct_nodes, class = "edbl_trt") + private$var_names(self$fct_nodes, role = "edbl_trt") }, #' @field unit_names #' Get the node labels for units unit_names = function() { - private$var_names(self$fct_nodes, class = "edbl_unit") + private$var_names(self$fct_nodes, role = "edbl_unit") }, #' @field rcrd_names #' Get the node labels for record rcrd_names = function() { - private$var_names(self$fct_nodes, class = "edbl_rcrd") + private$var_names(self$fct_nodes, role = "edbl_rcrd") }, #' @field is_connected @@ -435,18 +433,36 @@ Kitchen <- R6::R6Class("Kitchen", ), private = list( version = NULL, + fct_last_id = 0L, + lvl_last_id = 0L, + + #' @field fct_new_id + #' Get a new factor id. + fct_new_id = function(n = 1) { + ids <- seq(private$fct_last_id + 1, private$fct_last_id + n) + private$fct_last_id <- private$fct_last_id + n + ids + }, + + #' @field lvl_new_id + #' Get a new level id. + lvl_new_id = function(n = 1) { + ids <- seq(private$lvl_last_id + 1, private$lvl_last_id + n) + private$lvl_last_id <- private$lvl_last_id + n + ids + }, - var_names = function(nodes, id, class) { - if(is_null(class)) { + var_names = function(nodes, id, role) { + if(is_null(role)) { id_to_name <- pull(nodes, name, id) ids <- id %||% nodes$id unname(id_to_name[as.character(ids)]) } else { nodes <- self$fct_nodes - if(is_null(class)) { + if(is_null(role)) { nodes$name } else { - nodes[nodes$class %in% class, "name"] + nodes[nodes$role %in% role, "name"] } } }, @@ -461,16 +477,16 @@ Kitchen <- R6::R6Class("Kitchen", return("unimplemented") }, - next_method = function(generic, class) { + next_method = function(generic, role) { fns <- ls(envir = private) - method <- paste0(generic, ".", class[1]) + method <- paste0(generic, ".", role[1]) if(method %in% fns) { private[[method]] } else { - if(length(class)==1L) { + if(length(role)==1L) { private[[paste0(generic, ".default")]] } else { - private$next_method(generic, class[-1]) + private$next_method(generic, role[-1]) } } }, @@ -479,70 +495,57 @@ Kitchen <- R6::R6Class("Kitchen", setup_data.default = function(fresh, name, class) { type <- private$fresh_type(fresh) levels <- switch(type, - "numeric" = fct_attrs(levels = lvl_attrs(1:fresh, prefix = name), + "numeric" = fct_attrs(levels = lvl_attrs(label_seq_length(fresh, prefix = name)), class = class), "unnamed_vector" = fct_attrs(levels = lvl_attrs(fresh), class = class), "named_vector" = fct_attrs(levels = lvl_attrs(names(fresh), rep = unname(fresh)), class = class), - "unimplemented" = abort(paste0("Not sure how to handle ", class(fresh)[1]))) + "unimplemented" = abort(paste0("Not sure how to handle ", role(fresh)[1]))) private$setup_data.edbl_lvls(levels, name, class) }, setup_data.edbl_lvls = function(fresh, name, class) { - fid <- self$fct_last_id + 1L - lid <- self$lvl_last_id + 1L + fid <- private$fct_new_id(n = 1) attrs <- attributes(fresh) - fattrs <- do.call(data.frame, c(attrs[setdiff(names(attrs), c("names", "class"))], - list(stringsAsFactors = FALSE, - id = fid, - name = name, - class = class))) + fattrs <- data.frame(id = fid, name = name, role = class) self$append_fct_nodes(fattrs) lattrs <- lvl_data(fresh) - lattrs$idvar <- fid - lattrs$var <- name - lattrs$id <- lid:(lid + length(fresh) - 1) + lattrs$id <- private$lvl_new_id(length(fresh)) - self$append_lvl_nodes(lattrs) + self$append_lvl_nodes(lattrs, fid) }, - setup_data.formula = function(fresh, name, class) { + setup_data.formula = function(fresh, name, role) { flevels <- self$fct_levels() tt <- terms(fresh) vars <- rownames(attr(tt, "factor")) - private$setup_data.cross_lvls(vars, name, class) + private$setup_data.cross_lvls(vars, name, role) }, - setup_data.edbl_fct = function(fresh, name, class) { - fid <- self$fct_last_id + 1L - lid <- self$lvl_last_id + 1L - - self$append_fct_nodes(data.frame(id = fid, name = name, class = class, - stringsAsFactors = FALSE)) + setup_data.edbl_fct = function(fresh, name, role) { + fid <- private$fct_new_id + self$append_fct_nodes(tibble(id = fid, name = name, role = role)) lvls <- levels(fresh) - lattrs <- data.frame(name = lvls, - label = lvls, - idvar = fid, - var = name, - id = lid:(lid + length(lvls) - 1)) + lattrs <- tibble(id = private$lvl_new_id(length(lvls)), + value = lvls) - self$append_lvl_nodes(lattrs) + self$append_lvl_nodes(lattrs, fid) }, - setup_data.cross_lvls = function(fresh, name, class) { + setup_data.cross_lvls = function(fresh, name, role) { flevels <- self$fct_levels() vars <- fresh pdf <- expand.grid(flevels[vars]) pdf[[name]] <- fct_attrs(levels = lvl_attrs(1:nrow(pdf), prefix = name), - class = class) - private$setup_data.edbl_lvls(pdf[[name]], name, class) + role = role) + private$setup_data.edbl_lvls(pdf[[name]], name, role) fnodes <- self$fct_nodes idv <- fnodes[fnodes$name == name, "id"] for(avar in vars) { @@ -558,19 +561,19 @@ Kitchen <- R6::R6Class("Kitchen", self$append_fct_edges(cross_df) }, - setup_data.nest_lvls = function(fresh, name, class) { - idv <- self$fct_last_id + 1L - idl <- self$lvl_last_id + 1L + setup_data.nest_lvls = function(fresh, name, role) { + idv <- private$fct_new_id + idl <- private$lvl_new_id parent <- fresh %@% "keyname" cross_parents <- fresh %@% "parents" clabels <- fresh %@% "labels" - idp <- self$fct_id(name = c(parent, colnames(cross_parents[[1]]))) + idp <- self$fct_id_by_name(c(parent, colnames(cross_parents[[1]]))) attrs <- attributes(fresh) - fattrs <- do.call(data.frame, c(attrs[setdiff(names(attrs), c("names", "keyname", "class", "parents", "labels"))], + fattrs <- do.call(data.frame, c(attrs[setdiff(names(attrs), c("names", "keyname", "role", "parents", "labels"))], list(stringsAsFactors = FALSE, id = idv, name = name, - class = class))) + role = role))) self$append_fct_nodes(fattrs) self$append_fct_edges(data.frame(from = idp, to = idv, type = "nest")) plevels <- rep(names(fresh), lengths(fresh)) diff --git a/R/utils.R b/R/utils.R index 052266b7..c2567343 100644 --- a/R/utils.R +++ b/R/utils.R @@ -116,18 +116,18 @@ print.edbl_design <- function(x, label = as.character(decorate_title(title))) } else { - classes <- prep$fct_class() + roles <- prep$fct_role() label_names <- decorate_vars(fnames, decorate_units, decorate_trts, decorate_rcrds, - classes) + roles) var_nlevels <- lengths(prep$fct_levels()[fnames]) nvar <- length(fnames) ll <- lapply(fnames, function(v) { - id <- prep$fct_id(v) - class <- prep$fct_class(id = id) + id <- prep$fct_id_by_name(v) + class <- prep$fct_role(id = id) children <- prep$fct_child(id = id) if(class!="edbl_trt" & !is_empty(children)) { prep$fct_names(id = children) @@ -137,7 +137,7 @@ print.edbl_design <- function(x, }) nodes_with_parents <- unname(unlist(ll)) label_names_with_levels <- paste(label_names, map_chr(var_nlevels, decorate_levels)) - label_names_with_levels[classes=="edbl_rcrd"] <- label_names[classes=="edbl_rcrd"] + label_names_with_levels[roles=="edbl_rcrd"] <- label_names[roles=="edbl_rcrd"] data <- data.frame(var = c("root", fnames), child = I(c(list(setdiff(fnames, nodes_with_parents)), ll)), @@ -213,9 +213,9 @@ perm <- function(x) { #' @export print.edbl_graph <- function(x, show_levels = FALSE, ...) { cat(cli::col_green("factor nodes\n")) - print(x$nodes) + print(x$factors$nodes) cat(cli::col_green("factor edges\n")) - print(x$edges) + print(x$factors$edges) if(show_levels) { cat(cli::col_blue("level nodes\n")) print(x$levels$nodes) @@ -225,7 +225,7 @@ print.edbl_graph <- function(x, show_levels = FALSE, ...) { } names.edbl_graph <- function(graph) { - graph$nodes$name + graph$factors$nodes$name } names.edbl_design <- function(design) { From 230135c4874819047d99119b6524aa5028695188 Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 28 Jul 2023 17:23:35 -0400 Subject: [PATCH 09/83] doc update --- NAMESPACE | 4 ++ man/Kitchen.Rd | 132 +++++++++++++++++++++++++------------------ man/design.Rd | 3 +- man/expect_rcrds.Rd | 3 +- man/export_design.Rd | 3 +- man/fct_attrs.Rd | 4 +- man/label_seq.Rd | 83 +++++++++++++++++++++++++++ man/serve_table.Rd | 3 +- man/set_rcrds.Rd | 3 +- man/set_trts.Rd | 3 +- man/set_units.Rd | 3 +- 11 files changed, 178 insertions(+), 66 deletions(-) create mode 100644 man/label_seq.Rd diff --git a/NAMESPACE b/NAMESPACE index 56fa76d1..a3a96242 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -83,6 +83,10 @@ export(is_edibble_var) export(is_named_design) export(is_nest_levels) export(is_takeout) +export(label_seq_from_length) +export(label_seq_from_to) +export(label_seq_length) +export(label_seq_to_length) export(latin_array) export(latin_rectangle) export(latin_square) diff --git a/man/Kitchen.Rd b/man/Kitchen.Rd index ca0f5ebc..b18d0484 100644 --- a/man/Kitchen.Rd +++ b/man/Kitchen.Rd @@ -18,6 +18,10 @@ the edibble design object. \describe{ \item{\code{design}}{An edibble design object Initialise function} + +\item{\code{fct_last_id}}{Get the last factor id.} + +\item{\code{lvl_last_id}}{Get the last level id.} } \if{html}{\out{}} } @@ -62,16 +66,17 @@ Initialise function} \subsection{Public methods}{ \itemize{ \item \href{#method-Kitchen-new}{\code{Kitchen$new()}} -\item \href{#method-Kitchen-fct_id}{\code{Kitchen$fct_id()}} -\item \href{#method-Kitchen-lvl_id}{\code{Kitchen$lvl_id()}} +\item \href{#method-Kitchen-fct_id_by_name}{\code{Kitchen$fct_id_by_name()}} +\item \href{#method-Kitchen-fct_id_by_role}{\code{Kitchen$fct_id_by_role()}} +\item \href{#method-Kitchen-lvl_id_by_name}{\code{Kitchen$lvl_id_by_name()}} \item \href{#method-Kitchen-fct_names}{\code{Kitchen$fct_names()}} \item \href{#method-Kitchen-lvl_names}{\code{Kitchen$lvl_names()}} \item \href{#method-Kitchen-append_fct_nodes}{\code{Kitchen$append_fct_nodes()}} \item \href{#method-Kitchen-append_lvl_nodes}{\code{Kitchen$append_lvl_nodes()}} \item \href{#method-Kitchen-append_fct_edges}{\code{Kitchen$append_fct_edges()}} \item \href{#method-Kitchen-append_lvl_edges}{\code{Kitchen$append_lvl_edges()}} -\item \href{#method-Kitchen-fct_class}{\code{Kitchen$fct_class()}} -\item \href{#method-Kitchen-lvl_class}{\code{Kitchen$lvl_class()}} +\item \href{#method-Kitchen-fct_role}{\code{Kitchen$fct_role()}} +\item \href{#method-Kitchen-lvl_role}{\code{Kitchen$lvl_role()}} \item \href{#method-Kitchen-fct_child}{\code{Kitchen$fct_child()}} \item \href{#method-Kitchen-lvl_child}{\code{Kitchen$lvl_child()}} \item \href{#method-Kitchen-fct_parent}{\code{Kitchen$fct_parent()}} @@ -105,40 +110,55 @@ Initialise function} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_id}{}}} -\subsection{Method \code{fct_id()}}{ -Get the id based on either the name of the factor node or -the class. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Kitchen-fct_id_by_name}{}}} +\subsection{Method \code{fct_id_by_name()}}{ +Get the id based on either the name of the factor node. +If none supplied then it will give all. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_id(name = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$fct_id_by_name(name = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{name}}{The name of the vertex.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Kitchen-fct_id_by_role}{}}} +\subsection{Method \code{fct_id_by_role()}}{ +Get all ids associated with a role. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Kitchen$fct_id_by_role(role = NULL)}\if{html}{\out{
}} +} -\item{\code{class}}{The class for the vertex/node.} +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_id}{}}} -\subsection{Method \code{lvl_id()}}{ -Get the id based on name of level node +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Kitchen-lvl_id_by_name}{}}} +\subsection{Method \code{lvl_id_by_name()}}{ +Get the id based on name of level node. +If no name provided, all names returned. +FIXME \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_id(name = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$lvl_id_by_name(name = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{name}}{The name of the vertex.} - -\item{\code{class}}{The class for the vertex/node.} } \if{html}{\out{
}} } @@ -147,9 +167,9 @@ Get the id based on name of level node \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Kitchen-fct_names}{}}} \subsection{Method \code{fct_names()}}{ -Get the factor names based on id or class +Get the factor names based on id or role \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_names(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$fct_names(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -157,7 +177,7 @@ Get the factor names based on id or class \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -166,9 +186,9 @@ Get the factor names based on id or class \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Kitchen-lvl_names}{}}} \subsection{Method \code{lvl_names()}}{ -Get the level names based on id or class +Get the level names based on id or role \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_names(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$lvl_names(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -176,7 +196,7 @@ Get the level names based on id or class \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -250,12 +270,12 @@ Given edge data, append the level edges } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_class}{}}} -\subsection{Method \code{fct_class()}}{ -Get the class of the vertex given the factor id +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Kitchen-fct_role}{}}} +\subsection{Method \code{fct_role()}}{ +Get the role of the vertex given the factor id \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_class(id = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$fct_role(id = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -267,12 +287,12 @@ Get the class of the vertex given the factor id } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_class}{}}} -\subsection{Method \code{lvl_class()}}{ -Get the class of the vertex given the level id +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Kitchen-lvl_role}{}}} +\subsection{Method \code{lvl_role()}}{ +Get the role of the vertex given the level id \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_class(id = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$lvl_role(id = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -287,10 +307,10 @@ Get the class of the vertex given the level id \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Kitchen-fct_child}{}}} \subsection{Method \code{fct_child()}}{ -Get the factor child ids. If \code{class} is -supplied then the child has to fit \code{class} +Get the factor child ids. If \code{role} is +supplied then the child has to fit \code{role} \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_child(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$fct_child(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -298,7 +318,7 @@ supplied then the child has to fit \code{class} \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -309,7 +329,7 @@ supplied then the child has to fit \code{class} \subsection{Method \code{lvl_child()}}{ Get the level child ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_child(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$lvl_child(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -317,7 +337,7 @@ Get the level child ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -328,7 +348,7 @@ Get the level child ids \subsection{Method \code{fct_parent()}}{ Get the factor parent ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_parent(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$fct_parent(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -336,7 +356,7 @@ Get the factor parent ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -347,7 +367,7 @@ Get the factor parent ids \subsection{Method \code{lvl_parent()}}{ Get the level parent ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_parent(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$lvl_parent(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -355,7 +375,7 @@ Get the level parent ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -366,7 +386,7 @@ Get the level parent ids \subsection{Method \code{fct_ancestor()}}{ Get the factor ancestor ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_ancestor(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$fct_ancestor(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -374,7 +394,7 @@ Get the factor ancestor ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -385,7 +405,7 @@ Get the factor ancestor ids \subsection{Method \code{lvl_ancestor()}}{ Get the level ancestor ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_ancestor(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$lvl_ancestor(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -393,7 +413,7 @@ Get the level ancestor ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -423,7 +443,7 @@ Get the levels for each factor \subsection{Method \code{setup_data()}}{ Setup the node and edge data \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$setup_data(fresh, name, class)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$setup_data(fresh, name, role)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -433,7 +453,7 @@ Setup the node and edge data \item{\code{name}}{The name of the vertex.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -444,7 +464,7 @@ Setup the node and edge data \subsection{Method \code{add_anatomy()}}{ Add the anatomy structure \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$add_anatomy(fresh, name, class)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$add_anatomy(fresh, name, role)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -454,7 +474,7 @@ Add the anatomy structure \item{\code{name}}{The name of the vertex.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } @@ -463,11 +483,11 @@ Add the anatomy structure \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Kitchen-fct_exists}{}}} \subsection{Method \code{fct_exists()}}{ -One of \code{name}, \code{id} or \code{class} is defined to check if it exists. -If more than one of the arguments \code{name}, \code{id} and \code{class} are supplied, then +One of \code{name}, \code{id} or \code{role} is defined to check if it exists. +If more than one of the arguments \code{name}, \code{id} and \code{role} are supplied, then the intersection of it will be checked. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_exists(name = NULL, id = NULL, class = NULL, abort = TRUE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Kitchen$fct_exists(name = NULL, id = NULL, role = NULL, abort = TRUE)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -477,7 +497,7 @@ the intersection of it will be checked. \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} \item{\code{abort}}{A logical value to indicate whether to abort if it doesn't exist.} } diff --git a/man/design.Rd b/man/design.Rd index 9e7069a7..49213da7 100644 --- a/man/design.Rd +++ b/man/design.Rd @@ -46,7 +46,8 @@ Add variables to this design with \code{\link[=set_units]{set_units()}}, \code{\ \code{\link[=set_rcrds]{set_rcrds()}}. Other user-facing functions: -\code{\link{allot}}, +\code{\link{allot_trts}()}, +\code{\link{allot_units}()}, \code{\link{expect_rcrds}()}, \code{\link{export_design}()}, \code{\link{serve_table}()}, diff --git a/man/expect_rcrds.Rd b/man/expect_rcrds.Rd index 0b952b42..4f591cab 100644 --- a/man/expect_rcrds.Rd +++ b/man/expect_rcrds.Rd @@ -28,7 +28,8 @@ takeout(menu_crd(t = 4, n = 10)) \%>\% } \seealso{ Other user-facing functions: -\code{\link{allot}}, +\code{\link{allot_trts}()}, +\code{\link{allot_units}()}, \code{\link{design}()}, \code{\link{export_design}()}, \code{\link{serve_table}()}, diff --git a/man/export_design.Rd b/man/export_design.Rd index 57981a55..267f9b19 100644 --- a/man/export_design.Rd +++ b/man/export_design.Rd @@ -27,7 +27,8 @@ external xlsx file. } \seealso{ Other user-facing functions: -\code{\link{allot}}, +\code{\link{allot_trts}()}, +\code{\link{allot_units}()}, \code{\link{design}()}, \code{\link{expect_rcrds}()}, \code{\link{serve_table}()}, diff --git a/man/fct_attrs.Rd b/man/fct_attrs.Rd index 9e7b4634..a1920735 100644 --- a/man/fct_attrs.Rd +++ b/man/fct_attrs.Rd @@ -8,7 +8,7 @@ fct_attrs( levels = NULL, label = NULL, description = NULL, - unit_of_measure = NULL, + n = NULL, class = NULL, ... ) @@ -21,8 +21,6 @@ in the factor.} \item{description}{The text description of the factor.} -\item{unit_of_measure}{A string denoting the unit of measurement if applicable.} - \item{class}{An optional subclass.} \item{...}{A name-value pair of attributes. The value must be a scalar and diff --git a/man/label_seq.Rd b/man/label_seq.Rd new file mode 100644 index 00000000..a9590282 --- /dev/null +++ b/man/label_seq.Rd @@ -0,0 +1,83 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/labels.R +\name{label_seq} +\alias{label_seq} +\alias{label_seq_from_to} +\alias{label_seq_from_length} +\alias{label_seq_to_length} +\alias{label_seq_length} +\title{Generate a sequence of labels with custom formatting options} +\usage{ +label_seq_from_to( + from = 1L, + to = 1L, + by = 1L, + prefix = "", + suffix = "", + sep_prefix = "", + sep_suffix = "", + leading_zero = TRUE +) + +label_seq_from_length( + from = 1L, + length = 1L, + by = 1L, + prefix = "", + suffix = "", + sep_prefix = "", + sep_suffix = "", + leading_zero = TRUE +) + +label_seq_to_length( + to = 1L, + length = 1L, + by = 1L, + prefix = "", + suffix = "", + sep_prefix = "", + sep_suffix = "", + leading_zero = TRUE +) + +label_seq_length( + length = 1L, + prefix = "", + suffix = "", + sep_prefix = "", + sep_suffix = "", + leading_zero = TRUE +) +} +\arguments{ +\item{from}{An integer specifying the starting value (inclusive) of the sequence.} + +\item{to}{An integer specifying the ending value (inclusive) of the sequence.} + +\item{by}{An integer specifying the increment between values in the sequence.} + +\item{prefix}{A character string to be prepended to the labels.} + +\item{suffix}{A character string to be appended to the labels.} + +\item{sep_prefix}{A character string used to separate the prefix from the labels.} + +\item{sep_suffix}{A character string used to separate the suffix from the labels.} + +\item{leading_zero}{A logical value indicating whether to add leading zeros to the labels. +If integer, then pad based on the number supplied.} + +\item{length}{An integer specifying the desired length of the sequence.} +} +\value{ +A character vector containing the labels generated from the sequence. +} +\description{ +Generate a sequence of labels with custom formatting options +} +\examples{ +label_seq_to_length(to = 10, length = 5, by = 2) +label_seq_from_to(from = 8, to = 10, leading_zero = 3) +label_seq_length(10, leading_zero = FALSE) +} diff --git a/man/serve_table.Rd b/man/serve_table.Rd index 9b121ec9..c355b080 100644 --- a/man/serve_table.Rd +++ b/man/serve_table.Rd @@ -40,7 +40,8 @@ design("Completely Randomised Design") \%>\% } \seealso{ Other user-facing functions: -\code{\link{allot}}, +\code{\link{allot_trts}()}, +\code{\link{allot_units}()}, \code{\link{design}()}, \code{\link{expect_rcrds}()}, \code{\link{export_design}()}, diff --git a/man/set_rcrds.Rd b/man/set_rcrds.Rd index b074ded9..94ab9847 100644 --- a/man/set_rcrds.Rd +++ b/man/set_rcrds.Rd @@ -45,7 +45,8 @@ takeout(menu_crd(t = 4, n = 10)) \%>\% } \seealso{ Other user-facing functions: -\code{\link{allot}}, +\code{\link{allot_trts}()}, +\code{\link{allot_units}()}, \code{\link{design}()}, \code{\link{expect_rcrds}()}, \code{\link{export_design}()}, diff --git a/man/set_trts.Rd b/man/set_trts.Rd index c391c5e6..e862f66f 100644 --- a/man/set_trts.Rd +++ b/man/set_trts.Rd @@ -49,7 +49,8 @@ design() \%>\% } \seealso{ Other user-facing functions: -\code{\link{allot}}, +\code{\link{allot_trts}()}, +\code{\link{allot_units}()}, \code{\link{design}()}, \code{\link{expect_rcrds}()}, \code{\link{export_design}()}, diff --git a/man/set_units.Rd b/man/set_units.Rd index 96216e3c..2a04446c 100644 --- a/man/set_units.Rd +++ b/man/set_units.Rd @@ -82,7 +82,8 @@ design() \%>\% } \seealso{ Other user-facing functions: -\code{\link{allot}}, +\code{\link{allot_trts}()}, +\code{\link{allot_units}()}, \code{\link{design}()}, \code{\link{expect_rcrds}()}, \code{\link{export_design}()}, From 8e9f9070bc64b1b42c19d1e68f359244a9b02b4e Mon Sep 17 00:00:00 2001 From: Your Name Date: Fri, 4 Aug 2023 14:46:24 -0400 Subject: [PATCH 10/83] major internal change --- NAMESPACE | 9 +- R/allot.R | 22 +- R/anatomy.R | 16 + R/assign.R | 35 +- R/design.R | 35 +- R/edibble.R | 24 + R/fcts.R | 10 +- R/graph-input.R | 120 ++++ R/graph.R | 26 +- R/kitchen.R | 601 ---------------- R/nest.R | 27 +- R/provenance.R | 641 +++++++++++++++++ R/serve.R | 16 +- R/trts.R | 3 +- R/units.R | 9 +- R/utils.R | 105 +-- man/Kitchen.Rd | 575 --------------- man/Provenance.Rd | 663 ++++++++++++++++++ ...{cook_design.Rd => activate_provenance.Rd} | 10 +- man/design.Rd | 8 +- man/fct_generator.Rd | 29 + man/graph_input.Rd | 16 + man/label_seq.Rd | 11 +- man/lvl_attrs.Rd | 21 +- man/nested_in.Rd | 21 +- man/new_edibble.Rd | 3 - man/record_step.Rd | 16 - 27 files changed, 1664 insertions(+), 1408 deletions(-) create mode 100644 R/graph-input.R delete mode 100644 R/kitchen.R create mode 100644 R/provenance.R delete mode 100644 man/Kitchen.Rd create mode 100644 man/Provenance.Rd rename man/{cook_design.Rd => activate_provenance.Rd} (55%) create mode 100644 man/fct_generator.Rd create mode 100644 man/graph_input.Rd delete mode 100644 man/record_step.Rd diff --git a/NAMESPACE b/NAMESPACE index a3a96242..dc4cd0bf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,6 +28,7 @@ S3method(print,edbl_table) S3method(print,recipe_design) S3method(print,takeout) S3method(tbl_sum,edbl_table) +S3method(tbl_sum,hstry_table) S3method(vec_cast,character.edbl_fct) S3method(vec_cast,character.edbl_trt) S3method(vec_cast,character.edbl_unit) @@ -49,7 +50,9 @@ S3method(vec_ptype_full,edbl_rcrd) S3method(vec_ptype_full,edbl_trt) S3method(vec_ptype_full,edbl_unit) export("%>%") -export(Kitchen) +export("function") +export(Initialise) +export(activate_provenance) export(allot_table) export(allot_trts) export(allot_units) @@ -58,7 +61,6 @@ export(as_data_frame) export(as_edibble) export(assign_trts) export(assign_units) -export(cook_design) export(crossed_by) export(design) export(edbl_design) @@ -69,7 +71,9 @@ export(expect_rcrds) export(export_design) export(fct_attrs) export(fct_edges) +export(fct_generator) export(fct_nodes) +export(graph_input) export(is_cross_levels) export(is_edibble) export(is_edibble_design) @@ -110,7 +114,6 @@ export(pivot_trts_widelist) export(pivot_trts_widetable) export(plot_fct_graph) export(plot_lvl_graph) -export(record_step) export(redesign) export(scan_menu) export(select_units) diff --git a/R/allot.R b/R/allot.R index 3c0a3c2c..31a0c729 100644 --- a/R/allot.R +++ b/R/allot.R @@ -23,11 +23,10 @@ #' @seealso assign #' @export allot_trts <- function(.edibble, ..., .record = TRUE) { - not_edibble(.edibble) - if(.record) record_step() - des <- edbl_design(.edibble) + prep <- cook_design(des) + if(.record) prep$record_step() dots <- list2(...) if(!is_null(des$allotment)) { @@ -35,17 +34,17 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { } else { des$allotment <- list(trts = dots, units = NULL) } - prep <- cook_design(des) + for(ialloc in seq_along(dots)) { trts <- all.vars(f_lhs(dots[[ialloc]])) # there should be only one unit unit <- all.vars(f_rhs(dots[[ialloc]])) prep$fct_exists(name = unit, class = "edbl_unit") - uid <- prep$fct_id(unit) + uid <- prep$fct_id_by_name(unit) if(length(trts)) { prep$fct_exists(name = trts, class = "edbl_trt") - tids <- prep$fct_id(trts) + tids <- prep$fct_id_by_name(trts) } else { prep$trts_exists() classes <- prep$fct_class() @@ -55,9 +54,9 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { prep$append_fct_edges(data.frame(from = tids, to = uid, alloc = ialloc, type = "allot")) } - if(is_edibble_design(.edibble)) { - prep$design - } else if(is_edibble_table(.edibble)) { + des$graph <- prep$graph + + if(is_edibble_table(.edibble)) { if(length(trts)==0) { trts <- prep$trt_names } @@ -65,8 +64,10 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { prep$append_lvl_edges(data.frame(from = prep$lvl_id(as.character(.edibble[[atrt]])), to = prep$lvl_id(as.character(.edibble[[unit]])))) } - attr(.edibble, "design") <- prep$design + attr(.edibble, "design") <- des .edibble + } else { + des } } @@ -167,7 +168,6 @@ allot_units <- function(.edibble, ..., .record = TRUE) { #' #' @export allot_table <- function(.edibble, ..., order = "random", seed = NULL, constrain = nesting_structure(.edibble)) { - .edibble %>% allot_trts(...) %>% assign_trts(order = order, seed = seed, constrain = constrain) %>% diff --git a/R/anatomy.R b/R/anatomy.R index b5f6a797..3f1bcf08 100644 --- a/R/anatomy.R +++ b/R/anatomy.R @@ -26,3 +26,19 @@ anatomy <- function(.edibble, ...) { print.des_anatomy <- function(x, ...) { print(summary(x, ...)) } + + +add_anatomy <- function(anatomy, fresh, name, role) { + if(role=="edbl_unit") { + if(is.null(anatomy)) { + anatomy <- as.formula(paste0("~", name)) + } else { + term <- ifelse(inherits(fresh, "nest_lvls"), + paste0(attr(fresh, "keyname"), "/", name), + name) + anatomy <- update(anatomy, + as.formula(paste0("~ . + ", term)), evaluate = FALSE) + } + } + anatomy +} diff --git a/R/assign.R b/R/assign.R index 08081886..2fcd0936 100644 --- a/R/assign.R +++ b/R/assign.R @@ -38,10 +38,10 @@ assign_trts <- function(.design, order = "random", seed = NULL, constrain = nesting_structure(.design), ..., .record = TRUE) { not_edibble(.design) - if(.record) record_step() - - save_seed(seed) prep <- cook_design(.design) + if(.record) prep$record_step() + + prep$save_seed(seed) order <- rep(order, length.out = length(.design$allotment$trts)) @@ -49,18 +49,18 @@ assign_trts <- function(.design, order = "random", seed = NULL, constrain = nest trts <- all.vars(f_lhs(.design$allotment$trts[[ialloc]])) # there should be only one unit unit <- all.vars(f_rhs(.design$allotment$trts[[ialloc]])) - uid <- prep$fct_id(unit) + uid <- prep$fct_id_by_name(unit) if(length(trts)) { - tids <- prep$fct_id(trts) + tids <- prep$fct_id_by_name(trts) } else { classes <- prep$fct_class() tids <- prep$trt_ids } lnodes <- prep$lvl_nodes - luids <- lnodes[lnodes$idvar == uid, "id"] - tdf <- lnodes[lnodes$idvar %in% tids, ] - tidf <- expand.grid(split(tdf$name, prep$fct_names(tdf$idvar))[prep$fct_names(tids)], stringsAsFactors = FALSE) + luids <- lnodes[[as.character(uid)]]$id + tdf <- prep$fct_levels()[prep$fct_names(tids)] + tidf <- expand.grid(tdf, stringsAsFactors = FALSE) ntrts <- nrow(tidf) permutation <- switch(order[ialloc], "systematic" = rep(1:nrow(tidf), length.out = length(luids)), @@ -97,15 +97,16 @@ assign_trts <- function(.design, order = "random", seed = NULL, constrain = nest for(itvar in seq_along(tout)) { - prep$lvl_edges <- prep$append_lvl_edges(data.frame(from = prep$lvl_id(tout[[itvar]]), - to = luids, - alloc = ialloc)) + fid <- prep$fct_id_by_name(names(tout)[itvar]) + prep$append_lvl_edges(data.frame(from = prep$lvl_id_by_value(tout[[itvar]], fid), + to = luids, + lloc = ialloc)) } } - prep$design$assignment <- order - - prep$design + .design$graph <- prep$graph + .design$assignment <- order + .design } @@ -124,7 +125,8 @@ assign_units <- function(.design, order = "random", seed = NULL, constrain = nes rhs <- all.vars(f_rhs(.design$allotment$units[[ialloc]])) lnodes <- prep$lvl_nodes - lhs_id <- lnodes[lnodes$idvar == prep$fct_id(lhs), "id"] + + lhs_id <- lnodes[[prep$fct_id_by_name(lhs)]]$id udf <- as.data.frame(serve_units(select_units(prep, rhs))) udf <- udf[rhs] small_df <- data.frame(lhs = lhs_id) @@ -135,7 +137,7 @@ assign_units <- function(.design, order = "random", seed = NULL, constrain = nes # FIXME the ancestor should be found # based on `constrain`?? - vparents <- prep$fct_id(rhs[-length(rhs)]) + vparents <- prep$fct_id_by_name(rhs[-length(rhs)]) if(length(rhs)==1L) { out <- as.vector(replicate(ceiling(nrow(udf)/nrow(small_df)), @@ -150,6 +152,7 @@ assign_units <- function(.design, order = "random", seed = NULL, constrain = nes tout <- small_df[permutation, , drop = FALSE] + browser() for(itvar in seq_along(tout)) { prep$append_lvl_edges(data.frame(from = tout[[itvar]], to = prep$lvl_id(udf[[rhs[length(rhs)]]]), diff --git a/R/design.R b/R/design.R index 6babbf4b..3dc77ebe 100644 --- a/R/design.R +++ b/R/design.R @@ -7,8 +7,8 @@ #' @inheritParams set_units #' @param seed A seed number for reproducibility. #' @param .data An edibble table. -#' @param kitchen An environment setup in a manner to manipulate, extract and query -#' information on the design. +#' @param provenance An environment setup in a manner to store methods and +#' information to trace the origin of the design #' @return An empty `edbl_design` object. #' @examples #' design("My design") @@ -16,19 +16,22 @@ #' [set_rcrds()]. #' @family user-facing functions #' @export -design <- function(name = NULL, .record = TRUE, seed = NULL, kitchen = Kitchen) { - if(.record) record_step() - save_seed(seed) - structure(list(name = name, - graph = empty_edibble_graph(), - kitchen = kitchen), +design <- function(title = NULL, name = "edibble", .record = TRUE, seed = NULL, provenance = Provenance$new()) { + if(.record) provenance$record_step() + if(!is.null(title)) provenance$set_name(title) + provenance$set_name(name) + provenance$save_seed(seed) + structure(list(graph = provenance$graph, + provenance = provenance, + anatomy = NULL, + recipe = NULL), class = c("edbl_design", "edbl")) } #' @rdname design #' @export -redesign <- function(.data, name = NULL, .record = TRUE, seed = NULL, kitchen = Kitchen, ...) { - des <- design(name = name, .record = .record, seed = seed, kitchen = kitchen) +redesign <- function(.data, name = NULL, .record = TRUE, seed = NULL, provenance = provenance, ...) { + des <- design(name = name, .record = .record, seed = seed, provenance = provenance) new_edibble(.data, ..., design = des) } @@ -52,8 +55,12 @@ empty_edibble_graph <- function() { class = "edbl_graph") } -new_lnode <- function(ids, vals, data) { - tibble::tibble(id = ids, - value = vals, - attrs = data) +new_lnode <- function(ids, vals, data = NULL) { + res <- tibble::tibble(id = ids, + value = vals) + if(!is.null(data)) { + stopifnot(nrow(data) == length(ids)) + res$attrs <- data + } + res } diff --git a/R/edibble.R b/R/edibble.R index 9151ad76..b74e4e0e 100644 --- a/R/edibble.R +++ b/R/edibble.R @@ -134,6 +134,30 @@ new_edibble <- function(.data, ..., design = NULL, class = NULL) { class = c(class, "edbl_table", "edbl"), design = design) } + +new_trackable <- function(internal_cmd = character(), + time_internal = Sys.time(), + time_zone_internal = character(), + external_cmd = NULL, + time_external = NULL, + time_zone_external = NULL) { + new_tibble(tibble::tibble(internal_cmd = internal_cmd, + execution_time = time_internal, + time_zone = time_zone_internal), + class = "trck_table", + external_cmd = external_cmd, + execution_time = time_external, + time_zone = time_zone_external) +} + +#' @export +tbl_sum.trck_table <- function(x) { + c("A history table" = dim_desc(x), + "External command" = attr(x, "external_cmd"), + "Execution time" = paste(as.character(attr(x, "execution_time")), + as.character(attr(x, "time_zone")))) +} + #' @importFrom tibble tbl_sum #' @export tbl_sum.edbl_table <- function(x) { diff --git a/R/fcts.R b/R/fcts.R index 9e92f6f7..f316da00 100644 --- a/R/fcts.R +++ b/R/fcts.R @@ -22,16 +22,16 @@ set_fcts <- function(.edibble, ..., .class = NULL, dots <- enquos(..., .named = TRUE, .homonyms = "error", .check_assign = TRUE) fnames_new <- names(dots) - fnames_old <- names(prep$design) + fnames_old <- names(prep$graph) fnames <- vec_as_names(c(fnames_old, fnames_new), repair = .name_repair) for(i in seq_along(dots)) { fname <- fnames[i + length(fnames_old)] fresh <- eval_tidy(dots[[i]], data = c(prep$fct_levels(), list(prep = prep, .fname = fname))) - prep$add_anatomy(fresh, fname, .class) + .edibble$anatomy <- add_anatomy(.edibble$anatomy, fresh, fname, .class) prep$setup_data(fresh, fname, .class) } - prep$design + .edibble$graph <- prep$graph } else if(is_edibble_table(.edibble)) { @@ -45,11 +45,13 @@ set_fcts <- function(.edibble, ..., .class = NULL, class = .class, name = fname) prep$setup_data(.edibble[[loc[i]]], fname, .class) + # FIXME attr(.edibble, "design") <- prep$design } - .edibble + } + .edibble } diff --git a/R/graph-input.R b/R/graph-input.R new file mode 100644 index 00000000..42249bbc --- /dev/null +++ b/R/graph-input.R @@ -0,0 +1,120 @@ + +#' A function to process input as input for graph manipulation +#' +#' @param input An input. +#' @param prov A provenance object. +#' @export +graph_input <- function(input, prov, ...) { + UseMethod("graph_input") +} + +graph_input_type = function(input) { + if(is_edibble_levels(input)) return("edbl_lvls") + if(is_nest_levels(input)) return("nest_lvls") + if(vec_is(input, numeric(), 1)) return("numeric") + if(vec_is(input, integer(), 1)) return("numeric") + if(is.vector(input) && !is_named(input)) return("unnamed_vector") + if(is.vector(input) && is_named(input)) return("named_vector") + return("unimplemented") +} + +graph_input.default <- function(input, prov, name, class) { + type <- graph_input_type(input) + levels <- switch(type, + "numeric" = fct_attrs(levels = lvl_attrs(label_seq_length(input, prefix = name)), + class = class), + "unnamed_vector" = fct_attrs(levels = lvl_attrs(input), + class = class), + "named_vector" = fct_attrs(levels = lvl_attrs(names(input), + rep = unname(input)), + class = class), + "unimplemented" = abort(paste0("Not sure how to handle ", class(input)[1]))) + graph_input.edbl_lvls(levels, name, class) +} + +graph_input.edbl_lvls <- function(input, prov, name, class) { + fid <- private$fct_new_id(n = 1) + attrs <- attributes(input) + + fattrs <- data.frame(id = fid, name = name, class = class) + self$append_fct_nodes(fattrs) + + lattrs <- lvl_data(input) + lattrs$id <- private$lvl_new_id(length(input)) + + self$append_lvl_nodes(lattrs, fid) +} + +graph_input.formula <- function(input, prov, name, class) { + flevels <- self$fct_levels() + tt <- terms(input) + vars <- rownames(attr(tt, "factor")) + + private$graph_input.cross_lvls(vars, prov, name, class) +} + +graph_input.edbl_fct <- function(input, prov, name, class) { + # this looks the same as graph_input.edbl_levels??? + fid <- private$fct_new_id + self$append_fct_nodes(tibble(id = fid, name = name, class = class)) + + lvls <- levels(input) + lattrs <- tibble(id = private$lvl_new_id(length(lvls)), + value = lvls) + + self$append_lvl_nodes(lattrs, fid) +} + +graph_input.cross_lvls <- function(input, prov, name, class) { + flevels <- self$fct_levels() + vars <- input + + pdf <- expand.grid(flevels[vars]) + pdf[[name]] <- fct_attrs(levels = lvl_attrs(1:nrow(pdf), prefix = name), + class = class) + private$graph_input.edbl_lvls(pdf[[name]], name, class) + idv <- self$fct_id_by_name(name) + for(avar in vars) { + idp <- self$fct_id_by_name(avar) + self$append_fct_edges(data.frame(from = idp, to = idv, type = "nest")) + self$append_lvl_edges(data.frame(from = self$lvl_id_by_value(pdf[[avar]], idp), + to = self$lvl_id_by_value(pdf[[name]], idv))) + } + idvs <- self$fct_id_by_name(vars) + cross_df <- expand.grid(from = idvs, to = idvs) + cross_df <- subset(cross_df, from!=to) + cross_df$type <- "cross" + self$append_fct_edges(cross_df) +} + +graph_input.nest_lvls <- function(input, name, class) { + + idv <- private$fct_new_id() + parent <- input %@% "keyname" + cross_parents <- input %@% "parents" + clabels <- input %@% "labels" + idp <- self$fct_id_by_name(c(parent, colnames(cross_parents[[1]]))) + attrs <- attributes(input) + fattrs <- tibble::tibble(id = idv, + name = name, + class = class) + self$append_fct_nodes(fattrs) + self$append_fct_edges(tibble(from = idp, to = idv, type = "nest")) + plevels <- rep(names(input), lengths(input)) + clevels <- unname(unlist(input)) + pids <- self$lvl_id_by_value(plevels, idp) + vids <- private$lvl_new_id(length(clevels)) + self$append_lvl_nodes(tibble::tibble(id = vids, + value = clevels), + idv) + + self$append_lvl_edges(tibble::tibble(from = pids, to = vids)) + if(!is_null(cross_parents)) { + cross_df <- do.call("rbind", cross_parents[names(input)]) + cross_parent_names <- colnames(cross_df) + for(across in cross_parent_names) { + cpids <- self$lvl_id(cross_df[[across]]) + self$append_lvl_edges(tibble::tibble(from = cpids, to = vids)) + } + } +} diff --git a/R/graph.R b/R/graph.R index 5e89cd1f..68ad8bc9 100644 --- a/R/graph.R +++ b/R/graph.R @@ -6,7 +6,7 @@ # data or vector -------------------------------------------------- -#' Cook the design in the kitchen +#' Activate the provenance in the edibble design object #' #' This is a developer function to create a new Kitchen class with #' the existing design. @@ -14,18 +14,20 @@ #' @param x An edibble object. #' @return A Kitchen object. #' @examples -#' cook_design(takeout()) +#' activate_provenance(takeout()) #' @export -cook_design <- function(x) { - des <- edbl_design(x) - if(!is_environment(des$kitchen)) { - abort("The kitchen is not included in the design.") +activate_provenance <- function(.edibble, + overwrite = c("graph", "anatomy", "recipe")) { + des <- edbl_design(.edibble) + prov <- des$provenance + if(!is_environment(prov)) { + abort("The provenance is not included in the design.") } - return(des$kitchen$new(des)) + prov$reactivate(des, overwrite) + return(prov) } - #' Get the node or edge data from an edibble design #' #' @param edibble An edibble object. @@ -36,14 +38,14 @@ NULL #' @rdname design_data #' @export fct_nodes <- function(edibble) { - prep <- cook_design(edibble) + prep <- activate_provenance(edibble) prep$fct_nodes } #' @rdname design_data #' @export fct_edges <- function(edibble) { - prep <- cook_design(edibble) + prep <- activate_provenance(edibble) prep$fct_edges } @@ -52,14 +54,14 @@ fct_edges <- function(edibble) { #' @rdname design_data #' @export lvl_nodes <- function(edibble) { - prep <- cook_design(edibble) + prep <- activate_provenance(edibble) prep$lvl_nodes } #' @rdname design_data #' @export lvl_edges <- function(edibble) { - prep <- cook_design(edibble) + prep <- activate_provenance(edibble) prep$lvl_edges } diff --git a/R/kitchen.R b/R/kitchen.R deleted file mode 100644 index dc6e6708..00000000 --- a/R/kitchen.R +++ /dev/null @@ -1,601 +0,0 @@ - -#' A manipulator for the edbl_design. -#' -#' Internal functions should create a new Kitchen object. -#' The Kitchen contains a set of operations to manipulate the nodes and edges of -#' the edibble design object. -#' -#' @param role The role for the vertex/node. -#' @param data The nodes data -#' @param name The name of the vertex. -#' @param id The id of the corresponding node. -#' @param fresh The value of the new graph structure to add. -#' @param initial The intial id. -#' @param abort Whether to abort. -#' @importFrom vctrs vec_is -#' @export -Kitchen <- R6::R6Class("Kitchen", - public = list( - #' @field design An edibble design object - design = NULL, - - #' Initialise function - #' @param design An edibble design. - initialize = function(design = NULL) { - self$design <- design %||% design() - }, - - - - #' @description - #' Get the id based on either the name of the factor node. - #' If none supplied then it will give all. - fct_id_by_name = function(name = NULL) { - fnodes <- self$fct_nodes - name_to_id <- pull(fnodes, id, name) - name <- name %||% names(name_to_id) - unname(name_to_id[as.character(name)]) - }, - - #' @description - #' Get all ids associated with a role. - fct_id_by_role = function(role = NULL) { - fnodes <- self$fct_nodes - fnodes[fnodes$role %in% role, "id"] - }, - - #' @description - #' Get the id based on name of level node. - #' If no name provided, all names returned. - #' FIXME - lvl_id_by_name = function(name = NULL) { - lnodes <- self$lvl_nodes - name_to_id <- pull(self$lvl_nodes, id, name) - name <- name %||% names(name_to_id) - unname(name_to_id[as.character(name)]) - if(is_null(role)) { - - } else { - ids <- fnodes[fnodes$role %in% role, "id"] - lnodes[lnodes$idvar %in% ids, "id"] - } - }, - - #' @description - #' Get the factor names based on id or role - fct_names = function(id = NULL, role = NULL) { - private$var_names(self$fct_nodes, id, role) - }, - - #' @description - #' Get the level names based on id or role - lvl_names = function(id = NULL, role = NULL) { - private$var_names(self$lvl_nodes, id, role) - }, - - #' @description - #' Given node data, append the factor nodes - append_fct_nodes = function(data) { - self$fct_nodes <- rbind_(self$fct_nodes, data) - }, - - #' @description - #' Given node data, append the level nodes - append_lvl_nodes = function(data, fid = NULL) { - lnodes <- self$lvl_nodes - if(is.null(lnodes[[as.character(fid)]])) { - lnodes[[as.character(fid)]] <- new_lnode(data$id, data$value, data$attrs) - } else { - lnodes[[as.character(fid)]] <- rbind_(lnodes[[as.character(fid)]], data) - } - self$lvl_nodes <- lnodes - }, - - #' @description - #' Given edge data, append the factor edges - append_fct_edges = function(data) { - self$fct_edges <- rbind_(self$fct_edges, data) - }, - - #' @description - #' Given edge data, append the level edges - append_lvl_edges = function(data) { - self$lvl_edges <- rbind_(self$lvl_edges, data) - }, - - #' @description - #' Get the role of the vertex given the factor id - fct_role = function(id = NULL) { - nodes <- self$fct_nodes - id_to_role_fct <- pull(nodes, role, id) - ids_fct <- id %||% nodes$id - unname(id_to_role_fct[as.character(ids_fct)]) - }, - - #' @description - #' Get the role of the vertex given the level id - lvl_role = function(id = NULL) { - nodes <- self$lvl_nodes - id_to_role_fct <- pull(nodes, role, id) - ids_fct <- id %||% nodes$id - unname(id_to_role_fct[as.character(ids_fct)]) - }, - - #' @description - #' Get the factor child ids. If `role` is - #' supplied then the child has to fit `role` - fct_child = function(id = NULL, role = NULL) { - edges <- subset(self$fct_edges, !type %in% c("depends", "cross")) - child_ids <- edges$to - parent_ids <- edges$from - child_ids[parent_ids %in% id & child_ids %in% self$fct_id_by_role(role = role)] - }, - - #' @description - #' Get the level child ids - lvl_child = function(id = NULL, role = NULL) { - edges <- self$lvl_edges - child_ids <- edges$to - parent_ids <- edges$from - child_ids[parent_ids %in% id & child_ids %in% self$lvl_id(role = role)] - }, - - #' @description - #' Get the factor parent ids - fct_parent = function(id = NULL, role = NULL) { - edges <- subset(self$fct_edges, !type %in% c("depends", "cross")) - role_ids <- self$fct_id_by_role(role = role) - parent_ids <- edges$from - child_ids <- edges$to - parent_ids[child_ids %in% id & parent_ids %in% role_ids & child_ids %in% role_ids] - }, - - #' @description - #' Get the level parent ids - lvl_parent = function(id = NULL, role = NULL) { - edges <- self$lvl_edges - role_ids <- self$lvl_id(role = role) - parent_ids <- edges$from - child_ids <- edges$to - parent_ids[child_ids %in% id & parent_ids %in% role_ids & child_ids %in% role_ids] - }, - - - #' @description - #' Get the factor ancestor ids - fct_ancestor = function(id = NULL, role = NULL) { - out <- unique(id) - parent_ids <- self$fct_parent(id = id, role = role) - if(!is_empty(parent_ids)) { - out <- unique(c(out, self$fct_ancestor(id = parent_ids, role = role))) - } - out - }, - - - #' @description - #' Get the level ancestor ids - lvl_ancestor = function(id = NULL, role = NULL) { - out <- id - parent_ids <- self$lvl_parent(id = id, role = role) - if(!is_empty(parent_ids)) { - out <- c(out, self$lvl_ancestor(id = parent_ids, role = role)) - } - out - }, - - #' @description - #' Get the levels for each factor - fct_levels = function(id = NULL, name = NULL) { - qid <- id %||% self$fct_id_by_name(name) - lnodes <- self$lvl_nodes - lnodes[as.character(qid)] - }, - - - - #' @description - #' Setup the node and edge data - setup_data = function(fresh, name, role) { - setup_data_internal <- private$next_method("setup_data", class(fresh)) - setup_data_internal(fresh, name, role) - }, - - #' @description - #' Add the anatomy structure - add_anatomy = function(fresh, name, role) { - if(role=="edbl_unit") { - if(is.null(self$design$anatomy)) { - self$design$anatomy <- as.formula(paste0("~", name)) - } else { - term <- ifelse(inherits(fresh, "nest_lvls"), - paste0(attr(fresh, "keyname"), "/", name), - name) - self$design$anatomy <- update(self$design$anatomy, - as.formula(paste0("~ . + ", term)), evaluate = FALSE) - } - } - }, - - - #' @description - #' One of `name`, `id` or `role` is defined to check if it exists. - #' If more than one of the arguments `name`, `id` and `role` are supplied, then - #' the intersection of it will be checked. - #' @param abort A logical value to indicate whether to abort if it doesn't exist. - fct_exists = function(name = NULL, id = NULL, role = NULL, abort = TRUE) { - - exist <- TRUE - abort_missing <- function(vars = NULL, msg = NULL) { - if(abort & !exist) { - if(!is_null(vars)) { - abort(sprintf("%s does not exist in the design.", - .combine_words(paste0("`", vars, "`")))) - } - if(!is_null(msg)) { - abort(msg) - } - } - } - - fnodes <- self$fct_nodes - # at least one node exists - if(is_null(name) & is_null(id) & is_null(role)) { - exist <- nrow(fnodes) > 0 - abort_missing(msg = "There are no factor nodes.") - - } else if(!is_null(name) & is_null(id) & is_null(role)) { - vexist <- name %in% fnodes$name - exist <- all(vexist) - abort_missing(vars = name[!vexist]) - - } else if(is_null(name) & !is_null(id) & is_null(role)) { - vexist <- id %in% fnodes$id - exist <- all(vexist) - abort_missing(vars = id[!vexist]) - - } else if(is_null(name) & is_null(id) & !is_null(role)) { - exist <- any(role %in% fnodes$role) - abort_missing(msg = sprintf("There are no factors with role%s", - .combine_words(paste0("`", role, "`")))) - - } else if(is_null(name) & !is_null(id) & !is_null(role)) { - srole <- fnodes[match(id, fnodes$id), "role"] - vexist <- srole == role - exist <- all(vexist) - abort_missing(vars = id[!vexist]) - - } else if(!is_null(name) & is_null(id) & !is_null(role)) { - srole <- fnodes[match(name, fnodes$name), "role"] - vexist <- srole == role - exist <- all(vexist) - abort_missing(vars = name[!vexist]) - - } else if(!is_null(name) & !is_null(id) & is_null(role)) { - sid <- fnodes[match(name, fnodes$name), "id"] - vexist <- sid == id - exist <- all(vexist) - abort_missing(vars = name[!vexist]) - - } else { - snodes <- fnodes[match(name, fnodes$name), ] - vexist <- snodes$id == id & snodes$role == role - exist <- all(vexist) - abort_missing(vars = name[!vexist]) - } - - return(exist) - }, - - #' @description - #' Check if treatment exists. - trts_exists = function(abort = TRUE) { - self$fct_exists(role = "edbl_trt", abort = abort) - }, - - #' @description - #' Check if unit exists. - units_exists = function(abort = TRUE) { - self$fct_exists(role = "edbl_unit", abort = abort) - }, - - #' @description - #' Check if record exists. - rcrds_exists = function(abort = TRUE) { - self$fct_exists(role = "edbl_rcrd", abort = abort) - } - - ), - - active = list( - - #' @field fct_nodes - #' Get the factor nodes - fct_nodes = function(data) { - if(missing(data)) return(self$design$graph$factors$nodes) - else self$design$graph$factors$nodes <- data - }, - - #' @field lvl_nodes - #' Get the level nodes - lvl_nodes = function(data) { - if(missing(data)) { - nodes <- self$design$graph$levels$nodes - return(nodes) - } - else self$design$graph$levels$nodes <- data - }, - - #' @field fct_edges - #' Get the factor edges - fct_edges = function(data) { - if(missing(data)) { - edges <- self$design$graph$factors$edges - edges$var_from <- self$fct_names(id = edges$from) - edges$var_to <- self$fct_names(id = edges$to) - return(edges) - } else { - self$design$graph$factors$edges <- data - } - }, - - #' @field lvl_edges - #' Get the level edges - lvl_edges = function(data) { - if(missing(data)) { - edges <- self$design$graph$levels$edges - edges$lvl_from <- self$lvl_names(id = edges$from) - edges$lvl_to <- self$lvl_names(id = edges$to) - return(edges) - } else { - self$design$graph$levels$edges <- data - } - }, - - #' @field fct_n - #' Get the number of nodes in factor graph - fct_n = function(value) { - if (missing(value)) { - nrow(self$fct_nodes) - } else { - stop("Can't set `$fct_n`.") - } - }, - - #' @field lvl_n - #' Get the number of nodes in level graph - lvl_n = function(value) { - if (missing(value)) { - sum(lengths(self$lvl_nodes_list)) - } else { - stop("Can't set `$lvl_n`.") - } - }, - - - - #' @field fct_leaves - #' Get the leave factor ids. - fct_leaves = function() { - uids <- self$fct_id_by_role("edbl_unit") - has_child <- map_lgl(uids, function(id) length(intersect(self$fct_child(id), uids)) > 0) - uids[!has_child] - }, - - #' @field rcrd_ids - #' Get the ids for all edbl_rcrd factors. - rcrd_ids = function() { - self$fct_id_by_role("edbl_rcrd") - }, - - #' @field unit_ids - #' Get the ids for all edbl_unit factors. - unit_ids = function() { - self$fct_id_by_role("edbl_unit") - }, - - #' @field trt_ids - #' Get the ids for all edbl_trt factors. - trt_ids = function() { - self$fct_id_by_role("edbl_trt") - }, - - #' @field trt_names - #' Get the node labels for treatments - trt_names = function() { - private$var_names(self$fct_nodes, role = "edbl_trt") - }, - - #' @field unit_names - #' Get the node labels for units - unit_names = function() { - private$var_names(self$fct_nodes, role = "edbl_unit") - }, - - #' @field rcrd_names - #' Get the node labels for record - rcrd_names = function() { - private$var_names(self$fct_nodes, role = "edbl_rcrd") - }, - - #' @field is_connected - #' Check if nodes are connected. - is_connected = function() { - nvar <- self$fct_n - length(self$rcrd_ids) - if(nvar==0) return(FALSE) - if(nvar==1) return(TRUE) - lnodes <- self$lvl_nodes - ledges <- self$lvl_edges - all(lnodes$id %in% c(ledges$to, ledges$from)) - } - - - ), - private = list( - version = NULL, - fct_last_id = 0L, - lvl_last_id = 0L, - - #' @field fct_new_id - #' Get a new factor id. - fct_new_id = function(n = 1) { - ids <- seq(private$fct_last_id + 1, private$fct_last_id + n) - private$fct_last_id <- private$fct_last_id + n - ids - }, - - #' @field lvl_new_id - #' Get a new level id. - lvl_new_id = function(n = 1) { - ids <- seq(private$lvl_last_id + 1, private$lvl_last_id + n) - private$lvl_last_id <- private$lvl_last_id + n - ids - }, - - var_names = function(nodes, id, role) { - if(is_null(role)) { - id_to_name <- pull(nodes, name, id) - ids <- id %||% nodes$id - unname(id_to_name[as.character(ids)]) - } else { - nodes <- self$fct_nodes - if(is_null(role)) { - nodes$name - } else { - nodes[nodes$role %in% role, "name"] - } - } - }, - - fresh_type = function(fresh) { - if(is_edibble_levels(fresh)) return("edbl_lvls") - if(is_nest_levels(fresh)) return("nest_lvls") - if(vec_is(fresh, numeric(), 1)) return("numeric") - if(vec_is(fresh, integer(), 1)) return("numeric") - if(is.vector(fresh) && !is_named(fresh)) return("unnamed_vector") - if(is.vector(fresh) && is_named(fresh)) return("named_vector") - return("unimplemented") - }, - - next_method = function(generic, role) { - fns <- ls(envir = private) - method <- paste0(generic, ".", role[1]) - if(method %in% fns) { - private[[method]] - } else { - if(length(role)==1L) { - private[[paste0(generic, ".default")]] - } else { - private$next_method(generic, role[-1]) - } - } - }, - - - setup_data.default = function(fresh, name, class) { - type <- private$fresh_type(fresh) - levels <- switch(type, - "numeric" = fct_attrs(levels = lvl_attrs(label_seq_length(fresh, prefix = name)), - class = class), - "unnamed_vector" = fct_attrs(levels = lvl_attrs(fresh), - class = class), - "named_vector" = fct_attrs(levels = lvl_attrs(names(fresh), - rep = unname(fresh)), - class = class), - "unimplemented" = abort(paste0("Not sure how to handle ", role(fresh)[1]))) - private$setup_data.edbl_lvls(levels, name, class) - }, - - setup_data.edbl_lvls = function(fresh, name, class) { - fid <- private$fct_new_id(n = 1) - attrs <- attributes(fresh) - - fattrs <- data.frame(id = fid, name = name, role = class) - self$append_fct_nodes(fattrs) - - lattrs <- lvl_data(fresh) - lattrs$id <- private$lvl_new_id(length(fresh)) - - self$append_lvl_nodes(lattrs, fid) - }, - - setup_data.formula = function(fresh, name, role) { - flevels <- self$fct_levels() - tt <- terms(fresh) - vars <- rownames(attr(tt, "factor")) - - private$setup_data.cross_lvls(vars, name, role) - }, - - setup_data.edbl_fct = function(fresh, name, role) { - fid <- private$fct_new_id - self$append_fct_nodes(tibble(id = fid, name = name, role = role)) - - lvls <- levels(fresh) - lattrs <- tibble(id = private$lvl_new_id(length(lvls)), - value = lvls) - - self$append_lvl_nodes(lattrs, fid) - }, - - setup_data.cross_lvls = function(fresh, name, role) { - flevels <- self$fct_levels() - vars <- fresh - - pdf <- expand.grid(flevels[vars]) - pdf[[name]] <- fct_attrs(levels = lvl_attrs(1:nrow(pdf), prefix = name), - role = role) - private$setup_data.edbl_lvls(pdf[[name]], name, role) - fnodes <- self$fct_nodes - idv <- fnodes[fnodes$name == name, "id"] - for(avar in vars) { - idp <- fnodes[fnodes$name == avar, "id"] - self$append_fct_edges(data.frame(from = idp, to = idv, type = "nest")) - self$append_lvl_edges(data.frame(from = self$lvl_id(pdf[[avar]]), - to = self$lvl_id(pdf[[name]]))) - } - idvs <- fnodes[fnodes$name %in% vars, "id"] - cross_df <- expand.grid(from = idvs, to = idvs) - cross_df <- subset(cross_df, from!=to) - cross_df$type <- "cross" - self$append_fct_edges(cross_df) - }, - - setup_data.nest_lvls = function(fresh, name, role) { - idv <- private$fct_new_id - idl <- private$lvl_new_id - parent <- fresh %@% "keyname" - cross_parents <- fresh %@% "parents" - clabels <- fresh %@% "labels" - idp <- self$fct_id_by_name(c(parent, colnames(cross_parents[[1]]))) - attrs <- attributes(fresh) - fattrs <- do.call(data.frame, c(attrs[setdiff(names(attrs), c("names", "keyname", "role", "parents", "labels"))], - list(stringsAsFactors = FALSE, - id = idv, - name = name, - role = role))) - self$append_fct_nodes(fattrs) - self$append_fct_edges(data.frame(from = idp, to = idv, type = "nest")) - plevels <- rep(names(fresh), lengths(fresh)) - clevels <- unname(unlist(fresh)) - self$append_lvl_nodes(data.frame(idvar = idv, - id = idl:(idl + sum(lengths(fresh)) - 1), - name = clevels, - var = name, - label = unname(unlist(clabels)), - stringsAsFactors = FALSE)) - pids <- self$lvl_id(plevels) - vids <- self$lvl_id(clevels) - self$append_lvl_edges(data.frame(from = pids, to = vids)) - if(!is_null(cross_parents)) { - cross_df <- do.call("rbind", cross_parents[names(fresh)]) - cross_parent_names <- colnames(cross_df) - for(across in cross_parent_names) { - cpids <- self$lvl_id(cross_df[[across]]) - self$append_lvl_edges(data.frame(from = cpids, to = vids)) - } - } - } - - - )) diff --git a/R/nest.R b/R/nest.R index 42d28fbb..f161e78f 100644 --- a/R/nest.R +++ b/R/nest.R @@ -5,12 +5,6 @@ #' left-hand side corresponds to the name of the level (or the level number) of `x` #' and the right-hand side is an integer specifying the number of levels nested under the #' corresponding levels. -#' @param prefix The prefix of the label. -#' @param suffix The suffix of the label. -#' @param leading0 Whether there should be a leading 0 if labels are made. -#' @param sep A separator added between prefix and the number if prefix is empty. -#' @param attrs A named vector where names and values correspond to attribute names and values of the variable, or -#' a data frame. #' @seealso See [set_units()] for examples of how to use this. #' @return A nested level. #' @examples @@ -18,15 +12,11 @@ #' set_units(mainplot = 60, #' subplot = nested_in(mainplot, 10)) #' @export -nested_in <- function(x, ..., prefix = "", suffix = "", - leading0 = FALSE, - sep = edibble_labels_opt("sep"), - attrs = NULL) { +nested_in <- function(x, ...) { top <- caller_env()$.top_env if(is.null(top$.fname)) abort("The `nested_in` function must be used within `set_units` function.") prep <- top$prep vlevs <- prep$fct_levels() - if(prefix=="") prefix <- paste0(top$.fname, sep) parent_name <- as_string(enexpr(x)) parent_vlevels <- vlevs[[parent_name]] dots <- list2(...) @@ -60,22 +50,21 @@ nested_in <- function(x, ..., prefix = "", suffix = "", child_levels <- nestr::nest_in(parent_vlevels, !!!args, - prefix = prefix, - suffix = suffix, + prefix = top$.fname, + suffix = "", distinct = TRUE, - leading0 = leading0, + leading0 = TRUE, compact = FALSE, keyname = parent_name) child_labels <- nestr::nest_in(parent_vlevels, !!!args, - prefix = prefix, - suffix = suffix, + prefix = top$.fname, + suffix = "", distinct = FALSE, - leading0 = leading0, + leading0 = TRUE, compact = FALSE, keyname = parent_name) - lattrs <- as.list(attrs) - attributes(child_levels) <- c(lattrs, attributes(child_levels), + attributes(child_levels) <- c(attributes(child_levels), list(parents = attr(args, "parents"), labels = child_labels)) class(child_levels) <- c("nest_lvls", class(child_levels)) diff --git a/R/provenance.R b/R/provenance.R new file mode 100644 index 00000000..4e33a490 --- /dev/null +++ b/R/provenance.R @@ -0,0 +1,641 @@ + +#' A manipulator for the edbl_design. +#' +#' Internal functions should create a new Provenance object. +#' The Provenance contains a set of operations to manipulate the nodes and edges of +#' the edibble design object. +#' +#' @param class The class for the vertex/node. +#' @param data The nodes data +#' @param name The name of the vertex. +#' @param id The id of the corresponding node. +#' @param input The value of the new graph structure to add. +#' @param initial The intial id. +#' @param abort Whether to abort. +#' @importFrom vctrs vec_is +#' @export +Provenance <- R6::R6Class("Provenance", + public = list( + + #' Initialise function + #' @param design An edibble design. + initialize = function(graph = NULL) { + private$record_track_internal() + #self$add_tracker_to_set_fns(track_fns) + private$graph <- graph %||% empty_edibble_graph() + private$edbl_version <- packageVersion("edibble") + private$session_info <- utils::sessionInfo() + private$tracker <- list(new_trackable()) + }, + + # add_tracker_to_set_fns = function(fnames) { + # for(f in fnames) { + # b <- body(self[[f]]) + # if(length(b) > 1) { + # body(self[[f]]) <- as.call(c(b[[1]], expression(private$record_track_internal()), b[2:length(b)])) + # } + # } + # }, + + set_title = function(title) { + private$record_track_internal() + title <- vctrs::vec_cast(title, character()) + vctrs::vec_assert(title, character(), 1) + private$title <- title + }, + + set_name = function(name) { + private$record_track_internal() + name <- vctrs::vec_cast(name, character()) + vctrs::vec_assert(name, character(), 1) + private$name <- name + }, + + reactivate = function(des, overwrite = c("graph", "anatomy", "recipe")) { + private$record_track_internal() + for(obj in overwrite) { + private[[obj]] <- des[[obj]] + } + }, + + deactivate = function(delete = c("graph", "anatomy", "recipe")) { + private$record_track_internal() + for(obj in delete) { + private[[obj]] <- NULL + } + }, + + + #' @description + #' Get the id based on either the name of the factor node. + #' If none supplied then it will give all. + fct_id = function(name = NULL, role = NULL) { + fnodes <- self$fct_nodes + if(!is_null(role)) { + private$validate_role(role) + fnodes <- fnodes[fnodes$role == role, ] + } + name_to_id <- set_names(fnodes$id, fnodes$name) + name <- name %||% names(name_to_id) + unname(name_to_id[as.character(name)]) + }, + + + #' @description + #' Get the factor parent ids + fct_id_parent = function(id = NULL, role = NULL) { + private$node_id_parent_child(id = id, role = role, node = "factor", return = "parent") + }, + + #' @description + #' Get the factor child ids. If `role` is + #' supplied then the child has to fit `role` + fct_id_child = function(id = NULL, role = NULL) { + private$node_id_parent_child(id = id, role = role, node = "factor", return = "child") + }, + + + #' @description + #' Get the factor ancestor ids + fct_id_ancestor = function(id = NULL, role = NULL) { + private$var_id_ancestor(id = id, role = role, node = "factor") + }, + + + #' @field fct_leaves + #' Get the leave factor ids. + fct_id_leaves = function(role = NULL) { + fids <- self$fct_id(role = role) + has_child <- map_lgl(fids, function(id) length(self$fct_id_child(id = id)) > 0) + fids[!has_child] + }, + + #' @description + #' Get the id based on name of level node. + #' Assumes that level ids obtained are all from the same fid + lvl_id = function(value = NULL, role = NULL, fid = NULL) { + lnodes_list <- self$lvl_nodes + if(!is_null(role)) { + private$validate_role(role) + private$validate_id(fid, 1) + lnodes_list <- lnodes_list[as.character(fct_id(role = role))] + } + if(is_null(fid)) { + if(is_null(value)) { + # return all lvl ids + return(unname(unlist(lapply(lnodes_list, function(x) x$id)))) + } else { + fid_search <- as.integer(names(lnodes_list)) + fid <- self$fct_id_from_lvl_values(value = value, fid_search = fid_search) + return(self$lvl_id(value = value, role = role, fid = fid)) + } + } else { + private$validate_id(fid , 1) + lnodes <- lnodes_list[[as.character(fid)]] + if(!is_null(value)) { + value_to_id <- set_names(lnodes$id, lnodes$value) + unname(value_to_id[as.character(value)]) + } else { + lnodes$id + } + } + }, + + #' @description + #' Get the level parent ids + lvl_id_parent = function(id = NULL, class = NULL) { + private$node_id_parent_child(id = id, role = role, node = "level", return = "parent") + }, + + + #' @description + #' Get the level child ids + lvl_id_child = function(id = NULL, role = NULL) { + private$node_id_parent_child(id = id, role = role, node = "level", return = "child") + }, + + #' @description + #' Get the level ancestor ids + lvl_id_ancestor = function(id = NULL, role = NULL) { + private$var_id_ancestor(id = id, role = role, node = "level") + }, + + #' @param fid_search A vector of fids to search from. + fct_id_from_lvl_id = function(id = NULL, fid_search = NULL) { + lnodes_list <- self$lvl_nodes + if(!is_null(fid_search)) lnodes_list <- lnodes_list[as.character(fid_search)] + for(fname in names(lnodes_list)) { + if(all(id %in% lnodes_list[[fname]]$id)) return(as.integer(fname)) + } + }, + + fct_id_from_lvl_values = function(value = NULL, fid_search = NULL) { + lnodes_list <- self$lvl_nodes + if(!is_null(fid_search)) lnodes_list <- lnodes_list[as.character(fid_search)] + for(fname in names(lnodes_list)) { + if(all(value %in% lnodes_list[[fname]]$value)) return(as.integer(fname)) + } + }, + + lvl_id_from_fct_id = function(fid = NULL) { + lnodes_list <- self$lvl_nodes + lnodes_list[[as.character(fid)]]$id + }, + + #' @description + #' Get the factor names based on id or class + fct_names = function(id = NULL, role = NULL) { + fnodes <- self$fct_nodes + if(!is_null(role)) { + private$validate_role(role) + fnodes <- fnodes[fnodes$role == role, ] + } + id_to_name <- set_names(fnodes$name, fnodes$id) + ids <- id %||% fnodes$id + unname(id_to_name[as.character(ids)]) + }, + + unit_names = function(id = NULL) { + self$fct_names(id = id, role = "edbl_unit") + }, + + trt_names = function(id = NULL) { + self$fct_names(id = id, role = "edbl_trt") + }, + + rcrd_names = function(id = NULL) { + self$fct_names(id = id, role = "edbl_rcrd") + }, + + #' @description + #' Get the level values based on id or class + #' cannot have just role only defined. + #' id must be from the same fid + lvl_values = function(id = NULL, role = NULL, fid = NULL) { + lnodes_list <- self$lvl_nodes + if(!is_null(fid)) { + private$validate_id(fid, 1, role = role) + lnodes <- lnodes_list[[as.character(fid)]] + id <- id %||% lnodes$id + return(lnodes[lnodes$id %in% id, "value"]) + } + if(!is_null(id)) { + fid <- self$fct_id_from_lvl_id(id = id) + self$lvl_values(id = id, role = role, fid = fid) + } else { + abort("`id` or `fid` must be provided.") + } + }, + + unit_values = function(id = NULL, fid = NULL) { + self$lvl_values(id = id, role = "edbl_unit", fid = fid) + }, + + trt_values = function(id = NULL, fid = NULL) { + self$lvl_values(id = id, role = "edbl_trt", fid = fid) + }, + + #' @param uid The unit level id + rcrd_values = function(uid = NULL, fid = NULL) { + lnodes_list <- self$lvl_nodes + if(is_null(fid)) abort("The rcrd id must be supplied.") + private$validate_id(fid, 1, role = "edbl_rcrd") + uid_fct <- self$fct_id_child(id = fid, role = "edbl_unit") + lnodes <- lnodes_list[[as.character(uid_fct)]] + id <- uid %||% lnodes$id + return(lnodes[["attr"]][lnodes$id %in% id, self$fct_names(id = fid)]) + }, + + + + #' @description + #' Get the class of the vertex given the factor id + fct_role = function(id = NULL) { + fnodes <- self$fct_nodes + id_to_role <- pull(nodes, class, id) + ids_fct <- id %||% nodes$id + unname(id_to_class_fct[as.character(ids_fct)]) + }, + + #' @description + #' Get the levels for each factor + fct_levels = function(id = NULL, name = NULL) { + qid <- id %||% self$fct_id(name = name) + lnodes <- self$lvl_nodes + out <- lapply(lnodes[as.character(qid)], function(x) x$value) + names(out) <- self$fct_names(id = qid) + out + }, + + + #' @description + #' One of `name`, `id` or `role` is defined to check if it exists. + #' If more than one of the arguments `name`, `id` and `role` are supplied, then + #' the intersection of it will be checked. + #' @param abort A logical value to indicate whether to abort if it doesn't exist. + fct_exists = function(id = NULL, name = NULL, role = NULL, abort = TRUE) { + exist <- TRUE + abort_missing <- function(vars = NULL, msg = NULL) { + if(abort & !exist) { + if(!is_null(vars)) { + abort(sprintf("%s does not exist in the design.", + .combine_words(paste0("`", vars, "`")))) + } + if(!is_null(msg)) { + abort(msg) + } + } + } + + fnodes <- self$fct_nodes + # at least one node exists + if(is_null(name) & is_null(id) & is_null(role)) { + exist <- nrow(fnodes) > 0 + abort_missing(msg = "There are no factor nodes.") + + } else if(!is_null(name) & is_null(id) & is_null(role)) { + vexist <- name %in% fnodes$name + exist <- all(vexist) + abort_missing(vars = name[!vexist]) + + } else if(is_null(name) & !is_null(id) & is_null(role)) { + vexist <- id %in% fnodes$id + exist <- all(vexist) + abort_missing(vars = id[!vexist]) + + } else if(is_null(name) & is_null(id) & !is_null(role)) { + exist <- any(class %in% fnodes$class) + abort_missing(msg = sprintf("There are no factors with role%s", + .combine_words(paste0("`", role, "`")))) + + } else if(is_null(name) & !is_null(id) & !is_null(role)) { + srole <- fnodes[match(id, fnodes$id), "role"] + vexist <- srole == role + exist <- all(vexist) + abort_missing(vars = id[!vexist]) + + } else if(!is_null(name) & is_null(id) & !is_null(role)) { + srole <- fnodes[match(name, fnodes$name), "class"] + vexist <- srole == role + exist <- all(vexist) + abort_missing(vars = name[!vexist]) + + } else if(!is_null(name) & !is_null(id) & is_null(role)) { + sid <- fnodes[match(name, fnodes$name), "id"] + vexist <- sid == id + exist <- all(vexist) + abort_missing(vars = name[!vexist]) + + } else { + snodes <- fnodes[match(name, fnodes$name), ] + vexist <- snodes$id == id & snodes$role == role + exist <- all(vexist) + abort_missing(vars = name[!vexist]) + } + + return(exist) + }, + + #' @description + #' Check if treatment exists. + trt_exists = function(id = NULL, name = NULL, abort = TRUE) { + self$fct_exists(id = id, name = name, role = "edbl_trt", abort = abort) + }, + + #' @description + #' Check if unit exists. + unit_exists = function(id = NULL, name = NULL, abort = TRUE) { + self$fct_exists(id = id, name = name, role = "edbl_unit", abort = abort) + }, + + #' @description + #' Check if record exists. + rcrd_exists = function(id = NULL, name = NULL, abort = TRUE) { + self$fct_exists(id = id, name = name, role = "edbl_rcrd", abort = abort) + }, + + lvl_exists = function(id = NULL, name = NULL, abort = TRUE) { + self$fct_exists(id = id, name = name, role = "edbl_rcrd", abort = abort) + }, + + #' @description + #' Given node data, append the factor nodes + append_fct_nodes = function(name, role, attrs = NULL) { + n <- length(name) + role <- vctrs::vec_recycle(role, n) + data <- tibble::tibble(id = private$fct_new_id(n = n), + name = name, + role = role, + attrs = attrs) + + self$fct_nodes <- rbind_(self$fct_nodes, data) + }, + + #' @description + #' Given node data, append the level nodes + append_lvl_nodes = function(value, attrs = NULL, fid = NULL) { + lnodes <- self$lvl_nodes + id <- private$lvl_new_id(n = length(value)) + data <- tibble::tibble(id = id, value = value, attrs = attrs) + if(is.null(lnodes[[as.character(fid)]])) { + if(!is_null(attrs)) { + lnodes[[as.character(fid)]] <- new_lnode(id, value, attrs) + } else { + lnodes[[as.character(fid)]] <- new_lnode(id, value) + } + } else { + lnodes[[as.character(fid)]] <- rbind_(lnodes[[as.character(fid)]], data) + } + self$lvl_nodes <- lnodes + }, + + #' @description + #' Given edge data, append the factor edges + append_fct_edges = function(from, to, type = NULL, group = NULL, attrs = NULL) { + self$fct_edges <- rbind_(self$fct_edges, tibble::tibble(from = from, + to = to, + type = type, + group = group, + attrs = attrs)) + }, + + #' @description + #' Given edge data, append the level edges + append_lvl_edges = function(from, to, attrs = NULL) { + self$lvl_edges <- rbind_(self$lvl_edges, tibble::tibble(from = from, + to = to, + attrs = attrs)) + }, + + save_seed = function(seed) { + private$record_track_internal() + if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) + stats::runif(1) + if (is.null(seed)) + RNGstate <- get(".Random.seed", envir = .GlobalEnv) + else { + set.seed(seed) + RNGstate <- structure(seed, kind = as.list(RNGkind())) + } + private$seed <- RNGstate + }, + + get_trail = function() { + private$trail[-length(private$trail)] + }, + + get_seed = function() { + private$seed + }, + + get_session_info = function() { + private$session_info + }, + + get_edibble_version = function() { + private$edibble_version + }, + + record_step = function() { + do.call("on.exit", + list(quote(return(add_edibble_code(returnValue(default = FALSE), + paste(gsub("(^ +| +$)", "", deparse(match.call())), collapse = "")))), + add = TRUE), + envir = parent.frame()) + }, + + record_track_external = function(code) { + ncmds <- length(private$trail) + attr(private$trail[[ncmds]], "external_cmd") <- code + attr(private$trail[[ncmds]], "execution_time") <- Sys.time() + attr(private$trail[[ncmds]], "time_zone") <- Sys.timezone() + private$trail[[ncmds + 1]] <- new_trackable() + } + + ), + + active = list( + #' @field fct_nodes + #' Get the factor nodes + fct_nodes = function(data) { + if(missing(data)) return(self$graph$factors$nodes) + else self$graph$factors$nodes <- data + }, + + #' @field lvl_nodes + #' Get the level nodes + lvl_nodes = function(data) { + if(missing(data)) { + nodes <- self$graph$levels$nodes + return(nodes) + } + else self$graph$levels$nodes <- data + }, + + #' @field fct_edges + #' Get the factor edges + fct_edges = function(data) { + if(missing(data)) { + edges <- self$graph$factors$edges + edges$var_from <- self$fct_names(id = edges$from) + edges$var_to <- self$fct_names(id = edges$to) + return(edges) + } else { + self$graph$factors$edges <- data + } + }, + + #' @field lvl_edges + #' Get the level edges + lvl_edges = function(data) { + if(missing(data)) { + edges <- self$graph$levels$edges + edges$lvl_from <- self$lvl_names(id = edges$from) + edges$lvl_to <- self$lvl_names(id = edges$to) + return(edges) + } else { + self$graph$levels$edges <- data + } + }, + + #' @field fct_n + #' Get the number of nodes in factor graph + fct_n = function(value) { + if (missing(value)) { + nrow(self$fct_nodes) + } else { + stop("Can't set `$fct_n`.") + } + }, + + #' @field lvl_n + #' Get the number of nodes in level graph + lvl_n = function(value) { + if (missing(value)) { + sum(lengths(self$lvl_nodes_list)) + } else { + stop("Can't set `$lvl_n`.") + } + }, + + + + + #' @field rcrd_ids + #' Get the ids for all edbl_rcrd factors. + rcrd_ids = function() { + self$fct_id(role = "edbl_rcrd") + }, + + #' @field unit_ids + #' Get the ids for all edbl_unit factors. + unit_ids = function() { + self$fct_id(role = "edbl_unit") + }, + + #' @field trt_ids + #' Get the ids for all edbl_trt factors. + trt_ids = function() { + self$fct_id(role = "edbl_trt") + }, + + + #' @field is_connected + #' Check if nodes are connected. + is_connected = function() { + nvar <- self$fct_n - length(self$rcrd_ids) + if(nvar==0) return(FALSE) + if(nvar==1) return(TRUE) + ledges <- self$lvl_edges + all(self$lvl_id %in% c(ledges$to, ledges$from)) + } + ), + private = list( + fct_id_last = 0L, + lvl_id_last = 0L, + + title = "An edibble design", + name = NULL, + seed = NULL, + edbl_version = NULL, + session_info = NULL, + trail = NULL, + + anatomy = NULL, + recipe = NULL, + graph = NULL, + + validate_id = function(id, n = NULL, role = NULL) { + id <- vctrs::vec_cast(id, integer()) + if(is.null(n)) { + vctrs::vec_assert(id, integer()) + } else { + vctrs::vec_assert(id, integer(), n) + } + if(!is.null(role)) all(fct_role(id) %in% role) + }, + + validate_role = function(role) { + vctrs::vec_assert(role, character(), 1) + }, + + validate_name = function(name) { + vctrs::vec_assert(name, character()) + }, + + node_id_parent_child = function(id = NULL, role = NULL, node = c("factor", "level"), return = c("child", "parent")) { + type <- match.arg(type) + node <- match.arg(node) + if(node == "factor") { + edges <- self$fct_edges + edges <- edges[!edges$type %in% c("depends", "cross"), ] + } else if(node == "level") { + edges <- self$lvl_edges + } + child_ids <- edges$to + parent_ids <- edges$from + role_ids <- self$fct_id(role = role) + if(return == "parent") return(parent_ids[child_ids %in% id & parent_ids %in% role_ids]) + if(return == "child") return(child_ids[parent_ids %in% id & child_ids %in% role_ids]) + }, + + var_id_ancestor = function(id = NULL, role = NULL, node = c("factor", "level")) { + out <- unique(id) + parent_ids <- private$node_id_parent_child(id = id, role = role, node = node, return = "parent") + if(!is_empty(parent_ids)) { + out <- unique(c(out, private$var_id_ancestor(id = parent_ids, role = role, node = node))) + } + out + }, + + record_track_internal = function() { + do.call("on.exit", + list(quote(private$add_trail_internal(paste(gsub("(^ +| +$)", "", deparse(match.call())), collapse = ""))), + add = TRUE), + envir = parent.frame()) + }, + + add_trail_internal = function(code) { + private$trail[[length(private$trail)]] <- rbind(private$trail[[length(private$trail)]], + new_trackable(internal_cmd = code, + time_internal = Sys.time(), + time_zone_internal = Sys.timezone())) + }, + + + #' @field fct_new_id + #' Get a new factor id. + fct_new_id = function(n = 1) { + ids <- seq(private$fct_last_id + 1, private$fct_last_id + n) + private$fct_last_id <- private$fct_last_id + n + ids + }, + + #' @field lvl_new_id + #' Get a new level id. + lvl_new_id = function(n = 1) { + ids <- seq(private$lvl_last_id + 1, private$lvl_last_id + n) + private$lvl_last_id <- private$lvl_last_id + n + ids + } + )) diff --git a/R/serve.R b/R/serve.R index 30ad5159..249250eb 100644 --- a/R/serve.R +++ b/R/serve.R @@ -20,13 +20,13 @@ #' serve_table() #' @export serve_table <- function(.edibble, use_labels = FALSE, ..., .record = TRUE) { - if(.record) record_step() - prep <- cook_design(.edibble) + if(.record) prep$record_step() if(!prep$is_connected) { lout <- serve_vars_not_reconciled(prep) } else { + #browser() classes <- prep$fct_class() lunit <- ltrt <- lrcrd <- list() if("edbl_unit" %in% classes) lunit <- serve_units(prep) @@ -50,7 +50,7 @@ serve_table <- function(.edibble, use_labels = FALSE, ..., .record = TRUE) { } serve_trts <- function(prep, lunits) { - tids <- prep$unit_ids() + tids <- prep$trt_ids() vnames <- prep$fct_names(id = tids) lvs <- lapply(tids, function(i) { serve_trt(prep, i, lunits) @@ -91,7 +91,7 @@ serve_vars_not_reconciled <- function(prep) { function(avar) { new_edibble_fct(levels = prep$fct_levels(name = avar)[[avar]], name = avar, - class = prep$fct_class(id = prep$fct_id(avar))) + class = prep$fct_class(id = prep$fct_id_by_name(avar))) }) names(res) <- namesv res @@ -100,8 +100,8 @@ serve_vars_not_reconciled <- function(prep) { # Return edibble unit serve_unit_with_child <- function(parent_levels, parent_vname, parent_class, child_labels, child_vname, prep) { - pids <- prep$lvl_id(name = parent_levels) - cids <- prep$lvl_id(name = unique(child_labels)) + pids <- prep$lvl_id_by_value(parent_levels, prep$fct_id_by_name(parent_vname)) + cids <- prep$lvl_id_by_value(unique(child_labels), prep$fct_id_by_name(child_vname)) ledges <- prep$lvl_edges ledges <- ledges[ledges$to %in% cids & ledges$from %in% pids, ] dict <- set_names(prep$lvl_names(ledges$from), prep$lvl_names(ledges$to)) @@ -147,7 +147,7 @@ serve_units <- function(prep) { names(lvs) <- prep$fct_names(id = lid) res <- c(res, lvs) wid <- setdiff(wid, lid) - wprep <- select_units(prep, prep$fct_names(wid)) + wprep <- select_units(prep, prep$fct_names(id = wid)) lid <- wprep$fct_leaves } res @@ -166,7 +166,7 @@ serve_trts <- function(prep, lunits) { serve_trt <- function(prep, tid, lunits) { lnodes <- prep$lvl_nodes ledges <- prep$lvl_edges - tdf <- lnodes[lnodes$idvar == tid, ] + tdf <- lnodes[[as.character(tid)]] ltids <- tdf$id luids <- prep$lvl_child(id = ltids) ledges <- ledges[ledges$to %in% luids & ledges$from %in% ltids,] diff --git a/R/trts.R b/R/trts.R index 75dd1c3d..fd5ff80f 100644 --- a/R/trts.R +++ b/R/trts.R @@ -24,7 +24,8 @@ set_trts <- function(.edibble, ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE) { - if(.record) record_step() + prov <- cook_design(.edibble) + if(.record) prov$record_step() set_fcts(.edibble, ..., .name_repair = .name_repair, .class = "edbl_trt") } diff --git a/R/units.R b/R/units.R index 1458cc94..e0bdfae2 100644 --- a/R/units.R +++ b/R/units.R @@ -62,7 +62,8 @@ set_units <- function(.edibble, ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE) { - if(.record) record_step() + prov <- cook_design(.edibble) + if(.record) prov$record_step() set_fcts(.edibble, ..., .name_repair = .name_repair, .class = "edbl_unit") } @@ -78,7 +79,7 @@ select_units <- function(prep, ...) { vlevs <- prep$fct_levels() loc <- eval_select(expr(tidyselect::all_of(c(...))), vlevs) keep_units <- names(vlevs)[loc] - keep_uids <- prep$fct_id(keep_units) + keep_uids <- prep$fct_id_by_name(keep_units) keep_uids_ancestors <- prep$fct_ancestor(keep_uids, class = "edbl_unit") sprep <- prep$clone() fnodes <- prep$fct_nodes @@ -87,8 +88,8 @@ select_units <- function(prep, ...) { ledges <- prep$lvl_edges sprep$fct_nodes <- fnodes[fnodes$id %in% keep_uids_ancestors, ] sprep$fct_edges <- fedges[fedges$to %in% keep_uids_ancestors & fedges$from %in% keep_uids_ancestors,] - sprep$lvl_nodes <- lnodes[lnodes$idvar %in% keep_uids_ancestors, ] - keep_lids_ancestors <- sprep$lvl_id() + sprep$lvl_nodes <- lnodes[as.character(keep_uids_ancestors)] + keep_lids_ancestors <- sprep$lvl_id sprep$lvl_edges <- ledges[ledges$to %in% keep_lids_ancestors & ledges$from %in% keep_lids_ancestors,] sprep } diff --git a/R/utils.R b/R/utils.R index c2567343..ccb11810 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,66 +1,7 @@ -#' Record the coding step -#' -#' Call this function in functions that modify the edibble design or table so -#' the step is tracked. The output of functions using `record_step()` should -#' be returning an edibble design or table. -#' -#' @return Returns nothing. -#' @export -record_step <- function() { - do.call("on.exit", - list(quote(return(add_edibble_code(returnValue(default = FALSE), - paste(gsub("(^ +| +$)", "", deparse(match.call())), collapse = "")))), - add = TRUE), - envir = parent.frame()) -} - -add_edibble_seed <- function(.edibble, seed) { - if(!isFALSE(.edibble)) { - if(is_edibble_design(.edibble)) { - .edibble$seed <- seed - .edibble - } else { - des <- edbl_design(.edibble) - des$seed <- seed - attr(.edibble, "design") <- des - .edibble - } - } -} - -add_edibble_code <- function(.edibble, code) { - if(!isFALSE(.edibble)) { - if(is_edibble_design(.edibble)) { - .edibble$recipe <- c(.edibble$recipe, code) - .edibble - } else { - des <- edbl_design(.edibble) - des$recipe <- c(des$recipe, code) - attr(.edibble, "design") <- des - .edibble - } - } -} -save_seed <- function(seed) { - if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) - stats::runif(1) - if (is.null(seed)) - RNGstate <- get(".Random.seed", envir = .GlobalEnv) - else { - set.seed(seed) - RNGstate <- structure(seed, kind = as.list(RNGkind())) - } - assign(".RNGstate", RNGstate, envir = parent.frame()) - do.call("on.exit", - list(quote(return(add_edibble_seed(returnValue(default = FALSE), - .RNGstate))), - add = TRUE), - envir = parent.frame()) -} @@ -106,28 +47,28 @@ print.edbl_design <- function(x, decorate_levels = edibble_decorate("levels"), decorate_title = edibble_decorate("title"), title = NULL, ...) { - title <- title %||% x$name %||% "An edibble design" - fnames <- names(x) + title <- title %||% x$provenance$name prep <- cook_design(x) + fids <- prep$fct_nodes$id + fnames <- prep$fct_names(id = fids) - if(is_empty(fnames)) { + if(is_empty(fids)) { data <- data.frame(var = "root", child = NA, label = as.character(decorate_title(title))) } else { - roles <- prep$fct_role() + classes <- prep$fct_class() label_names <- decorate_vars(fnames, decorate_units, decorate_trts, decorate_rcrds, - roles) + classes) var_nlevels <- lengths(prep$fct_levels()[fnames]) - nvar <- length(fnames) - ll <- lapply(fnames, - function(v) { - id <- prep$fct_id_by_name(v) - class <- prep$fct_role(id = id) + nvar <- length(fids) + ll <- lapply(fids, + function(id) { + class <- prep$fct_class(id = id) children <- prep$fct_child(id = id) if(class!="edbl_trt" & !is_empty(children)) { prep$fct_names(id = children) @@ -137,10 +78,10 @@ print.edbl_design <- function(x, }) nodes_with_parents <- unname(unlist(ll)) label_names_with_levels <- paste(label_names, map_chr(var_nlevels, decorate_levels)) - label_names_with_levels[roles=="edbl_rcrd"] <- label_names[roles=="edbl_rcrd"] + label_names_with_levels[classes=="edbl_rcrd"] <- label_names[classes=="edbl_rcrd"] - data <- data.frame(var = c("root", fnames), - child = I(c(list(setdiff(fnames, nodes_with_parents)), ll)), + data <- data.frame(var = c("root", fids), + child = I(c(list(setdiff(fids, nodes_with_parents)), ll)), label = c(decorate_title(title), label_names_with_levels)) } @@ -327,3 +268,23 @@ as.data.frame.edbl_table <- function(x, }) as.data.frame(out) } + +append_recipe_code <- function(.design, new) { + .design$recipe <- c(.design$recipe, new) + prov <- activate_provenance(.design) + prov$record_history_external(new) + .design +} + +add_edibble_code <- function(.edibble, code) { + if(!isFALSE(.edibble)) { + if(is_edibble_design(.edibble)) { + append_recipe_code(.edibble, code) + } else { + des <- edbl_design(.edibble) %>% + append_recipe_code(code) + attr(.edibble, "design") <- des + .edibble + } + } +} diff --git a/man/Kitchen.Rd b/man/Kitchen.Rd deleted file mode 100644 index b18d0484..00000000 --- a/man/Kitchen.Rd +++ /dev/null @@ -1,575 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/kitchen.R -\name{Kitchen} -\alias{Kitchen} -\title{A manipulator for the edbl_design.} -\description{ -A manipulator for the edbl_design. - -A manipulator for the edbl_design. -} -\details{ -Internal functions should create a new Kitchen object. -The Kitchen contains a set of operations to manipulate the nodes and edges of -the edibble design object. -} -\section{Public fields}{ -\if{html}{\out{
}} -\describe{ -\item{\code{design}}{An edibble design object -Initialise function} - -\item{\code{fct_last_id}}{Get the last factor id.} - -\item{\code{lvl_last_id}}{Get the last level id.} -} -\if{html}{\out{
}} -} -\section{Active bindings}{ -\if{html}{\out{
}} -\describe{ -\item{\code{fct_nodes}}{Get the factor nodes} - -\item{\code{lvl_nodes}}{Get the level nodes} - -\item{\code{fct_edges}}{Get the factor edges} - -\item{\code{lvl_edges}}{Get the level edges} - -\item{\code{fct_n}}{Get the number of nodes in factor graph} - -\item{\code{lvl_n}}{Get the number of nodes in level graph} - -\item{\code{fct_last_id}}{Get the last factor id.} - -\item{\code{lvl_last_id}}{Get the last level id.} - -\item{\code{fct_leaves}}{Get the leave factor ids.} - -\item{\code{rcrd_ids}}{Get the ids for all edbl_rcrd factors.} - -\item{\code{unit_ids}}{Get the ids for all edbl_unit factors.} - -\item{\code{trt_ids}}{Get the ids for all edbl_trt factors.} - -\item{\code{trt_names}}{Get the node labels for treatments} - -\item{\code{unit_names}}{Get the node labels for units} - -\item{\code{rcrd_names}}{Get the node labels for record} - -\item{\code{is_connected}}{Check if nodes are connected.} -} -\if{html}{\out{
}} -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-Kitchen-new}{\code{Kitchen$new()}} -\item \href{#method-Kitchen-fct_id_by_name}{\code{Kitchen$fct_id_by_name()}} -\item \href{#method-Kitchen-fct_id_by_role}{\code{Kitchen$fct_id_by_role()}} -\item \href{#method-Kitchen-lvl_id_by_name}{\code{Kitchen$lvl_id_by_name()}} -\item \href{#method-Kitchen-fct_names}{\code{Kitchen$fct_names()}} -\item \href{#method-Kitchen-lvl_names}{\code{Kitchen$lvl_names()}} -\item \href{#method-Kitchen-append_fct_nodes}{\code{Kitchen$append_fct_nodes()}} -\item \href{#method-Kitchen-append_lvl_nodes}{\code{Kitchen$append_lvl_nodes()}} -\item \href{#method-Kitchen-append_fct_edges}{\code{Kitchen$append_fct_edges()}} -\item \href{#method-Kitchen-append_lvl_edges}{\code{Kitchen$append_lvl_edges()}} -\item \href{#method-Kitchen-fct_role}{\code{Kitchen$fct_role()}} -\item \href{#method-Kitchen-lvl_role}{\code{Kitchen$lvl_role()}} -\item \href{#method-Kitchen-fct_child}{\code{Kitchen$fct_child()}} -\item \href{#method-Kitchen-lvl_child}{\code{Kitchen$lvl_child()}} -\item \href{#method-Kitchen-fct_parent}{\code{Kitchen$fct_parent()}} -\item \href{#method-Kitchen-lvl_parent}{\code{Kitchen$lvl_parent()}} -\item \href{#method-Kitchen-fct_ancestor}{\code{Kitchen$fct_ancestor()}} -\item \href{#method-Kitchen-lvl_ancestor}{\code{Kitchen$lvl_ancestor()}} -\item \href{#method-Kitchen-fct_levels}{\code{Kitchen$fct_levels()}} -\item \href{#method-Kitchen-setup_data}{\code{Kitchen$setup_data()}} -\item \href{#method-Kitchen-add_anatomy}{\code{Kitchen$add_anatomy()}} -\item \href{#method-Kitchen-fct_exists}{\code{Kitchen$fct_exists()}} -\item \href{#method-Kitchen-trts_exists}{\code{Kitchen$trts_exists()}} -\item \href{#method-Kitchen-units_exists}{\code{Kitchen$units_exists()}} -\item \href{#method-Kitchen-rcrds_exists}{\code{Kitchen$rcrds_exists()}} -\item \href{#method-Kitchen-clone}{\code{Kitchen$clone()}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-new}{}}} -\subsection{Method \code{new()}}{ -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$new(design = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{design}}{An edibble design.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_id_by_name}{}}} -\subsection{Method \code{fct_id_by_name()}}{ -Get the id based on either the name of the factor node. -If none supplied then it will give all. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_id_by_name(name = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{name}}{The name of the vertex.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_id_by_role}{}}} -\subsection{Method \code{fct_id_by_role()}}{ -Get all ids associated with a role. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_id_by_role(role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_id_by_name}{}}} -\subsection{Method \code{lvl_id_by_name()}}{ -Get the id based on name of level node. -If no name provided, all names returned. -FIXME -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_id_by_name(name = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{name}}{The name of the vertex.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_names}{}}} -\subsection{Method \code{fct_names()}}{ -Get the factor names based on id or role -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_names(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_names}{}}} -\subsection{Method \code{lvl_names()}}{ -Get the level names based on id or role -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_names(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-append_fct_nodes}{}}} -\subsection{Method \code{append_fct_nodes()}}{ -Given node data, append the factor nodes -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$append_fct_nodes(data)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{The nodes data} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-append_lvl_nodes}{}}} -\subsection{Method \code{append_lvl_nodes()}}{ -Given node data, append the level nodes -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$append_lvl_nodes(data)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{The nodes data} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-append_fct_edges}{}}} -\subsection{Method \code{append_fct_edges()}}{ -Given edge data, append the factor edges -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$append_fct_edges(data)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{The nodes data} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-append_lvl_edges}{}}} -\subsection{Method \code{append_lvl_edges()}}{ -Given edge data, append the level edges -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$append_lvl_edges(data)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{data}}{The nodes data} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_role}{}}} -\subsection{Method \code{fct_role()}}{ -Get the role of the vertex given the factor id -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_role(id = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_role}{}}} -\subsection{Method \code{lvl_role()}}{ -Get the role of the vertex given the level id -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_role(id = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_child}{}}} -\subsection{Method \code{fct_child()}}{ -Get the factor child ids. If \code{role} is -supplied then the child has to fit \code{role} -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_child(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_child}{}}} -\subsection{Method \code{lvl_child()}}{ -Get the level child ids -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_child(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_parent}{}}} -\subsection{Method \code{fct_parent()}}{ -Get the factor parent ids -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_parent(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_parent}{}}} -\subsection{Method \code{lvl_parent()}}{ -Get the level parent ids -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_parent(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_ancestor}{}}} -\subsection{Method \code{fct_ancestor()}}{ -Get the factor ancestor ids -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_ancestor(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-lvl_ancestor}{}}} -\subsection{Method \code{lvl_ancestor()}}{ -Get the level ancestor ids -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$lvl_ancestor(id = NULL, role = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_levels}{}}} -\subsection{Method \code{fct_levels()}}{ -Get the levels for each factor -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_levels(id = NULL, name = NULL)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{name}}{The name of the vertex.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-setup_data}{}}} -\subsection{Method \code{setup_data()}}{ -Setup the node and edge data -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$setup_data(fresh, name, role)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{fresh}}{The value of the new graph structure to add.} - -\item{\code{name}}{The name of the vertex.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-add_anatomy}{}}} -\subsection{Method \code{add_anatomy()}}{ -Add the anatomy structure -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$add_anatomy(fresh, name, role)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{fresh}}{The value of the new graph structure to add.} - -\item{\code{name}}{The name of the vertex.} - -\item{\code{role}}{The role for the vertex/node.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-fct_exists}{}}} -\subsection{Method \code{fct_exists()}}{ -One of \code{name}, \code{id} or \code{role} is defined to check if it exists. -If more than one of the arguments \code{name}, \code{id} and \code{role} are supplied, then -the intersection of it will be checked. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$fct_exists(name = NULL, id = NULL, role = NULL, abort = TRUE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{name}}{The name of the vertex.} - -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{role}}{The role for the vertex/node.} - -\item{\code{abort}}{A logical value to indicate whether to abort if it doesn't exist.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-trts_exists}{}}} -\subsection{Method \code{trts_exists()}}{ -Check if treatment exists. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$trts_exists(abort = TRUE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{abort}}{Whether to abort.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-units_exists}{}}} -\subsection{Method \code{units_exists()}}{ -Check if unit exists. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$units_exists(abort = TRUE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{abort}}{Whether to abort.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-rcrds_exists}{}}} -\subsection{Method \code{rcrds_exists()}}{ -Check if record exists. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$rcrds_exists(abort = TRUE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{abort}}{Whether to abort.} -} -\if{html}{\out{
}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Kitchen-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Kitchen$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/Provenance.Rd b/man/Provenance.Rd new file mode 100644 index 00000000..6f6355ff --- /dev/null +++ b/man/Provenance.Rd @@ -0,0 +1,663 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/provenance.R +\name{Provenance} +\alias{Provenance} +\title{A manipulator for the edbl_design.} +\description{ +A manipulator for the edbl_design. + +A manipulator for the edbl_design. +} +\details{ +Internal functions should create a new Provenance object. +The Provenance contains a set of operations to manipulate the nodes and edges of +the edibble design object. +} +\section{Public fields}{ +\if{html}{\out{
}} +\describe{ +\item{\code{fct_new_id}}{Get a new factor id.} + +\item{\code{lvl_new_id}}{Get a new level id.} +} +\if{html}{\out{
}} +} +\section{Active bindings}{ +\if{html}{\out{
}} +\describe{ +\item{\code{fct_nodes}}{Get the factor nodes} + +\item{\code{lvl_nodes}}{Get the level nodes} + +\item{\code{fct_edges}}{Get the factor edges} + +\item{\code{lvl_edges}}{Get the level edges} + +\item{\code{fct_n}}{Get the number of nodes in factor graph} + +\item{\code{lvl_n}}{Get the number of nodes in level graph} + +\item{\code{fct_leaves}}{Get the leave factor ids.} + +\item{\code{rcrd_ids}}{Get the ids for all edbl_rcrd factors.} + +\item{\code{unit_ids}}{Get the ids for all edbl_unit factors.} + +\item{\code{trt_ids}}{Get the ids for all edbl_trt factors.} + +\item{\code{trt_names}}{Get the node labels for treatments} + +\item{\code{unit_names}}{Get the node labels for units} + +\item{\code{rcrd_names}}{Get the node labels for record} + +\item{\code{is_connected}}{Check if nodes are connected.} + +\item{\code{fct_new_id}}{Get a new factor id.} + +\item{\code{lvl_new_id}}{Get a new level id.} +} +\if{html}{\out{
}} +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-Provenance-new}{\code{Provenance$new()}} +\item \href{#method-Provenance-set_name}{\code{Provenance$set_name()}} +\item \href{#method-Provenance-reactivate}{\code{Provenance$reactivate()}} +\item \href{#method-Provenance-deactivate}{\code{Provenance$deactivate()}} +\item \href{#method-Provenance-fct_id_by_name}{\code{Provenance$fct_id_by_name()}} +\item \href{#method-Provenance-fct_id_by_class}{\code{Provenance$fct_id_by_class()}} +\item \href{#method-Provenance-lvl_id_by_value}{\code{Provenance$lvl_id_by_value()}} +\item \href{#method-Provenance-fct_names}{\code{Provenance$fct_names()}} +\item \href{#method-Provenance-lvl_names}{\code{Provenance$lvl_names()}} +\item \href{#method-Provenance-append_fct_nodes}{\code{Provenance$append_fct_nodes()}} +\item \href{#method-Provenance-append_lvl_nodes}{\code{Provenance$append_lvl_nodes()}} +\item \href{#method-Provenance-append_fct_edges}{\code{Provenance$append_fct_edges()}} +\item \href{#method-Provenance-append_lvl_edges}{\code{Provenance$append_lvl_edges()}} +\item \href{#method-Provenance-fct_class}{\code{Provenance$fct_class()}} +\item \href{#method-Provenance-lvl_class}{\code{Provenance$lvl_class()}} +\item \href{#method-Provenance-fct_child}{\code{Provenance$fct_child()}} +\item \href{#method-Provenance-lvl_child}{\code{Provenance$lvl_child()}} +\item \href{#method-Provenance-lvl_id_by_class}{\code{Provenance$lvl_id_by_class()}} +\item \href{#method-Provenance-fct_parent}{\code{Provenance$fct_parent()}} +\item \href{#method-Provenance-lvl_parent}{\code{Provenance$lvl_parent()}} +\item \href{#method-Provenance-fct_ancestor}{\code{Provenance$fct_ancestor()}} +\item \href{#method-Provenance-lvl_ancestor}{\code{Provenance$lvl_ancestor()}} +\item \href{#method-Provenance-fct_levels}{\code{Provenance$fct_levels()}} +\item \href{#method-Provenance-fct_exists}{\code{Provenance$fct_exists()}} +\item \href{#method-Provenance-trts_exists}{\code{Provenance$trts_exists()}} +\item \href{#method-Provenance-units_exists}{\code{Provenance$units_exists()}} +\item \href{#method-Provenance-rcrds_exists}{\code{Provenance$rcrds_exists()}} +\item \href{#method-Provenance-save_seed}{\code{Provenance$save_seed()}} +\item \href{#method-Provenance-get_history}{\code{Provenance$get_history()}} +\item \href{#method-Provenance-get_seed}{\code{Provenance$get_seed()}} +\item \href{#method-Provenance-get_session_info}{\code{Provenance$get_session_info()}} +\item \href{#method-Provenance-get_edibble_version}{\code{Provenance$get_edibble_version()}} +\item \href{#method-Provenance-record_step}{\code{Provenance$record_step()}} +\item \href{#method-Provenance-record_history_external}{\code{Provenance$record_history_external()}} +\item \href{#method-Provenance-record_history_internal}{\code{Provenance$record_history_internal()}} +\item \href{#method-Provenance-add_history_internal}{\code{Provenance$add_history_internal()}} +\item \href{#method-Provenance-clone}{\code{Provenance$clone()}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-new}{}}} +\subsection{Method \code{new()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$new(graph = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{design}}{An edibble design.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-set_name}{}}} +\subsection{Method \code{set_name()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$set_name(name)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{name}}{The name of the vertex.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-reactivate}{}}} +\subsection{Method \code{reactivate()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$reactivate(des, overwrite = c("graph", "anatomy", "recipe"))}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-deactivate}{}}} +\subsection{Method \code{deactivate()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$deactivate(delete = c("graph", "anatomy", "recipe"))}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_by_name}{}}} +\subsection{Method \code{fct_id_by_name()}}{ +Get the id based on either the name of the factor node. +If none supplied then it will give all. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_id_by_name(name = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{name}}{The name of the vertex.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_by_class}{}}} +\subsection{Method \code{fct_id_by_class()}}{ +Get all ids associated with a class. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_id_by_class(class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_by_value}{}}} +\subsection{Method \code{lvl_id_by_value()}}{ +Get the id based on name of level node. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_id_by_value(value = NULL, fid)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_names}{}}} +\subsection{Method \code{fct_names()}}{ +Get the factor names based on id or class +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_names(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_names}{}}} +\subsection{Method \code{lvl_names()}}{ +Get the level names based on id or class +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_names(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_fct_nodes}{}}} +\subsection{Method \code{append_fct_nodes()}}{ +Given node data, append the factor nodes +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_fct_nodes(data)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{data}}{The nodes data} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_lvl_nodes}{}}} +\subsection{Method \code{append_lvl_nodes()}}{ +Given node data, append the level nodes +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_lvl_nodes(data, fid = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{data}}{The nodes data} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_fct_edges}{}}} +\subsection{Method \code{append_fct_edges()}}{ +Given edge data, append the factor edges +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_fct_edges(data)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{data}}{The nodes data} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_lvl_edges}{}}} +\subsection{Method \code{append_lvl_edges()}}{ +Given edge data, append the level edges +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_lvl_edges(data)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{data}}{The nodes data} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_class}{}}} +\subsection{Method \code{fct_class()}}{ +Get the class of the vertex given the factor id +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_class(id = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_class}{}}} +\subsection{Method \code{lvl_class()}}{ +Get the class of the vertex given the level id +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_class(id = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_child}{}}} +\subsection{Method \code{fct_child()}}{ +Get the factor child ids. If \code{class} is +supplied then the child has to fit \code{class} +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_child(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_child}{}}} +\subsection{Method \code{lvl_child()}}{ +Get the level child ids +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_child(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_by_class}{}}} +\subsection{Method \code{lvl_id_by_class()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_id_by_class(class)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_parent}{}}} +\subsection{Method \code{fct_parent()}}{ +Get the factor parent ids +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_parent(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_parent}{}}} +\subsection{Method \code{lvl_parent()}}{ +Get the level parent ids +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_parent(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_ancestor}{}}} +\subsection{Method \code{fct_ancestor()}}{ +Get the factor ancestor ids +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_ancestor(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_ancestor}{}}} +\subsection{Method \code{lvl_ancestor()}}{ +Get the level ancestor ids +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_ancestor(id = NULL, class = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_levels}{}}} +\subsection{Method \code{fct_levels()}}{ +Get the levels for each factor +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_levels(id = NULL, name = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{name}}{The name of the vertex.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_exists}{}}} +\subsection{Method \code{fct_exists()}}{ +One of \code{name}, \code{id} or \code{class} is defined to check if it exists. +If more than one of the arguments \code{name}, \code{id} and \code{class} are supplied, then +the intersection of it will be checked. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_exists(name = NULL, id = NULL, class = NULL, abort = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{name}}{The name of the vertex.} + +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{class}}{The class for the vertex/node.} + +\item{\code{abort}}{A logical value to indicate whether to abort if it doesn't exist.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-trts_exists}{}}} +\subsection{Method \code{trts_exists()}}{ +Check if treatment exists. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$trts_exists(abort = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{abort}}{Whether to abort.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-units_exists}{}}} +\subsection{Method \code{units_exists()}}{ +Check if unit exists. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$units_exists(abort = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{abort}}{Whether to abort.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-rcrds_exists}{}}} +\subsection{Method \code{rcrds_exists()}}{ +Check if record exists. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$rcrds_exists(abort = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{abort}}{Whether to abort.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-save_seed}{}}} +\subsection{Method \code{save_seed()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$save_seed(seed)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_history}{}}} +\subsection{Method \code{get_history()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$get_history()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_seed}{}}} +\subsection{Method \code{get_seed()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$get_seed()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_session_info}{}}} +\subsection{Method \code{get_session_info()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$get_session_info()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_edibble_version}{}}} +\subsection{Method \code{get_edibble_version()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$get_edibble_version()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-record_step}{}}} +\subsection{Method \code{record_step()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$record_step()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-record_history_external}{}}} +\subsection{Method \code{record_history_external()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$record_history_external(code)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-record_history_internal}{}}} +\subsection{Method \code{record_history_internal()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$record_history_internal()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-add_history_internal}{}}} +\subsection{Method \code{add_history_internal()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$add_history_internal(code)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/man/cook_design.Rd b/man/activate_provenance.Rd similarity index 55% rename from man/cook_design.Rd rename to man/activate_provenance.Rd index 728fc894..f432ff29 100644 --- a/man/cook_design.Rd +++ b/man/activate_provenance.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/graph.R -\name{cook_design} -\alias{cook_design} -\title{Cook the design in the kitchen} +\name{activate_provenance} +\alias{activate_provenance} +\title{Activate the provenance in the edibble design object} \usage{ -cook_design(x) +activate_provenance(.edibble, overwrite = c("graph", "anatomy", "recipe")) } \arguments{ \item{x}{An edibble object.} @@ -17,5 +17,5 @@ This is a developer function to create a new Kitchen class with the existing design. } \examples{ -cook_design(takeout()) +activate_provenance(takeout()) } diff --git a/man/design.Rd b/man/design.Rd index 49213da7..2576fcd9 100644 --- a/man/design.Rd +++ b/man/design.Rd @@ -5,14 +5,14 @@ \alias{redesign} \title{Start the edibble design} \usage{ -design(name = NULL, .record = TRUE, seed = NULL, kitchen = Kitchen) +design(name = NULL, .record = TRUE, seed = NULL, provenance = Provenance$new()) redesign( .data, name = NULL, .record = TRUE, seed = NULL, - kitchen = Kitchen, + provenance = provenance, ... ) } @@ -25,8 +25,8 @@ function is used as a wrapper in other code.} \item{seed}{A seed number for reproducibility.} -\item{kitchen}{An environment setup in a manner to manipulate, extract and query -information on the design.} +\item{provenance}{An environment setup in a manner to store methods and +information to trace the origin of the design} \item{.data}{An edibble table.} diff --git a/man/fct_generator.Rd b/man/fct_generator.Rd new file mode 100644 index 00000000..0e270285 --- /dev/null +++ b/man/fct_generator.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/labels.R +\name{fct_generator} +\alias{fct_generator} +\title{Factor name generator} +\usage{ +fct_generator(labels, nlevels) +} +\arguments{ +\item{labels}{A character vector specifying the custom labels for the factor levels.} + +\item{nlevels}{An integer or a vector of integers indicating the number of repetitions for each label. +If a single integer is provided, it is recycled to match the length of \code{labels}. +If a vector is provided, it should have the same length as \code{labels}.} +} +\value{ +A factor with custom levels and repetitions. +} +\description{ +Generate a factor with custom levels and repetitions. +} +\details{ +This function creates a factor with custom labels and specified repetitions for each label. +} +\examples{ +# Example usage of the function +fct_generator(labels = c("A", "B", "C"), nlevels = 3) + +} diff --git a/man/graph_input.Rd b/man/graph_input.Rd new file mode 100644 index 00000000..1e64ff44 --- /dev/null +++ b/man/graph_input.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/graph-input.R +\name{graph_input} +\alias{graph_input} +\title{A function to process input as input for graph manipulation} +\usage{ +graph_input(input, prov, ...) +} +\arguments{ +\item{input}{An input.} + +\item{prov}{A provenance object.} +} +\description{ +A function to process input as input for graph manipulation +} diff --git a/man/label_seq.Rd b/man/label_seq.Rd index a9590282..2db83d7b 100644 --- a/man/label_seq.Rd +++ b/man/label_seq.Rd @@ -16,7 +16,7 @@ label_seq_from_to( suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE + leading_zero = edibble_labels_opt("leading_zero") ) label_seq_from_length( @@ -27,7 +27,7 @@ label_seq_from_length( suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE + leading_zero = edibble_labels_opt("leading_zero") ) label_seq_to_length( @@ -38,7 +38,7 @@ label_seq_to_length( suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE + leading_zero = edibble_labels_opt("leading_zero") ) label_seq_length( @@ -47,7 +47,7 @@ label_seq_length( suffix = "", sep_prefix = "", sep_suffix = "", - leading_zero = TRUE + leading_zero = edibble_labels_opt("leading_zero") ) } \arguments{ @@ -74,7 +74,8 @@ If integer, then pad based on the number supplied.} A character vector containing the labels generated from the sequence. } \description{ -Generate a sequence of labels with custom formatting options +These can be handy for generating pseudo labels for the levels or +factor names using \code{fct_generator} } \examples{ label_seq_to_length(to = 10, length = 5, by = 2) diff --git a/man/lvl_attrs.Rd b/man/lvl_attrs.Rd index 28bd21ae..63df8105 100644 --- a/man/lvl_attrs.Rd +++ b/man/lvl_attrs.Rd @@ -4,20 +4,16 @@ \alias{lvl_attrs} \title{Setting the traits of the levels} \usage{ -lvl_attrs( - levels = NULL, - labels = NULL, - prefix = "", - suffix = "", - sep = edibble_labels_opt("sep"), - include_leading_zero = edibble_labels_opt("leading_zero"), - data = NULL, - ... -) +lvl_attrs(levels = NULL, data = NULL, ...) } \arguments{ \item{levels}{A vector that either denotes the index number or short name of the levels.} +\item{data}{A list or data frame of the same size as the \code{levels}.} + +\item{...}{Name-value pair denoting other level attributes. The value should be the same +length as \code{levels} or a single value.} + \item{labels}{An optional character vector that is the long name format of \code{levels}.} \item{prefix}{The prefix of the labels.} @@ -28,11 +24,6 @@ lvl_attrs( \item{include_leading_zero}{A logical value to indicate whether there should be a leading zero added to level indexes. This is ignored if \code{levels} is not numeric.} - -\item{data}{A list or data frame of the same size as the \code{levels}.} - -\item{...}{Name-value pair denoting other level attributes. The value should be the same -length as \code{levels} or a single value.} } \value{ An edbl_lvls object. diff --git a/man/nested_in.Rd b/man/nested_in.Rd index 38775ba6..061c9e9f 100644 --- a/man/nested_in.Rd +++ b/man/nested_in.Rd @@ -4,15 +4,7 @@ \alias{nested_in} \title{Specify the nesting structure for units} \usage{ -nested_in( - x, - ..., - prefix = "", - suffix = "", - leading0 = FALSE, - sep = edibble_labels_opt("sep"), - attrs = NULL -) +nested_in(x, ...) } \arguments{ \item{x}{The name of the parent unit to nest under.} @@ -21,17 +13,6 @@ nested_in( left-hand side corresponds to the name of the level (or the level number) of \code{x} and the right-hand side is an integer specifying the number of levels nested under the corresponding levels.} - -\item{prefix}{The prefix of the label.} - -\item{suffix}{The suffix of the label.} - -\item{leading0}{Whether there should be a leading 0 if labels are made.} - -\item{sep}{A separator added between prefix and the number if prefix is empty.} - -\item{attrs}{A named vector where names and values correspond to attribute names and values of the variable, or -a data frame.} } \value{ A nested level. diff --git a/man/new_edibble.Rd b/man/new_edibble.Rd index 473592f9..cfcccf2e 100644 --- a/man/new_edibble.Rd +++ b/man/new_edibble.Rd @@ -35,9 +35,6 @@ code step. The default is TRUE. It should remain TRUE unless this function is used as a wrapper in other code.} \item{seed}{A seed number for reproducibility.} - -\item{kitchen}{An environment setup in a manner to manipulate, extract and query -information on the design.} } \value{ An edibble table. diff --git a/man/record_step.Rd b/man/record_step.Rd deleted file mode 100644 index f72cb5e1..00000000 --- a/man/record_step.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{record_step} -\alias{record_step} -\title{Record the coding step} -\usage{ -record_step() -} -\value{ -Returns nothing. -} -\description{ -Call this function in functions that modify the edibble design or table so -the step is tracked. The output of functions using \code{record_step()} should -be returning an edibble design or table. -} From b098da370e47d5186bd50903ba8a0d82f640281c Mon Sep 17 00:00:00 2001 From: Your Name Date: Sat, 12 Aug 2023 19:51:02 -0400 Subject: [PATCH 11/83] major internal change --- NAMESPACE | 8 +- R/allot.R | 57 ++- R/anatomy.R | 4 +- R/assign.R | 104 +++--- R/cross.R | 6 +- R/design.R | 92 ++++- R/edibble.R | 7 +- R/export.R | 2 +- R/fcts.R | 16 +- R/graph-input.R | 89 ++--- R/graph.R | 16 +- R/nest.R | 27 +- R/pivot.R | 4 +- R/plot.R | 13 +- R/provenance.R | 272 +++++++++++--- R/rcrds.R | 34 +- R/serve.R | 147 ++------ R/trts.R | 45 +-- R/units.R | 28 +- R/utils.R | 20 +- man/Provenance.Rd | 582 +++++++++++++++++++---------- man/design.Rd | 8 +- man/select_units.Rd | 19 - tests/testthat/_snaps/menu.md | 86 ++--- tests/testthat/_snaps/nest.md | 6 +- tests/testthat/_snaps/rcrds.md | 21 ++ tests/testthat/_snaps/rcrds.new.md | 16 + tests/testthat/_snaps/serve.new.md | 40 ++ tests/testthat/_snaps/trts.new.md | 433 +++++++++++++++++++++ tests/testthat/_snaps/units.new.md | 81 ++++ tests/testthat/test-design.R | 2 - tests/testthat/test-labels.R | 6 +- tests/testthat/test-nest.R | 46 ++- tests/testthat/test-rcrds.R | 2 +- tests/testthat/test-serve.R | 1 + tests/testthat/test-trts.R | 1 + tests/testthat/test-units.R | 1 + 37 files changed, 1605 insertions(+), 737 deletions(-) delete mode 100644 man/select_units.Rd create mode 100644 tests/testthat/_snaps/rcrds.new.md create mode 100644 tests/testthat/_snaps/serve.new.md create mode 100644 tests/testthat/_snaps/trts.new.md create mode 100644 tests/testthat/_snaps/units.new.md diff --git a/NAMESPACE b/NAMESPACE index dc4cd0bf..69f938a3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,7 +1,12 @@ # Generated by roxygen2: do not edit by hand S3method("!=",edbl_fct) +S3method("$",edbl_lnodes) S3method("==",edbl_fct) +S3method("[",edbl_lnodes) +S3method("[<-",edbl_lnodes) +S3method("[[",edbl_lnodes) +S3method("[[<-",edbl_lnodes) S3method(as.character,edbl_fct) S3method(as.character,edbl_lvls) S3method(as.character,edbl_rcrd) @@ -28,7 +33,7 @@ S3method(print,edbl_table) S3method(print,recipe_design) S3method(print,takeout) S3method(tbl_sum,edbl_table) -S3method(tbl_sum,hstry_table) +S3method(tbl_sum,trck_table) S3method(vec_cast,character.edbl_fct) S3method(vec_cast,character.edbl_trt) S3method(vec_cast,character.edbl_unit) @@ -116,7 +121,6 @@ export(plot_fct_graph) export(plot_lvl_graph) export(redesign) export(scan_menu) -export(select_units) export(serve_table) export(set_rcrds) export(set_rcrds_of) diff --git a/R/allot.R b/R/allot.R index 31a0c729..a4f40d4e 100644 --- a/R/allot.R +++ b/R/allot.R @@ -25,8 +25,8 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { not_edibble(.edibble) des <- edbl_design(.edibble) - prep <- cook_design(des) - if(.record) prep$record_step() + prov <- activate_provenance(des) + if(.record) prov$record_step() dots <- list2(...) if(!is_null(des$allotment)) { @@ -40,29 +40,28 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { trts <- all.vars(f_lhs(dots[[ialloc]])) # there should be only one unit unit <- all.vars(f_rhs(dots[[ialloc]])) - prep$fct_exists(name = unit, class = "edbl_unit") - uid <- prep$fct_id_by_name(unit) + prov$fct_exists(name = unit, role = "edbl_unit") + uid <- prov$fct_id(name = unit) if(length(trts)) { - prep$fct_exists(name = trts, class = "edbl_trt") - tids <- prep$fct_id_by_name(trts) + prov$trt_exists(name = trts) + tids <- prov$fct_id(name = trts) } else { - prep$trts_exists() - classes <- prep$fct_class() - tids <- prep$trt_ids + prov$trt_exists() + tids <- prov$trt_ids } - prep$append_fct_edges(data.frame(from = tids, to = uid, alloc = ialloc, type = "allot")) + prov$append_fct_edges(from = tids, to = uid, group = ialloc, type = "allot") } - des$graph <- prep$graph + des$graph <- prov$get_graph() if(is_edibble_table(.edibble)) { if(length(trts)==0) { - trts <- prep$trt_names + trts <- prov$trt_names() } for(atrt in trts) { - prep$append_lvl_edges(data.frame(from = prep$lvl_id(as.character(.edibble[[atrt]])), - to = prep$lvl_id(as.character(.edibble[[unit]])))) + prov$append_lvl_edges(from = prov$lvl_id(name = as.character(.edibble[[atrt]])), + to = prov$lvl_id(name = as.character(.edibble[[unit]]))) } attr(.edibble, "design") <- des .edibble @@ -104,24 +103,24 @@ allot_units <- function(.edibble, ..., .record = TRUE) { } else { des$allotment <- list(trts = NULL, units = dots) } - prep <- cook_design(des) + prov <- activate_provenance(des) for(ialloc in seq_along(dots)) { # there should be only one unit for `big` big <- all.vars(f_lhs(dots[[ialloc]])) small <- all.vars(f_rhs(dots[[ialloc]])) op <- as.character(as.list(f_rhs(dots[[ialloc]]))[[1]]) - prep$fct_exists(name = small, class = "edbl_unit") - big_id <- prep$fct_id(big) - prep$fct_exists(name = big, class = "edbl_unit") - small_id <- prep$fct_id(small) + prov$fct_exists(name = small, role = "edbl_unit") + big_id <- prov$fct_id(big) + prov$fct_exists(name = big, role = "edbl_unit") + small_id <- prov$fct_id(small) if(!op %in% c("crossed_by", "nested_in")) { - prep$append_fct_edges(data.frame(from = big_id, + prov$append_fct_edges(data.frame(from = big_id, to = small_id[length(small_id)], type = "nest")) if(length(small) > 1) { - prep$append_fct_edges(data.frame(from = big_id, + prov$append_fct_edges(data.frame(from = big_id, to = small_id[length(small_id) - 1], type = "depends")) } @@ -129,32 +128,32 @@ allot_units <- function(.edibble, ..., .record = TRUE) { } } if(is_edibble_design(.edibble)) { - prep$design + prov$design } else if(is_edibble_table(.edibble)) { # Note: for crossed and nested, it's the opposite -> small = big, not big = small. if(op %in% c("crossed_by", "nested_in")) { for(ismall in seq_along(small_id)) { - prep$append_fct_edges(data.frame(from = small_id[ismall], + prov$append_fct_edges(data.frame(from = small_id[ismall], to = big_id, type = "nest")) if(op == "crossed_by") { cross_df <- expand.grid(from = small_id, to = small_id) cross_df <- cross_df[cross_df$from!=cross_df$to,] cross_df$type <- "cross" - prep$append_fct_edges(cross_df) + prov$append_fct_edges(cross_df) } - prep$append_lvl_edges(data.frame(from = prep$lvl_id(as.character(.edibble[[small[ismall]]])), - to = prep$lvl_id(as.character(.edibble[[big]])))) + prov$append_lvl_edges(data.frame(from = prov$lvl_id(as.character(.edibble[[small[ismall]]])), + to = prov$lvl_id(as.character(.edibble[[big]])))) } } else { for(asmall in small) { - prep$append_lvl_edges(data.frame(from = prep$lvl_id(as.character(.edibble[[big]])), - to = prep$lvl_id(as.character(.edibble[[asmall]])))) + prov$append_lvl_edges(data.frame(from = prov$lvl_id(as.character(.edibble[[big]])), + to = prov$lvl_id(as.character(.edibble[[asmall]])))) } } - attr(.edibble, "design") <- prep$design + attr(.edibble, "design") <- prov$design .edibble } diff --git a/R/anatomy.R b/R/anatomy.R index 3f1bcf08..e21bb668 100644 --- a/R/anatomy.R +++ b/R/anatomy.R @@ -15,8 +15,8 @@ anatomy <- function(.edibble, ...) { des <- edbl_design(.edibble) tab <- edbl_table(.edibble) - prep <- cook_design(des) - trt_str <- stats::as.formula(paste0("~", paste0(prep$trt_names, collapse = "*"))) + prov <- activate_provenance(des) + trt_str <- stats::as.formula(paste0("~", paste0(prov$trt_names, collapse = "*"))) out <- dae::designAnatomy(list(unit = des$anatomy, trt = trt_str), data = tab, ...) structure(out, class = c("des_anatomy", class(out))) diff --git a/R/assign.R b/R/assign.R index 2fcd0936..dce77507 100644 --- a/R/assign.R +++ b/R/assign.R @@ -38,73 +38,63 @@ assign_trts <- function(.design, order = "random", seed = NULL, constrain = nesting_structure(.design), ..., .record = TRUE) { not_edibble(.design) - prep <- cook_design(.design) - if(.record) prep$record_step() + prov <- activate_provenance(.design) + if(.record) prov$record_step() - prep$save_seed(seed) + prov$save_seed(seed) - order <- rep(order, length.out = length(.design$allotment$trts)) - - for(ialloc in seq_along(.design$allotment$trts)) { - trts <- all.vars(f_lhs(.design$allotment$trts[[ialloc]])) + fedges <- prov$fct_edges + allotments <- fedges[fedges$type == "allot", ] + alloc_groups <- unique(allotments$group) + order <- rep(order, length.out = length(alloc_groups)) + for(igroup in alloc_groups) { + trts_id <- allotments[allotments$group == igroup, ]$from # there should be only one unit - unit <- all.vars(f_rhs(.design$allotment$trts[[ialloc]])) - uid <- prep$fct_id_by_name(unit) - if(length(trts)) { - tids <- prep$fct_id_by_name(trts) - } else { - classes <- prep$fct_class() - tids <- prep$trt_ids - } - - lnodes <- prep$lvl_nodes - luids <- lnodes[[as.character(uid)]]$id - tdf <- prep$fct_levels()[prep$fct_names(tids)] - tidf <- expand.grid(tdf, stringsAsFactors = FALSE) - ntrts <- nrow(tidf) - permutation <- switch(order[ialloc], - "systematic" = rep(1:nrow(tidf), length.out = length(luids)), - "systematic-random" = rep(sample(nrow(tidf)), length.out = length(luids)), + unit_id <- unique(allotments[allotments$group == igroup, ]$to) + unit_nm <- prov$fct_names(id = unit_id) + lnodes <- prov$lvl_nodes + unit_level_ids <- lnodes[[unit_id]]$id + nunits <- length(unit_level_ids) + + trts_list <- prov$fct_levels(id = trts_id, return = "id") + # only allows for factorial treatment structure for now + trts_df <- expand.grid(trts_list, stringsAsFactors = FALSE) + ntrts <- nrow(trts_df) + permutation <- switch(order[igroup], + "systematic" = rep(1:ntrts, length.out = nunits), + "systematic-random" = rep(sample(ntrts), length.out = nunits), "random" = { - if(is_empty(constrain[[unit]])) { - out <- as.vector(replicate(ceiling(length(luids) / nrow(tidf)), - sample(nrow(tidf)))) - sample(out[1:length(luids)]) + if(is_empty(constrain[[unit_nm]])) { + out <- as.vector(replicate(ceiling(nunits / ntrts), + sample(ntrts))) + sample(out[1:nunits]) } else { # FIXME the ancestor should be found # based on `constrain` # find the grandest ancestor - vanc <- prep$fct_ancestor(id = uid) - vanc <- vanc[vanc %in% prep$unit_ids] - udf <- as.data.frame(serve_units(select_units(prep, prep$fct_names(vanc)))) - - vparents <- prep$fct_parent(id = uid) - vparents <- vparents[vparents %in% prep$unit_ids] - vparents <- setdiff(vparents, uid) - + vanc <- prov$fct_id_ancestor(id = unit_id, role = "edbl_unit") + units_df <- tibble::as_tibble(prov$serve_units(id = vanc)) + vparents <- prov$fct_id_parent(id = unit_id, role = "edbl_unit") if(length(vparents)==1L) { - permute_parent_one_alg(prep, vparents, udf, ntrts) + permute_parent_one_alg(prov, vparents, units_df, ntrts) } else { - permute_parent_more_than_one(prep, vparents, udf, ntrts) + permute_parent_more_than_one(prov, vparents, units_df, ntrts) } } }, - order_trts(structure(order, class = order), prep, constrain, tidf, ...)) - - tout <- tidf[permutation, , drop = FALSE] + order_trts(structure(order, class = order), prov, constrain, trts_df, ...)) + trts_full_df <- trts_df[permutation, , drop = FALSE] - for(itvar in seq_along(tout)) { - fid <- prep$fct_id_by_name(names(tout)[itvar]) - prep$append_lvl_edges(data.frame(from = prep$lvl_id_by_value(tout[[itvar]], fid), - to = luids, - lloc = ialloc)) + for(itvar in seq_along(trts_full_df)) { + prov$append_lvl_edges(from = trts_full_df[[itvar]], + to = unit_level_ids) } } - .design$graph <- prep$graph + .design$graph <- prov$get_graph() .design$assignment <- order .design } @@ -118,16 +108,16 @@ assign_units <- function(.design, order = "random", seed = NULL, constrain = nes if(.record) record_step() save_seed(seed) - prep <- cook_design(.design) + prov <- activate_provenance(.design) for(ialloc in seq_along(.design$allotment$units)) { lhs <- all.vars(f_lhs(.design$allotment$units[[ialloc]])) rhs <- all.vars(f_rhs(.design$allotment$units[[ialloc]])) - lnodes <- prep$lvl_nodes + lnodes <- prov$lvl_nodes - lhs_id <- lnodes[[prep$fct_id_by_name(lhs)]]$id - udf <- as.data.frame(serve_units(select_units(prep, rhs))) + lhs_id <- lnodes[[prov$fct_id(name = lhs)]]$id + udf <- as.data.frame(serve_units(select_units(prov, rhs))) udf <- udf[rhs] small_df <- data.frame(lhs = lhs_id) permutation <- switch(order, @@ -137,16 +127,16 @@ assign_units <- function(.design, order = "random", seed = NULL, constrain = nes # FIXME the ancestor should be found # based on `constrain`?? - vparents <- prep$fct_id_by_name(rhs[-length(rhs)]) + vparents <- prov$fct_id_by_name(rhs[-length(rhs)]) if(length(rhs)==1L) { out <- as.vector(replicate(ceiling(nrow(udf)/nrow(small_df)), sample(nrow(small_df)))) out[1:nrow(udf)] } else if(length(rhs)==2L) { - permute_parent_one_alg(prep, vparents, udf, nrow(small_df)) + permute_parent_one_alg(prov, vparents, udf, nrow(small_df)) } else { - permute_parent_more_than_one(prep, vparents, udf, nrow(small_df)) + permute_parent_more_than_one(prov, vparents, udf, nrow(small_df)) } }, abort("not implemented yet")) @@ -154,12 +144,12 @@ assign_units <- function(.design, order = "random", seed = NULL, constrain = nes browser() for(itvar in seq_along(tout)) { - prep$append_lvl_edges(data.frame(from = tout[[itvar]], - to = prep$lvl_id(udf[[rhs[length(rhs)]]]), + prov$append_lvl_edges(data.frame(from = tout[[itvar]], + to = prov$lvl_id(udf[[rhs[length(rhs)]]]), alloc = ialloc)) } } - prep$design + prov$design } diff --git a/R/cross.R b/R/cross.R index 8b6ff4ab..c3e1789d 100644 --- a/R/cross.R +++ b/R/cross.R @@ -5,10 +5,6 @@ #' as well as adding new attributes. #' #' @param ... a sequence of units -#' @param prefix Currently not implemented.The prefix of the label. -#' @param suffix Currently not implemented.The suffix of the label. -#' @param leading0 Currently not implemented.Whether there should be a leading 0 if labels are made. -#' @param sep Currently not implemented.A separator added between prefix and the number if prefix is empty. #' @param attrs Currently not implemented. #' @examples #' design("Strip-Plot Design | Strip-Unit Design") %>% @@ -18,7 +14,7 @@ #' unit = nested_in(block, crossed_by(row, col))) #' @return An object of class "cross_lvls". #' @export -crossed_by <- function(..., prefix = NULL, suffix = NULL, leading0 = NULL, sep = NULL, attrs = NULL) { +crossed_by <- function(..., attrs = NULL) { e <- exprs(...) structure(as.character(e), attrs = attrs, class = "cross_lvls") diff --git a/R/design.R b/R/design.R index 3dc77ebe..3d33067f 100644 --- a/R/design.R +++ b/R/design.R @@ -18,10 +18,10 @@ #' @export design <- function(title = NULL, name = "edibble", .record = TRUE, seed = NULL, provenance = Provenance$new()) { if(.record) provenance$record_step() - if(!is.null(title)) provenance$set_name(title) + if(!is.null(title)) provenance$set_title(title) provenance$set_name(name) provenance$save_seed(seed) - structure(list(graph = provenance$graph, + structure(list(graph = provenance$get_graph(), provenance = provenance, anatomy = NULL, recipe = NULL), @@ -42,12 +42,96 @@ empty_edibble_graph <- function() { role = character(), name = character(), attrs = list()) - lnodes <- list() - fedges <- tibble::tibble(from = integer(), to = integer(), + lnodes <- structure(list(), class = c("edbl_lnodes", "list")) + fedges <- tibble::tibble(from = integer(), to = integer(), type = character(), group = integer(), attrs = list()) ledges <- tibble::tibble(from = integer(), to = integer(), attrs = list()) + new_edibble_graph(fnodes, lnodes, fedges, ledges) +} + + +as.list.edbl_lnodes <- function(x, ...) { + class(x) <- unique(c(setdiff(class(x), "edbl_lnodes"), "list")) + x +} + +# I don't know if this is a good idea but the level nodes are stored +# as a list of nodes +# below replaces some common `extract` options to make it feel like +# a data.frame instead + +#' Extract or replace parts of the level nodes +#' +#' The level nodes are stored as a named list of nodes where the name +#' corresponds to the id of the corresponding factor. This makes the +#' access of level nodes slightly awkward. For example, to extract the +#' id of the level nodes, you have to iterate over every list. +#' +#' @examples +#' crd <- takeout(menu_crd()) +#' +#' +#' +#' @name extract-lvl-nodes +NULL + +#' @rdname extract-lvl-nodes +#' @export +"$.edbl_lnodes" <- function(x, name) { + unname(unlist(lapply(x, function(.x) .x[[name]]))) +} + +#' @rdname extract-lvl-nodes +#' @export +"[.edbl_lnodes" <- function(x, i, ...) { + lx <- as.list(x) + if(is.numeric(i)) { + structure(lx[as.character(i)], class = class(x)) + } else { + structure(lx[i], class = class(x)) + } +} + +#' @rdname extract-lvl-nodes +#' @export +"[<-.edbl_lnodes" <- function(x, i, ..., value) { + lx <- as.list(x) + browser() + if(is.numeric(i)) { + lx[as.character(i)] <- value + } else { + lx[i] <- value + } + invisible(structure(lx, class = class(x))) +} + +#' @rdname extract-lvl-nodes +#' @export +"[[.edbl_lnodes" <- function(x, i, ...) { + lx <- as.list(x) + if(is.numeric(i)) { + lx[[as.character(i)]] + } else { + lx[[i]] + } +} + +#' @rdname extract-lvl-nodes +#' @export +"[[<-.edbl_lnodes" <- function(x, i, ..., value) { + lx <- as.list(x) + if(is.numeric(i)) { + lx[[as.character(i)]] <- value + } else { + lx[[i]] <- value + } + invisible(structure(lx, class = class(x))) +} + +new_edibble_graph <- function(fnodes, lnodes, fedges, ledges) { + if(!inherits(lnodes, "edbl_lnodes")) class(lnodes) <- c("edbl_lnodes", class(lnodes)) structure(list(factors = list(nodes = fnodes, edges = fedges), levels = list(nodes = lnodes, diff --git a/R/edibble.R b/R/edibble.R index b74e4e0e..742fef9b 100644 --- a/R/edibble.R +++ b/R/edibble.R @@ -166,9 +166,10 @@ tbl_sum.edbl_table <- function(x) { #' @export print.edbl_table <- function(x, ..., n = NULL, width = NULL, n_extra = NULL) { - name <- edbl_design(x)$name - format_name <- style_subtle(paste("#", cli::style_bold(name))) - if(!is.null(name)) cat(format_name, "\n") + prov <- activate_provenance(x) + title <- prov$get_title() + format_title <- style_subtle(paste("#", cli::style_bold(title))) + if(!is.null(title)) cat(format_title, "\n") NextMethod() } diff --git a/R/export.R b/R/export.R index dd602ab3..2f3511a6 100644 --- a/R/export.R +++ b/R/export.R @@ -276,7 +276,7 @@ export_design <- function(.data, file, author, date = Sys.Date(), overwrite = FA } else { abort("The input is not an edibble table.") } - prep <- cook_design(.design) + prep <- activate_provenance(.design) title <- .design$name sheet_names <- make_sheet_names(prep) diff --git a/R/fcts.R b/R/fcts.R index f316da00..7301519f 100644 --- a/R/fcts.R +++ b/R/fcts.R @@ -16,22 +16,22 @@ set_fcts <- function(.edibble, ..., .class = NULL, not_edibble(.edibble) .name_repair <- match.arg(.name_repair) - prep <- cook_design(.edibble) + prov <- activate_provenance(.edibble) if(is_edibble_design(.edibble)) { dots <- enquos(..., .named = TRUE, .homonyms = "error", .check_assign = TRUE) fnames_new <- names(dots) - fnames_old <- names(prep$graph) + fnames_old <- names(prov$graph) fnames <- vec_as_names(c(fnames_old, fnames_new), repair = .name_repair) for(i in seq_along(dots)) { fname <- fnames[i + length(fnames_old)] - fresh <- eval_tidy(dots[[i]], data = c(prep$fct_levels(), list(prep = prep, .fname = fname))) - .edibble$anatomy <- add_anatomy(.edibble$anatomy, fresh, fname, .class) - prep$setup_data(fresh, fname, .class) + input <- eval_tidy(dots[[i]], data = c(prov$fct_levels(return = "value"), list(prov = prov, .fname = fname))) + .edibble$anatomy <- add_anatomy(.edibble$anatomy, input, fname, .class) + graph_input(input, prov, fname, .class) } - .edibble$graph <- prep$graph + .edibble$graph <- prov$get_graph() } else if(is_edibble_table(.edibble)) { @@ -44,9 +44,9 @@ set_fcts <- function(.edibble, ..., .class = NULL, levels = lvls, class = .class, name = fname) - prep$setup_data(.edibble[[loc[i]]], fname, .class) + graph_input(.edibble[[loc[i]]], prov, fname, .class) # FIXME - attr(.edibble, "design") <- prep$design + attr(.edibble, "design") <- prov$design } diff --git a/R/graph-input.R b/R/graph-input.R index 42249bbc..30d6969f 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -29,92 +29,67 @@ graph_input.default <- function(input, prov, name, class) { rep = unname(input)), class = class), "unimplemented" = abort(paste0("Not sure how to handle ", class(input)[1]))) - graph_input.edbl_lvls(levels, name, class) + graph_input.edbl_lvls(levels, prov, name, class) } graph_input.edbl_lvls <- function(input, prov, name, class) { - fid <- private$fct_new_id(n = 1) - attrs <- attributes(input) - - fattrs <- data.frame(id = fid, name = name, class = class) - self$append_fct_nodes(fattrs) - + attrs <- NULL # attributes(input) + prov$append_fct_nodes(name = name, role = class, attrs = attrs) lattrs <- lvl_data(input) - lattrs$id <- private$lvl_new_id(length(input)) - - self$append_lvl_nodes(lattrs, fid) + prov$append_lvl_nodes(value = lattrs$value, fid = prov$fct_id(name = name)) } graph_input.formula <- function(input, prov, name, class) { - flevels <- self$fct_levels() tt <- terms(input) vars <- rownames(attr(tt, "factor")) - - private$graph_input.cross_lvls(vars, prov, name, class) -} - -graph_input.edbl_fct <- function(input, prov, name, class) { - # this looks the same as graph_input.edbl_levels??? - fid <- private$fct_new_id - self$append_fct_nodes(tibble(id = fid, name = name, class = class)) - - lvls <- levels(input) - lattrs <- tibble(id = private$lvl_new_id(length(lvls)), - value = lvls) - - self$append_lvl_nodes(lattrs, fid) + graph_input.cross_lvls(vars, prov, name, class) } graph_input.cross_lvls <- function(input, prov, name, class) { - flevels <- self$fct_levels() + flevels <- prov$fct_levels(return = "value") vars <- input pdf <- expand.grid(flevels[vars]) - pdf[[name]] <- fct_attrs(levels = lvl_attrs(1:nrow(pdf), prefix = name), + pdf[[name]] <- fct_attrs(levels = lvl_attrs(label_seq_length(nrow(pdf), prefix = name)), class = class) - private$graph_input.edbl_lvls(pdf[[name]], name, class) - idv <- self$fct_id_by_name(name) - for(avar in vars) { - idp <- self$fct_id_by_name(avar) - self$append_fct_edges(data.frame(from = idp, to = idv, type = "nest")) - self$append_lvl_edges(data.frame(from = self$lvl_id_by_value(pdf[[avar]], idp), - to = self$lvl_id_by_value(pdf[[name]], idv))) + # create notes for the crossed unit + graph_input.edbl_lvls(pdf[[name]], prov, name, class) + # for every parent unit, draw edges for factor and level graphs + for(var in vars) { + puid <- prov$fct_id(name = var) + cuid <- prov$fct_id(name = name) + prov$append_fct_edges(from = puid, to = cuid, type = "cross") + prov$append_lvl_edges(from = prov$lvl_id(value = pdf[[var]], fid = puid), + # TODO: this asserts that the level is a character + # which is reasonable at this stage, but I may like to make + # this more flexible in future + to = prov$lvl_id(value = as.character(pdf[[name]]), fid = cuid)) } - idvs <- self$fct_id_by_name(vars) - cross_df <- expand.grid(from = idvs, to = idvs) - cross_df <- subset(cross_df, from!=to) - cross_df$type <- "cross" - self$append_fct_edges(cross_df) } -graph_input.nest_lvls <- function(input, name, class) { - - idv <- private$fct_new_id() +graph_input.nest_lvls <- function(input, prov, name, class) { parent <- input %@% "keyname" cross_parents <- input %@% "parents" clabels <- input %@% "labels" - idp <- self$fct_id_by_name(c(parent, colnames(cross_parents[[1]]))) - attrs <- attributes(input) - fattrs <- tibble::tibble(id = idv, - name = name, - class = class) - self$append_fct_nodes(fattrs) - self$append_fct_edges(tibble(from = idp, to = idv, type = "nest")) + attrs <- NULL # attributes(input) + prov$append_fct_nodes(name = name, role = class) + idp <- prov$fct_id(name = parent) + idv <- prov$fct_id(name = name) + prov$append_fct_edges(from = idp, to = idv, type = "nest") plevels <- rep(names(input), lengths(input)) clevels <- unname(unlist(input)) - pids <- self$lvl_id_by_value(plevels, idp) - vids <- private$lvl_new_id(length(clevels)) - self$append_lvl_nodes(tibble::tibble(id = vids, - value = clevels), - idv) + pids <- prov$lvl_id(value = plevels, fid = idp) + prov$append_lvl_nodes(value = clevels, fid = idv) + vids <- prov$lvl_id(value = clevels, fid = idv) + prov$append_lvl_edges(from = pids, to = vids) - self$append_lvl_edges(tibble::tibble(from = pids, to = vids)) if(!is_null(cross_parents)) { cross_df <- do.call("rbind", cross_parents[names(input)]) cross_parent_names <- colnames(cross_df) for(across in cross_parent_names) { - cpids <- self$lvl_id(cross_df[[across]]) - self$append_lvl_edges(tibble::tibble(from = cpids, to = vids)) + prov$append_fct_edges(from = prov$fct_id(name = across), to = idv, type = "cross") + cpids <- prov$lvl_id(value = cross_df[[across]]) + prov$append_lvl_edges(from = cpids, to = vids) } } } diff --git a/R/graph.R b/R/graph.R index 68ad8bc9..7d3c2aa0 100644 --- a/R/graph.R +++ b/R/graph.R @@ -38,15 +38,15 @@ NULL #' @rdname design_data #' @export fct_nodes <- function(edibble) { - prep <- activate_provenance(edibble) - prep$fct_nodes + prov <- activate_provenance(edibble) + prov$fct_nodes } #' @rdname design_data #' @export fct_edges <- function(edibble) { - prep <- activate_provenance(edibble) - prep$fct_edges + prov <- activate_provenance(edibble) + prov$fct_edges } @@ -54,15 +54,15 @@ fct_edges <- function(edibble) { #' @rdname design_data #' @export lvl_nodes <- function(edibble) { - prep <- activate_provenance(edibble) - prep$lvl_nodes + prov <- activate_provenance(edibble) + prov$lvl_nodes } #' @rdname design_data #' @export lvl_edges <- function(edibble) { - prep <- activate_provenance(edibble) - prep$lvl_edges + prov <- activate_provenance(edibble) + prov$lvl_edges } diff --git a/R/nest.R b/R/nest.R index f161e78f..64e2379d 100644 --- a/R/nest.R +++ b/R/nest.R @@ -15,22 +15,17 @@ nested_in <- function(x, ...) { top <- caller_env()$.top_env if(is.null(top$.fname)) abort("The `nested_in` function must be used within `set_units` function.") - prep <- top$prep - vlevs <- prep$fct_levels() + prov <- top$prov + vlevs <- prov$fct_levels(return = "value") parent_name <- as_string(enexpr(x)) parent_vlevels <- vlevs[[parent_name]] dots <- list2(...) args <- list() for(.x in dots) { - ind <- is_cross_levels(.x) | is_formula(.x, lhs = FALSE) - if(ind) { - if(is_formula(.x, lhs = FALSE)) { - vars <- rownames(attr(stats::terms(.x), "factors")) - } else { - vars <- .x - } + if(is_cross_levels(.x) | is_formula(.x, lhs = FALSE)) { + vars <- if(is_formula(.x, lhs = FALSE)) rownames(attr(stats::terms(.x), "factors")) else .x child_lvls_by_parent <- map(vars, function(.var) { - out <- serve_units(select_units(prep, .var, parent_name)) + out <- prov$serve_units(id = prov$fct_id(name = c(.var, parent_name)), return = "value") split(out[[.var]], out[[parent_name]]) }) names(child_lvls_by_parent) <- vars @@ -79,12 +74,12 @@ nested_in <- function(x, ...) { #' @return Return a named list. Only shows the direct parent. #' @export nesting_structure <- function(design) { - prep <- cook_design(design) - uids <- prep$unit_ids - fedges <- prep$fct_edges - ndf <- fedges[fedges$from %in% uids & fedges$to %in% uids & !fedges$type %in% c("depends", "cross"),] - from <- prep$fct_names(ndf$from) - to <- prep$fct_names(ndf$to) + prov <- activate_provenance(design) + uids <- prov$unit_ids + fedges <- prov$fct_edges + ndf <- fedges[fedges$from %in% uids & fedges$to %in% uids, ] + from <- prov$fct_names(id = ndf$from) + to <- prov$fct_names(id = ndf$to) split(from, to) } diff --git a/R/pivot.R b/R/pivot.R index be438d7d..9929fe8b 100644 --- a/R/pivot.R +++ b/R/pivot.R @@ -14,9 +14,9 @@ pivot_trts_widelist <- function(.data, trts = NULL, fcts = NULL, drop = FALSE) { not_edibble(.data) data <- as.data.frame(.data, levels_as = "character") - des <- cook_design(.data) + prov <- activate_provenance(.data) if(is.null(trts)) { - trt_names <- des$trt_names + trt_names <- prov$trt_names() } else { tloc <- eval_select(enexpr(trts), .data) trt_names <- names(tloc) diff --git a/R/plot.R b/R/plot.R index 79bcb8ee..04e3a1ee 100644 --- a/R/plot.R +++ b/R/plot.R @@ -24,11 +24,12 @@ plot.edbl_design <- function(x, which = c("factors", "levels"), if(!requireNamespace("visNetwork")) abort("You need to install `visNetwork` package.") which <- match.arg(which) view <- match.arg(view) - prep <- cook_design(x) + prov <- activate_provenance(x) nodes <- switch(which, - "factors" = prep$fct_nodes, - "levels" = prep$lvl_nodes) + "factors" = prov$fct_nodes, + # FIXME + "levels" = prov$lvl_nodes) nodes$group <- switch(which, "factors" = gsub("edbl_", "", nodes$class), "levels" = nodes$var) @@ -36,7 +37,7 @@ plot.edbl_design <- function(x, which = c("factors", "levels"), class2shape <- c("edbl_unit" = "circle", "edbl_trt" = "diamond", "edbl_rcrd" = "database") - nodes$shape <- class2shape[prep$fct_class(nodes$idvar)] + nodes$shape <- class2shape[prov$fct_class(nodes$idvar)] main <- names(title) %||% title %||% x$name main_style <- ifelse(is_named(title), title, "") @@ -46,8 +47,8 @@ plot.edbl_design <- function(x, which = c("factors", "levels"), footer_style <- ifelse(is_named(footer), footer, "") background <- ifelse(background=="transparent", "rgba(0, 0, 0, 0)", background) edges <- switch(which, - "factors" = prep$fct_edges, - "levels" = prep$lvl_edges) + "factors" = prov$fct_edges, + "levels" = prov$lvl_edges) if(nrow(edges)) { if(which=="factors") { # this doesn't seem to work diff --git a/R/provenance.R b/R/provenance.R index 4e33a490..c9ed3c55 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -5,7 +5,7 @@ #' The Provenance contains a set of operations to manipulate the nodes and edges of #' the edibble design object. #' -#' @param class The class for the vertex/node. +#' @param role The role for the vertex/node. #' @param data The nodes data #' @param name The name of the vertex. #' @param id The id of the corresponding node. @@ -25,7 +25,7 @@ Provenance <- R6::R6Class("Provenance", private$graph <- graph %||% empty_edibble_graph() private$edbl_version <- packageVersion("edibble") private$session_info <- utils::sessionInfo() - private$tracker <- list(new_trackable()) + private$trail <- list(new_trackable()) }, # add_tracker_to_set_fns = function(fnames) { @@ -77,7 +77,7 @@ Provenance <- R6::R6Class("Provenance", } name_to_id <- set_names(fnodes$id, fnodes$name) name <- name %||% names(name_to_id) - unname(name_to_id[as.character(name)]) + unname(name_to_id[name]) }, @@ -118,23 +118,22 @@ Provenance <- R6::R6Class("Provenance", if(!is_null(role)) { private$validate_role(role) private$validate_id(fid, 1) - lnodes_list <- lnodes_list[as.character(fct_id(role = role))] + lnodes_list <- lnodes_list[self$fct_id(role = role)] } if(is_null(fid)) { if(is_null(value)) { # return all lvl ids - return(unname(unlist(lapply(lnodes_list, function(x) x$id)))) + return(lnodes_list$id) } else { fid_search <- as.integer(names(lnodes_list)) fid <- self$fct_id_from_lvl_values(value = value, fid_search = fid_search) return(self$lvl_id(value = value, role = role, fid = fid)) } } else { - private$validate_id(fid , 1) - lnodes <- lnodes_list[[as.character(fid)]] + private$validate_id(fid, 1) + lnodes <- lnodes_list[[fid]] if(!is_null(value)) { - value_to_id <- set_names(lnodes$id, lnodes$value) - unname(value_to_id[as.character(value)]) + lnodes[match(value, lnodes$value), ]$id } else { lnodes$id } @@ -143,7 +142,7 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Get the level parent ids - lvl_id_parent = function(id = NULL, class = NULL) { + lvl_id_parent = function(id = NULL, role = NULL) { private$node_id_parent_child(id = id, role = role, node = "level", return = "parent") }, @@ -163,7 +162,7 @@ Provenance <- R6::R6Class("Provenance", #' @param fid_search A vector of fids to search from. fct_id_from_lvl_id = function(id = NULL, fid_search = NULL) { lnodes_list <- self$lvl_nodes - if(!is_null(fid_search)) lnodes_list <- lnodes_list[as.character(fid_search)] + if(!is_null(fid_search)) lnodes_list <- lnodes_list[fid_search] for(fname in names(lnodes_list)) { if(all(id %in% lnodes_list[[fname]]$id)) return(as.integer(fname)) } @@ -171,7 +170,7 @@ Provenance <- R6::R6Class("Provenance", fct_id_from_lvl_values = function(value = NULL, fid_search = NULL) { lnodes_list <- self$lvl_nodes - if(!is_null(fid_search)) lnodes_list <- lnodes_list[as.character(fid_search)] + if(!is_null(fid_search)) lnodes_list <- lnodes_list[fid_search] for(fname in names(lnodes_list)) { if(all(value %in% lnodes_list[[fname]]$value)) return(as.integer(fname)) } @@ -179,20 +178,19 @@ Provenance <- R6::R6Class("Provenance", lvl_id_from_fct_id = function(fid = NULL) { lnodes_list <- self$lvl_nodes - lnodes_list[[as.character(fid)]]$id + lnodes_list[[fid]]$id }, #' @description - #' Get the factor names based on id or class + #' Get the factor names based on id or role fct_names = function(id = NULL, role = NULL) { fnodes <- self$fct_nodes if(!is_null(role)) { private$validate_role(role) fnodes <- fnodes[fnodes$role == role, ] } - id_to_name <- set_names(fnodes$name, fnodes$id) - ids <- id %||% fnodes$id - unname(id_to_name[as.character(ids)]) + id <- id %||% fnodes$id + fnodes[match(id, fnodes$id), ]$name }, unit_names = function(id = NULL) { @@ -208,16 +206,16 @@ Provenance <- R6::R6Class("Provenance", }, #' @description - #' Get the level values based on id or class + #' Get the level values based on id or role #' cannot have just role only defined. #' id must be from the same fid lvl_values = function(id = NULL, role = NULL, fid = NULL) { lnodes_list <- self$lvl_nodes if(!is_null(fid)) { private$validate_id(fid, 1, role = role) - lnodes <- lnodes_list[[as.character(fid)]] + lnodes <- lnodes_list[[fid]] id <- id %||% lnodes$id - return(lnodes[lnodes$id %in% id, "value"]) + return(lnodes[match(id, lnodes$id), ]$value) } if(!is_null(id)) { fid <- self$fct_id_from_lvl_id(id = id) @@ -241,7 +239,7 @@ Provenance <- R6::R6Class("Provenance", if(is_null(fid)) abort("The rcrd id must be supplied.") private$validate_id(fid, 1, role = "edbl_rcrd") uid_fct <- self$fct_id_child(id = fid, role = "edbl_unit") - lnodes <- lnodes_list[[as.character(uid_fct)]] + lnodes <- lnodes_list[[uid_fct]] id <- uid %||% lnodes$id return(lnodes[["attr"]][lnodes$id %in% id, self$fct_names(id = fid)]) }, @@ -249,21 +247,57 @@ Provenance <- R6::R6Class("Provenance", #' @description - #' Get the class of the vertex given the factor id + #' Get the role of the vertex given the factor id fct_role = function(id = NULL) { fnodes <- self$fct_nodes - id_to_role <- pull(nodes, class, id) - ids_fct <- id %||% nodes$id - unname(id_to_class_fct[as.character(ids_fct)]) + id <- id %||% fnodes$id + fnodes[match(id, fnodes$id), ]$role }, #' @description #' Get the levels for each factor - fct_levels = function(id = NULL, name = NULL) { + fct_levels = function(id = NULL, name = NULL, return = c("id", "value")) { + return <- match.arg(return) qid <- id %||% self$fct_id(name = name) lnodes <- self$lvl_nodes - out <- lapply(lnodes[as.character(qid)], function(x) x$value) - names(out) <- self$fct_names(id = qid) + switch(return, + id = lapply(lnodes[qid], function(x) x$id), + value = { + out <- lapply(lnodes[qid], function(x) x$value) + names(out) <- self$fct_names(id = qid) + out + }) + }, + + fct_levels_id_to_edbl_fct = function(fct_levels, role) { + ret <- lapply(names(fct_levels), function(fid) { + lvls <- fct_levels[[fid]] + fid <- as.numeric(fid) + fname <- self$fct_names(id = fid) + lvls_value <- self$lvl_values(id = lvls, fid = fid) + new_edibble_fct(labels = lvls_value, + name = fname, + class = role) + }) + names(ret) <- self$fct_names(id = as.numeric(names(fct_levels))) + ret + }, + + fct_levels_id_to_value = function(fct_levels) { + out <- lapply(names(fct_levels), function(fid) { + lvls <- fct_levels[[fid]] + self$lvl_values(id = lvls, fid = fid) + }) + names(out) <- self$fct_names(id = as.numeric(names(fct_levels))) + out + }, + + fct_levels_value_to_id = function(fct_levels) { + out <- lapply(names(fct_levels), function(fname) { + lvls <- fct_levels[[fname]] + self$lvl_id(value = lvls, fid = self$fct_id(name = fname)) + }) + names(out) <- self$fct_id(name = names(fct_levels)) out }, @@ -304,7 +338,7 @@ Provenance <- R6::R6Class("Provenance", abort_missing(vars = id[!vexist]) } else if(is_null(name) & is_null(id) & !is_null(role)) { - exist <- any(class %in% fnodes$class) + exist <- any(role %in% fnodes$role) abort_missing(msg = sprintf("There are no factors with role%s", .combine_words(paste0("`", role, "`")))) @@ -315,7 +349,7 @@ Provenance <- R6::R6Class("Provenance", abort_missing(vars = id[!vexist]) } else if(!is_null(name) & is_null(id) & !is_null(role)) { - srole <- fnodes[match(name, fnodes$name), "class"] + srole <- fnodes[match(name, fnodes$name), "role"] vexist <- srole == role exist <- all(vexist) abort_missing(vars = name[!vexist]) @@ -377,14 +411,14 @@ Provenance <- R6::R6Class("Provenance", lnodes <- self$lvl_nodes id <- private$lvl_new_id(n = length(value)) data <- tibble::tibble(id = id, value = value, attrs = attrs) - if(is.null(lnodes[[as.character(fid)]])) { + if(is.null(lnodes[[fid]])) { if(!is_null(attrs)) { - lnodes[[as.character(fid)]] <- new_lnode(id, value, attrs) + lnodes[[fid]] <- new_lnode(id, value, attrs) } else { - lnodes[[as.character(fid)]] <- new_lnode(id, value) + lnodes[[fid]] <- new_lnode(id, value) } } else { - lnodes[[as.character(fid)]] <- rbind_(lnodes[[as.character(fid)]], data) + lnodes[[fid]] <- rbind_(lnodes[[fid]], data) } self$lvl_nodes <- lnodes }, @@ -407,6 +441,116 @@ Provenance <- R6::R6Class("Provenance", attrs = attrs)) }, + serve_units = function(id = NULL, return = c("id", "value")) { + return <- match.arg(return) + id <- id %||% self$fct_id(role = "edbl_unit") + if(length(id) == 0) abort("There needs to be at least one unit supplied.") + id_ancestors <- self$fct_id_ancestor(id = id, role = "edbl_unit") + sub_graph <- self$graph_subset(id = id_ancestors, include = "self") + top_graph <- private$graph_reverse_topological_order(sub_graph) + sub_fnodes <- top_graph$factors$nodes + sub_fedges <- top_graph$factors$edges + sub_lnodes <- top_graph$levels$nodes + sub_ledges <- top_graph$levels$edges + + out <- list() + for(irow in seq(nrow(sub_fnodes))) { + # check if children. + iunit <- sub_fnodes$id[irow] + if(sub_fnodes$child[irow] == 0) { + # if no children, just render it + out[[as.character(iunit)]] <- self$lvl_id(fid = iunit) + } else { + children_id <- sub_fedges$to[sub_fedges$from == iunit] + # all children id should have levels in the `out` + # any children should be the same -- take the first one + cid <- out[[as.character(children_id[1])]] + pid <- sub_lnodes[[iunit]]$id + cid_to_pid <- map_int(cid, function(id) sub_ledges$from[sub_ledges$to == id & sub_ledges$from %in% pid]) + out[[as.character(iunit)]] <- cid_to_pid + } + } + private$table$units <- out + switch(return, + id = out, + value = self$fct_levels_id_to_edbl_fct(out, role = "edbl_unit")) + }, + + serve_trts = function(id = NULL, return = c("id", "value")) { + + return <- match.arg(return) + lnodes <- self$lvl_nodes + ledges <- self$lvl_edges + + serve_trt = function(fid) { + # linked unit - + # each treatment factor should only be applied to a single unit factor + uid <- self$fct_id_child(id = fid, role = "edbl_unit") + vctrs::vec_assert(uid, integer(), size = 1) + if(!uid %in% as.integer(names(private$table$units))) self$serve_units(id = uid) + tids <- self$lvl_id(fid = fid, role = "edbl_trt") + uids <- private$table$units[[as.character(uid)]] + ledges <- ledges[ledges$to %in% uids & ledges$from %in% tids, ] + ledges[match(uids, ledges$to), ]$from + } + id <- id %||% self$trt_ids + out <- lapply(id, serve_trt) + names(out) <- as.character(id) + private$table$trts <- out + switch(return, + id = out, + value = self$fct_levels_id_to_edbl_fct(out, role = "edbl_trt")) + }, + + + serve_rcrds = function(id = NULL, return = c("id", "value")) { + id <- id %||% self$rcrd_ids + out <- lapply(id, function(rid) { + uid <- self$fct_id_child(id = rid, role = "edbl_unit") + # should be only a single unit factor + vctrs::vec_assert(uid, integer(), size = 1) + if(!uid %in% as.integer(names(private$table$units))) self$serve_units(id = uid) + uid + }) + names(out) <- as.character(id) + switch(return, + id = out, + value = { + N <- max(lengths(private$table$units)) + lvs <- lapply(id, function(rid) { + uid <- out[[as.character(rid)]] + uids <- private$table$units[[as.character(uid)]] + new_edibble_rcrd(rep(NA_real_, N), uids) + }) + names(lvs) <- self$fct_names(id = id) + lvs + }) + }, + + #' @param include "self" for only input id, "child" for child also, + #' "parent" for parent also, + #' nodes immediately related, and "ancestors" for all ancestors + #' @return subsetted graph + graph_subset = function(id = NULL, include = c("self", "child", "parent", "ancestors")) { + include <- match.arg(include) + idx <- switch(include, + "self" = id, + "child" = c(id, self$fct_id_child(id = id)), + "parent" = c(id, self$fct_id_parent(id = id)), + "ancestors" = unique(c(id, self$fct_id_ancestor(id = id)))) + fnodes <- self$fct_nodes + fedges <- self$fct_edges + lnodes <- self$lvl_nodes + ledges <- self$lvl_edges + # subset + fnodes <- fnodes[fnodes$id %in% idx, ] + fedges <- fedges[fedges$from %in% idx & fedges$to %in% idx, ] + lnodes <- lnodes[fnodes$id] + ledges <- ledges[ledges$from %in% lnodes$id & ledges$to %in% lnodes$id, ] + + new_edibble_graph(fnodes, lnodes, fedges, ledges) + }, + save_seed = function(seed) { private$record_track_internal() if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) @@ -420,10 +564,18 @@ Provenance <- R6::R6Class("Provenance", private$seed <- RNGstate }, + get_title = function() { + private$title + }, + get_trail = function() { private$trail[-length(private$trail)] }, + get_graph = function() { + private$graph + }, + get_seed = function() { private$seed }, @@ -458,30 +610,30 @@ Provenance <- R6::R6Class("Provenance", #' @field fct_nodes #' Get the factor nodes fct_nodes = function(data) { - if(missing(data)) return(self$graph$factors$nodes) - else self$graph$factors$nodes <- data + if(missing(data)) return(private$graph$factors$nodes) + else private$graph$factors$nodes <- data }, #' @field lvl_nodes #' Get the level nodes lvl_nodes = function(data) { if(missing(data)) { - nodes <- self$graph$levels$nodes + nodes <- private$graph$levels$nodes return(nodes) } - else self$graph$levels$nodes <- data + else private$graph$levels$nodes <- data }, #' @field fct_edges #' Get the factor edges fct_edges = function(data) { if(missing(data)) { - edges <- self$graph$factors$edges + edges <- private$graph$factors$edges edges$var_from <- self$fct_names(id = edges$from) edges$var_to <- self$fct_names(id = edges$to) return(edges) } else { - self$graph$factors$edges <- data + private$graph$factors$edges <- data } }, @@ -489,12 +641,10 @@ Provenance <- R6::R6Class("Provenance", #' Get the level edges lvl_edges = function(data) { if(missing(data)) { - edges <- self$graph$levels$edges - edges$lvl_from <- self$lvl_names(id = edges$from) - edges$lvl_to <- self$lvl_names(id = edges$to) + edges <- private$graph$levels$edges return(edges) } else { - self$graph$levels$edges <- data + private$graph$levels$edges <- data } }, @@ -512,7 +662,7 @@ Provenance <- R6::R6Class("Provenance", #' Get the number of nodes in level graph lvl_n = function(value) { if (missing(value)) { - sum(lengths(self$lvl_nodes_list)) + sum(lengths(self$lvl_nodes)) } else { stop("Can't set `$lvl_n`.") } @@ -547,7 +697,7 @@ Provenance <- R6::R6Class("Provenance", if(nvar==0) return(FALSE) if(nvar==1) return(TRUE) ledges <- self$lvl_edges - all(self$lvl_id %in% c(ledges$to, ledges$from)) + all(self$lvl_id() %in% c(ledges$to, ledges$from)) } ), private = list( @@ -564,6 +714,8 @@ Provenance <- R6::R6Class("Provenance", anatomy = NULL, recipe = NULL, graph = NULL, + # table should only contain the id of levels and factors + table = list(units = NULL, trts = NULL, rcrds = NULL), validate_id = function(id, n = NULL, role = NULL) { id <- vctrs::vec_cast(id, integer()) @@ -584,11 +736,11 @@ Provenance <- R6::R6Class("Provenance", }, node_id_parent_child = function(id = NULL, role = NULL, node = c("factor", "level"), return = c("child", "parent")) { - type <- match.arg(type) + return <- match.arg(return) node <- match.arg(node) if(node == "factor") { edges <- self$fct_edges - edges <- edges[!edges$type %in% c("depends", "cross"), ] + #edges <- edges[!edges$type %in% c("depends", "cross"), ] } else if(node == "level") { edges <- self$lvl_edges } @@ -626,16 +778,30 @@ Provenance <- R6::R6Class("Provenance", #' @field fct_new_id #' Get a new factor id. fct_new_id = function(n = 1) { - ids <- seq(private$fct_last_id + 1, private$fct_last_id + n) - private$fct_last_id <- private$fct_last_id + n + ids <- seq(private$fct_id_last + 1, private$fct_id_last + n) + private$fct_id_last <- private$fct_id_last + n ids }, #' @field lvl_new_id #' Get a new level id. lvl_new_id = function(n = 1) { - ids <- seq(private$lvl_last_id + 1, private$lvl_last_id + n) - private$lvl_last_id <- private$lvl_last_id + n + ids <- seq(private$lvl_id_last + 1, private$lvl_id_last + n) + private$lvl_id_last <- private$lvl_id_last + n ids - } + }, + + #' Given a particular DAG, return a topological order + #' Remember that there could be more than one order. + graph_reverse_topological_order = function(graph) { + fnodes <- graph$factors$nodes + lnodes <- graph$levels$nodes + fedges <- graph$factors$edges + ledges <- graph$levels$edges + fnodes$parent <- map_int(fnodes$id, function(id) sum(fedges$to %in% id)) + fnodes$child <- map_int(fnodes$id, function(id) sum(fedges$from %in% id)) + fnodes$nlevels <- map_int(fnodes$id, function(id) nrow(lnodes[[id]])) + fnodes <- fnodes[order(fnodes$child, -fnodes$nlevels), ] + new_edibble_graph(fnodes = fnodes, lnodes = lnodes, fedges = fedges, ledges = ledges) + } )) diff --git a/R/rcrds.R b/R/rcrds.R index 347160a5..9598ad6c 100644 --- a/R/rcrds.R +++ b/R/rcrds.R @@ -24,7 +24,7 @@ set_rcrds <- function(.edibble, ..., not_edibble(.edibble) if(.record) record_step() - prep <- cook_design(.edibble) + prov <- activate_provenance(.edibble) .name_repair <- match.arg(.name_repair) units <- map(enexprs(...), function(x) { @@ -34,22 +34,22 @@ set_rcrds <- function(.edibble, ..., }) rcrds <- names(units) - prep$fct_exists(name = unlist(units), class = "edbl_unit") + prov$fct_exists(name = unlist(units), class = "edbl_unit") for(i in seq_along(units)) { - rid <- prep$fct_last_id + 1L - uid <- prep$fct_id(units[[i]]) + rid <- prov$fct_last_id + 1L + uid <- prov$fct_id(units[[i]]) attrs <- attributes(units[[i]]) fattrs <- do.call(data.frame, c(attrs[setdiff(names(attrs), c("names", "class"))], list(stringsAsFactors = FALSE, id = rid, name = rcrds[i], class = "edbl_rcrd"))) - prep$append_fct_nodes(fattrs) - prep$append_fct_edges(data.frame(from = uid, to = rid)) + prov$append_fct_nodes(fattrs) + prov$append_fct_edges(data.frame(from = uid, to = rid)) } - if(is_edibble_table(.edibble)) return(serve_table(prep$design)) - prep$design + if(is_edibble_table(.edibble)) return(serve_table(prov$design)) + prov$design } #' @rdname set_rcrds @@ -85,15 +85,15 @@ expect_rcrds <- function(.edibble, ...) { record_step() dots <- enquos(...) dots_nms <- names(dots) - prep <- cook_design(.edibble) + prov <- activate_provenance(.edibble) rules_named <- map(dots[dots_nms!=""], eval_tidy) rules_unnamed <- map(dots[dots_nms==""], validate_rcrd, - rnames = prep$rcrd_names) + rnames = prov$rcrd_names) rules_unnamed <- stats::setNames(rules_unnamed, map_chr(rules_unnamed, function(x) x$rcrd)) - prep$design$validation <- simplify_validation(c(rules_named, rules_unnamed)) - if(is_edibble_table(.edibble)) return(serve_table(prep$design)) - prep$design + prov$design$validation <- simplify_validation(c(rules_named, rules_unnamed)) + if(is_edibble_table(.edibble)) return(serve_table(prov$design)) + prov$design } simplify_validation <- function(x) { @@ -197,8 +197,8 @@ validate_rcrd <- function(x, rnames = NULL) { } -has_record <- function(prep) { - "edbl_rcrd" %in% prep$design$graph$nodes$class +has_record <- function(prov) { + "edbl_rcrd" %in% prov$design$graph$nodes$class } @@ -294,9 +294,9 @@ fill_symbol <- function() "o" dup_symbol <- function() "x" -new_edibble_rcrd <- function(x, unit_name = NULL, unit_values = NULL, class = NULL, ...) { +new_edibble_rcrd <- function(x, unit_values = NULL, class = NULL, ...) { res <- new_vctr(x, class = c("edbl_rcrd", "edbl_fct"), - unit = unit_name %||% attr(x, "unit_name"), + #unit = unit_name %||% attr(x, "unit_name"), unit_values = unit_values %||% attr(x, "unit_values"), ...) class(res) <- c(class, class(res)) diff --git a/R/serve.R b/R/serve.R index 249250eb..66f5c72b 100644 --- a/R/serve.R +++ b/R/serve.R @@ -20,165 +20,60 @@ #' serve_table() #' @export serve_table <- function(.edibble, use_labels = FALSE, ..., .record = TRUE) { - prep <- cook_design(.edibble) - if(.record) prep$record_step() + prov <- activate_provenance(.edibble) + if(.record) prov$record_step() - if(!prep$is_connected) { - lout <- serve_vars_not_reconciled(prep) + if(!prov$is_connected) { + lout <- serve_vars_not_reconciled(prov) } else { - #browser() - classes <- prep$fct_class() + roles <- prov$fct_role() lunit <- ltrt <- lrcrd <- list() - if("edbl_unit" %in% classes) lunit <- serve_units(prep) - if("edbl_trt" %in% classes) ltrt <- serve_trts(prep, lunit) + if("edbl_unit" %in% roles) { + lunit <- prov$serve_units(return = "value") + } else { + abort("At least one `unit` factor needs to be set.") + } + if("edbl_trt" %in% roles) ltrt <- prov$serve_trts(return = "value") if(length(lunit) | length(ltrt)) { - if("edbl_rcrd" %in% classes) lrcrd <- serve_rcrds(prep, lunit) + if("edbl_rcrd" %in% roles) lrcrd <- prov$serve_rcrds() lout <- c(lunit, ltrt, lrcrd) } else { - lout <- serve_vars_not_reconciled(prep) + lout <- serve_vars_not_reconciled(prov) } } - namesv <- prep$fct_names() + namesv <- prov$fct_names() if(use_labels) { - translate <- stats::setNames(prep$lvl_nodes$label, prep$lvl_nodes$name) - # FIXME: it lsoes the classes when this is done + translate <- stats::setNames(prov$lvl_nodes$label, prov$lvl_nodes$name) + # FIXME: it loses the classes when this is done lout <- lapply(lout, function(.x) translate[.x]) } new_edibble(lout[namesv], design = .edibble) } -serve_trts <- function(prep, lunits) { - tids <- prep$trt_ids() - vnames <- prep$fct_names(id = tids) - lvs <- lapply(tids, function(i) { - serve_trt(prep, i, lunits) - }) - names(lvs) <- vnames - lvs -} -rcrd_to_unit_dict <- function(prep, rids) { - fedges <- prep$fct_edges - tdf <- fedges[fedges$to %in% rids, ] - set_names(prep$fct_names(tdf$from), - prep$fct_names(tdf$to)) -} -serve_rcrds <- function(prep, lunits) { - rids <- prep$rcrd_ids - rcrd2unit <- rcrd_to_unit_dict(prep, rids) - rnames <- prep$rcrd_names - N <- max(lengths(lunits)) - lvs <- lapply(rnames, function(avar) { - unit <- rcrd2unit[avar] - unit_values <- lunits[[unit]] - new_edibble_rcrd(rep(NA_real_, N), unit, unit_values) - }) - names(lvs) <- rnames - lvs -} + # Returns list of edibble variables -serve_vars_not_reconciled <- function(prep) { - namesv <- prep$fct_names() +serve_vars_not_reconciled <- function(prov) { + namesv <- prov$fct_names() res <- lapply(namesv, function(avar) { - new_edibble_fct(levels = prep$fct_levels(name = avar)[[avar]], + new_edibble_fct(levels = prov$lvl_values(fid = prov$fct_id(name = avar)), name = avar, - class = prep$fct_class(id = prep$fct_id_by_name(avar))) + class = prov$fct_role(id = prov$fct_id(name = avar))) }) names(res) <- namesv res } -# Return edibble unit -serve_unit_with_child <- function(parent_levels, parent_vname, parent_class, - child_labels, child_vname, prep) { - pids <- prep$lvl_id_by_value(parent_levels, prep$fct_id_by_name(parent_vname)) - cids <- prep$lvl_id_by_value(unique(child_labels), prep$fct_id_by_name(child_vname)) - ledges <- prep$lvl_edges - ledges <- ledges[ledges$to %in% cids & ledges$from %in% pids, ] - dict <- set_names(prep$lvl_names(ledges$from), prep$lvl_names(ledges$to)) - new_edibble_fct(levels = parent_levels, - labels = unname(dict[child_labels]), - name = parent_vname, - class = parent_class) - -} - -serve_unit_with_no_child <- function(vlevs, vname, classv) { - new_edibble_fct(levels = vlevs, - labels = vlevs, - name = vname, - class = classv) -} -serve_units <- function(prep) { - uid <- prep$unit_ids - lid <- prep$fct_leaves - if(length(lid) != 1) { - return(list()) - } - wid <- uid - vlev <- prep$fct_levels() - res <- list() - while(!is_empty(lid)) { - lvs <- lapply(lid, function(i) { - vname <- prep$fct_names(id = i) - classv <- prep$fct_class(id = i) - vlevs <- vlev[[vname]] - cid <- intersect(prep$fct_child(id = i), uid) - if(!is_empty(cid)) { - # currently uses the first child only - cname <- prep$fct_names(id = cid) - serve_unit_with_child(vlevs, vname, classv, - as.character(res[[cname[1]]]), cname[1], prep) - } else { - serve_unit_with_no_child(vlevs, vname, classv) - } - }) - names(lvs) <- prep$fct_names(id = lid) - res <- c(res, lvs) - wid <- setdiff(wid, lid) - wprep <- select_units(prep, prep$fct_names(id = wid)) - lid <- wprep$fct_leaves - } - res -} -serve_trts <- function(prep, lunits) { - tids <- prep$trt_ids - tnames <- prep$trt_names - lvs <- lapply(tids, function(i) { - serve_trt(prep, i, lunits) - }) - names(lvs) <- tnames - lvs -} -serve_trt <- function(prep, tid, lunits) { - lnodes <- prep$lvl_nodes - ledges <- prep$lvl_edges - tdf <- lnodes[[as.character(tid)]] - ltids <- tdf$id - luids <- prep$lvl_child(id = ltids) - ledges <- ledges[ledges$to %in% luids & ledges$from %in% ltids,] - aunit <- prep$fct_names(id = prep$fct_child(id = tid)) - if(!is_empty(aunit)) { - dict <- set_names(prep$lvl_names(ledges$from), prep$lvl_names(ledges$to)) - labels <- unname(dict[lunits[[aunit]]]) - } else { - labels <- tdf$label - } - new_edibble_fct(levels = tdf$label, - labels = labels, - name = prep$fct_names(id = tid), - class = prep$fct_class(id = tid)) -} diff --git a/R/trts.R b/R/trts.R index fd5ff80f..d3f69ce8 100644 --- a/R/trts.R +++ b/R/trts.R @@ -24,7 +24,7 @@ set_trts <- function(.edibble, ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE) { - prov <- cook_design(.edibble) + prov <- activate_provenance(.edibble) if(.record) prov$record_step() set_fcts(.edibble, ..., .name_repair = .name_repair, .class = "edbl_trt") } @@ -35,48 +35,43 @@ order_trts <- function(x, ...) { UseMethod("order_trts") } -order_trts.default <- function(order, prep, constrain, ...) { +order_trts.default <- function(order, prov, constrain, ...) { abort(paste("The", order, "`order` is not implemented.")) } -order_trts.dae <- function(order, prep, constrain, trts, ...) { - dat <- assign_trts(prep$design, order = "systematic", constrain = constrain, .record = FALSE) %>% +order_trts.dae <- function(order, prov, constrain, trts, ...) { + # FIXME + dat <- assign_trts(prov$design, order = "systematic", constrain = constrain, .record = FALSE) %>% serve_table(use_labels = TRUE) %>% lapply(as.factor) %>% as.data.frame() - out <- dae::designRandomize(allocated = dat[prep$trt_names], - recipient = dat[prep$unit_names], + out <- dae::designRandomize(allocated = dat[prov$trt_names], + recipient = dat[prov$unit_names], nested.recipients = constrain) - trtsv <- stats::setNames(1:nrow(trts), do.call(paste0, trts[prep$trt_names])) - otrtsv <- do.call(paste0, dat[prep$trt_names]) + trtsv <- stats::setNames(1:nrow(trts), do.call(paste0, trts[prov$trt_names])) + otrtsv <- do.call(paste0, dat[prov$trt_names]) unname(trtsv[otrtsv]) } -permute_parent_more_than_one <- function(prep, vids, udf, ntrts) { - gparents <- prep$fct_names(vids) - vlevs <- prep$fct_levels() - - lvls <- lengths(vlevs[gparents]) +permute_parent_more_than_one <- function(prov, vids, udf, ntrts) { + vlevs <- prov$fct_levels(return = "id") + lvls <- lengths(vlevs[as.character(vids)]) oa <- latin_array(dim = lvls, ntrts) - - index <- lapply(gparents, function(gparent) match(udf[[gparent]], vlevs[[gparent]])) + index <- lapply(vids, function(id) match(udf[[as.character(id)]], vlevs[[as.character(id)]])) out <- vector("integer", length = nrow(udf)) for(i in seq(nrow(udf))) { out[i] <- do.call("[", c(list(oa), lapply(index, function(x) x[i]))) } - out - } -permute_parent_one_alg <- function(prep, vid, udf, ntrts) { - gparent <- prep$fct_names(vid) +permute_parent_one_alg <- function(prov, vid, udf, ntrts) { udf$.id <- 1:nrow(udf) - udf <- udf[order(udf[[gparent]]),] - blocksizes <- table(udf[[gparent]]) + udf <- udf[order(udf[[as.character(vid)]]),] + blocksizes <- table(udf[[as.character(vid)]]) # if(min(blocksizes) > ntrts) { # permute_parent_one(.edibble, vid, udf, ntrts) # } else { @@ -92,7 +87,7 @@ permute_parent_one_alg <- function(prep, vid, udf, ntrts) { withinData = data.frame(tindex = factor(1:ntrts)), blocksizes = blocksizes_adj) }, error = function(x) { - return(permute_parent_one(prep, vid, udf, ntrts)) + return(permute_parent_one(prov, vid, udf, ntrts)) }) }) if(is.integer(res)) return(res) @@ -103,12 +98,12 @@ permute_parent_one_alg <- function(prep, vid, udf, ntrts) { if(length(xv)==1) xv else sample(xv) }))) udf$.res <- out - udf[order(udf$.id), ".res"] + udf[order(udf$.id), ".res", drop = TRUE] } -permute_parent_one <- function(prep, vid, udf, ntrts) { - gparent <- prep$fct_names(vid) +permute_parent_one <- function(prov, vid, udf, ntrts) { + gparent <- prov$fct_names(vid) blocksizes <- as.data.frame(table(table(udf[[gparent]]))) blocksizes$size <- as.numeric(as.character(blocksizes$Var1)) for(isize in seq(nrow(blocksizes))) { diff --git a/R/units.R b/R/units.R index e0bdfae2..67e80274 100644 --- a/R/units.R +++ b/R/units.R @@ -62,37 +62,11 @@ set_units <- function(.edibble, ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE) { - prov <- cook_design(.edibble) + prov <- activate_provenance(.edibble) if(.record) prov$record_step() set_fcts(.edibble, ..., .name_repair = .name_repair, .class = "edbl_unit") } -#' Select a subset of units from a cooked design -#' -#' @param prep A cooked design. -#' @param ... The units to select. -#' -#' @importFrom tidyselect eval_select -#' @return An edibble design. -#' @export -select_units <- function(prep, ...) { - vlevs <- prep$fct_levels() - loc <- eval_select(expr(tidyselect::all_of(c(...))), vlevs) - keep_units <- names(vlevs)[loc] - keep_uids <- prep$fct_id_by_name(keep_units) - keep_uids_ancestors <- prep$fct_ancestor(keep_uids, class = "edbl_unit") - sprep <- prep$clone() - fnodes <- prep$fct_nodes - fedges <- prep$fct_edges - lnodes <- prep$lvl_nodes - ledges <- prep$lvl_edges - sprep$fct_nodes <- fnodes[fnodes$id %in% keep_uids_ancestors, ] - sprep$fct_edges <- fedges[fedges$to %in% keep_uids_ancestors & fedges$from %in% keep_uids_ancestors,] - sprep$lvl_nodes <- lnodes[as.character(keep_uids_ancestors)] - keep_lids_ancestors <- sprep$lvl_id - sprep$lvl_edges <- ledges[ledges$to %in% keep_lids_ancestors & ledges$from %in% keep_lids_ancestors,] - sprep -} #' @importFrom vctrs vec_ptype_abbr #' @export diff --git a/R/utils.R b/R/utils.R index ccb11810..abbdd38e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -47,10 +47,10 @@ print.edbl_design <- function(x, decorate_levels = edibble_decorate("levels"), decorate_title = edibble_decorate("title"), title = NULL, ...) { - title <- title %||% x$provenance$name - prep <- cook_design(x) - fids <- prep$fct_nodes$id - fnames <- prep$fct_names(id = fids) + prov <- activate_provenance(x) + title <- title %||% prov$get_title() + fids <- prov$fct_nodes$id + fnames <- prov$fct_names(id = fids) if(is_empty(fids)) { data <- data.frame(var = "root", @@ -58,20 +58,20 @@ print.edbl_design <- function(x, label = as.character(decorate_title(title))) } else { - classes <- prep$fct_class() + classes <- prov$fct_role() label_names <- decorate_vars(fnames, decorate_units, decorate_trts, decorate_rcrds, classes) - var_nlevels <- lengths(prep$fct_levels()[fnames]) + var_nlevels <- lengths(prov$fct_levels(name = fnames, return = "id")) nvar <- length(fids) ll <- lapply(fids, function(id) { - class <- prep$fct_class(id = id) - children <- prep$fct_child(id = id) + class <- prov$fct_role(id = id) + children <- prov$fct_id_child(id = id) if(class!="edbl_trt" & !is_empty(children)) { - prep$fct_names(id = children) + prov$fct_names(id = children) } else { character() } @@ -272,7 +272,7 @@ as.data.frame.edbl_table <- function(x, append_recipe_code <- function(.design, new) { .design$recipe <- c(.design$recipe, new) prov <- activate_provenance(.design) - prov$record_history_external(new) + prov$record_track_external(new) .design } diff --git a/man/Provenance.Rd b/man/Provenance.Rd index 6f6355ff..502bc084 100644 --- a/man/Provenance.Rd +++ b/man/Provenance.Rd @@ -16,15 +16,21 @@ the edibble design object. \section{Public fields}{ \if{html}{\out{
}} \describe{ +\item{\code{fct_leaves}}{Get the leave factor ids.} + \item{\code{fct_new_id}}{Get a new factor id.} -\item{\code{lvl_new_id}}{Get a new level id.} +\item{\code{lvl_new_id}}{Get a new level id. +Given a particular DAG, return a topological order +Remember that there could be more than one order.} } \if{html}{\out{
}} } \section{Active bindings}{ \if{html}{\out{
}} \describe{ +\item{\code{fct_leaves}}{Get the leave factor ids.} + \item{\code{fct_nodes}}{Get the factor nodes} \item{\code{lvl_nodes}}{Get the level nodes} @@ -37,25 +43,19 @@ the edibble design object. \item{\code{lvl_n}}{Get the number of nodes in level graph} -\item{\code{fct_leaves}}{Get the leave factor ids.} - \item{\code{rcrd_ids}}{Get the ids for all edbl_rcrd factors.} \item{\code{unit_ids}}{Get the ids for all edbl_unit factors.} \item{\code{trt_ids}}{Get the ids for all edbl_trt factors.} -\item{\code{trt_names}}{Get the node labels for treatments} - -\item{\code{unit_names}}{Get the node labels for units} - -\item{\code{rcrd_names}}{Get the node labels for record} - \item{\code{is_connected}}{Check if nodes are connected.} \item{\code{fct_new_id}}{Get a new factor id.} -\item{\code{lvl_new_id}}{Get a new level id.} +\item{\code{lvl_new_id}}{Get a new level id. +Given a particular DAG, return a topological order +Remember that there could be more than one order.} } \if{html}{\out{
}} } @@ -63,41 +63,53 @@ the edibble design object. \subsection{Public methods}{ \itemize{ \item \href{#method-Provenance-new}{\code{Provenance$new()}} +\item \href{#method-Provenance-set_title}{\code{Provenance$set_title()}} \item \href{#method-Provenance-set_name}{\code{Provenance$set_name()}} \item \href{#method-Provenance-reactivate}{\code{Provenance$reactivate()}} \item \href{#method-Provenance-deactivate}{\code{Provenance$deactivate()}} -\item \href{#method-Provenance-fct_id_by_name}{\code{Provenance$fct_id_by_name()}} -\item \href{#method-Provenance-fct_id_by_class}{\code{Provenance$fct_id_by_class()}} -\item \href{#method-Provenance-lvl_id_by_value}{\code{Provenance$lvl_id_by_value()}} +\item \href{#method-Provenance-fct_id}{\code{Provenance$fct_id()}} +\item \href{#method-Provenance-fct_id_parent}{\code{Provenance$fct_id_parent()}} +\item \href{#method-Provenance-fct_id_child}{\code{Provenance$fct_id_child()}} +\item \href{#method-Provenance-fct_id_ancestor}{\code{Provenance$fct_id_ancestor()}} +\item \href{#method-Provenance-fct_id_leaves}{\code{Provenance$fct_id_leaves()}} +\item \href{#method-Provenance-lvl_id}{\code{Provenance$lvl_id()}} +\item \href{#method-Provenance-lvl_id_parent}{\code{Provenance$lvl_id_parent()}} +\item \href{#method-Provenance-lvl_id_child}{\code{Provenance$lvl_id_child()}} +\item \href{#method-Provenance-lvl_id_ancestor}{\code{Provenance$lvl_id_ancestor()}} +\item \href{#method-Provenance-fct_id_from_lvl_id}{\code{Provenance$fct_id_from_lvl_id()}} +\item \href{#method-Provenance-fct_id_from_lvl_values}{\code{Provenance$fct_id_from_lvl_values()}} +\item \href{#method-Provenance-lvl_id_from_fct_id}{\code{Provenance$lvl_id_from_fct_id()}} \item \href{#method-Provenance-fct_names}{\code{Provenance$fct_names()}} -\item \href{#method-Provenance-lvl_names}{\code{Provenance$lvl_names()}} +\item \href{#method-Provenance-unit_names}{\code{Provenance$unit_names()}} +\item \href{#method-Provenance-trt_names}{\code{Provenance$trt_names()}} +\item \href{#method-Provenance-rcrd_names}{\code{Provenance$rcrd_names()}} +\item \href{#method-Provenance-lvl_values}{\code{Provenance$lvl_values()}} +\item \href{#method-Provenance-unit_values}{\code{Provenance$unit_values()}} +\item \href{#method-Provenance-trt_values}{\code{Provenance$trt_values()}} +\item \href{#method-Provenance-rcrd_values}{\code{Provenance$rcrd_values()}} +\item \href{#method-Provenance-fct_role}{\code{Provenance$fct_role()}} +\item \href{#method-Provenance-fct_levels_id}{\code{Provenance$fct_levels_id()}} +\item \href{#method-Provenance-fct_levels_value}{\code{Provenance$fct_levels_value()}} +\item \href{#method-Provenance-fct_exists}{\code{Provenance$fct_exists()}} +\item \href{#method-Provenance-trt_exists}{\code{Provenance$trt_exists()}} +\item \href{#method-Provenance-unit_exists}{\code{Provenance$unit_exists()}} +\item \href{#method-Provenance-rcrd_exists}{\code{Provenance$rcrd_exists()}} +\item \href{#method-Provenance-lvl_exists}{\code{Provenance$lvl_exists()}} \item \href{#method-Provenance-append_fct_nodes}{\code{Provenance$append_fct_nodes()}} \item \href{#method-Provenance-append_lvl_nodes}{\code{Provenance$append_lvl_nodes()}} \item \href{#method-Provenance-append_fct_edges}{\code{Provenance$append_fct_edges()}} \item \href{#method-Provenance-append_lvl_edges}{\code{Provenance$append_lvl_edges()}} -\item \href{#method-Provenance-fct_class}{\code{Provenance$fct_class()}} -\item \href{#method-Provenance-lvl_class}{\code{Provenance$lvl_class()}} -\item \href{#method-Provenance-fct_child}{\code{Provenance$fct_child()}} -\item \href{#method-Provenance-lvl_child}{\code{Provenance$lvl_child()}} -\item \href{#method-Provenance-lvl_id_by_class}{\code{Provenance$lvl_id_by_class()}} -\item \href{#method-Provenance-fct_parent}{\code{Provenance$fct_parent()}} -\item \href{#method-Provenance-lvl_parent}{\code{Provenance$lvl_parent()}} -\item \href{#method-Provenance-fct_ancestor}{\code{Provenance$fct_ancestor()}} -\item \href{#method-Provenance-lvl_ancestor}{\code{Provenance$lvl_ancestor()}} -\item \href{#method-Provenance-fct_levels}{\code{Provenance$fct_levels()}} -\item \href{#method-Provenance-fct_exists}{\code{Provenance$fct_exists()}} -\item \href{#method-Provenance-trts_exists}{\code{Provenance$trts_exists()}} -\item \href{#method-Provenance-units_exists}{\code{Provenance$units_exists()}} -\item \href{#method-Provenance-rcrds_exists}{\code{Provenance$rcrds_exists()}} +\item \href{#method-Provenance-serve_units}{\code{Provenance$serve_units()}} +\item \href{#method-Provenance-graph_subset}{\code{Provenance$graph_subset()}} \item \href{#method-Provenance-save_seed}{\code{Provenance$save_seed()}} -\item \href{#method-Provenance-get_history}{\code{Provenance$get_history()}} +\item \href{#method-Provenance-get_title}{\code{Provenance$get_title()}} +\item \href{#method-Provenance-get_trail}{\code{Provenance$get_trail()}} +\item \href{#method-Provenance-get_graph}{\code{Provenance$get_graph()}} \item \href{#method-Provenance-get_seed}{\code{Provenance$get_seed()}} \item \href{#method-Provenance-get_session_info}{\code{Provenance$get_session_info()}} \item \href{#method-Provenance-get_edibble_version}{\code{Provenance$get_edibble_version()}} \item \href{#method-Provenance-record_step}{\code{Provenance$record_step()}} -\item \href{#method-Provenance-record_history_external}{\code{Provenance$record_history_external()}} -\item \href{#method-Provenance-record_history_internal}{\code{Provenance$record_history_internal()}} -\item \href{#method-Provenance-add_history_internal}{\code{Provenance$add_history_internal()}} +\item \href{#method-Provenance-record_track_external}{\code{Provenance$record_track_external()}} \item \href{#method-Provenance-clone}{\code{Provenance$clone()}} } } @@ -116,6 +128,15 @@ the edibble design object. } \if{html}{\out{}} } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-set_title}{}}} +\subsection{Method \code{set_title()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$set_title(title)}\if{html}{\out{
}} +} + } \if{html}{\out{
}} \if{html}{\out{}} @@ -152,57 +173,71 @@ the edibble design object. } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_id_by_name}{}}} -\subsection{Method \code{fct_id_by_name()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id}{}}} +\subsection{Method \code{fct_id()}}{ Get the id based on either the name of the factor node. If none supplied then it will give all. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_id_by_name(name = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_id(name = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{name}}{The name of the vertex.} + +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_id_by_class}{}}} -\subsection{Method \code{fct_id_by_class()}}{ -Get all ids associated with a class. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_parent}{}}} +\subsection{Method \code{fct_id_parent()}}{ +Get the factor parent ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_id_by_class(class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_id_parent(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{class}}{The class for the vertex/node.} +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_by_value}{}}} -\subsection{Method \code{lvl_id_by_value()}}{ -Get the id based on name of level node. +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_child}{}}} +\subsection{Method \code{fct_id_child()}}{ +Get the factor child ids. If \code{role} is +supplied then the child has to fit \code{role} \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_id_by_value(value = NULL, fid)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_id_child(id = NULL, role = NULL)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{role}}{The role for the vertex/node.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_names}{}}} -\subsection{Method \code{fct_names()}}{ -Get the factor names based on id or class +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_ancestor}{}}} +\subsection{Method \code{fct_id_ancestor()}}{ +Get the factor ancestor ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_names(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_id_ancestor(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -210,194 +245,214 @@ Get the factor names based on id or class \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_names}{}}} -\subsection{Method \code{lvl_names()}}{ -Get the level names based on id or class +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_leaves}{}}} +\subsection{Method \code{fct_id_leaves()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_names(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_id_leaves(role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-append_fct_nodes}{}}} -\subsection{Method \code{append_fct_nodes()}}{ -Given node data, append the factor nodes +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_id}{}}} +\subsection{Method \code{lvl_id()}}{ +Get the id based on name of level node. +Assumes that level ids obtained are all from the same fid \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$append_fct_nodes(data)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$lvl_id(value = NULL, role = NULL, fid = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{data}}{The nodes data} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-append_lvl_nodes}{}}} -\subsection{Method \code{append_lvl_nodes()}}{ -Given node data, append the level nodes +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_parent}{}}} +\subsection{Method \code{lvl_id_parent()}}{ +Get the level parent ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$append_lvl_nodes(data, fid = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$lvl_id_parent(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{data}}{The nodes data} +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-append_fct_edges}{}}} -\subsection{Method \code{append_fct_edges()}}{ -Given edge data, append the factor edges +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_child}{}}} +\subsection{Method \code{lvl_id_child()}}{ +Get the level child ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$append_fct_edges(data)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$lvl_id_child(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{data}}{The nodes data} +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-append_lvl_edges}{}}} -\subsection{Method \code{append_lvl_edges()}}{ -Given edge data, append the level edges +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_ancestor}{}}} +\subsection{Method \code{lvl_id_ancestor()}}{ +Get the level ancestor ids \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$append_lvl_edges(data)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$lvl_id_ancestor(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{data}}{The nodes data} +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_class}{}}} -\subsection{Method \code{fct_class()}}{ -Get the class of the vertex given the factor id +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_from_lvl_id}{}}} +\subsection{Method \code{fct_id_from_lvl_id()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_class(id = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_id_from_lvl_id(id = NULL, fid_search = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} + +\item{\code{fid_search}}{A vector of fids to search from.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_class}{}}} -\subsection{Method \code{lvl_class()}}{ -Get the class of the vertex given the level id +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_id_from_lvl_values}{}}} +\subsection{Method \code{fct_id_from_lvl_values()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_class(id = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_id_from_lvl_values(value = NULL, fid_search = NULL)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_from_fct_id}{}}} +\subsection{Method \code{lvl_id_from_fct_id()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_id_from_fct_id(fid = NULL)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_names}{}}} +\subsection{Method \code{fct_names()}}{ +Get the factor names based on id or role +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_names(id = NULL, role = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} + +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_child}{}}} -\subsection{Method \code{fct_child()}}{ -Get the factor child ids. If \code{class} is -supplied then the child has to fit \code{class} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-unit_names}{}}} +\subsection{Method \code{unit_names()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_child(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$unit_names(id = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} - -\item{\code{class}}{The class for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_child}{}}} -\subsection{Method \code{lvl_child()}}{ -Get the level child ids +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-trt_names}{}}} +\subsection{Method \code{trt_names()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_child(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$trt_names(id = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} - -\item{\code{class}}{The class for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_id_by_class}{}}} -\subsection{Method \code{lvl_id_by_class()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-rcrd_names}{}}} +\subsection{Method \code{rcrd_names()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_id_by_class(class)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$rcrd_names(id = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{class}}{The class for the vertex/node.} +\item{\code{id}}{The id of the corresponding node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_parent}{}}} -\subsection{Method \code{fct_parent()}}{ -Get the factor parent ids +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_values}{}}} +\subsection{Method \code{lvl_values()}}{ +Get the level values based on id or role +cannot have just role only defined. +id must be from the same fid \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_parent(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$lvl_values(id = NULL, role = NULL, fid = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -405,75 +460,101 @@ Get the factor parent ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{role}}{The role for the vertex/node.} } \if{html}{\out{}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_parent}{}}} -\subsection{Method \code{lvl_parent()}}{ -Get the level parent ids +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-unit_values}{}}} +\subsection{Method \code{unit_values()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_parent(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$unit_values(id = NULL, fid = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} - -\item{\code{class}}{The class for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_ancestor}{}}} -\subsection{Method \code{fct_ancestor()}}{ -Get the factor ancestor ids +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-trt_values}{}}} +\subsection{Method \code{trt_values()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_ancestor(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$trt_values(id = NULL, fid = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-rcrd_values}{}}} +\subsection{Method \code{rcrd_values()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$rcrd_values(uid = NULL, fid = NULL)}\if{html}{\out{
}} +} -\item{\code{class}}{The class for the vertex/node.} +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{uid}}{The unit level id} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_ancestor}{}}} -\subsection{Method \code{lvl_ancestor()}}{ -Get the level ancestor ids +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_role}{}}} +\subsection{Method \code{fct_role()}}{ +Get the role of the vertex given the factor id \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_ancestor(id = NULL, class = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_role(id = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} - -\item{\code{class}}{The class for the vertex/node.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_levels}{}}} -\subsection{Method \code{fct_levels()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_levels_id}{}}} +\subsection{Method \code{fct_levels_id()}}{ Get the levels for each factor \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_levels(id = NULL, name = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_levels_id(id = NULL, name = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{name}}{The name of the vertex.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_levels_value}{}}} +\subsection{Method \code{fct_levels_value()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_levels_value(id = NULL, name = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -490,21 +571,21 @@ Get the levels for each factor \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-fct_exists}{}}} \subsection{Method \code{fct_exists()}}{ -One of \code{name}, \code{id} or \code{class} is defined to check if it exists. -If more than one of the arguments \code{name}, \code{id} and \code{class} are supplied, then +One of \code{name}, \code{id} or \code{role} is defined to check if it exists. +If more than one of the arguments \code{name}, \code{id} and \code{role} are supplied, then the intersection of it will be checked. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_exists(name = NULL, id = NULL, class = NULL, abort = TRUE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_exists(id = NULL, name = NULL, role = NULL, abort = TRUE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{name}}{The name of the vertex.} - \item{\code{id}}{The id of the corresponding node.} -\item{\code{class}}{The class for the vertex/node.} +\item{\code{name}}{The name of the vertex.} + +\item{\code{role}}{The role for the vertex/node.} \item{\code{abort}}{A logical value to indicate whether to abort if it doesn't exist.} } @@ -512,57 +593,180 @@ the intersection of it will be checked. } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-trts_exists}{}}} -\subsection{Method \code{trts_exists()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-trt_exists}{}}} +\subsection{Method \code{trt_exists()}}{ Check if treatment exists. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$trts_exists(abort = TRUE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$trt_exists(id = NULL, name = NULL, abort = TRUE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{name}}{The name of the vertex.} + \item{\code{abort}}{Whether to abort.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-units_exists}{}}} -\subsection{Method \code{units_exists()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-unit_exists}{}}} +\subsection{Method \code{unit_exists()}}{ Check if unit exists. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$units_exists(abort = TRUE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$unit_exists(id = NULL, name = NULL, abort = TRUE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{name}}{The name of the vertex.} + \item{\code{abort}}{Whether to abort.} } \if{html}{\out{
}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-rcrds_exists}{}}} -\subsection{Method \code{rcrds_exists()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-rcrd_exists}{}}} +\subsection{Method \code{rcrd_exists()}}{ Check if record exists. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$rcrds_exists(abort = TRUE)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$rcrd_exists(id = NULL, name = NULL, abort = TRUE)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{name}}{The name of the vertex.} + \item{\code{abort}}{Whether to abort.} } \if{html}{\out{
}} } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-lvl_exists}{}}} +\subsection{Method \code{lvl_exists()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$lvl_exists(id = NULL, name = NULL, abort = TRUE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{name}}{The name of the vertex.} + +\item{\code{abort}}{Whether to abort.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_fct_nodes}{}}} +\subsection{Method \code{append_fct_nodes()}}{ +Given node data, append the factor nodes +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_fct_nodes(name, role, attrs = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{name}}{The name of the vertex.} + +\item{\code{role}}{The role for the vertex/node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_lvl_nodes}{}}} +\subsection{Method \code{append_lvl_nodes()}}{ +Given node data, append the level nodes +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_lvl_nodes(value, attrs = NULL, fid = NULL)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_fct_edges}{}}} +\subsection{Method \code{append_fct_edges()}}{ +Given edge data, append the factor edges +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_fct_edges(from, to, type = NULL, group = NULL, attrs = NULL)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-append_lvl_edges}{}}} +\subsection{Method \code{append_lvl_edges()}}{ +Given edge data, append the level edges +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$append_lvl_edges(from, to, attrs = NULL)}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-serve_units}{}}} +\subsection{Method \code{serve_units()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$serve_units(id = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-graph_subset}{}}} +\subsection{Method \code{graph_subset()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$graph_subset( + id = NULL, + include = c("self", "child", "parent", "ancestors") +)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{include}}{"self" for only input id, "child" for child also, +"parent" for parent also, +nodes immediately related, and "ancestors" for all ancestors} +} +\if{html}{\out{
}} +} +\subsection{Returns}{ +subsetted graph +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-save_seed}{}}} \subsection{Method \code{save_seed()}}{ @@ -572,11 +776,29 @@ Check if record exists. } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-get_history}{}}} -\subsection{Method \code{get_history()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_title}{}}} +\subsection{Method \code{get_title()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$get_history()}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$get_title()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_trail}{}}} +\subsection{Method \code{get_trail()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$get_trail()}\if{html}{\out{
}} +} + +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_graph}{}}} +\subsection{Method \code{get_graph()}}{ +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$get_graph()}\if{html}{\out{
}} } } @@ -617,29 +839,11 @@ Check if record exists. } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-record_history_external}{}}} -\subsection{Method \code{record_history_external()}}{ -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$record_history_external(code)}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-record_history_internal}{}}} -\subsection{Method \code{record_history_internal()}}{ -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$record_history_internal()}\if{html}{\out{
}} -} - -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-add_history_internal}{}}} -\subsection{Method \code{add_history_internal()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-record_track_external}{}}} +\subsection{Method \code{record_track_external()}}{ \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$add_history_internal(code)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$record_track_external(code)}\if{html}{\out{
}} } } diff --git a/man/design.Rd b/man/design.Rd index 2576fcd9..dc5fd783 100644 --- a/man/design.Rd +++ b/man/design.Rd @@ -5,7 +5,13 @@ \alias{redesign} \title{Start the edibble design} \usage{ -design(name = NULL, .record = TRUE, seed = NULL, provenance = Provenance$new()) +design( + title = NULL, + name = "edibble", + .record = TRUE, + seed = NULL, + provenance = Provenance$new() +) redesign( .data, diff --git a/man/select_units.Rd b/man/select_units.Rd deleted file mode 100644 index 7dae78ef..00000000 --- a/man/select_units.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/units.R -\name{select_units} -\alias{select_units} -\title{Select a subset of units from a cooked design} -\usage{ -select_units(prep, ...) -} -\arguments{ -\item{prep}{A cooked design.} - -\item{...}{The units to select.} -} -\value{ -An edibble design. -} -\description{ -Select a subset of units from a cooked design -} diff --git a/tests/testthat/_snaps/menu.md b/tests/testthat/_snaps/menu.md index 49f62789..cc956d07 100644 --- a/tests/testthat/_snaps/menu.md +++ b/tests/testthat/_snaps/menu.md @@ -25,7 +25,7 @@ 8 unit8 trt1 9 unit9 trt2 10 unit10 trt4 - # ... with 14 more rows + # i 14 more rows # rcbd @@ -45,15 +45,15 @@ # An edibble: 15 x 3 block unit trt * - 1 block1 unit1 trt3 - 2 block1 unit2 trt2 - 3 block1 unit3 trt4 - 4 block1 unit4 trt5 - 5 block1 unit5 trt1 - 6 block2 unit6 trt2 - 7 block2 unit7 trt1 - 8 block2 unit8 trt5 - 9 block2 unit9 trt3 + 1 block1 unit01 trt3 + 2 block1 unit02 trt2 + 3 block1 unit03 trt4 + 4 block1 unit04 trt5 + 5 block1 unit05 trt1 + 6 block2 unit06 trt2 + 7 block2 unit07 trt1 + 8 block2 unit08 trt5 + 9 block2 unit09 trt3 10 block2 unit10 trt4 11 block3 unit11 trt1 12 block3 unit12 trt3 @@ -81,15 +81,15 @@ # An edibble: 12 x 4 mainplot subplot trt1 trt2 * - 1 mainplot1 subplot1 trt13 trt22 - 2 mainplot1 subplot2 trt13 trt21 - 3 mainplot2 subplot3 trt12 trt22 - 4 mainplot2 subplot4 trt12 trt21 - 5 mainplot3 subplot5 trt13 trt21 - 6 mainplot3 subplot6 trt13 trt22 - 7 mainplot4 subplot7 trt11 trt22 - 8 mainplot4 subplot8 trt11 trt21 - 9 mainplot5 subplot9 trt11 trt22 + 1 mainplot1 subplot01 trt13 trt22 + 2 mainplot1 subplot02 trt13 trt21 + 3 mainplot2 subplot03 trt12 trt22 + 4 mainplot2 subplot04 trt12 trt21 + 5 mainplot3 subplot05 trt13 trt21 + 6 mainplot3 subplot06 trt13 trt22 + 7 mainplot4 subplot07 trt11 trt22 + 8 mainplot4 subplot08 trt11 trt21 + 9 mainplot5 subplot09 trt11 trt22 10 mainplot5 subplot10 trt11 trt21 11 mainplot6 subplot11 trt12 trt21 12 mainplot6 subplot12 trt12 trt22 @@ -116,17 +116,17 @@ # An edibble: 24 x 6 block row col unit trt1 trt2 * - 1 block1 row1 col1 unit1 trt12 trt21 - 2 block1 row2 col1 unit2 trt13 trt21 - 3 block1 row3 col1 unit3 trt11 trt21 - 4 block1 row1 col2 unit4 trt12 trt22 - 5 block1 row2 col2 unit5 trt13 trt22 - 6 block1 row3 col2 unit6 trt11 trt22 - 7 block2 row4 col3 unit7 trt12 trt22 - 8 block2 row5 col3 unit8 trt13 trt22 - 9 block2 row6 col3 unit9 trt11 trt22 - 10 block2 row4 col4 unit10 trt12 trt21 - # ... with 14 more rows + 1 block1 row01 col1 unit01 trt12 trt21 + 2 block1 row02 col1 unit02 trt13 trt21 + 3 block1 row03 col1 unit03 trt11 trt21 + 4 block1 row01 col2 unit04 trt12 trt22 + 5 block1 row02 col2 unit05 trt13 trt22 + 6 block1 row03 col2 unit06 trt11 trt22 + 7 block2 row04 col3 unit07 trt12 trt22 + 8 block2 row05 col3 unit08 trt13 trt22 + 9 block2 row06 col3 unit09 trt11 trt22 + 10 block2 row04 col4 unit10 trt12 trt21 + # i 14 more rows # factorial @@ -158,7 +158,7 @@ 8 unit8 trt11 trt22 trt34 9 unit9 trt11 trt23 trt32 10 unit10 trt11 trt23 trt33 - # ... with 38 more rows + # i 38 more rows Code fac_rcbd <- takeout(menu_factorial(trt = c(2, 3, 4), design = "rcbd", r = 2, seed = 1)) @@ -178,17 +178,17 @@ # An edibble: 48 x 5 block unit trt1 trt2 trt3 * - 1 block1 unit1 trt11 trt23 trt31 - 2 block1 unit2 trt11 trt21 trt32 - 3 block1 unit3 trt12 trt23 trt34 - 4 block1 unit4 trt12 trt23 trt32 - 5 block1 unit5 trt12 trt21 trt33 - 6 block1 unit6 trt12 trt23 trt31 - 7 block1 unit7 trt12 trt22 trt33 - 8 block1 unit8 trt11 trt22 trt33 - 9 block1 unit9 trt12 trt21 trt31 + 1 block1 unit01 trt11 trt23 trt31 + 2 block1 unit02 trt11 trt21 trt32 + 3 block1 unit03 trt12 trt23 trt34 + 4 block1 unit04 trt12 trt23 trt32 + 5 block1 unit05 trt12 trt21 trt33 + 6 block1 unit06 trt12 trt23 trt31 + 7 block1 unit07 trt12 trt22 trt33 + 8 block1 unit08 trt11 trt22 trt33 + 9 block1 unit09 trt12 trt21 trt31 10 block1 unit10 trt11 trt21 trt31 - # ... with 38 more rows + # i 38 more rows # lsd @@ -219,7 +219,7 @@ 8 row8 col1 unit8 trt5 9 row9 col1 unit9 trt2 10 row10 col1 unit10 trt8 - # ... with 90 more rows + # i 90 more rows # youden @@ -250,5 +250,5 @@ 8 row8 col1 unit8 trt5 9 row9 col1 unit9 trt2 10 row10 col1 unit10 trt8 - # ... with 60 more rows + # i 60 more rows diff --git a/tests/testthat/_snaps/nest.md b/tests/testthat/_snaps/nest.md index fd211d64..fb9309fc 100644 --- a/tests/testthat/_snaps/nest.md +++ b/tests/testthat/_snaps/nest.md @@ -5,7 +5,7 @@ block, 2)) des1 Output - nested units - \-block (3 levels) - \-plot (6 levels) + An edibble design + +-block (3 levels) + \-plot (6 levels) diff --git a/tests/testthat/_snaps/rcrds.md b/tests/testthat/_snaps/rcrds.md index 6a2dd6d7..dde8eb65 100644 --- a/tests/testthat/_snaps/rcrds.md +++ b/tests/testthat/_snaps/rcrds.md @@ -251,3 +251,24 @@ Message * exam_mark: numeric (0, Inf] +--- + + Code + des0 %>% serve_table() %>% set_rcrds(exam_mark = student, room = class) + Output + # Effective teaching + # An edibble: 120 x 6 + class student style exam exam_mark room + + 1 class1 student1 traditional closed-book o o + 2 class1 student2 traditional closed-book o x + 3 class1 student3 traditional take-home o x + 4 class1 student4 traditional take-home o x + 5 class1 student5 traditional open-book o x + 6 class1 student6 traditional take-home o x + 7 class1 student7 traditional take-home o x + 8 class1 student8 traditional closed-book o x + 9 class1 student9 traditional closed-book o x + 10 class1 student10 traditional open-book o x + # ... with 110 more rows + diff --git a/tests/testthat/_snaps/rcrds.new.md b/tests/testthat/_snaps/rcrds.new.md new file mode 100644 index 00000000..9c9227b5 --- /dev/null +++ b/tests/testthat/_snaps/rcrds.new.md @@ -0,0 +1,16 @@ +# measure response + + Code + serve_table(des1) + Output + # An edibble design + # An edibble: 6 x 2 + block plot + + 1 block1 plot1 + 2 block1 plot2 + 3 block2 plot3 + 4 block2 plot4 + 5 block3 plot5 + 6 block3 plot6 + diff --git a/tests/testthat/_snaps/serve.new.md b/tests/testthat/_snaps/serve.new.md new file mode 100644 index 00000000..735aed3c --- /dev/null +++ b/tests/testthat/_snaps/serve.new.md @@ -0,0 +1,40 @@ +# serve + + Code + design(name = "unlinked units with table") %>% set_units(block = 3, plot = 2) %>% + serve_table() + Output + # An edibble design + # An edibble: 0 x 2 + # i 2 variables: block , plot + +--- + + Code + design(name = "one unit") %>% set_units(block = 3) %>% serve_table() + Output + # An edibble design + # An edibble: 3 x 1 + block + + 1 block1 + 2 block2 + 3 block3 + +--- + + Code + design(name = "serve nested units") %>% set_units(block = 3, plot = nested_in( + block, 2)) %>% serve_table() + Output + # An edibble design + # An edibble: 6 x 2 + block plot + + 1 block1 plot1 + 2 block1 plot2 + 3 block2 plot3 + 4 block2 plot4 + 5 block3 plot5 + 6 block3 plot6 + diff --git a/tests/testthat/_snaps/trts.new.md b/tests/testthat/_snaps/trts.new.md new file mode 100644 index 00000000..b01e8490 --- /dev/null +++ b/tests/testthat/_snaps/trts.new.md @@ -0,0 +1,433 @@ +# treatments + + Code + design(seed = 1) %>% set_trts(vaccine = 2) + Output + An edibble design + \-vaccine (2 levels) + +--- + + Code + design(seed = 1) %>% set_trts(vaccine = 2, sex = 2) + Output + An edibble design + +-vaccine (2 levels) + \-sex (2 levels) + +--- + + Code + design(seed = 1) %>% set_units(person = 5) %>% set_trts(vaccine = 2, sex = 2) + Output + An edibble design + +-person (5 levels) + +-vaccine (2 levels) + \-sex (2 levels) + +--- + + Code + design(seed = 1) %>% set_trts(vaccine = 2, sex = 2) %>% set_units(person = 5) + Output + An edibble design + +-vaccine (2 levels) + +-sex (2 levels) + \-person (5 levels) + +--- + + Code + design() %>% set_trts(vaccine = 3, sex = 2) %>% set_units(person = 30) %>% + allot_trts(~person) %>% assign_trts("systematic") %>% serve_table() + Output + # An edibble design + # An edibble: 30 x 3 + vaccine sex person + + 1 vaccine1 sex1 person1 + 2 vaccine2 sex1 person2 + 3 vaccine3 sex1 person3 + 4 vaccine1 sex2 person4 + 5 vaccine2 sex2 person5 + 6 vaccine3 sex2 person6 + 7 vaccine1 sex1 person7 + 8 vaccine2 sex1 person8 + 9 vaccine3 sex1 person9 + 10 vaccine1 sex2 person10 + # i 20 more rows + +--- + + Code + design() %>% set_trts(vaccine = 3, sex = c("F", "M")) %>% set_units(person = 30) %>% + allot_trts(vaccine:sex ~ person) %>% assign_trts("systematic") %>% + serve_table() + Output + # An edibble design + # An edibble: 30 x 3 + vaccine sex person + + 1 vaccine1 F person1 + 2 vaccine2 F person2 + 3 vaccine3 F person3 + 4 vaccine1 M person4 + 5 vaccine2 M person5 + 6 vaccine3 M person6 + 7 vaccine1 F person7 + 8 vaccine2 F person8 + 9 vaccine3 F person9 + 10 vaccine1 M person10 + # i 20 more rows + +--- + + Code + design() %>% set_trts(vaccine = 3, sex = c("F", "M")) %>% set_units(person = 30) %>% + allot_trts(vaccine ~ person, sex ~ person) %>% assign_trts("systematic") %>% + serve_table() + Output + # An edibble design + # An edibble: 30 x 3 + vaccine sex person + + 1 vaccine1 F person1 + 2 vaccine2 M person2 + 3 vaccine3 F person3 + 4 vaccine1 M person4 + 5 vaccine2 F person5 + 6 vaccine3 M person6 + 7 vaccine1 F person7 + 8 vaccine2 M person8 + 9 vaccine3 F person9 + 10 vaccine1 M person10 + # i 20 more rows + +--- + + Code + design() %>% set_trts(vaccine = 3) %>% set_units(person = 30) %>% allot_trts( + vaccine ~ person) %>% assign_trts("systematic") %>% serve_table() + Output + # An edibble design + # An edibble: 30 x 2 + vaccine person + + 1 vaccine1 person1 + 2 vaccine2 person2 + 3 vaccine3 person3 + 4 vaccine1 person4 + 5 vaccine2 person5 + 6 vaccine3 person6 + 7 vaccine1 person7 + 8 vaccine2 person8 + 9 vaccine3 person9 + 10 vaccine1 person10 + # i 20 more rows + +--- + + Code + design() %>% set_trts(vaccine = 3) %>% set_units(person = 5) %>% allot_trts( + vaccine ~ person) %>% assign_trts("systematic-random", seed = 2) %>% + serve_table() + Output + # An edibble design + # An edibble: 5 x 2 + vaccine person + + 1 vaccine1 person1 + 2 vaccine3 person2 + 3 vaccine2 person3 + 4 vaccine1 person4 + 5 vaccine3 person5 + +--- + + Code + design() %>% set_trts(vaccine = 3) %>% set_units(person = 5) %>% allot_trts( + vaccine ~ person) %>% assign_trts("random", seed = 3) %>% serve_table() + Output + # An edibble design + # An edibble: 5 x 2 + vaccine person + + 1 vaccine3 person1 + 2 vaccine2 person2 + 3 vaccine2 person3 + 4 vaccine1 person4 + 5 vaccine3 person5 + +--- + + Code + tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( + person, 3)) %>% allot_trts(vaccine ~ person) %>% assign_trts("random", seed = 2) %>% + serve_table() + table(tab$vaccine, tab$person) + Output + + person1 person10 person11 person12 person13 person14 person15 + vaccine1 0 3 0 0 3 0 0 + vaccine2 0 0 0 3 0 3 0 + vaccine3 3 0 3 0 0 0 3 + + person16 person17 person18 person19 person2 person20 person3 person4 + vaccine1 3 0 0 0 3 3 3 0 + vaccine2 0 0 3 3 0 0 0 3 + vaccine3 0 3 0 0 0 0 0 0 + + person5 person6 person7 person8 person9 + vaccine1 0 0 0 3 0 + vaccine2 3 3 0 0 0 + vaccine3 0 0 3 0 3 + +--- + + Code + tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( + person, 3)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2, + constrain = NULL) %>% serve_table() + table(tab$vaccine, tab$person) + Output + + person1 person10 person11 person12 person13 person14 person15 + vaccine1 1 2 0 1 2 2 0 + vaccine2 0 1 2 2 0 0 2 + vaccine3 2 0 1 0 1 1 1 + + person16 person17 person18 person19 person2 person20 person3 person4 + vaccine1 0 2 3 0 1 1 1 1 + vaccine2 1 1 0 1 1 2 1 2 + vaccine3 2 0 0 2 1 0 1 0 + + person5 person6 person7 person8 person9 + vaccine1 1 2 0 0 0 + vaccine2 1 1 1 1 0 + vaccine3 1 0 2 2 3 + +--- + + Code + tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( + person, 3)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2) %>% + serve_table() + table(tab$vaccine, tab$person) + Output + + person1 person10 person11 person12 person13 person14 person15 + vaccine1 1 1 1 1 1 1 1 + vaccine2 1 1 1 1 1 1 1 + vaccine3 1 1 1 1 1 1 1 + + person16 person17 person18 person19 person2 person20 person3 person4 + vaccine1 1 1 1 1 1 1 1 1 + vaccine2 1 1 1 1 1 1 1 1 + vaccine3 1 1 1 1 1 1 1 1 + + person5 person6 person7 person8 person9 + vaccine1 1 1 1 1 1 + vaccine2 1 1 1 1 1 + vaccine3 1 1 1 1 1 + +--- + + Code + tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( + person, 2)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2) %>% + serve_table() + table(tab$vaccine, tab$person) + Output + + person1 person10 person11 person12 person13 person14 person15 + vaccine1 1 0 1 1 1 0 1 + vaccine2 1 1 0 1 1 1 0 + vaccine3 0 1 1 0 0 1 1 + + person16 person17 person18 person19 person2 person20 person3 person4 + vaccine1 0 1 1 1 1 0 0 0 + vaccine2 1 1 0 0 0 1 1 1 + vaccine3 1 0 1 1 1 1 1 1 + + person5 person6 person7 person8 person9 + vaccine1 1 1 0 1 1 + vaccine2 0 1 1 1 0 + vaccine3 1 0 1 0 1 + +--- + + Code + tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( + person, 8)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2) %>% + serve_table() + table(tab$vaccine, tab$person) + Output + + person1 person10 person11 person12 person13 person14 person15 + vaccine1 3 2 3 3 3 2 3 + vaccine2 3 3 2 3 3 3 2 + vaccine3 2 3 3 2 2 3 3 + + person16 person17 person18 person19 person2 person20 person3 person4 + vaccine1 2 3 3 3 3 2 2 2 + vaccine2 3 3 2 2 2 3 3 3 + vaccine3 3 2 3 3 3 3 3 3 + + person5 person6 person7 person8 person9 + vaccine1 3 3 2 3 3 + vaccine2 2 3 3 3 2 + vaccine3 3 2 3 2 3 + +--- + + Code + tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( + person, 1 ~ 8, 2 ~ 3, . ~ 4)) %>% allot_trts(vaccine ~ blood) %>% assign_trts( + "random", seed = 2) %>% serve_table() + table(tab$vaccine, tab$person) + Output + + person1 person10 person11 person12 person13 person14 person15 + vaccine1 3 2 1 1 2 1 1 + vaccine2 3 1 2 1 1 2 1 + vaccine3 2 1 1 2 1 1 2 + + person16 person17 person18 person19 person2 person20 person3 person4 + vaccine1 2 1 1 2 1 1 1 2 + vaccine2 1 2 1 1 1 2 1 1 + vaccine3 1 1 2 1 1 1 2 1 + + person5 person6 person7 person8 person9 + vaccine1 1 1 2 1 1 + vaccine2 2 1 1 2 1 + vaccine3 1 2 1 1 2 + +--- + + Code + tab <- design() %>% set_trts(fert = 8) %>% set_units(site = 10, plot = nested_in( + site, 10), sample = nested_in(plot, 1 ~ 8, 2 ~ 3, . ~ 4)) %>% allot_trts( + fert ~ sample) %>% assign_trts("random", seed = 2) %>% serve_table() + table(tab$fert, tab$plot) + Output + + plot001 plot002 plot003 plot004 plot005 plot006 plot007 plot008 plot009 + fert1 1 1 0 0 0 0 1 1 1 + fert2 1 0 1 1 1 0 0 1 0 + fert3 1 0 0 1 1 0 0 1 1 + fert4 1 1 1 0 0 1 0 0 1 + fert5 1 0 0 0 0 1 1 0 0 + fert6 1 1 1 0 1 1 1 0 1 + fert7 1 0 0 1 0 0 1 1 0 + fert8 1 0 1 1 1 1 0 0 0 + + plot010 plot011 plot012 plot013 plot014 plot015 plot016 plot017 plot018 + fert1 1 1 1 0 1 0 0 0 1 + fert2 0 0 1 1 1 0 1 0 1 + fert3 1 0 0 0 0 1 0 0 1 + fert4 0 1 1 0 1 0 1 1 0 + fert5 1 0 0 1 0 1 1 1 0 + fert6 1 1 0 0 0 1 1 1 0 + fert7 0 1 1 1 1 1 0 0 0 + fert8 0 0 0 1 0 0 0 1 1 + + plot019 plot020 plot021 plot022 plot023 plot024 plot025 plot026 plot027 + fert1 0 1 1 0 1 0 1 1 0 + fert2 0 1 0 0 1 0 1 0 1 + fert3 0 1 1 0 0 1 1 0 1 + fert4 1 0 1 0 1 1 0 0 0 + fert5 0 0 0 1 0 0 0 1 1 + fert6 1 1 1 1 0 0 0 1 0 + fert7 1 0 0 1 1 1 1 1 0 + fert8 1 0 0 1 0 1 0 0 1 + + plot028 plot029 plot030 plot031 plot032 plot033 plot034 plot035 plot036 + fert1 1 1 1 0 0 1 0 0 1 + fert2 1 0 1 0 1 0 1 1 0 + fert3 1 0 0 1 1 0 1 0 0 + fert4 1 1 0 1 0 0 1 1 0 + fert5 0 1 0 0 1 1 1 0 1 + fert6 0 0 1 0 1 0 0 0 0 + fert7 0 1 0 1 0 1 0 1 1 + fert8 0 0 1 1 0 1 0 1 1 + + plot037 plot038 plot039 plot040 plot041 plot042 plot043 plot044 plot045 + fert1 1 0 1 0 1 0 1 1 0 + fert2 1 1 0 1 0 1 0 1 0 + fert3 1 1 0 1 0 0 1 0 1 + fert4 0 1 0 0 1 0 1 1 1 + fert5 0 1 0 0 1 0 0 1 0 + fert6 1 0 1 0 1 1 0 0 0 + fert7 0 0 1 1 0 1 0 0 1 + fert8 0 0 1 1 0 1 1 0 1 + + plot046 plot047 plot048 plot049 plot050 plot051 plot052 plot053 plot054 + fert1 0 1 0 0 1 0 1 0 1 + fert2 1 0 0 0 1 1 0 1 1 + fert3 0 1 1 0 0 0 1 1 0 + fert4 0 1 0 1 0 1 1 0 0 + fert5 1 1 1 1 0 1 0 1 0 + fert6 1 0 0 1 1 0 0 1 1 + fert7 0 0 1 0 1 0 1 0 0 + fert8 1 0 1 1 0 1 0 0 1 + + plot055 plot056 plot057 plot058 plot059 plot060 plot061 plot062 plot063 + fert1 0 0 1 0 1 1 0 0 1 + fert2 0 1 0 0 0 0 1 0 0 + fert3 1 0 1 1 0 0 1 1 1 + fert4 1 0 0 0 0 1 0 1 0 + fert5 0 1 1 1 0 1 0 0 1 + fert6 0 0 1 1 1 0 1 1 0 + fert7 1 1 0 1 1 0 1 1 0 + fert8 1 1 0 0 1 1 0 0 1 + + plot064 plot065 plot066 plot067 plot068 plot069 plot070 plot071 plot072 + fert1 0 1 1 0 0 0 1 1 0 + fert2 1 0 0 1 1 0 1 0 0 + fert3 0 1 0 1 0 1 0 0 1 + fert4 1 1 1 0 0 1 0 1 0 + fert5 0 0 1 1 1 0 0 1 0 + fert6 1 0 0 0 1 1 1 0 1 + fert7 1 0 0 1 1 0 0 1 1 + fert8 0 1 1 0 0 1 1 0 1 + + plot073 plot074 plot075 plot076 plot077 plot078 plot079 plot080 plot081 + fert1 1 0 1 1 0 0 1 1 0 + fert2 0 1 1 1 0 1 0 1 1 + fert3 1 0 1 0 1 0 1 0 1 + fert4 0 1 0 1 1 1 0 0 1 + fert5 1 1 0 1 0 1 0 1 0 + fert6 0 0 0 0 1 1 1 0 1 + fert7 0 1 0 0 1 0 0 1 0 + fert8 1 0 1 0 0 0 1 0 0 + + plot082 plot083 plot084 plot085 plot086 plot087 plot088 plot089 plot090 + fert1 1 0 0 1 0 0 1 1 0 + fert2 1 0 1 0 1 0 0 0 1 + fert3 0 1 1 0 0 0 1 1 1 + fert4 0 1 1 0 1 1 1 0 0 + fert5 0 1 0 1 1 0 0 1 1 + fert6 0 0 1 1 0 1 0 0 0 + fert7 1 0 0 1 0 1 1 0 1 + fert8 1 1 0 0 1 1 0 1 0 + + plot091 plot092 plot093 plot094 plot095 plot096 plot097 plot098 plot099 + fert1 1 1 0 0 0 1 0 0 1 + fert2 0 1 1 0 0 1 1 0 1 + fert3 0 0 0 1 1 1 0 1 0 + fert4 0 0 1 0 1 0 1 0 1 + fert5 1 0 1 1 1 1 0 1 0 + fert6 1 1 0 0 1 0 1 1 0 + fert7 0 0 1 1 0 0 0 1 0 + fert8 1 1 0 1 0 0 1 0 1 + + plot100 + fert1 1 + fert2 0 + fert3 0 + fert4 1 + fert5 0 + fert6 1 + fert7 1 + fert8 0 + diff --git a/tests/testthat/_snaps/units.new.md b/tests/testthat/_snaps/units.new.md new file mode 100644 index 00000000..fb4adae9 --- /dev/null +++ b/tests/testthat/_snaps/units.new.md @@ -0,0 +1,81 @@ +# set_units + + Code + design(name = "unlinked units") %>% set_units(block = 3, plot = 2) + Output + An edibble design + +-block (3 levels) + \-plot (2 levels) + +--- + + Code + design() %>% set_units(row = 3, col = 4, plot = ~ row:col) %>% serve_table() + Warning + partial match of 'factor' to 'factors' + Output + # An edibble design + # An edibble: 12 x 3 + row col plot + + 1 row1 col1 plot1 + 2 row2 col1 plot2 + 3 row3 col1 plot3 + 4 row1 col2 plot4 + 5 row2 col2 plot5 + 6 row3 col2 plot6 + 7 row1 col3 plot7 + 8 row2 col3 plot8 + 9 row3 col3 plot9 + 10 row1 col4 plot10 + 11 row2 col4 plot11 + 12 row3 col4 plot12 + +--- + + Code + design() %>% set_units(row = 3, col = 4, site = 4, plot = ~ site:row:col) %>% + serve_table() + Warning + partial match of 'factor' to 'factors' + Output + # An edibble design + # An edibble: 48 x 4 + row col site plot + + 1 row1 col1 site1 plot1 + 2 row1 col1 site2 plot2 + 3 row1 col1 site3 plot3 + 4 row1 col1 site4 plot4 + 5 row2 col1 site1 plot5 + 6 row2 col1 site2 plot6 + 7 row2 col1 site3 plot7 + 8 row2 col1 site4 plot8 + 9 row3 col1 site1 plot9 + 10 row3 col1 site2 plot10 + # i 38 more rows + +--- + + Code + design() %>% set_units(site = 2, row = nested_in(site, 1 ~ 2, 2 ~ 3), col = nested_in( + site, 3), plot = ~ site:row:col) %>% serve_table() + Warning + partial match of 'factor' to 'factors' + Output + # An edibble design + # An edibble: 60 x 4 + site row col plot + + 1 site1 row1 col1 plot1 + 2 site1 row1 col1 plot2 + 3 site1 row2 col1 plot3 + 4 site1 row2 col1 plot4 + 5 site2 row3 col1 plot5 + 6 site2 row3 col1 plot6 + 7 site2 row4 col1 plot7 + 8 site2 row4 col1 plot8 + 9 site2 row5 col1 plot9 + 10 site2 row5 col1 plot10 + # i 50 more rows + diff --git a/tests/testthat/test-design.R b/tests/testthat/test-design.R index 21ccdb8c..311e7fb3 100644 --- a/tests/testthat/test-design.R +++ b/tests/testthat/test-design.R @@ -3,8 +3,6 @@ test_that("start designs", { des2 <- design("Some design") expect_equal(class(des1), c("edbl_design", "edbl")) - expect_equal(des1$name, NULL) - expect_equal(des2$name, "Some design") expect_snapshot({ des1 diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index b8c0c85e..a8cb9e3d 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -1,8 +1,8 @@ test_that("label works", { - expect_equal(label_seq_from_to(from = 8, to = 10, by = 2), c("08", "10")) + expect_equal(label_seq_from_to(from = 8, to = 10, by = 2), c("8", "10")) expect_equal(label_seq_from_to(from = 8, to = 10, leading_zero = 3), c("008", "009", "010")) - expect_equal(label_seq_from_length(from = 8, length = 3, prefix = "P", sep_prefix = "-"), c("P-08", "P-09", "P-10")) - expect_equal(label_seq_to_length(to = 10, length = 3, suffix = "P", sep_suffix = "-"), c("08-P", "09-P", "10-P")) + expect_equal(label_seq_from_length(from = 8, length = 3, prefix = "P", sep_prefix = "-", leading_zero = TRUE), c("P-08", "P-09", "P-10")) + expect_equal(label_seq_to_length(to = 10, length = 3, suffix = "P", sep_suffix = "-", leading_zero = 2), c("08-P", "09-P", "10-P")) expect_equal(label_seq_length(length = 3, prefix = "P", sep_prefix = "-"), c("P-1", "P-2", "P-3")) }) diff --git a/tests/testthat/test-nest.R b/tests/testthat/test-nest.R index 67333c3c..49801362 100644 --- a/tests/testthat/test-nest.R +++ b/tests/testthat/test-nest.R @@ -8,31 +8,41 @@ test_that("nested-units", { }) expect_equal(fct_nodes(des1), - data.frame(id = c(1L, 2L), - name = c("block", "plot"), - class = "edbl_unit")) + tibble::tibble(id = c(1L, 2L), + role = "edbl_unit", + name = c("block", "plot"), + attrs = NA)) expect_equal(lvl_nodes(des1), - data.frame(idvar = rep(1:2, c(3, 6)), - id = 1:9, - name = c(paste0("block", 1:3), paste0("plot", 1:6)), - var = rep(c("block", "plot"), c(3, 6)), - label = c(paste0("block", 1:3), rep(paste0("plot", 1:2), 3)))) + structure(list(`1` = tibble::tibble(id = 1:3, + value = c("block1", "block2", "block3")), + `2` = tibble::tibble(id = 4:9, + value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6"))), + class = c("edbl_lnodes", "list"))) des2 <- des1 %>% set_units(sample = nested_in(plot, 1 ~ 20, - . ~ 3, leading0 = 3)) + . ~ 3)) expect_equal(fct_nodes(des2), - data.frame(id = c(1L, 2L, 3L), - name = c("block", "plot", "sample"), - class = "edbl_unit")) + tibble::tibble(id = c(1L, 2L, 3L), + role = "edbl_unit", + name = c("block", "plot", "sample"), + attrs = NA)) expect_equal(lvl_nodes(des2), - data.frame(idvar = rep(1:3, c(3, 6, 35)), - id = 1:44, - name = c(paste0("block", 1:3), paste0("plot", 1:6), sprintf("sample%.3d", 1:35)), - var = rep(c("block", "plot", "sample"), c(3, 6, 35)), - label = c(paste0("block", 1:3), rep(paste0("plot", 1:2), 3), sprintf("sample%.3d", 1:20), - rep(sprintf("sample%.3d", 1:3), 5)))) + structure(list(`1` = tibble::tibble(id = 1:3, + value = c("block1", "block2", "block3")), + `2` = tibble::tibble(id = 4:9, + value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6")), + `3` = tibble::tibble(id = 10:44, + value = c("sample01", "sample02", "sample03", + "sample04", "sample05", "sample06", "sample07", "sample08", + "sample09", "sample10", "sample11", "sample12", "sample13", + "sample14", "sample15", "sample16", "sample17", "sample18", + "sample19", "sample20", "sample21", "sample22", "sample23", + "sample24", "sample25", "sample26", "sample27", "sample28", + "sample29", "sample30", "sample31", "sample32", "sample33", + "sample34", "sample35"))), + class = c("edbl_lnodes", "list"))) diff --git a/tests/testthat/test-rcrds.R b/tests/testthat/test-rcrds.R index 30455623..95de093b 100644 --- a/tests/testthat/test-rcrds.R +++ b/tests/testthat/test-rcrds.R @@ -1,5 +1,5 @@ test_that("measure response", { - + # FIXME des0 <- design(name = "Effective teaching") %>% set_units(class = 4, diff --git a/tests/testthat/test-serve.R b/tests/testthat/test-serve.R index 14ec6a07..1dc49732 100644 --- a/tests/testthat/test-serve.R +++ b/tests/testthat/test-serve.R @@ -1,4 +1,5 @@ test_that("serve", { + # FIXME expect_snapshot({ design(name = "unlinked units with table") %>% set_units(block = 3, diff --git a/tests/testthat/test-trts.R b/tests/testthat/test-trts.R index 81a4beae..3c2a342e 100644 --- a/tests/testthat/test-trts.R +++ b/tests/testthat/test-trts.R @@ -1,4 +1,5 @@ test_that("treatments", { + # FIXME expect_snapshot({ design(seed = 1) %>% set_trts(vaccine = 2) diff --git a/tests/testthat/test-units.R b/tests/testthat/test-units.R index 7accf4ab..b3e57249 100644 --- a/tests/testthat/test-units.R +++ b/tests/testthat/test-units.R @@ -1,4 +1,5 @@ test_that("set_units", { + # FIXME expect_snapshot({ design(name = "unlinked units") %>% From e0fb4e05f9d38925149155667ebf181efd164124 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sat, 12 Aug 2023 20:32:05 -0400 Subject: [PATCH 12/83] test-units passed --- R/edibble.R | 2 +- R/graph-input.R | 2 +- R/provenance.R | 2 +- R/utils.R | 2 +- tests/testthat/_snaps/trts.new.md | 2 +- tests/testthat/_snaps/units.md | 6 +-- tests/testthat/_snaps/units.new.md | 81 ------------------------------ tests/testthat/test-units.R | 24 ++++----- 8 files changed, 20 insertions(+), 101 deletions(-) delete mode 100644 tests/testthat/_snaps/units.new.md diff --git a/R/edibble.R b/R/edibble.R index 742fef9b..6fcc8490 100644 --- a/R/edibble.R +++ b/R/edibble.R @@ -152,7 +152,7 @@ new_trackable <- function(internal_cmd = character(), #' @export tbl_sum.trck_table <- function(x) { - c("A history table" = dim_desc(x), + c("A tracking table" = dim_desc(x), "External command" = attr(x, "external_cmd"), "Execution time" = paste(as.character(attr(x, "execution_time")), as.character(attr(x, "time_zone")))) diff --git a/R/graph-input.R b/R/graph-input.R index 30d6969f..ede0895c 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -41,7 +41,7 @@ graph_input.edbl_lvls <- function(input, prov, name, class) { graph_input.formula <- function(input, prov, name, class) { tt <- terms(input) - vars <- rownames(attr(tt, "factor")) + vars <- rownames(attr(tt, "factors")) graph_input.cross_lvls(vars, prov, name, class) } diff --git a/R/provenance.R b/R/provenance.R index c9ed3c55..7d17d671 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -704,7 +704,7 @@ Provenance <- R6::R6Class("Provenance", fct_id_last = 0L, lvl_id_last = 0L, - title = "An edibble design", + title = NULL, name = NULL, seed = NULL, edbl_version = NULL, diff --git a/R/utils.R b/R/utils.R index abbdd38e..161505c8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -48,7 +48,7 @@ print.edbl_design <- function(x, decorate_title = edibble_decorate("title"), title = NULL, ...) { prov <- activate_provenance(x) - title <- title %||% prov$get_title() + title <- title %||% prov$get_title() %||% "An edibble design" fids <- prov$fct_nodes$id fnames <- prov$fct_names(id = fids) diff --git a/tests/testthat/_snaps/trts.new.md b/tests/testthat/_snaps/trts.new.md index b01e8490..5185536c 100644 --- a/tests/testthat/_snaps/trts.new.md +++ b/tests/testthat/_snaps/trts.new.md @@ -41,7 +41,7 @@ design() %>% set_trts(vaccine = 3, sex = 2) %>% set_units(person = 30) %>% allot_trts(~person) %>% assign_trts("systematic") %>% serve_table() Output - # An edibble design + # An edibble design # An edibble: 30 x 3 vaccine sex person diff --git a/tests/testthat/_snaps/units.md b/tests/testthat/_snaps/units.md index 0e32d3e7..445c66cb 100644 --- a/tests/testthat/_snaps/units.md +++ b/tests/testthat/_snaps/units.md @@ -1,7 +1,7 @@ # set_units Code - design(name = "unlinked units") %>% set_units(block = 3, plot = 2) + design(title = "unlinked units") %>% set_units(block = 3, plot = 2) Output unlinked units +-block (3 levels) @@ -47,7 +47,7 @@ 8 row2 col1 site4 plot8 9 row3 col1 site1 plot9 10 row3 col1 site2 plot10 - # ... with 38 more rows + # i 38 more rows --- @@ -68,5 +68,5 @@ 8 site2 row4 col1 plot8 9 site2 row5 col1 plot9 10 site2 row5 col1 plot10 - # ... with 50 more rows + # i 50 more rows diff --git a/tests/testthat/_snaps/units.new.md b/tests/testthat/_snaps/units.new.md deleted file mode 100644 index fb4adae9..00000000 --- a/tests/testthat/_snaps/units.new.md +++ /dev/null @@ -1,81 +0,0 @@ -# set_units - - Code - design(name = "unlinked units") %>% set_units(block = 3, plot = 2) - Output - An edibble design - +-block (3 levels) - \-plot (2 levels) - ---- - - Code - design() %>% set_units(row = 3, col = 4, plot = ~ row:col) %>% serve_table() - Warning - partial match of 'factor' to 'factors' - Output - # An edibble design - # An edibble: 12 x 3 - row col plot - - 1 row1 col1 plot1 - 2 row2 col1 plot2 - 3 row3 col1 plot3 - 4 row1 col2 plot4 - 5 row2 col2 plot5 - 6 row3 col2 plot6 - 7 row1 col3 plot7 - 8 row2 col3 plot8 - 9 row3 col3 plot9 - 10 row1 col4 plot10 - 11 row2 col4 plot11 - 12 row3 col4 plot12 - ---- - - Code - design() %>% set_units(row = 3, col = 4, site = 4, plot = ~ site:row:col) %>% - serve_table() - Warning - partial match of 'factor' to 'factors' - Output - # An edibble design - # An edibble: 48 x 4 - row col site plot - - 1 row1 col1 site1 plot1 - 2 row1 col1 site2 plot2 - 3 row1 col1 site3 plot3 - 4 row1 col1 site4 plot4 - 5 row2 col1 site1 plot5 - 6 row2 col1 site2 plot6 - 7 row2 col1 site3 plot7 - 8 row2 col1 site4 plot8 - 9 row3 col1 site1 plot9 - 10 row3 col1 site2 plot10 - # i 38 more rows - ---- - - Code - design() %>% set_units(site = 2, row = nested_in(site, 1 ~ 2, 2 ~ 3), col = nested_in( - site, 3), plot = ~ site:row:col) %>% serve_table() - Warning - partial match of 'factor' to 'factors' - Output - # An edibble design - # An edibble: 60 x 4 - site row col plot - - 1 site1 row1 col1 plot1 - 2 site1 row1 col1 plot2 - 3 site1 row2 col1 plot3 - 4 site1 row2 col1 plot4 - 5 site2 row3 col1 plot5 - 6 site2 row3 col1 plot6 - 7 site2 row4 col1 plot7 - 8 site2 row4 col1 plot8 - 9 site2 row5 col1 plot9 - 10 site2 row5 col1 plot10 - # i 50 more rows - diff --git a/tests/testthat/test-units.R b/tests/testthat/test-units.R index b3e57249..b899130a 100644 --- a/tests/testthat/test-units.R +++ b/tests/testthat/test-units.R @@ -2,25 +2,25 @@ test_that("set_units", { # FIXME expect_snapshot({ - design(name = "unlinked units") %>% + design(title = "unlinked units") %>% set_units(block = 3, plot = 2) }) - des <- design(name = "unlinked units") %>% + des <- design(title = "unlinked units") %>% set_units(block = 3, plot = 2) - expect_equal(nrow(des$graph$nodes), 2) - expect_equal(names(des$graph$nodes), c("id", "name", "class")) - expect_equal(nrow(des$graph$levels$nodes), 5) - expect_equal(des$graph$nodes$id, c(1L, 2L)) - expect_equal(des$graph$nodes$name, c("block", "plot")) - expect_equal(des$graph$nodes$class, c("edbl_unit", "edbl_unit")) - expect_equal(des$graph$levels$nodes$idvar, c(1L, 1L, 1L, 2L, 2L)) - expect_equal(des$graph$levels$nodes$id, 1:5) - expect_equal(des$graph$levels$nodes$name, c("block1", "block2", "block3", "plot1", "plot2")) - expect_equal(names(des$graph$levels$nodes), c("idvar", "id", "name", "var", "label")) + expect_equal(nrow(des$graph$factors$nodes), 2) + expect_equal(names(des$graph$factors$nodes), c("id", "role", "name", "attrs")) + expect_equal(des$graph$factors$nodes$id, c(1L, 2L)) + expect_equal(des$graph$factors$nodes$name, c("block", "plot")) + expect_equal(des$graph$factors$nodes$role, c("edbl_unit", "edbl_unit")) + expect_equal(des$graph$levels$nodes[["1"]]$id, 1:3) + expect_equal(des$graph$levels$nodes[["2"]]$id, 4:5) + expect_equal(des$graph$levels$nodes[["1"]]$value, c("block1", "block2", "block3")) + expect_equal(des$graph$levels$nodes[["2"]]$value, c("plot1", "plot2")) + expect_equal(names(des$graph$levels$nodes[["1"]]), c("id", "value")) expect_snapshot({ From 70ec287a24f5a3ba2dbd4472cf6b088c40634c47 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 13 Aug 2023 16:38:39 -0400 Subject: [PATCH 13/83] some fixes for assign trts --- R/assign.R | 1 + R/design.R | 2 +- R/provenance.R | 2 +- tests/testthat/_snaps/trts.md | 500 +++++++++--------------------- tests/testthat/_snaps/trts.new.md | 433 -------------------------- tests/testthat/test-trts.R | 2 +- tests/testthat/test-units.R | 1 - 7 files changed, 154 insertions(+), 787 deletions(-) delete mode 100644 tests/testthat/_snaps/trts.new.md diff --git a/R/assign.R b/R/assign.R index dce77507..1e6e6fe3 100644 --- a/R/assign.R +++ b/R/assign.R @@ -47,6 +47,7 @@ assign_trts <- function(.design, order = "random", seed = NULL, constrain = nest allotments <- fedges[fedges$type == "allot", ] alloc_groups <- unique(allotments$group) order <- rep(order, length.out = length(alloc_groups)) + for(igroup in alloc_groups) { trts_id <- allotments[allotments$group == igroup, ]$from # there should be only one unit diff --git a/R/design.R b/R/design.R index 3d33067f..d5f28f6a 100644 --- a/R/design.R +++ b/R/design.R @@ -80,7 +80,7 @@ NULL #' @rdname extract-lvl-nodes #' @export "$.edbl_lnodes" <- function(x, name) { - unname(unlist(lapply(x, function(.x) .x[[name]]))) + unname(unlist(lapply(unclass(x), function(.x) .x[[name]]))) } #' @rdname extract-lvl-nodes diff --git a/R/provenance.R b/R/provenance.R index 7d17d671..6fb7b295 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -261,7 +261,7 @@ Provenance <- R6::R6Class("Provenance", qid <- id %||% self$fct_id(name = name) lnodes <- self$lvl_nodes switch(return, - id = lapply(lnodes[qid], function(x) x$id), + id = lapply(unclass(lnodes[qid]), function(x) x$id), value = { out <- lapply(lnodes[qid], function(x) x$value) names(out) <- self$fct_names(id = qid) diff --git a/tests/testthat/_snaps/trts.md b/tests/testthat/_snaps/trts.md index 367394b7..0f9e4a50 100644 --- a/tests/testthat/_snaps/trts.md +++ b/tests/testthat/_snaps/trts.md @@ -54,7 +54,7 @@ 8 vaccine2 sex1 person8 9 vaccine3 sex1 person9 10 vaccine1 sex2 person10 - # ... with 20 more rows + # i 20 more rows --- @@ -76,7 +76,7 @@ 8 vaccine2 F person8 9 vaccine3 F person9 10 vaccine1 M person10 - # ... with 20 more rows + # i 20 more rows --- @@ -98,7 +98,7 @@ 8 vaccine2 M person8 9 vaccine3 F person9 10 vaccine1 M person10 - # ... with 20 more rows + # i 20 more rows --- @@ -119,7 +119,7 @@ 8 vaccine2 person8 9 vaccine3 person9 10 vaccine1 person10 - # ... with 20 more rows + # i 20 more rows --- @@ -234,19 +234,19 @@ Output person1 person10 person11 person12 person13 person14 person15 - vaccine1 1 1 0 0 1 1 0 - vaccine2 1 0 1 1 0 1 1 - vaccine3 0 1 1 1 1 0 1 + vaccine1 1 0 1 1 1 0 1 + vaccine2 1 1 0 1 1 1 0 + vaccine3 0 1 1 0 0 1 1 person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 1 1 0 1 1 1 0 1 - vaccine2 1 0 1 0 1 1 1 0 - vaccine3 0 1 1 1 0 0 1 1 + vaccine1 0 1 1 1 1 0 0 0 + vaccine2 1 1 0 0 0 1 1 1 + vaccine3 1 0 1 1 1 1 1 1 person5 person6 person7 person8 person9 - vaccine1 0 1 1 1 0 - vaccine2 1 1 0 0 1 - vaccine3 1 0 1 1 1 + vaccine1 1 1 0 1 1 + vaccine2 0 1 1 1 0 + vaccine3 1 0 1 0 1 --- @@ -258,19 +258,19 @@ Output person1 person10 person11 person12 person13 person14 person15 - vaccine1 3 3 2 2 3 3 2 - vaccine2 3 2 3 3 2 3 3 - vaccine3 2 3 3 3 3 2 3 + vaccine1 3 2 3 3 3 2 3 + vaccine2 3 3 2 3 3 3 2 + vaccine3 2 3 3 2 2 3 3 person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 3 3 2 3 3 3 2 3 - vaccine2 3 2 3 2 3 3 3 2 - vaccine3 2 3 3 3 2 2 3 3 + vaccine1 2 3 3 3 3 2 2 2 + vaccine2 3 3 2 2 2 3 3 3 + vaccine3 3 2 3 3 3 3 3 3 person5 person6 person7 person8 person9 - vaccine1 2 3 3 3 2 - vaccine2 3 3 2 2 3 - vaccine3 3 2 3 3 3 + vaccine1 3 3 2 3 3 + vaccine2 2 3 3 3 2 + vaccine3 3 2 3 2 3 --- @@ -282,19 +282,19 @@ Output person1 person10 person11 person12 person13 person14 person15 - vaccine1 3 1 2 1 1 2 1 - vaccine2 3 1 1 2 1 1 2 - vaccine3 2 2 1 1 2 1 1 + vaccine1 3 2 1 1 2 1 1 + vaccine2 3 1 2 1 1 2 1 + vaccine3 2 1 1 2 1 1 2 person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 1 2 1 1 1 2 1 1 - vaccine2 1 1 2 1 1 1 2 1 - vaccine3 2 1 1 2 1 1 1 2 + vaccine1 2 1 1 2 1 1 1 2 + vaccine2 1 2 1 1 1 2 1 1 + vaccine3 1 1 2 1 1 1 2 1 person5 person6 person7 person8 person9 - vaccine1 2 1 1 2 1 - vaccine2 1 2 1 1 2 - vaccine3 1 1 2 1 1 + vaccine1 1 1 2 1 1 + vaccine2 2 1 1 2 1 + vaccine3 1 2 1 1 2 --- @@ -305,323 +305,123 @@ table(tab$fert, tab$plot) Output - plot1 plot10 plot100 plot11 plot12 plot13 plot14 plot15 plot16 plot17 - fert1 1 0 0 0 1 0 0 1 0 0 - fert2 1 1 1 0 1 1 0 1 0 0 - fert3 1 0 0 1 0 0 1 0 1 1 - fert4 1 1 0 0 1 1 0 1 0 0 - fert5 1 0 1 1 0 0 1 0 1 1 - fert6 1 0 1 0 0 0 1 0 0 0 - fert7 1 1 0 1 1 1 0 0 1 1 - fert8 1 1 1 1 0 1 1 1 1 1 - - plot18 plot19 plot2 plot20 plot21 plot22 plot23 plot24 plot25 plot26 - fert1 1 1 0 0 1 1 1 0 0 1 - fert2 0 1 1 0 0 0 1 0 1 0 - fert3 0 1 0 1 1 0 0 0 1 0 - fert4 1 1 1 1 0 0 0 1 1 1 - fert5 0 0 0 1 0 1 0 1 0 1 - fert6 1 0 1 1 1 1 0 1 0 0 - fert7 1 0 0 0 1 0 1 1 0 1 - fert8 0 0 0 0 0 1 1 0 1 0 - - plot27 plot28 plot29 plot3 plot30 plot31 plot32 plot33 plot34 plot35 - fert1 0 1 1 0 1 0 1 0 1 0 - fert2 1 0 0 0 0 1 0 1 0 1 - fert3 1 1 0 1 0 1 1 1 0 0 - fert4 0 0 1 1 0 1 0 0 0 1 - fert5 0 1 1 0 1 1 0 1 0 1 - fert6 1 0 1 0 1 0 0 1 1 0 - fert7 0 0 0 1 1 0 1 0 1 1 - fert8 1 1 0 1 0 0 1 0 1 0 - - plot36 plot37 plot38 plot39 plot4 plot40 plot41 plot42 plot43 plot44 - fert1 0 1 1 1 0 1 0 1 0 0 - fert2 0 1 0 0 1 1 0 0 1 0 - fert3 1 0 1 1 0 0 1 1 0 1 - fert4 1 0 1 0 0 1 1 0 0 1 - fert5 1 1 0 1 0 1 1 0 1 0 - fert6 0 0 0 1 1 0 1 0 1 1 - fert7 0 0 1 0 1 0 0 1 0 0 - fert8 1 1 0 0 1 0 0 1 1 1 - - plot45 plot46 plot47 plot48 plot49 plot5 plot50 plot51 plot52 plot53 - fert1 1 0 1 1 0 1 0 0 1 1 - fert2 1 1 0 0 1 1 1 1 1 0 - fert3 0 0 1 0 1 0 1 1 0 1 - fert4 1 1 1 0 1 0 1 0 1 0 - fert5 1 1 0 1 0 0 0 1 0 1 - fert6 0 0 1 0 0 1 1 0 1 0 - fert7 0 1 0 1 0 0 0 1 0 0 - fert8 0 0 0 1 1 1 0 0 0 1 - - plot54 plot55 plot56 plot57 plot58 plot59 plot6 plot60 plot61 plot62 - fert1 0 0 1 1 0 0 1 0 1 1 - fert2 1 1 0 0 1 0 1 0 1 0 - fert3 0 1 0 1 0 1 0 1 0 1 - fert4 1 0 1 0 1 1 0 1 0 1 - fert5 0 1 1 0 1 0 1 0 0 1 - fert6 1 1 0 1 0 1 0 0 1 0 - fert7 1 0 1 0 0 1 1 1 0 0 - fert8 0 0 0 1 1 0 0 1 1 0 - - plot63 plot64 plot65 plot66 plot67 plot68 plot69 plot7 plot70 plot71 - fert1 0 0 0 1 0 1 0 1 0 1 - fert2 1 0 1 0 1 1 0 0 1 1 - fert3 0 0 1 0 0 1 1 0 0 1 - fert4 0 0 0 0 0 0 0 1 1 0 - fert5 1 1 0 0 0 0 1 0 1 0 - fert6 1 1 1 1 1 0 1 1 0 0 - fert7 0 1 1 1 1 1 1 0 1 1 - fert8 1 1 0 1 1 0 0 1 0 0 - - plot72 plot73 plot74 plot75 plot76 plot77 plot78 plot79 plot8 plot80 - fert1 1 1 0 1 0 1 0 1 1 1 - fert2 0 1 1 1 0 0 1 1 0 1 - fert3 0 1 0 1 1 0 1 1 0 0 - fert4 1 0 1 0 1 1 0 0 1 0 - fert5 1 0 0 0 1 0 1 0 1 1 - fert6 0 1 0 0 1 1 0 0 0 1 - fert7 0 0 1 1 0 0 1 0 0 0 - fert8 1 0 1 0 0 1 0 1 1 0 - - plot81 plot82 plot83 plot84 plot85 plot86 plot87 plot88 plot89 plot9 - fert1 0 0 1 1 0 0 0 1 1 0 - fert2 0 0 1 0 1 1 0 0 1 1 - fert3 0 1 1 0 1 0 1 0 1 0 - fert4 1 0 1 1 0 0 1 0 0 1 - fert5 0 1 0 1 0 1 0 1 0 1 - fert6 1 0 0 1 1 1 1 1 0 0 - fert7 1 1 0 0 1 1 0 1 0 0 - fert8 1 1 0 0 0 0 1 0 1 1 - - plot90 plot91 plot92 plot93 plot94 plot95 plot96 plot97 plot98 plot99 - fert1 1 0 1 1 0 1 0 1 0 0 - fert2 0 0 1 0 1 1 0 0 1 0 - fert3 0 1 1 1 0 0 0 1 1 0 - fert4 1 1 0 1 0 0 1 0 1 1 - fert5 0 1 0 0 1 1 0 1 0 0 - fert6 1 0 1 0 1 0 1 0 1 1 - fert7 1 0 0 1 1 0 1 1 0 1 - fert8 0 1 0 0 0 1 1 0 0 1 - ---- - - Code - tab <- design() %>% set_trts(fert = 2, irr = 2) %>% set_units(block = 10, - wplot = nested_in(block, 3), splot = nested_in(wplot, 4)) %>% allot_trts( - fert ~ splot, irr ~ wplot) %>% assign_trts("random", seed = 2) %>% - serve_table() - table(tab$fert, tab$irr, tab$wplot) - Output - , , = wplot1 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot10 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot11 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot12 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot13 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot14 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot15 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot16 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot17 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot18 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot19 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot2 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot20 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot21 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot22 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot23 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot24 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot25 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot26 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot27 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot28 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot29 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot3 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot30 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot4 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot5 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - - , , = wplot6 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot7 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot8 - - - irr1 irr2 - fert1 2 0 - fert2 2 0 - - , , = wplot9 - - - irr1 irr2 - fert1 0 2 - fert2 0 2 - + plot001 plot002 plot003 plot004 plot005 plot006 plot007 plot008 plot009 + fert1 1 1 0 0 0 0 1 1 1 + fert2 1 0 1 1 1 0 0 1 0 + fert3 1 0 0 1 1 0 0 1 1 + fert4 1 1 1 0 0 1 0 0 1 + fert5 1 0 0 0 0 1 1 0 0 + fert6 1 1 1 0 1 1 1 0 1 + fert7 1 0 0 1 0 0 1 1 0 + fert8 1 0 1 1 1 1 0 0 0 + + plot010 plot011 plot012 plot013 plot014 plot015 plot016 plot017 plot018 + fert1 1 1 1 0 1 0 0 0 1 + fert2 0 0 1 1 1 0 1 0 1 + fert3 1 0 0 0 0 1 0 0 1 + fert4 0 1 1 0 1 0 1 1 0 + fert5 1 0 0 1 0 1 1 1 0 + fert6 1 1 0 0 0 1 1 1 0 + fert7 0 1 1 1 1 1 0 0 0 + fert8 0 0 0 1 0 0 0 1 1 + + plot019 plot020 plot021 plot022 plot023 plot024 plot025 plot026 plot027 + fert1 0 1 1 0 1 0 1 1 0 + fert2 0 1 0 0 1 0 1 0 1 + fert3 0 1 1 0 0 1 1 0 1 + fert4 1 0 1 0 1 1 0 0 0 + fert5 0 0 0 1 0 0 0 1 1 + fert6 1 1 1 1 0 0 0 1 0 + fert7 1 0 0 1 1 1 1 1 0 + fert8 1 0 0 1 0 1 0 0 1 + + plot028 plot029 plot030 plot031 plot032 plot033 plot034 plot035 plot036 + fert1 1 1 1 0 0 1 0 0 1 + fert2 1 0 1 0 1 0 1 1 0 + fert3 1 0 0 1 1 0 1 0 0 + fert4 1 1 0 1 0 0 1 1 0 + fert5 0 1 0 0 1 1 1 0 1 + fert6 0 0 1 0 1 0 0 0 0 + fert7 0 1 0 1 0 1 0 1 1 + fert8 0 0 1 1 0 1 0 1 1 + + plot037 plot038 plot039 plot040 plot041 plot042 plot043 plot044 plot045 + fert1 1 0 1 0 1 0 1 1 0 + fert2 1 1 0 1 0 1 0 1 0 + fert3 1 1 0 1 0 0 1 0 1 + fert4 0 1 0 0 1 0 1 1 1 + fert5 0 1 0 0 1 0 0 1 0 + fert6 1 0 1 0 1 1 0 0 0 + fert7 0 0 1 1 0 1 0 0 1 + fert8 0 0 1 1 0 1 1 0 1 + + plot046 plot047 plot048 plot049 plot050 plot051 plot052 plot053 plot054 + fert1 0 1 0 0 1 0 1 0 1 + fert2 1 0 0 0 1 1 0 1 1 + fert3 0 1 1 0 0 0 1 1 0 + fert4 0 1 0 1 0 1 1 0 0 + fert5 1 1 1 1 0 1 0 1 0 + fert6 1 0 0 1 1 0 0 1 1 + fert7 0 0 1 0 1 0 1 0 0 + fert8 1 0 1 1 0 1 0 0 1 + + plot055 plot056 plot057 plot058 plot059 plot060 plot061 plot062 plot063 + fert1 0 0 1 0 1 1 0 0 1 + fert2 0 1 0 0 0 0 1 0 0 + fert3 1 0 1 1 0 0 1 1 1 + fert4 1 0 0 0 0 1 0 1 0 + fert5 0 1 1 1 0 1 0 0 1 + fert6 0 0 1 1 1 0 1 1 0 + fert7 1 1 0 1 1 0 1 1 0 + fert8 1 1 0 0 1 1 0 0 1 + + plot064 plot065 plot066 plot067 plot068 plot069 plot070 plot071 plot072 + fert1 0 1 1 0 0 0 1 1 0 + fert2 1 0 0 1 1 0 1 0 0 + fert3 0 1 0 1 0 1 0 0 1 + fert4 1 1 1 0 0 1 0 1 0 + fert5 0 0 1 1 1 0 0 1 0 + fert6 1 0 0 0 1 1 1 0 1 + fert7 1 0 0 1 1 0 0 1 1 + fert8 0 1 1 0 0 1 1 0 1 + + plot073 plot074 plot075 plot076 plot077 plot078 plot079 plot080 plot081 + fert1 1 0 1 1 0 0 1 1 0 + fert2 0 1 1 1 0 1 0 1 1 + fert3 1 0 1 0 1 0 1 0 1 + fert4 0 1 0 1 1 1 0 0 1 + fert5 1 1 0 1 0 1 0 1 0 + fert6 0 0 0 0 1 1 1 0 1 + fert7 0 1 0 0 1 0 0 1 0 + fert8 1 0 1 0 0 0 1 0 0 + + plot082 plot083 plot084 plot085 plot086 plot087 plot088 plot089 plot090 + fert1 1 0 0 1 0 0 1 1 0 + fert2 1 0 1 0 1 0 0 0 1 + fert3 0 1 1 0 0 0 1 1 1 + fert4 0 1 1 0 1 1 1 0 0 + fert5 0 1 0 1 1 0 0 1 1 + fert6 0 0 1 1 0 1 0 0 0 + fert7 1 0 0 1 0 1 1 0 1 + fert8 1 1 0 0 1 1 0 1 0 + + plot091 plot092 plot093 plot094 plot095 plot096 plot097 plot098 plot099 + fert1 1 1 0 0 0 1 0 0 1 + fert2 0 1 1 0 0 1 1 0 1 + fert3 0 0 0 1 1 1 0 1 0 + fert4 0 0 1 0 1 0 1 0 1 + fert5 1 0 1 1 1 1 0 1 0 + fert6 1 1 0 0 1 0 1 1 0 + fert7 0 0 1 1 0 0 0 1 0 + fert8 1 1 0 1 0 0 1 0 1 + + plot100 + fert1 1 + fert2 0 + fert3 0 + fert4 1 + fert5 0 + fert6 1 + fert7 1 + fert8 0 diff --git a/tests/testthat/_snaps/trts.new.md b/tests/testthat/_snaps/trts.new.md deleted file mode 100644 index 5185536c..00000000 --- a/tests/testthat/_snaps/trts.new.md +++ /dev/null @@ -1,433 +0,0 @@ -# treatments - - Code - design(seed = 1) %>% set_trts(vaccine = 2) - Output - An edibble design - \-vaccine (2 levels) - ---- - - Code - design(seed = 1) %>% set_trts(vaccine = 2, sex = 2) - Output - An edibble design - +-vaccine (2 levels) - \-sex (2 levels) - ---- - - Code - design(seed = 1) %>% set_units(person = 5) %>% set_trts(vaccine = 2, sex = 2) - Output - An edibble design - +-person (5 levels) - +-vaccine (2 levels) - \-sex (2 levels) - ---- - - Code - design(seed = 1) %>% set_trts(vaccine = 2, sex = 2) %>% set_units(person = 5) - Output - An edibble design - +-vaccine (2 levels) - +-sex (2 levels) - \-person (5 levels) - ---- - - Code - design() %>% set_trts(vaccine = 3, sex = 2) %>% set_units(person = 30) %>% - allot_trts(~person) %>% assign_trts("systematic") %>% serve_table() - Output - # An edibble design - # An edibble: 30 x 3 - vaccine sex person - - 1 vaccine1 sex1 person1 - 2 vaccine2 sex1 person2 - 3 vaccine3 sex1 person3 - 4 vaccine1 sex2 person4 - 5 vaccine2 sex2 person5 - 6 vaccine3 sex2 person6 - 7 vaccine1 sex1 person7 - 8 vaccine2 sex1 person8 - 9 vaccine3 sex1 person9 - 10 vaccine1 sex2 person10 - # i 20 more rows - ---- - - Code - design() %>% set_trts(vaccine = 3, sex = c("F", "M")) %>% set_units(person = 30) %>% - allot_trts(vaccine:sex ~ person) %>% assign_trts("systematic") %>% - serve_table() - Output - # An edibble design - # An edibble: 30 x 3 - vaccine sex person - - 1 vaccine1 F person1 - 2 vaccine2 F person2 - 3 vaccine3 F person3 - 4 vaccine1 M person4 - 5 vaccine2 M person5 - 6 vaccine3 M person6 - 7 vaccine1 F person7 - 8 vaccine2 F person8 - 9 vaccine3 F person9 - 10 vaccine1 M person10 - # i 20 more rows - ---- - - Code - design() %>% set_trts(vaccine = 3, sex = c("F", "M")) %>% set_units(person = 30) %>% - allot_trts(vaccine ~ person, sex ~ person) %>% assign_trts("systematic") %>% - serve_table() - Output - # An edibble design - # An edibble: 30 x 3 - vaccine sex person - - 1 vaccine1 F person1 - 2 vaccine2 M person2 - 3 vaccine3 F person3 - 4 vaccine1 M person4 - 5 vaccine2 F person5 - 6 vaccine3 M person6 - 7 vaccine1 F person7 - 8 vaccine2 M person8 - 9 vaccine3 F person9 - 10 vaccine1 M person10 - # i 20 more rows - ---- - - Code - design() %>% set_trts(vaccine = 3) %>% set_units(person = 30) %>% allot_trts( - vaccine ~ person) %>% assign_trts("systematic") %>% serve_table() - Output - # An edibble design - # An edibble: 30 x 2 - vaccine person - - 1 vaccine1 person1 - 2 vaccine2 person2 - 3 vaccine3 person3 - 4 vaccine1 person4 - 5 vaccine2 person5 - 6 vaccine3 person6 - 7 vaccine1 person7 - 8 vaccine2 person8 - 9 vaccine3 person9 - 10 vaccine1 person10 - # i 20 more rows - ---- - - Code - design() %>% set_trts(vaccine = 3) %>% set_units(person = 5) %>% allot_trts( - vaccine ~ person) %>% assign_trts("systematic-random", seed = 2) %>% - serve_table() - Output - # An edibble design - # An edibble: 5 x 2 - vaccine person - - 1 vaccine1 person1 - 2 vaccine3 person2 - 3 vaccine2 person3 - 4 vaccine1 person4 - 5 vaccine3 person5 - ---- - - Code - design() %>% set_trts(vaccine = 3) %>% set_units(person = 5) %>% allot_trts( - vaccine ~ person) %>% assign_trts("random", seed = 3) %>% serve_table() - Output - # An edibble design - # An edibble: 5 x 2 - vaccine person - - 1 vaccine3 person1 - 2 vaccine2 person2 - 3 vaccine2 person3 - 4 vaccine1 person4 - 5 vaccine3 person5 - ---- - - Code - tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( - person, 3)) %>% allot_trts(vaccine ~ person) %>% assign_trts("random", seed = 2) %>% - serve_table() - table(tab$vaccine, tab$person) - Output - - person1 person10 person11 person12 person13 person14 person15 - vaccine1 0 3 0 0 3 0 0 - vaccine2 0 0 0 3 0 3 0 - vaccine3 3 0 3 0 0 0 3 - - person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 3 0 0 0 3 3 3 0 - vaccine2 0 0 3 3 0 0 0 3 - vaccine3 0 3 0 0 0 0 0 0 - - person5 person6 person7 person8 person9 - vaccine1 0 0 0 3 0 - vaccine2 3 3 0 0 0 - vaccine3 0 0 3 0 3 - ---- - - Code - tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( - person, 3)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2, - constrain = NULL) %>% serve_table() - table(tab$vaccine, tab$person) - Output - - person1 person10 person11 person12 person13 person14 person15 - vaccine1 1 2 0 1 2 2 0 - vaccine2 0 1 2 2 0 0 2 - vaccine3 2 0 1 0 1 1 1 - - person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 0 2 3 0 1 1 1 1 - vaccine2 1 1 0 1 1 2 1 2 - vaccine3 2 0 0 2 1 0 1 0 - - person5 person6 person7 person8 person9 - vaccine1 1 2 0 0 0 - vaccine2 1 1 1 1 0 - vaccine3 1 0 2 2 3 - ---- - - Code - tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( - person, 3)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2) %>% - serve_table() - table(tab$vaccine, tab$person) - Output - - person1 person10 person11 person12 person13 person14 person15 - vaccine1 1 1 1 1 1 1 1 - vaccine2 1 1 1 1 1 1 1 - vaccine3 1 1 1 1 1 1 1 - - person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 1 1 1 1 1 1 1 1 - vaccine2 1 1 1 1 1 1 1 1 - vaccine3 1 1 1 1 1 1 1 1 - - person5 person6 person7 person8 person9 - vaccine1 1 1 1 1 1 - vaccine2 1 1 1 1 1 - vaccine3 1 1 1 1 1 - ---- - - Code - tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( - person, 2)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2) %>% - serve_table() - table(tab$vaccine, tab$person) - Output - - person1 person10 person11 person12 person13 person14 person15 - vaccine1 1 0 1 1 1 0 1 - vaccine2 1 1 0 1 1 1 0 - vaccine3 0 1 1 0 0 1 1 - - person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 0 1 1 1 1 0 0 0 - vaccine2 1 1 0 0 0 1 1 1 - vaccine3 1 0 1 1 1 1 1 1 - - person5 person6 person7 person8 person9 - vaccine1 1 1 0 1 1 - vaccine2 0 1 1 1 0 - vaccine3 1 0 1 0 1 - ---- - - Code - tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( - person, 8)) %>% allot_trts(vaccine ~ blood) %>% assign_trts("random", seed = 2) %>% - serve_table() - table(tab$vaccine, tab$person) - Output - - person1 person10 person11 person12 person13 person14 person15 - vaccine1 3 2 3 3 3 2 3 - vaccine2 3 3 2 3 3 3 2 - vaccine3 2 3 3 2 2 3 3 - - person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 2 3 3 3 3 2 2 2 - vaccine2 3 3 2 2 2 3 3 3 - vaccine3 3 2 3 3 3 3 3 3 - - person5 person6 person7 person8 person9 - vaccine1 3 3 2 3 3 - vaccine2 2 3 3 3 2 - vaccine3 3 2 3 2 3 - ---- - - Code - tab <- design() %>% set_trts(vaccine = 3) %>% set_units(person = 20, blood = nested_in( - person, 1 ~ 8, 2 ~ 3, . ~ 4)) %>% allot_trts(vaccine ~ blood) %>% assign_trts( - "random", seed = 2) %>% serve_table() - table(tab$vaccine, tab$person) - Output - - person1 person10 person11 person12 person13 person14 person15 - vaccine1 3 2 1 1 2 1 1 - vaccine2 3 1 2 1 1 2 1 - vaccine3 2 1 1 2 1 1 2 - - person16 person17 person18 person19 person2 person20 person3 person4 - vaccine1 2 1 1 2 1 1 1 2 - vaccine2 1 2 1 1 1 2 1 1 - vaccine3 1 1 2 1 1 1 2 1 - - person5 person6 person7 person8 person9 - vaccine1 1 1 2 1 1 - vaccine2 2 1 1 2 1 - vaccine3 1 2 1 1 2 - ---- - - Code - tab <- design() %>% set_trts(fert = 8) %>% set_units(site = 10, plot = nested_in( - site, 10), sample = nested_in(plot, 1 ~ 8, 2 ~ 3, . ~ 4)) %>% allot_trts( - fert ~ sample) %>% assign_trts("random", seed = 2) %>% serve_table() - table(tab$fert, tab$plot) - Output - - plot001 plot002 plot003 plot004 plot005 plot006 plot007 plot008 plot009 - fert1 1 1 0 0 0 0 1 1 1 - fert2 1 0 1 1 1 0 0 1 0 - fert3 1 0 0 1 1 0 0 1 1 - fert4 1 1 1 0 0 1 0 0 1 - fert5 1 0 0 0 0 1 1 0 0 - fert6 1 1 1 0 1 1 1 0 1 - fert7 1 0 0 1 0 0 1 1 0 - fert8 1 0 1 1 1 1 0 0 0 - - plot010 plot011 plot012 plot013 plot014 plot015 plot016 plot017 plot018 - fert1 1 1 1 0 1 0 0 0 1 - fert2 0 0 1 1 1 0 1 0 1 - fert3 1 0 0 0 0 1 0 0 1 - fert4 0 1 1 0 1 0 1 1 0 - fert5 1 0 0 1 0 1 1 1 0 - fert6 1 1 0 0 0 1 1 1 0 - fert7 0 1 1 1 1 1 0 0 0 - fert8 0 0 0 1 0 0 0 1 1 - - plot019 plot020 plot021 plot022 plot023 plot024 plot025 plot026 plot027 - fert1 0 1 1 0 1 0 1 1 0 - fert2 0 1 0 0 1 0 1 0 1 - fert3 0 1 1 0 0 1 1 0 1 - fert4 1 0 1 0 1 1 0 0 0 - fert5 0 0 0 1 0 0 0 1 1 - fert6 1 1 1 1 0 0 0 1 0 - fert7 1 0 0 1 1 1 1 1 0 - fert8 1 0 0 1 0 1 0 0 1 - - plot028 plot029 plot030 plot031 plot032 plot033 plot034 plot035 plot036 - fert1 1 1 1 0 0 1 0 0 1 - fert2 1 0 1 0 1 0 1 1 0 - fert3 1 0 0 1 1 0 1 0 0 - fert4 1 1 0 1 0 0 1 1 0 - fert5 0 1 0 0 1 1 1 0 1 - fert6 0 0 1 0 1 0 0 0 0 - fert7 0 1 0 1 0 1 0 1 1 - fert8 0 0 1 1 0 1 0 1 1 - - plot037 plot038 plot039 plot040 plot041 plot042 plot043 plot044 plot045 - fert1 1 0 1 0 1 0 1 1 0 - fert2 1 1 0 1 0 1 0 1 0 - fert3 1 1 0 1 0 0 1 0 1 - fert4 0 1 0 0 1 0 1 1 1 - fert5 0 1 0 0 1 0 0 1 0 - fert6 1 0 1 0 1 1 0 0 0 - fert7 0 0 1 1 0 1 0 0 1 - fert8 0 0 1 1 0 1 1 0 1 - - plot046 plot047 plot048 plot049 plot050 plot051 plot052 plot053 plot054 - fert1 0 1 0 0 1 0 1 0 1 - fert2 1 0 0 0 1 1 0 1 1 - fert3 0 1 1 0 0 0 1 1 0 - fert4 0 1 0 1 0 1 1 0 0 - fert5 1 1 1 1 0 1 0 1 0 - fert6 1 0 0 1 1 0 0 1 1 - fert7 0 0 1 0 1 0 1 0 0 - fert8 1 0 1 1 0 1 0 0 1 - - plot055 plot056 plot057 plot058 plot059 plot060 plot061 plot062 plot063 - fert1 0 0 1 0 1 1 0 0 1 - fert2 0 1 0 0 0 0 1 0 0 - fert3 1 0 1 1 0 0 1 1 1 - fert4 1 0 0 0 0 1 0 1 0 - fert5 0 1 1 1 0 1 0 0 1 - fert6 0 0 1 1 1 0 1 1 0 - fert7 1 1 0 1 1 0 1 1 0 - fert8 1 1 0 0 1 1 0 0 1 - - plot064 plot065 plot066 plot067 plot068 plot069 plot070 plot071 plot072 - fert1 0 1 1 0 0 0 1 1 0 - fert2 1 0 0 1 1 0 1 0 0 - fert3 0 1 0 1 0 1 0 0 1 - fert4 1 1 1 0 0 1 0 1 0 - fert5 0 0 1 1 1 0 0 1 0 - fert6 1 0 0 0 1 1 1 0 1 - fert7 1 0 0 1 1 0 0 1 1 - fert8 0 1 1 0 0 1 1 0 1 - - plot073 plot074 plot075 plot076 plot077 plot078 plot079 plot080 plot081 - fert1 1 0 1 1 0 0 1 1 0 - fert2 0 1 1 1 0 1 0 1 1 - fert3 1 0 1 0 1 0 1 0 1 - fert4 0 1 0 1 1 1 0 0 1 - fert5 1 1 0 1 0 1 0 1 0 - fert6 0 0 0 0 1 1 1 0 1 - fert7 0 1 0 0 1 0 0 1 0 - fert8 1 0 1 0 0 0 1 0 0 - - plot082 plot083 plot084 plot085 plot086 plot087 plot088 plot089 plot090 - fert1 1 0 0 1 0 0 1 1 0 - fert2 1 0 1 0 1 0 0 0 1 - fert3 0 1 1 0 0 0 1 1 1 - fert4 0 1 1 0 1 1 1 0 0 - fert5 0 1 0 1 1 0 0 1 1 - fert6 0 0 1 1 0 1 0 0 0 - fert7 1 0 0 1 0 1 1 0 1 - fert8 1 1 0 0 1 1 0 1 0 - - plot091 plot092 plot093 plot094 plot095 plot096 plot097 plot098 plot099 - fert1 1 1 0 0 0 1 0 0 1 - fert2 0 1 1 0 0 1 1 0 1 - fert3 0 0 0 1 1 1 0 1 0 - fert4 0 0 1 0 1 0 1 0 1 - fert5 1 0 1 1 1 1 0 1 0 - fert6 1 1 0 0 1 0 1 1 0 - fert7 0 0 1 1 0 0 0 1 0 - fert8 1 1 0 1 0 0 1 0 1 - - plot100 - fert1 1 - fert2 0 - fert3 0 - fert4 1 - fert5 0 - fert6 1 - fert7 1 - fert8 0 - diff --git a/tests/testthat/test-trts.R b/tests/testthat/test-trts.R index 3c2a342e..35cccee9 100644 --- a/tests/testthat/test-trts.R +++ b/tests/testthat/test-trts.R @@ -69,7 +69,7 @@ test_that("treatments", { sex = c("F", "M")) %>% set_units(person = 30) %>% allot_trts(vaccine ~ person, - sex ~ person) %>% + sex ~ person) %>% assign_trts("systematic") %>% serve_table() }) diff --git a/tests/testthat/test-units.R b/tests/testthat/test-units.R index b899130a..bb7c8249 100644 --- a/tests/testthat/test-units.R +++ b/tests/testthat/test-units.R @@ -1,5 +1,4 @@ test_that("set_units", { - # FIXME expect_snapshot({ design(title = "unlinked units") %>% From 027f539cb4a1902b760047133ddd7ad344142594 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 13 Aug 2023 20:51:41 -0400 Subject: [PATCH 14/83] fix issue with permute parent one --- R/trts.R | 8 +- tests/testthat/_snaps/trts.md | 220 ++++++++++++++++++++++++++++++++++ 2 files changed, 224 insertions(+), 4 deletions(-) diff --git a/R/trts.R b/R/trts.R index d3f69ce8..89775420 100644 --- a/R/trts.R +++ b/R/trts.R @@ -103,9 +103,9 @@ permute_parent_one_alg <- function(prov, vid, udf, ntrts) { permute_parent_one <- function(prov, vid, udf, ntrts) { - gparent <- prov$fct_names(vid) - blocksizes <- as.data.frame(table(table(udf[[gparent]]))) + blocksizes <- as.data.frame(table(table(udf[[as.character(vid)]]))) blocksizes$size <- as.numeric(as.character(blocksizes$Var1)) + for(isize in seq(nrow(blocksizes))) { if(blocksizes$size[isize] <= ntrts) { comb <- utils::combn(ntrts, blocksizes$size[isize]) @@ -120,13 +120,13 @@ permute_parent_one <- function(prov, vid, udf, ntrts) { blocksizes$select[isize] <- list(sample(rep(sample(ncol(comb)), length.out = blocksizes$Freq[isize]))) } blocksizes$wselect <- blocksizes$select - gpar_tab <- as.data.frame(table(udf[[gparent]])) + gpar_tab <- as.data.frame(table(udf[[as.character(vid)]])) out <- vector("integer", length = nrow(udf)) for(ianc in seq(nrow(gpar_tab))) { imatch <- which(blocksizes$size == gpar_tab$Freq[ianc]) iselect <- blocksizes$wselect[imatch][[1]][1] blocksizes$wselect[imatch] <- list(blocksizes$wselect[imatch][[1]][-1]) - out[as.character(udf[[gparent]])==as.character(gpar_tab$Var1[ianc])] <- sample(blocksizes$rows[imatch][[1]][,iselect]) + out[as.character(udf[[as.character(vid)]])==as.character(gpar_tab$Var1[ianc])] <- sample(blocksizes$rows[imatch][[1]][,iselect]) } out } diff --git a/tests/testthat/_snaps/trts.md b/tests/testthat/_snaps/trts.md index 0f9e4a50..fcbbf98c 100644 --- a/tests/testthat/_snaps/trts.md +++ b/tests/testthat/_snaps/trts.md @@ -425,3 +425,223 @@ fert7 1 fert8 0 +--- + + Code + tab <- design() %>% set_trts(fert = 2, irr = 2) %>% set_units(block = 10, + wplot = nested_in(block, 3), splot = nested_in(wplot, 4)) %>% allot_trts( + fert ~ splot, irr ~ wplot) %>% assign_trts("random", seed = 2) %>% + serve_table() + table(tab$fert, tab$irr, tab$wplot) + Output + , , = wplot01 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot02 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot03 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot04 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot05 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot06 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot07 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot08 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot09 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot10 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot11 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot12 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot13 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot14 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot15 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot16 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot17 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot18 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot19 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot20 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot21 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot22 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot23 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot24 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot25 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot26 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + , , = wplot27 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot28 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot29 + + + irr1 irr2 + fert1 2 0 + fert2 2 0 + + , , = wplot30 + + + irr1 irr2 + fert1 0 2 + fert2 0 2 + + From fc88097e3a12907e04908c6c8d8dde2f217f1bb7 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 13 Aug 2023 21:35:28 -0400 Subject: [PATCH 15/83] error on fail to produce table --- R/serve.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/serve.R b/R/serve.R index 66f5c72b..8d3d3dfc 100644 --- a/R/serve.R +++ b/R/serve.R @@ -8,6 +8,7 @@ #' #' @inheritParams set_units #' @param use_labels To show the labels instead of names. +#' @param fail What to do when failing to convert graph to table. #' @return An `edbl` data frame with columns defined by vertices and #' rows displayed only if the vertices are connected and reconcile for output. #' @family user-facing functions @@ -19,11 +20,14 @@ #' assign_trts("random", seed = 521) %>% #' serve_table() #' @export -serve_table <- function(.edibble, use_labels = FALSE, ..., .record = TRUE) { +serve_table <- function(.edibble, use_labels = FALSE, fail = c("error", "warn", "ignore"), .record = TRUE) { prov <- activate_provenance(.edibble) + fail <- match.arg(fail) if(.record) prov$record_step() if(!prov$is_connected) { + if(fail == "error") abort("The graph cannot be converted to a table format.") + if(fail == "warn") warn("The graph cannot be converted to a table format.") lout <- serve_vars_not_reconciled(prov) } else { roles <- prov$fct_role() From 250c847447d461163f5e49dbb8b10ca0080c37d2 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 13 Aug 2023 21:36:03 -0400 Subject: [PATCH 16/83] allot_table now recorded instead of sub functions --- R/allot.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/R/allot.R b/R/allot.R index a4f40d4e..b19995f4 100644 --- a/R/allot.R +++ b/R/allot.R @@ -49,10 +49,10 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { prov$trt_exists() tids <- prov$trt_ids } - prov$append_fct_edges(from = tids, to = uid, group = ialloc, type = "allot") } + des$graph <- prov$get_graph() if(is_edibble_table(.edibble)) { @@ -166,9 +166,12 @@ allot_units <- function(.edibble, ..., .record = TRUE) { #' and `serve_table()`. #' #' @export -allot_table <- function(.edibble, ..., order = "random", seed = NULL, constrain = nesting_structure(.edibble)) { +allot_table <- function(.edibble, ..., order = "random", seed = NULL, constrain = nesting_structure(.edibble), .record = TRUE) { + prov <- activate_provenance(.edibble) + if(.record) prov$record_step() + .edibble %>% - allot_trts(...) %>% - assign_trts(order = order, seed = seed, constrain = constrain) %>% - serve_table() + allot_trts(..., .record = FALSE) %>% + assign_trts(order = order, seed = seed, constrain = constrain, .record = FALSE) %>% + serve_table(.record = FALSE) } From e27de548e92d6d59b0a5034f895b27e0e9baa455 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 13 Aug 2023 21:36:20 -0400 Subject: [PATCH 17/83] fix issue of disappearing allotment --- R/assign.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/assign.R b/R/assign.R index 1e6e6fe3..444e8dd0 100644 --- a/R/assign.R +++ b/R/assign.R @@ -37,10 +37,10 @@ #' @export assign_trts <- function(.design, order = "random", seed = NULL, constrain = nesting_structure(.design), ..., .record = TRUE) { not_edibble(.design) + force(constrain) # evaluate this now rather than later prov <- activate_provenance(.design) if(.record) prov$record_step() - prov$save_seed(seed) fedges <- prov$fct_edges From 31a381f33886255afaa8a7d9685f670ae76d5b04 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 13 Aug 2023 21:36:35 -0400 Subject: [PATCH 18/83] update record track internal --- R/provenance.R | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/R/provenance.R b/R/provenance.R index 6fb7b295..3302fbef 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -52,14 +52,14 @@ Provenance <- R6::R6Class("Provenance", }, reactivate = function(des, overwrite = c("graph", "anatomy", "recipe")) { - private$record_track_internal() + #private$record_track_internal() for(obj in overwrite) { private[[obj]] <- des[[obj]] } }, deactivate = function(delete = c("graph", "anatomy", "recipe")) { - private$record_track_internal() + #private$record_track_internal() for(obj in delete) { private[[obj]] <- NULL } @@ -395,6 +395,7 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Given node data, append the factor nodes append_fct_nodes = function(name, role, attrs = NULL) { + private$record_track_internal() n <- length(name) role <- vctrs::vec_recycle(role, n) data <- tibble::tibble(id = private$fct_new_id(n = n), @@ -408,6 +409,7 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Given node data, append the level nodes append_lvl_nodes = function(value, attrs = NULL, fid = NULL) { + private$record_track_internal() lnodes <- self$lvl_nodes id <- private$lvl_new_id(n = length(value)) data <- tibble::tibble(id = id, value = value, attrs = attrs) @@ -426,6 +428,7 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Given edge data, append the factor edges append_fct_edges = function(from, to, type = NULL, group = NULL, attrs = NULL) { + private$record_track_internal() self$fct_edges <- rbind_(self$fct_edges, tibble::tibble(from = from, to = to, type = type, @@ -436,6 +439,7 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Given edge data, append the level edges append_lvl_edges = function(from, to, attrs = NULL) { + private$record_track_internal() self$lvl_edges <- rbind_(self$lvl_edges, tibble::tibble(from = from, to = to, attrs = attrs)) @@ -482,6 +486,8 @@ Provenance <- R6::R6Class("Provenance", lnodes <- self$lvl_nodes ledges <- self$lvl_edges + + serve_trt = function(fid) { # linked unit - # each treatment factor should only be applied to a single unit factor From faadf9768c9e0661c3cc4514ffd584653094f545 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 13 Aug 2023 21:36:52 -0400 Subject: [PATCH 19/83] update serve test --- tests/testthat/_snaps/serve.md | 44 ++++++++---------------------- tests/testthat/_snaps/serve.new.md | 40 --------------------------- tests/testthat/test-serve.R | 19 ++++++------- tests/testthat/test-trts.R | 1 - 4 files changed, 20 insertions(+), 84 deletions(-) delete mode 100644 tests/testthat/_snaps/serve.new.md diff --git a/tests/testthat/_snaps/serve.md b/tests/testthat/_snaps/serve.md index 0a3a3807..a658f86f 100644 --- a/tests/testthat/_snaps/serve.md +++ b/tests/testthat/_snaps/serve.md @@ -1,17 +1,7 @@ # serve Code - design(name = "unlinked units with table") %>% set_units(block = 3, plot = 2) %>% - serve_table() - Output - # unlinked units with table - # An edibble: 0 x 2 - # ... with 2 variables: block , plot - ---- - - Code - design(name = "one unit") %>% set_units(block = 3) %>% serve_table() + design(title = "one unit") %>% set_units(block = 3) %>% serve_table() Output # one unit # An edibble: 3 x 1 @@ -24,7 +14,7 @@ --- Code - design(name = "serve nested units") %>% set_units(block = 3, plot = nested_in( + design(title = "serve nested units") %>% set_units(block = 3, plot = nested_in( block, 2)) %>% serve_table() Output # serve nested units @@ -38,18 +28,6 @@ 5 block3 plot5 6 block3 plot6 ---- - - Code - design() %>% set_trts(vaccine = c("AZ", "M", "P")) %>% serve_table() - Output - # An edibble: 3 x 1 - vaccine - - 1 AZ - 2 M - 3 P - --- Code @@ -60,15 +38,15 @@ # An edibble: 13 x 5 site row col plot trt - 1 site1 row1 col1 plot1 A - 2 site1 row2 col1 plot2 B - 3 site1 row3 col1 plot3 A - 4 site1 row1 col2 plot4 B - 5 site1 row2 col2 plot5 A - 6 site1 row3 col2 plot6 B - 7 site1 row1 col3 plot7 A - 8 site1 row2 col3 plot8 B - 9 site1 row3 col3 plot9 A + 1 site1 row1 col1 plot01 A + 2 site1 row2 col1 plot02 B + 3 site1 row3 col1 plot03 A + 4 site1 row1 col2 plot04 B + 5 site1 row2 col2 plot05 A + 6 site1 row3 col2 plot06 B + 7 site1 row1 col3 plot07 A + 8 site1 row2 col3 plot08 B + 9 site1 row3 col3 plot09 A 10 site2 row4 col4 plot10 A 11 site2 row5 col4 plot11 B 12 site2 row4 col5 plot12 B diff --git a/tests/testthat/_snaps/serve.new.md b/tests/testthat/_snaps/serve.new.md deleted file mode 100644 index 735aed3c..00000000 --- a/tests/testthat/_snaps/serve.new.md +++ /dev/null @@ -1,40 +0,0 @@ -# serve - - Code - design(name = "unlinked units with table") %>% set_units(block = 3, plot = 2) %>% - serve_table() - Output - # An edibble design - # An edibble: 0 x 2 - # i 2 variables: block , plot - ---- - - Code - design(name = "one unit") %>% set_units(block = 3) %>% serve_table() - Output - # An edibble design - # An edibble: 3 x 1 - block - - 1 block1 - 2 block2 - 3 block3 - ---- - - Code - design(name = "serve nested units") %>% set_units(block = 3, plot = nested_in( - block, 2)) %>% serve_table() - Output - # An edibble design - # An edibble: 6 x 2 - block plot - - 1 block1 plot1 - 2 block1 plot2 - 3 block2 plot3 - 4 block2 plot4 - 5 block3 plot5 - 6 block3 plot6 - diff --git a/tests/testthat/test-serve.R b/tests/testthat/test-serve.R index 1dc49732..97d121d3 100644 --- a/tests/testthat/test-serve.R +++ b/tests/testthat/test-serve.R @@ -1,7 +1,6 @@ test_that("serve", { - # FIXME - expect_snapshot({ - design(name = "unlinked units with table") %>% + expect_error({ + design(title = "unlinked units with table") %>% set_units(block = 3, plot = 2) %>% serve_table() @@ -10,27 +9,27 @@ test_that("serve", { # The cut-off seems to have only happened for when the title was "unlinked units with table" # and the ANSI styling was cut expect_equal({ - design(name = "unlinked units with table") %>% + design(title = "unlinked units with table") %>% set_units(block = 3, plot = 2) %>% - serve_table() + serve_table(fail = "ignore") }, data.frame(block = character(), plot = character()), ignore_attr = TRUE) expect_snapshot({ - design(name = "one unit") %>% + design(title = "one unit") %>% set_units(block = 3) %>% serve_table() }) expect_equal({ - design(name = "one unit") %>% + design(title = "one unit") %>% set_units(block = 3) %>% serve_table() }, data.frame(block = c("block1", "block2", "block3")), ignore_attr = TRUE) expect_snapshot({ - design(name = "serve nested units") %>% + design(title = "serve nested units") %>% set_units(block = 3, plot = nested_in(block, 2)) %>% serve_table() @@ -55,10 +54,10 @@ test_that("serve", { expect_equal(ncol(tabs[[3]]), 3) expect_equal(as.character(tabs[[3]]$site), rep(c("site1", "site2"), each = 3 * 2)) expect_equal(as.character(tabs[[3]]$block), rep(paste0("block", 1:6), each = 2)) - expect_equal(as.character(tabs[[3]]$plot), paste0("plot", 1:12)) + expect_equal(as.character(tabs[[3]]$plot), sprintf("plot%.2d", 1:12)) - expect_snapshot({ + expect_error({ design() %>% set_trts(vaccine = c("AZ", "M", "P")) %>% serve_table() diff --git a/tests/testthat/test-trts.R b/tests/testthat/test-trts.R index 35cccee9..f2282c19 100644 --- a/tests/testthat/test-trts.R +++ b/tests/testthat/test-trts.R @@ -1,5 +1,4 @@ test_that("treatments", { - # FIXME expect_snapshot({ design(seed = 1) %>% set_trts(vaccine = 2) From 93e6a19f6954218895ff3d98d405ca720d4604cb Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:23:33 -0400 Subject: [PATCH 20/83] make handy return function --- R/allot.R | 17 +---------------- 1 file changed, 1 insertion(+), 16 deletions(-) diff --git a/R/allot.R b/R/allot.R index b19995f4..86574133 100644 --- a/R/allot.R +++ b/R/allot.R @@ -52,22 +52,7 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { prov$append_fct_edges(from = tids, to = uid, group = ialloc, type = "allot") } - - des$graph <- prov$get_graph() - - if(is_edibble_table(.edibble)) { - if(length(trts)==0) { - trts <- prov$trt_names() - } - for(atrt in trts) { - prov$append_lvl_edges(from = prov$lvl_id(name = as.character(.edibble[[atrt]])), - to = prov$lvl_id(name = as.character(.edibble[[unit]]))) - } - attr(.edibble, "design") <- des - .edibble - } else { - des - } + return_edibble_with_graph(.edibble, prov) } From 40e32b9865b5bce43eceaa1c51dac3d75c921e1a Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:23:50 -0400 Subject: [PATCH 21/83] rename .design to .edibble --- R/assign.R | 50 +++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/R/assign.R b/R/assign.R index 444e8dd0..1f9f06db 100644 --- a/R/assign.R +++ b/R/assign.R @@ -2,7 +2,7 @@ #' #' This function assigns specific treatment or unit levels to actual units. #' -#' @param .design An edibble design which should have units, treatments and allotment defined. +#' @param .edibble An edibble design which should have units, treatments and allotment defined. #' @param order A character vector signifying the apportion of treatments to units. #' The value should be either "random", "systematic", "systematic-random" or a class name corresponding to the algorithm for order_trts(). #' "random" allocates the treatment randomly to units based on specified allotment with restrictions @@ -35,11 +35,11 @@ #' serve_table() #' @return An edibble design. #' @export -assign_trts <- function(.design, order = "random", seed = NULL, constrain = nesting_structure(.design), ..., .record = TRUE) { - not_edibble(.design) +assign_trts <- function(.edibble, order = "random", seed = NULL, constrain = nesting_structure(.edibble), ..., .record = TRUE) { + not_edibble(.edibble) force(constrain) # evaluate this now rather than later - prov <- activate_provenance(.design) + prov <- activate_provenance(.edibble) if(.record) prov$record_step() prov$save_seed(seed) @@ -95,31 +95,32 @@ assign_trts <- function(.design, order = "random", seed = NULL, constrain = nest } } - .design$graph <- prov$get_graph() - .design$assignment <- order - .design + return_edibble_with_graph(.edibble, prov) + + # .edibble$assignment <- order } #' @rdname assign #' @export -assign_units <- function(.design, order = "random", seed = NULL, constrain = nesting_structure(.design), ..., .record = TRUE) { - not_edibble(.design) - - if(.record) record_step() - - save_seed(seed) - prov <- activate_provenance(.design) +assign_units <- function(.edibble, order = "random", seed = NULL, constrain = nesting_structure(.edibble), ..., .record = TRUE) { + not_edibble(.edibble) + prov <- activate_provenance(prov) + if(.record) prov$record_step() + prov$save_seed(seed) + # FIXME: check - for(ialloc in seq_along(.design$allotment$units)) { - lhs <- all.vars(f_lhs(.design$allotment$units[[ialloc]])) - rhs <- all.vars(f_rhs(.design$allotment$units[[ialloc]])) + for(ialloc in seq_along(.edibble$allotment$units)) { + lhs <- all.vars(f_lhs(.edibble$allotment$units[[ialloc]])) + rhs <- all.vars(f_rhs(.edibble$allotment$units[[ialloc]])) lnodes <- prov$lvl_nodes - lhs_id <- lnodes[[prov$fct_id(name = lhs)]]$id - udf <- as.data.frame(serve_units(select_units(prov, rhs))) - udf <- udf[rhs] + lid <- prov$fct_id(name = lhs) + rid <- prov$fct_id(name = rhs) + lhs_id <- lnodes[[lid]]$id + udf <- as.data.frame(prov$serve_units(id = lid, return = "id")) + udf <- udf[rid] small_df <- data.frame(lhs = lhs_id) permutation <- switch(order, "systematic" = rep(1:nrow(small_df), length.out = nrow(udf)), @@ -143,14 +144,13 @@ assign_units <- function(.design, order = "random", seed = NULL, constrain = nes tout <- small_df[permutation, , drop = FALSE] - browser() for(itvar in seq_along(tout)) { - prov$append_lvl_edges(data.frame(from = tout[[itvar]], - to = prov$lvl_id(udf[[rhs[length(rhs)]]]), - alloc = ialloc)) + prov$append_lvl_edges(from = tout[[itvar]], + to = udf[[rhs[length(rhs)]]], + group = ialloc) } } - prov$design + return_edibble_with_graph(.edibble, prov) } From fe9ae21bfb9c9241def2a8dbbd9cce041f58ad8f Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:24:04 -0400 Subject: [PATCH 22/83] add validation in provenance object --- R/provenance.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/R/provenance.R b/R/provenance.R index 3302fbef..6a746362 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -51,6 +51,11 @@ Provenance <- R6::R6Class("Provenance", private$name <- name }, + set_validation = function(validation, type) { + private$record_track_internal() + private$validation[[type]] <- validation + } + reactivate = function(des, overwrite = c("graph", "anatomy", "recipe")) { #private$record_track_internal() for(obj in overwrite) { @@ -510,7 +515,9 @@ Provenance <- R6::R6Class("Provenance", serve_rcrds = function(id = NULL, return = c("id", "value")) { + id <- id %||% self$rcrd_ids + return <- match.arg(return) out <- lapply(id, function(rid) { uid <- self$fct_id_child(id = rid, role = "edbl_unit") # should be only a single unit factor @@ -574,6 +581,10 @@ Provenance <- R6::R6Class("Provenance", private$title }, + get_validation = function(type) { + private$validation[[type]] + }, + get_trail = function() { private$trail[-length(private$trail)] }, @@ -720,6 +731,7 @@ Provenance <- R6::R6Class("Provenance", anatomy = NULL, recipe = NULL, graph = NULL, + validation = list(rcrds = NULL), # table should only contain the id of levels and factors table = list(units = NULL, trts = NULL, rcrds = NULL), From 440c56e7ef189821bbe685371fe756ce17c79bed Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:24:17 -0400 Subject: [PATCH 23/83] handy return function in utils --- R/utils.R | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 161505c8..dbd026d3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,5 +1,14 @@ - +return_edibble_with_graph <- function(edibble, prov) { + des <- edbl_design(edibble) + des$graph <- prov$get_graph() + if(is_edibble_table(edibble)) { + attr(edibble, "design") <- des + edibble + } else { + des + } +} @@ -47,11 +56,14 @@ print.edbl_design <- function(x, decorate_levels = edibble_decorate("levels"), decorate_title = edibble_decorate("title"), title = NULL, ...) { + prov <- activate_provenance(x) title <- title %||% prov$get_title() %||% "An edibble design" fids <- prov$fct_nodes$id fnames <- prov$fct_names(id = fids) + + if(is_empty(fids)) { data <- data.frame(var = "root", child = NA, From 3b678ffec7f7a2c7558cfb1630ef15f7bbec9a29 Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:24:31 -0400 Subject: [PATCH 24/83] fix set_rcrds --- R/rcrds.R | 44 ++++++++++++++++++-------------------------- 1 file changed, 18 insertions(+), 26 deletions(-) diff --git a/R/rcrds.R b/R/rcrds.R index 9598ad6c..c5e753b5 100644 --- a/R/rcrds.R +++ b/R/rcrds.R @@ -23,33 +23,29 @@ set_rcrds <- function(.edibble, ..., .record = TRUE) { not_edibble(.edibble) - if(.record) record_step() - prov <- activate_provenance(.edibble) - + des <- edbl_design(.edibble) + prov <- activate_provenance(des) + if(.record) prov$record_step() .name_repair <- match.arg(.name_repair) + units <- map(enexprs(...), function(x) { if(is.character(x)) return(x) if(is_symbol(x)) return(quo_text(x)) return(eval(x)) }) + rcrds <- names(units) - prov$fct_exists(name = unlist(units), class = "edbl_unit") + prov$fct_exists(name = unlist(units), role = "edbl_unit") for(i in seq_along(units)) { - rid <- prov$fct_last_id + 1L - uid <- prov$fct_id(units[[i]]) - attrs <- attributes(units[[i]]) - fattrs <- do.call(data.frame, c(attrs[setdiff(names(attrs), c("names", "class"))], - list(stringsAsFactors = FALSE, - id = rid, - name = rcrds[i], - class = "edbl_rcrd"))) - prov$append_fct_nodes(fattrs) - prov$append_fct_edges(data.frame(from = uid, to = rid)) + prov$append_fct_nodes(name = rcrds[i], role = "edbl_rcrd") + uid <- prov$fct_id(name = units[[i]]) + rid <- prov$fct_id(name = rcrds[i]) + prov$append_fct_edges(from = rid, to = uid) } - if(is_edibble_table(.edibble)) return(serve_table(prov$design)) - prov$design + + return_edibble_with_graph(.edibble, prov) } #' @rdname set_rcrds @@ -80,20 +76,20 @@ set_rcrds_of <- function(.edibble, ...) { #' expect_rcrds(y > 0) #' @return An edibble design. #' @export -expect_rcrds <- function(.edibble, ...) { +expect_rcrds <- function(.edibble, ..., .record = TRUE) { not_edibble(.edibble) - record_step() + prov <- activate_provenance(.edibble) + if(.record) prov$record_step() dots <- enquos(...) dots_nms <- names(dots) - prov <- activate_provenance(.edibble) rules_named <- map(dots[dots_nms!=""], eval_tidy) rules_unnamed <- map(dots[dots_nms==""], validate_rcrd, rnames = prov$rcrd_names) rules_unnamed <- stats::setNames(rules_unnamed, map_chr(rules_unnamed, function(x) x$rcrd)) - prov$design$validation <- simplify_validation(c(rules_named, rules_unnamed)) - if(is_edibble_table(.edibble)) return(serve_table(prov$design)) - prov$design + prov$set_validation(simplify_validation(c(rules_named, rules_unnamed)), type = "rcrds") + + return_edibble_with_graph(.edibble, prov) } simplify_validation <- function(x) { @@ -197,10 +193,6 @@ validate_rcrd <- function(x, rnames = NULL) { } -has_record <- function(prov) { - "edbl_rcrd" %in% prov$design$graph$nodes$class -} - #' Expected type of data entry #' From 7efdef4c2fa12e06ee2632bc7d9c88d1b0c05a97 Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:25:08 -0400 Subject: [PATCH 25/83] change to return method in set_fcts --- R/fcts.R | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/R/fcts.R b/R/fcts.R index 7301519f..0c549f95 100644 --- a/R/fcts.R +++ b/R/fcts.R @@ -31,10 +31,9 @@ set_fcts <- function(.edibble, ..., .class = NULL, .edibble$anatomy <- add_anatomy(.edibble$anatomy, input, fname, .class) graph_input(input, prov, fname, .class) } - .edibble$graph <- prov$get_graph() } else if(is_edibble_table(.edibble)) { - + # FIXME loc <- eval_select(expr(tidyselect::all_of(c(...))), .edibble) for(i in seq_along(loc)) { var <- .edibble[[loc[i]]] @@ -45,13 +44,12 @@ set_fcts <- function(.edibble, ..., .class = NULL, class = .class, name = fname) graph_input(.edibble[[loc[i]]], prov, fname, .class) - # FIXME - attr(.edibble, "design") <- prov$design + } } - .edibble + return_edibble_with_graph(.edibble, prov) } From e8a0c4b7cd16599a498067f42f2eb5b85f4deecd Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:25:22 -0400 Subject: [PATCH 26/83] fix serve table for records --- R/serve.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/serve.R b/R/serve.R index 8d3d3dfc..35294cfd 100644 --- a/R/serve.R +++ b/R/serve.R @@ -39,7 +39,7 @@ serve_table <- function(.edibble, use_labels = FALSE, fail = c("error", "warn", } if("edbl_trt" %in% roles) ltrt <- prov$serve_trts(return = "value") if(length(lunit) | length(ltrt)) { - if("edbl_rcrd" %in% roles) lrcrd <- prov$serve_rcrds() + if("edbl_rcrd" %in% roles) lrcrd <- prov$serve_rcrds(return = "value") lout <- c(lunit, ltrt, lrcrd) } else { lout <- serve_vars_not_reconciled(prov) From c25ff1cbc0c65af5da22471e8c8dfcaf44dd4921 Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:25:54 -0400 Subject: [PATCH 27/83] prep -> prov and small fixes (but not completely fixed) for export --- R/export.R | 103 +++++++++++++++++++++++++++-------------------------- 1 file changed, 52 insertions(+), 51 deletions(-) diff --git a/R/export.R b/R/export.R index 2f3511a6..4f753712 100644 --- a/R/export.R +++ b/R/export.R @@ -1,11 +1,12 @@ -make_sheet_names <- function(prep = NULL) { - if(is_null(prep)) { +make_sheet_names <- function(prov = NULL) { + if(is_null(prov)) { data_sheet_names <- "Data" } else { - if(has_record(prep)) { - rids <- prep$rcrd_ids - rcrds <- rcrd_to_unit_dict(prep, rids) + if(prov$rcrd_exists(abort = FALSE)) { + rids <- prov$rcrd_ids + # FIXME + rcrds <- rcrd_to_unit_dict(prov, rids) units <- unique(unname(rcrds)) if(length(units) == 1) { data_sheet_names <- "Data" @@ -66,9 +67,9 @@ add_worksheets <- function(wb, sheet_names, title) { -write_title_sheet <- function(wb, sheet_name, cell_styles, prep, author, date = Sys.Date()) { +write_title_sheet <- function(wb, sheet_name, cell_styles, prov, author, date = Sys.Date()) { # title - openxlsx::writeData(wb, sheet = sheet_name, x = prep$design$name, + openxlsx::writeData(wb, sheet = sheet_name, x = prov$design$name, startRow = 1, startCol = 1, name = "title") openxlsx::addStyle(wb, sheet = sheet_name, style = cell_styles$title, 1, 1, stack = TRUE) @@ -86,15 +87,15 @@ write_title_sheet <- function(wb, sheet_name, cell_styles, prep, author, date = } # context - ncontext <- length(prep$design$context) + ncontext <- length(prov$design$context) openxlsx::writeData(wb, sheet = sheet_name, - x = unlist(prep$design$context), + x = unlist(prov$design$context), startRow = 5, startCol = 2) openxlsx::addStyle(wb, sheet_name, cell_styles$context, 5:(5 + ncontext), 2, stack = TRUE) openxlsx::writeData(wb, sheet = sheet_name, - x = names(prep$design$context), + x = names(prov$design$context), startCol = 1, startRow = 5) openxlsx::addStyle(wb, sheet_name, cell_styles$context_name, 5:(5 + ncontext), 1, stack = TRUE) @@ -109,48 +110,48 @@ data_sheet_name <- function(name) { paste0("Data.", name) } -subset_design <- function(prep, unit, rcrds) { - keep_rids <- prep$fct_id(rcrds) - keep_uids <- prep$fct_id(unit) - keep_uids_ancestors <- prep$fct_ancestor(keep_uids) - sprep <- prep$clone() - sprep$fct_nodes <- sprep$fct_nodes[sprep$fct_nodes$id %in% c(keep_uids_ancestors, keep_rids), ] - sprep$fct_edges <- sprep$fct_edges[(sprep$fct_edges$to %in% keep_uids_ancestors & - sprep$fct_edges$from %in% keep_uids_ancestors) | - sprep$fct_edges$to %in% keep_rids, ] - sprep$lvl_nodes <- sprep$lvl_nodes[sprep$lvl_nodes$idvar %in% keep_uids_ancestors, ] - keep_lids_ancestors <- sprep$lvl_id() - sprep$lvl_edges <- sprep$lvl_edges[sprep$lvl_edges$to %in% keep_lids_ancestors & sprep$lvl_edges$from %in% keep_lids_ancestors, ] - if(!is_null(sprep$design$allotment$trts)) { - units <- map_chr(sprep$design$allotment$trts, function(x) all.vars(f_rhs(x))) - allotments <- sprep$design$allotment$trts[units %in% sprep$fct_names()] +subset_design <- function(prov, unit, rcrds) { + keep_rids <- prov$fct_id(rcrds) + keep_uids <- prov$fct_id(unit) + keep_uids_ancestors <- prov$fct_ancestor(keep_uids) + sprov <- prov$clone() + sprov$fct_nodes <- sprov$fct_nodes[sprov$fct_nodes$id %in% c(keep_uids_ancestors, keep_rids), ] + sprov$fct_edges <- sprov$fct_edges[(sprov$fct_edges$to %in% keep_uids_ancestors & + sprov$fct_edges$from %in% keep_uids_ancestors) | + sprov$fct_edges$to %in% keep_rids, ] + sprov$lvl_nodes <- sprov$lvl_nodes[sprov$lvl_nodes$idvar %in% keep_uids_ancestors, ] + keep_lids_ancestors <- sprov$lvl_id() + sprov$lvl_edges <- sprov$lvl_edges[sprov$lvl_edges$to %in% keep_lids_ancestors & sprov$lvl_edges$from %in% keep_lids_ancestors, ] + if(!is_null(sprov$design$allotment$trts)) { + units <- map_chr(sprov$design$allotment$trts, function(x) all.vars(f_rhs(x))) + allotments <- sprov$design$allotment$trts[units %in% sprov$fct_names()] if(is_empty(allotments)) { - sprep$design$allotment$trts <- NULL + sprov$design$allotment$trts <- NULL } else { - sprep$design$allotment$trts <- allotments + sprov$design$allotment$trts <- allotments } } - if(!is_null(sprep$design$validation)) { - rcrds <- sprep$fct_names(keep_rids) - if(!any(rcrds %in% names(sprep$design$validation))) { - sprep$design$validation <- NULL + if(!is_null(sprov$design$validation)) { + rcrds <- sprov$fct_names(keep_rids) + if(!any(rcrds %in% names(sprov$design$validation))) { + sprov$design$validation <- NULL } else { - sprep$design$validation <- sprep$design$validation[rcrds] + sprov$design$validation <- sprov$design$validation[rcrds] } } - sprep$design + sprov$design } -write_data_sheet <- function(wb, sheet_names, cell_styles, prep, .data) { +write_data_sheet <- function(wb, sheet_names, cell_styles, prov, .data) { if(nrow(.data) && ncol(.data)) { if(length(sheet_names) > 1) { - rids <- prep$rcrd_ids - rcrds2unit <- rcrd_to_unit_dict(prep, rids) + rids <- prov$rcrd_ids + rcrds2unit <- rcrd_to_unit_dict(prov, rids) units <- unique(unname(rcrds2unit)) for(aunit in units) { rcrds <- names(rcrds2unit)[rcrds2unit==aunit] - des <- subset_design(prep, aunit, rcrds) + des <- subset_design(prov, aunit, rcrds) data <- as_data_frame(serve_table(des)) openxlsx::writeData(wb, sheet = data_sheet_name(aunit), x = data, startCol = 1, @@ -175,7 +176,7 @@ write_data_sheet <- function(wb, sheet_names, cell_styles, prep, .data) { } -write_variables_sheet <- function(wb, sheet_name, cell_styles, prep, .data) { +write_variables_sheet <- function(wb, sheet_name, cell_styles, prov, .data) { type <- map_chr(.data, function(var) { cls <- class(var) @@ -187,13 +188,13 @@ write_variables_sheet <- function(wb, sheet_name, cell_styles, prep, .data) { data <- data.frame(variable = names(.data), type = unname(type), stringsAsFactors = FALSE) - if(!is_null(prep$design$validation)) { + if(!is_null(prov$design$validation)) { data$record <- "" data$value <- "" - valid <- prep$design$validation + valid <- prov$design$validation valid_names <- names(valid) - rids <- prep$rcrd_ids - rcrds <- rcrd_to_unit_dict(prep, rids) + rids <- prov$rcrd_ids + rcrds <- rcrd_to_unit_dict(prov, rids) n_ounits <- length(unique(rcrds)) for(i in seq_along(valid)) { unit <- rcrds[valid_names[i]] @@ -276,10 +277,10 @@ export_design <- function(.data, file, author, date = Sys.Date(), overwrite = FA } else { abort("The input is not an edibble table.") } - prep <- activate_provenance(.design) + prov <- activate_provenance(.design) title <- .design$name - sheet_names <- make_sheet_names(prep) + sheet_names <- make_sheet_names(prov) cell_styles_list <- make_cell_styles() wb <- openxlsx::createWorkbook() @@ -287,22 +288,22 @@ export_design <- function(.data, file, author, date = Sys.Date(), overwrite = FA add_creator(wb, author) write_title_sheet(wb, sheet_names[1], - cell_styles_list$context, prep, author, date) + cell_styles_list$context, prov, author, date) write_data_sheet(wb, sheet_names[-c(1, length(sheet_names))], - cell_styles_list$data, prep, .data) + cell_styles_list$data, prov, .data) write_variables_sheet(wb, sheet_names[length(sheet_names)], - cell_styles_list$variables, prep, .data) + cell_styles_list$variables, prov, .data) - save_workbook(wb, file, overwrite, prep) + save_workbook(wb, file, overwrite, prov) invisible(.data) } -save_workbook <- function(wb, file, overwrite, prep) { +save_workbook <- function(wb, file, overwrite, prov) { success <- openxlsx::saveWorkbook(wb, file, overwrite = overwrite, returnValue = TRUE) if(success) { - cli::cli_alert_success("{.emph {prep$design$name}} has been written to {.file {file}}") + cli::cli_alert_success("{.emph {prov$design$name}} has been written to {.file {file}}") } else { - cli::cli_alert_warning("Something went wrong. {.emph {prep$design$name}} failed to be exported.") + cli::cli_alert_warning("Something went wrong. {.emph {prov$design$name}} failed to be exported.") } } From 0980ae993353b96df5efe22cedaecc2a9f37fd1b Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 10:26:11 -0400 Subject: [PATCH 28/83] update test for rcrds --- tests/testthat/_snaps/rcrds.md | 21 +++++++ tests/testthat/_snaps/rcrds.new.md | 99 +++++++++++++++++++++++++++--- tests/testthat/test-rcrds.R | 6 +- 3 files changed, 113 insertions(+), 13 deletions(-) diff --git a/tests/testthat/_snaps/rcrds.md b/tests/testthat/_snaps/rcrds.md index dde8eb65..dfbcf9c3 100644 --- a/tests/testthat/_snaps/rcrds.md +++ b/tests/testthat/_snaps/rcrds.md @@ -272,3 +272,24 @@ 10 class1 student10 traditional open-book o x # ... with 110 more rows +--- + + Code + serve_table(des1) + Output + # Effective teaching + # An edibble: 120 x 6 + class student style exam exam_mark room + + 1 class1 student1 traditional closed-book o o + 2 class1 student2 traditional closed-book o x + 3 class1 student3 traditional take-home o x + 4 class1 student4 traditional take-home o x + 5 class1 student5 traditional open-book o x + 6 class1 student6 traditional take-home o x + 7 class1 student7 traditional take-home o x + 8 class1 student8 traditional closed-book o x + 9 class1 student9 traditional closed-book o x + 10 class1 student10 traditional open-book o x + # ... with 110 more rows + diff --git a/tests/testthat/_snaps/rcrds.new.md b/tests/testthat/_snaps/rcrds.new.md index 9c9227b5..ab8fabed 100644 --- a/tests/testthat/_snaps/rcrds.new.md +++ b/tests/testthat/_snaps/rcrds.new.md @@ -1,16 +1,95 @@ # measure response + Code + des0 %>% set_rcrds(exam_mark = student, room = class) %>% serve_table() + Output + # Effective teaching + # An edibble: 120 x 6 + class student style exam exam_mark room + + 1 class1 student001 traditional closed-book o o + 2 class1 student002 traditional closed-book o x + 3 class1 student003 traditional take-home o x + 4 class1 student004 traditional take-home o x + 5 class1 student005 traditional open-book o x + 6 class1 student006 traditional take-home o x + 7 class1 student007 traditional take-home o x + 8 class1 student008 traditional closed-book o x + 9 class1 student009 traditional closed-book o x + 10 class1 student010 traditional open-book o x + # i 110 more rows + +--- + + Code + des1 <- des0 %>% set_rcrds(exam_mark = student, room = class) + des1 + Output + Effective teaching + +-class (4 levels) + +-student (120 levels) + +-style (2 levels) + +-exam (3 levels) + +-exam_mark + \-room + +--- + Code serve_table(des1) Output - # An edibble design - # An edibble: 6 x 2 - block plot - - 1 block1 plot1 - 2 block1 plot2 - 3 block2 plot3 - 4 block2 plot4 - 5 block3 plot5 - 6 block3 plot6 + # Effective teaching + # An edibble: 120 x 6 + class student style exam exam_mark room + + 1 class1 student001 traditional closed-book o o + 2 class1 student002 traditional closed-book o x + 3 class1 student003 traditional take-home o x + 4 class1 student004 traditional take-home o x + 5 class1 student005 traditional open-book o x + 6 class1 student006 traditional take-home o x + 7 class1 student007 traditional take-home o x + 8 class1 student008 traditional closed-book o x + 9 class1 student009 traditional closed-book o x + 10 class1 student010 traditional open-book o x + # i 110 more rows + +--- + + Code + des2 + Output + Effective teaching + +-class (4 levels) + +-student (120 levels) + +-style (2 levels) + +-exam (3 levels) + +-exam_mark + +-quiz1_mark + +-quiz2_mark + +-gender + +-room + \-teacher + +--- + + Code + serve_table(des2) + Output + # Effective teaching + # An edibble: 120 x 10 + class student style exam exam_mark quiz1_mark quiz2_mark + + 1 class1 student001 traditional closed-book o o o + 2 class1 student002 traditional closed-book o o o + 3 class1 student003 traditional take-home o o o + 4 class1 student004 traditional take-home o o o + 5 class1 student005 traditional open-book o o o + 6 class1 student006 traditional take-home o o o + 7 class1 student007 traditional take-home o o o + 8 class1 student008 traditional closed-book o o o + 9 class1 student009 traditional closed-book o o o + 10 class1 student010 traditional open-book o o o + # i 110 more rows + # i 3 more variables: gender , room , teacher diff --git a/tests/testthat/test-rcrds.R b/tests/testthat/test-rcrds.R index 95de093b..231bcc7a 100644 --- a/tests/testthat/test-rcrds.R +++ b/tests/testthat/test-rcrds.R @@ -1,7 +1,7 @@ test_that("measure response", { # FIXME - des0 <- design(name = "Effective teaching") %>% + des0 <- design(title = "Effective teaching") %>% set_units(class = 4, student = nested_in(class, 30)) %>% set_trts(style = c("flipped", "traditional"), @@ -12,9 +12,9 @@ test_that("measure response", { expect_snapshot({ des0 %>% - serve_table() %>% set_rcrds(exam_mark = student, - room = class) + room = class) %>% + serve_table() }) From 831b0b92fc1a259fffddb3b9b5b547f2ffc39626 Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 20:11:08 -0400 Subject: [PATCH 29/83] vectorise role/id argument --- R/provenance.R | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/R/provenance.R b/R/provenance.R index 6a746362..db675bf8 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -54,7 +54,7 @@ Provenance <- R6::R6Class("Provenance", set_validation = function(validation, type) { private$record_track_internal() private$validation[[type]] <- validation - } + }, reactivate = function(des, overwrite = c("graph", "anatomy", "recipe")) { #private$record_track_internal() @@ -77,8 +77,7 @@ Provenance <- R6::R6Class("Provenance", fct_id = function(name = NULL, role = NULL) { fnodes <- self$fct_nodes if(!is_null(role)) { - private$validate_role(role) - fnodes <- fnodes[fnodes$role == role, ] + fnodes <- fnodes[fnodes$role %in% role, ] } name_to_id <- set_names(fnodes$id, fnodes$name) name <- name %||% names(name_to_id) @@ -192,7 +191,7 @@ Provenance <- R6::R6Class("Provenance", fnodes <- self$fct_nodes if(!is_null(role)) { private$validate_role(role) - fnodes <- fnodes[fnodes$role == role, ] + fnodes <- fnodes[fnodes$role %in% role, ] } id <- id %||% fnodes$id fnodes[match(id, fnodes$id), ]$name @@ -344,30 +343,30 @@ Provenance <- R6::R6Class("Provenance", } else if(is_null(name) & is_null(id) & !is_null(role)) { exist <- any(role %in% fnodes$role) - abort_missing(msg = sprintf("There are no factors with role%s", + abort_missing(msg = sprintf("There are no factors with role %s", .combine_words(paste0("`", role, "`")))) } else if(is_null(name) & !is_null(id) & !is_null(role)) { - srole <- fnodes[match(id, fnodes$id), "role"] - vexist <- srole == role + srole <- fnodes[match(id, fnodes$id), "role", drop = TRUE] + vexist <- srole %in% role exist <- all(vexist) abort_missing(vars = id[!vexist]) } else if(!is_null(name) & is_null(id) & !is_null(role)) { - srole <- fnodes[match(name, fnodes$name), "role"] - vexist <- srole == role + srole <- fnodes[match(name, fnodes$name), "role", drop = TRUE] + vexist <- srole %in% role exist <- all(vexist) abort_missing(vars = name[!vexist]) } else if(!is_null(name) & !is_null(id) & is_null(role)) { - sid <- fnodes[match(name, fnodes$name), "id"] - vexist <- sid == id + sid <- fnodes[match(name, fnodes$name), "id", drop = TRUE] + vexist <- sid %in% id exist <- all(vexist) abort_missing(vars = name[!vexist]) } else { snodes <- fnodes[match(name, fnodes$name), ] - vexist <- snodes$id == id & snodes$role == role + vexist <- snodes$id %in% id & snodes$role %in% role exist <- all(vexist) abort_missing(vars = name[!vexist]) } @@ -393,8 +392,9 @@ Provenance <- R6::R6Class("Provenance", self$fct_exists(id = id, name = name, role = "edbl_rcrd", abort = abort) }, - lvl_exists = function(id = NULL, name = NULL, abort = TRUE) { - self$fct_exists(id = id, name = name, role = "edbl_rcrd", abort = abort) + + lvl_exists = function(id = NULL, value = NULL, fid = NULL, abort = TRUE) { + # FIXME }, #' @description From e6488ad22fd0abaf5c9f2465d631df1e5b054409 Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 20:11:21 -0400 Subject: [PATCH 30/83] add edge type record --- R/rcrds.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/rcrds.R b/R/rcrds.R index c5e753b5..062c3bf0 100644 --- a/R/rcrds.R +++ b/R/rcrds.R @@ -36,13 +36,14 @@ set_rcrds <- function(.edibble, ..., rcrds <- names(units) + prov$fct_exists(name = unlist(units), role = "edbl_unit") for(i in seq_along(units)) { prov$append_fct_nodes(name = rcrds[i], role = "edbl_rcrd") uid <- prov$fct_id(name = units[[i]]) rid <- prov$fct_id(name = rcrds[i]) - prov$append_fct_edges(from = rid, to = uid) + prov$append_fct_edges(from = rid, to = uid, type = "record") } return_edibble_with_graph(.edibble, prov) From dce82d4a138ed19b88186dce5b69fbb5cc5a1ea9 Mon Sep 17 00:00:00 2001 From: Your Name Date: Mon, 14 Aug 2023 20:11:57 -0400 Subject: [PATCH 31/83] fix print util --- R/utils.R | 46 +++-- tests/testthat/_snaps/rcrds.md | 300 ++++++++--------------------- tests/testthat/_snaps/rcrds.new.md | 68 ++++++- 3 files changed, 161 insertions(+), 253 deletions(-) diff --git a/R/utils.R b/R/utils.R index dbd026d3..74dc0a5e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -62,8 +62,6 @@ print.edbl_design <- function(x, fids <- prov$fct_nodes$id fnames <- prov$fct_names(id = fids) - - if(is_empty(fids)) { data <- data.frame(var = "root", child = NA, @@ -81,14 +79,16 @@ print.edbl_design <- function(x, ll <- lapply(fids, function(id) { class <- prov$fct_role(id = id) - children <- prov$fct_id_child(id = id) - if(class!="edbl_trt" & !is_empty(children)) { - prov$fct_names(id = children) - } else { - character() + children <- prov$fct_id_child(id = id, role = "edbl_unit") + parents <- prov$fct_id_parent(id = id, role = c("edbl_trt", "edbl_rcrd")) + if(class=="edbl_unit") { + if(!is_empty(children)) return(children) + if(!is_empty(parents)) return(parents) } + return(character()) }) - nodes_with_parents <- unname(unlist(ll)) + names(ll) <- as.character(fids) + nodes_with_parents <- as.integer(unname(unlist(ll))) label_names_with_levels <- paste(label_names, map_chr(var_nlevels, decorate_levels)) label_names_with_levels[classes=="edbl_rcrd"] <- label_names[classes=="edbl_rcrd"] @@ -98,23 +98,31 @@ print.edbl_design <- function(x, label_names_with_levels)) } cat(tree(data, root = "root"), sep = "\n") - if(!is_null(x$allotment)) { + + fedges <- prov$fct_edges + if("allot" %in% fedges$type) { cat(decorate_title("Allotment:\n")) - s <- as.character(c(x$allotment$trts, x$allotment$units)) - tilde_pos <- unlist(gregexpr("~", s)) - tilde_pos_max <- max(tilde_pos) - pad <- map_chr(tilde_pos_max - tilde_pos, function(n) ifelse(n==0, "", paste0(rep(" ", n), collapse = ""))) - cli_li(items = paste0(" ", pad, s)) + allots <- fedges[fedges$type=="allot", ] + trts_to_units <- paste(fedges$var_from, "~", fedges$var_to) + # this is so it aligns the tilde position + # it seems that it's automatically strips away the padding now + # so below no longer works + #tilde_pos <- unlist(gregexpr("~", trts_to_units)) + #tilde_pos_max <- max(tilde_pos) + #pad <- map_chr(tilde_pos_max - tilde_pos, function(n) ifelse(n==0, "", paste0(rep(" ", n), collapse = ""))) + #cli_li(items = paste0(" ", pad, trts_to_units)) + cli_li(items = trts_to_units) } + # FIXME: should this be included - currently it is not if(!is_null(x$assignment)) { cat(decorate_title("Assignment:"), paste0(x$assignment, collapse = ", "), "\n") } - if(!is_null(x$validation)) { + if(!is_null(valids <- prov$get_validation())) { cat(decorate_title("Validation:\n")) - rnames <- names(x$validation) - items <- map_chr(seq_along(x$validation), function(i) { - paste0(rnames[i], ": ", style_italic(x$validation[[i]]$record), " ", - validation_interval(x$validation[[i]])) + rnames <- names(valids) + items <- map_chr(seq_along(valids), function(i) { + paste0(rnames[i], ": ", style_italic(valids[[i]]$record), " ", + validation_interval(valids[[i]])) }) cli_li(items = items) } diff --git a/tests/testthat/_snaps/rcrds.md b/tests/testthat/_snaps/rcrds.md index dfbcf9c3..b74a35f5 100644 --- a/tests/testthat/_snaps/rcrds.md +++ b/tests/testthat/_snaps/rcrds.md @@ -1,23 +1,23 @@ # measure response Code - des0 %>% serve_table() %>% set_rcrds(exam_mark = student, room = class) + des0 %>% set_rcrds(exam_mark = student, room = class) %>% serve_table() Output - # Effective teaching + # Effective teaching # An edibble: 120 x 6 class student style exam exam_mark room - 1 class1 student1 traditional closed-book o o - 2 class1 student2 traditional closed-book o x - 3 class1 student3 traditional take-home o x - 4 class1 student4 traditional take-home o x - 5 class1 student5 traditional open-book o x - 6 class1 student6 traditional take-home o x - 7 class1 student7 traditional take-home o x - 8 class1 student8 traditional closed-book o x - 9 class1 student9 traditional closed-book o x - 10 class1 student10 traditional open-book o x - # ... with 110 more rows + 1 class1 student001 traditional closed-book o o + 2 class1 student002 traditional closed-book o x + 3 class1 student003 traditional take-home o x + 4 class1 student004 traditional take-home o x + 5 class1 student005 traditional open-book o x + 6 class1 student006 traditional take-home o x + 7 class1 student007 traditional take-home o x + 8 class1 student008 traditional closed-book o x + 9 class1 student009 traditional closed-book o x + 10 class1 student010 traditional open-book o x + # i 110 more rows --- @@ -27,17 +27,18 @@ Output Effective teaching +-class (4 levels) - | +-student (120 levels) - | | \-exam_mark - | \-room + | \-student (120 levels) + | +-exam (3 levels) + | \-exam_mark +-style (2 levels) - \-exam (3 levels) + \-room Allotment: Message + * class ~ student * style ~ class * exam ~ student - Output - Assignment: random, random + * exam_mark ~ student + * room ~ class --- @@ -48,17 +49,17 @@ # An edibble: 120 x 6 class student style exam exam_mark room - 1 class1 student1 traditional closed-book o o - 2 class1 student2 traditional closed-book o x - 3 class1 student3 traditional take-home o x - 4 class1 student4 traditional take-home o x - 5 class1 student5 traditional open-book o x - 6 class1 student6 traditional take-home o x - 7 class1 student7 traditional take-home o x - 8 class1 student8 traditional closed-book o x - 9 class1 student9 traditional closed-book o x - 10 class1 student10 traditional open-book o x - # ... with 110 more rows + 1 class1 student001 traditional closed-book o o + 2 class1 student002 traditional closed-book o x + 3 class1 student003 traditional take-home o x + 4 class1 student004 traditional take-home o x + 5 class1 student005 traditional open-book o x + 6 class1 student006 traditional take-home o x + 7 class1 student007 traditional take-home o x + 8 class1 student008 traditional closed-book o x + 9 class1 student009 traditional closed-book o x + 10 class1 student010 traditional open-book o x + # i 110 more rows --- @@ -67,21 +68,26 @@ Output Effective teaching +-class (4 levels) - | +-student (120 levels) - | | +-exam_mark - | | +-quiz1_mark - | | +-quiz2_mark - | | \-gender - | +-room - | \-teacher + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender +-style (2 levels) - \-exam (3 levels) + +-room + \-teacher Allotment: Message + * class ~ student * style ~ class * exam ~ student - Output - Assignment: random, random + * exam_mark ~ student + * quiz1_mark ~ student + * quiz2_mark ~ student + * gender ~ student + * room ~ class + * teacher ~ class --- @@ -90,20 +96,20 @@ Output # Effective teaching # An edibble: 120 x 10 - class student style exam exam_m~1 quiz1~2 quiz2~3 gender - - 1 class1 student1 traditional closed-book o o o o - 2 class1 student2 traditional closed-book o o o o - 3 class1 student3 traditional take-home o o o o - 4 class1 student4 traditional take-home o o o o - 5 class1 student5 traditional open-book o o o o - 6 class1 student6 traditional take-home o o o o - 7 class1 student7 traditional take-home o o o o - 8 class1 student8 traditional closed-book o o o o - 9 class1 student9 traditional closed-book o o o o - 10 class1 student10 traditional open-book o o o o - # ... with 110 more rows, 2 more variables: room , teacher , and - # abbreviated variable names 1: exam_mark, 2: quiz1_mark, 3: quiz2_mark + class student style exam exam_mark quiz1_mark quiz2_mark + + 1 class1 student001 traditional closed-book o o o + 2 class1 student002 traditional closed-book o o o + 3 class1 student003 traditional take-home o o o + 4 class1 student004 traditional take-home o o o + 5 class1 student005 traditional open-book o o o + 6 class1 student006 traditional take-home o o o + 7 class1 student007 traditional take-home o o o + 8 class1 student008 traditional closed-book o o o + 9 class1 student009 traditional closed-book o o o + 10 class1 student010 traditional open-book o o o + # i 110 more rows + # i 3 more variables: gender , room , teacher --- @@ -116,180 +122,24 @@ Output Effective teaching +-class (4 levels) - | +-student (120 levels) - | | +-exam_mark - | | +-quiz1_mark - | | +-quiz2_mark - | | \-gender - | +-room - | \-teacher + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender +-style (2 levels) - \-exam (3 levels) + +-room + \-teacher Allotment: Message + * class ~ student * style ~ class * exam ~ student - Output - Assignment: random, random - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: integer [0, 30] - * gender: factor [female, male, non-binary] - * teacher: text - * room: text - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | +-student (120 levels) - | | +-exam_mark - | | +-quiz1_mark - | | +-quiz2_mark - | | \-gender - | +-room - | \-teacher - +-style (2 levels) - \-exam (3 levels) - Allotment: - Message - * style ~ class - * exam ~ student - Output - Assignment: random, random - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: numeric [-Inf, 12) - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | +-student (120 levels) - | | +-exam_mark - | | +-quiz1_mark - | | +-quiz2_mark - | | \-gender - | +-room - | \-teacher - +-style (2 levels) - \-exam (3 levels) - Allotment: - Message - * style ~ class - * exam ~ student - Output - Assignment: random, random - Validation: - Message - * exam_mark: numeric [0, 100] - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark < -1) - Output - Effective teaching - +-class (4 levels) - | +-student (120 levels) - | | +-exam_mark - | | +-quiz1_mark - | | +-quiz2_mark - | | \-gender - | +-room - | \-teacher - +-style (2 levels) - \-exam (3 levels) - Allotment: - Message - * style ~ class - * exam ~ student - Output - Assignment: random, random - Validation: - Message - * exam_mark: numeric [-Inf, -1) - ---- - - Code - des2 %>% expect_rcrds(0 < exam_mark) - Output - Effective teaching - +-class (4 levels) - | +-student (120 levels) - | | +-exam_mark - | | +-quiz1_mark - | | +-quiz2_mark - | | \-gender - | +-room - | \-teacher - +-style (2 levels) - \-exam (3 levels) - Allotment: - Message - * style ~ class - * exam ~ student - Output - Assignment: random, random - Validation: - Message - * exam_mark: numeric (0, Inf] - ---- - - Code - des0 %>% serve_table() %>% set_rcrds(exam_mark = student, room = class) - Output - # Effective teaching - # An edibble: 120 x 6 - class student style exam exam_mark room - - 1 class1 student1 traditional closed-book o o - 2 class1 student2 traditional closed-book o x - 3 class1 student3 traditional take-home o x - 4 class1 student4 traditional take-home o x - 5 class1 student5 traditional open-book o x - 6 class1 student6 traditional take-home o x - 7 class1 student7 traditional take-home o x - 8 class1 student8 traditional closed-book o x - 9 class1 student9 traditional closed-book o x - 10 class1 student10 traditional open-book o x - # ... with 110 more rows - ---- - - Code - serve_table(des1) - Output - # Effective teaching - # An edibble: 120 x 6 - class student style exam exam_mark room - - 1 class1 student1 traditional closed-book o o - 2 class1 student2 traditional closed-book o x - 3 class1 student3 traditional take-home o x - 4 class1 student4 traditional take-home o x - 5 class1 student5 traditional open-book o x - 6 class1 student6 traditional take-home o x - 7 class1 student7 traditional take-home o x - 8 class1 student8 traditional closed-book o x - 9 class1 student9 traditional closed-book o x - 10 class1 student10 traditional open-book o x - # ... with 110 more rows + * exam_mark ~ student + * quiz1_mark ~ student + * quiz2_mark ~ student + * gender ~ student + * room ~ class + * teacher ~ class diff --git a/tests/testthat/_snaps/rcrds.new.md b/tests/testthat/_snaps/rcrds.new.md index ab8fabed..c65c3bab 100644 --- a/tests/testthat/_snaps/rcrds.new.md +++ b/tests/testthat/_snaps/rcrds.new.md @@ -27,11 +27,18 @@ Output Effective teaching +-class (4 levels) - +-student (120 levels) + | \-student (120 levels) + | +-exam (3 levels) + | \-exam_mark +-style (2 levels) - +-exam (3 levels) - +-exam_mark \-room + Allotment: + Message + * class ~ student + * style ~ class + * exam ~ student + * exam_mark ~ student + * room ~ class --- @@ -61,15 +68,26 @@ Output Effective teaching +-class (4 levels) - +-student (120 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender +-style (2 levels) - +-exam (3 levels) - +-exam_mark - +-quiz1_mark - +-quiz2_mark - +-gender +-room \-teacher + Allotment: + Message + * class ~ student + * style ~ class + * exam ~ student + * exam_mark ~ student + * quiz1_mark ~ student + * quiz2_mark ~ student + * gender ~ student + * room ~ class + * teacher ~ class --- @@ -93,3 +111,35 @@ # i 110 more rows # i 3 more variables: gender , room , teacher +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( + with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", + "male", "non-binary")), teacher = to_be_character(length = with_value("<=", + 100)), room = to_be_character(length = with_value(">=", 1))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * class ~ student + * style ~ class + * exam ~ student + * exam_mark ~ student + * quiz1_mark ~ student + * quiz2_mark ~ student + * gender ~ student + * room ~ class + * teacher ~ class + From 91a77b39f8e52af9d38e60f2fd1492de2e9097b9 Mon Sep 17 00:00:00 2001 From: Your Name Date: Thu, 17 Aug 2023 19:25:57 -0400 Subject: [PATCH 32/83] fix scan menu print out --- R/menu.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/menu.R b/R/menu.R index 8d9a0e1d..1473d118 100644 --- a/R/menu.R +++ b/R/menu.R @@ -457,7 +457,7 @@ scan_menu <- function(pkgs = NULL) { tryCatch({ short_names <- c(short_names, set_names(des$name, pkg_names[i])) cli_li("{.pkg {des$name}} with the arguments {.field {names(args)}} - for a {.combine_words(des$name_full, fun = style_bold, and = ' / ')}.") + for a { .combine_words(des$name_full, fun = cli::style_bold, and = ' / ')}.") }, error = function(x) { cli_li("{.pkg {gsub('menu_', '', menu_fn)}} seems to be {cli::col_red('unavailable')}.") }) From 4dfb9f0e374745942049e116e6963a261908eb90 Mon Sep 17 00:00:00 2001 From: Your Name Date: Thu, 17 Aug 2023 19:26:07 -0400 Subject: [PATCH 33/83] fix print --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 74dc0a5e..fd67754b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -117,7 +117,7 @@ print.edbl_design <- function(x, if(!is_null(x$assignment)) { cat(decorate_title("Assignment:"), paste0(x$assignment, collapse = ", "), "\n") } - if(!is_null(valids <- prov$get_validation())) { + if(!is_null(valids <- prov$get_validation(type = "rcrds"))) { cat(decorate_title("Validation:\n")) rnames <- names(valids) items <- map_chr(seq_along(valids), function(i) { From 831751e1a209700d0fa7739142391dbcab0f28ec Mon Sep 17 00:00:00 2001 From: Your Name Date: Sat, 19 Aug 2023 10:34:15 -0400 Subject: [PATCH 34/83] update provenance doc --- NAMESPACE | 3 +- R/provenance.R | 119 ++++++++++-- man/Provenance.Rd | 377 ++++++++++++++++++++++++++++++--------- man/allot_table.Rd | 3 +- man/allot_trts.Rd | 4 +- man/allot_units.Rd | 4 +- man/assign.Rd | 10 +- man/crossed_by.Rd | 17 +- man/expect_rcrds.Rd | 6 +- man/extract-lvl-nodes.Rd | 33 ++++ man/serve_table.Rd | 9 +- 11 files changed, 451 insertions(+), 134 deletions(-) create mode 100644 man/extract-lvl-nodes.Rd diff --git a/NAMESPACE b/NAMESPACE index 69f938a3..6566cb37 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -55,8 +55,7 @@ S3method(vec_ptype_full,edbl_rcrd) S3method(vec_ptype_full,edbl_trt) S3method(vec_ptype_full,edbl_unit) export("%>%") -export("function") -export(Initialise) +export(Provenance) export(activate_provenance) export(allot_table) export(allot_trts) diff --git a/R/provenance.R b/R/provenance.R index db675bf8..2f900ce7 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -1,24 +1,25 @@ -#' A manipulator for the edbl_design. +#' An object to query, record and modify an edibble graph #' -#' Internal functions should create a new Provenance object. #' The Provenance contains a set of operations to manipulate the nodes and edges of -#' the edibble design object. +#' the edibble graph object. #' -#' @param role The role for the vertex/node. -#' @param data The nodes data -#' @param name The name of the vertex. +#' @param role The role for the node. +#' @param name The name of the node. +#' @param value The value of the node. #' @param id The id of the corresponding node. -#' @param input The value of the new graph structure to add. -#' @param initial The intial id. +#' @param fid The factor id. +#' @param attrs The attributes. #' @param abort Whether to abort. +#' @param return To return in "id" or "value" format. #' @importFrom vctrs vec_is #' @export Provenance <- R6::R6Class("Provenance", public = list( + #' @description #' Initialise function - #' @param design An edibble design. + #' @param graph An edibble graph. initialize = function(graph = NULL) { private$record_track_internal() #self$add_tracker_to_set_fns(track_fns) @@ -37,6 +38,9 @@ Provenance <- R6::R6Class("Provenance", # } # }, + #' @description + #' Set the title. + #' @param title The title of the experiment set_title = function(title) { private$record_track_internal() title <- vctrs::vec_cast(title, character()) @@ -44,6 +48,9 @@ Provenance <- R6::R6Class("Provenance", private$title <- title }, + #' @description + #' Set the name. + #' @param name The name of the edibble graph object. set_name = function(name) { private$record_track_internal() name <- vctrs::vec_cast(name, character()) @@ -51,18 +58,30 @@ Provenance <- R6::R6Class("Provenance", private$name <- name }, - set_validation = function(validation, type) { + #' @description + #' Set the validation. + #' @param validation The validation statement. + #' @param type The type of validation. + set_validation = function(validation, type = "rcrds") { private$record_track_internal() private$validation[[type]] <- validation }, - reactivate = function(des, overwrite = c("graph", "anatomy", "recipe")) { + #' @description + #' Reactivate the graph in the provenance object. + #' @param design An edibble design + #' @param overwrite A vector of character to overwrite from the + #' supplied design object. + reactivate = function(design, overwrite = c("graph", "anatomy", "recipe")) { #private$record_track_internal() for(obj in overwrite) { - private[[obj]] <- des[[obj]] + private[[obj]] <- design[[obj]] } }, + #' @description + #' Deactivate the provenance object. + #' @param delete A vector of character to delete. deactivate = function(delete = c("graph", "anatomy", "recipe")) { #private$record_track_internal() for(obj in delete) { @@ -106,7 +125,8 @@ Provenance <- R6::R6Class("Provenance", }, - #' @field fct_leaves + + #' @description #' Get the leave factor ids. fct_id_leaves = function(role = NULL) { fids <- self$fct_id(role = role) @@ -163,6 +183,8 @@ Provenance <- R6::R6Class("Provenance", private$var_id_ancestor(id = id, role = role, node = "level") }, + #' @description + #' Find the factor id from level ids. #' @param fid_search A vector of fids to search from. fct_id_from_lvl_id = function(id = NULL, fid_search = NULL) { lnodes_list <- self$lvl_nodes @@ -172,6 +194,9 @@ Provenance <- R6::R6Class("Provenance", } }, + #' @description + #' Find the factor id from level values. + #' @param fid_search A vector of fids to search from. fct_id_from_lvl_values = function(value = NULL, fid_search = NULL) { lnodes_list <- self$lvl_nodes if(!is_null(fid_search)) lnodes_list <- lnodes_list[fid_search] @@ -180,6 +205,8 @@ Provenance <- R6::R6Class("Provenance", } }, + #' @description + #' Find the level id from the given fid lvl_id_from_fct_id = function(fid = NULL) { lnodes_list <- self$lvl_nodes lnodes_list[[fid]]$id @@ -197,14 +224,20 @@ Provenance <- R6::R6Class("Provenance", fnodes[match(id, fnodes$id), ]$name }, + #' @description + #' Get the unit names unit_names = function(id = NULL) { self$fct_names(id = id, role = "edbl_unit") }, + #' @description + #' Get the treatment names trt_names = function(id = NULL) { self$fct_names(id = id, role = "edbl_trt") }, + #' @description + #' Get the record names. rcrd_names = function(id = NULL) { self$fct_names(id = id, role = "edbl_rcrd") }, @@ -229,14 +262,20 @@ Provenance <- R6::R6Class("Provenance", } }, + #' @description + #' Get the unit values. unit_values = function(id = NULL, fid = NULL) { self$lvl_values(id = id, role = "edbl_unit", fid = fid) }, + #' @description + #' Get the treatment values. trt_values = function(id = NULL, fid = NULL) { self$lvl_values(id = id, role = "edbl_trt", fid = fid) }, + #' @description + #' Get the record values. #' @param uid The unit level id rcrd_values = function(uid = NULL, fid = NULL) { lnodes_list <- self$lvl_nodes @@ -273,6 +312,9 @@ Provenance <- R6::R6Class("Provenance", }) }, + #' @description + #' Factor levels to edble factor + #' @param fct_levels The factor levels in id. fct_levels_id_to_edbl_fct = function(fct_levels, role) { ret <- lapply(names(fct_levels), function(fid) { lvls <- fct_levels[[fid]] @@ -287,6 +329,9 @@ Provenance <- R6::R6Class("Provenance", ret }, + #' @description + #' Get the factor levels in value given id format + #' @param fct_levels A list of factor levels in id format. fct_levels_id_to_value = function(fct_levels) { out <- lapply(names(fct_levels), function(fid) { lvls <- fct_levels[[fid]] @@ -296,6 +341,9 @@ Provenance <- R6::R6Class("Provenance", out }, + #' @description + #' Get the factor levels in id given value format. + #' @param fct_levels A list of factor levels in id format. fct_levels_value_to_id = function(fct_levels) { out <- lapply(names(fct_levels), function(fname) { lvls <- fct_levels[[fname]] @@ -310,7 +358,6 @@ Provenance <- R6::R6Class("Provenance", #' One of `name`, `id` or `role` is defined to check if it exists. #' If more than one of the arguments `name`, `id` and `role` are supplied, then #' the intersection of it will be checked. - #' @param abort A logical value to indicate whether to abort if it doesn't exist. fct_exists = function(id = NULL, name = NULL, role = NULL, abort = TRUE) { exist <- TRUE abort_missing <- function(vars = NULL, msg = NULL) { @@ -393,9 +440,10 @@ Provenance <- R6::R6Class("Provenance", }, - lvl_exists = function(id = NULL, value = NULL, fid = NULL, abort = TRUE) { + + #lvl_exists = function(id = NULL, value = NULL, fid = NULL, abort = TRUE) { # FIXME - }, + #}, #' @description #' Given node data, append the factor nodes @@ -432,6 +480,10 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Given edge data, append the factor edges + #' @param from The node id from. + #' @param to The node id to. + #' @param type The type of edges. + #' @param group The group id. append_fct_edges = function(from, to, type = NULL, group = NULL, attrs = NULL) { private$record_track_internal() self$fct_edges <- rbind_(self$fct_edges, tibble::tibble(from = from, @@ -443,6 +495,8 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Given edge data, append the level edges + #' @param from The node id from. + #' @param to The node id to. append_lvl_edges = function(from, to, attrs = NULL) { private$record_track_internal() self$lvl_edges <- rbind_(self$lvl_edges, tibble::tibble(from = from, @@ -450,6 +504,8 @@ Provenance <- R6::R6Class("Provenance", attrs = attrs)) }, + #' @description + #' Serve the units. serve_units = function(id = NULL, return = c("id", "value")) { return <- match.arg(return) id <- id %||% self$fct_id(role = "edbl_unit") @@ -485,6 +541,8 @@ Provenance <- R6::R6Class("Provenance", value = self$fct_levels_id_to_edbl_fct(out, role = "edbl_unit")) }, + #' @description + #' Serve treatments serve_trts = function(id = NULL, return = c("id", "value")) { return <- match.arg(return) @@ -514,6 +572,8 @@ Provenance <- R6::R6Class("Provenance", }, + #' @description + #' Serve records serve_rcrds = function(id = NULL, return = c("id", "value")) { id <- id %||% self$rcrd_ids @@ -540,6 +600,8 @@ Provenance <- R6::R6Class("Provenance", }) }, + #' @description + #' Subset graph #' @param include "self" for only input id, "child" for child also, #' "parent" for parent also, #' nodes immediately related, and "ancestors" for all ancestors @@ -564,6 +626,9 @@ Provenance <- R6::R6Class("Provenance", new_edibble_graph(fnodes, lnodes, fedges, ledges) }, + #' @description + #' Save the seed + #' @param seed A seed. save_seed = function(seed) { private$record_track_internal() if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) @@ -577,34 +642,51 @@ Provenance <- R6::R6Class("Provenance", private$seed <- RNGstate }, + #' @description + #' Get the title get_title = function() { private$title }, + #' @description + #' Get the validation + #' @param type A type. get_validation = function(type) { private$validation[[type]] }, + #' @description + #' Get the trail. get_trail = function() { private$trail[-length(private$trail)] }, + #' @description + #' Get the graph get_graph = function() { private$graph }, + #' @description + #' Get the seed get_seed = function() { private$seed }, + #' @description + #' Get the session information get_session_info = function() { private$session_info }, + #' @description + #' Get the edibble version. get_edibble_version = function() { private$edibble_version }, + #' @description + #' Record step. record_step = function() { do.call("on.exit", list(quote(return(add_edibble_code(returnValue(default = FALSE), @@ -613,6 +695,9 @@ Provenance <- R6::R6Class("Provenance", envir = parent.frame()) }, + #' @description + #' Record track external. + #' @param code The code to record. record_track_external = function(code) { ncmds <- length(private$trail) attr(private$trail[[ncmds]], "external_cmd") <- code @@ -793,7 +878,6 @@ Provenance <- R6::R6Class("Provenance", }, - #' @field fct_new_id #' Get a new factor id. fct_new_id = function(n = 1) { ids <- seq(private$fct_id_last + 1, private$fct_id_last + n) @@ -801,7 +885,6 @@ Provenance <- R6::R6Class("Provenance", ids }, - #' @field lvl_new_id #' Get a new level id. lvl_new_id = function(n = 1) { ids <- seq(private$lvl_id_last + 1, private$lvl_id_last + n) diff --git a/man/Provenance.Rd b/man/Provenance.Rd index 502bc084..5366ab55 100644 --- a/man/Provenance.Rd +++ b/man/Provenance.Rd @@ -2,35 +2,19 @@ % Please edit documentation in R/provenance.R \name{Provenance} \alias{Provenance} -\title{A manipulator for the edbl_design.} +\title{An object to query, record and modify an edibble graph} \description{ -A manipulator for the edbl_design. +An object to query, record and modify an edibble graph -A manipulator for the edbl_design. +An object to query, record and modify an edibble graph } \details{ -Internal functions should create a new Provenance object. The Provenance contains a set of operations to manipulate the nodes and edges of -the edibble design object. -} -\section{Public fields}{ -\if{html}{\out{
}} -\describe{ -\item{\code{fct_leaves}}{Get the leave factor ids.} - -\item{\code{fct_new_id}}{Get a new factor id.} - -\item{\code{lvl_new_id}}{Get a new level id. -Given a particular DAG, return a topological order -Remember that there could be more than one order.} -} -\if{html}{\out{
}} +the edibble graph object. } \section{Active bindings}{ \if{html}{\out{
}} \describe{ -\item{\code{fct_leaves}}{Get the leave factor ids.} - \item{\code{fct_nodes}}{Get the factor nodes} \item{\code{lvl_nodes}}{Get the level nodes} @@ -49,11 +33,9 @@ Remember that there could be more than one order.} \item{\code{trt_ids}}{Get the ids for all edbl_trt factors.} -\item{\code{is_connected}}{Check if nodes are connected.} - -\item{\code{fct_new_id}}{Get a new factor id.} - -\item{\code{lvl_new_id}}{Get a new level id. +\item{\code{is_connected}}{Check if nodes are connected. +Get a new factor id. +Get a new level id. Given a particular DAG, return a topological order Remember that there could be more than one order.} } @@ -65,6 +47,7 @@ Remember that there could be more than one order.} \item \href{#method-Provenance-new}{\code{Provenance$new()}} \item \href{#method-Provenance-set_title}{\code{Provenance$set_title()}} \item \href{#method-Provenance-set_name}{\code{Provenance$set_name()}} +\item \href{#method-Provenance-set_validation}{\code{Provenance$set_validation()}} \item \href{#method-Provenance-reactivate}{\code{Provenance$reactivate()}} \item \href{#method-Provenance-deactivate}{\code{Provenance$deactivate()}} \item \href{#method-Provenance-fct_id}{\code{Provenance$fct_id()}} @@ -88,21 +71,25 @@ Remember that there could be more than one order.} \item \href{#method-Provenance-trt_values}{\code{Provenance$trt_values()}} \item \href{#method-Provenance-rcrd_values}{\code{Provenance$rcrd_values()}} \item \href{#method-Provenance-fct_role}{\code{Provenance$fct_role()}} -\item \href{#method-Provenance-fct_levels_id}{\code{Provenance$fct_levels_id()}} -\item \href{#method-Provenance-fct_levels_value}{\code{Provenance$fct_levels_value()}} +\item \href{#method-Provenance-fct_levels}{\code{Provenance$fct_levels()}} +\item \href{#method-Provenance-fct_levels_id_to_edbl_fct}{\code{Provenance$fct_levels_id_to_edbl_fct()}} +\item \href{#method-Provenance-fct_levels_id_to_value}{\code{Provenance$fct_levels_id_to_value()}} +\item \href{#method-Provenance-fct_levels_value_to_id}{\code{Provenance$fct_levels_value_to_id()}} \item \href{#method-Provenance-fct_exists}{\code{Provenance$fct_exists()}} \item \href{#method-Provenance-trt_exists}{\code{Provenance$trt_exists()}} \item \href{#method-Provenance-unit_exists}{\code{Provenance$unit_exists()}} \item \href{#method-Provenance-rcrd_exists}{\code{Provenance$rcrd_exists()}} -\item \href{#method-Provenance-lvl_exists}{\code{Provenance$lvl_exists()}} \item \href{#method-Provenance-append_fct_nodes}{\code{Provenance$append_fct_nodes()}} \item \href{#method-Provenance-append_lvl_nodes}{\code{Provenance$append_lvl_nodes()}} \item \href{#method-Provenance-append_fct_edges}{\code{Provenance$append_fct_edges()}} \item \href{#method-Provenance-append_lvl_edges}{\code{Provenance$append_lvl_edges()}} \item \href{#method-Provenance-serve_units}{\code{Provenance$serve_units()}} +\item \href{#method-Provenance-serve_trts}{\code{Provenance$serve_trts()}} +\item \href{#method-Provenance-serve_rcrds}{\code{Provenance$serve_rcrds()}} \item \href{#method-Provenance-graph_subset}{\code{Provenance$graph_subset()}} \item \href{#method-Provenance-save_seed}{\code{Provenance$save_seed()}} \item \href{#method-Provenance-get_title}{\code{Provenance$get_title()}} +\item \href{#method-Provenance-get_validation}{\code{Provenance$get_validation()}} \item \href{#method-Provenance-get_trail}{\code{Provenance$get_trail()}} \item \href{#method-Provenance-get_graph}{\code{Provenance$get_graph()}} \item \href{#method-Provenance-get_seed}{\code{Provenance$get_seed()}} @@ -117,6 +104,7 @@ Remember that there could be more than one order.} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-new}{}}} \subsection{Method \code{new()}}{ +Initialise function \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$new(graph = NULL)}\if{html}{\out{
}} } @@ -124,7 +112,7 @@ Remember that there could be more than one order.} \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{design}}{An edibble design.} +\item{\code{graph}}{An edibble graph.} } \if{html}{\out{
}} } @@ -133,15 +121,24 @@ Remember that there could be more than one order.} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-set_title}{}}} \subsection{Method \code{set_title()}}{ +Set the title. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$set_title(title)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{title}}{The title of the experiment} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-set_name}{}}} \subsection{Method \code{set_name()}}{ +Set the name. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$set_name(name)}\if{html}{\out{
}} } @@ -149,7 +146,26 @@ Remember that there could be more than one order.} \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the edibble graph object.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-set_validation}{}}} +\subsection{Method \code{set_validation()}}{ +Set the validation. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$set_validation(validation, type = "rcrds")}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{validation}}{The validation statement.} + +\item{\code{type}}{The type of validation.} } \if{html}{\out{
}} } @@ -158,19 +174,38 @@ Remember that there could be more than one order.} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-reactivate}{}}} \subsection{Method \code{reactivate()}}{ +Reactivate the graph in the provenance object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$reactivate(des, overwrite = c("graph", "anatomy", "recipe"))}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$reactivate(design, overwrite = c("graph", "anatomy", "recipe"))}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{design}}{An edibble design} + +\item{\code{overwrite}}{A vector of character to overwrite from the +supplied design object.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-deactivate}{}}} \subsection{Method \code{deactivate()}}{ +Deactivate the provenance object. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$deactivate(delete = c("graph", "anatomy", "recipe"))}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{delete}}{A vector of character to delete.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} @@ -185,9 +220,9 @@ If none supplied then it will give all. \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{
}} } @@ -206,7 +241,7 @@ Get the factor parent ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{
}} } @@ -226,7 +261,7 @@ supplied then the child has to fit \code{role} \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{
}} } @@ -245,7 +280,7 @@ Get the factor ancestor ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{}} } @@ -254,6 +289,7 @@ Get the factor ancestor ids \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-fct_id_leaves}{}}} \subsection{Method \code{fct_id_leaves()}}{ +Get the leave factor ids. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$fct_id_leaves(role = NULL)}\if{html}{\out{
}} } @@ -261,7 +297,7 @@ Get the factor ancestor ids \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{
}} } @@ -279,7 +315,11 @@ Assumes that level ids obtained are all from the same fid \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{role}}{The role for the vertex/node.} +\item{\code{value}}{The value of the node.} + +\item{\code{role}}{The role for the node.} + +\item{\code{fid}}{The factor id.} } \if{html}{\out{
}} } @@ -298,7 +338,7 @@ Get the level parent ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{}} } @@ -317,7 +357,7 @@ Get the level child ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{}} } @@ -336,7 +376,7 @@ Get the level ancestor ids \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{}} } @@ -345,6 +385,7 @@ Get the level ancestor ids \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-fct_id_from_lvl_id}{}}} \subsection{Method \code{fct_id_from_lvl_id()}}{ +Find the factor id from level ids. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$fct_id_from_lvl_id(id = NULL, fid_search = NULL)}\if{html}{\out{
}} } @@ -363,19 +404,37 @@ Get the level ancestor ids \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-fct_id_from_lvl_values}{}}} \subsection{Method \code{fct_id_from_lvl_values()}}{ +Find the factor id from level values. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$fct_id_from_lvl_values(value = NULL, fid_search = NULL)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{value}}{The value of the node.} + +\item{\code{fid_search}}{A vector of fids to search from.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-lvl_id_from_fct_id}{}}} \subsection{Method \code{lvl_id_from_fct_id()}}{ +Find the level id from the given fid \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$lvl_id_from_fct_id(fid = NULL)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{fid}}{The factor id.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} @@ -391,7 +450,7 @@ Get the factor names based on id or role \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} } \if{html}{\out{}} } @@ -400,6 +459,7 @@ Get the factor names based on id or role \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-unit_names}{}}} \subsection{Method \code{unit_names()}}{ +Get the unit names \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$unit_names(id = NULL)}\if{html}{\out{
}} } @@ -416,6 +476,7 @@ Get the factor names based on id or role \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-trt_names}{}}} \subsection{Method \code{trt_names()}}{ +Get the treatment names \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$trt_names(id = NULL)}\if{html}{\out{
}} } @@ -432,6 +493,7 @@ Get the factor names based on id or role \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-rcrd_names}{}}} \subsection{Method \code{rcrd_names()}}{ +Get the record names. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$rcrd_names(id = NULL)}\if{html}{\out{
}} } @@ -460,7 +522,9 @@ id must be from the same fid \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} + +\item{\code{fid}}{The factor id.} } \if{html}{\out{}} } @@ -469,6 +533,7 @@ id must be from the same fid \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-unit_values}{}}} \subsection{Method \code{unit_values()}}{ +Get the unit values. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$unit_values(id = NULL, fid = NULL)}\if{html}{\out{
}} } @@ -477,6 +542,8 @@ id must be from the same fid \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} + +\item{\code{fid}}{The factor id.} } \if{html}{\out{
}} } @@ -485,6 +552,7 @@ id must be from the same fid \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-trt_values}{}}} \subsection{Method \code{trt_values()}}{ +Get the treatment values. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$trt_values(id = NULL, fid = NULL)}\if{html}{\out{
}} } @@ -493,6 +561,8 @@ id must be from the same fid \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} + +\item{\code{fid}}{The factor id.} } \if{html}{\out{
}} } @@ -501,6 +571,7 @@ id must be from the same fid \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-rcrd_values}{}}} \subsection{Method \code{rcrd_values()}}{ +Get the record values. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$rcrd_values(uid = NULL, fid = NULL)}\if{html}{\out{
}} } @@ -509,6 +580,8 @@ id must be from the same fid \if{html}{\out{
}} \describe{ \item{\code{uid}}{The unit level id} + +\item{\code{fid}}{The factor id.} } \if{html}{\out{
}} } @@ -531,12 +604,12 @@ Get the role of the vertex given the factor id } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_levels_id}{}}} -\subsection{Method \code{fct_levels_id()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_levels}{}}} +\subsection{Method \code{fct_levels()}}{ Get the levels for each factor \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_levels_id(id = NULL, name = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_levels(id = NULL, name = NULL, return = c("id", "value"))}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -544,25 +617,62 @@ Get the levels for each factor \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the node.} + +\item{\code{return}}{To return in "id" or "value" format.} } \if{html}{\out{}} } } \if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-fct_levels_value}{}}} -\subsection{Method \code{fct_levels_value()}}{ +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_levels_id_to_edbl_fct}{}}} +\subsection{Method \code{fct_levels_id_to_edbl_fct()}}{ +Factor levels to edble factor \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$fct_levels_value(id = NULL, name = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$fct_levels_id_to_edbl_fct(fct_levels, role)}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{id}}{The id of the corresponding node.} +\item{\code{fct_levels}}{The factor levels in id.} -\item{\code{name}}{The name of the vertex.} +\item{\code{role}}{The role for the node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_levels_id_to_value}{}}} +\subsection{Method \code{fct_levels_id_to_value()}}{ +Get the factor levels in value given id format +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_levels_id_to_value(fct_levels)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{fct_levels}}{A list of factor levels in id format.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-fct_levels_value_to_id}{}}} +\subsection{Method \code{fct_levels_value_to_id()}}{ +Get the factor levels in id given value format. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$fct_levels_value_to_id(fct_levels)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{fct_levels}}{A list of factor levels in id format.} } \if{html}{\out{
}} } @@ -583,11 +693,11 @@ the intersection of it will be checked. \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} -\item{\code{abort}}{A logical value to indicate whether to abort if it doesn't exist.} +\item{\code{abort}}{Whether to abort.} } \if{html}{\out{}} } @@ -606,7 +716,7 @@ Check if treatment exists. \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the node.} \item{\code{abort}}{Whether to abort.} } @@ -627,7 +737,7 @@ Check if unit exists. \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the node.} \item{\code{abort}}{Whether to abort.} } @@ -648,27 +758,7 @@ Check if record exists. \describe{ \item{\code{id}}{The id of the corresponding node.} -\item{\code{name}}{The name of the vertex.} - -\item{\code{abort}}{Whether to abort.} -} -\if{html}{\out{}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-Provenance-lvl_exists}{}}} -\subsection{Method \code{lvl_exists()}}{ -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$lvl_exists(id = NULL, name = NULL, abort = TRUE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{id}}{The id of the corresponding node.} - -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the node.} \item{\code{abort}}{Whether to abort.} } @@ -687,9 +777,11 @@ Given node data, append the factor nodes \subsection{Arguments}{ \if{html}{\out{
}} \describe{ -\item{\code{name}}{The name of the vertex.} +\item{\code{name}}{The name of the node.} -\item{\code{role}}{The role for the vertex/node.} +\item{\code{role}}{The role for the node.} + +\item{\code{attrs}}{The attributes.} } \if{html}{\out{
}} } @@ -703,6 +795,17 @@ Given node data, append the level nodes \if{html}{\out{
}}\preformatted{Provenance$append_lvl_nodes(value, attrs = NULL, fid = NULL)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{value}}{The value of the node.} + +\item{\code{attrs}}{The attributes.} + +\item{\code{fid}}{The factor id.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} @@ -713,6 +816,21 @@ Given edge data, append the factor edges \if{html}{\out{
}}\preformatted{Provenance$append_fct_edges(from, to, type = NULL, group = NULL, attrs = NULL)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{from}}{The node id from.} + +\item{\code{to}}{The node id to.} + +\item{\code{type}}{The type of edges.} + +\item{\code{group}}{The group id.} + +\item{\code{attrs}}{The attributes.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} @@ -723,19 +841,71 @@ Given edge data, append the level edges \if{html}{\out{
}}\preformatted{Provenance$append_lvl_edges(from, to, attrs = NULL)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{from}}{The node id from.} + +\item{\code{to}}{The node id to.} + +\item{\code{attrs}}{The attributes.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-serve_units}{}}} \subsection{Method \code{serve_units()}}{ +Serve the units. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$serve_units(id = NULL)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$serve_units(id = NULL, return = c("id", "value"))}\if{html}{\out{
}} } \subsection{Arguments}{ \if{html}{\out{
}} \describe{ \item{\code{id}}{The id of the corresponding node.} + +\item{\code{return}}{To return in "id" or "value" format.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-serve_trts}{}}} +\subsection{Method \code{serve_trts()}}{ +Serve treatments +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$serve_trts(id = NULL, return = c("id", "value"))}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{return}}{To return in "id" or "value" format.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-serve_rcrds}{}}} +\subsection{Method \code{serve_rcrds()}}{ +Serve records +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$serve_rcrds(id = NULL, return = c("id", "value"))}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} + +\item{\code{return}}{To return in "id" or "value" format.} } \if{html}{\out{
}} } @@ -744,6 +914,7 @@ Given edge data, append the level edges \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-graph_subset}{}}} \subsection{Method \code{graph_subset()}}{ +Subset graph \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$graph_subset( id = NULL, @@ -770,24 +941,51 @@ subsetted graph \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-save_seed}{}}} \subsection{Method \code{save_seed()}}{ +Save the seed \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$save_seed(seed)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{seed}}{A seed.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-get_title}{}}} \subsection{Method \code{get_title()}}{ +Get the title \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$get_title()}\if{html}{\out{
}} } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-get_validation}{}}} +\subsection{Method \code{get_validation()}}{ +Get the validation +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$get_validation(type)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{type}}{A type.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-get_trail}{}}} \subsection{Method \code{get_trail()}}{ +Get the trail. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$get_trail()}\if{html}{\out{
}} } @@ -797,6 +995,7 @@ subsetted graph \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-get_graph}{}}} \subsection{Method \code{get_graph()}}{ +Get the graph \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$get_graph()}\if{html}{\out{
}} } @@ -806,6 +1005,7 @@ subsetted graph \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-get_seed}{}}} \subsection{Method \code{get_seed()}}{ +Get the seed \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$get_seed()}\if{html}{\out{
}} } @@ -815,6 +1015,7 @@ subsetted graph \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-get_session_info}{}}} \subsection{Method \code{get_session_info()}}{ +Get the session information \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$get_session_info()}\if{html}{\out{
}} } @@ -824,6 +1025,7 @@ subsetted graph \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-get_edibble_version}{}}} \subsection{Method \code{get_edibble_version()}}{ +Get the edibble version. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$get_edibble_version()}\if{html}{\out{
}} } @@ -833,6 +1035,7 @@ subsetted graph \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-record_step}{}}} \subsection{Method \code{record_step()}}{ +Record step. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$record_step()}\if{html}{\out{
}} } @@ -842,10 +1045,18 @@ subsetted graph \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-record_track_external}{}}} \subsection{Method \code{record_track_external()}}{ +Record track external. \subsection{Usage}{ \if{html}{\out{
}}\preformatted{Provenance$record_track_external(code)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{code}}{The code to record.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/allot_table.Rd b/man/allot_table.Rd index 05b8a67d..4b86e70a 100644 --- a/man/allot_table.Rd +++ b/man/allot_table.Rd @@ -9,7 +9,8 @@ allot_table( ..., order = "random", seed = NULL, - constrain = nesting_structure(.edibble) + constrain = nesting_structure(.edibble), + .record = TRUE ) } \description{ diff --git a/man/allot_trts.Rd b/man/allot_trts.Rd index 11899414..ed5ec7f4 100644 --- a/man/allot_trts.Rd +++ b/man/allot_trts.Rd @@ -7,9 +7,7 @@ allot_trts(.edibble, ..., .record = TRUE) } \arguments{ -\item{.edibble}{An edibble design (\code{edbl_design}), an edibble data frame (\code{edbl_table}) or an -object that contains the edibble data frame in the attribute -\code{design}.} +\item{.edibble}{An edibble design which should have units, treatments and allotment defined.} \item{...}{One-sided or two-sided formula. If the input is a one-sided formula then the whole treatment is applied to the specified unit.} diff --git a/man/allot_units.Rd b/man/allot_units.Rd index 56a47df4..60c2ae36 100644 --- a/man/allot_units.Rd +++ b/man/allot_units.Rd @@ -7,9 +7,7 @@ allot_units(.edibble, ..., .record = TRUE) } \arguments{ -\item{.edibble}{An edibble design (\code{edbl_design}), an edibble data frame (\code{edbl_table}) or an -object that contains the edibble data frame in the attribute -\code{design}.} +\item{.edibble}{An edibble design which should have units, treatments and allotment defined.} \item{...}{A two-sided formula.} diff --git a/man/assign.Rd b/man/assign.Rd index 199cb490..0e41b6f2 100644 --- a/man/assign.Rd +++ b/man/assign.Rd @@ -7,25 +7,25 @@ \title{Assign treatments or units to units} \usage{ assign_trts( - .design, + .edibble, order = "random", seed = NULL, - constrain = nesting_structure(.design), + constrain = nesting_structure(.edibble), ..., .record = TRUE ) assign_units( - .design, + .edibble, order = "random", seed = NULL, - constrain = nesting_structure(.design), + constrain = nesting_structure(.edibble), ..., .record = TRUE ) } \arguments{ -\item{.design}{An edibble design which should have units, treatments and allotment defined.} +\item{.edibble}{An edibble design which should have units, treatments and allotment defined.} \item{order}{A character vector signifying the apportion of treatments to units. The value should be either "random", "systematic", "systematic-random" or a class name corresponding to the algorithm for order_trts(). diff --git a/man/crossed_by.Rd b/man/crossed_by.Rd index 53449408..12ae7baf 100644 --- a/man/crossed_by.Rd +++ b/man/crossed_by.Rd @@ -4,26 +4,11 @@ \alias{crossed_by} \title{Specify the units to cross to index a new unit} \usage{ -crossed_by( - ..., - prefix = NULL, - suffix = NULL, - leading0 = NULL, - sep = NULL, - attrs = NULL -) +crossed_by(..., attrs = NULL) } \arguments{ \item{...}{a sequence of units} -\item{prefix}{Currently not implemented.The prefix of the label.} - -\item{suffix}{Currently not implemented.The suffix of the label.} - -\item{leading0}{Currently not implemented.Whether there should be a leading 0 if labels are made.} - -\item{sep}{Currently not implemented.A separator added between prefix and the number if prefix is empty.} - \item{attrs}{Currently not implemented.} } \value{ diff --git a/man/expect_rcrds.Rd b/man/expect_rcrds.Rd index 4f591cab..12d93a26 100644 --- a/man/expect_rcrds.Rd +++ b/man/expect_rcrds.Rd @@ -4,7 +4,7 @@ \alias{expect_rcrds} \title{Set the expected values for recording variables} \usage{ -expect_rcrds(.edibble, ...) +expect_rcrds(.edibble, ..., .record = TRUE) } \arguments{ \item{.edibble}{An edibble design (\code{edbl_design}), an edibble data frame (\code{edbl_table}) or an @@ -14,6 +14,10 @@ object that contains the edibble data frame in the attribute \item{...}{Name-value pairs with the name belonging to the variable that are plan to be recorded from \code{set_rcrds()} and the values are the expected types and values set by helper functions, see \code{?expect-rcrds}.} + +\item{.record}{A logical value. This indicates whether to record this +code step. The default is TRUE. It should remain TRUE unless this +function is used as a wrapper in other code.} } \value{ An edibble design. diff --git a/man/extract-lvl-nodes.Rd b/man/extract-lvl-nodes.Rd new file mode 100644 index 00000000..3fe2ff63 --- /dev/null +++ b/man/extract-lvl-nodes.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/design.R +\name{extract-lvl-nodes} +\alias{extract-lvl-nodes} +\alias{$.edbl_lnodes} +\alias{[.edbl_lnodes} +\alias{[<-.edbl_lnodes} +\alias{[[.edbl_lnodes} +\alias{[[<-.edbl_lnodes} +\title{Extract or replace parts of the level nodes} +\usage{ +\method{$}{edbl_lnodes}(x, name) + +\method{[}{edbl_lnodes}(x, i, ...) + +\method{[}{edbl_lnodes}(x, i, ...) <- value + +\method{[[}{edbl_lnodes}(x, i, ...) + +\method{[[}{edbl_lnodes}(x, i, ...) <- value +} +\description{ +The level nodes are stored as a named list of nodes where the name +corresponds to the id of the corresponding factor. This makes the +access of level nodes slightly awkward. For example, to extract the +id of the level nodes, you have to iterate over every list. +} +\examples{ +crd <- takeout(menu_crd()) + + + +} diff --git a/man/serve_table.Rd b/man/serve_table.Rd index c355b080..33f14d85 100644 --- a/man/serve_table.Rd +++ b/man/serve_table.Rd @@ -4,7 +4,12 @@ \alias{serve_table} \title{Serve edibble table} \usage{ -serve_table(.edibble, use_labels = FALSE, ..., .record = TRUE) +serve_table( + .edibble, + use_labels = FALSE, + fail = c("error", "warn", "ignore"), + .record = TRUE +) } \arguments{ \item{.edibble}{An edibble design (\code{edbl_design}), an edibble data frame (\code{edbl_table}) or an @@ -13,7 +18,7 @@ object that contains the edibble data frame in the attribute \item{use_labels}{To show the labels instead of names.} -\item{...}{Either a name-value pair or a series of the names.} +\item{fail}{What to do when failing to convert graph to table.} \item{.record}{A logical value. This indicates whether to record this code step. The default is TRUE. It should remain TRUE unless this From 0b26115d5203c1f8171ece8393828379fa8acaa9 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sat, 19 Aug 2023 10:36:00 -0400 Subject: [PATCH 35/83] kitchen to prov --- R/edibble.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/edibble.R b/R/edibble.R index 6fcc8490..3768e4a4 100644 --- a/R/edibble.R +++ b/R/edibble.R @@ -187,8 +187,8 @@ as_edibble.default <- function(.data, ...) { #' @rdname new_edibble #' @export -edibble <- function(.data, name = NULL, .record = TRUE, seed = NULL, kitchen = Kitchen, ...) { - des <- design(name = name, .record = .record, seed = seed, kitchen = kitchen) +edibble <- function(.data, name = NULL, .record = TRUE, seed = NULL, provenance = Provenance$new(), ...) { + des <- design(name = name, .record = .record, seed = seed, provenance = provenance) new_edibble(.data, ..., design = des) } From 9dcb9aacbc9716c92b7e32f5428834101994db8f Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 09:50:18 -0400 Subject: [PATCH 36/83] update the output for scan menu --- R/menu.R | 32 +++++++++++++++++++------------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/R/menu.R b/R/menu.R index 1473d118..47640a7d 100644 --- a/R/menu.R +++ b/R/menu.R @@ -427,43 +427,49 @@ menu_hyper_graeco <- function(t = random_integer_small(), #' Find the short names of the named designs #' -#' @param pkgs A character vector containing the package names to search +#' @param packages A character vector containing the package names to search #' named designs from. By default it will search edibble and other packages loaded. -#' @return A character vector of the short names of the named menu designs. +#' @param exclude A character vector denoting the packages to exclude search from. +#' @return A data.frame with package, name, arguments, and full name. #' @examples #' scan_menu() #' @export -scan_menu <- function(pkgs = NULL) { +scan_menu <- function(packages = NULL, exclude = NULL) { # ignore searching in base pkgs base_pkgs <- c("stats", "graphics", "grDevices", "utils", "datasets", "methods", "base") - pkgs <- pkgs %||% setdiff(.packages(), base_pkgs) - pkgs <- unique(c(pkgs, "edibble")) # always add edibble whether it is loaded or not + packages <- packages %||% setdiff(.packages(), base_pkgs) + packages <- setdiff(packages, exclude) + packages <- unique(c(packages, "edibble")) # always add edibble whether it is loaded or not - ls_fns <- lapply(pkgs, function(pkg) { + ls_fns <- lapply(packages, function(pkg) { fns <- unclass(utils::lsf.str(envir = asNamespace(pkg), all = TRUE)) fns[grep("^menu_", fns)] }) - names(ls_fns) <- pkgs + names(ls_fns) <- packages ls_fns <- compact(ls_fns) pkg_names <- names(ls_fns) - short_names <- NULL + ret <- tibble::tibble(package = character(), + name = character(), + args = character(), + name_full = character()) for(i in seq_along(ls_fns)) { - cli_h2(pkg_names[i]) for(menu_fn in ls_fns[[i]]) { args <- as.list(formals(menu_fn)) des <- do.call(menu_fn, list()) tryCatch({ - short_names <- c(short_names, set_names(des$name, pkg_names[i])) - cli_li("{.pkg {des$name}} with the arguments {.field {names(args)}} - for a { .combine_words(des$name_full, fun = cli::style_bold, and = ' / ')}.") + ret <- tibble::add_row(ret, + package = pkg_names[i], + name = des$name, + args = paste0(names(args), collapse = ", "), + name_full = paste0(des$name_full, collapse = ", ")) }, error = function(x) { cli_li("{.pkg {gsub('menu_', '', menu_fn)}} seems to be {cli::col_red('unavailable')}.") }) } } - invisible(short_names) + ret } From c623a2b2e2375fa25b87ff39da77830815a99a34 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 10:08:29 -0400 Subject: [PATCH 37/83] fix rcrds --- R/rcrds.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/rcrds.R b/R/rcrds.R index 062c3bf0..6b67ac3f 100644 --- a/R/rcrds.R +++ b/R/rcrds.R @@ -85,7 +85,7 @@ expect_rcrds <- function(.edibble, ..., .record = TRUE) { dots_nms <- names(dots) rules_named <- map(dots[dots_nms!=""], eval_tidy) rules_unnamed <- map(dots[dots_nms==""], validate_rcrd, - rnames = prov$rcrd_names) + rnames = prov$rcrd_names()) rules_unnamed <- stats::setNames(rules_unnamed, map_chr(rules_unnamed, function(x) x$rcrd)) prov$set_validation(simplify_validation(c(rules_named, rules_unnamed)), type = "rcrds") From 6e895e28caa1a355e05ed306083c4bb923100f58 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 10:08:35 -0400 Subject: [PATCH 38/83] fix print --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index fd67754b..e334b622 100644 --- a/R/utils.R +++ b/R/utils.R @@ -103,7 +103,7 @@ print.edbl_design <- function(x, if("allot" %in% fedges$type) { cat(decorate_title("Allotment:\n")) allots <- fedges[fedges$type=="allot", ] - trts_to_units <- paste(fedges$var_from, "~", fedges$var_to) + trts_to_units <- paste(allots$var_from, "~", allots$var_to) # this is so it aligns the tilde position # it seems that it's automatically strips away the padding now # so below no longer works From bc3e050f4d56fdeea433a4e6548b7206805f16dc Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 10:08:55 -0400 Subject: [PATCH 39/83] fix snapshots in test --- tests/testthat/_snaps/menu.new.md | 254 +++++++++++++++++++++++++++++ tests/testthat/_snaps/nest.md | 4 +- tests/testthat/_snaps/rcrds.md | 135 +++++++++++++-- tests/testthat/_snaps/rcrds.new.md | 145 ---------------- 4 files changed, 373 insertions(+), 165 deletions(-) create mode 100644 tests/testthat/_snaps/menu.new.md delete mode 100644 tests/testthat/_snaps/rcrds.new.md diff --git a/tests/testthat/_snaps/menu.new.md b/tests/testthat/_snaps/menu.new.md new file mode 100644 index 00000000..70e99e75 --- /dev/null +++ b/tests/testthat/_snaps/menu.new.md @@ -0,0 +1,254 @@ +# crd + + Code + crd <- takeout(menu_crd(n = 24, t = 4, seed = 1)) + crd + Output + design("Completely Randomised Design") %>% + set_units(unit = 24) %>% + set_trts(trt = 4) %>% + allot_trts(trt ~ unit) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Completely Randomised Design + # An edibble: 24 x 2 + unit trt + * + 1 unit1 trt4 + 2 unit2 trt1 + 3 unit3 trt4 + 4 unit4 trt3 + 5 unit5 trt3 + 6 unit6 trt4 + 7 unit7 trt2 + 8 unit8 trt1 + 9 unit9 trt2 + 10 unit10 trt4 + # i 14 more rows + +# rcbd + + Code + rcbd <- takeout(menu_rcbd(r = 3, t = 5, seed = 1)) + rcbd + Output + design("Randomised Complete Block Design") %>% + set_units(block = 3, + unit = nested_in(block, 5)) %>% + set_trts(trt = 5) %>% + allot_trts(trt ~ unit) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Randomised Complete Block Design + # An edibble: 15 x 3 + block unit trt + * + 1 block1 unit01 trt3 + 2 block1 unit02 trt2 + 3 block1 unit03 trt4 + 4 block1 unit04 trt5 + 5 block1 unit05 trt1 + 6 block2 unit06 trt2 + 7 block2 unit07 trt1 + 8 block2 unit08 trt5 + 9 block2 unit09 trt3 + 10 block2 unit10 trt4 + 11 block3 unit11 trt1 + 12 block3 unit12 trt3 + 13 block3 unit13 trt4 + 14 block3 unit14 trt2 + 15 block3 unit15 trt5 + +# split + + Code + split <- takeout(menu_split(t1 = 3, t2 = 2, r = 2, seed = 1)) + split + Output + design("Split-Plot Design | Split-Unit Design") %>% + set_units(mainplot = 6, + subplot = nested_in(mainplot, 2)) %>% + set_trts(trt1 = 3, + trt2 = 2) %>% + allot_trts(trt1 ~ mainplot, + trt2 ~ subplot) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Split-Plot Design | Split-Unit Design + # An edibble: 12 x 4 + mainplot subplot trt1 trt2 + * + 1 mainplot1 subplot01 trt13 trt22 + 2 mainplot1 subplot02 trt13 trt21 + 3 mainplot2 subplot03 trt12 trt22 + 4 mainplot2 subplot04 trt12 trt21 + 5 mainplot3 subplot05 trt13 trt21 + 6 mainplot3 subplot06 trt13 trt22 + 7 mainplot4 subplot07 trt11 trt22 + 8 mainplot4 subplot08 trt11 trt21 + 9 mainplot5 subplot09 trt11 trt22 + 10 mainplot5 subplot10 trt11 trt21 + 11 mainplot6 subplot11 trt12 trt21 + 12 mainplot6 subplot12 trt12 trt22 + +# strip + + Code + strip <- takeout(menu_strip(t1 = 3, t2 = 2, r = 4, seed = 1)) + strip + Output + design("Strip-Plot Design | Strip-Unit Design") %>% + set_units(block = 4, + row = nested_in(block, 3), + col = nested_in(block, 2), + unit = nested_in(block, crossed_by(row, col))) %>% + set_trts(trt1 = 3, + trt2 = 2) %>% + allot_trts(trt1 ~ row, + trt2 ~ col) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Strip-Plot Design | Strip-Unit Design + # An edibble: 24 x 6 + block row col unit trt1 trt2 + * + 1 block1 row01 col1 unit01 trt12 trt21 + 2 block1 row02 col1 unit02 trt13 trt21 + 3 block1 row03 col1 unit03 trt11 trt21 + 4 block1 row01 col2 unit04 trt12 trt22 + 5 block1 row02 col2 unit05 trt13 trt22 + 6 block1 row03 col2 unit06 trt11 trt22 + 7 block2 row04 col3 unit07 trt12 trt22 + 8 block2 row05 col3 unit08 trt13 trt22 + 9 block2 row06 col3 unit09 trt11 trt22 + 10 block2 row04 col4 unit10 trt12 trt21 + # i 14 more rows + +# factorial + + Code + fac_crd <- takeout(menu_factorial(trt = c(2, 3, 4), design = "crd", r = 2, + seed = 1)) + fac_crd + Output + design("Factorial Design") %>% + set_units(unit = 48) %>% + set_trts(trt1 = 2, + trt2 = 3, + trt3 = 4) %>% + allot_trts(~unit) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Factorial Design + # An edibble: 48 x 4 + unit trt1 trt2 trt3 + * + 1 unit1 trt12 trt22 trt34 + 2 unit2 trt12 trt21 trt33 + 3 unit3 trt12 trt23 trt34 + 4 unit4 trt12 trt23 trt33 + 5 unit5 trt11 trt23 trt34 + 6 unit6 trt11 trt21 trt32 + 7 unit7 trt11 trt23 trt33 + 8 unit8 trt11 trt22 trt34 + 9 unit9 trt11 trt23 trt32 + 10 unit10 trt11 trt23 trt33 + # i 38 more rows + Code + fac_rcbd <- takeout(menu_factorial(trt = c(2, 3, 4), design = "rcbd", r = 2, + seed = 1)) + fac_rcbd + Output + design("Factorial Design with RCBD structure") %>% + set_units(block = 2, + unit = nested_in(block, 24)) %>% + set_trts(trt1 = 2, + trt2 = 3, + trt3 = 4) %>% + allot_trts(~unit) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Factorial Design with RCBD structure + # An edibble: 48 x 5 + block unit trt1 trt2 trt3 + * + 1 block1 unit01 trt11 trt23 trt31 + 2 block1 unit02 trt11 trt21 trt32 + 3 block1 unit03 trt12 trt23 trt34 + 4 block1 unit04 trt12 trt23 trt32 + 5 block1 unit05 trt12 trt21 trt33 + 6 block1 unit06 trt12 trt23 trt31 + 7 block1 unit07 trt12 trt22 trt33 + 8 block1 unit08 trt11 trt22 trt33 + 9 block1 unit09 trt12 trt21 trt31 + 10 block1 unit10 trt11 trt21 trt31 + # i 38 more rows + +# lsd + + Code + lsd <- takeout(menu_lsd(t = 10, seed = 1)) + lsd + Output + design("Latin Square Design") %>% + set_units(row = 10, + col = 10, + unit = crossed_by(row, col)) %>% + set_trts(trt = 10) %>% + allot_trts(trt ~ unit) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Latin Square Design + # An edibble: 100 x 4 + row col unit trt + * + 1 row1 col1 unit1 trt3 + 2 row2 col1 unit2 trt9 + 3 row3 col1 unit3 trt7 + 4 row4 col1 unit4 trt10 + 5 row5 col1 unit5 trt4 + 6 row6 col1 unit6 trt6 + 7 row7 col1 unit7 trt1 + 8 row8 col1 unit8 trt5 + 9 row9 col1 unit9 trt2 + 10 row10 col1 unit10 trt8 + # i 90 more rows + +# youden + + Code + youden <- takeout(menu_youden(nc = 7, t = 10, seed = 1)) + youden + Output + design("Youden Square Design") %>% + set_units(row = 10, + col = 7, + unit = crossed_by(row, col)) %>% + set_trts(trt = 10) %>% + allot_trts(trt ~ unit) %>% + assign_trts("random", seed = 1) %>% + serve_table() + + # Youden Square Design + # An edibble: 70 x 4 + row col unit trt + * + 1 row1 col1 unit1 trt3 + 2 row2 col1 unit2 trt9 + 3 row3 col1 unit3 trt7 + 4 row4 col1 unit4 trt10 + 5 row5 col1 unit5 trt4 + 6 row6 col1 unit6 trt6 + 7 row7 col1 unit7 trt1 + 8 row8 col1 unit8 trt5 + 9 row9 col1 unit9 trt2 + 10 row10 col1 unit10 trt8 + # i 60 more rows + diff --git a/tests/testthat/_snaps/nest.md b/tests/testthat/_snaps/nest.md index fb9309fc..017b587f 100644 --- a/tests/testthat/_snaps/nest.md +++ b/tests/testthat/_snaps/nest.md @@ -6,6 +6,6 @@ des1 Output An edibble design - +-block (3 levels) - \-plot (6 levels) + \-block (3 levels) + \-plot (6 levels) diff --git a/tests/testthat/_snaps/rcrds.md b/tests/testthat/_snaps/rcrds.md index b74a35f5..3d70e702 100644 --- a/tests/testthat/_snaps/rcrds.md +++ b/tests/testthat/_snaps/rcrds.md @@ -3,7 +3,7 @@ Code des0 %>% set_rcrds(exam_mark = student, room = class) %>% serve_table() Output - # Effective teaching + # Effective teaching # An edibble: 120 x 6 class student style exam exam_mark room @@ -34,11 +34,8 @@ \-room Allotment: Message - * class ~ student * style ~ class * exam ~ student - * exam_mark ~ student - * room ~ class --- @@ -79,15 +76,8 @@ \-teacher Allotment: Message - * class ~ student * style ~ class * exam ~ student - * exam_mark ~ student - * quiz1_mark ~ student - * quiz2_mark ~ student - * gender ~ student - * room ~ class - * teacher ~ class --- @@ -133,13 +123,122 @@ \-teacher Allotment: Message - * class ~ student * style ~ class * exam ~ student - * exam_mark ~ student - * quiz1_mark ~ student - * quiz2_mark ~ student - * gender ~ student - * room ~ class - * teacher ~ class + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: integer [0, 30] + * gender: factor [female, male, non-binary] + * teacher: text + * room: text + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: numeric [-Inf, 12) + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark < -1) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [-Inf, -1) + +--- + + Code + des2 %>% expect_rcrds(0 < exam_mark) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric (0, Inf] diff --git a/tests/testthat/_snaps/rcrds.new.md b/tests/testthat/_snaps/rcrds.new.md deleted file mode 100644 index c65c3bab..00000000 --- a/tests/testthat/_snaps/rcrds.new.md +++ /dev/null @@ -1,145 +0,0 @@ -# measure response - - Code - des0 %>% set_rcrds(exam_mark = student, room = class) %>% serve_table() - Output - # Effective teaching - # An edibble: 120 x 6 - class student style exam exam_mark room - - 1 class1 student001 traditional closed-book o o - 2 class1 student002 traditional closed-book o x - 3 class1 student003 traditional take-home o x - 4 class1 student004 traditional take-home o x - 5 class1 student005 traditional open-book o x - 6 class1 student006 traditional take-home o x - 7 class1 student007 traditional take-home o x - 8 class1 student008 traditional closed-book o x - 9 class1 student009 traditional closed-book o x - 10 class1 student010 traditional open-book o x - # i 110 more rows - ---- - - Code - des1 <- des0 %>% set_rcrds(exam_mark = student, room = class) - des1 - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | \-exam_mark - +-style (2 levels) - \-room - Allotment: - Message - * class ~ student - * style ~ class - * exam ~ student - * exam_mark ~ student - * room ~ class - ---- - - Code - serve_table(des1) - Output - # Effective teaching - # An edibble: 120 x 6 - class student style exam exam_mark room - - 1 class1 student001 traditional closed-book o o - 2 class1 student002 traditional closed-book o x - 3 class1 student003 traditional take-home o x - 4 class1 student004 traditional take-home o x - 5 class1 student005 traditional open-book o x - 6 class1 student006 traditional take-home o x - 7 class1 student007 traditional take-home o x - 8 class1 student008 traditional closed-book o x - 9 class1 student009 traditional closed-book o x - 10 class1 student010 traditional open-book o x - # i 110 more rows - ---- - - Code - des2 - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * class ~ student - * style ~ class - * exam ~ student - * exam_mark ~ student - * quiz1_mark ~ student - * quiz2_mark ~ student - * gender ~ student - * room ~ class - * teacher ~ class - ---- - - Code - serve_table(des2) - Output - # Effective teaching - # An edibble: 120 x 10 - class student style exam exam_mark quiz1_mark quiz2_mark - - 1 class1 student001 traditional closed-book o o o - 2 class1 student002 traditional closed-book o o o - 3 class1 student003 traditional take-home o o o - 4 class1 student004 traditional take-home o o o - 5 class1 student005 traditional open-book o o o - 6 class1 student006 traditional take-home o o o - 7 class1 student007 traditional take-home o o o - 8 class1 student008 traditional closed-book o o o - 9 class1 student009 traditional closed-book o o o - 10 class1 student010 traditional open-book o o o - # i 110 more rows - # i 3 more variables: gender , room , teacher - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( - with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", - "male", "non-binary")), teacher = to_be_character(length = with_value("<=", - 100)), room = to_be_character(length = with_value(">=", 1))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * class ~ student - * style ~ class - * exam ~ student - * exam_mark ~ student - * quiz1_mark ~ student - * quiz2_mark ~ student - * gender ~ student - * room ~ class - * teacher ~ class - From 7ac1ce3f9ebb12a645645eb0cab9cb680f0fb3bd Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 10:09:31 -0400 Subject: [PATCH 40/83] delete new menu snapshot --- tests/testthat/_snaps/menu.new.md | 254 ------------------------------ 1 file changed, 254 deletions(-) delete mode 100644 tests/testthat/_snaps/menu.new.md diff --git a/tests/testthat/_snaps/menu.new.md b/tests/testthat/_snaps/menu.new.md deleted file mode 100644 index 70e99e75..00000000 --- a/tests/testthat/_snaps/menu.new.md +++ /dev/null @@ -1,254 +0,0 @@ -# crd - - Code - crd <- takeout(menu_crd(n = 24, t = 4, seed = 1)) - crd - Output - design("Completely Randomised Design") %>% - set_units(unit = 24) %>% - set_trts(trt = 4) %>% - allot_trts(trt ~ unit) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Completely Randomised Design - # An edibble: 24 x 2 - unit trt - * - 1 unit1 trt4 - 2 unit2 trt1 - 3 unit3 trt4 - 4 unit4 trt3 - 5 unit5 trt3 - 6 unit6 trt4 - 7 unit7 trt2 - 8 unit8 trt1 - 9 unit9 trt2 - 10 unit10 trt4 - # i 14 more rows - -# rcbd - - Code - rcbd <- takeout(menu_rcbd(r = 3, t = 5, seed = 1)) - rcbd - Output - design("Randomised Complete Block Design") %>% - set_units(block = 3, - unit = nested_in(block, 5)) %>% - set_trts(trt = 5) %>% - allot_trts(trt ~ unit) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Randomised Complete Block Design - # An edibble: 15 x 3 - block unit trt - * - 1 block1 unit01 trt3 - 2 block1 unit02 trt2 - 3 block1 unit03 trt4 - 4 block1 unit04 trt5 - 5 block1 unit05 trt1 - 6 block2 unit06 trt2 - 7 block2 unit07 trt1 - 8 block2 unit08 trt5 - 9 block2 unit09 trt3 - 10 block2 unit10 trt4 - 11 block3 unit11 trt1 - 12 block3 unit12 trt3 - 13 block3 unit13 trt4 - 14 block3 unit14 trt2 - 15 block3 unit15 trt5 - -# split - - Code - split <- takeout(menu_split(t1 = 3, t2 = 2, r = 2, seed = 1)) - split - Output - design("Split-Plot Design | Split-Unit Design") %>% - set_units(mainplot = 6, - subplot = nested_in(mainplot, 2)) %>% - set_trts(trt1 = 3, - trt2 = 2) %>% - allot_trts(trt1 ~ mainplot, - trt2 ~ subplot) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Split-Plot Design | Split-Unit Design - # An edibble: 12 x 4 - mainplot subplot trt1 trt2 - * - 1 mainplot1 subplot01 trt13 trt22 - 2 mainplot1 subplot02 trt13 trt21 - 3 mainplot2 subplot03 trt12 trt22 - 4 mainplot2 subplot04 trt12 trt21 - 5 mainplot3 subplot05 trt13 trt21 - 6 mainplot3 subplot06 trt13 trt22 - 7 mainplot4 subplot07 trt11 trt22 - 8 mainplot4 subplot08 trt11 trt21 - 9 mainplot5 subplot09 trt11 trt22 - 10 mainplot5 subplot10 trt11 trt21 - 11 mainplot6 subplot11 trt12 trt21 - 12 mainplot6 subplot12 trt12 trt22 - -# strip - - Code - strip <- takeout(menu_strip(t1 = 3, t2 = 2, r = 4, seed = 1)) - strip - Output - design("Strip-Plot Design | Strip-Unit Design") %>% - set_units(block = 4, - row = nested_in(block, 3), - col = nested_in(block, 2), - unit = nested_in(block, crossed_by(row, col))) %>% - set_trts(trt1 = 3, - trt2 = 2) %>% - allot_trts(trt1 ~ row, - trt2 ~ col) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Strip-Plot Design | Strip-Unit Design - # An edibble: 24 x 6 - block row col unit trt1 trt2 - * - 1 block1 row01 col1 unit01 trt12 trt21 - 2 block1 row02 col1 unit02 trt13 trt21 - 3 block1 row03 col1 unit03 trt11 trt21 - 4 block1 row01 col2 unit04 trt12 trt22 - 5 block1 row02 col2 unit05 trt13 trt22 - 6 block1 row03 col2 unit06 trt11 trt22 - 7 block2 row04 col3 unit07 trt12 trt22 - 8 block2 row05 col3 unit08 trt13 trt22 - 9 block2 row06 col3 unit09 trt11 trt22 - 10 block2 row04 col4 unit10 trt12 trt21 - # i 14 more rows - -# factorial - - Code - fac_crd <- takeout(menu_factorial(trt = c(2, 3, 4), design = "crd", r = 2, - seed = 1)) - fac_crd - Output - design("Factorial Design") %>% - set_units(unit = 48) %>% - set_trts(trt1 = 2, - trt2 = 3, - trt3 = 4) %>% - allot_trts(~unit) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Factorial Design - # An edibble: 48 x 4 - unit trt1 trt2 trt3 - * - 1 unit1 trt12 trt22 trt34 - 2 unit2 trt12 trt21 trt33 - 3 unit3 trt12 trt23 trt34 - 4 unit4 trt12 trt23 trt33 - 5 unit5 trt11 trt23 trt34 - 6 unit6 trt11 trt21 trt32 - 7 unit7 trt11 trt23 trt33 - 8 unit8 trt11 trt22 trt34 - 9 unit9 trt11 trt23 trt32 - 10 unit10 trt11 trt23 trt33 - # i 38 more rows - Code - fac_rcbd <- takeout(menu_factorial(trt = c(2, 3, 4), design = "rcbd", r = 2, - seed = 1)) - fac_rcbd - Output - design("Factorial Design with RCBD structure") %>% - set_units(block = 2, - unit = nested_in(block, 24)) %>% - set_trts(trt1 = 2, - trt2 = 3, - trt3 = 4) %>% - allot_trts(~unit) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Factorial Design with RCBD structure - # An edibble: 48 x 5 - block unit trt1 trt2 trt3 - * - 1 block1 unit01 trt11 trt23 trt31 - 2 block1 unit02 trt11 trt21 trt32 - 3 block1 unit03 trt12 trt23 trt34 - 4 block1 unit04 trt12 trt23 trt32 - 5 block1 unit05 trt12 trt21 trt33 - 6 block1 unit06 trt12 trt23 trt31 - 7 block1 unit07 trt12 trt22 trt33 - 8 block1 unit08 trt11 trt22 trt33 - 9 block1 unit09 trt12 trt21 trt31 - 10 block1 unit10 trt11 trt21 trt31 - # i 38 more rows - -# lsd - - Code - lsd <- takeout(menu_lsd(t = 10, seed = 1)) - lsd - Output - design("Latin Square Design") %>% - set_units(row = 10, - col = 10, - unit = crossed_by(row, col)) %>% - set_trts(trt = 10) %>% - allot_trts(trt ~ unit) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Latin Square Design - # An edibble: 100 x 4 - row col unit trt - * - 1 row1 col1 unit1 trt3 - 2 row2 col1 unit2 trt9 - 3 row3 col1 unit3 trt7 - 4 row4 col1 unit4 trt10 - 5 row5 col1 unit5 trt4 - 6 row6 col1 unit6 trt6 - 7 row7 col1 unit7 trt1 - 8 row8 col1 unit8 trt5 - 9 row9 col1 unit9 trt2 - 10 row10 col1 unit10 trt8 - # i 90 more rows - -# youden - - Code - youden <- takeout(menu_youden(nc = 7, t = 10, seed = 1)) - youden - Output - design("Youden Square Design") %>% - set_units(row = 10, - col = 7, - unit = crossed_by(row, col)) %>% - set_trts(trt = 10) %>% - allot_trts(trt ~ unit) %>% - assign_trts("random", seed = 1) %>% - serve_table() - - # Youden Square Design - # An edibble: 70 x 4 - row col unit trt - * - 1 row1 col1 unit1 trt3 - 2 row2 col1 unit2 trt9 - 3 row3 col1 unit3 trt7 - 4 row4 col1 unit4 trt10 - 5 row5 col1 unit5 trt4 - 6 row6 col1 unit6 trt6 - 7 row7 col1 unit7 trt1 - 8 row8 col1 unit8 trt5 - 9 row9 col1 unit9 trt2 - 10 row10 col1 unit10 trt8 - # i 60 more rows - From 97ca843c7c70ee7a11a3d78d15a408f6aef5a90d Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 12:32:48 -0400 Subject: [PATCH 41/83] add is_provenance function --- R/provenance.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/R/provenance.R b/R/provenance.R index 2f900ce7..e2224f0f 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -906,3 +906,18 @@ Provenance <- R6::R6Class("Provenance", new_edibble_graph(fnodes = fnodes, lnodes = lnodes, fedges = fedges, ledges = ledges) } )) + + +#' Check if an object is an instance of the "Provenance" class. +#' +#' This function determines whether the given object is an instance of the +#' "Provenance" class. +#' +#' @param x An object to be checked for its class membership. +#' +#' @return \code{TRUE} if the object is an instance of the "Provenance" class, +#' \code{FALSE} otherwise. +#' @export +is_provenance <- function(x) { + inherits(x, "Provenance") +} From b76ff88caf95f6d15b05349fb5a8bf7607faa728 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 13:08:31 -0400 Subject: [PATCH 42/83] update the external fct_nodes, fct_edges, lvl_nodes, lvl_edges commands --- R/graph.R | 48 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 35 insertions(+), 13 deletions(-) diff --git a/R/graph.R b/R/graph.R index 7d3c2aa0..ef880ed6 100644 --- a/R/graph.R +++ b/R/graph.R @@ -37,33 +37,55 @@ NULL #' @rdname design_data #' @export -fct_nodes <- function(edibble) { - prov <- activate_provenance(edibble) - prov$fct_nodes +fct_nodes <- function(x) { + prov <- get_provenance(x) + fnodes <- prov$fct_nodes + fnodes[, c("name", "role", "attrs")] } #' @rdname design_data #' @export -fct_edges <- function(edibble) { - prov <- activate_provenance(edibble) - prov$fct_edges +fct_edges <- function(x) { + prov <- get_provenance(x) + fedges <- prov$fct_edges + fedges[, c("var_from", "var_to", "type", "group", "attrs")] } - #' @rdname design_data #' @export -lvl_nodes <- function(edibble) { - prov <- activate_provenance(edibble) - prov$lvl_nodes +lvl_nodes <- function(x) { + prov <- get_provenance(x) + lnodes <- prov$lvl_nodes + lnodes <- lapply(lnodes, function(x) x[, "value", drop = FALSE]) + names(lnodes) <- prov$fct_names(id = as.numeric(names(lnodes))) + lnodes } #' @rdname design_data #' @export -lvl_edges <- function(edibble) { - prov <- activate_provenance(edibble) - prov$lvl_edges +lvl_edges <- function(x) { + prov <- get_provenance(x) + ledges <- prov$lvl_edges + lnodes <- prov$lvl_nodes + lnodes_df <- do.call("rbind", lapply(names(lnodes), function(x) data.frame(fid = as.numeric(x), id = lnodes[[x]]$id))) + ledges$var_from <- prov$fct_names(id = lnodes_df[match(ledges$from, lnodes_df$id), "fid"]) + ledges$var_to <- prov$fct_names(id = lnodes_df[match(ledges$to, lnodes_df$id), "fid"]) + ledges <- split(ledges, paste(ledges$var_from, "->", ledges$var_to)) + lapply(ledges, function(df) { + df$val_from <- prov$lvl_values(id = df$from, fid = prov$fct_id(name = df$var_from[1])) + df$val_to <- prov$lvl_values(id = df$to, fid = prov$fct_id(name = df$var_to[1])) + df[, c("var_from", "var_to", "val_from", "val_to", "attrs")] + }) } +get_provenance <- function(x) { + if(is_provenance(x)) { + x + } else { + not_edibble(x) + activate_provenance(x) + } +} From c603fc811901e48190f84c2fab3e60092adec38c Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 13:08:41 -0400 Subject: [PATCH 43/83] fix takeout --- R/menu.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/menu.R b/R/menu.R index 47640a7d..2d010aad 100644 --- a/R/menu.R +++ b/R/menu.R @@ -503,7 +503,7 @@ scan_menu <- function(packages = NULL, exclude = NULL) { takeout <- function(recipe = NULL, show = TRUE) { if(is.null(recipe)) { cli::cli_alert("No name was supplied so selecting a random named experimental design...") - name <- sample(suppressMessages(scan_menu()), 1L) + name <- sample(scan_menu()$name, 1L) recipe <- do.call(paste0("menu_", name), list()) cli::cli_alert(sprintf("Selected %s", recipe$name_full)) } From b40d36f48ffc0d122b892849bfb5be873bf4c99e Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 13:08:59 -0400 Subject: [PATCH 44/83] fixes in allot --- R/allot.R | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/R/allot.R b/R/allot.R index 86574133..8c27f219 100644 --- a/R/allot.R +++ b/R/allot.R @@ -79,7 +79,8 @@ allot_trts <- function(.edibble, ..., .record = TRUE) { #' @export allot_units <- function(.edibble, ..., .record = TRUE) { not_edibble(.edibble) - if(.record) record_step() + prov <- activate_provenance(.edibble) + if(.record) prov$record_step() des <- edbl_design(.edibble) dots <- list2(...) @@ -88,7 +89,6 @@ allot_units <- function(.edibble, ..., .record = TRUE) { } else { des$allotment <- list(trts = NULL, units = dots) } - prov <- activate_provenance(des) for(ialloc in seq_along(dots)) { # there should be only one unit for `big` @@ -96,24 +96,23 @@ allot_units <- function(.edibble, ..., .record = TRUE) { small <- all.vars(f_rhs(dots[[ialloc]])) op <- as.character(as.list(f_rhs(dots[[ialloc]]))[[1]]) prov$fct_exists(name = small, role = "edbl_unit") - big_id <- prov$fct_id(big) + big_id <- prov$fct_id(name = big) prov$fct_exists(name = big, role = "edbl_unit") - small_id <- prov$fct_id(small) + small_id <- prov$fct_id(name = small) if(!op %in% c("crossed_by", "nested_in")) { - prov$append_fct_edges(data.frame(from = big_id, - to = small_id[length(small_id)], - type = "nest")) + prov$append_fct_edges(from = big_id, + to = small_id[length(small_id)], + type = "nest") if(length(small) > 1) { - prov$append_fct_edges(data.frame(from = big_id, - to = small_id[length(small_id) - 1], - type = "depends")) + prov$append_fct_edges(from = big_id, + to = small_id[length(small_id) - 1], + type = "depends") } - } } if(is_edibble_design(.edibble)) { - prov$design + return_edibble_with_graph(.edibble, prov) } else if(is_edibble_table(.edibble)) { # Note: for crossed and nested, it's the opposite -> small = big, not big = small. if(op %in% c("crossed_by", "nested_in")) { @@ -124,18 +123,17 @@ allot_units <- function(.edibble, ..., .record = TRUE) { if(op == "crossed_by") { cross_df <- expand.grid(from = small_id, to = small_id) cross_df <- cross_df[cross_df$from!=cross_df$to,] - cross_df$type <- "cross" - prov$append_fct_edges(cross_df) + prov$append_fct_edges(from = cross_df$from, to = cross_df$to, type = "cross") } - prov$append_lvl_edges(data.frame(from = prov$lvl_id(as.character(.edibble[[small[ismall]]])), - to = prov$lvl_id(as.character(.edibble[[big]])))) + prov$append_lvl_edges(from = prov$lvl_id(name = as.character(.edibble[[small[ismall]]])), + to = prov$lvl_id(name = as.character(.edibble[[big]]))) } } else { for(asmall in small) { - prov$append_lvl_edges(data.frame(from = prov$lvl_id(as.character(.edibble[[big]])), - to = prov$lvl_id(as.character(.edibble[[asmall]])))) + prov$append_lvl_edges(from = prov$lvl_id(name = as.character(.edibble[[big]])), + to = prov$lvl_id(name = as.character(.edibble[[asmall]]))) } } attr(.edibble, "design") <- prov$design From 213ff0a3a3e3bd7291e86be3d5b84d7888db412b Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 13:23:11 -0400 Subject: [PATCH 45/83] add testing for allot --- tests/testthat/test-allot.R | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 tests/testthat/test-allot.R diff --git a/tests/testthat/test-allot.R b/tests/testthat/test-allot.R new file mode 100644 index 00000000..dfcf0629 --- /dev/null +++ b/tests/testthat/test-allot.R @@ -0,0 +1,21 @@ +test_that("allot works", { + des1 <- design() %>% + set_units(block = 10, + plot = 20) %>% + allot_units(block ~ plot) + fedges1 <- fct_edges(des1) + expect_equal(fedges1$var_from, "block") + expect_equal(fedges1$var_to, "plot") + + + des2 <- design() %>% + set_units(block = 10, + plot = nested_in(block, 3)) %>% + set_trts(treat = c("A", "B", "C"), + pest = c("a", "b")) %>% + allot_trts(treat ~ plot, + pest ~ block) + fedges2 <- fct_edges(des2) + expect_equal(fedges2$var_from, c("block", "treat", "pest")) + expect_equal(fedges2$var_to, c("plot", "plot", "block")) +}) From 33cff29581a9963fc4ca0921522701ad3ca8ee4e Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 18:05:53 -0400 Subject: [PATCH 46/83] record call to edibble fn --- R/edibble.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/edibble.R b/R/edibble.R index 3768e4a4..c2fcf5eb 100644 --- a/R/edibble.R +++ b/R/edibble.R @@ -187,8 +187,9 @@ as_edibble.default <- function(.data, ...) { #' @rdname new_edibble #' @export -edibble <- function(.data, name = NULL, .record = TRUE, seed = NULL, provenance = Provenance$new(), ...) { - des <- design(name = name, .record = .record, seed = seed, provenance = provenance) +edibble <- function(.data, title = NULL, name = "edibble", .record = TRUE, seed = NULL, provenance = Provenance$new(), ...) { + if(.record) provenance$record_step() + des <- design(title = title, name = name, .record = FALSE, seed = seed, provenance = provenance) new_edibble(.data, ..., design = des) } From 14f603b7eabd1029e09b049fa670a69cc0fd170b Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 18:06:22 -0400 Subject: [PATCH 47/83] fix conversion to edibble variable in table --- R/fcts.R | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/R/fcts.R b/R/fcts.R index 0c549f95..b7c72252 100644 --- a/R/fcts.R +++ b/R/fcts.R @@ -33,19 +33,17 @@ set_fcts <- function(.edibble, ..., .class = NULL, } } else if(is_edibble_table(.edibble)) { - # FIXME - loc <- eval_select(expr(tidyselect::all_of(c(...))), .edibble) + + loc <- eval_select(expr(c(...)), .edibble) for(i in seq_along(loc)) { var <- .edibble[[loc[i]]] - lvls <- as.character(sort(unique(var))) + lvls <- sort(unique(var)) fname <- names(loc)[i] - .edibble[[loc[i]]] <- new_edibble_fct(labels = as.character(.edibble[[loc[[i]]]]), + .edibble[[loc[i]]] <- new_edibble_fct(labels = var, levels = lvls, class = .class, name = fname) - graph_input(.edibble[[loc[i]]], prov, fname, .class) - - + graph_input.default(lvls, prov, fname, .class) } } @@ -62,7 +60,7 @@ set_fcts <- function(.edibble, ..., .class = NULL, new_edibble_fct <- function(labels = character(), levels = unique(labels), name = character(), rep = NULL, ..., class = NULL) { x <- new_vctr(labels, levels = levels, name = name, - ..., class = c("edbl_fct", "character")) + ..., class = c("edbl_fct", class(labels))) class(x) <- c(class, class(x)) x } From 0a1dd0f45c8aa1e6ec93cb67bff5904b0f8cf87b Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 18:06:44 -0400 Subject: [PATCH 48/83] is.vector for ordinal returned false so use is_vector instead --- R/graph-input.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/graph-input.R b/R/graph-input.R index ede0895c..b9c22204 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -13,8 +13,8 @@ graph_input_type = function(input) { if(is_nest_levels(input)) return("nest_lvls") if(vec_is(input, numeric(), 1)) return("numeric") if(vec_is(input, integer(), 1)) return("numeric") - if(is.vector(input) && !is_named(input)) return("unnamed_vector") - if(is.vector(input) && is_named(input)) return("named_vector") + if(is_vector(input) && !is_named(input)) return("unnamed_vector") + if(is_vector(input) && is_named(input)) return("named_vector") return("unimplemented") } From c96af42dadfaae601497d8807511dd7d11d81011 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 18:07:35 -0400 Subject: [PATCH 49/83] new_edibble_fct has levels has character as default -- should be the type of value? --- R/serve.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/serve.R b/R/serve.R index 35294cfd..313ef55c 100644 --- a/R/serve.R +++ b/R/serve.R @@ -69,6 +69,7 @@ serve_vars_not_reconciled <- function(prov) { namesv <- prov$fct_names() res <- lapply(namesv, function(avar) { + # FIXME: labels should not necessary be character? new_edibble_fct(levels = prov$lvl_values(fid = prov$fct_id(name = avar)), name = avar, class = prov$fct_role(id = prov$fct_id(name = avar))) From 1121c11b9fca4b7f22d4c864149b14629a5a3240 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 18:08:03 -0400 Subject: [PATCH 50/83] hack to implement class type on row after pillar type print --- R/units.R | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/R/units.R b/R/units.R index 67e80274..399636dd 100644 --- a/R/units.R +++ b/R/units.R @@ -82,6 +82,36 @@ vec_cast.edbl_unit.edbl_unit <- function(x, to, ...) { x } +#' @importFrom pillar tbl_format_body +#' @export +tbl_format_body.edbl_table <- function(x, setup, ...) { + # this is a bit of a hack to get the type + # it probably should get the alignement from pillar + edbl_types <- cli::ansi_strip(setup$body[2]) + pos <- gregexpr(">", edbl_types)[[1]] + types <- map_chr(x, vec_ptype_abbr2) + string <- paste0(rep(" ", length.out = setup$width), collapse = "") + for(i in 1:length(types)) { + start <- pos[i] - length(types[i]) - 3 + end <- pos[i] + new <- paste0("<", types[i], ">") + if(substr(edbl_types, start, end) != new) substr(string, start, end) <- new + } + setup$body <- c(setup$body[1:2], cli::style_italic(cli::col_silver(string)), + setup$body[3:length(setup$body)]) + NextMethod() +} + +vec_ptype_abbr2 <- function(x, ...) { + cls <- class(x) + class(x) <- setdiff(cls, c("edbl_unit", "edbl_trt", "edbl_rcrd", "edbl_fct", "vctrs_vctr")) + vctrs::vec_ptype_abbr(x, ...) +} + + + + + ### below may not be working as intended #' @export From 48037d10d3ce784beb996a64829f760d950d4b09 Mon Sep 17 00:00:00 2001 From: Your Name Date: Sun, 20 Aug 2023 18:08:11 -0400 Subject: [PATCH 51/83] update doc and tests --- NAMESPACE | 3 + man/design_data.Rd | 8 +- man/is_provenance.Rd | 19 + man/new_edibble.Rd | 8 +- man/scan_menu.Rd | 8 +- tests/testthat/_snaps/edibble.md | 21 ++ tests/testthat/_snaps/menu.md | 8 + tests/testthat/_snaps/rcrds.md | 580 ++++++++++++++++++++++++++++- tests/testthat/_snaps/serve.new.md | 57 +++ tests/testthat/test-allot.R | 6 + tests/testthat/test-edibble.R | 5 + tests/testthat/test-nest.R | 25 +- tests/testthat/test-rcrds.R | 2 +- 13 files changed, 705 insertions(+), 45 deletions(-) create mode 100644 man/is_provenance.Rd create mode 100644 tests/testthat/_snaps/edibble.md create mode 100644 tests/testthat/_snaps/serve.new.md create mode 100644 tests/testthat/test-edibble.R diff --git a/NAMESPACE b/NAMESPACE index 6566cb37..82ba7ddf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,6 +32,7 @@ S3method(print,edbl_graph) S3method(print,edbl_table) S3method(print,recipe_design) S3method(print,takeout) +S3method(tbl_format_body,edbl_table) S3method(tbl_sum,edbl_table) S3method(tbl_sum,trck_table) S3method(vec_cast,character.edbl_fct) @@ -90,6 +91,7 @@ export(is_edibble_unit) export(is_edibble_var) export(is_named_design) export(is_nest_levels) +export(is_provenance) export(is_takeout) export(label_seq_from_length) export(label_seq_from_to) @@ -150,6 +152,7 @@ importFrom(magrittr,"%>%") importFrom(pillar,new_pillar_shaft_simple) importFrom(pillar,pillar_shaft) importFrom(pillar,style_subtle) +importFrom(pillar,tbl_format_body) importFrom(tibble,new_tibble) importFrom(tibble,tbl_sum) importFrom(tidyselect,eval_select) diff --git a/man/design_data.Rd b/man/design_data.Rd index d4795e7b..87a9b3a4 100644 --- a/man/design_data.Rd +++ b/man/design_data.Rd @@ -8,13 +8,13 @@ \alias{lvl_edges} \title{Get the node or edge data from an edibble design} \usage{ -fct_nodes(edibble) +fct_nodes(x) -fct_edges(edibble) +fct_edges(x) -lvl_nodes(edibble) +lvl_nodes(x) -lvl_edges(edibble) +lvl_edges(x) } \arguments{ \item{edibble}{An edibble object.} diff --git a/man/is_provenance.Rd b/man/is_provenance.Rd new file mode 100644 index 00000000..fa9237a7 --- /dev/null +++ b/man/is_provenance.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/provenance.R +\name{is_provenance} +\alias{is_provenance} +\title{Check if an object is an instance of the "Provenance" class.} +\usage{ +is_provenance(x) +} +\arguments{ +\item{x}{An object to be checked for its class membership.} +} +\value{ +\code{TRUE} if the object is an instance of the "Provenance" class, +\code{FALSE} otherwise. +} +\description{ +This function determines whether the given object is an instance of the +"Provenance" class. +} diff --git a/man/new_edibble.Rd b/man/new_edibble.Rd index cfcccf2e..8f4f1dd3 100644 --- a/man/new_edibble.Rd +++ b/man/new_edibble.Rd @@ -12,10 +12,11 @@ as_edibble(.data, ...) edibble( .data, - name = NULL, + title = NULL, + name = "edibble", .record = TRUE, seed = NULL, - kitchen = Kitchen, + provenance = Provenance$new(), ... ) } @@ -35,6 +36,9 @@ code step. The default is TRUE. It should remain TRUE unless this function is used as a wrapper in other code.} \item{seed}{A seed number for reproducibility.} + +\item{provenance}{An environment setup in a manner to store methods and +information to trace the origin of the design} } \value{ An edibble table. diff --git a/man/scan_menu.Rd b/man/scan_menu.Rd index 12977d3d..42de8e8d 100644 --- a/man/scan_menu.Rd +++ b/man/scan_menu.Rd @@ -4,14 +4,16 @@ \alias{scan_menu} \title{Find the short names of the named designs} \usage{ -scan_menu(pkgs = NULL) +scan_menu(packages = NULL, exclude = NULL) } \arguments{ -\item{pkgs}{A character vector containing the package names to search +\item{packages}{A character vector containing the package names to search named designs from. By default it will search edibble and other packages loaded.} + +\item{exclude}{A character vector denoting the packages to exclude search from.} } \value{ -A character vector of the short names of the named menu designs. +A data.frame with package, name, arguments, and full name. } \description{ Find the short names of the named designs diff --git a/tests/testthat/_snaps/edibble.md b/tests/testthat/_snaps/edibble.md new file mode 100644 index 00000000..a5fd9c47 --- /dev/null +++ b/tests/testthat/_snaps/edibble.md @@ -0,0 +1,21 @@ +# edibble works + + Code + edibble(ChickWeight) + Output + # An edibble: 578 x 4 + weight Time Chick Diet + + + 1 42 0 1 1 + 2 51 2 1 1 + 3 59 4 1 1 + 4 64 6 1 1 + 5 76 8 1 1 + 6 93 10 1 1 + 7 106 12 1 1 + 8 125 14 1 1 + 9 149 16 1 1 + 10 171 18 1 1 + # i 568 more rows + diff --git a/tests/testthat/_snaps/menu.md b/tests/testthat/_snaps/menu.md index cc956d07..dcaebeab 100644 --- a/tests/testthat/_snaps/menu.md +++ b/tests/testthat/_snaps/menu.md @@ -15,6 +15,7 @@ # An edibble: 24 x 2 unit trt * + 1 unit1 trt4 2 unit2 trt1 3 unit3 trt4 @@ -45,6 +46,7 @@ # An edibble: 15 x 3 block unit trt * + 1 block1 unit01 trt3 2 block1 unit02 trt2 3 block1 unit03 trt4 @@ -81,6 +83,7 @@ # An edibble: 12 x 4 mainplot subplot trt1 trt2 * + 1 mainplot1 subplot01 trt13 trt22 2 mainplot1 subplot02 trt13 trt21 3 mainplot2 subplot03 trt12 trt22 @@ -116,6 +119,7 @@ # An edibble: 24 x 6 block row col unit trt1 trt2 * + 1 block1 row01 col1 unit01 trt12 trt21 2 block1 row02 col1 unit02 trt13 trt21 3 block1 row03 col1 unit03 trt11 trt21 @@ -148,6 +152,7 @@ # An edibble: 48 x 4 unit trt1 trt2 trt3 * + 1 unit1 trt12 trt22 trt34 2 unit2 trt12 trt21 trt33 3 unit3 trt12 trt23 trt34 @@ -178,6 +183,7 @@ # An edibble: 48 x 5 block unit trt1 trt2 trt3 * + 1 block1 unit01 trt11 trt23 trt31 2 block1 unit02 trt11 trt21 trt32 3 block1 unit03 trt12 trt23 trt34 @@ -209,6 +215,7 @@ # An edibble: 100 x 4 row col unit trt * + 1 row1 col1 unit1 trt3 2 row2 col1 unit2 trt9 3 row3 col1 unit3 trt7 @@ -240,6 +247,7 @@ # An edibble: 70 x 4 row col unit trt * + 1 row1 col1 unit1 trt3 2 row2 col1 unit2 trt9 3 row3 col1 unit3 trt7 diff --git a/tests/testthat/_snaps/rcrds.md b/tests/testthat/_snaps/rcrds.md index 3d70e702..dec85e6b 100644 --- a/tests/testthat/_snaps/rcrds.md +++ b/tests/testthat/_snaps/rcrds.md @@ -3,10 +3,11 @@ Code des0 %>% set_rcrds(exam_mark = student, room = class) %>% serve_table() Output - # Effective teaching + # Effective teaching # An edibble: 120 x 6 class student style exam exam_mark room + 1 class1 student001 traditional closed-book o o 2 class1 student002 traditional closed-book o x 3 class1 student003 traditional take-home o x @@ -46,6 +47,7 @@ # An edibble: 120 x 6 class student style exam exam_mark room + 1 class1 student001 traditional closed-book o o 2 class1 student002 traditional closed-book o x 3 class1 student003 traditional take-home o x @@ -82,24 +84,566 @@ --- Code - serve_table(des2) + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( + with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", + "male", "non-binary")), teacher = to_be_character(length = with_value("<=", + 100)), room = to_be_character(length = with_value(">=", 1))) Output - # Effective teaching - # An edibble: 120 x 10 - class student style exam exam_mark quiz1_mark quiz2_mark - - 1 class1 student001 traditional closed-book o o o - 2 class1 student002 traditional closed-book o o o - 3 class1 student003 traditional take-home o o o - 4 class1 student004 traditional take-home o o o - 5 class1 student005 traditional open-book o o o - 6 class1 student006 traditional take-home o o o - 7 class1 student007 traditional take-home o o o - 8 class1 student008 traditional closed-book o o o - 9 class1 student009 traditional closed-book o o o - 10 class1 student010 traditional open-book o o o - # i 110 more rows - # i 3 more variables: gender , room , teacher + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: integer [0, 30] + * gender: factor [female, male, non-binary] + * teacher: text + * room: text + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: numeric [-Inf, 12) + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark < -1) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [-Inf, -1) + +--- + + Code + des2 %>% expect_rcrds(0 < exam_mark) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric (0, Inf] + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( + with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", + "male", "non-binary")), teacher = to_be_character(length = with_value("<=", + 100)), room = to_be_character(length = with_value(">=", 1))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: integer [0, 30] + * gender: factor [female, male, non-binary] + * teacher: text + * room: text + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: numeric [-Inf, 12) + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark < -1) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [-Inf, -1) + +--- + + Code + des2 %>% expect_rcrds(0 < exam_mark) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric (0, Inf] + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( + with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", + "male", "non-binary")), teacher = to_be_character(length = with_value("<=", + 100)), room = to_be_character(length = with_value(">=", 1))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: integer [0, 30] + * gender: factor [female, male, non-binary] + * teacher: text + * room: text + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: numeric [-Inf, 12) + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark < -1) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [-Inf, -1) + +--- + + Code + des2 %>% expect_rcrds(0 < exam_mark) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric (0, Inf] + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( + with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", + "male", "non-binary")), teacher = to_be_character(length = with_value("<=", + 100)), room = to_be_character(length = with_value(">=", 1))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: integer [0, 30] + * gender: factor [female, male, non-binary] + * teacher: text + * room: text + +--- + + Code + des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), + quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * quiz1_mark: integer [0, 15] + * quiz2_mark: numeric [-Inf, 12) + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( + "female", "male", "non-binary"))) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [0, 100] + * gender: factor [female, male, non-binary] + +--- + + Code + des2 %>% expect_rcrds(exam_mark < -1) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric [-Inf, -1) + +--- + + Code + des2 %>% expect_rcrds(0 < exam_mark) + Output + Effective teaching + +-class (4 levels) + | \-student (120 levels) + | +-exam (3 levels) + | +-exam_mark + | +-quiz1_mark + | +-quiz2_mark + | \-gender + +-style (2 levels) + +-room + \-teacher + Allotment: + Message + * style ~ class + * exam ~ student + Output + Validation: + Message + * exam_mark: numeric (0, Inf] --- diff --git a/tests/testthat/_snaps/serve.new.md b/tests/testthat/_snaps/serve.new.md new file mode 100644 index 00000000..c9f718bc --- /dev/null +++ b/tests/testthat/_snaps/serve.new.md @@ -0,0 +1,57 @@ +# serve + + Code + design(title = "one unit") %>% set_units(block = 3) %>% serve_table() + Output + # one unit + # An edibble: 3 x 1 + block + + + 1 block1 + 2 block2 + 3 block3 + +--- + + Code + design(title = "serve nested units") %>% set_units(block = 3, plot = nested_in( + block, 2)) %>% serve_table() + Output + # serve nested units + # An edibble: 6 x 2 + block plot + + + 1 block1 plot1 + 2 block1 plot2 + 3 block2 plot3 + 4 block2 plot4 + 5 block3 plot5 + 6 block3 plot6 + +--- + + Code + design() %>% set_units(site = 2, row = nested_in(site, 1 ~ 3, 2 ~ 2), col = nested_in( + site, 1 ~ 3, 2 ~ 2), plot = nested_in(site, ~ row:col)) %>% set_trts(trt = c( + "A", "B")) %>% allot_table(trt ~ plot, seed = 1) + Output + # An edibble: 13 x 5 + site row col plot trt + + + 1 site1 row1 col1 plot01 A + 2 site1 row2 col1 plot02 B + 3 site1 row3 col1 plot03 A + 4 site1 row1 col2 plot04 B + 5 site1 row2 col2 plot05 A + 6 site1 row3 col2 plot06 B + 7 site1 row1 col3 plot07 A + 8 site1 row2 col3 plot08 B + 9 site1 row3 col3 plot09 A + 10 site2 row4 col4 plot10 A + 11 site2 row5 col4 plot11 B + 12 site2 row4 col5 plot12 B + 13 site2 row5 col5 plot13 A + diff --git a/tests/testthat/test-allot.R b/tests/testthat/test-allot.R index dfcf0629..4ebdc71d 100644 --- a/tests/testthat/test-allot.R +++ b/tests/testthat/test-allot.R @@ -18,4 +18,10 @@ test_that("allot works", { fedges2 <- fct_edges(des2) expect_equal(fedges2$var_from, c("block", "treat", "pest")) expect_equal(fedges2$var_to, c("plot", "plot", "block")) + + df <- as.data.frame(takeout(menu_split())) + attr(df, "design") <- NULL + attr(df, "recipe") <- NULL + + }) diff --git a/tests/testthat/test-edibble.R b/tests/testthat/test-edibble.R new file mode 100644 index 00000000..ccafe600 --- /dev/null +++ b/tests/testthat/test-edibble.R @@ -0,0 +1,5 @@ +test_that("edibble works", { + + expect_snapshot(edibble(ChickWeight)) + +}) diff --git a/tests/testthat/test-nest.R b/tests/testthat/test-nest.R index 49801362..53f56b13 100644 --- a/tests/testthat/test-nest.R +++ b/tests/testthat/test-nest.R @@ -8,41 +8,32 @@ test_that("nested-units", { }) expect_equal(fct_nodes(des1), - tibble::tibble(id = c(1L, 2L), + tibble::tibble(name = c("block", "plot"), role = "edbl_unit", - name = c("block", "plot"), attrs = NA)) expect_equal(lvl_nodes(des1), - structure(list(`1` = tibble::tibble(id = 1:3, - value = c("block1", "block2", "block3")), - `2` = tibble::tibble(id = 4:9, - value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6"))), - class = c("edbl_lnodes", "list"))) + list(block = tibble::tibble(value = c("block1", "block2", "block3")), + plot = tibble::tibble(value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6"))) ) des2 <- des1 %>% set_units(sample = nested_in(plot, 1 ~ 20, . ~ 3)) expect_equal(fct_nodes(des2), - tibble::tibble(id = c(1L, 2L, 3L), + tibble::tibble(name = c("block", "plot", "sample"), role = "edbl_unit", - name = c("block", "plot", "sample"), attrs = NA)) expect_equal(lvl_nodes(des2), - structure(list(`1` = tibble::tibble(id = 1:3, - value = c("block1", "block2", "block3")), - `2` = tibble::tibble(id = 4:9, - value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6")), - `3` = tibble::tibble(id = 10:44, - value = c("sample01", "sample02", "sample03", + list(block = tibble::tibble(value = c("block1", "block2", "block3")), + plot = tibble::tibble(value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6")), + sample = tibble::tibble(value = c("sample01", "sample02", "sample03", "sample04", "sample05", "sample06", "sample07", "sample08", "sample09", "sample10", "sample11", "sample12", "sample13", "sample14", "sample15", "sample16", "sample17", "sample18", "sample19", "sample20", "sample21", "sample22", "sample23", "sample24", "sample25", "sample26", "sample27", "sample28", "sample29", "sample30", "sample31", "sample32", "sample33", - "sample34", "sample35"))), - class = c("edbl_lnodes", "list"))) + "sample34", "sample35")))) diff --git a/tests/testthat/test-rcrds.R b/tests/testthat/test-rcrds.R index 231bcc7a..cf70597c 100644 --- a/tests/testthat/test-rcrds.R +++ b/tests/testthat/test-rcrds.R @@ -1,5 +1,4 @@ test_that("measure response", { - # FIXME des0 <- design(title = "Effective teaching") %>% set_units(class = 4, @@ -39,6 +38,7 @@ test_that("measure response", { des2 }) + # FIXME: not sure why this fails expect_snapshot({ serve_table(des2) }) From 145fb96396e9da68efc63ead316bfd25d5800af6 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 26 Aug 2023 16:34:14 -0400 Subject: [PATCH 52/83] fixed the print issue --- R/units.R | 4 +- tests/testthat/_snaps/rcrds.md | 579 ++------------------------------- tests/testthat/test-rcrds.R | 1 - 3 files changed, 22 insertions(+), 562 deletions(-) diff --git a/R/units.R b/R/units.R index 399636dd..8a3f6e70 100644 --- a/R/units.R +++ b/R/units.R @@ -88,10 +88,12 @@ tbl_format_body.edbl_table <- function(x, setup, ...) { # this is a bit of a hack to get the type # it probably should get the alignement from pillar edbl_types <- cli::ansi_strip(setup$body[2]) + # pos is shorter than types, since it is limited to print width + # note if class abbreviation contains ">", it will be an issue below pos <- gregexpr(">", edbl_types)[[1]] types <- map_chr(x, vec_ptype_abbr2) string <- paste0(rep(" ", length.out = setup$width), collapse = "") - for(i in 1:length(types)) { + for(i in 1:length(pos)) { start <- pos[i] - length(types[i]) - 3 end <- pos[i] new <- paste0("<", types[i], ">") diff --git a/tests/testthat/_snaps/rcrds.md b/tests/testthat/_snaps/rcrds.md index dec85e6b..0fa6fec4 100644 --- a/tests/testthat/_snaps/rcrds.md +++ b/tests/testthat/_snaps/rcrds.md @@ -3,7 +3,7 @@ Code des0 %>% set_rcrds(exam_mark = student, room = class) %>% serve_table() Output - # Effective teaching + # Effective teaching # An edibble: 120 x 6 class student style exam exam_mark room @@ -84,566 +84,25 @@ --- Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( - with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", - "male", "non-binary")), teacher = to_be_character(length = with_value("<=", - 100)), room = to_be_character(length = with_value(">=", 1))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: integer [0, 30] - * gender: factor [female, male, non-binary] - * teacher: text - * room: text - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: numeric [-Inf, 12) - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark < -1) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [-Inf, -1) - ---- - - Code - des2 %>% expect_rcrds(0 < exam_mark) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric (0, Inf] - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( - with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", - "male", "non-binary")), teacher = to_be_character(length = with_value("<=", - 100)), room = to_be_character(length = with_value(">=", 1))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: integer [0, 30] - * gender: factor [female, male, non-binary] - * teacher: text - * room: text - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: numeric [-Inf, 12) - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark < -1) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student + serve_table(des2) Output - Validation: - Message - * exam_mark: numeric [-Inf, -1) - ---- - - Code - des2 %>% expect_rcrds(0 < exam_mark) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric (0, Inf] - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( - with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", - "male", "non-binary")), teacher = to_be_character(length = with_value("<=", - 100)), room = to_be_character(length = with_value(">=", 1))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: integer [0, 30] - * gender: factor [female, male, non-binary] - * teacher: text - * room: text - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: numeric [-Inf, 12) - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark < -1) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [-Inf, -1) - ---- - - Code - des2 %>% expect_rcrds(0 < exam_mark) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric (0, Inf] - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark = to_be_integer(with_value(between = c(0, 15))), quiz2_mark = to_be_integer( - with_value(between = c(0, 30))), gender = to_be_factor(levels = c("female", - "male", "non-binary")), teacher = to_be_character(length = with_value("<=", - 100)), room = to_be_character(length = with_value(">=", 1))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: integer [0, 30] - * gender: factor [female, male, non-binary] - * teacher: text - * room: text - ---- - - Code - des2 %>% expect_rcrds(exam_mark = to_be_numeric(with_value(between = c(0, 100))), - quiz1_mark >= 0L, quiz1_mark <= 15L, quiz2_mark < 12, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: numeric [-Inf, 12) - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark >= 0, exam_mark <= 100, factor(gender, levels = c( - "female", "male", "non-binary"))) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * gender: factor [female, male, non-binary] - ---- - - Code - des2 %>% expect_rcrds(exam_mark < -1) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [-Inf, -1) - ---- - - Code - des2 %>% expect_rcrds(0 < exam_mark) - Output - Effective teaching - +-class (4 levels) - | \-student (120 levels) - | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender - +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric (0, Inf] + # Effective teaching + # An edibble: 120 x 10 + class student style exam exam_mark quiz1_mark quiz2_mark + + + 1 class1 student001 traditional closed-book o o o + 2 class1 student002 traditional closed-book o o o + 3 class1 student003 traditional take-home o o o + 4 class1 student004 traditional take-home o o o + 5 class1 student005 traditional open-book o o o + 6 class1 student006 traditional take-home o o o + 7 class1 student007 traditional take-home o o o + 8 class1 student008 traditional closed-book o o o + 9 class1 student009 traditional closed-book o o o + 10 class1 student010 traditional open-book o o o + # i 110 more rows + # i 3 more variables: gender , room , teacher --- diff --git a/tests/testthat/test-rcrds.R b/tests/testthat/test-rcrds.R index cf70597c..eb77f690 100644 --- a/tests/testthat/test-rcrds.R +++ b/tests/testthat/test-rcrds.R @@ -38,7 +38,6 @@ test_that("measure response", { des2 }) - # FIXME: not sure why this fails expect_snapshot({ serve_table(des2) }) From bb5fc5cb0d7945c35b831066983e8218d32ce853 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 26 Aug 2023 16:36:10 -0400 Subject: [PATCH 53/83] serve new snapshot --- tests/testthat/_snaps/serve.md | 3 ++ tests/testthat/_snaps/serve.new.md | 57 ------------------------------ 2 files changed, 3 insertions(+), 57 deletions(-) delete mode 100644 tests/testthat/_snaps/serve.new.md diff --git a/tests/testthat/_snaps/serve.md b/tests/testthat/_snaps/serve.md index a658f86f..c9f718bc 100644 --- a/tests/testthat/_snaps/serve.md +++ b/tests/testthat/_snaps/serve.md @@ -7,6 +7,7 @@ # An edibble: 3 x 1 block + 1 block1 2 block2 3 block3 @@ -21,6 +22,7 @@ # An edibble: 6 x 2 block plot + 1 block1 plot1 2 block1 plot2 3 block2 plot3 @@ -38,6 +40,7 @@ # An edibble: 13 x 5 site row col plot trt + 1 site1 row1 col1 plot01 A 2 site1 row2 col1 plot02 B 3 site1 row3 col1 plot03 A diff --git a/tests/testthat/_snaps/serve.new.md b/tests/testthat/_snaps/serve.new.md deleted file mode 100644 index c9f718bc..00000000 --- a/tests/testthat/_snaps/serve.new.md +++ /dev/null @@ -1,57 +0,0 @@ -# serve - - Code - design(title = "one unit") %>% set_units(block = 3) %>% serve_table() - Output - # one unit - # An edibble: 3 x 1 - block - - - 1 block1 - 2 block2 - 3 block3 - ---- - - Code - design(title = "serve nested units") %>% set_units(block = 3, plot = nested_in( - block, 2)) %>% serve_table() - Output - # serve nested units - # An edibble: 6 x 2 - block plot - - - 1 block1 plot1 - 2 block1 plot2 - 3 block2 plot3 - 4 block2 plot4 - 5 block3 plot5 - 6 block3 plot6 - ---- - - Code - design() %>% set_units(site = 2, row = nested_in(site, 1 ~ 3, 2 ~ 2), col = nested_in( - site, 1 ~ 3, 2 ~ 2), plot = nested_in(site, ~ row:col)) %>% set_trts(trt = c( - "A", "B")) %>% allot_table(trt ~ plot, seed = 1) - Output - # An edibble: 13 x 5 - site row col plot trt - - - 1 site1 row1 col1 plot01 A - 2 site1 row2 col1 plot02 B - 3 site1 row3 col1 plot03 A - 4 site1 row1 col2 plot04 B - 5 site1 row2 col2 plot05 A - 6 site1 row3 col2 plot06 B - 7 site1 row1 col3 plot07 A - 8 site1 row2 col3 plot08 B - 9 site1 row3 col3 plot09 A - 10 site2 row4 col4 plot10 A - 11 site2 row5 col4 plot11 B - 12 site2 row4 col5 plot12 B - 13 site2 row5 col5 plot13 A - From 3f1ffea75f79463431e5a02acdaf0113d6ac8555 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 26 Aug 2023 16:37:09 -0400 Subject: [PATCH 54/83] new trts snapshots saved --- tests/testthat/_snaps/trts.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/testthat/_snaps/trts.md b/tests/testthat/_snaps/trts.md index fcbbf98c..579c8a1a 100644 --- a/tests/testthat/_snaps/trts.md +++ b/tests/testthat/_snaps/trts.md @@ -44,6 +44,7 @@ # An edibble: 30 x 3 vaccine sex person + 1 vaccine1 sex1 person1 2 vaccine2 sex1 person2 3 vaccine3 sex1 person3 @@ -66,6 +67,7 @@ # An edibble: 30 x 3 vaccine sex person + 1 vaccine1 F person1 2 vaccine2 F person2 3 vaccine3 F person3 @@ -88,6 +90,7 @@ # An edibble: 30 x 3 vaccine sex person + 1 vaccine1 F person1 2 vaccine2 M person2 3 vaccine3 F person3 @@ -109,6 +112,7 @@ # An edibble: 30 x 2 vaccine person + 1 vaccine1 person1 2 vaccine2 person2 3 vaccine3 person3 @@ -131,6 +135,7 @@ # An edibble: 5 x 2 vaccine person + 1 vaccine1 person1 2 vaccine3 person2 3 vaccine2 person3 @@ -146,6 +151,7 @@ # An edibble: 5 x 2 vaccine person + 1 vaccine3 person1 2 vaccine2 person2 3 vaccine2 person3 From 08666be321afdf625dc04b3b5852841fd7899adf Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 26 Aug 2023 16:37:26 -0400 Subject: [PATCH 55/83] new units serve snapshot --- tests/testthat/_snaps/units.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/testthat/_snaps/units.md b/tests/testthat/_snaps/units.md index 445c66cb..a4e6376e 100644 --- a/tests/testthat/_snaps/units.md +++ b/tests/testthat/_snaps/units.md @@ -15,6 +15,7 @@ # An edibble: 12 x 3 row col plot + 1 row1 col1 plot1 2 row2 col1 plot2 3 row3 col1 plot3 @@ -37,6 +38,7 @@ # An edibble: 48 x 4 row col site plot + 1 row1 col1 site1 plot1 2 row1 col1 site2 plot2 3 row1 col1 site3 plot3 @@ -58,6 +60,7 @@ # An edibble: 60 x 4 site row col plot + 1 site1 row1 col1 plot1 2 site1 row1 col1 plot2 3 site1 row2 col1 plot3 From 17849fbad7bc095b292607c2eb416574c7d2768f Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 26 Aug 2023 17:32:19 -0400 Subject: [PATCH 56/83] fix return for allot --- R/allot.R | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/R/allot.R b/R/allot.R index 8c27f219..7eda55a3 100644 --- a/R/allot.R +++ b/R/allot.R @@ -111,9 +111,7 @@ allot_units <- function(.edibble, ..., .record = TRUE) { } } } - if(is_edibble_design(.edibble)) { - return_edibble_with_graph(.edibble, prov) - } else if(is_edibble_table(.edibble)) { + if(is_edibble_table(.edibble)) { # Note: for crossed and nested, it's the opposite -> small = big, not big = small. if(op %in% c("crossed_by", "nested_in")) { for(ismall in seq_along(small_id)) { @@ -136,9 +134,8 @@ allot_units <- function(.edibble, ..., .record = TRUE) { to = prov$lvl_id(name = as.character(.edibble[[asmall]]))) } } - attr(.edibble, "design") <- prov$design - .edibble } + return_edibble_with_graph(.edibble, prov) } From 34783027daaabca129ad8a693eaf59960c5ef8dc Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 26 Aug 2023 17:32:34 -0400 Subject: [PATCH 57/83] allow new edibble graph without certain elements --- R/design.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/design.R b/R/design.R index d5f28f6a..b5b79211 100644 --- a/R/design.R +++ b/R/design.R @@ -130,8 +130,8 @@ NULL invisible(structure(lx, class = class(x))) } -new_edibble_graph <- function(fnodes, lnodes, fedges, ledges) { - if(!inherits(lnodes, "edbl_lnodes")) class(lnodes) <- c("edbl_lnodes", class(lnodes)) +new_edibble_graph <- function(fnodes = NULL, lnodes = NULL, fedges = NULL, ledges = NULL) { + if(!is_null(lnodes) && !inherits(lnodes, "edbl_lnodes")) class(lnodes) <- c("edbl_lnodes", class(lnodes)) structure(list(factors = list(nodes = fnodes, edges = fedges), levels = list(nodes = lnodes, From c776d5c28f0a1e72432ada8352d7d77814535428 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 26 Aug 2023 17:32:58 -0400 Subject: [PATCH 58/83] remove get_provenance (redundant) and add fct_graph --- R/graph.R | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/R/graph.R b/R/graph.R index ef880ed6..d3d55fc8 100644 --- a/R/graph.R +++ b/R/graph.R @@ -38,7 +38,7 @@ NULL #' @rdname design_data #' @export fct_nodes <- function(x) { - prov <- get_provenance(x) + prov <- activate_provenance(x) fnodes <- prov$fct_nodes fnodes[, c("name", "role", "attrs")] } @@ -46,7 +46,7 @@ fct_nodes <- function(x) { #' @rdname design_data #' @export fct_edges <- function(x) { - prov <- get_provenance(x) + prov <- activate_provenance(x) fedges <- prov$fct_edges fedges[, c("var_from", "var_to", "type", "group", "attrs")] } @@ -55,7 +55,7 @@ fct_edges <- function(x) { #' @rdname design_data #' @export lvl_nodes <- function(x) { - prov <- get_provenance(x) + prov <- activate_provenance(x) lnodes <- prov$lvl_nodes lnodes <- lapply(lnodes, function(x) x[, "value", drop = FALSE]) names(lnodes) <- prov$fct_names(id = as.numeric(names(lnodes))) @@ -65,7 +65,7 @@ lvl_nodes <- function(x) { #' @rdname design_data #' @export lvl_edges <- function(x) { - prov <- get_provenance(x) + prov <- activate_provenance(x) ledges <- prov$lvl_edges lnodes <- prov$lvl_nodes lnodes_df <- do.call("rbind", lapply(names(lnodes), function(x) data.frame(fid = as.numeric(x), id = lnodes[[x]]$id))) @@ -80,12 +80,10 @@ lvl_edges <- function(x) { } -get_provenance <- function(x) { - if(is_provenance(x)) { - x - } else { - not_edibble(x) - activate_provenance(x) - } +fct_graph <- function(x) { + prov <- activate_provenance(x) + fnodes <- fct_nodes(x) + fedges <- fct_edges(x) + new_edibble_graph(fnodes = fnodes, fedges = fedges) } From e409237b224e161f720103ddbb0400bd37e9b880 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Wed, 30 Aug 2023 11:31:52 +1000 Subject: [PATCH 59/83] add lvls_data --- R/attrs.R | 26 +++++++++++++++++--------- R/graph-input.R | 6 ++++-- R/graph.R | 2 +- R/provenance.R | 6 +----- 4 files changed, 23 insertions(+), 17 deletions(-) diff --git a/R/attrs.R b/R/attrs.R index 8679d7fd..da4fad9c 100644 --- a/R/attrs.R +++ b/R/attrs.R @@ -40,14 +40,9 @@ fct_attrs <- function(levels = NULL, #' #' Use this function to create a "vector" of levels. The vector is actually comprised of a #' data frame with a column `labels` and other columns with corresponding level attribute (if any). -#' This data frame can be accessed with `lvl_data()`. #' #' @param levels A vector that either denotes the index number or short name of the levels. #' @param labels An optional character vector that is the long name format of `levels`. -#' @param prefix The prefix of the labels. -#' @param suffix The suffix of the labels. -#' @param sep A string to add between `prefix` and `levels`. -#' @param include_leading_zero A logical value to indicate whether there should #' be a leading zero added to level indexes. This is ignored if `levels` is not numeric. #' @param data A list or data frame of the same size as the `levels`. #' @param ... Name-value pair denoting other level attributes. The value should be the same @@ -63,6 +58,22 @@ lvl_attrs <- function(levels = NULL, new_rcrd(c(list2(value = levels, ...), data), class = "edbl_lvls") } +#' @export +lvls <- function(.x, ...) { + new_rcrd(list2(.value = .x, ...), class = "edbl_lvls") +} + +#' @export +lvls_data <- function(data, value = NULL) { + value <- enexpr(value) + if(is_null(value)) { + pos <- 1L + } else { + pos <- eval_select(value, data) + } + new_rcrd(c(list2(.value = data[[pos]]), data[-pos]), class = "edbl_lvls") +} + #' @export format.edbl_lvls <- function(x, ...) { levels(x) @@ -70,10 +81,7 @@ format.edbl_lvls <- function(x, ...) { #' @export levels.edbl_lvls <- function(x, ...) { - lvl_data(x)$value + vec_data(x)$.value } -lvl_data <- function(x) { - vec_data(x) -} diff --git a/R/graph-input.R b/R/graph-input.R index b9c22204..84e1e1bc 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -35,8 +35,10 @@ graph_input.default <- function(input, prov, name, class) { graph_input.edbl_lvls <- function(input, prov, name, class) { attrs <- NULL # attributes(input) prov$append_fct_nodes(name = name, role = class, attrs = attrs) - lattrs <- lvl_data(input) - prov$append_lvl_nodes(value = lattrs$value, fid = prov$fct_id(name = name)) + lattrs <- vec_data(input) + value <- lattrs$.value + lattrs <- lattrs[setdiff(names(lattrs), ".value")] + prov$append_lvl_nodes(value = value, fid = prov$fct_id(name = name), attrs = lattrs) } graph_input.formula <- function(input, prov, name, class) { diff --git a/R/graph.R b/R/graph.R index d3d55fc8..d14b7b46 100644 --- a/R/graph.R +++ b/R/graph.R @@ -57,7 +57,7 @@ fct_edges <- function(x) { lvl_nodes <- function(x) { prov <- activate_provenance(x) lnodes <- prov$lvl_nodes - lnodes <- lapply(lnodes, function(x) x[, "value", drop = FALSE]) + lnodes <- lapply(lnodes, function(x) x[setdiff(names(x), "id")]) names(lnodes) <- prov$fct_names(id = as.numeric(names(lnodes))) lnodes } diff --git a/R/provenance.R b/R/provenance.R index e2224f0f..625e773e 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -467,11 +467,7 @@ Provenance <- R6::R6Class("Provenance", id <- private$lvl_new_id(n = length(value)) data <- tibble::tibble(id = id, value = value, attrs = attrs) if(is.null(lnodes[[fid]])) { - if(!is_null(attrs)) { - lnodes[[fid]] <- new_lnode(id, value, attrs) - } else { - lnodes[[fid]] <- new_lnode(id, value) - } + lnodes[[fid]] <- data } else { lnodes[[fid]] <- rbind_(lnodes[[fid]], data) } From 33c518aaae7a3490b9941661c5f5cd115a8ff29d Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Wed, 30 Aug 2023 18:24:41 +1000 Subject: [PATCH 60/83] change how lvl_attrs and fct_attrs are specified --- NAMESPACE | 3 ++- R/attrs.R | 49 ++++++++++++++----------------------------------- R/design.R | 6 +++--- R/graph-input.R | 8 ++++---- R/provenance.R | 8 +++++--- 5 files changed, 28 insertions(+), 46 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 82ba7ddf..874e52b9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -66,6 +66,7 @@ export(as_data_frame) export(as_edibble) export(assign_trts) export(assign_units) +export(column) export(crossed_by) export(design) export(edbl_design) @@ -100,9 +101,9 @@ export(label_seq_to_length) export(latin_array) export(latin_rectangle) export(latin_square) -export(lvl_attrs) export(lvl_edges) export(lvl_nodes) +export(lvls) export(menu_bibd) export(menu_crd) export(menu_factorial) diff --git a/R/attrs.R b/R/attrs.R index da4fad9c..61b710a8 100644 --- a/R/attrs.R +++ b/R/attrs.R @@ -3,11 +3,8 @@ #' #' This function is used to set characteristics of the factors. #' -#' @param levels An `edbl_lvls` object that should contain information about the levels +#' @param .levels An `edbl_lvls` object that should contain information about the levels #' in the factor. -#' @param label A string that denotes the long name of the factor. -#' @param description The text description of the factor. -#' @param class An optional subclass. #' @param ... A name-value pair of attributes. The value must be a scalar and #' attributed to the whole factor (not individual levels). #' The values are added as attributes to the output object. @@ -17,22 +14,11 @@ #' fct_attrs(levels = c("A", "B")) #' @return An `edbl_lvls` object. #' @export -fct_attrs <- function(levels = NULL, - label = NULL, - description = NULL, - n = NULL, - class = NULL, +fct_attrs <- function(.levels = NULL, ...) { - - class(levels) <- c(class, class(levels)) - attr(levels, "label") <- label - attr(levels, "description") <- description dots <- dots_list(..., .named = TRUE, .homonyms = "keep", .ignore_empty = "all") - dots_names <- names(dots) - for(i in seq_along(dots)) { - attr(levels, dots_names[i]) <- dots[[i]] - } - levels + attr(.levels, "attrs") <- dots + .levels } @@ -42,8 +28,6 @@ fct_attrs <- function(levels = NULL, #' data frame with a column `labels` and other columns with corresponding level attribute (if any). #' #' @param levels A vector that either denotes the index number or short name of the levels. -#' @param labels An optional character vector that is the long name format of `levels`. -#' be a leading zero added to level indexes. This is ignored if `levels` is not numeric. #' @param data A list or data frame of the same size as the `levels`. #' @param ... Name-value pair denoting other level attributes. The value should be the same #' length as `levels` or a single value. @@ -52,27 +36,22 @@ fct_attrs <- function(levels = NULL, #' lvl_attrs(c("A", "B")) #' @return An edbl_lvls object. #' @export -lvl_attrs <- function(levels = NULL, +lvls <- function(value = NULL, data = NULL, ...) { + if(!is_null(data) && isTRUE(attr(value, "column"))) { + pos <- eval_select(value[[1]], data) + value <- data[[pos]] + data <- data[-pos] + } - new_rcrd(c(list2(value = levels, ...), data), class = "edbl_lvls") + new_rcrd(c(list2(..value.. = value, ...), data), class = "edbl_lvls") } #' @export -lvls <- function(.x, ...) { - new_rcrd(list2(.value = .x, ...), class = "edbl_lvls") +column <- function(x) { + structure(list(enexpr(x)), column = TRUE) } -#' @export -lvls_data <- function(data, value = NULL) { - value <- enexpr(value) - if(is_null(value)) { - pos <- 1L - } else { - pos <- eval_select(value, data) - } - new_rcrd(c(list2(.value = data[[pos]]), data[-pos]), class = "edbl_lvls") -} #' @export format.edbl_lvls <- function(x, ...) { @@ -81,7 +60,7 @@ format.edbl_lvls <- function(x, ...) { #' @export levels.edbl_lvls <- function(x, ...) { - vec_data(x)$.value + vec_data(x)[["..value.."]] } diff --git a/R/design.R b/R/design.R index b5b79211..bd301774 100644 --- a/R/design.R +++ b/R/design.R @@ -41,13 +41,13 @@ empty_edibble_graph <- function() { fnodes <- tibble::tibble(id = integer(), role = character(), name = character(), - attrs = list()) + attrs = data.frame()) lnodes <- structure(list(), class = c("edbl_lnodes", "list")) fedges <- tibble::tibble(from = integer(), to = integer(), type = character(), group = integer(), - attrs = list()) + attrs = data.frame()) ledges <- tibble::tibble(from = integer(), to = integer(), - attrs = list()) + attrs = data.frame()) new_edibble_graph(fnodes, lnodes, fedges, ledges) } diff --git a/R/graph-input.R b/R/graph-input.R index 84e1e1bc..00f7b7eb 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -33,11 +33,11 @@ graph_input.default <- function(input, prov, name, class) { } graph_input.edbl_lvls <- function(input, prov, name, class) { - attrs <- NULL # attributes(input) - prov$append_fct_nodes(name = name, role = class, attrs = attrs) + fattrs <- as.data.frame(attr(input, "attrs")) + prov$append_fct_nodes(name = name, role = class, attrs = fattrs) lattrs <- vec_data(input) - value <- lattrs$.value - lattrs <- lattrs[setdiff(names(lattrs), ".value")] + value <- lattrs$..value.. + lattrs <- lattrs[setdiff(names(lattrs), "..value..")] prov$append_lvl_nodes(value = value, fid = prov$fct_id(name = name), attrs = lattrs) } diff --git a/R/provenance.R b/R/provenance.R index 625e773e..dacf0be7 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -449,14 +449,16 @@ Provenance <- R6::R6Class("Provenance", #' Given node data, append the factor nodes append_fct_nodes = function(name, role, attrs = NULL) { private$record_track_internal() + fnodes <- self$fct_nodes n <- length(name) role <- vctrs::vec_recycle(role, n) data <- tibble::tibble(id = private$fct_new_id(n = n), name = name, - role = role, - attrs = attrs) + role = role) - self$fct_nodes <- rbind_(self$fct_nodes, data) + out <- rbind_(fnodes[setdiff(names(fnodes), "attrs")], data) + out$attrs <- rbind_(fnodes$attrs, attrs) + self$fct_nodes <- out }, #' @description From b313aad26f59bea7bac4820e4f98b8bd3ecb5255 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Wed, 30 Aug 2023 18:24:54 +1000 Subject: [PATCH 61/83] doc update --- man/fct_attrs.Rd | 17 ++--------------- man/{lvl_attrs.Rd => lvls.Rd} | 20 ++++---------------- 2 files changed, 6 insertions(+), 31 deletions(-) rename man/{lvl_attrs.Rd => lvls.Rd} (56%) diff --git a/man/fct_attrs.Rd b/man/fct_attrs.Rd index a1920735..1fee26d9 100644 --- a/man/fct_attrs.Rd +++ b/man/fct_attrs.Rd @@ -4,25 +4,12 @@ \alias{fct_attrs} \title{Setting the traits of factors} \usage{ -fct_attrs( - levels = NULL, - label = NULL, - description = NULL, - n = NULL, - class = NULL, - ... -) +fct_attrs(.levels = NULL, ...) } \arguments{ -\item{levels}{An \code{edbl_lvls} object that should contain information about the levels +\item{.levels}{An \code{edbl_lvls} object that should contain information about the levels in the factor.} -\item{label}{A string that denotes the long name of the factor.} - -\item{description}{The text description of the factor.} - -\item{class}{An optional subclass.} - \item{...}{A name-value pair of attributes. The value must be a scalar and attributed to the whole factor (not individual levels). The values are added as attributes to the output object.} diff --git a/man/lvl_attrs.Rd b/man/lvls.Rd similarity index 56% rename from man/lvl_attrs.Rd rename to man/lvls.Rd index 63df8105..0021e2c6 100644 --- a/man/lvl_attrs.Rd +++ b/man/lvls.Rd @@ -1,29 +1,18 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/attrs.R -\name{lvl_attrs} -\alias{lvl_attrs} +\name{lvls} +\alias{lvls} \title{Setting the traits of the levels} \usage{ -lvl_attrs(levels = NULL, data = NULL, ...) +lvls(value = NULL, data = NULL, ...) } \arguments{ -\item{levels}{A vector that either denotes the index number or short name of the levels.} - \item{data}{A list or data frame of the same size as the \code{levels}.} \item{...}{Name-value pair denoting other level attributes. The value should be the same length as \code{levels} or a single value.} -\item{labels}{An optional character vector that is the long name format of \code{levels}.} - -\item{prefix}{The prefix of the labels.} - -\item{suffix}{The suffix of the labels.} - -\item{sep}{A string to add between \code{prefix} and \code{levels}.} - -\item{include_leading_zero}{A logical value to indicate whether there should -be a leading zero added to level indexes. This is ignored if \code{levels} is not numeric.} +\item{levels}{A vector that either denotes the index number or short name of the levels.} } \value{ An edbl_lvls object. @@ -31,7 +20,6 @@ An edbl_lvls object. \description{ Use this function to create a "vector" of levels. The vector is actually comprised of a data frame with a column \code{labels} and other columns with corresponding level attribute (if any). -This data frame can be accessed with \code{lvl_data()}. } \examples{ lvl_attrs(c("A", "B")) From c89cb51dc6ba3eb714e0c72b6a9e48a237614cb5 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 08:17:43 +1000 Subject: [PATCH 62/83] fix attrs --- R/attrs.R | 6 ++---- R/graph-input.R | 10 +++++----- R/graph.R | 14 +++++++++++--- R/provenance.R | 6 +++++- 4 files changed, 23 insertions(+), 13 deletions(-) diff --git a/R/attrs.R b/R/attrs.R index 61b710a8..af483a8a 100644 --- a/R/attrs.R +++ b/R/attrs.R @@ -14,8 +14,7 @@ #' fct_attrs(levels = c("A", "B")) #' @return An `edbl_lvls` object. #' @export -fct_attrs <- function(.levels = NULL, - ...) { +fct_attrs <- function(.levels, ...) { dots <- dots_list(..., .named = TRUE, .homonyms = "keep", .ignore_empty = "all") attr(.levels, "attrs") <- dots .levels @@ -36,8 +35,7 @@ fct_attrs <- function(.levels = NULL, #' lvl_attrs(c("A", "B")) #' @return An edbl_lvls object. #' @export -lvls <- function(value = NULL, - data = NULL, ...) { +lvls <- function(value = NULL, data = NULL, ...) { if(!is_null(data) && isTRUE(attr(value, "column"))) { pos <- eval_select(value[[1]], data) value <- data[[pos]] diff --git a/R/graph-input.R b/R/graph-input.R index 00f7b7eb..237f6763 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -21,12 +21,12 @@ graph_input_type = function(input) { graph_input.default <- function(input, prov, name, class) { type <- graph_input_type(input) levels <- switch(type, - "numeric" = fct_attrs(levels = lvl_attrs(label_seq_length(input, prefix = name)), + "numeric" = fct_attrs(lvls(label_seq_length(input, prefix = name)), class = class), - "unnamed_vector" = fct_attrs(levels = lvl_attrs(input), + "unnamed_vector" = fct_attrs(lvls(input), class = class), - "named_vector" = fct_attrs(levels = lvl_attrs(names(input), - rep = unname(input)), + "named_vector" = fct_attrs(lvls(names(input), + rep = unname(input)), class = class), "unimplemented" = abort(paste0("Not sure how to handle ", class(input)[1]))) graph_input.edbl_lvls(levels, prov, name, class) @@ -52,7 +52,7 @@ graph_input.cross_lvls <- function(input, prov, name, class) { vars <- input pdf <- expand.grid(flevels[vars]) - pdf[[name]] <- fct_attrs(levels = lvl_attrs(label_seq_length(nrow(pdf), prefix = name)), + pdf[[name]] <- fct_attrs(levels = lvls(label_seq_length(nrow(pdf), prefix = name)), class = class) # create notes for the crossed unit graph_input.edbl_lvls(pdf[[name]], prov, name, class) diff --git a/R/graph.R b/R/graph.R index d14b7b46..9f57de3b 100644 --- a/R/graph.R +++ b/R/graph.R @@ -73,13 +73,13 @@ lvl_edges <- function(x) { ledges$var_to <- prov$fct_names(id = lnodes_df[match(ledges$to, lnodes_df$id), "fid"]) ledges <- split(ledges, paste(ledges$var_from, "->", ledges$var_to)) lapply(ledges, function(df) { - df$val_from <- prov$lvl_values(id = df$from, fid = prov$fct_id(name = df$var_from[1])) - df$val_to <- prov$lvl_values(id = df$to, fid = prov$fct_id(name = df$var_to[1])) + df$val_from <- prov$lvl_values(id = df$from, fid = prov$fct_id(name = df$var_from[1])) %||% character(0) + df$val_to <- prov$lvl_values(id = df$to, fid = prov$fct_id(name = df$var_to[1])) %||% character(0) df[, c("var_from", "var_to", "val_from", "val_to", "attrs")] }) } - +#' @export fct_graph <- function(x) { prov <- activate_provenance(x) fnodes <- fct_nodes(x) @@ -87,3 +87,11 @@ fct_graph <- function(x) { new_edibble_graph(fnodes = fnodes, fedges = fedges) } + +lvl_graph <- function(x) { + prov <- activate_provenance(x) + lnodes <- lvl_nodes(x) + ledges <- lvl_edges(x) + new_edibble_graph(lnodes = lnodes, ledges = ledges) +} + diff --git a/R/provenance.R b/R/provenance.R index dacf0be7..500e9550 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -457,7 +457,11 @@ Provenance <- R6::R6Class("Provenance", role = role) out <- rbind_(fnodes[setdiff(names(fnodes), "attrs")], data) - out$attrs <- rbind_(fnodes$attrs, attrs) + out_attrs <- rbind_(fnodes$attrs, attrs) + if(nrow(out_attrs)==0) { + out_attrs <- data.frame(row.names = nrow(out)) + } + out$attrs <- out_attrs self$fct_nodes <- out }, From a068dc25f4c774115ee30e7845759e1d0eabae90 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 08:18:09 +1000 Subject: [PATCH 63/83] update print method for edbl_graph --- R/utils.R | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/R/utils.R b/R/utils.R index e334b622..fa76fd5f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -172,12 +172,15 @@ perm <- function(x) { } #' @export -print.edbl_graph <- function(x, show_levels = FALSE, ...) { - cat(cli::col_green("factor nodes\n")) - print(x$factors$nodes) - cat(cli::col_green("factor edges\n")) - print(x$factors$edges) - if(show_levels) { +print.edbl_graph <- function(x, show = c("factors", "levels", "both"), ...) { + show <- match.arg(show) + if(show %in% c("factors", "both")) { + cat(cli::col_green("factor nodes\n")) + print(x$factors$nodes) + cat(cli::col_green("factor edges\n")) + print(x$factors$edges) + } + if(show %in% c("levels", "both")) { cat(cli::col_blue("level nodes\n")) print(x$levels$nodes) cat(cli::col_blue("level edges\n")) From 494aa07c57a8c49c716de214369929ec1192ab23 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 08:18:57 +1000 Subject: [PATCH 64/83] add default .edibble for set_units and set_trts --- R/fcts.R | 1 - R/trts.R | 2 +- R/units.R | 2 +- man/set_trts.Rd | 2 +- man/set_units.Rd | 2 +- 5 files changed, 4 insertions(+), 5 deletions(-) diff --git a/R/fcts.R b/R/fcts.R index b7c72252..fe7064ff 100644 --- a/R/fcts.R +++ b/R/fcts.R @@ -33,7 +33,6 @@ set_fcts <- function(.edibble, ..., .class = NULL, } } else if(is_edibble_table(.edibble)) { - loc <- eval_select(expr(c(...)), .edibble) for(i in seq_along(loc)) { var <- .edibble[[loc[i]]] diff --git a/R/trts.R b/R/trts.R index 89775420..b124620d 100644 --- a/R/trts.R +++ b/R/trts.R @@ -21,7 +21,7 @@ #' #' @return An edibble design. #' @export -set_trts <- function(.edibble, ..., +set_trts <- function(.edibble = design(), ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE) { prov <- activate_provenance(.edibble) diff --git a/R/units.R b/R/units.R index 8a3f6e70..5c8101a7 100644 --- a/R/units.R +++ b/R/units.R @@ -59,7 +59,7 @@ #' @family user-facing functions #' @return An edibble design. #' @export -set_units <- function(.edibble, ..., +set_units <- function(.edibble = design(), ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE) { prov <- activate_provenance(.edibble) diff --git a/man/set_trts.Rd b/man/set_trts.Rd index e862f66f..fe4a4c59 100644 --- a/man/set_trts.Rd +++ b/man/set_trts.Rd @@ -5,7 +5,7 @@ \title{Set the treatment variables} \usage{ set_trts( - .edibble, + .edibble = design(), ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE diff --git a/man/set_units.Rd b/man/set_units.Rd index 2a04446c..650a2472 100644 --- a/man/set_units.Rd +++ b/man/set_units.Rd @@ -5,7 +5,7 @@ \title{Set units used in experiment} \usage{ set_units( - .edibble, + .edibble = design(), ..., .name_repair = c("check_unique", "unique", "universal", "minimal"), .record = TRUE From ce6cf0f2e37a6e0c59da95c92a2e0a140a9fcd78 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 09:46:42 +1000 Subject: [PATCH 65/83] testing attrs --- R/attrs.R | 8 ++++++ R/graph.R | 6 ++--- tests/testthat/test-allot.R | 15 +++++++++--- tests/testthat/test-attrs.R | 49 +++++++++++++++++++++++++++++++++++++ 4 files changed, 71 insertions(+), 7 deletions(-) create mode 100644 tests/testthat/test-attrs.R diff --git a/R/attrs.R b/R/attrs.R index af483a8a..13a3882a 100644 --- a/R/attrs.R +++ b/R/attrs.R @@ -16,6 +16,14 @@ #' @export fct_attrs <- function(.levels, ...) { dots <- dots_list(..., .named = TRUE, .homonyms = "keep", .ignore_empty = "all") + if(length(dots)) { + for(x in dots) { + vctrs::vec_assert(x, size = 1) + } + } + if(!inherits(.levels, "edbl_lvls")) { + .levels <- new_rcrd(list2(..value.. = .levels), class = "edbl_lvls") + } attr(.levels, "attrs") <- dots .levels } diff --git a/R/graph.R b/R/graph.R index 9f57de3b..c8ce9a24 100644 --- a/R/graph.R +++ b/R/graph.R @@ -57,9 +57,9 @@ fct_edges <- function(x) { lvl_nodes <- function(x) { prov <- activate_provenance(x) lnodes <- prov$lvl_nodes - lnodes <- lapply(lnodes, function(x) x[setdiff(names(x), "id")]) - names(lnodes) <- prov$fct_names(id = as.numeric(names(lnodes))) - lnodes + olnodes <- lapply(unclass(lnodes), function(.x) .x[setdiff(names(.x), "id")]) + names(olnodes) <- prov$fct_names(id = as.numeric(names(olnodes))) + olnodes } #' @rdname design_data diff --git a/tests/testthat/test-allot.R b/tests/testthat/test-allot.R index 4ebdc71d..95ed76ae 100644 --- a/tests/testthat/test-allot.R +++ b/tests/testthat/test-allot.R @@ -3,6 +3,7 @@ test_that("allot works", { set_units(block = 10, plot = 20) %>% allot_units(block ~ plot) + fedges1 <- fct_edges(des1) expect_equal(fedges1$var_from, "block") expect_equal(fedges1$var_to, "plot") @@ -15,13 +16,19 @@ test_that("allot works", { pest = c("a", "b")) %>% allot_trts(treat ~ plot, pest ~ block) - fedges2 <- fct_edges(des2) + + fedges2 <- fct_edges(des2) expect_equal(fedges2$var_from, c("block", "treat", "pest")) expect_equal(fedges2$var_to, c("plot", "plot", "block")) - df <- as.data.frame(takeout(menu_split())) - attr(df, "design") <- NULL - attr(df, "recipe") <- NULL + # it seems that factor has precedence in printing over other types + # in tibble + ChickWeight %>% + edibble() %>% + set_units(Diet) + ChickWeight %>% + edibble() %>% + set_units(Chick, Time) }) diff --git a/tests/testthat/test-attrs.R b/tests/testthat/test-attrs.R new file mode 100644 index 00000000..2891e708 --- /dev/null +++ b/tests/testthat/test-attrs.R @@ -0,0 +1,49 @@ +test_that("check lvls works", { + des0 <- set_trts(diet = fct_attrs(lvls(value = c("A", "B", "C")))) + des1 <- set_trts(diet = lvls(value = c("A", "B", "C"))) + expect_equal(fct_graph(des0), fct_graph(des1)) + expect_equal(lvl_graph(des0), lvl_graph(des1)) + trtinfo <- data.frame(label = c("Keto", "Vegan", "Meat")) + des2 <- set_trts(diet = fct_attrs(lvls(value = c("A", "B", "C"), + label = trtinfo$label))) + des3 <- set_trts(diet = fct_attrs(lvls(value = c("A", "B", "C"), + data = trtinfo))) + out <- list(diet = tibble::tibble(value = LETTERS[1:3], + attrs = trtinfo)) + + trtinfo$value <- LETTERS[1:3] + des4 <- set_trts(diet = fct_attrs(lvls(value = column(value), + data = trtinfo))) + des5 <- set_trts(diet = fct_attrs(lvls(value = column(2), + data = trtinfo))) + + expect_equal(lvl_nodes(des2), out) + expect_equal(lvl_nodes(des3), out) + expect_equal(lvl_nodes(des4), out) + expect_equal(lvl_nodes(des5), out) + + attrs_lvls <- data.frame(sex = rep(c("F", "M"), 3), + height = c(0.514, -0.156, 0.731, -2.633, 0.912, 0.439)) + des5 %>% + set_units(subject = lvls(1:6, + sex = attrs_lvls$sex, + height = attrs_lvls$height)) %>% + lvl_nodes() %>% + expect_equal(c(out, list(subject = tibble::tibble(value = 1:6, + attrs = attrs_lvls)))) + + +}) + + +test_that("check fct_attrs works", { + des0 <- set_trts(diet = fct_attrs(c("A", "B", "C"), + desc = "human diet"), + exercise = fct_attrs(c("Y", "N"), + label = "Exercise")) + expect_equal(fct_nodes(des0), tibble::tibble(name = c("diet", "exercise"), + role = "edbl_trt", + attrs = data.frame(desc = c("human diet", NA), + label = c(NA, "Exercise")))) + +}) From 69a085eec23f050e6137d8f411d5f0cdf4566e7b Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 10:16:22 +1000 Subject: [PATCH 66/83] fix allot --- R/graph-input.R | 9 +++------ R/provenance.R | 9 ++++----- R/utils.R | 2 +- tests/testthat/test-allot.R | 7 +++---- 4 files changed, 11 insertions(+), 16 deletions(-) diff --git a/R/graph-input.R b/R/graph-input.R index 237f6763..542f0044 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -21,13 +21,10 @@ graph_input_type = function(input) { graph_input.default <- function(input, prov, name, class) { type <- graph_input_type(input) levels <- switch(type, - "numeric" = fct_attrs(lvls(label_seq_length(input, prefix = name)), - class = class), - "unnamed_vector" = fct_attrs(lvls(input), - class = class), + "numeric" = fct_attrs(lvls(label_seq_length(input, prefix = name))), + "unnamed_vector" = fct_attrs(lvls(input)), "named_vector" = fct_attrs(lvls(names(input), - rep = unname(input)), - class = class), + rep = unname(input))), "unimplemented" = abort(paste0("Not sure how to handle ", class(input)[1]))) graph_input.edbl_lvls(levels, prov, name, class) } diff --git a/R/provenance.R b/R/provenance.R index 500e9550..c706dd8e 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -453,12 +453,11 @@ Provenance <- R6::R6Class("Provenance", n <- length(name) role <- vctrs::vec_recycle(role, n) data <- tibble::tibble(id = private$fct_new_id(n = n), - name = name, - role = role) - + role = role, + name = name) out <- rbind_(fnodes[setdiff(names(fnodes), "attrs")], data) - out_attrs <- rbind_(fnodes$attrs, attrs) - if(nrow(out_attrs)==0) { + out_attrs <- rbind_(fnodes$attrs, attrs %||% data.frame()) + if(nrow(out_attrs) < nrow(out)) { out_attrs <- data.frame(row.names = nrow(out)) } out$attrs <- out_attrs diff --git a/R/utils.R b/R/utils.R index fa76fd5f..4e168453 100644 --- a/R/utils.R +++ b/R/utils.R @@ -217,7 +217,7 @@ rbind_ <- function(df1, df2) { if(nrow(df1) & nrow(df2)) { df1[setdiff(names(df2), names(df1))] <- NA df2[setdiff(names(df1), names(df2))] <- NA - out <- rbind(df1, df2) + out <- rbind(df1, df2[names(df1)]) } else if(nrow(df1)) { df1[setdiff(names(df2), names(df1))] <- NA out <- df1 diff --git a/tests/testthat/test-allot.R b/tests/testthat/test-allot.R index 95ed76ae..807ab3b0 100644 --- a/tests/testthat/test-allot.R +++ b/tests/testthat/test-allot.R @@ -9,15 +9,14 @@ test_that("allot works", { expect_equal(fedges1$var_to, "plot") - des2 <- design() %>% - set_units(block = 10, - plot = nested_in(block, 3)) %>% + des2 <- set_units(block = 10, + plot = nested_in(block, 3)) %>% set_trts(treat = c("A", "B", "C"), pest = c("a", "b")) %>% allot_trts(treat ~ plot, pest ~ block) - fedges2 <- fct_edges(des2) + fedges2 <- fct_edges(des2) expect_equal(fedges2$var_from, c("block", "treat", "pest")) expect_equal(fedges2$var_to, c("plot", "plot", "block")) From 0c633247879e7ee9a103da9994cfafdf491a1a75 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 10:20:58 +1000 Subject: [PATCH 67/83] fix call to fct_attrs --- NAMESPACE | 1 + R/attrs.R | 2 +- R/graph-input.R | 3 +-- man/fct_attrs.Rd | 4 ++-- tests/testthat/test-units.R | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 874e52b9..745518ed 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -78,6 +78,7 @@ export(export_design) export(fct_attrs) export(fct_edges) export(fct_generator) +export(fct_graph) export(fct_nodes) export(graph_input) export(is_cross_levels) diff --git a/R/attrs.R b/R/attrs.R index 13a3882a..979d9d69 100644 --- a/R/attrs.R +++ b/R/attrs.R @@ -11,7 +11,7 @@ #' #' @seealso lvl_traits #' @examples -#' fct_attrs(levels = c("A", "B")) +#' fct_attrs(c("A", "B")) #' @return An `edbl_lvls` object. #' @export fct_attrs <- function(.levels, ...) { diff --git a/R/graph-input.R b/R/graph-input.R index 542f0044..89714936 100644 --- a/R/graph-input.R +++ b/R/graph-input.R @@ -49,8 +49,7 @@ graph_input.cross_lvls <- function(input, prov, name, class) { vars <- input pdf <- expand.grid(flevels[vars]) - pdf[[name]] <- fct_attrs(levels = lvls(label_seq_length(nrow(pdf), prefix = name)), - class = class) + pdf[[name]] <- fct_attrs(lvls(label_seq_length(nrow(pdf), prefix = name))) # create notes for the crossed unit graph_input.edbl_lvls(pdf[[name]], prov, name, class) # for every parent unit, draw edges for factor and level graphs diff --git a/man/fct_attrs.Rd b/man/fct_attrs.Rd index 1fee26d9..f6de1d6b 100644 --- a/man/fct_attrs.Rd +++ b/man/fct_attrs.Rd @@ -4,7 +4,7 @@ \alias{fct_attrs} \title{Setting the traits of factors} \usage{ -fct_attrs(.levels = NULL, ...) +fct_attrs(.levels, ...) } \arguments{ \item{.levels}{An \code{edbl_lvls} object that should contain information about the levels @@ -21,7 +21,7 @@ An \code{edbl_lvls} object. This function is used to set characteristics of the factors. } \examples{ -fct_attrs(levels = c("A", "B")) +fct_attrs(c("A", "B")) } \seealso{ lvl_traits diff --git a/tests/testthat/test-units.R b/tests/testthat/test-units.R index bb7c8249..254a9ce9 100644 --- a/tests/testthat/test-units.R +++ b/tests/testthat/test-units.R @@ -19,7 +19,7 @@ test_that("set_units", { expect_equal(des$graph$levels$nodes[["2"]]$id, 4:5) expect_equal(des$graph$levels$nodes[["1"]]$value, c("block1", "block2", "block3")) expect_equal(des$graph$levels$nodes[["2"]]$value, c("plot1", "plot2")) - expect_equal(names(des$graph$levels$nodes[["1"]]), c("id", "value")) + expect_equal(names(des$graph$levels$nodes[["1"]]), c("id", "value", "attrs")) expect_snapshot({ From 40fb23b33531806bee4fe10f2a8d2f57e91e476c Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 10:24:52 +1000 Subject: [PATCH 68/83] fix test for nest --- tests/testthat/test-nest.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-nest.R b/tests/testthat/test-nest.R index 53f56b13..bb53fb33 100644 --- a/tests/testthat/test-nest.R +++ b/tests/testthat/test-nest.R @@ -10,10 +10,12 @@ test_that("nested-units", { expect_equal(fct_nodes(des1), tibble::tibble(name = c("block", "plot"), role = "edbl_unit", - attrs = NA)) + attrs = data.frame(row.names = 1:2))) + # FIXME there is no attrs for the second factor expect_equal(lvl_nodes(des1), - list(block = tibble::tibble(value = c("block1", "block2", "block3")), - plot = tibble::tibble(value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6"))) ) + list(block = tibble::tibble(value = c("block1", "block2", "block3"), + attrs = data.frame(row.names = 1:3)), + plot = tibble::tibble(value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6"))) ) des2 <- des1 %>% set_units(sample = nested_in(plot, @@ -22,9 +24,10 @@ test_that("nested-units", { expect_equal(fct_nodes(des2), tibble::tibble(name = c("block", "plot", "sample"), role = "edbl_unit", - attrs = NA)) + attrs = data.frame(row.names = 1:3))) expect_equal(lvl_nodes(des2), - list(block = tibble::tibble(value = c("block1", "block2", "block3")), + list(block = tibble::tibble(value = c("block1", "block2", "block3"), + attrs = data.frame(row.names = 1:3)), plot = tibble::tibble(value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6")), sample = tibble::tibble(value = c("sample01", "sample02", "sample03", "sample04", "sample05", "sample06", "sample07", "sample08", From 3fa95791b65268b543a421603114d027d7933b0e Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 12:30:50 +1000 Subject: [PATCH 69/83] unclass needed? --- R/provenance.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/provenance.R b/R/provenance.R index c706dd8e..19f2713e 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -306,7 +306,7 @@ Provenance <- R6::R6Class("Provenance", switch(return, id = lapply(unclass(lnodes[qid]), function(x) x$id), value = { - out <- lapply(lnodes[qid], function(x) x$value) + out <- lapply(unclass(lnodes[qid]), function(x) x$value) names(out) <- self$fct_names(id = qid) out }) From a63d72e088aeace48cab2a73bde8806d37a88752 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 13:24:40 +1000 Subject: [PATCH 70/83] prettify the print when no attrs --- R/graph.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/graph.R b/R/graph.R index c8ce9a24..934ecb58 100644 --- a/R/graph.R +++ b/R/graph.R @@ -40,6 +40,7 @@ NULL fct_nodes <- function(x) { prov <- activate_provenance(x) fnodes <- prov$fct_nodes + if(ncol(fnodes$attrs) == 0) return(fnodes[, c("name", "role")]) fnodes[, c("name", "role", "attrs")] } @@ -57,7 +58,11 @@ fct_edges <- function(x) { lvl_nodes <- function(x) { prov <- activate_provenance(x) lnodes <- prov$lvl_nodes - olnodes <- lapply(unclass(lnodes), function(.x) .x[setdiff(names(.x), "id")]) + olnodes <- lapply(unclass(lnodes), function(.x) { + out <- .x[setdiff(names(.x), "id")] + if(ncol(out$attrs)==0) out$attrs <- NULL + out + }) names(olnodes) <- prov$fct_names(id = as.numeric(names(olnodes))) olnodes } From d82fe71b4332cc81063d640b04b7e187e2ad7e7e Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 13:24:49 +1000 Subject: [PATCH 71/83] fix plot --- R/plot.R | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/R/plot.R b/R/plot.R index 04e3a1ee..0eb082c4 100644 --- a/R/plot.R +++ b/R/plot.R @@ -30,16 +30,30 @@ plot.edbl_design <- function(x, which = c("factors", "levels"), "factors" = prov$fct_nodes, # FIXME "levels" = prov$lvl_nodes) + + if(which=="levels") { + nodes <- lapply(names(nodes), function(avar) { + out <- unclass(nodes)[[avar]] + out$name <- as.character(out$value) + out$attrs <- NULL + out$fct_var <- prov$fct_names(id = as.integer(avar)) + out$role <- prov$fct_role(id = as.integer(avar)) + out + }) + nodes <- do.call(rbind, nodes) + } + + nodes$group <- switch(which, - "factors" = gsub("edbl_", "", nodes$class), - "levels" = nodes$var) + "factors" = gsub("edbl_", "", nodes$role), + "levels" = nodes$fct_var) nodes$label <- nodes$name class2shape <- c("edbl_unit" = "circle", "edbl_trt" = "diamond", "edbl_rcrd" = "database") - nodes$shape <- class2shape[prov$fct_class(nodes$idvar)] + nodes$shape <- class2shape[nodes$role] - main <- names(title) %||% title %||% x$name + main <- names(title) %||% title %||% prov$get_title() main_style <- ifelse(is_named(title), title, "") submain <- names(subtitle) %||% subtitle %||% "" submain_style <- ifelse(is_named(submain), submain, "") @@ -63,6 +77,9 @@ plot.edbl_design <- function(x, which = c("factors", "levels"), edges$arrows <- "to" } } + # the data.frame column causes issue + nodes$attrs <- NULL + edges$attrs <- NULL out <- visNetwork::visNetwork(nodes = nodes, edges = edges, From f51b309e4ffdfb865664a455f4d077a4e6c00313 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 14:43:01 +1000 Subject: [PATCH 72/83] change the print for the edbl_design so it is more compact --- R/utils.R | 42 ++++++++++++------------------------------ 1 file changed, 12 insertions(+), 30 deletions(-) diff --git a/R/utils.R b/R/utils.R index 4e168453..fb84a667 100644 --- a/R/utils.R +++ b/R/utils.R @@ -61,7 +61,7 @@ print.edbl_design <- function(x, title <- title %||% prov$get_title() %||% "An edibble design" fids <- prov$fct_nodes$id fnames <- prov$fct_names(id = fids) - + valids <- prov$get_validation(type = "rcrds") if(is_empty(fids)) { data <- data.frame(var = "root", child = NA, @@ -90,8 +90,16 @@ print.edbl_design <- function(x, names(ll) <- as.character(fids) nodes_with_parents <- as.integer(unname(unlist(ll))) label_names_with_levels <- paste(label_names, map_chr(var_nlevels, decorate_levels)) - label_names_with_levels[classes=="edbl_rcrd"] <- label_names[classes=="edbl_rcrd"] - + #browser() + rcrd_names <- prov$rcrd_names() + for(arcrd in rcrd_names) { + ipos <- which(fnames == arcrd) + label_names_with_levels[ipos] <- label_names[ipos] + if(!is_null(valids[[arcrd]])) { + label_names_with_levels[ipos] <- paste(label_names_with_levels[ipos], + cli::col_grey(validation_interval(valids[[arcrd]]))) + } + } data <- data.frame(var = c("root", fids), child = I(c(list(setdiff(fids, nodes_with_parents)), ll)), label = c(decorate_title(title), @@ -99,33 +107,7 @@ print.edbl_design <- function(x, } cat(tree(data, root = "root"), sep = "\n") - fedges <- prov$fct_edges - if("allot" %in% fedges$type) { - cat(decorate_title("Allotment:\n")) - allots <- fedges[fedges$type=="allot", ] - trts_to_units <- paste(allots$var_from, "~", allots$var_to) - # this is so it aligns the tilde position - # it seems that it's automatically strips away the padding now - # so below no longer works - #tilde_pos <- unlist(gregexpr("~", trts_to_units)) - #tilde_pos_max <- max(tilde_pos) - #pad <- map_chr(tilde_pos_max - tilde_pos, function(n) ifelse(n==0, "", paste0(rep(" ", n), collapse = ""))) - #cli_li(items = paste0(" ", pad, trts_to_units)) - cli_li(items = trts_to_units) - } - # FIXME: should this be included - currently it is not - if(!is_null(x$assignment)) { - cat(decorate_title("Assignment:"), paste0(x$assignment, collapse = ", "), "\n") - } - if(!is_null(valids <- prov$get_validation(type = "rcrds"))) { - cat(decorate_title("Validation:\n")) - rnames <- names(valids) - items <- map_chr(seq_along(valids), function(i) { - paste0(rnames[i], ": ", style_italic(valids[[i]]$record), " ", - validation_interval(valids[[i]])) - }) - cli_li(items = items) - } + # validation_interval(valids[[i]]) } validation_interval <- function(x) { From dcc5c31326ed6ee2d79991cbd648c603c85d395a Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 14:47:29 +1000 Subject: [PATCH 73/83] update snapshots and fix lvl_nodes --- tests/testthat/_snaps/rcrds.md | 85 ++++++---------------------------- tests/testthat/test-nest.R | 12 ++--- 2 files changed, 18 insertions(+), 79 deletions(-) diff --git a/tests/testthat/_snaps/rcrds.md b/tests/testthat/_snaps/rcrds.md index 0fa6fec4..dc714d4a 100644 --- a/tests/testthat/_snaps/rcrds.md +++ b/tests/testthat/_snaps/rcrds.md @@ -33,10 +33,6 @@ | \-exam_mark +-style (2 levels) \-room - Allotment: - Message - * style ~ class - * exam ~ student --- @@ -76,10 +72,6 @@ +-style (2 levels) +-room \-teacher - Allotment: - Message - * style ~ class - * exam ~ student --- @@ -117,26 +109,13 @@ +-class (4 levels) | \-student (120 levels) | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender + | +-exam_mark [0, 100] + | +-quiz1_mark [0, 15] + | +-quiz2_mark [0, 30] + | \-gender [female, male, non-binary] +-style (2 levels) - +-room - \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: integer [0, 30] - * gender: factor [female, male, non-binary] - * teacher: text - * room: text + +-room + \-teacher --- @@ -149,24 +128,13 @@ +-class (4 levels) | \-student (120 levels) | +-exam (3 levels) - | +-exam_mark - | +-quiz1_mark - | +-quiz2_mark - | \-gender + | +-exam_mark [0, 100] + | +-quiz1_mark [0, 15] + | +-quiz2_mark [-Inf, 12) + | \-gender [female, male, non-binary] +-style (2 levels) +-room \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * quiz1_mark: integer [0, 15] - * quiz2_mark: numeric [-Inf, 12) - * gender: factor [female, male, non-binary] --- @@ -178,22 +146,13 @@ +-class (4 levels) | \-student (120 levels) | +-exam (3 levels) - | +-exam_mark + | +-exam_mark [0, 100] | +-quiz1_mark | +-quiz2_mark - | \-gender + | \-gender [female, male, non-binary] +-style (2 levels) +-room \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [0, 100] - * gender: factor [female, male, non-binary] --- @@ -204,21 +163,13 @@ +-class (4 levels) | \-student (120 levels) | +-exam (3 levels) - | +-exam_mark + | +-exam_mark [-Inf, -1) | +-quiz1_mark | +-quiz2_mark | \-gender +-style (2 levels) +-room \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric [-Inf, -1) --- @@ -229,19 +180,11 @@ +-class (4 levels) | \-student (120 levels) | +-exam (3 levels) - | +-exam_mark + | +-exam_mark (0, Inf] | +-quiz1_mark | +-quiz2_mark | \-gender +-style (2 levels) +-room \-teacher - Allotment: - Message - * style ~ class - * exam ~ student - Output - Validation: - Message - * exam_mark: numeric (0, Inf] diff --git a/tests/testthat/test-nest.R b/tests/testthat/test-nest.R index bb53fb33..36534188 100644 --- a/tests/testthat/test-nest.R +++ b/tests/testthat/test-nest.R @@ -9,12 +9,10 @@ test_that("nested-units", { expect_equal(fct_nodes(des1), tibble::tibble(name = c("block", "plot"), - role = "edbl_unit", - attrs = data.frame(row.names = 1:2))) + role = "edbl_unit")) # FIXME there is no attrs for the second factor expect_equal(lvl_nodes(des1), - list(block = tibble::tibble(value = c("block1", "block2", "block3"), - attrs = data.frame(row.names = 1:3)), + list(block = tibble::tibble(value = c("block1", "block2", "block3")), plot = tibble::tibble(value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6"))) ) des2 <- des1 %>% @@ -23,11 +21,9 @@ test_that("nested-units", { . ~ 3)) expect_equal(fct_nodes(des2), tibble::tibble(name = c("block", "plot", "sample"), - role = "edbl_unit", - attrs = data.frame(row.names = 1:3))) + role = "edbl_unit")) expect_equal(lvl_nodes(des2), - list(block = tibble::tibble(value = c("block1", "block2", "block3"), - attrs = data.frame(row.names = 1:3)), + list(block = tibble::tibble(value = c("block1", "block2", "block3")), plot = tibble::tibble(value = c("plot1", "plot2", "plot3", "plot4", "plot5", "plot6")), sample = tibble::tibble(value = c("sample01", "sample02", "sample03", "sample04", "sample05", "sample06", "sample07", "sample08", From c6081f93e6f0f16b3b0a92ea380640d7fe4e86bd Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Thu, 31 Aug 2023 14:47:36 +1000 Subject: [PATCH 74/83] fix lvl_nodes --- R/graph.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/graph.R b/R/graph.R index 934ecb58..3ba9fb1d 100644 --- a/R/graph.R +++ b/R/graph.R @@ -60,7 +60,7 @@ lvl_nodes <- function(x) { lnodes <- prov$lvl_nodes olnodes <- lapply(unclass(lnodes), function(.x) { out <- .x[setdiff(names(.x), "id")] - if(ncol(out$attrs)==0) out$attrs <- NULL + if("attrs" %in% names(out) && ncol(out$attrs)==0) out$attrs <- NULL out }) names(olnodes) <- prov$fct_names(id = as.numeric(names(olnodes))) From e194f3cbc6997528035e07411898fa86d6e1afd3 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Fri, 1 Sep 2023 17:51:37 +1000 Subject: [PATCH 75/83] using openxlsx2 now. Rewriting export_design. --- DESCRIPTION | 2 +- NAMESPACE | 3 +- R/export.R | 449 +++++++++--------- R/graph.R | 2 +- R/provenance.R | 21 +- R/rcrds.R | 1 - R/utils.R | 1 + man/Provenance.Rd | 20 +- man/activate_provenance.Rd | 5 +- ..._data_frame.Rd => as_tibble.edbl_table.Rd} | 6 +- man/export_design.Rd | 11 +- tests/testthat/test-export.R | 21 + 12 files changed, 295 insertions(+), 247 deletions(-) rename man/{as_data_frame.Rd => as_tibble.edbl_table.Rd} (76%) create mode 100644 tests/testthat/test-export.R diff --git a/DESCRIPTION b/DESCRIPTION index 06cde546..0797da42 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,7 @@ Imports: Suggests: testthat (>= 3.0.0), rmarkdown, - openxlsx, + openxlsx2 (>= 1.0.0), visNetwork Depends: R (>= 2.10) diff --git a/NAMESPACE b/NAMESPACE index 745518ed..d2d363a3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ S3method(as.integer,edbl_fct) S3method(as.integer,edbl_lvls) S3method(as.numeric,edbl_rcrd) S3method(as_edibble,default) +S3method(as_tibble,edbl_table) S3method(examine_recipe,default) S3method(examine_recipe,edbl_design) S3method(examine_recipe,edbl_table) @@ -62,7 +63,6 @@ export(allot_table) export(allot_trts) export(allot_units) export(anatomy) -export(as_data_frame) export(as_edibble) export(assign_trts) export(assign_units) @@ -155,6 +155,7 @@ importFrom(pillar,new_pillar_shaft_simple) importFrom(pillar,pillar_shaft) importFrom(pillar,style_subtle) importFrom(pillar,tbl_format_body) +importFrom(tibble,as_tibble) importFrom(tibble,new_tibble) importFrom(tibble,tbl_sum) importFrom(tidyselect,eval_select) diff --git a/R/export.R b/R/export.R index 4f753712..562513aa 100644 --- a/R/export.R +++ b/R/export.R @@ -1,198 +1,233 @@ -make_sheet_names <- function(prov = NULL) { - if(is_null(prov)) { - data_sheet_names <- "Data" - } else { - if(prov$rcrd_exists(abort = FALSE)) { - rids <- prov$rcrd_ids - # FIXME - rcrds <- rcrd_to_unit_dict(prov, rids) - units <- unique(unname(rcrds)) - if(length(units) == 1) { - data_sheet_names <- "Data" - } else { - data_sheet_names <- data_sheet_name(units) - } - } else { - data_sheet_names <- "Data" - } + + +#' Export the design to xlsx +#' +#' @description +#' This function is designed to export the design made using edibble to an +#' external xlsx file. +#' +#' @param .data An edibble data frame or design. +#' @param file File, including the path, to export the data to. +#' @param author Name of the author in character. A vector of character is supported +#' for where there are multiple authors. +#' @param date The date to be inserted in header. +#' @param overwrite A logical indicating whether to overwrite exisitng file or not. +#' +#' @importFrom cli cli_alert_success +#' @family user-facing functions +#' @return The input data object. +#' @export +export_design <- function(.data, + file, + author = NULL, + date = Sys.Date(), + theme = NULL, + overwrite = FALSE, + subject = NULL, + category = NULL) { + + if(!is_edibble_table(.data)) { + abort("The input is not an edibble table.") } - c("Context", data_sheet_names, "Variables") + if(!requireNamespace("openxlsx2")) { + abort("Please install the `openxlsx2` package to use this function.") + } + + prov <- activate_provenance(.data) + + title <- prov$get_title() + sheet_names <- make_sheet_names(prov) + + wb <- openxlsx2::wb_workbook(creator = author, + title = title, + subject = subject, + category = category, + datetime_created = Sys.time(), + theme = theme) + + # some large number to make it full size + # there's no way to set it to 100% or alike + # so this is a hack + wb$set_bookview(window_height = 10000000, + window_width = 10000000) + + + add_worksheets(wb, sheet_names, title) + add_creator(wb, author) + + write_title_sheet(wb, + sheet_names[1], + title, + author, + date) + + + # FIXME: producing some recovery error - idk why + write_data_sheet(wb, + sheet_names[-c(1, length(sheet_names))], + prov, + .data) + # FIXME: validation not implemented yet + # write_variables_sheet(wb, + # sheet_names[length(sheet_names)], + # cell_styles_list$variables, + # prov, + # .data) + + save_workbook(wb, file, overwrite, title) + + invisible(.data) } -make_cell_styles <- function() { - list(context = list(title = openxlsx::createStyle(fontSize = 30, - textDecoration = "bold"), - date = openxlsx::createStyle(fontSize = 25), - author = openxlsx::createStyle(fontSize = 25), - contact = openxlsx::createStyle(fontSize = 25), - context_name = openxlsx::createStyle(fontSize = 18, fontColour = "blue"), - context = openxlsx::createStyle(fontSize = 18), - instructions = openxlsx::createStyle(fontSize = 12)), - data = list(header = openxlsx::createStyle(fgFill = "#DCE6F1", - halign = "left", - textDecoration = "bold", - border = "Bottom"), - body = openxlsx::createStyle(fontSize = 12)), - variables = list(header = openxlsx::createStyle(fgFill = "#DCE6F1", - halign = "left", - textDecoration = "bold", - border = "Bottom"), - names = openxlsx::createStyle(fontSize = 14, - textDecoration = "bold"), - type = openxlsx::createStyle(fontSize = 14, - fontColour = "blue"), - what = openxlsx::createStyle(fontSize = 14), - validation = openxlsx::createStyle(fontSize = 14))) +data_sheet_name <- function(name) { + paste0("Data.", name) } -add_creator <- function(wb, authors) { - openxlsx::addCreator(wb, "Created with edibble using R") - if(!missing(authors)) { - for(author in authors) { - openxlsx::addCreator(wb, author) - } +make_sheet_names <- function(prov) { + if(!prov$rcrd_exists()) { + # if no record is supplied, then use the smallest unit + uname <- prov$fct_name(id = prov$fct_id_leaves(role = "edbl_unit")) + data_sheet_names <- data_sheet_name(uname) + names(data_sheet_names) <- uname + } else { + map_rcrd_to_unit <- prov$mapping("edbl_rcrd", "edbl_unit") + unames <- prov$fct_names(id = unique(map_rcrd_to_unit)) + data_sheet_names <- data_sheet_name(unames) + names(data_sheet_names) <- unames } + c("Context", data_sheet_names, "Variables") } + add_worksheets <- function(wb, sheet_names, title) { for(asheet in sheet_names) { - openxlsx::addWorksheet(wb, asheet, - header = c(paste0("Created on ", Sys.Date()), title, "&[Page] / &[Pages]"), - footer = c("&[File]", "&[Tab]", "Printed on &[Date]"), - gridLines = ifelse(asheet==sheet_names[1], FALSE, TRUE)) + wb$add_worksheet(asheet, + zoom = ifelse(asheet==sheet_names[1], 200, 100), + header = c(paste0("Created on ", Sys.Date()), title, "&[Page] / &[Pages]"), + footer = c("&[File]", "&[Tab]", "Printed on &[Date]"), + grid_lines = ifelse(asheet==sheet_names[1], FALSE, TRUE), + visible = ifelse(asheet=="Variables", "hidden", "visible")) } } +save_workbook <- function(wb, file, overwrite, title) { + tryCatch(wb$save(file = file, overwrite = overwrite), + error = function(e) { + cli::cli_alert_warning("Something went wrong. {.emph {title}} failed to be exported.") + }) + cli::cli_alert_success("{.emph {title}} has been written to {.file {file}}") +} + -write_title_sheet <- function(wb, sheet_name, cell_styles, prov, author, date = Sys.Date()) { +write_title_sheet <- function(wb, sheet_name, title, author, date) { # title - openxlsx::writeData(wb, sheet = sheet_name, x = prov$design$name, - startRow = 1, startCol = 1, name = "title") - openxlsx::addStyle(wb, sheet = sheet_name, - style = cell_styles$title, 1, 1, stack = TRUE) + title_pos <- openxlsx2::wb_dims(from_row = 1, from_col = 1) + wb$set_col_widths(sheet = sheet_name, + cols = 1, + widths = 100) # 250 is max + wb$add_data(sheet = sheet_name, + x = title, + dims = title_pos, + name = "title", + col_names = FALSE) + wb$add_font(sheet = sheet_name, + dims = title_pos, + bold = TRUE, + size = 30) + wb$add_cell_style(sheet = sheet_name, + dims = title_pos, + wrap_text = TRUE) # date - openxlsx::writeData(wb, sheet = sheet_name, x = date, - startRow = 2, startCol = 1, name = "date") - openxlsx::addStyle(wb, sheet_name, cell_styles$date, 2, 1, stack = TRUE) + date_pos <- openxlsx2::wb_dims(from_row = 2, from_col = 1) + wb$add_data(sheet = sheet_name, + x = date, + dims = date_pos, + name = "date", + col_names = FALSE) + wb$add_font(sheet = sheet_name, + dims = date_pos, + size = 25) + wb$add_cell_style(sheet = sheet_name, + dims = date_pos, + horizontal = "left") # author - if(!missing(author)) { - openxlsx::writeData(wb, sheet = sheet_name, x = author, - startRow = 3, startCol = 1, name = "author") - openxlsx::addStyle(wb, sheet_name, cell_styles$author, 3, 1, stack = TRUE) + if(!is_null(author)) { + author_pos <- openxlsx2::wb_dims(from_row = 3, from_col = 1) + wb$add_data(sheet = sheet_name, + x = author, + dims = author_pos, + name = "author", + col_names = FALSE) + wb$add_font(sheet = sheet_name, + dims = author_pos, + size = 25) } - # context - ncontext <- length(prov$design$context) - openxlsx::writeData(wb, sheet = sheet_name, - x = unlist(prov$design$context), - startRow = 5, startCol = 2) - openxlsx::addStyle(wb, sheet_name, cell_styles$context, 5:(5 + ncontext), 2, - stack = TRUE) - - openxlsx::writeData(wb, sheet = sheet_name, - x = names(prov$design$context), - startCol = 1, startRow = 5) - openxlsx::addStyle(wb, sheet_name, cell_styles$context_name, 5:(5 + ncontext), 1, - stack = TRUE) - - openxlsx::createNamedRegion(wb, sheet_name, cols = 1:2, rows = 5:(5 + ncontext), - name = "context") - - } -data_sheet_name <- function(name) { - paste0("Data.", name) -} -subset_design <- function(prov, unit, rcrds) { - keep_rids <- prov$fct_id(rcrds) - keep_uids <- prov$fct_id(unit) - keep_uids_ancestors <- prov$fct_ancestor(keep_uids) - sprov <- prov$clone() - sprov$fct_nodes <- sprov$fct_nodes[sprov$fct_nodes$id %in% c(keep_uids_ancestors, keep_rids), ] - sprov$fct_edges <- sprov$fct_edges[(sprov$fct_edges$to %in% keep_uids_ancestors & - sprov$fct_edges$from %in% keep_uids_ancestors) | - sprov$fct_edges$to %in% keep_rids, ] - sprov$lvl_nodes <- sprov$lvl_nodes[sprov$lvl_nodes$idvar %in% keep_uids_ancestors, ] - keep_lids_ancestors <- sprov$lvl_id() - sprov$lvl_edges <- sprov$lvl_edges[sprov$lvl_edges$to %in% keep_lids_ancestors & sprov$lvl_edges$from %in% keep_lids_ancestors, ] - if(!is_null(sprov$design$allotment$trts)) { - units <- map_chr(sprov$design$allotment$trts, function(x) all.vars(f_rhs(x))) - allotments <- sprov$design$allotment$trts[units %in% sprov$fct_names()] - if(is_empty(allotments)) { - sprov$design$allotment$trts <- NULL - } else { - sprov$design$allotment$trts <- allotments - } - } - if(!is_null(sprov$design$validation)) { - rcrds <- sprov$fct_names(keep_rids) - if(!any(rcrds %in% names(sprov$design$validation))) { - sprov$design$validation <- NULL - } else { - sprov$design$validation <- sprov$design$validation[rcrds] + +add_creator <- function(wb, authors) { + wb$add_creators(paste0("Created with edibble (version ", + utils::packageVersion("edibble"), + ") using R")) + if(!is_null(authors)) { + for(author in authors) { + wb$add_creators(author) } } - - sprov$design } -write_data_sheet <- function(wb, sheet_names, cell_styles, prov, .data) { - if(nrow(.data) && ncol(.data)) { - if(length(sheet_names) > 1) { - rids <- prov$rcrd_ids - rcrds2unit <- rcrd_to_unit_dict(prov, rids) - units <- unique(unname(rcrds2unit)) - for(aunit in units) { - rcrds <- names(rcrds2unit)[rcrds2unit==aunit] - des <- subset_design(prov, aunit, rcrds) - data <- as_data_frame(serve_table(des)) - openxlsx::writeData(wb, sheet = data_sheet_name(aunit), - x = data, startCol = 1, - headerStyle = cell_styles$header, - name = data_sheet_name(aunit)) - openxlsx::addStyle(wb, sheet = data_sheet_name(aunit), - rows = 2:(nrow(data) + 1), - cols = 1:ncol(data), gridExpand = TRUE, stack = TRUE, - style = cell_styles$body) + + +write_data_sheet <- function(wb, sheet_names, prov, data) { + if(!prov$rcrd_exists()) { + wb$add_data_table(sheet = sheet_names, + x = data, + table_name = sheet_names) + } else { + rids <- prov$rcrd_ids + rcrds2unit <- prov$mapping("edbl_rcrd", "edbl_unit") + uids <- unique(rcrds2unit) + for(uid in uids) { + uname <- prov$fct_names(id = uid) + rids <- names(rcrds2unit)[rcrds2unit==uid] + data <- as_tibble.edbl_table(prov$serve_units(id = uid, return = "value")) + for(rid in rids) { + data[[prov$fct_names(id = rid)]] <- NA } - } else { - data <- as_data_frame(.data) - openxlsx::writeData(wb, sheet = sheet_names, x = data, startCol = 1, - headerStyle = cell_styles$header, - name = "Data") - openxlsx::addStyle(wb, sheet = sheet_names, rows = 2:(nrow(data) + 1), - cols = 1:ncol(data), gridExpand = TRUE, stack = TRUE, - style = cell_styles$body) + wb$add_data_table(sheet = sheet_names[uname], + x = data, + table_name = sheet_names[uname]) } } - } write_variables_sheet <- function(wb, sheet_name, cell_styles, prov, .data) { type <- map_chr(.data, function(var) { - cls <- class(var) - if("edbl_unit" %in% cls) return("unit") - if("edbl_trt" %in% cls) return("trt") - if("edbl_rcrd" %in% cls) return("rcrd") - "var" - }) + cls <- class(var) + if("edbl_unit" %in% cls) return("unit") + if("edbl_trt" %in% cls) return("trt") + if("edbl_rcrd" %in% cls) return("rcrd") + "var" + }) data <- data.frame(variable = names(.data), - type = unname(type), - stringsAsFactors = FALSE) - if(!is_null(prov$design$validation)) { + type = unname(type), + stringsAsFactors = FALSE) + + # FIXME + valids <- prov$get_validation("rcrds") + if(!is_null(valids)) { data$record <- "" data$value <- "" - valid <- prov$design$validation - valid_names <- names(valid) + valid_names <- names(valids) rids <- prov$rcrd_ids rcrds <- rcrd_to_unit_dict(prov, rids) n_ounits <- length(unique(rcrds)) @@ -207,32 +242,40 @@ write_variables_sheet <- function(wb, sheet_name, cell_styles, prov, .data) { if(valid[[i]]$type != "list") { data$value[j] <- restriction_for_human(valid[[i]]$operator, valid[[i]]$value) openxlsx::dataValidation(wb, sheet = data_sheet, - rows = 1:nrow(dat) + 1, - cols = j, - type = valid[[i]]$type, - operator = valid[[i]]$operator, - value = valid[[i]]$value) + rows = 1:nrow(dat) + 1, + cols = j, + type = valid[[i]]$type, + operator = valid[[i]]$operator, + value = valid[[i]]$value) } else { k <- which(names(data) == "value") values <- valid[[i]]$values data$value[j] <- values[1] L <- LETTERS[c(k, k + length(values) - 1)] - openxlsx::writeData(wb, sheet = sheet_name, x = data.frame(t(values), stringsAsFactors = FALSE), - startCol = k, - startRow = j + 1, colNames = FALSE) - openxlsx::dataValidation(wb, sheet = data_sheet, - rows = 1:nrow(dat) + 1, - cols = j, - type = "list", operator = NULL, - value = paste0("'", sheet_name, "'!$", - L[1], "$", j + 1, ":$", L[2], "$", j + 1)) + openxlsx::writeData(wb, + sheet = sheet_name, + x = data.frame(t(values), stringsAsFactors = FALSE), + + startCol = k, + startRow = j + 1, colNames = FALSE) + openxlsx::dataValidation(wb, + sheet = data_sheet, + rows = 1:nrow(dat) + 1, + cols = j, + type = "list", + operator = NULL, + value = paste0("'", sheet_name, "'!$", + L[1], "$", j + 1, ":$", L[2], "$", j + 1)) } } } - openxlsx::writeData(wb, sheet = sheet_name, x = data, startCol = 1, - headerStyle = cell_styles$header, - name = "Variables") + openxlsx::writeData(wb, + sheet = sheet_name, + x = data, + startCol = 1, + headerStyle = cell_styles$header, + name = "Variables") } @@ -249,80 +292,22 @@ restriction_for_human <- function(operator, value) { "") } - -#' Export the design to xlsx -#' -#' @description -#' This function is designed to export the design made using edibble to an -#' external xlsx file. -#' -#' @param .data An edibble data frame or design. -#' @param file File, including the path, to export the data to. -#' @param author Name of the author in character. A vector of character is supported -#' for where there are multiple authors. -#' @param date The date to be inserted in header. -#' @param overwrite A logical indicating whether to overwrite exisitng file or not. -#' -#' @importFrom cli cli_alert_success -#' @family user-facing functions -#' @return The input data object. -#' @export -export_design <- function(.data, file, author, date = Sys.Date(), overwrite = FALSE) { - if(!requireNamespace("openxlsx")) { - stop("Please install the `openxlsx` package to use this function.") - } - - if(is_edibble_table(.data)) { - .design <- attr(.data, "design") - } else { - abort("The input is not an edibble table.") - } - prov <- activate_provenance(.design) - - title <- .design$name - sheet_names <- make_sheet_names(prov) - cell_styles_list <- make_cell_styles() - - wb <- openxlsx::createWorkbook() - add_worksheets(wb, sheet_names, title) - add_creator(wb, author) - - write_title_sheet(wb, sheet_names[1], - cell_styles_list$context, prov, author, date) - write_data_sheet(wb, sheet_names[-c(1, length(sheet_names))], - cell_styles_list$data, prov, .data) - write_variables_sheet(wb, sheet_names[length(sheet_names)], - cell_styles_list$variables, prov, .data) - - save_workbook(wb, file, overwrite, prov) - invisible(.data) -} - -save_workbook <- function(wb, file, overwrite, prov) { - success <- openxlsx::saveWorkbook(wb, file, overwrite = overwrite, returnValue = TRUE) - if(success) { - cli::cli_alert_success("{.emph {prov$design$name}} has been written to {.file {file}}") - } else { - cli::cli_alert_warning("Something went wrong. {.emph {prov$design$name}} failed to be exported.") - } -} - #' Convert an edibble data frame to normal data frame #' #' A patch function where there is an issue with edbl factors #' #' @param .data can be a list or data frame #' @return A data.frame. +#' @importFrom tibble as_tibble #' @export -as_data_frame <- function(.data) { +as_tibble.edbl_table <- function(.data) { rcrd_names <- names(.data)[map_lgl(.data, function(x) "edbl_rcrd" %in% class(x))] .data[rcrd_names] <- lapply(.data[rcrd_names], unclass) structure(lapply(.data, function(x) { - if(inherits(x, "edbl_unit")) return(as.character(x)) - if(inherits(x, "edbl_trt")) return(as.character(x)) - if(inherits(x, "edbl_rcrd")) return(as.numeric(x)) + class(x) <- setdiff(class(x), c("edbl_unit", "edbl_rcrd", "edbl_trt", "edbl_fct", "vctrs_vctr")) + attr(x, "levels") <- NULL return(x) }), names = names(.data), - class = "data.frame", + class = c("tbl_df", "tbl", "data.frame"), row.names = 1:vec_size_common(!!!.data)) } diff --git a/R/graph.R b/R/graph.R index 3ba9fb1d..3dd309e7 100644 --- a/R/graph.R +++ b/R/graph.R @@ -17,7 +17,7 @@ #' activate_provenance(takeout()) #' @export activate_provenance <- function(.edibble, - overwrite = c("graph", "anatomy", "recipe")) { + overwrite = c("graph", "anatomy", "recipe", "validation")) { des <- edbl_design(.edibble) prov <- des$provenance if(!is_environment(prov)) { diff --git a/R/provenance.R b/R/provenance.R index 19f2713e..c62e295d 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -72,7 +72,7 @@ Provenance <- R6::R6Class("Provenance", #' @param design An edibble design #' @param overwrite A vector of character to overwrite from the #' supplied design object. - reactivate = function(design, overwrite = c("graph", "anatomy", "recipe")) { + reactivate = function(design, overwrite = c("graph", "anatomy", "recipe", "validation")) { #private$record_track_internal() for(obj in overwrite) { private[[obj]] <- design[[obj]] @@ -82,7 +82,7 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Deactivate the provenance object. #' @param delete A vector of character to delete. - deactivate = function(delete = c("graph", "anatomy", "recipe")) { + deactivate = function(delete = c("graph", "anatomy", "recipe", "validation")) { #private$record_track_internal() for(obj in delete) { private[[obj]] <- NULL @@ -652,7 +652,8 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Get the validation #' @param type A type. - get_validation = function(type) { + get_validation = function(type = NULL) { + if(is_null(type)) return(private$validation) private$validation[[type]] }, @@ -686,6 +687,20 @@ Provenance <- R6::R6Class("Provenance", private$edibble_version }, + #' @description + #' Mapping of a role to role + mapping = function(role_from, role_to) { + ids <- self$fct_id(role = role_from) + out <- map_int(ids, function(id_from) { + id_to <- self$fct_id_child(id = id_from, role = role_to) + vctrs::vec_assert(id_to, integer(), size = 1) + id_to + }) + names(out) <- ids + out + }, + + #' @description #' Record step. record_step = function() { diff --git a/R/rcrds.R b/R/rcrds.R index 6b67ac3f..796ae37d 100644 --- a/R/rcrds.R +++ b/R/rcrds.R @@ -89,7 +89,6 @@ expect_rcrds <- function(.edibble, ..., .record = TRUE) { rules_unnamed <- stats::setNames(rules_unnamed, map_chr(rules_unnamed, function(x) x$rcrd)) prov$set_validation(simplify_validation(c(rules_named, rules_unnamed)), type = "rcrds") - return_edibble_with_graph(.edibble, prov) } diff --git a/R/utils.R b/R/utils.R index fb84a667..ab851713 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,6 +2,7 @@ return_edibble_with_graph <- function(edibble, prov) { des <- edbl_design(edibble) des$graph <- prov$get_graph() + des$validation <- prov$get_validation() if(is_edibble_table(edibble)) { attr(edibble, "design") <- des edibble diff --git a/man/Provenance.Rd b/man/Provenance.Rd index 5366ab55..d1041002 100644 --- a/man/Provenance.Rd +++ b/man/Provenance.Rd @@ -95,6 +95,7 @@ Remember that there could be more than one order.} \item \href{#method-Provenance-get_seed}{\code{Provenance$get_seed()}} \item \href{#method-Provenance-get_session_info}{\code{Provenance$get_session_info()}} \item \href{#method-Provenance-get_edibble_version}{\code{Provenance$get_edibble_version()}} +\item \href{#method-Provenance-mapping}{\code{Provenance$mapping()}} \item \href{#method-Provenance-record_step}{\code{Provenance$record_step()}} \item \href{#method-Provenance-record_track_external}{\code{Provenance$record_track_external()}} \item \href{#method-Provenance-clone}{\code{Provenance$clone()}} @@ -176,7 +177,10 @@ Set the validation. \subsection{Method \code{reactivate()}}{ Reactivate the graph in the provenance object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$reactivate(design, overwrite = c("graph", "anatomy", "recipe"))}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$reactivate( + design, + overwrite = c("graph", "anatomy", "recipe", "validation") +)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -196,7 +200,7 @@ supplied design object.} \subsection{Method \code{deactivate()}}{ Deactivate the provenance object. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$deactivate(delete = c("graph", "anatomy", "recipe"))}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$deactivate(delete = c("graph", "anatomy", "recipe", "validation"))}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -970,7 +974,7 @@ Get the title \subsection{Method \code{get_validation()}}{ Get the validation \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{Provenance$get_validation(type)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{Provenance$get_validation(type = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ @@ -1030,6 +1034,16 @@ Get the edibble version. \if{html}{\out{
}}\preformatted{Provenance$get_edibble_version()}\if{html}{\out{
}} } +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-mapping}{}}} +\subsection{Method \code{mapping()}}{ +Mapping of a role to role +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$mapping(role_from, role_to)}\if{html}{\out{
}} +} + } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/activate_provenance.Rd b/man/activate_provenance.Rd index f432ff29..2e232bcd 100644 --- a/man/activate_provenance.Rd +++ b/man/activate_provenance.Rd @@ -4,7 +4,10 @@ \alias{activate_provenance} \title{Activate the provenance in the edibble design object} \usage{ -activate_provenance(.edibble, overwrite = c("graph", "anatomy", "recipe")) +activate_provenance( + .edibble, + overwrite = c("graph", "anatomy", "recipe", "validation") +) } \arguments{ \item{x}{An edibble object.} diff --git a/man/as_data_frame.Rd b/man/as_tibble.edbl_table.Rd similarity index 76% rename from man/as_data_frame.Rd rename to man/as_tibble.edbl_table.Rd index 8f95a35d..027492fe 100644 --- a/man/as_data_frame.Rd +++ b/man/as_tibble.edbl_table.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/export.R -\name{as_data_frame} -\alias{as_data_frame} +\name{as_tibble.edbl_table} +\alias{as_tibble.edbl_table} \title{Convert an edibble data frame to normal data frame} \usage{ -as_data_frame(.data) +\method{as_tibble}{edbl_table}(.data) } \arguments{ \item{.data}{can be a list or data frame} diff --git a/man/export_design.Rd b/man/export_design.Rd index 267f9b19..d13ae436 100644 --- a/man/export_design.Rd +++ b/man/export_design.Rd @@ -4,7 +4,16 @@ \alias{export_design} \title{Export the design to xlsx} \usage{ -export_design(.data, file, author, date = Sys.Date(), overwrite = FALSE) +export_design( + .data, + file, + author = NULL, + date = Sys.Date(), + theme = NULL, + overwrite = FALSE, + subject = NULL, + category = NULL +) } \arguments{ \item{.data}{An edibble data frame or design.} diff --git a/tests/testthat/test-export.R b/tests/testthat/test-export.R new file mode 100644 index 00000000..b6fa86c6 --- /dev/null +++ b/tests/testthat/test-export.R @@ -0,0 +1,21 @@ +test_that("export works", { + set.seed(1) + des0 <- takeout(menu_split()) %>% + set_rcrds(yield = mainplot, + height = subplot, + genotype = subplot, + yield_date = mainplot) %>% + expect_rcrds(yield > 0, + #date = to_be_date(range = edibble::) + 100 > height, + height > 0, + factor(genotype, levels = c("A", "B"))) + + prov <- activate_provenance(des0) + prov$get_validation("rcrd") + + ## validation by writing file and reading it in + + export_design(des0, file = "~/Downloads/test.xlsx", overwrite = TRUE) + +}) From d3b1f3280341bb5ba6b5cdde12ac7651ae250fae Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 2 Sep 2023 09:00:54 +1000 Subject: [PATCH 76/83] fix export_design --- R/export.R | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/R/export.R b/R/export.R index 562513aa..005bea8a 100644 --- a/R/export.R +++ b/R/export.R @@ -186,10 +186,20 @@ add_creator <- function(wb, authors) { write_data_sheet <- function(wb, sheet_names, prov, data) { + if(!prov$rcrd_exists()) { wb$add_data_table(sheet = sheet_names, x = data, - table_name = sheet_names) + table_style = "TableStyleMedium9", + na.strings = "", + with_filter = FALSE) + col_width <- vapply(data, function(x) max(nchar(format(x))), + NA_real_) + + wb$set_col_widths(sheet = sheet_names[uname], + cols = 1:ncol(data), + widths = max(col_width)) + } else { rids <- prov$rcrd_ids rcrds2unit <- prov$mapping("edbl_rcrd", "edbl_unit") @@ -201,9 +211,22 @@ write_data_sheet <- function(wb, sheet_names, prov, data) { for(rid in rids) { data[[prov$fct_names(id = rid)]] <- NA } + wb$add_data_table(sheet = sheet_names[uname], x = data, - table_name = sheet_names[uname]) + # below causes XML error so omit + #table_name = sheet_names[uname], + table_style = "TableStyleMedium9", + na.strings = "", + with_filter = FALSE) + + col_width <- vapply(data, function(x) max(nchar(format(x))), + NA_real_) + + wb$set_col_widths(sheet = sheet_names[uname], + cols = 1:ncol(data), + widths = max(col_width)) + } } } @@ -306,6 +329,7 @@ as_tibble.edbl_table <- function(.data) { structure(lapply(.data, function(x) { class(x) <- setdiff(class(x), c("edbl_unit", "edbl_rcrd", "edbl_trt", "edbl_fct", "vctrs_vctr")) attr(x, "levels") <- NULL + attr(x, "name") <- NULL return(x) }), names = names(.data), class = c("tbl_df", "tbl", "data.frame"), From bf0faaa64b7c0ad08c6c71f6c239f333f616c03d Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 2 Sep 2023 09:08:09 +1000 Subject: [PATCH 77/83] improve write_data_sheet --- R/export.R | 43 ++++++++++++------------------------------- 1 file changed, 12 insertions(+), 31 deletions(-) diff --git a/R/export.R b/R/export.R index 005bea8a..03efb218 100644 --- a/R/export.R +++ b/R/export.R @@ -186,48 +186,29 @@ add_creator <- function(wb, authors) { write_data_sheet <- function(wb, sheet_names, prov, data) { + for(iunit in seq_along(sheet_names)) { + if(prov$rcrd_exists()) { + uid <- prov$fct_id(name = names(sheet_names)[iunit]) + data <- as_tibble.edbl_table(prov$serve_units(id = uid, return = "value")) + rids <- prov$fct_id_parent(id = uid, role = "edbl_rcrd") + for(rid in rids) { + data[[prov$fct_names(id = rid)]] <- NA + } + } - if(!prov$rcrd_exists()) { - wb$add_data_table(sheet = sheet_names, + wb$add_data_table(sheet = sheet_names[iunit], x = data, table_style = "TableStyleMedium9", na.strings = "", with_filter = FALSE) + col_width <- vapply(data, function(x) max(nchar(format(x))), NA_real_) - wb$set_col_widths(sheet = sheet_names[uname], + wb$set_col_widths(sheet = sheet_names[iunit], cols = 1:ncol(data), widths = max(col_width)) - } else { - rids <- prov$rcrd_ids - rcrds2unit <- prov$mapping("edbl_rcrd", "edbl_unit") - uids <- unique(rcrds2unit) - for(uid in uids) { - uname <- prov$fct_names(id = uid) - rids <- names(rcrds2unit)[rcrds2unit==uid] - data <- as_tibble.edbl_table(prov$serve_units(id = uid, return = "value")) - for(rid in rids) { - data[[prov$fct_names(id = rid)]] <- NA - } - - wb$add_data_table(sheet = sheet_names[uname], - x = data, - # below causes XML error so omit - #table_name = sheet_names[uname], - table_style = "TableStyleMedium9", - na.strings = "", - with_filter = FALSE) - - col_width <- vapply(data, function(x) max(nchar(format(x))), - NA_real_) - - wb$set_col_widths(sheet = sheet_names[uname], - cols = 1:ncol(data), - widths = max(col_width)) - - } } } From 7ea5ecb4a47f014a2769bfef9561977af5687647 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 2 Sep 2023 09:24:26 +1000 Subject: [PATCH 78/83] update doc --- NAMESPACE | 1 - R/export.R | 41 +++++++++++++++-------------------------- R/provenance.R | 2 ++ man/Provenance.Rd | 9 +++++++++ man/export_design.Rd | 18 ++++++++++++------ 5 files changed, 38 insertions(+), 33 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index d2d363a3..0e6e373e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -140,7 +140,6 @@ export(vec_math) export(with_value) import(rlang) importFrom(cli,ansi_strip) -importFrom(cli,cli_alert_success) importFrom(cli,cli_end) importFrom(cli,cli_h1) importFrom(cli,cli_h2) diff --git a/R/export.R b/R/export.R index 03efb218..4447548f 100644 --- a/R/export.R +++ b/R/export.R @@ -7,14 +7,15 @@ #' This function is designed to export the design made using edibble to an #' external xlsx file. #' -#' @param .data An edibble data frame or design. +#' @param .data An edibble table to export. #' @param file File, including the path, to export the data to. -#' @param author Name of the author in character. A vector of character is supported +#' @param author (Optional) name of the author in character. A vector of character is supported #' for where there are multiple authors. -#' @param date The date to be inserted in header. -#' @param overwrite A logical indicating whether to overwrite exisitng file or not. -#' -#' @importFrom cli cli_alert_success +#' @param date The date to be inserted in header (defaults to today). +#' @param overwrite A logical indicating whether to overwrite existing file or not. +#' @param subject The subject of the workbook (optional). +#' @param category The category of the workbook (optional). +#' @param table_style The table style to apply to the exported data (default: "TableStyleMedium9"). #' @family user-facing functions #' @return The input data object. #' @export @@ -22,10 +23,10 @@ export_design <- function(.data, file, author = NULL, date = Sys.Date(), - theme = NULL, overwrite = FALSE, subject = NULL, - category = NULL) { + category = NULL, + table_style = "TableStyleMedium9") { if(!is_edibble_table(.data)) { abort("The input is not an edibble table.") @@ -57,24 +58,12 @@ export_design <- function(.data, add_worksheets(wb, sheet_names, title) add_creator(wb, author) - write_title_sheet(wb, - sheet_names[1], - title, - author, - date) - + write_title_sheet(wb, sheet_names[1], title, author, date) - # FIXME: producing some recovery error - idk why - write_data_sheet(wb, - sheet_names[-c(1, length(sheet_names))], - prov, - .data) + write_data_sheet(wb, sheet_names[-c(1, length(sheet_names))], prov, .data, + table_style) # FIXME: validation not implemented yet - # write_variables_sheet(wb, - # sheet_names[length(sheet_names)], - # cell_styles_list$variables, - # prov, - # .data) + write_variables_sheet(wb, sheet_names[length(sheet_names)], prov, .data) save_workbook(wb, file, overwrite, title) @@ -185,7 +174,7 @@ add_creator <- function(wb, authors) { -write_data_sheet <- function(wb, sheet_names, prov, data) { +write_data_sheet <- function(wb, sheet_names, prov, data, table_style) { for(iunit in seq_along(sheet_names)) { if(prov$rcrd_exists()) { uid <- prov$fct_id(name = names(sheet_names)[iunit]) @@ -198,7 +187,7 @@ write_data_sheet <- function(wb, sheet_names, prov, data) { wb$add_data_table(sheet = sheet_names[iunit], x = data, - table_style = "TableStyleMedium9", + table_style = table_style, na.strings = "", with_filter = FALSE) diff --git a/R/provenance.R b/R/provenance.R index c62e295d..6281dac0 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -689,6 +689,8 @@ Provenance <- R6::R6Class("Provenance", #' @description #' Mapping of a role to role + #' @param role_from The role from. + #' @param role_to The role to. mapping = function(role_from, role_to) { ids <- self$fct_id(role = role_from) out <- map_int(ids, function(id_from) { diff --git a/man/Provenance.Rd b/man/Provenance.Rd index d1041002..a31a1024 100644 --- a/man/Provenance.Rd +++ b/man/Provenance.Rd @@ -1044,6 +1044,15 @@ Mapping of a role to role \if{html}{\out{
}}\preformatted{Provenance$mapping(role_from, role_to)}\if{html}{\out{
}} } +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{role_from}}{The role from.} + +\item{\code{role_to}}{The role to.} +} +\if{html}{\out{
}} +} } \if{html}{\out{
}} \if{html}{\out{}} diff --git a/man/export_design.Rd b/man/export_design.Rd index d13ae436..282874c0 100644 --- a/man/export_design.Rd +++ b/man/export_design.Rd @@ -9,23 +9,29 @@ export_design( file, author = NULL, date = Sys.Date(), - theme = NULL, overwrite = FALSE, subject = NULL, - category = NULL + category = NULL, + table_style = "TableStyleMedium9" ) } \arguments{ -\item{.data}{An edibble data frame or design.} +\item{.data}{An edibble table to export.} \item{file}{File, including the path, to export the data to.} -\item{author}{Name of the author in character. A vector of character is supported +\item{author}{(Optional) name of the author in character. A vector of character is supported for where there are multiple authors.} -\item{date}{The date to be inserted in header.} +\item{date}{The date to be inserted in header (defaults to today).} -\item{overwrite}{A logical indicating whether to overwrite exisitng file or not.} +\item{overwrite}{A logical indicating whether to overwrite existing file or not.} + +\item{subject}{The subject of the workbook (optional).} + +\item{category}{The category of the workbook (optional).} + +\item{table_style}{The table style to apply to the exported data (default: "TableStyleMedium9").} } \value{ The input data object. From 6fb4639f548a22a0c18a122caa88172f86ce94dd Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sat, 2 Sep 2023 20:36:30 +1000 Subject: [PATCH 79/83] data export with hierchies --- R/export.R | 90 ++++++++++++++++++++++++++---------- R/provenance.R | 21 ++++----- man/export_design.Rd | 3 ++ tests/testthat/test-export.R | 22 ++++++--- 4 files changed, 94 insertions(+), 42 deletions(-) diff --git a/R/export.R b/R/export.R index 4447548f..6a79aa11 100644 --- a/R/export.R +++ b/R/export.R @@ -12,7 +12,10 @@ #' @param author (Optional) name of the author in character. A vector of character is supported #' for where there are multiple authors. #' @param date The date to be inserted in header (defaults to today). -#' @param overwrite A logical indicating whether to overwrite existing file or not. +#' @param overwrite A logical value indicating whether to overwrite existing file or not. +#' @param hide_treatments A logical value indicating whether treatments should be included in the data entry sheet. +#' Default is true. +#' @param theme The Excel theme to use (optional). One of "Atlas", "Badge", "Berlin", "Celestial", "Crop", "Depth", "Droplet", "Facet", "Feathered", "Gallery", "Headlines", "Integral", "Ion", "Ion Boardroom", "Madison", "Main Event", "Mesh", "Office Theme", "Old Office Theme", "Organic", "Parallax", "Parcel", "Retrospect", "Savon", "Slice", "Vapor Trail", "View", "Wisp", "Wood Type". #' @param subject The subject of the workbook (optional). #' @param category The category of the workbook (optional). #' @param table_style The table style to apply to the exported data (default: "TableStyleMedium9"). @@ -24,6 +27,8 @@ export_design <- function(.data, author = NULL, date = Sys.Date(), overwrite = FALSE, + hide_treatments = FALSE, + theme = NULL, subject = NULL, category = NULL, table_style = "TableStyleMedium9") { @@ -60,10 +65,14 @@ export_design <- function(.data, write_title_sheet(wb, sheet_names[1], title, author, date) - write_data_sheet(wb, sheet_names[-c(1, length(sheet_names))], prov, .data, - table_style) + write_data_sheet(wb, sheet_names[-c(1, 2, length(sheet_names))], prov, + as_tibble(.data), table_style, hide_treatments) + + write_grand_data_sheet(wb, sheet_names[2], prov, + as_tibble(.data), table_style) + # FIXME: validation not implemented yet - write_variables_sheet(wb, sheet_names[length(sheet_names)], prov, .data) + #write_variables_sheet(wb, sheet_names[length(sheet_names)], prov, .data) save_workbook(wb, file, overwrite, title) @@ -75,18 +84,19 @@ data_sheet_name <- function(name) { } make_sheet_names <- function(prov) { - if(!prov$rcrd_exists()) { - # if no record is supplied, then use the smallest unit - uname <- prov$fct_name(id = prov$fct_id_leaves(role = "edbl_unit")) - data_sheet_names <- data_sheet_name(uname) - names(data_sheet_names) <- uname + rexists <- prov$rcrd_exists(abort = FALSE) + texists <- prov$trt_exists(abort = FALSE) + if(!rexists & !texists) { + # if no record and treatment is supplied, then use the smallest unit + uname <- prov$fct_names(id = prov$fct_id_leaves(role = "edbl_unit")) } else { map_rcrd_to_unit <- prov$mapping("edbl_rcrd", "edbl_unit") - unames <- prov$fct_names(id = unique(map_rcrd_to_unit)) - data_sheet_names <- data_sheet_name(unames) - names(data_sheet_names) <- unames + map_trt_to_unit <- prov$mapping("edbl_trt", "edbl_unit") + uname <- prov$fct_names(id = unique(c(map_rcrd_to_unit))) } - c("Context", data_sheet_names, "Variables") + data_sheet_names <- data_sheet_name(uname) + names(data_sheet_names) <- uname + c("Context", "Data", data_sheet_names, "Variables") } @@ -174,34 +184,64 @@ add_creator <- function(wb, authors) { -write_data_sheet <- function(wb, sheet_names, prov, data, table_style) { +write_data_sheet <- function(wb, sheet_names, prov, data, table_style, hide_treatments) { for(iunit in seq_along(sheet_names)) { - if(prov$rcrd_exists()) { + + if(prov$rcrd_exists(abort = FALSE)) { uid <- prov$fct_id(name = names(sheet_names)[iunit]) data <- as_tibble.edbl_table(prov$serve_units(id = uid, return = "value")) + if(prov$trt_exists(abort = FALSE) && !hide_treatments) { + trts <- as_tibble.edbl_table(prov$serve_trts(id = prov$fct_id_parent(id = uid, role = "edbl_trt"), + return = "value")) + data <- cbind(data, trts) + } rids <- prov$fct_id_parent(id = uid, role = "edbl_rcrd") for(rid in rids) { data[[prov$fct_names(id = rid)]] <- NA } } - wb$add_data_table(sheet = sheet_names[iunit], - x = data, - table_style = table_style, - na.strings = "", - with_filter = FALSE) + write_data_table(wb, sheet_names[iunit], data, table_style) + + } +} - col_width <- vapply(data, function(x) max(nchar(format(x))), - NA_real_) +write_data_table <- function(wb, sheet, data, table_style) { + wb$add_data_table(sheet = sheet, + x = data, + table_style = table_style, + na.strings = "", + with_filter = FALSE) - wb$set_col_widths(sheet = sheet_names[iunit], - cols = 1:ncol(data), - widths = max(col_width)) + col_width <- vapply(data, function(x) max(nchar(format(x))), + NA_real_) + + wb$set_col_widths(sheet = sheet, + cols = 1:ncol(data), + widths = max(col_width)) +} + + +write_grand_data_sheet <- function(wb, sheet_name, prov, data, table_style) { + if(prov$rcrd_exists(abort = FALSE)) { + map_rcrd_to_unit <- prov$mapping("edbl_rcrd", "edbl_unit") + for(rid in as.numeric(names(map_rcrd_to_unit))) { + rname <- prov$fct_names(id = rid) + uname <- prov$fct_names(id = map_rcrd_to_unit[as.character(rid)]) + dname <- data_sheet_name(uname) + df <- wb$to_df(sheet = dname) + col <- match(rname, names(df)) + rows <- match(data[[uname]], df[[uname]]) + data[[rname]] <- paste0(dname, "!", map_chr(rows, function(row) wb_dims(row + 1L, col))) + class(data[[rname]]) <- c(class(data[[rname]]), "formula") + } } + write_data_table(wb, sheet_name, data, table_style) } + write_variables_sheet <- function(wb, sheet_name, cell_styles, prov, .data) { type <- map_chr(.data, function(var) { diff --git a/R/provenance.R b/R/provenance.R index 6281dac0..9113f66a 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -360,7 +360,7 @@ Provenance <- R6::R6Class("Provenance", #' the intersection of it will be checked. fct_exists = function(id = NULL, name = NULL, role = NULL, abort = TRUE) { exist <- TRUE - abort_missing <- function(vars = NULL, msg = NULL) { + abort_missing <- function(vars = NULL, msg = NULL, abort = NULL) { if(abort & !exist) { if(!is_null(vars)) { abort(sprintf("%s does not exist in the design.", @@ -376,46 +376,47 @@ Provenance <- R6::R6Class("Provenance", # at least one node exists if(is_null(name) & is_null(id) & is_null(role)) { exist <- nrow(fnodes) > 0 - abort_missing(msg = "There are no factor nodes.") + abort_missing(msg = "There are no factor nodes.", abort = abort) } else if(!is_null(name) & is_null(id) & is_null(role)) { vexist <- name %in% fnodes$name exist <- all(vexist) - abort_missing(vars = name[!vexist]) + abort_missing(vars = name[!vexist], abort = abort) } else if(is_null(name) & !is_null(id) & is_null(role)) { vexist <- id %in% fnodes$id exist <- all(vexist) - abort_missing(vars = id[!vexist]) + abort_missing(vars = id[!vexist], abort = abort) } else if(is_null(name) & is_null(id) & !is_null(role)) { exist <- any(role %in% fnodes$role) abort_missing(msg = sprintf("There are no factors with role %s", - .combine_words(paste0("`", role, "`")))) + .combine_words(paste0("`", role, "`"))), + abort = abort) } else if(is_null(name) & !is_null(id) & !is_null(role)) { srole <- fnodes[match(id, fnodes$id), "role", drop = TRUE] vexist <- srole %in% role exist <- all(vexist) - abort_missing(vars = id[!vexist]) + abort_missing(vars = id[!vexist], abort = abort) } else if(!is_null(name) & is_null(id) & !is_null(role)) { srole <- fnodes[match(name, fnodes$name), "role", drop = TRUE] vexist <- srole %in% role exist <- all(vexist) - abort_missing(vars = name[!vexist]) + abort_missing(vars = name[!vexist], abort = abort) } else if(!is_null(name) & !is_null(id) & is_null(role)) { sid <- fnodes[match(name, fnodes$name), "id", drop = TRUE] vexist <- sid %in% id exist <- all(vexist) - abort_missing(vars = name[!vexist]) + abort_missing(vars = name[!vexist], abort = abort) } else { snodes <- fnodes[match(name, fnodes$name), ] vexist <- snodes$id %in% id & snodes$role %in% role exist <- all(vexist) - abort_missing(vars = name[!vexist]) + abort_missing(vars = name[!vexist], abort = abort) } return(exist) @@ -550,8 +551,6 @@ Provenance <- R6::R6Class("Provenance", lnodes <- self$lvl_nodes ledges <- self$lvl_edges - - serve_trt = function(fid) { # linked unit - # each treatment factor should only be applied to a single unit factor diff --git a/man/export_design.Rd b/man/export_design.Rd index 282874c0..98d8d864 100644 --- a/man/export_design.Rd +++ b/man/export_design.Rd @@ -10,6 +10,7 @@ export_design( author = NULL, date = Sys.Date(), overwrite = FALSE, + theme = NULL, subject = NULL, category = NULL, table_style = "TableStyleMedium9" @@ -27,6 +28,8 @@ for where there are multiple authors.} \item{overwrite}{A logical indicating whether to overwrite existing file or not.} +\item{theme}{The Excel theme to use (optional). One of "Atlas", "Badge", "Berlin", "Celestial", "Crop", "Depth", "Droplet", "Facet", "Feathered", "Gallery", "Headlines", "Integral", "Ion", "Ion Boardroom", "Madison", "Main Event", "Mesh", "Office Theme", "Old Office Theme", "Organic", "Parallax", "Parcel", "Retrospect", "Savon", "Slice", "Vapor Trail", "View", "Wisp", "Wood Type".} + \item{subject}{The subject of the workbook (optional).} \item{category}{The category of the workbook (optional).} diff --git a/tests/testthat/test-export.R b/tests/testthat/test-export.R index b6fa86c6..edec5b9f 100644 --- a/tests/testthat/test-export.R +++ b/tests/testthat/test-export.R @@ -1,6 +1,16 @@ -test_that("export works", { +test_that("export with no record", { set.seed(1) - des0 <- takeout(menu_split()) %>% + des <- takeout() + fn <- tempfile() + export_design(des0, file = fn, overwrite = TRUE) + dat <- openxlsx2::read_xlsx(fn, sheet = 2) + + expect_equal(dat, as_tibble(des), ignore_attr = TRUE) +}) + +test_that("export with record", { + set.seed(1) + des <- takeout(menu_split()) %>% set_rcrds(yield = mainplot, height = subplot, genotype = subplot, @@ -11,11 +21,11 @@ test_that("export works", { height > 0, factor(genotype, levels = c("A", "B"))) - prov <- activate_provenance(des0) - prov$get_validation("rcrd") - ## validation by writing file and reading it in + fn <- tempfile() + export_design(des, file = fn, overwrite = TRUE) - export_design(des0, file = "~/Downloads/test.xlsx", overwrite = TRUE) + dat <- openxlsx2::read_xlsx(fn, sheet = 2) + #expect_equal(dat, as_tibble(des), ignore_attr = TRUE) }) From 572e6063e35225f411402dd4d8bc12505a9cb66b Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sun, 3 Sep 2023 10:13:19 +1000 Subject: [PATCH 80/83] mapping_to_unit --- R/provenance.R | 5 +++++ man/Provenance.Rd | 18 ++++++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/R/provenance.R b/R/provenance.R index 9113f66a..87b11c9f 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -701,6 +701,11 @@ Provenance <- R6::R6Class("Provenance", out }, + #' @description + #' Mapping of an id to a unit + mapping_to_unit = function(id = NULL) { + self$fct_id_child(id = id, role = "edbl_unit") + }, #' @description #' Record step. diff --git a/man/Provenance.Rd b/man/Provenance.Rd index a31a1024..e42341d9 100644 --- a/man/Provenance.Rd +++ b/man/Provenance.Rd @@ -96,6 +96,7 @@ Remember that there could be more than one order.} \item \href{#method-Provenance-get_session_info}{\code{Provenance$get_session_info()}} \item \href{#method-Provenance-get_edibble_version}{\code{Provenance$get_edibble_version()}} \item \href{#method-Provenance-mapping}{\code{Provenance$mapping()}} +\item \href{#method-Provenance-mapping_to_unit}{\code{Provenance$mapping_to_unit()}} \item \href{#method-Provenance-record_step}{\code{Provenance$record_step()}} \item \href{#method-Provenance-record_track_external}{\code{Provenance$record_track_external()}} \item \href{#method-Provenance-clone}{\code{Provenance$clone()}} @@ -1055,6 +1056,23 @@ Mapping of a role to role } } \if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-Provenance-mapping_to_unit}{}}} +\subsection{Method \code{mapping_to_unit()}}{ +Mapping of an id to a unit +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{Provenance$mapping_to_unit(id = NULL)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{id}}{The id of the corresponding node.} +} +\if{html}{\out{
}} +} +} +\if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-Provenance-record_step}{}}} \subsection{Method \code{record_step()}}{ From e39d7a2bb4066cb99f7af647b8f78524230e1bf9 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sun, 3 Sep 2023 11:37:32 +1000 Subject: [PATCH 81/83] fix set_rcrds for edbl table input --- R/rcrds.R | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/R/rcrds.R b/R/rcrds.R index 796ae37d..697ae6e3 100644 --- a/R/rcrds.R +++ b/R/rcrds.R @@ -36,7 +36,6 @@ set_rcrds <- function(.edibble, ..., rcrds <- names(units) - prov$fct_exists(name = unlist(units), role = "edbl_unit") for(i in seq_along(units)) { @@ -46,6 +45,20 @@ set_rcrds <- function(.edibble, ..., prov$append_fct_edges(from = rid, to = uid, type = "record") } + if(is_edibble_table(.edibble)) { + rcrds <- prov$serve_rcrds(return = "value") + for(arcrd in names(rcrds)) { + if(arcrd %in% names(.edibble)) { + uid <- prov$mapping_to_unit(id = prov$fct_id(name = arcrd)) + uname <- prov$fct_names(id = uid) + uids <- prov$fct_id(name = .edibble[[uname]]) + .edibble[[arcrd]] <- new_edibble_rcrd(rep(NA_real_, nrow(.edibble)), uids) + } else { + .edibble[[arcrd]] <- rcrds[[arcrd]] + } + } + } + return_edibble_with_graph(.edibble, prov) } From b66965aea89fc126ea48c697210ee9705568060d Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sun, 3 Sep 2023 11:39:10 +1000 Subject: [PATCH 82/83] update export --- R/export.R | 137 ++++++++++++++++++++++++------------------- man/export_design.Rd | 6 +- 2 files changed, 82 insertions(+), 61 deletions(-) diff --git a/R/export.R b/R/export.R index 6a79aa11..9269e029 100644 --- a/R/export.R +++ b/R/export.R @@ -68,11 +68,25 @@ export_design <- function(.data, write_data_sheet(wb, sheet_names[-c(1, 2, length(sheet_names))], prov, as_tibble(.data), table_style, hide_treatments) + write_grand_data_sheet(wb, sheet_names[2], prov, as_tibble(.data), table_style) - # FIXME: validation not implemented yet - #write_variables_sheet(wb, sheet_names[length(sheet_names)], prov, .data) + wb$protect_worksheet(sheet = sheet_names[2], + protect = TRUE, + properties = c("formatCells", + "formatColumns", + "formatRows", + "insertRows", + "deleteColumns", + "deleteRows", + "sort", + "autoFilter", + "pivotTables", + "objects", + "scenarios")) + + write_variables_sheet(wb, sheet_names[length(sheet_names)], prov, .data) save_workbook(wb, file, overwrite, title) @@ -232,7 +246,7 @@ write_grand_data_sheet <- function(wb, sheet_name, prov, data, table_style) { df <- wb$to_df(sheet = dname) col <- match(rname, names(df)) rows <- match(data[[uname]], df[[uname]]) - data[[rname]] <- paste0(dname, "!", map_chr(rows, function(row) wb_dims(row + 1L, col))) + data[[rname]] <- paste0(dname, "!", map_chr(rows, function(row) openxlsx2::wb_dims(row + 1L, col))) class(data[[rname]]) <- c(class(data[[rname]]), "formula") } @@ -242,74 +256,77 @@ write_grand_data_sheet <- function(wb, sheet_name, prov, data, table_style) { -write_variables_sheet <- function(wb, sheet_name, cell_styles, prov, .data) { - - type <- map_chr(.data, function(var) { - cls <- class(var) - if("edbl_unit" %in% cls) return("unit") - if("edbl_trt" %in% cls) return("trt") - if("edbl_rcrd" %in% cls) return("rcrd") - "var" +write_variables_sheet <- function(wb, sheet_name, prov, data) { + type <- map_chr(data, function(var) { + if(inherits(var, "edbl_unit")) return("unit") + if(inherits(var, "edbl_trt")) return("trt") + if(inherits(var, "edbl_rcrd")) return("rcrd") + "fct" }) - data <- data.frame(variable = names(.data), - type = unname(type), - stringsAsFactors = FALSE) + vardf <- data.frame(variable = names(data), + type = unname(type), + nlevels = map_int(names(data), function(var) { + id <- prov$fct_id(name = var) + role <- prov$fct_role(id = id) + if(role == "edbl_rcrd") { + uid <- prov$mapping_to_unit(id = id) + var <- prov$fct_names(id = uid) + } + length(unique(data[[var]])) + }), + stringsAsFactors = FALSE) - # FIXME valids <- prov$get_validation("rcrds") if(!is_null(valids)) { - data$record <- "" - data$value <- "" + vardf$record <- "" + vardf$value <- "" valid_names <- names(valids) - rids <- prov$rcrd_ids - rcrds <- rcrd_to_unit_dict(prov, rids) - n_ounits <- length(unique(rcrds)) - for(i in seq_along(valid)) { - unit <- rcrds[valid_names[i]] - data_sheet <- ifelse(n_ounits > 1, - data_sheet_name(unit), - "Data") - dat <- openxlsx::read.xlsx(wb, namedRegion = data_sheet) - j <- which(data$variable == valid_names[i]) - data$record[j] <- valid[[i]]$record - if(valid[[i]]$type != "list") { - data$value[j] <- restriction_for_human(valid[[i]]$operator, valid[[i]]$value) - openxlsx::dataValidation(wb, sheet = data_sheet, - rows = 1:nrow(dat) + 1, - cols = j, - type = valid[[i]]$type, - operator = valid[[i]]$operator, - value = valid[[i]]$value) + for(ivalid in seq_along(valids)) { + valid <- valids[[ivalid]] + rname <- valid_names[ivalid] + rid <- prov$fct_id(name = rname) + uid <- prov$mapping_to_unit(id = rid) + uname <- prov$fct_names(id = uid) + data_sheet <- data_sheet_name(uname) + + dat <- wb$to_df(sheet = data_sheet) + i <- which(vardf$variable == rname) + jdata <- which(names(dat) == rname) + vardf$record[i] <- valid$record + + if(valid$type != "list") { + vardf$value[i] <- restriction_for_human(valid$operator, valid$value) + wb$add_data_validation(sheet = data_sheet, + dims = openxlsx2::wb_dims(1:nrow(dat) + 1L, jdata), + type = valid$type, + operator = valid$operator, + value = valid$value) } else { - k <- which(names(data) == "value") - values <- valid[[i]]$values - data$value[j] <- values[1] - L <- LETTERS[c(k, k + length(values) - 1)] - openxlsx::writeData(wb, - sheet = sheet_name, - x = data.frame(t(values), stringsAsFactors = FALSE), - - startCol = k, - startRow = j + 1, colNames = FALSE) - openxlsx::dataValidation(wb, - sheet = data_sheet, - rows = 1:nrow(dat) + 1, - cols = j, - type = "list", - operator = NULL, - value = paste0("'", sheet_name, "'!$", - L[1], "$", j + 1, ":$", L[2], "$", j + 1)) + j <- which(names(vardf) == "value") + + values <- valid$values + vardf$value[i] <- values[1] + dim_list <- openxlsx2::wb_dims(i + 1L, j:(j + length(values) - 1)) + wb$add_data(sheet = sheet_name, + x = t(data.frame(x = values)), + dims = dim_list, + col_names = FALSE) + L <- gsub("[0-9]+", "", strsplit(dim_list, ":")[[1]]) + wb$add_data_validation(sheet = data_sheet, + dims = openxlsx2::wb_dims(1:nrow(dat) + 1L, jdata), + type = "list", + value = paste0("'", sheet_name, "'!$", + L[1], "$", i + 1L, ":$", L[2], "$", i + 1L)) } } } - openxlsx::writeData(wb, - sheet = sheet_name, - x = data, - startCol = 1, - headerStyle = cell_styles$header, - name = "Variables") + wb$add_data(sheet = sheet_name, + x = vardf) + wb$add_font(sheet = sheet_name, + dims = openxlsx2::wb_dims(1, 1:ncol(vardf)), + bold = TRUE) } restriction_for_human <- function(operator, value) { diff --git a/man/export_design.Rd b/man/export_design.Rd index 98d8d864..bfc90af4 100644 --- a/man/export_design.Rd +++ b/man/export_design.Rd @@ -10,6 +10,7 @@ export_design( author = NULL, date = Sys.Date(), overwrite = FALSE, + hide_treatments = FALSE, theme = NULL, subject = NULL, category = NULL, @@ -26,7 +27,10 @@ for where there are multiple authors.} \item{date}{The date to be inserted in header (defaults to today).} -\item{overwrite}{A logical indicating whether to overwrite existing file or not.} +\item{overwrite}{A logical value indicating whether to overwrite existing file or not.} + +\item{hide_treatments}{A logical value indicating whether treatments should be included in the data entry sheet. +Default is true.} \item{theme}{The Excel theme to use (optional). One of "Atlas", "Badge", "Berlin", "Celestial", "Crop", "Depth", "Droplet", "Facet", "Feathered", "Gallery", "Headlines", "Integral", "Ion", "Ion Boardroom", "Madison", "Main Event", "Mesh", "Office Theme", "Old Office Theme", "Organic", "Parallax", "Parcel", "Retrospect", "Savon", "Slice", "Vapor Trail", "View", "Wisp", "Wood Type".} From 3d5ee7a954759982dfeb6d8873cb7a48757c50c8 Mon Sep 17 00:00:00 2001 From: Emi Tanaka Date: Sun, 3 Sep 2023 13:14:53 +1000 Subject: [PATCH 83/83] update test-export --- tests/testthat/test-export.R | 49 +++++++++++++++++++++++++++++++----- 1 file changed, 43 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-export.R b/tests/testthat/test-export.R index edec5b9f..2ad5db2f 100644 --- a/tests/testthat/test-export.R +++ b/tests/testthat/test-export.R @@ -1,8 +1,8 @@ test_that("export with no record", { set.seed(1) - des <- takeout() + des <- suppressMessages(takeout()) fn <- tempfile() - export_design(des0, file = fn, overwrite = TRUE) + suppressMessages(export_design(des0, file = fn, overwrite = TRUE)) dat <- openxlsx2::read_xlsx(fn, sheet = 2) expect_equal(dat, as_tibble(des), ignore_attr = TRUE) @@ -10,7 +10,7 @@ test_that("export with no record", { test_that("export with record", { set.seed(1) - des <- takeout(menu_split()) %>% + des <- takeout(menu_split(t1 = 2, t2 = 3, r = 2)) %>% set_rcrds(yield = mainplot, height = subplot, genotype = subplot, @@ -23,9 +23,46 @@ test_that("export with record", { fn <- tempfile() - export_design(des, file = fn, overwrite = TRUE) - + suppressMessages(export_design(des, file = fn, overwrite = TRUE)) dat <- openxlsx2::read_xlsx(fn, sheet = 2) - #expect_equal(dat, as_tibble(des), ignore_attr = TRUE) + expect_equal(dat, as_tibble(des), ignore_attr = TRUE) + + dat <- openxlsx2::read_xlsx(fn, sheet = "Data.mainplot") + out1 <- data.frame(mainplot = c("mainplot1", "mainplot2", "mainplot3", "mainplot4"), + trt = c("trt11", "trt11", "trt12", "trt12"), + yield = NA_real_, + yield_date = NA_real_) + expect_equal(out1, dat, ignore_attr = TRUE) + + dat <- openxlsx2::read_xlsx(fn, sheet = "Data.subplot") + out2 <- data.frame(subplot = c("subplot01", "subplot02", "subplot03", "subplot04", "subplot05", + "subplot06", "subplot07", "subplot08", "subplot09", "subplot10", + "subplot11", "subplot12"), + mainplot = c("mainplot1", "mainplot1", "mainplot1", "mainplot2", "mainplot2", + "mainplot2", "mainplot3", "mainplot3", "mainplot3", "mainplot4", + "mainplot4", "mainplot4"), + trt2 = c("trt21", "trt22", "trt23", "trt22", "trt21", "trt23", "trt22", + "trt21", "trt23", "trt23", "trt22", "trt21"), + height = NA_real_, + genotype = NA_real_) + expect_equal(out2, dat, ignore_attr = TRUE) + + # check hide_treatments + suppressMessages(export_design(des, file = fn, overwrite = TRUE, hide_treatments = TRUE)) + dat <- openxlsx2::read_xlsx(fn, sheet = "Data.mainplot") + expect_equal(out1[-2], dat, ignore_attr = TRUE) + dat <- openxlsx2::read_xlsx(fn, sheet = "Data.subplot") + expect_equal(out2[-3], dat, ignore_attr = TRUE) + + # check for Variables + dat <- openxlsx2::read_xlsx(fn, sheet = "Variables") + expect_equal(dat$variable, c("mainplot", "subplot", "trt1", "trt2", "yield", "height", "genotype", + "yield_date")) + expect_equal(dat$type, c("unit", "unit", "trt", "trt", "rcrd", "rcrd", "rcrd", "rcrd")) + expect_equal(dat$nlevels, c(4, 12, 2, 3, 4, 12, 12, 4)) + expect_equal(dat$record, c(NA, NA, NA, NA, "numeric", "numeric", "factor", NA)) + expect_equal(dat$value, c(NA, NA, NA, NA, "> 0", "between 0 and 100 inclusive", "A", + NA)) + expect_equal(dat[[6]], c(NA, NA, NA, NA, NA, NA, "B", NA)) })