Skip to content

Commit

Permalink
feat: implement conditional sampling
Browse files Browse the repository at this point in the history
  • Loading branch information
@WetRobot
WetRobot committed Mar 4, 2024
1 parent 7b71aaf commit 97bda33
Show file tree
Hide file tree
Showing 5 changed files with 275 additions and 153 deletions.
160 changes: 159 additions & 1 deletion R/06_assertions.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -268,6 +268,7 @@ assert_is_sampler <- function(
x = x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type,
classes = c("NULL", "list", "function", "call", "{", "name")
)
if (is.null(x)) {
Expand Down Expand Up @@ -490,7 +491,7 @@ assert_is_describer <- function(
),
fail_messages = c(
paste0("R expression `", deparse1(x), "` from object/expression `",
x_nm , "` must contain variable `descr_nm`")
x_nm, "` must contain variable `descr_nm`")
),
call = call,
env = environment()
Expand Down Expand Up @@ -537,3 +538,160 @@ assert_is_arg_data <- function(
assertion_type = assertion_type
)
}

assert_is_var_nm <- function(
vm,
x,
x_nm = NULL,
call = NULL,
assertion_type = NULL
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
dbc::assert_is_character_nonNA_atom(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type,
set = var_meta_get_all(vm, "var_nm")
)
}

assert_is_var_meta_nm <- function(
vm,
x,
x_nm = NULL,
call = NULL,
assertion_type = NULL
) {
assert_is_variablemetadata(
vm,
call = call,
assertion_type = "prod_input"
)
dbc::assert_is_character_nonNA_atom(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type,
set = names(vd_get(vm))
)
}

assert_is_var_set_id <- function(
vm,
x,
x_nm = NULL,
call = NULL,
assertion_type = NULL
) {
dbc::handle_args_inplace()
assert_is_variablemetadata(vm, assertion_type = "prod_input")
dbc::assert_is_atom(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type
)
dbc::assert_is_nonNA(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type,
set = vsd_get(vm)[["id"]]
)
}

assert_is_var_set_meta_nm <- function(
vm,
x,
x_nm = NULL,
call = NULL,
assertion_type = NULL
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
dbc::assert_is_character_nonNA_atom(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type,
set = names(vsd_get(vm))
)
}
assert_var_set_value_space_is_defined <- function(
vm
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
if (!var_set_value_space_is_defined(vm)) {
stop("No value spaces have been defined")
}
}


assert_is_arg_ids <- function(
x,
x_nm = NULL,
call = NULL,
assertion_type = NULL,
vm
) {
dbc::handle_args_inplace()
dbc::assert_is_one_of(
x = x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type,
funs = list(dbc::report_is_NULL,
dbc::report_is_vector)
)
lapply(seq_along(x), function(i) {
assert_is_var_set_id(
vm = vm,
x = x[[i]],
x_nm = sprintf("x[[%i]]", i),
call = call,
assertion_type = assertion_type
)
})
}

assert_is_arg_var_nms <- function(
x,
x_nm = NULL,
call = NULL,
assertion_type = NULL,
vm
) {
dbc::handle_args_inplace()
dbc::assert_is_one_of(
x = x,
x_nm = x_nm,
call = call,
assertion_type = assertion_type,
funs = list(dbc::report_is_NULL,
dbc::report_is_character_nonNA_vector)
)
}
78 changes: 0 additions & 78 deletions R/07_nonslot_funs.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,84 +24,6 @@ data_obj_set <- function(
vm_env[["data"]][[obj_nm]] <- value
}

