Skip to content

Commit

Permalink
add label_distinct, label_nested, index_levels; fix rescale_values; f…
Browse files Browse the repository at this point in the history
…ix sim with nested labels; fix edbl_fns were values defined in environment
  • Loading branch information
emitanaka committed Nov 25, 2023
1 parent 8778647 commit 8bb07a6
Show file tree
Hide file tree
Showing 12 changed files with 75 additions and 22 deletions.
3 changes: 3 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -120,6 +120,7 @@ export(fct_edges)
export(fct_generator)
export(fct_graph)
export(fct_nodes)
export(index_levels)
export(is_cross_levels)
export(is_edibble)
export(is_edibble_design)
Expand All @@ -134,6 +135,8 @@ export(is_rcrd)
export(is_takeout)
export(is_trt)
export(is_unit)
export(label_distinct)
export(label_nested)
export(label_seq_from_length)
export(label_seq_from_to)
export(label_seq_length)
Expand Down
14 changes: 11 additions & 3 deletions R/allot.R
Original file line number Diff line number Diff line change
Expand Up @@ -23,13 +23,13 @@
#' @seealso assign_fcts
#' @export
allot_trts <- function(.edibble = NULL, ..., .record = TRUE) {
if(is.null(.edibble)) return(structure(match.call(), class = c("edbl_fn", "edbl")))
if(is.null(.edibble)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
if(is_formula(.edibble)) {
cl <- match.call()
ncl <- length(cl)
cl[3:(ncl + 1)] <- cl[2:ncl]
cl$.edibble <- NULL
return(structure(cl, class = c("edbl_fn", "edbl")))
return(structure(cl, env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
}
dots <- list2(...)
not_edibble(.edibble)
Expand Down Expand Up @@ -86,6 +86,14 @@ allot_trts <- function(.edibble = NULL, ..., .record = TRUE) {
#' @seealso assign_fcts
#' @export
allot_units <- function(.edibble, ..., .record = TRUE) {
if(is.null(.edibble)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
if(is_formula(.edibble)) {
cl <- match.call()
ncl <- length(cl)
cl[3:(ncl + 1)] <- cl[2:ncl]
cl$.edibble <- NULL
return(structure(cl, env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
}
dots <- list2(...)
not_edibble(.edibble)
prov <- activate_provenance(.edibble)
Expand Down Expand Up @@ -160,7 +168,7 @@ allot_units <- function(.edibble, ..., .record = TRUE) {
#'
#' @export
allot_table <- function(.edibble = NULL, ..., order = "random", seed = NULL, constrain = nesting_structure(.edibble), label_nested = NULL, fail = "error", .record = TRUE) {
if(is.null(.edibble)) return(structure(match.call(), class = c("edbl_fn", "edbl")))
if(is.null(.edibble)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
if(is_formula(.edibble)) {
cl <- match.call()
ncl <- length(cl)
Expand Down
4 changes: 2 additions & 2 deletions R/assign.R
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@
#' @return An edibble design.
#' @export
assign_trts <- function(.edibble = NULL, order = "random", seed = NULL, constrain = nesting_structure(.edibble), ..., .record = TRUE) {
if(is.null(.edibble)) return(structure(match.call(), class = c("edbl_fn", "edbl")))
if(is.null(.edibble)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
not_edibble(.edibble)
force(constrain) # evaluate this now rather than later

Expand Down Expand Up @@ -166,7 +166,7 @@ assign_trts <- function(.edibble = NULL, order = "random", seed = NULL, constrai
#' @rdname assign_fcts
#' @export
assign_units <- function(.edibble = NULL, order = "random", seed = NULL, constrain = nesting_structure(.edibble), ..., .record = TRUE) {
if(is.null(.edibble)) return(structure(match.call(), class = c("edbl_fn", "edbl")))
if(is.null(.edibble)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
not_edibble(.edibble)
prov <- activate_provenance(.edibble)
if(.record) prov$record_step()
Expand Down
19 changes: 19 additions & 0 deletions R/labels.R
Original file line number Diff line number Diff line change
Expand Up @@ -75,6 +75,25 @@ label_seq_length <- function(length = 1L,
sep_prefix, sep_suffix)
}

#' Label with nested or distinct labels
#'
#' @param x A unit vector.
#' @export
label_nested <- function(x) {
attr(x, "label-nested") %||% x
}

#' @rdname label_nested
#' @export
label_distinct <- function(x) {
attr(x, "label-non-nested") %||% x
}

#' @rdname label_nested
#' @export
index_levels <- function(x) {
as.integer(label_distinct(x))
}


label_form <- function(levels, leading_zero,
Expand Down
6 changes: 3 additions & 3 deletions R/rcrds.R
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@
set_rcrds <- function(.edibble = NULL, ...,
.name_repair = c("check_unique", "unique", "universal", "minimal"),
.record = TRUE) {
if(is.null(.edibble)) return(structure(match.call(), class = c("edbl_fn", "edbl")))
if(is.null(.edibble)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
not_edibble(.edibble)
des <- edbl_design(.edibble)
prov <- activate_provenance(des)
Expand Down Expand Up @@ -100,13 +100,13 @@ expect_rcrds <- function(.edibble = NULL, ..., .record = TRUE) {
arg1 <- enquo(.edibble)
arg1 <- tryCatch(rlang::eval_tidy(arg1),
error = function(e) arg1)
if(is.null(arg1)) return(structure(match.call(), class = c("edbl_fn", "edbl")))
if(is.null(arg1)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
if(!is_edibble(arg1)) {
cl <- match.call()
ncl <- length(cl)
cl[3:(ncl + 1)] <- cl[2:ncl]
cl$.edibble <- NULL
return(structure(cl, class = c("edbl_fn", "edbl")))
return(structure(cl, env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
}
prov <- activate_provenance(.edibble)
if(.record) prov$record_step()
Expand Down
2 changes: 1 addition & 1 deletion R/serve.R
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@
#' @import tidyselect
#' @export
serve_table <- function(.edibble = NULL, label_nested = NULL, fail = c("error", "warn", "ignore"), .record = TRUE) {
if(is.null(.edibble)) return(structure(match.call(), class = c("edbl_fn", "edbl")))
if(is.null(.edibble)) return(structure(match.call(), env = rlang::caller_env(), class = c("edbl_fn", "edbl")))
prov <- activate_provenance(.edibble)
fail <- match.arg(fail)
if(.record) prov$record_step()
Expand Down
14 changes: 7 additions & 7 deletions R/simulate.R
Original file line number Diff line number Diff line change
Expand Up @@ -449,7 +449,7 @@ effects_code <- function(dep_fcts, .data, nlevels = 1) {
if(nlevels <= 2) {
for(fct in dep_fcts) {
fct_class <- class(.data[[fct]])
nfct <- length(unique(.data[[fct]]))
nfct <- nlevels(.data[[fct]])
if("numeric" %in% fct_class) {
code_list$process_code <- c(code_list$process_code,
sprintf('%s_degree <- sample(1:%d, 1)', fct, ifelse(nfct > 5, 5, nfct - 1)),
Expand All @@ -461,9 +461,9 @@ effects_code <- function(dep_fcts, .data, nlevels = 1) {
# logical not accounted for
} else if(any(c("factor", "character") %in% fct_class)) {
code_list$process_code <- c(code_list$process_code,
sprintf(' %s_effects <- setNames(rnorm(%d, 0, 10), unique(%s))',
fct, nfct, fct))
code_list$model_code <- c(code_list$model_code, sprintf("%s_effects[%s]", fct, fct))
sprintf(' %s_effects <- rnorm(%d, 0, 10)',
fct, nfct))
code_list$model_code <- c(code_list$model_code, sprintf("%s_effects[index_levels(%s)]", fct, fct))
}
}
# combine
Expand All @@ -480,9 +480,9 @@ effects_code <- function(dep_fcts, .data, nlevels = 1) {
code_list$model_code <- c(code_list$model_code, sprintf("%s_effects[[i]]", fct))
} else if(any(c("factor", "character") %in% fct_class)) {
code_list$process_code <- c(code_list$process_code,
sprintf(' %s_effects <- lapply(1:%d, function(i) setNames(rnorm(%d, 0, 10), unique(%s)))',
fct, nlevels, nfct, fct))
code_list$model_code <- c(code_list$model_code, sprintf("%s_effects[[i]][%s]", fct, fct))
sprintf(' %s_effects <- lapply(1:%d, function(i) rnorm(%d, 0, 10))',
fct, nlevels, nfct))
code_list$model_code <- c(code_list$model_code, sprintf("%s_effects[[i]][index_levels(%s)]", fct, fct))
}
}
# combine
Expand Down
7 changes: 5 additions & 2 deletions R/utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -344,7 +344,10 @@ rescale_values <- function(x, lower = NA, upper = NA) {
if(shift >= 0) return(x)
return(x - shift + .Machine$double.xmin)
}
(x - minx) / (maxx - minx) * (upper - .Machine$double.xmin - lower) + lower + .Machine$double.xmin
ret <- (x - minx) / (maxx - minx) * (upper - lower)
ret[ret == min(ret)] <- ret[ret == min(ret)] + (upper - lower) * .Machine$double.eps
ret[ret == max(ret)] <- ret[ret == max(ret)] - (upper - lower) * .Machine$double.eps
ret
}

#' @export
Expand Down Expand Up @@ -436,7 +439,7 @@ print.edbl_fct <- function(x, ...) {
e1
} else if(inherits(e2, "edbl_fn")) {
e2$.edibble <- e1
eval(e2)
eval(e2, envir = attr(e2, "env"))
} else if(inherits(e2, "edbl_fns")) {
ret <- e1 + e2[[1]]
if(length(e2) == 1L) return(ret)
Expand Down
2 changes: 1 addition & 1 deletion man/allot_table.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion man/expect_rcrds.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

20 changes: 20 additions & 0 deletions man/label_nested.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

4 changes: 2 additions & 2 deletions man/set_rcrds.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit 8bb07a6

Please sign in to comment.