Fixing assertion example errors. Updating release schedule

NAMESPACE

@@ -25,11 +25,13 @@ export(assert_vars)
 export(assert_varval_list)
 export(convert_blanks_to_na)
 export(dataset_vignette)
+export(desc)
 export(expect_dfs_equal)
 export(extract_unit)
 export(filter_if)
 export(hello_admiral)
 export(negate_vars)
+export(vars)
 export(vars2chr)
 importFrom(admiral,assert_character_scalar)
 importFrom(admiral,derive_vars_dy)

R/assertions.R

@@ -23,6 +23,7 @@
 #'
 #' @examples
 #' library(admiral.test)
+#' library(admiral)
 #' data(admiral_dm)
 #'
 #' example_fun <- function(dataset) {
@@ -503,6 +504,7 @@ assert_vars <- function(arg, optional = FALSE) {
 #' @keywords assertion
 #' @family assertion
 #' @examples
+#'
 #' example_fun <- function(by_vars) {
 #'   assert_order_vars(by_vars)
 #' }
@@ -947,14 +949,15 @@ assert_function_param <- function(arg, params) {
 #'
 #' @export
 #'
-#' @keywords assertion
-#' @family assertion
 #' @examples
-#' data(admiral_advs)
-#' assert_unit(admiral_advs, param = "WEIGHT", required_unit = "kg", get_unit_expr = VSSTRESU)
-#' \dontrun{
-#' assert_unit(admiral_advs, param = "WEIGHT", required_unit = "g", get_unit_expr = VSSTRESU)
-#' }
+#' library(tibble)
+#' advs <- tribble(
+#'   ~USUBJID, ~VSTESTCD, ~VSTRESN, ~VSSTRESU, ~PARAMCD, ~AVAL,
+#'   "P01",    "WEIGHT",      80.1, "kg",      "WEIGHT",  80.1,
+#'   "P02",    "WEIGHT",      85.7, "kg",      "WEIGHT",  85.7
+#' )
+#'
+#' assert_unit(advs, param = "WEIGHT", required_unit = "kg", get_unit_expr = VSSTRESU)
 assert_unit <- function(dataset, param, required_unit, get_unit_expr) {
   assert_data_frame(dataset, required_vars = vars(PARAMCD))
   assert_character_scalar(param)
@@ -1015,9 +1018,15 @@ assert_unit <- function(dataset, param, required_unit, get_unit_expr) {
 #' @keywords assertion
 #' @family assertion
 #' @examples
-#' data(admiral_advs)
-#' assert_param_does_not_exist(admiral_advs, param = "HR")
-#' try(assert_param_does_not_exist(admiral_advs, param = "WEIGHT"))
+#'
+#' library(tibble)
+#' advs <- tribble(
+#'   ~USUBJID, ~VSTESTCD, ~VSTRESN, ~VSSTRESU, ~PARAMCD, ~AVAL,
+#'   "P01",    "WEIGHT",      80.1, "kg",      "WEIGHT",  80.1,
+#'   "P02",    "WEIGHT",      85.7, "kg",      "WEIGHT",  85.7
+#' )
+#' assert_param_does_not_exist(advs, param = "HR")
+#' try(assert_param_does_not_exist(advs, param = "WEIGHT"))
 assert_param_does_not_exist <- function(dataset, param) {
   assert_data_frame(dataset, required_vars = vars(PARAMCD))
   if (param %in% unique(dataset$PARAMCD)) {
@@ -1209,6 +1218,8 @@ assert_varval_list <- function(arg, # nolint
 #' @export
 #'
 #' @examples
+#' library(admiral)
+#'
 #' death <- event_source(
 #'   dataset_name = "adsl",
 #'   filter = DTHFL == "Y",

R/compat_friendly_type.R

@@ -0,0 +1,166 @@
+#' Return English-friendly Type
+#' @param x Any R object.
+#' @param value Whether to describe the value of `x`.
+#' @param length Whether to mention the length of vectors and lists.
+#' @return A string describing the type. Starts with an indefinite
+#'   article, e.g. "an integer vector".
+#' @noRd
+friendly_type_of <- function(x, value = TRUE, length = FALSE) { # nolint
+  if (rlang::is_missing(x)) {
+    return("absent")
+  }
+
+  if (is.object(x)) {
+    if (inherits(x, "quosure")) {
+      type <- "quosure"
+    } else {
+      type <- paste(class(x), collapse = "/")
+    }
+    return(sprintf("a <%s> object", type))
+  }
+
+  if (!rlang::is_vector(x)) {
+    return(.rlang_as_friendly_type(typeof(x)))
+  }
+
+  n_dim <- length(dim(x))
+
+  if (value && !n_dim) {
+    if (rlang::is_na(x)) {
+      return(switch(typeof(x),
+                    logical = "`NA`",
+                    integer = "an integer `NA`",
+                    double = "a numeric `NA`",
+                    complex = "a complex `NA`",
+                    character = "a character `NA`",
+                    .rlang_stop_unexpected_typeof(x)
+      ))
+    }
+    if (length(x) == 1 && !rlang::is_list(x)) {
+      return(switch(typeof(x),
+                    logical = if (x) "`TRUE`" else "`FALSE`",
+                    integer = "an integer",
+                    double = "a number",
+                    complex = "a complex number",
+                    character = if (nzchar(x)) "a string" else "`\"\"`",
+                    raw = "a raw value",
+                    .rlang_stop_unexpected_typeof(x)
+      ))
+    }
+    if (length(x) == 0) {
+      return(switch(typeof(x),
+                    logical = "an empty logical vector",
+                    integer = "an empty integer vector",
+                    double = "an empty numeric vector",
+                    complex = "an empty complex vector",
+                    character = "an empty character vector",
+                    raw = "an empty raw vector",
+                    list = "an empty list",
+                    .rlang_stop_unexpected_typeof(x)
+      ))
+    }
+  }
+
+  type <- .rlang_as_friendly_vector_type(typeof(x), n_dim)
+
+  if (length && !n_dim) {
+    type <- paste0(type, sprintf(" of length %s", length(x)))
+  }
+
+  type
+}
+
+.rlang_as_friendly_vector_type <- function(type, n_dim) {
+  if (type == "list") {
+    if (n_dim < 2) {
+      return("a list")
+    } else if (n_dim == 2) {
+      return("a list matrix")
+    } else {
+      return("a list array")
+    }
+  }
+
+  type <- switch(type,
+                 logical = "a logical %s",
+                 integer = "an integer %s",
+                 numeric = , # nolint
+                 double = "a double %s",
+                 complex = "a complex %s",
+                 character = "a character %s",
+                 raw = "a raw %s",
+                 type = paste0("a ", type, " %s")
+  )
+
+  if (n_dim < 2) {
+    kind <- "vector"
+  } else if (n_dim == 2) {
+    kind <- "matrix"
+  } else {
+    kind <- "array"
+  }
+  sprintf(type, kind)
+}
+
+.rlang_as_friendly_type <- function(type) {
+  switch(type,
+         list = "a list",
+         NULL = "NULL",
+         environment = "an environment",
+         externalptr = "a pointer",
+         weakref = "a weak reference",
+         S4 = "an S4 object",
+         name = , # nolint
+         symbol = "a symbol",
+         language = "a call",
+         pairlist = "a pairlist node",
+         expression = "an expression vector",
+         char = "an internal string",
+         promise = "an internal promise",
+         ... = "an internal dots object",
+         any = "an internal `any` object",
+         bytecode = "an internal bytecode object",
+         primitive = , # nolint
+         builtin = , # nolint
+         special = "a primitive function",
+         closure = "a function",
+         type
+  )
+}
+
+.rlang_stop_unexpected_typeof <- function(x, call = rlang::caller_env()) {
+  rlang::abort(
+    sprintf("Unexpected type <%s>.", typeof(x)),
+    call = call
+  )
+}
+
+#' @param x The object type which does not conform to `what`. Its
+#'   `friendly_type_of()` is taken and mentioned in the error message.
+#' @param what The friendly expected type.
+#' @param ... Arguments passed to [abort()].
+#' @inheritParams args_error_context
+#' @noRd
+stop_input_type <- function(x,
+                            what,
+                            ...,
+                            arg = rlang::caller_arg(x),
+                            call = rlang::caller_env()) {
+  # From compat-cli.R
+  format_arg <- rlang::env_get(
+    nm = "format_arg",
+    last = topenv(),
+    default = NULL
+  )
+  if (!is.function(format_arg)) {
+    format_arg <- function(x) sprintf("`%s`", x)
+  }
+
+  message <- sprintf(
+    "%s must be %s, not %s.",
+    format_arg(arg),
+    what,
+    friendly_type_of(x)
+  )
+  rlang::abort(message, ..., call = call)
+}

R/global.R

@@ -73,5 +73,7 @@ globalVariables(c(
   "CDISC_VALUE",
   "DOSE_WINDOW",
   "DOSE_COUNT",
-  "CONVERSION_FACTOR"
+  "CONVERSION_FACTOR",
+  "_unit",
+  "auto"
 ))

R/reexports.R

@@ -0,0 +1,5 @@
+#' @export
+dplyr::vars
+
+#' @export
+dplyr::desc

README.Rmd

@@ -72,3 +72,44 @@ remotes::install_github("pharmaverse/admiraldev", ref = "devel")
 | `get`                                                                             | A function that ...      
 
 
+```{r, echo = FALSE, results = 'asis'}
+nomnoml::nomnoml(
+  "[<frame>Release Schedule|
+[Q3-2022]
+[August 29th|
+admiraldev
+admiral.test
+]
+
+[September 5th|
+admiral
+]
+
+[September 12th|
+admiralonco
+admiralroche
+admiralext
+]
+  
+[Q4-2022]
+[Logs|
+  R does not naturally create a log file
+  There are many possible ways to create a log file
+  Clinical Environment creates a unique siutation
+]
+[Q1-2023]
+[R Logs|
+Does a R Log need to be like a SAS Log?
+Could a user decide on unique customization
+A new way of thinking!!?
+]
+[Logging in R] -> [Logs]
+[Audit-Ready] -> [Ready!]
+[SAS Logs] -> [R Logs]
+]",
+width = 1000,
+height = 500
+)
+```
+
+

README.md

@@ -68,3 +68,9 @@ GitHub use the following code:
 </tr>
 </tbody>
 </table>
+
+QStandardPaths: XDG\_RUNTIME\_DIR not set, defaulting to
+‘/tmp/runtime-r590548’ TypeError: Attempting to change the setter of an
+unconfigurable property. TypeError: Attempting to change the setter of
+an unconfigurable property.
+![](README_files/figure-markdown_strict/unnamed-chunk-2-1.png)

admiralext.Rproj

@@ -19,3 +19,4 @@ LineEndingConversion: Posix
 BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
+PackageRoxygenize: rd,collate,namespace