# assertions -------------------------------------------------------------------
assert_is_var_nm <- function(
vm,
var_nm,
assertion_type = NULL
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
dbc::assert_is_character_nonNA_atom(
var_nm,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
var_nm,
set = var_meta_get_all(vm, "var_nm"),
assertion_type = assertion_type
)
}
assert_is_var_meta_nm <- function(
vm,
meta_nm,
assertion_type = NULL
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
dbc::assert_is_character_nonNA_atom(
meta_nm,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
meta_nm,
set = names(vd_get(vm)),
assertion_type = assertion_type
)
}
assert_is_var_set_id <- function(
vm,
id,
assertion_type = NULL
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
dbc::assert_is_atom(
id,
assertion_type = assertion_type
)
dbc::assert_is_nonNA(
id,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
id,
set = vsd_get(vm)[["id"]],
assertion_type = assertion_type
)
}
assert_is_var_set_meta_nm <- function(
vm,
meta_nm,
assertion_type = NULL
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
dbc::assert_is_character_nonNA_atom(
meta_nm,
assertion_type = assertion_type
)
dbc::assert_atom_is_in_set(
meta_nm,
set = names(vsd_get(vm)),
assertion_type = assertion_type
)
}
assert_var_set_value_space_is_defined <- function(
vm
) {
assert_is_variablemetadata(vm, assertion_type = "prod_input")
if (!var_set_value_space_is_defined(vm)) {
stop("No value spaces have been defined")
}
}

# vd funs ----------------------------------------------------------------
vd_get <- function(
vm,
Expand Down
52 changes: 52 additions & 0 deletions R/08_slot_fun_utils.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -47,3 +47,55 @@ handle_arg_data__ <- function(data) {

return(arg_list)
}

handle_arg_ids_et_var_nms_inplace__ <- function(vm) {
calling_env <- parent.frame(1L)
dbc::assert_prod_interim_is(
quote(c("ids", "var_nms") %in% ls(envir = calling_env))
)
ids <- calling_env[["ids"]]
var_nms <- calling_env[["var_nms"]]
# @codedoc_comment_block doc_slot_fun_arg(ids)
# @param ids `[NULL, vector]` (default `NULL`)
#
# - `NULL`: Behaviour varies. An error is raised if this cannot be inferred.
# If the function has the argument `var_nms`, that will be used
# to infer `ids`.
# - `vector`: One or more values that can be found in `var_set_dt$id`.
# @codedoc_comment_block doc_slot_fun_arg(ids)
assert_is_arg_ids(vm = vm, x = ids)
# @codedoc_comment_block doc_slot_fun_arg(var_nms)
# @param var_nms `[NULL, character]` (default `NULL`)
#
# - `NULL`: Behaviour varies. If the function has the argument `ids` or `id`,
# uses all variable names in those variable sets.
# - `character`: Use these variable names.
# @codedoc_comment_block doc_slot_fun_arg(var_nms)
assert_is_arg_var_nms(var_nms)
all_var_nm_sets <- var_set_var_nm_set_get_all(vm = vm)
all_ids <- var_set_meta_get_all(vm = vm, meta_nm = "id")
if (is.null(ids) && is.null(var_nms)) {
stop("Both `ids` and `var_nms` cannot be `NULL`")
} else if (!is.null(var_nms) && is.null(ids)) {
ids <- all_ids[vapply(
seq_along(all_ids),
function(i) {
any(all_var_nm_sets[[i]] %in% var_nms)
},
logical(1L)
)]
} else if (is.null(var_nms) && !is.null(ids)) {
var_nms <- unlist(all_var_nm_sets[match(ids, all_ids)])
} else {
inferred_var_nms <- unlist(all_var_nm_sets[match(ids, all_ids)])
extra_var_nms <- setdiff(var_nms, inferred_var_nms)
if (length(extra_var_nms) > 0) {
stop("Arguments `ids` and `var_nms` are incongruent: `var_nms` contains ",
"these variable names not found in any of the variable name sets ",
"for the supplied `ids`: ", deparse1(extra_var_nms))
}
}
calling_env[["ids"]] <- ids
calling_env[["var_nms"]] <- var_nms
return(invisible(NULL))
}
Loading

0 comments on commit 97bda33

Please sign in to comment.