Skip to content

Commit

Permalink
Merge pull request #63 from emitanaka/new-internal
Browse files Browse the repository at this point in the history 
Major internal update
  • Loading branch information
@emitanaka
emitanaka authored Sep 3, 2023
2 parents 1ea1f02 + 3d5ee7a commit 70d1d85
Show file tree
Hide file tree
Showing 73 changed files with 4,242 additions and 2,742 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,7 +35,7 @@ Imports:
Suggests:
testthat (>= 3.0.0),
rmarkdown,
openxlsx,
openxlsx2 (>= 1.0.0),
visNetwork
Depends:
R (>= 2.10)
29 changes: 22 additions & 7 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
@@ -1,14 +1,20 @@
# 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)
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)
Expand All @@ -27,7 +33,9 @@ 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)
S3method(vec_cast,character.edbl_trt)
S3method(vec_cast,character.edbl_unit)
Expand All @@ -49,16 +57,16 @@ S3method(vec_ptype_full,edbl_rcrd)
S3method(vec_ptype_full,edbl_trt)
S3method(vec_ptype_full,edbl_unit)
export("%>%")
export(Kitchen)
export(Provenance)
export(activate_provenance)
export(allot_table)
export(allot_trts)
export(allot_units)
export(anatomy)
export(as_data_frame)
export(as_edibble)
export(assign_trts)
export(assign_units)
export(cook_design)
export(column)
export(crossed_by)
export(design)
export(edbl_design)
Expand All @@ -69,7 +77,10 @@ export(expect_rcrds)
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)
export(is_edibble)
export(is_edibble_design)
Expand All @@ -82,13 +93,18 @@ 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)
export(label_seq_length)
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)
Expand All @@ -106,10 +122,8 @@ 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)
export(serve_table)
export(set_rcrds)
export(set_rcrds_of)
Expand All @@ -126,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)
Expand All @@ -140,6 +153,8 @@ importFrom(magrittr,"%>%")
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)
Expand Down
131 changes: 66 additions & 65 deletions R/allot.R
View file
Original file line number Diff line number Diff line change
@@ -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.
Expand All @@ -20,66 +20,67 @@
#' pest ~ block)
#'
#' @return Return an edibble design.
#' @name allot
#' @seealso assign
NULL

#' @rdname allot
#' @export
allot_trts <- function(.edibble, ..., .record = TRUE) {

not_edibble(.edibble)
if(.record) record_step()

des <- edbl_design(.edibble)
prov <- activate_provenance(des)
if(.record) prov$record_step()

dots <- list2(...)
if(!is_null(des$allotment)) {
des$allotment$trts <- c(des$allotment$trts, dots)
} 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)
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(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")
}

if(is_edibble_design(.edibble)) {
prep$design
} else if(is_edibble_table(.edibble)) {
if(length(trts)==0) {
trts <- prep$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]]))))
}
attr(.edibble, "design") <- prep$design
.edibble
}
return_edibble_with_graph(.edibble, prov)
}


#' @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)
if(.record) record_step()
prov <- activate_provenance(.edibble)
if(.record) prov$record_step()
des <- edbl_design(.edibble)

dots <- list2(...)
Expand All @@ -88,69 +89,69 @@ allot_units <- function(.edibble, ..., .record = TRUE) {
} else {
des$allotment <- list(trts = NULL, units = dots)
}
prep <- cook_design(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(name = big)
prov$fct_exists(name = big, role = "edbl_unit")
small_id <- prov$fct_id(name = small)

if(!op %in% c("crossed_by", "nested_in")) {
prep$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) {
prep$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)) {
prep$design
} 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)) {
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(from = cross_df$from, to = cross_df$to, type = "cross")
}
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(from = prov$lvl_id(name = as.character(.edibble[[small[ismall]]])),
to = prov$lvl_id(name = 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(from = prov$lvl_id(name = as.character(.edibble[[big]])),
to = prov$lvl_id(name = as.character(.edibble[[asmall]])))
}
}
attr(.edibble, "design") <- prep$design
.edibble
}
return_edibble_with_graph(.edibble, prov)

}


#' @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)) {
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)
}
20 changes: 18 additions & 2 deletions R/anatomy.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand All @@ -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
}
Loading

0 comments on commit 70d1d85

Please sign in to comment.