Merge branch 'main' into 18-last-obs-before-exposure-flag-and-baselin…

…e-flag

DESCRIPTION

@@ -47,9 +47,11 @@ Imports:
     vctrs,
     readr,
     glue,
+    DT,
     pillar
 Suggests:
     knitr,
+    htmltools,
     lifecycle,
     magrittr,
     rmarkdown,

NAMESPACE

@@ -19,6 +19,7 @@ export(derive_study_day)
 export(domain_example)
 export(dtc_timepart)
 export(fmt_cmp)
+export(generate_oak_id_vars)
 export(hardcode_ct)
 export(hardcode_no_ct)
 export(oak_id_vars)
@@ -33,5 +34,6 @@ importFrom(pillar,tbl_sum)
 importFrom(rlang,"%||%")
 importFrom(rlang,":=")
 importFrom(rlang,.data)
+importFrom(rlang,exprs)
 importFrom(stats,na.omit)
 importFrom(tibble,tibble)

R/dataset_oak_vignette.R

@@ -0,0 +1,84 @@
+#' Output a Dataset in a Vignette in the sdtm.oak Format
+#'
+#' Output a dataset in a vignette with the pre-specified sdtm.oak format.
+#'
+#' @param dataset Dataset to output in the vignette
+#'
+#' @param display_vars Variables selected to demonstrate the outcome of the mapping
+#'
+#' Permitted Values: list of variables
+#'
+#' Default is NULL
+#'
+#' If `display_vars` is not NULL, only the selected variables are visible in the vignette while the
+#' other variables are hidden. They can be made visible by clicking the`Choose the columns to
+#'  display` button.
+#'
+#' @param filter Filter condition
+#'
+#' The specified condition is applied to the dataset before it is displayed.
+#'
+#' Permitted Values: a condition
+#'
+#' @return A HTML table
+#'
+#' @keywords dev_utility
+#' @importFrom rlang exprs
+#'
+#' @keywords internal
+#'
+dataset_oak_vignette <- function(dataset, display_vars = NULL, filter = NULL) {
+  filter <- admiraldev::assert_filter_cond(rlang::enexpr(filter), optional = TRUE)
+
+  out <- dataset |>
+    admiraldev::filter_if(filter) |>
+    dplyr::mutate(dplyr::across(dplyr::where(is.character), as.factor))
+
+  # Create a short markdown table when this function is called outside {pkgdown}
+  if (!identical(Sys.getenv("IN_PKGDOWN"), "true")) {
+    if (is.null(display_vars)) {
+      return(knitr::kable(utils::head(out, 10L)))
+    } else {
+      return(knitr::kable(utils::head(dplyr::select(out, !!!display_vars), 10L)))
+    }
+  }
+
+  if (!is.null(display_vars)) {
+    hide_columns <- which(!(colnames(out) %in% admiraldev::vars2chr(display_vars)))
+    cols_to_hide <- list(list(targets = hide_columns - 1L, visible = FALSE))
+  } else {
+    cols_to_hide <- list()
+  }
+  htmltools::tagList(
+    htmltools::htmlDependency(
+      name = "dt-scroll",
+      version = "1.0.0",
+      src = "www",
+      stylesheet = "style.css",
+      package = "sdtm.oak"
+    ),
+    DT::datatable(
+      out,
+      rownames = FALSE,
+      filter = "top",
+      height = "auto",
+      width = "auto",
+      extensions = c("Buttons", "ColReorder", "Scroller"),
+      options = list(
+        columnDefs = cols_to_hide,
+        searchHighlight = TRUE,
+        searching = TRUE,
+        pageLength = 5L,
+        lengthMenu = c(5L, 10L, 15L, 20L, 50L, 100L),
+        dom = "<Bfr<\"dt-scroll\"t>ipl>",
+        buttons = list(list(
+          extend = "colvis",
+          text = "Choose the columns to display",
+          scroller = TRUE,
+          collectionLayout = "fixed two-column"
+        )),
+        colReorder = TRUE
+      )
+    )
+  )
+}

R/derive_study_day.R

@@ -94,6 +94,10 @@ derive_study_day <- function(sdtm_in,
       )
   }
 
+  # convert to character to verify the iso format
+  sdtm_in[[refdt]] <- as.character(sdtm_in[[refdt]])
+  sdtm_in[[tgdt]] <- as.character(sdtm_in[[tgdt]])
+
   # refdt/tgdt should be in ISO format, otherwise throw warning
   sdtm_in[[refdt]] <- tryCatch(
     as.Date(sdtm_in[[refdt]], "%Y-%m-%d"),
@@ -104,7 +108,7 @@ derive_study_day <- function(sdtm_in,
         e$message,
         call. = FALSE
       )
-      NA
+      sdtm_in[[refdt]]
     }
   )
   sdtm_in[[tgdt]] <- tryCatch(
@@ -116,12 +120,12 @@ derive_study_day <- function(sdtm_in,
         e$message,
         call. = FALSE
       )
-      NA
+      sdtm_in[[tgdt]]
     }
   )
 
-  ref <- sdtm_in[[refdt]]
-  tgt <- sdtm_in[[tgdt]]
+  ref <- as.Date(sdtm_in[[refdt]])
+  tgt <- as.Date(sdtm_in[[tgdt]])
 
   # SDTMIG 4.4.4 Use of the Study Day Variables
   res <- ifelse(tgt >= ref, tgt - ref + 1L, tgt - ref)

R/oak_id_vars.R

@@ -51,3 +51,48 @@ contains_oak_id_vars <- function(x) {
   admiraldev::assert_character_vector(x)
   all(oak_id_vars() %in% x)
 }
+
+
+#' A function to generate oak_id_vars
+#'
+#' @param raw_dat The raw dataset (dataframe)
+#' @param pat_var Variable that holds the patient number
+#' @param raw_src Name of the raw source
+#'
+#' @return dataframe
+#' @export
+#'
+#' @examples
+#' raw_dataset <-
+#'   tibble::tribble(
+#'     ~patnum, ~MDRAW,
+#'     101L, "BABY ASPIRIN",
+#'     102L, "CORTISPORIN",
+#'     103L, NA_character_,
+#'     104L, "DIPHENHYDRAMINE HCL"
+#'   )
+#'
+#' # Generate oak_id_vars
+#' generate_oak_id_vars(
+#'   raw_dat = raw_dataset,
+#'   pat_var = "patnum",
+#'   raw_src = "Concomitant Medication"
+#' )
+generate_oak_id_vars <- function(raw_dat,
+                                 pat_var,
+                                 raw_src) {
+  admiraldev::assert_character_scalar(pat_var)
+  admiraldev::assert_character_scalar(raw_src)
+  admiraldev::assert_data_frame(raw_dat)
+  admiraldev::assert_data_frame(raw_dat, required_vars = rlang::syms(pat_var))
+
+  raw_oak_id_vars <- raw_dat |>
+    dplyr::mutate(
+      oak_id = structure(seq_len(nrow(raw_dat))),
+      patient_number = !!rlang::sym(pat_var),
+      raw_source = raw_src
+    ) |>
+    dplyr::select(oak_id_vars(), dplyr::everything())
+
+  return(raw_oak_id_vars)
+}

_pkgdown.yml

@@ -8,8 +8,8 @@ navbar:
   title: "sdtm.oak"
 
 reference:
-- title: SDTM derivation
-  desc: Toolkit for SDTM derivations
+- title: SDTM Mapping Algorithms/functions
+  desc: Set of functions to perform SDTM Mappings
   contents:
   - assign
   - harcode
@@ -54,3 +54,6 @@ reference:
 - title: Package global state
   contents:
   - clear_cache
+  - generate_oak_id_vars
+  - oak_id_vars
+  - %.>%