random.cdisc.data coverage - 98.80%

Files
Source

#' ECG Analysis Dataset (ADEG)
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Function for generating random dataset from ECG Analysis Dataset for a given
#' Subject-Level Analysis Dataset.
#'
#' @details One record per subject per parameter per analysis visit per analysis date.
#'
#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`, `BASETYPE`, `AVISITN`, `ATPTN`, `DTYPE`, `ADTM`, `EGSEQ`, `ASPID`
#'
#' @inheritParams argument_convention
#' @param egcat (`character vector`)\cr EG category values.
#' @param max_n_eg (`integer`)\cr Maximum number of EG results per patient. Defaults to 10.
#' @template param_cached
#' @templateVar data adeg
#'
#' @return `data.frame`
#' @export
#'
#' @author tomlinsj, npaszty, Xuefeng Hou, dipietrc
#'
#' @examples
#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
#'
#' adeg <- radeg(adsl, visit_format = "WEEK", n_assessments = 7L, seed = 2)
#' adeg
#'
#' adeg <- radeg(adsl, visit_format = "CYCLE", n_assessments = 2L, seed = 2)
#' adeg
radeg <- function(adsl,
                  egcat = c("INTERVAL", "INTERVAL", "MEASUREMENT", "FINDING"),
                  param = c(
                    "QT Duration",
                    "RR Duration",
                    "Heart Rate",
                    "ECG Interpretation"
                  ),
                  paramcd = c("QT", "RR", "HR", "ECGINTP"),
                  paramu = c("msec", "msec", "beats/min", ""),
                  visit_format = "WEEK",
                  n_assessments = 5L,
                  n_days = 5L,
                  max_n_eg = 10L,
                  lookup = NULL,
                  seed = NULL,
                  na_percentage = 0,
                  na_vars = list(
                    ABLFL = c(1235, 0.1), BASE = c(NA, 0.1), BASEC = c(NA, 0.1),
                    CHG = c(1234, 0.1), PCHG = c(1234, 0.1)
                  ),
                  cached = FALSE) {
  checkmate::assert_flag(cached)
  if (cached) {
    return(get_cached_data("cadeg"))
  }

  checkmate::assert_data_frame(adsl)
  checkmate::assert_character(egcat, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(paramu, min.len = 1, any.missing = FALSE)
  checkmate::assert_string(visit_format)
  checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
  checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
  checkmate::assert_integer(max_n_eg, len = 1, any.missing = FALSE)
  checkmate::assert_data_frame(lookup, null.ok = TRUE)
  checkmate::assert_number(seed, null.ok = TRUE)
  checkmate::assert_number(na_percentage, lower = 0, upper = 1)
  checkmate::assert_true(na_percentage < 1)

  # validate and initialize related variables
  egcat_init_list <- relvar_init(param, egcat)
  param_init_list <- relvar_init(param, paramcd)
  unit_init_list <- relvar_init(param, paramu)

  if (!is.null(seed)) {
    set.seed(seed)
  }
  study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))

  adeg <- expand.grid(
    STUDYID = unique(adsl$STUDYID),
    USUBJID = adsl$USUBJID,
    PARAM = as.factor(param_init_list$relvar1),
    AVISIT = visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days),
    stringsAsFactors = FALSE
  )

  # assign related variable values: PARAMxEGCAT are related
  adeg <- adeg %>% rel_var(
    var_name = "EGCAT",
    related_var = "PARAM",
    var_values = egcat_init_list$relvar2
  )

  # assign related variable values: PARAMxPARAMCD are related
  adeg <- adeg %>% rel_var(
    var_name = "PARAMCD",
    related_var = "PARAM",
    var_values = param_init_list$relvar2
  )

  adeg <- adeg %>% dplyr::mutate(AVAL = dplyr::case_when(
    PARAMCD == "QT" ~ stats::rnorm(nrow(adeg), mean = 350, sd = 100),
    PARAMCD == "RR" ~ stats::rnorm(nrow(adeg), mean = 1050, sd = 300),
    PARAMCD == "HR" ~ stats::rnorm(nrow(adeg), mean = 70, sd = 20),
    PARAMCD == "ECGINTP" ~ NA_real_
  ))

  adeg <- adeg %>%
    dplyr::mutate(EGTESTCD = PARAMCD) %>%
    dplyr::mutate(EGTEST = PARAM)

  adeg <- adeg %>% dplyr::mutate(AVISITN = dplyr::case_when(
    AVISIT == "SCREENING" ~ -1,
    AVISIT == "BASELINE" ~ 0,
    (grepl("^WEEK", AVISIT) | grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
    TRUE ~ NA_real_
  ))

  adeg <- adeg %>% rel_var(
    var_name = "AVALU",
    related_var = "PARAM",
    var_values = unit_init_list$relvar2
  )

  # order to prepare for change from screening and baseline values
  adeg <- adeg[order(adeg$STUDYID, adeg$USUBJID, adeg$PARAMCD, adeg$AVISITN), ]

  adeg <- Reduce(rbind, lapply(split(adeg, adeg$USUBJID), function(x) {
    x$STUDYID <- adsl$STUDYID[which(adsl$USUBJID == x$USUBJID[1])]
    x$ABLFL <- ifelse(toupper(visit_format) == "WEEK" & x$AVISIT == "BASELINE",
      "Y",
      ifelse(toupper(visit_format) == "CYCLE" & x$AVISIT == "CYCLE 1 DAY 1", "Y", "")
    )
    x
  }))

  adeg$BASE <- ifelse(adeg$AVISITN >= 0, retain(adeg, adeg$AVAL, adeg$ABLFL == "Y"), adeg$AVAL)

  adeg <- adeg %>% dplyr::mutate(ANRLO = dplyr::case_when(
    PARAMCD == "QT" ~ 200,
    PARAMCD == "RR" ~ 600,
    PARAMCD == "HR" ~ 40,
    PARAMCD == "ECGINTP" ~ NA_real_
  ))

  adeg <- adeg %>% dplyr::mutate(ANRHI = dplyr::case_when(
    PARAMCD == "QT" ~ 500,
    PARAMCD == "RR" ~ 1500,
    PARAMCD == "HR" ~ 100,
    PARAMCD == "ECGINTP" ~ NA_real_
  ))

  adeg <- adeg %>% dplyr::mutate(ANRIND = factor(dplyr::case_when(
    AVAL < ANRLO ~ "LOW",
    AVAL >= ANRLO & AVAL <= ANRHI ~ "NORMAL",
    AVAL > ANRHI ~ "HIGH"
  )))

  adeg <- adeg %>%
    dplyr::mutate(CHG = ifelse(AVISITN > 0, AVAL - BASE, NA)) %>%
    dplyr::mutate(PCHG = ifelse(AVISITN > 0, 100 * (CHG / BASE), NA)) %>%
    dplyr::mutate(BASETYPE = "LAST") %>%
    dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
    dplyr::mutate(BNRIND = ANRIND[ABLFL == "Y"]) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(ATPTN = 1) %>%
    dplyr::mutate(DTYPE = NA)

  adeg$ANRIND <- factor(adeg$ANRIND, levels = c("LOW", "NORMAL", "HIGH"))
  adeg$BNRIND <- factor(adeg$BNRIND, levels = c("LOW", "NORMAL", "HIGH"))

  adeg <- rcd_var_relabel(
    adeg,
    STUDYID = "Study Identifier",
    USUBJID = "Unique Subject Identifier"
  )

  # merge ADSL to be able to add EG date and study day variables
  adeg <- dplyr::inner_join(
    adeg,
    adsl,
    by = c("STUDYID", "USUBJID")
  ) %>%
    dplyr::rowwise() %>%
    dplyr::mutate(TRTENDT = lubridate::date(dplyr::case_when(
      is.na(TRTEDTM) ~ lubridate::floor_date(lubridate::date(TRTSDTM) + study_duration_secs, unit = "day"),
      TRUE ~ TRTEDTM
    ))) %>%
    dplyr::ungroup()

  adeg <- adeg %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::arrange(USUBJID, AVISITN) %>%
    dplyr::mutate(ADTM = rep(
      sort(sample(
        seq(lubridate::as_datetime(TRTSDTM[1]), lubridate::as_datetime(TRTENDT[1]), by = "day"),
        size = nlevels(AVISIT)
      )),
      each = n() / nlevels(AVISIT)
    )) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(ADY = ceiling(difftime(ADTM, TRTSDTM, units = "days"))) %>%
    dplyr::select(-TRTENDT) %>%
    dplyr::arrange(STUDYID, USUBJID, ADTM)

  adeg <- adeg %>%
    dplyr::mutate(ASPID = sample(seq_len(dplyr::n()))) %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::mutate(EGSEQ = seq_len(dplyr::n())) %>%
    dplyr::mutate(ASEQ = EGSEQ) %>%
    dplyr::ungroup() %>%
    dplyr::arrange(
      STUDYID,
      USUBJID,
      PARAMCD,
      BASETYPE,
      AVISITN,
      ATPTN,
      DTYPE,
      ADTM,
      EGSEQ,
      ASPID
    )

  adeg <- adeg %>% dplyr::mutate(ONTRTFL = factor(dplyr::case_when(
    !AVISIT %in% c("SCREENING", "BASELINE") ~ "Y",
    TRUE ~ ""
  )))

  adeg <- adeg %>% dplyr::mutate(AVALC = ifelse(
    PARAMCD == "ECGINTP",
    as.character(sample_fct(c("ABNORMAL", "NORMAL"), nrow(adeg), prob = c(0.25, 0.75))),
    as.character(AVAL)
  ))

  # Temporarily creating a row_check column to easily match newly created
  # observations with their row correct arrangement.
  adeg <- adeg %>%
    dplyr::mutate(row_check = seq_len(nrow(adeg)))

  # Created function to add in new observations for DTYPE, "MINIMUM" & "MAXIMUM" in this case.
  get_groups <- function(data,
                         minimum) {
    data <- data %>%
      dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
      dplyr::arrange(ADTM, ASPID, EGSEQ) %>%
      dplyr::filter(
        (AVISIT != "BASELINE" & AVISIT != "SCREENING") &
          (ONTRTFL == "Y" | ADTM <= TRTSDTM)
      ) %>%
      {
        if (minimum == TRUE) {
          dplyr::filter(., AVAL == min(AVAL)) %>%
            dplyr::mutate(., DTYPE = "MINIMUM", AVISIT = "POST-BASELINE MINIMUM")
        } else {
          dplyr::filter(., AVAL == max(AVAL)) %>%
            dplyr::mutate(., DTYPE = "MAXIMUM", AVISIT = "POST-BASELINE MAXIMUM")
        }
      } %>%
      dplyr::slice(1) %>%
      dplyr::ungroup()

    return(data)
  }

  # Binding the new observations to the dataset from the function above and rearranging in the correct order.
  adeg <- rbind(adeg, get_groups(adeg, TRUE), get_groups(adeg, FALSE)) %>%
    dplyr::arrange(row_check) %>%
    dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
    dplyr::arrange(AVISIT, .by_group = TRUE) %>%
    dplyr::ungroup()

  # Dropping the "row_check" column created above.
  adeg <- adeg[, -which(names(adeg) %in% c("row_check"))]

  # Created function to easily match rows which comply to ONTRTFL derivation
  flag_variables <- function(data, worst_obs) {
    data_compare <- data %>%
      dplyr::mutate(row_check = seq_len(nrow(data)))

    data <- data_compare %>%
      {
        if (worst_obs == FALSE) {
          dplyr::group_by(., USUBJID, PARAMCD, BASETYPE, AVISIT) %>%
            dplyr::arrange(., ADTM, ASPID, EGSEQ)
        } else {
          dplyr::group_by(., USUBJID, PARAMCD, BASETYPE)
        }
      } %>%
      dplyr::filter(
        AVISITN > 0 & (ONTRTFL == "Y" | ADTM <= TRTSDTM) &
          is.na(DTYPE)
      ) %>%
      {
        if (worst_obs == TRUE) {
          dplyr::arrange(., AVALC) %>% dplyr::filter(., ifelse(
            PARAMCD == "ECGINTP",
            ifelse(AVALC == "ABNORMAL", AVALC == "ABNORMAL", AVALC == "NORMAL"),
            AVAL == min(AVAL)
          ))
        } else {
          dplyr::filter(., ifelse(
            PARAMCD == "ECGINTP",
            AVALC == "ABNORMAL" | AVALC == "NORMAL",
            AVAL == min(AVAL)
          ))
        }
      } %>%
      dplyr::slice(1) %>%
      {
        if (worst_obs == TRUE) {
          dplyr::mutate(., new_var = dplyr::case_when(
            (AVALC == "ABNORMAL" | AVALC == "NORMAL") ~ "Y",
            (!is.na(AVAL) & is.na(DTYPE)) ~ "Y",
            TRUE ~ ""
          ))
        } else {
          dplyr::mutate(., new_var = dplyr::case_when(
            (AVALC == "ABNORMAL" | AVALC == "NORMAL") ~ "Y",
            (!is.na(AVAL) & is.na(DTYPE)) ~ "Y",
            TRUE ~ ""
          ))
        }
      } %>%
      dplyr::ungroup()

    data_compare$new_var <- ifelse(data_compare$row_check %in% data$row_check, "Y", "")
    data_compare <- data_compare[, -which(names(data_compare) %in% c("row_check"))]

    return(data_compare)
  }

  adeg <- flag_variables(adeg, FALSE) %>% dplyr::rename(WORS01FL = "new_var")
  adeg <- flag_variables(adeg, TRUE) %>% dplyr::rename(WORS02FL = "new_var")

  adeg <- adeg %>% dplyr::mutate(ANL01FL = factor(ifelse(
    (ABLFL == "Y" | (is.na(DTYPE) & WORS01FL == "Y")) &
      (AVISIT != "SCREENING"),
    "Y",
    ""
  )))

  adeg <- adeg %>%
    dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
    dplyr::mutate(BASEC = ifelse(
      PARAMCD == "ECGINTP",
      AVALC[AVISIT == "BASELINE"],
      as.character(BASE)
    )) %>%
    dplyr::mutate(ANL03FL = dplyr::case_when(
      DTYPE == "MINIMUM" ~ "Y",
      ABLFL == "Y" & PARAMCD != "ECGINTP" ~ "Y",
      TRUE ~ ""
    )) %>%
    dplyr::mutate(ANL04FL = dplyr::case_when(
      DTYPE == "MAXIMUM" ~ "Y",
      ABLFL == "Y" & PARAMCD != "ECGINTP" ~ "Y",
      TRUE ~ ""
    )) %>%
    dplyr::ungroup()

  if (length(na_vars) > 0 && na_percentage > 0) {
    adeg <- mutate_na(ds = adeg, na_vars = na_vars, na_percentage = na_percentage)
  }

  # apply metadata
  adeg <- apply_metadata(adeg, "metadata/ADEG.yml")

  return(adeg)
}

#' Time to Adverse Event Analysis Dataset (ADAETTE)
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Function to generate random Time-to-AE Dataset for a
#' given Subject-Level Analysis Dataset.
#'
#' @details
#'
#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`
#'
#' @inheritParams argument_convention
#' @param event_descr (`character vector`)\cr Descriptions of events. Defaults to `NULL`.
#' @param censor_descr (`character vector`)\cr Descriptions of censors. Defaults to `NULL`.
#' @template param_cached
#' @templateVar data adaette
#'
#' @return `data.frame`
#' @export
#'
#' @author Xiuting Mi
#'
#' @examples
#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
#'
#' adaette <- radaette(adsl, seed = 2)
#' adaette
radaette <- function(adsl,
                     event_descr = NULL,
                     censor_descr = NULL,
                     lookup = NULL,
                     seed = NULL,
                     na_percentage = 0,
                     na_vars = list(CNSR = c(NA, 0.1), AVAL = c(1234, 0.1)),
                     cached = FALSE) {
  checkmate::assert_flag(cached)
  if (cached) {
    return(get_cached_data("cadaette"))
  }

  checkmate::assert_data_frame(adsl)
  checkmate::assert_character(censor_descr, null.ok = TRUE, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(event_descr, null.ok = TRUE, min.len = 1, any.missing = FALSE)
  checkmate::assert_number(seed, null.ok = TRUE)
  checkmate::assert_number(na_percentage, lower = 0, upper = 1)
  checkmate::assert_true(na_percentage < 1)

  checkmate::assert_data_frame(lookup, null.ok = TRUE)
  lookup_adaette <- if (!is.null(lookup)) {
    lookup
  } else {
    tibble::tribble(
      ~ARM, ~CATCD, ~CAT, ~LAMBDA, ~CNSR_P,
      "ARM A", "1", "any adverse event", 1 / 80, 0.4,
      "ARM B", "1", "any adverse event", 1 / 100, 0.2,
      "ARM C", "1", "any adverse event", 1 / 60, 0.42,
      "ARM A", "2", "any serious adverse event", 1 / 100, 0.3,
      "ARM B", "2", "any serious adverse event", 1 / 150, 0.1,
      "ARM C", "2", "any serious adverse event", 1 / 80, 0.32,
      "ARM A", "3", "a grade 3-5 adverse event", 1 / 80, 0.2,
      "ARM B", "3", "a grade 3-5 adverse event", 1 / 100, 0.08,
      "ARM C", "3", "a grade 3-5 adverse event", 1 / 60, 0.23
    )
  }

  if (!is.null(seed)) {
    set.seed(seed)
  }
  study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))

  evntdescr_sel <- if (!is.null(event_descr)) {
    event_descr
  } else {
    "Preferred Term"
  }

  cnsdtdscr_sel <- if (!is.null(censor_descr)) {
    censor_descr
  } else {
    c(
      "Clinical Cut Off",
      "Completion or Discontinuation",
      "End of AE Reporting Period"
    )
  }

  random_patient_data <- function(patient_info) {
    startdt <- lubridate::date(patient_info$TRTSDTM)
    trtedtm <- lubridate::floor_date(dplyr::case_when(
      is.na(patient_info$TRTEDTM) ~ lubridate::date(patient_info$TRTSDTM) + study_duration_secs,
      TRUE ~ lubridate::date(patient_info$TRTEDTM)
    ), unit = "day")
    enddts <- c(patient_info$EOSDT, lubridate::date(trtedtm))
    enddts_min_index <- which.min(enddts)
    adt <- enddts[enddts_min_index]
    adtm <- lubridate::as_datetime(adt)
    ady <- as.numeric(adt - startdt + 1)
    data.frame(
      ARM = patient_info$ARM,
      STUDYID = patient_info$STUDYID,
      SITEID = patient_info$SITEID,
      USUBJID = patient_info$USUBJID,
      PARAMCD = "AEREPTTE",
      PARAM = "Time to end of AE reporting period",
      CNSR = 0,
      AVAL = lubridate::days(ady) / lubridate::years(1),
      AVALU = "YEARS",
      EVNTDESC = ifelse(enddts_min_index == 1, "Completion or Discontinuation", "End of AE Reporting Period"),
      CNSDTDSC = NA,
      ADTM = adtm,
      ADY = ady,
      stringsAsFactors = FALSE
    )
  }

  # validate and initialize related variables for Hy's law
  paramcd_hy <- c("HYSTTEUL", "HYSTTEBL")
  param_hy <- c("Time to Hy's Law Elevation in relation to ULN", "Time to Hy's Law Elevation in relation to Baseline")
  param_init_list <- relvar_init(param_hy, paramcd_hy)
  adsl_hy <- dplyr::select(adsl, "STUDYID", "USUBJID", "TRTSDTM", "SITEID", "ARM")

  # create all combinations of unique values in STUDYID, USUBJID, PARAM, AVISIT
  adaette_hy <- expand.grid(
    STUDYID = unique(adsl$STUDYID),
    USUBJID = adsl$USUBJID,
    PARAM = as.factor(param_init_list$relvar1),
    stringsAsFactors = FALSE
  )

  # Add other variables to adaette_hy
  adaette_hy <- dplyr::left_join(adaette_hy, adsl_hy, by = c("STUDYID", "USUBJID")) %>%
    rel_var(
      var_name = "PARAMCD",
      related_var = "PARAM",
      var_values = param_init_list$relvar2
    ) %>%
    dplyr::mutate(
      CNSR = sample(c(0, 1), prob = c(0.1, 0.9), size = dplyr::n(), replace = TRUE),
      EVNTDESC = dplyr::if_else(
        CNSR == 0,
        "First Post-Baseline Raised ALT or AST Elevation Result",
        NA_character_
      ),
      CNSDTDSC = dplyr::if_else(CNSR == 0, NA_character_,
        sample(c("Last Post-Baseline ALT or AST Result", "Treatment Start"),
          prob = c(0.9, 0.1),
          size = dplyr::n(), replace = TRUE
        )
      )
    ) %>%
    dplyr::rowwise() %>%
    dplyr::mutate(ADTM = dplyr::case_when(
      CNSDTDSC == "Treatment Start" ~ TRTSDTM,
      TRUE ~ TRTSDTM + sample(seq(0, study_duration_secs), size = dplyr::n(), replace = TRUE)
    )) %>%
    dplyr::mutate(
      ADY_int = lubridate::date(ADTM) - lubridate::date(TRTSDTM) + 1,
      ADY = as.numeric(ADY_int),
      AVAL = lubridate::days(ADY_int) / lubridate::weeks(1),
      AVALU = "WEEKS"
    ) %>%
    dplyr::select(-TRTSDTM, -ADY_int)

  random_ae_data <- function(lookup_info, patient_info, patient_data) {
    cnsr <- sample(c(0, 1), 1, prob = c(1 - lookup_info$CNSR_P, lookup_info$CNSR_P))
    ae_rep_tte <- patient_data$AVAL[patient_data$PARAMCD == "AEREPTTE"]
    data.frame(
      ARM = rep(patient_data$ARM, 2),
      STUDYID = rep(patient_data$STUDYID, 2),
      SITEID = rep(patient_data$SITEID, 2),
      USUBJID = rep(patient_data$USUBJID, 2),
      PARAMCD = c(
        paste0("AETTE", lookup_info$CATCD),
        paste0("AETOT", lookup_info$CATCD)
      ),
      PARAM = c(
        paste("Time to first occurrence of", lookup_info$CAT),
        paste("Number of occurrences of", lookup_info$CAT)
      ),
      CNSR = c(
        cnsr,
        NA
      ),
      AVAL = c(
        # We generate these values conditional on the censoring information.
        # If this time to event is censored, then there were no AEs reported and the time is set
        # to the AE reporting period time. Otherwise we draw from truncated distributions to make
        # sure that we are within the AE reporting time and above 0 AEs.
        ifelse(cnsr == 1, ae_rep_tte, rtexp(1, lookup_info$LAMBDA * 365.25, r = ae_rep_tte)),
        ifelse(cnsr == 1, 0, rtpois(1, lookup_info$LAMBDA * 365.25))
      ),
      AVALU = c(
        "YEARS",
        NA
      ),
      EVNTDESC = c(
        ifelse(cnsr == 0, sample(evntdescr_sel, 1), ""),
        NA
      ),
      CNSDTDSC = c(
        ifelse(cnsr == 1, sample(cnsdtdscr_sel, 1), ""),
        NA
      ),
      stringsAsFactors = FALSE
    ) %>% dplyr::mutate(
      ADY = dplyr::if_else(is.na(AVALU), NA_real_, ceiling(as.numeric(lubridate::dyears(AVAL), "days"))),
      ADTM = dplyr::if_else(
        is.na(AVALU),
        lubridate::as_datetime(NA),
        patient_info$TRTSDTM + lubridate::days(ADY)
      )
    )
  }

  adaette <- split(adsl, adsl$USUBJID) %>%
    lapply(function(patient_info) {
      patient_data <- random_patient_data(patient_info)
      lookup_arm <- lookup_adaette %>%
        dplyr::filter(ARM == as.character(patient_info$ARMCD))
      ae_data <- split(lookup_arm, lookup_arm$CATCD) %>%
        lapply(random_ae_data, patient_data = patient_data, patient_info = patient_info) %>%
        Reduce(rbind, .)
      dplyr::bind_rows(patient_data, ae_data)
    }) %>%
    Reduce(rbind, .) %>%
    rcd_var_relabel(
      STUDYID = "Study Identifier",
      USUBJID = "Unique Subject Identifier"
    )

  adaette <- rcd_var_relabel(
    adaette,
    STUDYID = "Study Identifier",
    USUBJID = "Unique Subject Identifier"
  )

  adaette <- rbind(adaette, adaette_hy)

  adaette <- dplyr::inner_join(
    dplyr::select(adaette, -"SITEID", -"ARM"),
    adsl,
    by = c("STUDYID", "USUBJID")
  ) %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::arrange(ADTM) %>%
    dplyr::mutate(TTESEQ = seq_len(dplyr::n())) %>%
    dplyr::mutate(ASEQ = TTESEQ) %>%
    dplyr::mutate(PARAM = as.factor(PARAM)) %>%
    dplyr::mutate(PARAMCD = as.factor(PARAMCD)) %>%
    dplyr::ungroup() %>%
    dplyr::arrange(
      STUDYID,
      USUBJID,
      PARAMCD,
      ADTM,
      TTESEQ
    )

  if (length(na_vars) > 0 && na_percentage > 0) {
    adaette <- dplyr::mutate(ds = adaette, na_vars = na_vars, na_percentage = na_percentage)
  }

  # apply metadata
  adaette <- apply_metadata(adaette, "metadata/ADAETTE.yml")

  return(adaette)
}

#' Load Cached Data
#'
#' Return data attached to package.
#'
#' @keywords internal
#' @noRd
get_cached_data <- function(dataname) {
  checkmate::assert_string(dataname)
  if (!("package:random.cdisc.data" %in% search())) {
    stop("cached data can only be loaded if the random.cdisc.data package is attached.",
      "Please run library(random.cdisc.data) before loading cached data.",
      call. = FALSE
    )
  } else {
    get(dataname, envir = asNamespace("random.cdisc.data"))
  }
}

#' Create a Factor with Random Elements of x
#'
#' Sample elements from `x` with replacement to build a factor.
#'
#' @param x (`character vector` or `factor`)\cr If character vector then it is also used
#'   as levels of the returned factor. If factor then the levels are used as the new levels.
#' @param N (`numeric`)\cr Number of items to choose.
#' @param ... Additional arguments to be passed to `sample`.
#'
#' @return A factor of length `N`.
#' @export
#'
#' @examples
#' sample_fct(letters[1:3], 10)
#' sample_fct(iris$Species, 10)
sample_fct <- function(x, N, ...) { # nolint
  checkmate::assert_number(N)

  factor(sample(x, N, replace = TRUE, ...), levels = if (is.factor(x)) levels(x) else x)
}

#' Related Variables: Initialize
#'
#' Verify and initialize related variable values.
#' For example, `relvar_init("Alanine Aminotransferase Measurement", "ALT")`.
#'
#' @param relvar1 (`list` of `character`)\cr List of n elements.
#' @param relvar2 (`list` of `character`)\cr List of n elements.
#'
#' @return A vector of n elements.
#'
#' @keywords internal
relvar_init <- function(relvar1, relvar2) {
  checkmate::assert_character(relvar1, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(relvar2, min.len = 1, any.missing = FALSE)

  if (length(relvar1) != length(relvar2)) {
    message(simpleError(
      "The argument value length of relvar1 and relvar2 differ. They must contain the same number of elements."
    ))
    return(NA)
  }
  return(list("relvar1" = relvar1, "relvar2" = relvar2))
}

#' Related Variables: Assign
#'
#' Assign values to a related variable within a domain.
#'
#' @param df (`data.frame`)\cr Data frame containing the related variables.
#' @param var_name (`character`)\cr Name of variable related to `rel_var` to add to `df`.
#' @param var_values (`any`)\cr Vector of values related to values of `related_var`.
#' @param related_var (`character`)\cr Name of variable within `df` with values to which values
#' of `var_name` must relate.
#'
#' @return `df` with added factor variable `var_name` containing `var_values` corresponding to `related_var`.
#' @export
#'
#' @examples
#' # Example with data.frame.
#' params <- c("Level A", "Level B", "Level C")
#' adlb_df <- data.frame(
#'   ID = 1:9,
#'   PARAM = factor(
#'     rep(c("Level A", "Level B", "Level C"), 3),
#'     levels = params
#'   )
#' )
#' rel_var(
#'   df = adlb_df,
#'   var_name = "PARAMCD",
#'   var_values = c("A", "B", "C"),
#'   related_var = "PARAM"
#' )
#'
#' # Example with tibble.
#' adlb_tbl <- tibble::tibble(
#'   ID = 1:9,
#'   PARAM = factor(
#'     rep(c("Level A", "Level B", "Level C"), 3),
#'     levels = params
#'   )
#' )
#' rel_var(
#'   df = adlb_tbl,
#'   var_name = "PARAMCD",
#'   var_values = c("A", "B", "C"),
#'   related_var = "PARAM"
#' )
rel_var <- function(df, var_name, related_var, var_values = NULL) {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(var_name)
  checkmate::assert_string(related_var)
  n_relvar1 <- length(unique(df[, related_var, drop = TRUE]))
  checkmate::assert_vector(var_values, null.ok = TRUE, len = n_relvar1, any.missing = FALSE)
  if (is.null(var_values)) var_values <- rep(NA, n_relvar1)

  relvar1 <- unique(df[, related_var, drop = TRUE])
  relvar2_values <- rep(NA, nrow(df))
  for (r in seq_len(n_relvar1)) {
    matched <- which(df[, related_var, drop = TRUE] == relvar1[r])
    relvar2_values[matched] <- var_values[r]
  }
  df[[var_name]] <- factor(relvar2_values)
  return(df)
}

#' Create Visit Schedule
#'
#' Create a visit schedule as a factor.
#'
#' X number of visits, or X number of cycles and Y number of days.
#'
#' @inheritParams argument_convention
#'
#' @return A factor of length `n_assessments`.
#' @export
#'
#' @examples
#' visit_schedule(visit_format = "WEeK", n_assessments = 10L)
#' visit_schedule(visit_format = "CyCLE", n_assessments = 5L, n_days = 2L)
visit_schedule <- function(visit_format = "WEEK",
                           n_assessments = 10L,
                           n_days = 5L) {
  checkmate::assert_string(visit_format, pattern = "^WEEK$|^CYCLE$", ignore.case = TRUE)
  checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
  checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)

  if (toupper(visit_format) == "WEEK") {
    # numeric vector of n assessments/cycles/days
    assessments <- 1:n_assessments
    # numeric vector for ordering including screening (-1) and baseline (0) place holders
    assessments_ord <- -1:n_assessments
    # character vector of nominal visit values
    visit_values <- c("SCREENING", "BASELINE", paste(toupper(visit_format), assessments, "DAY", (assessments * 7) + 1))
  } else if (toupper(visit_format) == "CYCLE") {
    cycles <- sort(rep(1:n_assessments, times = 1, each = n_days))
    days <- rep(seq(1:n_days), times = n_assessments, each = 1)
    assessments_ord <- 0:(n_assessments * n_days)
    visit_values <- c("SCREENING", paste(toupper(visit_format), cycles, "DAY", days))
  }

  # create and order factor variable to return from function
  visit_values <- stats::reorder(factor(visit_values), assessments_ord)
}

#' Primary Keys: Retain Values
#'
#' Retain values within primary keys.
#'
#' @param df (`data.frame`)\cr Data frame in which to apply the retain.
#' @param value_var (`any`)\cr Variable in `df` containing the value to be retained.
#' @param event (`expression`)\cr Expression returning a logical value to trigger the retain.
#' @param outside (`any`)\cr Additional value to retain. Defaults to `NA`.
#' @return A vector of values where expression is true.
#' @keywords internal
retain <- function(df, value_var, event, outside = NA) {
  indices <- c(1, which(event == TRUE), nrow(df) + 1)
  values <- c(outside, value_var[event == TRUE])
  rep(values, diff(indices))
}

#' Primary Keys: Labels
#'
#' @description Shallow copy of `formatters::var_relabel()`. Used mainly internally to
#'   relabel a subset of variables in a data set.
#'
#' @param x (`data.frame`)\cr Data frame containing variables to which labels are applied.
#' @param ... (`named character`)\cr Name-Value pairs, where name corresponds to a variable
#'   name in `x` and the value to the new variable label.
#' @return x (`data.frame`)\cr Data frame with labels applied.
#'
#' @keywords internal
rcd_var_relabel <- function(x, ...) {
  stopifnot(is.data.frame(x))
  if (missing(...)) {
    return(x)
  }
  dots <- list(...)
  varnames <- names(dots)
  if (is.null(varnames)) {
    stop("missing variable declarations")
  }
  map_varnames <- match(varnames, colnames(x))
  if (any(is.na(map_varnames))) {
    stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found")
  }
  if (any(vapply(dots, Negate(is.character), logical(1)))) {
    stop("all variable labels must be of type character")
  }
  for (i in seq_along(map_varnames)) {
    attr(x[[map_varnames[[i]]]], "label") <- dots[[i]]
  }
  x
}

#' Apply Metadata
#'
#' Apply label and variable ordering attributes to domains.
#'
#' @param df (`data.frame`)\cr Data frame to which metadata is applied.
#' @param filename (`yaml`)\cr File containing domain metadata.
#' @param add_adsl (`logical`)\cr Should ADSL data be merged to domain.
#' @param adsl_filename (`yaml`)\cr File containing ADSL metadata.
#' @return Data frame with metadata applied.
#'
#' @export
#' @examples
#' seed <- 1
#' adsl <- radsl(seed = seed)
#' adsub <- radsub(adsl, seed = seed)
#' yaml_path <- file.path(path.package("random.cdisc.data"), "inst", "metadata")
#' adsl <- apply_metadata(adsl, file.path(yaml_path, "ADSL.yml"), FALSE)
#' adsub <- apply_metadata(
#'   adsub, file.path(yaml_path, "ADSUB.yml"), TRUE,
#'   file.path(yaml_path, "ADSL.yml")
#' )
apply_metadata <- function(df, filename, add_adsl = TRUE, adsl_filename = "metadata/ADSL.yml") {
  checkmate::assert_data_frame(df)
  checkmate::assert_string(filename)
  checkmate::assert_flag(add_adsl)
  checkmate::assert_string(adsl_filename)

  apply_type <- function(df, var, type) {
    if (is.null(type)) {
      return()
    }

    if (type == "character" && !is.character(df[[var]])) {
      df[[var]] <- as.character(df[[var]])
    } else if (type == "factor" && !is.factor(df[[var]])) {
      df[[var]] <- as.factor(df[[var]])
    } else if (type == "integer" && !is.integer(df[[var]])) {
      df[[var]] <- as.integer(df[[var]])
    } else if (type == "numeric" && !is.numeric(df[[var]])) {
      df[[var]] <- as.numeric(df[[var]])
    } else if (type == "logical" && !is.logical(df[[var]])) {
      df[[var]] <- as.logical(df[[var]])
    } else if (type == "datetime" && !lubridate::is.POSIXct(df[[var]])) {
      df[[var]] <- as.POSIXct(df[[var]])
    } else if (type == "date" && !lubridate::is.Date(df[[var]])) {
      df[[var]] <- as.Date(df[[var]])
    }
    return(df)
  }

  # remove existing attributes
  for (i in base::setdiff(names(attributes(df)), names(attributes(data.frame())))) {
    attr(df, i) <- NULL
  }

  # get metadata
  metadata <- yaml::yaml.load_file(system.file(filename, package = "random.cdisc.data"))
  adsl_metadata <- if (add_adsl) {
    yaml::yaml.load_file(system.file(adsl_filename, package = "random.cdisc.data"))
  } else {
    NULL
  }
  metadata_variables <- append(adsl_metadata$variables, metadata$variables)
  metadata_varnames <- names(metadata_variables)

  # find variables that does not have labels and are not it metadata
  missing_vars_map <- vapply(
    names(df),
    function(x) {
      !(x %in% c("STUDYID", "USUBJID", metadata_varnames)) && is.null(attr(df[[x]], "label"))
    },
    logical(1)
  )
  missing_vars <- names(df)[missing_vars_map]
  if (length(missing_vars) > 0) {
    msg <- paste0(
      "Following variables does not have label or are not found in ",
      filename,
      ": ",
      paste0(missing_vars, collapse = ", ")
    )
    warning(msg)
  }

  if (!all(metadata_varnames %in% names(df))) {
    metadata_varnames <- metadata_varnames[metadata_varnames %in% names(df)]
  }

  # assign labels to variables
  for (var in metadata_varnames) {
    df <- apply_type(df, var, metadata_variables[[var]]$type)
    attr(df[[var]], "label") <- metadata_variables[[var]]$label
  }

  # reorder data frame columns to expected BDS order
  df <- df[, unique(c("STUDYID", "USUBJID", metadata_varnames, names(df)))]

  # assign label to data frame
  attr(df, "label") <- metadata$domain$label

  df
}

#' Replace Values in a Vector by NA
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Randomized replacement of values by `NA`.
#'
#' @inheritParams argument_convention
#' @param v (`any`)\cr Vector of any type.
#' @param percentage (`proportion`)\cr Value between 0 and 1 defining
#'   how much of the vector shall be replaced by `NA`. This number
#'   is randomized by +/- 5% to have full randomization.
#'
#' @return The input vector `v` where a certain number of values are replaced by `NA`.
#'
#' @export
replace_na <- function(v, percentage = 0.05, seed = NULL) {
  checkmate::assert_number(percentage, lower = 0, upper = 1)

  if (percentage == 0) {
    return(v)
  }

  if (!is.null(seed) && !is.na(seed)) {
    set.seed(seed)
  }

  # randomize the percentage
  ind <- sample(seq_along(v), round(length(v) * percentage))

  v[ind] <- NA

  return(v)
}

#' Replace Values with NA
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Replace column values with `NA`s.
#'
#' @inheritParams argument_convention
#' @param ds (`data.frame`)\cr Any data set.
#'
#' @return dataframe without `NA` values.
#'
#' @export
mutate_na <- function(ds, na_vars = NULL, na_percentage = 0.05) {
  if (!is.null(na_vars)) {
    stopifnot(is.list(na_vars)) # any list is OK; as values can be left NA
    stopifnot(length(names(na_vars)) == length(na_vars)) # names for all elements
  } else {
    na_vars <- names(ds)
  }

  stopifnot(is.numeric(na_percentage))
  stopifnot(na_percentage >= 0 && na_percentage < 1)

  for (na_var in names(na_vars)) {
    if (!is.na(na_var)) {
      if (!na_var %in% names(ds)) {
        warning(paste(na_var, "not in column names"))
      } else {
        ds <- ds %>%
          ungroup_rowwise_df() %>%
          dplyr::mutate(
            !!na_var := ds[[na_var]] %>%
              replace_na(
                percentage = ifelse(is.na(na_vars[[na_var]][2]), na_percentage, na_vars[[na_var]][2]),
                seed = na_vars[[na_var]][1]
              )
          )
      }
    }
  }
  return(ds)
}

ungroup_rowwise_df <- function(x) {
  class(x) <- c("tbl", "tbl_df", "data.frame")
  return(x)
}

#' Zero-Truncated Poisson Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This generates random numbers from a zero-truncated Poisson distribution,
#' i.e. from `X | X > 0` when `X ~ Poisson(lambda)`. The advantage here is that
#' we guarantee to return exactly `n` numbers and without using a loop internally.
#' This solution was provided in a post by
#' [Peter Dalgaard](https://stat.ethz.ch/pipermail/r-help/2005-May/070680.html).
#'
#' @param n (`numeric`)\cr Number of random numbers.
#' @param lambda (`numeric`)\cr Non-negative mean(s).
#'
#' @return The random numbers.
#' @export
#'
#' @examples
#' x <- rpois(1e6, lambda = 5)
#' x <- x[x > 0]
#' hist(x)
#'
#' y <- rtpois(1e6, lambda = 5)
#' hist(y)
rtpois <- function(n, lambda) {
  stats::qpois(stats::runif(n, stats::dpois(0, lambda), 1), lambda)
}

#' Truncated Exponential Distribution
#'
#' @description `r lifecycle::badge("stable")`
#'
#' This generates random numbers from a truncated Exponential distribution,
#' i.e. from `X | X > l` or `X | X < r` when `X ~ Exp(rate)`. The advantage here is that
#' we guarantee to return exactly `n` numbers and without using a loop internally.
#' This can be derived from the quantile functions of the left- and right-truncated
#' Exponential distributions.
#'
#' @param n (`numeric`)\cr Number of random numbers.
#' @param rate (`numeric`)\cr Non-negative rate.
#' @param l (`numeric`)\cr Positive left-hand truncation parameter.
#' @param r (`numeric`)\cr Positive right-hand truncation parameter.
#'
#' @return The random numbers. If neither `l` nor `r` are provided then the usual Exponential
#'  distribution is used.
#' @export
#'
#' @examples
#' x <- stats::rexp(1e6, rate = 5)
#' x <- x[x > 0.5]
#' hist(x)
#'
#' y <- rtexp(1e6, rate = 5, l = 0.5)
#' hist(y)
#'
#' z <- rtexp(1e6, rate = 5, r = 0.5)
#' hist(z)
rtexp <- function(n, rate, l = NULL, r = NULL) {
  if (!is.null(l)) {
    l - log(1 - stats::runif(n)) / rate
  } else if (!is.null(r)) {
    -log(1 - stats::runif(n) * (1 - exp(-r * rate))) / rate
  } else {
    stats::rexp(n, rate)
  }
}

#' Hy's Law Analysis Dataset (ADHY)
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Function for generating a random Hy's Law Analysis Dataset for a given
#' Subject-Level Analysis Dataset.
#'
#' @details One record per subject per parameter per analysis visit per analysis date.
#'
#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`, `AVISITN`, `ADTM`, `SRCSEQ`
#
#' @inheritParams argument_convention
#' @template param_cached
#' @templateVar data adhy
#'
#' @return `data.frame`
#' @export
#'
#' @author wojciakw
#'
#' @examples
#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
#'
#' adhy <- radhy(adsl, seed = 2)
#' adhy
radhy <- function(adsl,
                  param = c(
                    "TBILI <= 2 times ULN and ALT value category",
                    "TBILI > 2 times ULN and AST value category",
                    "TBILI > 2 times ULN and ALT value category",
                    "TBILI <= 2 times ULN and AST value category",
                    "TBILI > 2 times ULN and ALKPH <= 2 times ULN and ALT value category",
                    "TBILI > 2 times ULN and ALKPH <= 2 times ULN and AST value category",
                    "TBILI > 2 times ULN and ALKPH <= 5 times ULN and ALT value category",
                    "TBILI > 2 times ULN and ALKPH <= 5 times ULN and AST value category",
                    "TBILI <= 2 times ULN and two consecutive elevations of ALT in relation to ULN",
                    "TBILI > 2 times ULN and two consecutive elevations of AST in relation to ULN",
                    "TBILI <= 2 times ULN and two consecutive elevations of AST in relation to ULN",
                    "TBILI > 2 times ULN and two consecutive elevations of ALT in relation to ULN",
                    "TBILI > 2 times ULN and two consecutive elevations of ALT in relation to Baseline",
                    "TBILI <= 2 times ULN and two consecutive elevations of ALT in relation to Baseline",
                    "TBILI > 2 times ULN and two consecutive elevations of AST in relation to Baseline",
                    "TBILI <= 2 times ULN and two consecutive elevations of AST in relation to Baseline",
                    "ALT > 3 times ULN by Period",
                    "AST > 3 times ULN by Period",
                    "ALT or AST > 3 times ULN by Period",
                    "ALT > 3 times Baseline by Period",
                    "AST > 3 times Baseline by Period",
                    "ALT or AST > 3 times Baseline by Period"
                  ),
                  paramcd = c(
                    "BLAL",
                    "BGAS",
                    "BGAL",
                    "BLAS",
                    "BA2AL",
                    "BA2AS",
                    "BA5AL",
                    "BA5AS",
                    "BL2AL2CU",
                    "BG2AS2CU",
                    "BL2AS2CU",
                    "BG2AL2CU",
                    "BG2AL2CB",
                    "BL2AL2CB",
                    "BG2AS2CB",
                    "BL2AS2CB",
                    "ALTPULN",
                    "ASTPULN",
                    "ALTASTPU",
                    "ALTPBASE",
                    "ASTPBASE",
                    "ALTASTPB"
                  ),
                  seed = NULL,
                  cached = FALSE) {
  checkmate::assert_flag(cached)

  if (cached) {
    return(get_cached_data("cadhy"))
  }

  checkmate::assert_data_frame(adsl)
  checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
  checkmate::assert_number(seed, null.ok = TRUE)

  # validate and initialize related variables
  param_init_list <- relvar_init(param, paramcd)

  if (!is.null(seed)) {
    set.seed(seed)
  }
  study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))

  # create all combinations of unique values in STUDYID, USUBJID, PARAM, AVISIT
  adhy <- expand.grid(
    STUDYID = unique(adsl$STUDYID),
    USUBJID = adsl$USUBJID,
    PARAM = as.factor(param_init_list$relvar1),
    AVISIT = as.factor(c("BASELINE", "POST-BASELINE")),
    APERIODC = as.factor(c("PERIOD 1", "PERIOD 2")),
    stringsAsFactors = FALSE
  )

  # remove records that are not needed and were created as a side product of expand.grid above
  adhy <- dplyr::filter(adhy, !(AVISIT == "BASELINE" & APERIODC == "PERIOD 2"))

  # define TBILI ALT/AST params, period dependent parameters and the parameters that will be assigned values "Y" or "N"
  paramcd_tbilialtast <- c("BLAL", "BGAS", "BGAL", "BLAS", "BA2AL", "BA2AS", "BA5AL", "BA5AS")
  paramcd_by_period <- c("ALTPULN", "ASTPULN", "ALTASTPU", "ALTPBASE", "ASTPBASE", "ALTASTPB")
  paramcd_yn <- c(
    "BL2AL2CU", "BG2AS2CU", "BL2AS2CU", "BG2AL2CU", "BG2AL2CB", "BL2AL2CB", "BG2AS2CB", "BL2AS2CB",
    paramcd_by_period
  )

  # add other variables to adhy
  adhy <- adhy %>%
    rel_var(
      var_name = "PARAMCD",
      related_var = "PARAM",
      var_values = param_init_list$relvar2
    ) %>%
    dplyr::mutate(
      AVALC = dplyr::case_when(
        PARAMCD %in% paramcd_tbilialtast ~ sample(
          x = c(">3-5ULN", ">5-10ULN", ">10-20ULN", ">20ULN", "Criteria not met"), size = dplyr::n(), replace = TRUE
        ),
        PARAMCD %in% paramcd_yn ~ sample(
          x = c("Y", "N"), prob = c(0.1, 0.9), size = dplyr::n(), replace = TRUE
        )
      ),
      AVAL = dplyr::case_when(
        AVALC == ">3-5ULN" ~ 1,
        AVALC == ">5-10ULN" ~ 2,
        AVALC == ">10-20ULN" ~ 3,
        AVALC == ">20ULN" ~ 4,
        AVALC == "Y" ~ 1,
        AVALC == "N" ~ 0,
        AVALC == "Criteria not met" ~ 0
      ),
      AVISITN = dplyr::case_when(
        AVISIT == "BASELINE" ~ 0L,
        AVISIT == "POST-BASELINE" ~ 9995L,
        TRUE ~ NA_integer_
      ),
      APERIOD = dplyr::case_when(
        APERIODC == "PERIOD 1" ~ 1L,
        APERIODC == "PERIOD 2" ~ 2L,
        TRUE ~ NA_integer_
      ),
      ABLFL = dplyr::if_else(AVISIT == "BASELINE", "Y", NA_character_),
      ONTRTFL = dplyr::if_else(AVISIT == "POST-BASELINE", "Y", NA_character_),
      ANL01FL = "Y",
      SRCSEQ = NA_integer_
    )

  # remove records for parameters with period 2 and not in paramcd_by_period
  adhy <- dplyr::filter(adhy, PARAMCD %in% paramcd_by_period | APERIODC == "PERIOD 1")

  # add baseline variables
  adhy <- adhy %>%
    dplyr::group_by(USUBJID, PARAMCD) %>%
    dplyr::mutate(
      BASEC = AVALC[AVISIT == "BASELINE"],
      BASE = AVAL[AVISIT == "BASELINE"]
    ) %>%
    dplyr::ungroup()

  adhy <- adhy %>%
    rcd_var_relabel(
      STUDYID = attr(adsl$STUDYID, "label"),
      USUBJID = attr(adsl$USUBJID, "label")
    )

  # merge ADSL to be able to add analysis datetime and analysis relative day variables
  adhy <- dplyr::inner_join(adhy, adsl, by = c("STUDYID", "USUBJID"))

  # define a simple helper function to create ADY variable
  add_ady <- function(x, avisit) {
    if (avisit == "BASELINE") {
      dplyr::mutate(
        x,
        ADY = sample(x = -(1:14), size = dplyr::n(), replace = TRUE)
      )
    } else if (avisit == "POST-BASELINE") {
      dplyr::rowwise(x) %>%
        dplyr::mutate(ADY = as.integer(sample(
          dplyr::if_else(
            !is.na(TRTEDTM),
            as.numeric(difftime(TRTEDTM, TRTSDTM, units = "days")),
            as.numeric(study_duration_secs, "days")
          ),
          size = 1,
          replace = TRUE
        )))
    } else {
      dplyr::mutate(x, ADY = NA_integer_)
    }
  }

  # add ADY and ADTM variables
  adhy <- adhy %>%
    dplyr::group_by(AVISIT, .add = FALSE) %>%
    dplyr::group_modify(~ add_ady(.x, .y$AVISIT)) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(ADTM = TRTSDTM + lubridate::days(ADY))

  # order columns and arrange rows; column order follows ADaM_1.1 specification
  adhy <-
    adhy[, c(
      colnames(adsl),
      "PARAM",
      "PARAMCD",
      "AVAL",
      "AVALC",
      "BASE",
      "BASEC",
      "ABLFL",
      "ADTM",
      "ADY",
      "AVISIT",
      "AVISITN",
      "APERIOD",
      "APERIODC",
      "ONTRTFL",
      "SRCSEQ",
      "ANL01FL"
    )]

  adhy <- adhy %>%
    dplyr::arrange(
      STUDYID,
      USUBJID,
      PARAMCD,
      AVISITN,
      ADTM,
      SRCSEQ
    )

  # apply metadata
  adhy <- apply_metadata(adhy, "metadata/ADHY.yml")

  return(adhy)
}

#' EORTC QLQ-C30 V3 Analysis Dataset (ADQLQC)
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Function for generating a random EORTC QLQ-C30 V3 Analysis Dataset for a given
#' Subject-Level Analysis Dataset.
#'
#' @details
#'
#' Keys: `STUDYID`, `USUBJID`, `PARCAT1N`, `PARAMCD`, `BASETYPE`, `AVISITN`, `ATPTN`, `ADTM`, `QSSEQ`
#'
#' @inheritParams argument_convention
#' @param percent (`numeric`)\cr Completion - Completed at least y percent of questions, 1 record per visit
#' @param number (`numeric`)\cr Completion - Completed at least x question(s), 1 record per visit
#' @template param_cached
#' @templateVar data adqlqc
#'
#' @return `data.frame`
#' @export
#'
#' @examples
#' adsl <- radsl(N = 10, study_duration = 2, seed = 1)
#'
#' adqlqc <- radqlqc(adsl, seed = 1, percent = 80, number = 2)
#' adqlqc
radqlqc <- function(adsl,
                    percent,
                    number,
                    seed = NULL,
                    cached = FALSE) {
  checkmate::assert_flag(cached)
  if (cached) {
    return(get_cached_data("cadqlqc"))
  }

  checkmate::assert_data_frame(adsl)
  checkmate::assert_number(percent, lower = 1, upper = 100)
  checkmate::assert_number(number, lower = 1)

  if (!is.null(seed)) {
    set.seed(seed)
  }

  # ADQLQC data -------------------------------------------------------------
  qs <- get_qs_data(adsl, n_assessments = 5L, seed = seed, na_percentage = 0.1)
  # prepare ADaM ADQLQC data
  adqlqc1 <- prep_adqlqc(df = qs)
  # derive AVAL and AVALC
  adqlqc1 <- mutate(
    adqlqc1,
    AVAL = as.numeric(QSSTRESC),
    AVALC = case_when(
      QSTESTCD == "QSALL" ~ QSREASND,
      TRUE ~ QSORRES
    ),
    AVISIT = VISIT,
    AVISITN = VISITNUM,
    ADTM = QSDTC
  )
  # include scale calculation
  adqlqc_tmp <- calc_scales(adqlqc1)
  # order to prepare for change from screening and baseline values
  adqlqc_tmp <- adqlqc_tmp[order(adqlqc_tmp$STUDYID, adqlqc_tmp$USUBJID, adqlqc_tmp$PARAMCD, adqlqc_tmp$AVISITN), ]

  adqlqc_tmp <- Reduce(
    rbind,
    lapply(
      split(adqlqc_tmp, adqlqc_tmp$USUBJID),
      function(x) {
        x$STUDYID <- adsl$STUDYID[which(adsl$USUBJID == x$USUBJID[1])]
        x$ABLFL2 <- ifelse(x$AVISIT == "SCREENING", "Y", "")
        x$ABLFL <- ifelse(
          x$AVISIT == "BASELINE" &
            x$PARAMCD != "EX028",
          "Y",
          ifelse(
            x$AVISIT == "CYCLE 1 DAY 1" &
              x$PARAMCD != "EX028",
            "Y",
            ""
          )
        )
        x
      }
    )
  )

  adqlqc_tmp$BASE2 <- ifelse(
    str_detect(adqlqc_tmp$PARCAT2, "Completion", negate = TRUE),
    retain(
      df = adqlqc_tmp,
      value_var = adqlqc_tmp$AVAL,
      event = adqlqc_tmp$ABLFL2 == "Y"
    ),
    NA
  )

  adqlqc_tmp$BASE <- ifelse(
    adqlqc_tmp$ABLFL2 != "Y" &
      str_detect(adqlqc_tmp$PARCAT2, "Completion", negate = TRUE),
    retain(
      adqlqc_tmp,
      adqlqc_tmp$AVAL,
      adqlqc_tmp$ABLFL == "Y"
    ),
    NA
  )

  adqlqc_tmp <- adqlqc_tmp %>%
    dplyr::mutate(CHG2 = AVAL - BASE2) %>%
    dplyr::mutate(PCHG2 = 100 * (CHG2 / BASE2)) %>%
    dplyr::mutate(CHG = AVAL - BASE) %>%
    dplyr::mutate(PCHG = 100 * (CHG / BASE)) %>%
    rcd_var_relabel(
      STUDYID = attr(adsl$STUDYID, "label"),
      USUBJID = attr(adsl$USUBJID, "label")
    )
  # derive CHGCAT1 ----------------------------------------------------------
  adqlqc_tmp <- derv_chgcat1(dataset = adqlqc_tmp)

  adqlqc_tmp <- rcd_var_relabel(
    adqlqc_tmp,
    STUDYID = "Study Identifier",
    USUBJID = "Unique Subject Identifier"
  )

  adqlqc_tmp <- arrange(
    adqlqc_tmp,
    USUBJID,
    AVISITN
  )
  # Merge ADSL --------------------------------------------------------------
  # ADSL variables needed for ADQLQC
  adsl_vars <- c(
    "STUDYID", "USUBJID", "SUBJID", "SITEID", "REGION1", "COUNTRY", "ETHNIC", "AGE",
    "AGEU", "AAGE", "AAGEU", "AGEGR1", "AGEGR2", "AGEGR3", "STRATwNM", "STRATw", "STRATwV",
    "SEX", "RACE", "ITTFL", "SAFFL", "PPROTFL", "TRT01P", "TRT01A",
    "TRTSEQP", "TRTSEQA", "TRTSDTM", "TRTSDT", "TRTEDTM", "TRTEDT", "DCUTDT"
  )
  adsl <- select(
    adsl,
    any_of(adsl_vars)
  )
  adqlqc <- dplyr::inner_join(
    adqlqc_tmp,
    adsl,
    by = c("STUDYID", "USUBJID")
  ) %>%
    dplyr::mutate(
      ADY_der = ceiling(difftime(ADTM, TRTSDTM, units = "days")),
      ADY = case_when(
        ADY_der >= 0 ~ ADY_der + 1,
        TRUE ~ ADY_der
      )
    ) %>%
    select(-ADY_der)

  # get compliance data ---------------------------------------------------
  compliance_data <- comp_derv(
    dataset = adqlqc,
    percent = percent,
    number = number
  )
  # add ADSL variables
  compliance_data <- left_join(
    compliance_data,
    adsl,
    by = c("STUDYID", "USUBJID")
  )
  # add completion to ADQLQC
  adqlqc <- bind_rows(
    adqlqc,
    compliance_data
  ) %>%
    arrange(
      USUBJID,
      AVISITN,
      QSTESTCD
    )
  # find first set of questionnaire observations
  adqlqc_x <- arrange(
    adqlqc,
    USUBJID,
    ADTM
  ) %>%
    filter(
      PARAMCD != "QSALL" &
        !str_detect(AVISIT, "SCREENING|UNSCHEDULED")
    ) %>%
    group_by(
      USUBJID,
      ADTM
    ) %>%
    summarise(first_date = first(ADTM), .groups = "drop")

  adqlqc <- left_join(
    adqlqc,
    adqlqc_x,
    by = c("USUBJID", "ADTM")
  ) %>%
    mutate(
      ANL01FL = case_when(
        PARAMCD != "QSALL" & ABLFL == "Y" ~ "Y",
        PARAMCD != "QSALL" &
          !str_detect(AVISIT, "UNSCHEDULED") &
          !is.na(first_date) ~ "Y"
      )
    ) %>%
    select(-first_date)

  # final dataset -----------------------------------------------------------
  adqlqc_final <- adqlqc %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::mutate(ASEQ = row_number()) %>%
    dplyr::ungroup() %>%
    dplyr::arrange(
      STUDYID,
      USUBJID,
      AVISITN
    ) %>%
    select(
      -c("BASE2", "CHG2", "PCHG2", "ABLFL2")
    ) %>%
    ungroup()

  adam_vars <- c(
    adsl_vars, "QSSEQ", "QSCAT", "QSSCAT", "QSDTC", "QSSPID", "QSSTAT", "QSSTRESN",
    "QSSTRESC", "QSSTRESU", "QSORRES", "QSORRESU", "QSTEST", "QSTESTCD", "QSTPT",
    "QSTPTNUM", "QSTPTREF", "QSDY", "QSREASND", "QSTSTDTL", "QSEVAL", "VISIT", "VISITNUM",
    "PARAM", "PARAMCD", "PARCAT1", "PARCAT1N", "PARCAT2", "AVAL", "AVALC", "AREASND",
    "BASE", "BASETYPE", "ABLFL", "CHG", "PCHG", "CHGCAT1", "CRIT1", "CRIT1FL", "DTYPE",
    "ADTM", "ADT", "ADY", "ADTF", "ATMF", "ATPT", "ATPTN", "AVISIT", "AVISITN", "APHASE",
    "APHASEN", "APERIOD", "APERIODC", "APERIODC", "ASPER", "ASPERC", "PERADY", "TRTP",
    "TRTA", "ONTRTFL", "LAST02FL", "FIRS02FL", "ANL01FL", "ANL02FL", "ANL03FL",
    "ANL04FL", "CGCAT1NX"
  )
  # order variables in mapped qs by variables in adam_vars
  adqlqc_name_ordered <- names(adqlqc_final)[order(match(names(adqlqc_final), adam_vars))]
  # adqlqc with variables ordered per gdsr
  adqlqc_final <- adqlqc_final %>%
    select(
      any_of(adqlqc_name_ordered)
    )

  adqlqc_final <- relocate(adqlqc_final, "QSEVLINT", .after = "QSTESTCD") %>%
    arrange(
      USUBJID,
      AVISITN,
      ASEQ,
      QSTESTCD
    )
  # apply metadata
  adqlqc_final <- apply_metadata(adqlqc_final, "metadata/ADQLQC.yml")
  return(adqlqc_final)
}

#' Helper Functions for Constructing ADQLQC
#'
#' Internal functions used by `radqlqc`.
#'
#' @inheritParams argument_convention
#' @inheritParams radqlqc
#'
#' @examples
#' adsl <- radsl(N = 10, study_duration = 2, seed = 1)
#' adqlqc <- radqlqc(adsl, seed = 1, percent = 80, number = 2)
#'
#' @name h_adqlqc
NULL

#' @describeIn h_adqlqc Questionnaires EORTC QLQ-C30 V3.0 SDTM (QS)
#'
#' Function for generating random Questionnaires SDTM domain
#'
#' @return a dataframe with SDTM questionnaire data
#' @keywords internal
get_qs_data <- function(adsl,
                        visit_format = "CYCLE",
                        n_assessments = 5L,
                        n_days = 1L,
                        lookup = NULL,
                        seed = NULL,
                        na_percentage = 0,
                        na_vars = list(
                          QSORRES = c(1234, 0.2),
                          QSSTRESC = c(1234, 0.2)
                        )) {
  load(system.file("sysdata.rda", package = "random.cdisc.data"))
  checkmate::assert_string(visit_format)
  checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
  checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
  checkmate::assert_number(seed, null.ok = TRUE)
  checkmate::assert_number(na_percentage, lower = 0, upper = 1, na.ok = TRUE)
  checkmate::assert_number(na_percentage, lower = 0, upper = 1)
  checkmate::assert_true(na_percentage < 1)

  # get subjects for QS data from ADSL
  # get studyid, subject for QS generation
  qs <- select(
    adsl,
    STUDYID,
    USUBJID
  ) %>%
    mutate(
      DOMAIN = "QS"
    )

  # QS prep -----------------------------------------------------------------
  # get questionnaire function for QS
  # QSTESTCD: EOR0101 to EOR0130
  eortc_qlq_c30_sub <- filter(
    eortc_qlq_c30,
    as.numeric(str_extract(QSTESTCD, "\\d+$")) >= 101 &
      as.numeric(str_extract(QSTESTCD, "\\d+$")) <= 130
  ) %>%
    select(-publication_name)

  # validate and initialize QSTEST vectors
  qstest_init_list <- relvar_init(
    unique(eortc_qlq_c30_sub$QSTEST),
    unique(eortc_qlq_c30_sub$QSTESTCD)
  )

  if (!is.null(seed)) {
    set.seed(seed)
  }

  checkmate::assert_data_frame(lookup, null.ok = TRUE)

  lookup_qs <- if (!is.null(lookup)) {
    lookup
  } else {
    expand.grid(
      STUDYID = unique(qs$STUDYID),
      USUBJID = qs$USUBJID,
      QSTEST = qstest_init_list$relvar1,
      VISIT = visit_schedule(
        visit_format = visit_format,
        n_assessments = n_assessments,
        n_days = n_days
      ),
      stringsAsFactors = FALSE
    )
  }

  # assign related variable values: QSTESTxQSTESTCD are related
  lookup_qs <- lookup_qs %>% rel_var(
    var_name = "QSTESTCD",
    related_var = "QSTEST",
    var_values = qstest_init_list$relvar2
  )

  lookup_qs <- left_join(
    lookup_qs,
    eortc_qlq_c30_sub,
    by = c(
      "QSTEST",
      "QSTESTCD"
    ),
    multiple = "all",
    relationship = "many-to-many"
  )

  lookup_qs <- dplyr::mutate(
    lookup_qs,
    VISITNUM = dplyr::case_when(
      VISIT == "SCREENING" ~ -1,
      VISIT == "BASELINE" ~ 0,
      (grepl("^WEEK", VISIT) | grepl("^CYCLE", VISIT)) ~ as.numeric(VISIT) - 2,
      TRUE ~ NA_real_
    )
  ) %>% arrange(USUBJID)

  # # prep QSALL --------------------------------------------------------------
  # get last subject and visit for QSALL
  last_subj_vis <- select(lookup_qs, USUBJID, VISIT) %>%
    distinct() %>%
    slice(n())
  last_subj_vis_full <- filter(
    lookup_qs,
    USUBJID == last_subj_vis$USUBJID,
    VISIT == last_subj_vis$VISIT
  )

  qsall_data1 <- tibble::tibble(
    STUDYID = unique(last_subj_vis_full$STUDYID),
    USUBJID = unique(last_subj_vis_full$USUBJID),
    VISIT = unique(last_subj_vis_full$VISIT),
    VISITNUM = unique(last_subj_vis_full$VISITNUM),
    QSTESTCD = "QSALL",
    QSTEST = "Questionnaires",
    QSSTAT = "NOT DONE",
    QSREASND = "SUBJECT REFUSED"
  )

  # remove last subject and visit from main data
  lookup_qs_sub <- anti_join(
    lookup_qs,
    last_subj_vis_full,
    by = c("USUBJID", "VISIT")
  )

  set.seed(seed)
  lookup_qs_sub_x <- lookup_qs_sub %>%
    group_by(
      USUBJID,
      QSTESTCD,
      VISIT
    ) %>%
    slice_sample(n = 1) %>%
    ungroup() %>%
    as.data.frame()

  lookup_qs_sub_x <- arrange(
    lookup_qs_sub_x,
    USUBJID,
    VISITNUM
  )

  # add date: QSDTC ---------------------------------------------------------
  # get treatment dates from ADSL
  adsl_trt <- select(
    adsl,
    USUBJID,
    TRTSDTM,
    TRTEDTM
  )
  # use to derive QSDTC
  # if no treatment end date, create an arbituary one
  trt_end_date <- max(adsl_trt$TRTEDTM, na.rm = TRUE)

  lookup_qs_sub_x <- left_join(
    lookup_qs_sub_x,
    adsl_trt,
    by = "USUBJID"
  ) %>%
    group_by(
      USUBJID
    ) %>%
    mutate(QSDTC = get_random_dates_between(
      from = TRTSDTM,
      to = ifelse(
        is.na(TRTEDTM),
        trt_end_date,
        TRTEDTM
      ),
      visit_id = VISITNUM
    )) %>%
    select(-c("TRTSDTM", "TRTEDTM"))

  # filter out subjects with missing dates
  lookup_qs_sub_x1 <- filter(
    lookup_qs_sub_x,
    !is.na(QSDTC)
  )

  # subjects with missing dates
  lookup_qs_sub_x2 <- filter(
    lookup_qs_sub_x,
    is.na(QSDTC)
  ) %>%
    select(
      STUDYID,
      USUBJID,
      VISIT,
      VISITNUM
    ) %>%
    distinct()

  # generate QSALL for subjects with missing dates
  qsall_data2 <- mutate(
    lookup_qs_sub_x2,
    QSTESTCD = "QSALL",
    QSTEST = "Questionnaires",
    QSSTAT = "NOT DONE",
    QSREASND = "SUBJECT REFUSED"
  )

  # add qsall data to original item data
  lookup_qs_sub_all <- bind_rows(
    lookup_qs_sub_x1,
    qsall_data1,
    qsall_data2
  )

  qs_all <- lookup_qs_sub_all %>%
    arrange(
      STUDYID,
      USUBJID,
      VISITNUM
    ) %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::ungroup()

  # get first and second subject ids
  first_second_subj <- select(qs_all, USUBJID) %>%
    distinct() %>%
    slice(1:2)

  qs1 <- filter(
    qs_all,
    USUBJID %in% first_second_subj$USUBJID
  )

  if (length(na_vars) > 0 && na_percentage > 0) {
    qs1 <- mutate_na(ds = qs1, na_vars = na_vars, na_percentage = na_percentage)
  }

  # QSSTAT = NOT DONE
  qs1 <- mutate(
    qs1,
    QSSTAT = case_when(
      is.na(QSORRES) & is.na(QSSTRESC) ~ "NOT DONE"
    )
  )

  # remove first and second subjects from main data
  qs2 <- anti_join(
    qs_all,
    qs1,
    by = c("USUBJID")
  )

  final_qs <- rbind(
    qs1,
    qs2
  ) %>%
    group_by(USUBJID) %>%
    dplyr::mutate(QSSEQ = row_number()) %>%
    arrange(
      STUDYID,
      USUBJID,
      VISITNUM
    ) %>%
    ungroup()

  # ordered variables as per gdsr
  final_qs <- select(
    final_qs,
    STUDYID,
    USUBJID,
    QSSEQ,
    QSTESTCD,
    QSTEST,
    QSCAT,
    QSSCAT,
    QSORRES,
    QSORRESU,
    QSSTRESC,
    QSSTRESU,
    QSSTAT,
    QSREASND,
    VISITNUM,
    VISIT,
    QSDTC,
    QSEVLINT
  )
  return(final_qs)
}

#' @describeIn h_adqlqc Function for generating random dates between 2 dates
#'
#' @param from (`datetime vector`)\cr Start date/times.
#' @param to (`datetime vector`)\cr End date/times.
#' @param visit_id (`vector`)\cr Visit identifiers.
#'
#' @return Data frame with new randomly generated dates variable.
#' @keywords internal
get_random_dates_between <- function(from, to, visit_id) {
  min_date <- min(lubridate::as_datetime(from), na.rm = TRUE)
  max_date <- max(lubridate::as_datetime(to), na.rm = TRUE)
  date_seq <- seq(from = min_date + lubridate::days(1), to = max_date, by = "28 days")

  visit_ids <- unique(visit_id)
  out <- sapply(visit_ids, simplify = TRUE, USE.NAMES = TRUE, FUN = function(x) {
    if (x == -1) {
      random_days_to_subtract <- lubridate::days(sample(1:10, size = 1))
      min_date - random_days_to_subtract
    } else if (x == 0) {
      min_date
    } else if (x > 0) {
      if (x %in% seq_along(date_seq)) {
        date_seq[[x]]
      } else {
        NA
      }
    }
  })
  lubridate::as_datetime(out[match(visit_id, visit_ids)])
}

#' @describeIn h_adqlqc Prepare ADaM ADQLQC data, adding PARAMCD to SDTM QS data
#'
#' @param df (`data.frame`)\cr SDTM QS dataset.
#'
#' @return `data.frame`
#' @keywords internal
prep_adqlqc <- function(df) {
  # create PARAMCD from QSTESTCD
  adqlqc <- dplyr::mutate(
    df,
    PARAMCD = case_when(
      QSTESTCD == "EOR0101" ~ "QS02801",
      QSTESTCD == "EOR0102" ~ "QS02802",
      QSTESTCD == "EOR0103" ~ "QS02803",
      QSTESTCD == "EOR0104" ~ "QS02804",
      QSTESTCD == "EOR0105" ~ "QS02805",
      QSTESTCD == "EOR0106" ~ "QS02806",
      QSTESTCD == "EOR0107" ~ "QS02807",
      QSTESTCD == "EOR0108" ~ "QS02808",
      QSTESTCD == "EOR0109" ~ "QS02809",
      QSTESTCD == "EOR0110" ~ "QS02810",
      QSTESTCD == "EOR0111" ~ "QS02811",
      QSTESTCD == "EOR0112" ~ "QS02812",
      QSTESTCD == "EOR0113" ~ "QS02813",
      QSTESTCD == "EOR0114" ~ "QS02814",
      QSTESTCD == "EOR0115" ~ "QS02815",
      QSTESTCD == "EOR0116" ~ "QS02816",
      QSTESTCD == "EOR0117" ~ "QS02817",
      QSTESTCD == "EOR0118" ~ "QS02818",
      QSTESTCD == "EOR0119" ~ "QS02819",
      QSTESTCD == "EOR0120" ~ "QS02820",
      QSTESTCD == "EOR0121" ~ "QS02821",
      QSTESTCD == "EOR0122" ~ "QS02822",
      QSTESTCD == "EOR0123" ~ "QS02823",
      QSTESTCD == "EOR0124" ~ "QS02824",
      QSTESTCD == "EOR0125" ~ "QS02825",
      QSTESTCD == "EOR0126" ~ "QS02826",
      QSTESTCD == "EOR0127" ~ "QS02827",
      QSTESTCD == "EOR0128" ~ "QS02828",
      QSTESTCD == "EOR0129" ~ "QS02829",
      QSTESTCD == "EOR0130" ~ "QS02830",
      TRUE ~ QSTESTCD
    )
  )
  load(system.file("sysdata.rda", package = "random.cdisc.data"))
  adqlqc1 <- dplyr::left_join(
    adqlqc,
    gdsr_param_adqlqc,
    by = "PARAMCD"
  )
  return(adqlqc1)
}

#' @describeIn h_adqlqc Scale calculation for ADQLQC data
#'
#' @param adqlqc1 (`data.frame`)\cr Prepared data generated from the [prep_adqlqc()] function.
#'
#' @return `data.frame`
#' @keywords internal
calc_scales <- function(adqlqc1) {
  # Prep scale data ---------------------------------------------------------
  # parcat2 = scales or global health status
  # global health status/scales data
  # QSTESTCD: EOR0131 to EOR0145 (global health status and scales)
  load(system.file("sysdata.rda", package = "random.cdisc.data"))
  eortc_qlq_c30_sub <- filter(
    eortc_qlq_c30,
    !(as.numeric(str_extract(QSTESTCD, "\\d+$")) >= 101 & as.numeric(str_extract(QSTESTCD, "\\d+$")) <= 130)
  ) %>%
    mutate(
      PARAMCD = case_when(
        QSTESTCD == "EOR0131" ~ "QS028QL2",
        QSTESTCD == "EOR0132" ~ "QS028PF2",
        QSTESTCD == "EOR0133" ~ "QS028RF2",
        QSTESTCD == "EOR0134" ~ "QS028EF",
        QSTESTCD == "EOR0135" ~ "QS028CF",
        QSTESTCD == "EOR0136" ~ "QS028SF",
        QSTESTCD == "EOR0137" ~ "QS028FA",
        QSTESTCD == "EOR0138" ~ "QS028NV",
        QSTESTCD == "EOR0139" ~ "QS028PA",
        QSTESTCD == "EOR0140" ~ "QS028DY",
        QSTESTCD == "EOR0141" ~ "QS028SL",
        QSTESTCD == "EOR0142" ~ "QS028AP",
        QSTESTCD == "EOR0143" ~ "QS028CO",
        QSTESTCD == "EOR0144" ~ "QS028DI",
        QSTESTCD == "EOR0145" ~ "QS028FI",
        TRUE ~ QSTESTCD
      )
    ) %>%
    select(-publication_name)

  # ADaM global health status and scales from gdsr
  gdsr_param_adqlqc <- gdsr_param_adqlqc %>%
    filter(
      !str_detect(PARCAT2, "Original Items|Completion")
    )

  ghs_scales <- left_join(
    eortc_qlq_c30_sub,
    gdsr_param_adqlqc,
    by = "PARAMCD"
  )
  # scale data
  df <- data.frame(index = seq_len(nrow(ghs_scales)))
  df$previous <- list(
    c("QS02826", "QS02827"),
    c("QS02811"),
    c("QS02810", "QS02812", "QS02818"),
    c("QS02806", "QS02807"),
    c("QS02814", "QS02815"),
    c("QS02808"),
    c("QS02817"),
    c("QS02816"),
    c("QS02821", "QS02822", "QS02823", "QS02824"),
    c("QS02829", "QS02830"),
    c("QS02813"),
    c("QS02801", "QS02802", "QS02803", "QS02804", "QS02805"),
    c("QS02809", "QS02819"),
    c("QS02820", "QS02825"),
    c("QS02828")
  )
  df$newName <- list(
    "QS028SF",
    "QS028SL",
    "QS028FA",
    "QS028RF2",
    "QS028NV",
    "QS028DY",
    "QS028DI",
    "QS028CO",
    "QS028EF",
    "QS028QL2",
    "QS028AP",
    "QS028PF2",
    "QS028PA",
    "QS028CF",
    "QS028FI"
  )
  df$newNamelabel <- list(
    "EORTC QLQ-C30: Social functioning",
    "EORTC QLQ-C30: Insomnia",
    "EORTC QLQ-C30: Fatigue",
    "EORTC QLQ-C30: Role functioning (revised)",
    "EORTC QLQ-C30: Nausea and vomiting",
    "EORTC QLQ-C30: Dyspnoea",
    "EORTC QLQ-C30: Diarrhoea",
    "EORTC QLQ-C30: Constipation",
    "EORTC QLQ-C30: Emotional functioning",
    "EORTC QLQ-C30: Global health status/QoL (revised)",
    "EORTC QLQ-C30: Appetite loss",
    "EORTC QLQ-C30: Physical functioning (revised)",
    "EORTC QLQ-C30: Pain",
    "EORTC QLQ-C30: Cognitive functioning",
    "EORTC QLQ-C30: Financial difficulties"
  )
  df$newNameCategory <- list(
    "Functional Scales",
    "Symptom Scales",
    "Symptom Scales",
    "Functional Scales",
    "Symptom Scales",
    "Symptom Scales",
    "Symptom Scales",
    "Symptom Scales",
    "Functional Scales",
    "Global Health Status",
    "Symptom Scales",
    "Functional Scales",
    "Symptom Scales",
    "Functional Scales",
    "Symptom Scales"
  )
  df$num_param <- list(
    "1",
    "1",
    "2",
    "1",
    "1",
    "1",
    "1",
    "1",
    "2",
    "1",
    "1",
    "3",
    "1",
    "1",
    "1"
  )
  df$equation <- list(
    "new_value = (1 - ((temp_val/var_length)-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = (1 - ((temp_val/var_length)-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = (1 - ((temp_val/var_length)-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/6)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = (1 - ((temp_val/var_length)-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0",
    "new_value = (1 - ((temp_val/var_length)-1)/3)*100.0",
    "new_value = ((temp_val/var_length-1)/3)*100.0"
  )

  expect_data <- data.frame(
    PARAM = expect$PARAM,
    PARAMCD = expect$PARAMCD,
    PARCAT2 = expect$PARCAT2,
    PARCAT1N = expect$PARCAT1N,
    AVAL = c(0, 1),
    AVALC = c(
      "Not expected to complete questionnaire",
      "Expected to complete questionnaire"
    )
  )

  df_saved <- data.frame()

  unique_id <- unique(adqlqc1$USUBJID)

  for (id in unique_id) {
    id_data <- adqlqc1[adqlqc1$USUBJID == id, ]
    unique_avisit <- unique(id_data$AVISIT)
    for (visit in unique_avisit) {
      if (is.na(visit)) {
        next
      }
      id_data_at_visit <- id_data[id_data$AVISIT == visit, ]

      if (any(id_data_at_visit$PARAMCD != "QSALL")) {
        for (idx in seq_along(df$index)) {
          previous_names <- df$previous[idx]
          current_name <- df$newName[idx]
          current_name_label <- df$newNamelabel[idx]
          current_name_category <- df$newNameCategory[idx]
          eqn <- df$equation[idx]
          temp_val <- 0
          var_length <- 0
          for (param_name in previous_names[[1]]) {
            if (param_name %in% id_data_at_visit$PARAMCD) { ####
              current_val <- as.numeric(as.character(id_data_at_visit$AVAL[id_data_at_visit$PARAMCD == param_name]))
              if (!is.na(current_val)) {
                temp_val <- temp_val + current_val ###
                var_length <- var_length + 1
              }
            } # if
          } # param_name
          # eval
          if (var_length >= as.numeric(df$num_param[idx])) {
            eval(parse(text = eqn)) #####
          } else {
            new_value <- NA
          }

          new_data_row <- data.frame(
            study = str_extract(id, "[A-Z]+[0-9]+"),
            id,
            visit,
            id_data_at_visit$AVISITN[1],
            id_data_at_visit$QSDTC[1],
            current_name_category,
            current_name_label,
            current_name,
            new_value,
            NA,
            stringsAsFactors = FALSE
          )
          colnames(new_data_row) <- c(
            "STUDYID", "USUBJID", "AVISIT", "AVISITN",
            "ADTM", "PARCAT2", "PARAM", "PARAMCD",
            "AVAL", "AVALC"
          ) ###
          df_saved <- rbind(df_saved, new_data_row) #####
        } # idx
      }
      # add expect data
      expect_value <- sample(expect_data$AVAL, 1, prob = c(0.10, 0.90))
      expect_valuec <- expect_data$AVALC[expect_data$AVAL == expect_value]

      new_data_row <- data.frame(
        study = str_extract(id, "[A-Z]+[0-9]+"),
        id,
        visit,
        id_data_at_visit$AVISITN[1],
        datetime = NA,
        expect_data$PARCAT2[1],
        expect_data$PARAM[1],
        expect_data$PARAMCD[1],
        expect_value,
        expect_valuec,
        stringsAsFactors = FALSE
      )
      colnames(new_data_row) <- c(
        "STUDYID", "USUBJID", "AVISIT", "AVISITN",
        "ADTM", "PARCAT2", "PARAM", "PARAMCD", "AVAL",
        "AVALC"
      ) ###
      df_saved <- rbind(df_saved, new_data_row)
    } # visit
  } # id

  df_saved1 <- left_join(
    df_saved,
    ghs_scales,
    by = c(
      "PARAM",
      "PARAMCD",
      "PARCAT2"
    )
  ) %>%
    mutate(
      AVALC = ifelse(is.na(AVALC), as.character(AVAL), AVALC),
      PARCAT1 = ifelse(PARAMCD == "EX028", expect$PARCAT1, PARCAT1),
      PARCAT1N = ifelse(PARAMCD == "EX028", expect$PARCAT1N, PARCAT1N)
    )

  adqlqc_tmp <- bind_rows(adqlqc1, df_saved1) %>%
    arrange(
      USUBJID,
      AVISITN,
      QSTESTCD
    )
  return(adqlqc_tmp)
}

#' @describeIn h_adqlqc Calculate Change from Baseline Category 1
#'
#' @param dataset (`data.frame`)\cr ADaM dataset.
#'
#' @return `data.frame`
#' @keywords internal
derv_chgcat1 <- function(dataset) {
  # derivation of CHGCAT1
  check_vars <- c("PARCAT2", "CHG")

  if (all(check_vars %in% names(dataset))) {
    dataset$CHGCAT1 <- ifelse(
      dataset$PARCAT2 == "Symptom Scales" & !is.na(dataset$CHG) & dataset$CHG <= -10,
      "Improved", ""
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARCAT2 == "Symptom Scales" & !is.na(dataset$CHG) & dataset$CHG >= 10,
      "Worsened", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARCAT2 == "Symptom Scales" &
        !is.na(dataset$CHG) & dataset$CHG > -10 &
        dataset$CHG < 10,
      "No change", dataset$CHGCAT1
    )

    dataset$CHGCAT1 <- ifelse(
      dataset$PARCAT2 %in% c("Functional Scales", "Global Health Status") &
        !is.na(dataset$CHG) & dataset$CHG >= 10,
      "Improved", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARCAT2 %in% c("Functional Scales", "Global Health Status") &
        !is.na(dataset$CHG) & dataset$CHG <= -10,
      "Worsened", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARCAT2 %in% c("Functional Scales", "Global Health Status") &
        !is.na(dataset$CHG) &
        dataset$CHG > -10 & dataset$CHG < 10,
      "No change", dataset$CHGCAT1
    )

    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == 6,
      "Improved by six levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == 5,
      "Improved by five levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == 4,
      "Improved by four levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == 3,
      "Improved by three levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == 2,
      "Improved by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == 1,
      "Improved by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == 0,
      "No change", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == -1,
      "Worsened by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == -2,
      "Worsened by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == -3,
      "Worsened by three levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == -4,
      "Worsened by four levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == -5,
      "Worsened by five levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02829", "QS02830") & dataset$CHG == -6,
      "Worsened by six levels", dataset$CHGCAT1
    )

    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02802", "QS02806") & dataset$CHG == -3,
      "Improved by three levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02802", "QS02806") & dataset$CHG == -2,
      "Improved by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02802", "QS02806") & dataset$CHG == -1,
      "Improved by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02802", "QS02806") & dataset$CHG == 0,
      "No change", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02802", "QS02806") & dataset$CHG == 1,
      "Worsened by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02802", "QS02806") & dataset$CHG == 2,
      "Worsened by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% c("QS02802", "QS02806") & dataset$CHG == 3,
      "Worsened by three levels", dataset$CHGCAT1
    )

    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD == "QS02801" & dataset$CHG == -3,
      "Improved by three levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD == "QS02801" & dataset$CHG == -2,
      "Improved by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD == "QS02801" & dataset$CHG == -1,
      "Improved by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD == "QS02801" & dataset$CHG == 0,
      "No changed", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD == "QS02801" & dataset$CHG == 1,
      "Worsened by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD == "QS02801" & dataset$CHG == 2,
      "Worsened by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD == "QS02801" & dataset$CHG == 3,
      "Worsened by three levels", dataset$CHGCAT1
    )

    paramcd_vec <- c(
      "QS02803", "QS02804", "QS02805", "QS02807", "QS02808", "QS02809", "QS02810",
      "QS02811", "QS02812", "QS02813", "QS02814", "QS02815", "QS02816", "QS02817",
      "QS02818", "QS02819", "QS02820", "QS02821", "QS02822", "QS02823", "QS02824",
      "QS02825", "QS02826", "QS02827", "QS02828"
    )

    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% paramcd_vec & dataset$CHG == -3,
      "Improved by three levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% paramcd_vec & dataset$CHG == -2,
      "Improved by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% paramcd_vec & dataset$CHG == -1,
      "Improved by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% paramcd_vec & dataset$CHG == 0,
      "No change", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% paramcd_vec & dataset$CHG == 1,
      "Worsened by one level", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% paramcd_vec & dataset$CHG == 2,
      "Worsened by two levels", dataset$CHGCAT1
    )
    dataset$CHGCAT1 <- ifelse(
      dataset$PARAMCD %in% paramcd_vec & dataset$CHG == 3,
      "Worsened by three levels", dataset$CHGCAT1
    )

    return(dataset)
  } else {
    collapse_vars <- paste(check_vars, collapse = ", ")
    stop(sprintf(
      "%s: one or both variables is/are missing, needed for derivation",
      collapse_vars
    ))
  }
}

#' @describeIn h_adqlqc Completion/Compliance Data Calculation
#'
#' @param dataset (`data.frame`)\cr Dataset.
#'
#' @return `data.frame`
#' @keywords internal
comp_derv <- function(dataset, percent, number) {
  # original items data
  orig_data <- filter(
    dataset,
    PARCAT2 == "Original Items"
  )
  # total number of questionnaires
  comp_count_all <- select(
    orig_data,
    PARAMCD
  ) %>%
    distinct() %>%
    count()
  comp_count_all <- comp_count_all$n
  # original items data count of questions answered
  orig_data_summ <- group_by(
    orig_data,
    STUDYID,
    USUBJID,
    PARCAT1,
    AVISIT,
    AVISITN,
    ADTM,
    ADY
  ) %>%
    summarise(
      comp_count = sum(!is.na(AVAL)),
      comp_count_all = comp_count_all,
      .groups = "drop"
    ) %>%
    mutate(
      per_comp = trunc((comp_count / comp_count_all) * 100)
    )
  # expected data
  ex028_data <- filter(
    dataset,
    PARAMCD == "EX028",
    AVAL == 1
  ) %>%
    select(
      STUDYID,
      USUBJID,
      PARCAT1,
      AVISIT,
      AVISITN,
      ADTM,
      ADY,
      AVAL_ex028 = AVAL
    ) %>%
    mutate(
      comp_count_all = comp_count_all
    )

  joined <- left_join(
    ex028_data,
    orig_data_summ,
    by = c(
      "STUDYID",
      "USUBJID",
      "PARCAT1",
      "AVISIT",
      "AVISITN",
      "comp_count_all"
    )
  ) %>%
    select(-c("ADTM.x", "ADY.x"))

  joined <- rename(
    joined,
    ADTM = ADTM.y,
    ADY = ADY.y
  )
  # CO028ALL
  co028all <- mutate(
    joined,
    PARAMCD = "CO028ALL",
    PARAM = "EORTC QLQ-C30: Completion - Completed all questions",
    PARCAT2 = "Completion",
    AVAL = case_when(
      AVAL_ex028 == 1 & comp_count == comp_count_all ~ 1,
      AVAL_ex028 == 1 & (is.na(comp_count) | comp_count < comp_count_all) ~ 0
    ),
    AVALC = case_when(
      AVAL == 1 ~ "Completed all questions",
      AVAL == 0 ~ "Did not complete all questions"
    )
  )
  # CO028<y>P
  co028p <- mutate(
    joined,
    PARAMCD = paste0("CO028", as.character(percent), "P"),
    PARAM = sprintf(
      "EORTC QLQ-C30: Completion - Completed at least %s%% of questions",
      as.character(percent)
    ),
    PARCAT2 = "Completion",
    AVAL = case_when(
      AVAL_ex028 == 1 & per_comp >= percent ~ 1,
      AVAL_ex028 == 1 & (is.na(per_comp) | per_comp < percent) ~ 0
    ),
    AVALC = case_when(
      AVAL == 1 ~ sprintf(
        "Completed at least %s%% of questions",
        as.character(percent)
      ),
      AVAL == 0 ~ sprintf(
        "Did not complete at least %s%% of questions",
        as.character(percent)
      )
    )
  )
  # CO028<x>Q
  co028q <- mutate(
    joined,
    PARAMCD = paste0("CO028", as.character(number), "Q"),
    PARAM = sprintf(
      "EORTC QLQ-C30: Completion - Completed at least %s question(s)",
      as.character(number)
    ),
    PARCAT2 = "Completion",
    AVAL = case_when(
      AVAL_ex028 == 1 & comp_count >= number ~ 1,
      AVAL_ex028 == 1 & (comp_count < number | is.na(comp_count)) ~ 0
    ),
    AVALC = case_when(
      AVAL == 1 ~ sprintf(
        "Completed at least %s questions",
        as.character(number)
      ),
      AVAL == 0 ~ sprintf(
        "Did not complete at least %s question(s)",
        as.character(number)
      )
    )
  )

  co028_bind <- rbind(
    co028all,
    co028p,
    co028q
  ) %>%
    select(
      -c("AVAL_ex028", "comp_count", "comp_count_all", "per_comp")
    )
  return(co028_bind)
}

#' Exposure Analysis Dataset (ADEX)
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Function for generating random Exposure Analysis Dataset for a given
#' Subject-Level Analysis Dataset.
#'
#' @details One record per each record in the corresponding SDTM domain.
#'
#' Keys: `STUDYID`, `USUBJID`, `EXSEQ`, `PARAMCD`, `PARCAT1`, `ASTDTM`, `AENDTM`, `ASTDY`, `AENDY`,
#' `AVISITN`, `EXDOSFRQ`, `EXROUTE`, `VISIT`, `VISITDY`, `EXSTDTC`, `EXENDTC`, `EXSTDY`, `EXENDY`
#'
#' @inheritParams argument_convention
#' @param parcat1 (`character vector`)\cr Dose amount categories. Defaults to "Individual" and "Overall".
#' @param parcat2 (`character vector`)\cr Types of drug received. Defaults to "Drug A" and "Drug B".
#' @param max_n_exs (`integer`)\cr Maximum number of exposures per patient. Defaults to 6.
#' @template param_cached
#' @templateVar data adex
#'
#' @return `data.frame`
#' @export
#'
#' @examples
#' adsl <- radsl(N = 10, study_duration = 2, seed = 1)
#'
#' adex <- radex(adsl, seed = 2)
#' adex
radex <- function(adsl,
                  param = c(
                    "Dose administered during constant dosing interval",
                    "Number of doses administered during constant dosing interval",
                    "Total dose administered",
                    "Total number of doses administered"
                  ),
                  paramcd = c("DOSE", "NDOSE", "TDOSE", "TNDOSE"),
                  paramu = c("mg", " ", "mg", " "),
                  parcat1 = c("INDIVIDUAL", "OVERALL"),
                  parcat2 = c("Drug A", "Drug B"),
                  visit_format = "WEEK",
                  n_assessments = 5L,
                  n_days = 5L,
                  max_n_exs = 6L,
                  lookup = NULL,
                  seed = NULL,
                  na_percentage = 0,
                  na_vars = list(AVAL = c(NA, 0.1), AVALU = c(NA), 0.1),
                  cached = FALSE) {
  checkmate::assert_flag(cached)
  if (cached) {
    return(get_cached_data("cadex"))
  }

  checkmate::assert_data_frame(adsl)
  checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(parcat1, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(parcat2, min.len = 1, any.missing = FALSE)
  checkmate::assert_string(visit_format)
  checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
  checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
  checkmate::assert_integer(max_n_exs, len = 1, any.missing = FALSE)
  checkmate::assert_data_frame(lookup, null.ok = TRUE)
  checkmate::assert_number(seed, null.ok = TRUE)
  checkmate::assert_number(na_percentage, lower = 0, upper = 1)
  checkmate::assert_true(na_percentage < 1)

  # validate and initialize related variables
  param_init_list <- relvar_init(param, paramcd)
  unit_init_list <- relvar_init(param, paramu)

  if (!is.null(seed)) {
    set.seed(seed)
  }
  study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))

  adex <- expand.grid(
    STUDYID = unique(adsl$STUDYID),
    USUBJID = adsl$USUBJID,
    PARAM = c(
      rep(
        param_init_list$relvar1[1],
        length(levels(visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days)))
      ),
      rep(
        param_init_list$relvar1[2],
        length(levels(visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days)))
      ),
      param_init_list$relvar1[3:4]
    ),
    stringsAsFactors = FALSE
  )

  # assign related variable values: PARAMxPARAMCD are related
  adex <- adex %>% rel_var(
    var_name = "PARAMCD",
    related_var = "PARAM",
    var_values = param_init_list$relvar2
  )

  # assign related variable values: AVALUxPARAM are related
  adex <- adex %>% rel_var(
    var_name = "AVALU",
    related_var = "PARAM",
    var_values = unit_init_list$relvar2
  )

  adex <- adex %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::mutate(PARCAT_ind = sample(c(1, 2), size = 1)) %>%
    dplyr::mutate(PARCAT2 = ifelse(PARCAT_ind == 1, parcat2[1], parcat2[2])) %>%
    dplyr::select(-"PARCAT_ind")

  # Add in PARCAT1
  adex <- adex %>% dplyr::mutate(PARCAT1 = dplyr::case_when(
    (PARAMCD == "TNDOSE" | PARAMCD == "TDOSE") ~ "OVERALL",
    PARAMCD == "DOSE" | PARAMCD == "NDOSE" ~ "INDIVIDUAL"
  ))

  adex_visit <- adex %>%
    dplyr::filter(PARAMCD == "DOSE" | PARAMCD == "NDOSE") %>%
    dplyr::mutate(
      AVISIT = rep(visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days), 2)
    )

  adex <- dplyr::left_join(
    adex %>%
      dplyr::group_by(
        USUBJID,
        STUDYID,
        PARAM,
        PARAMCD,
        AVALU,
        PARCAT1,
        PARCAT2
      ) %>%
      dplyr::mutate(id = dplyr::row_number()),
    adex_visit %>%
      dplyr::group_by(
        USUBJID,
        STUDYID,
        PARAM,
        PARAMCD,
        AVALU,
        PARCAT1,
        PARCAT2
      ) %>%
      dplyr::mutate(id = dplyr::row_number()),
    by = c("USUBJID", "STUDYID", "PARCAT1", "PARCAT2", "id", "PARAMCD", "PARAM", "AVALU")
  ) %>%
    dplyr::select(-"id")

  # Visit numbers
  adex <- adex %>% dplyr::mutate(AVISITN = dplyr::case_when(
    AVISIT == "SCREENING" ~ -1,
    AVISIT == "BASELINE" ~ 0,
    (grepl("^WEEK", AVISIT) | grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
    TRUE ~ 999000
  ))


  adex2 <- split(adex, adex$USUBJID) %>%
    lapply(function(pinfo) {
      pinfo %>%
        dplyr::filter(PARAMCD == "DOSE") %>%
        dplyr::group_by(USUBJID, PARCAT2, AVISIT) %>%
        dplyr::mutate(changeind = dplyr::case_when(
          AVISIT == "SCREENING" ~ 0,
          AVISIT != "SCREENING" ~ sample(c(-1, 0, 1),
            size = 1,
            prob = c(0.25, 0.5, 0.25),
            replace = TRUE
          )
        )) %>%
        dplyr::ungroup() %>%
        dplyr::group_by(USUBJID, PARCAT2) %>%
        dplyr::mutate(
          csum = cumsum(changeind),
          changeind = dplyr::case_when(
            csum <= -3 ~ sample(c(0, 1), size = 1, prob = c(0.5, 0.5)),
            csum >= 3 ~ sample(c(0, -1), size = 1, prob = c(0.5, 0.5)),
            TRUE ~ changeind
          )
        ) %>%
        dplyr::mutate(csum = cumsum(changeind)) %>%
        dplyr::ungroup() %>%
        dplyr::group_by(USUBJID, PARCAT2, AVISIT) %>%
        dplyr::mutate(AVAL = dplyr::case_when(
          csum == -2 ~ 480,
          csum == -1 ~ 720,
          csum == 0 ~ 960,
          csum == 1 ~ 1200,
          csum == 2 ~ 1440
        )) %>%
        dplyr::select(-c("csum", "changeind")) %>%
        dplyr::ungroup()
    }) %>%
    Reduce(rbind, .)

  adex_tmp <- dplyr::full_join(adex2, adex, by = names(adex))
  adex <- adex_tmp %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::mutate(AVAL = ifelse(PARAMCD == "NDOSE", 1, AVAL)) %>%
    dplyr::mutate(AVAL = ifelse(
      PARAMCD == "TNDOSE",
      sum(AVAL[PARAMCD == "NDOSE"]),
      AVAL
    )) %>%
    dplyr::ungroup() %>%
    dplyr::group_by(USUBJID, STUDYID, PARCAT2) %>%
    dplyr::mutate(AVAL = ifelse(
      PARAMCD == "TDOSE",
      sum(AVAL[PARAMCD == "DOSE"]),
      AVAL
    ))

  adex <- rcd_var_relabel(
    adex,
    STUDYID = "Study Identifier",
    USUBJID = "Unique Subject Identifier"
  )

  # merge ADSL to be able to add ADEX date and study day variables
  adex <- dplyr::inner_join(adex, adsl, by = c("STUDYID", "USUBJID")) %>%
    dplyr::rowwise() %>%
    dplyr::mutate(TRTENDT = lubridate::date(dplyr::case_when(
      is.na(TRTEDTM) ~ lubridate::floor_date(lubridate::date(TRTSDTM) + study_duration_secs, unit = "day"),
      TRUE ~ TRTEDTM
    ))) %>%
    dplyr::mutate(ASTDTM = sample(
      seq(lubridate::as_datetime(TRTSDTM), lubridate::as_datetime(TRTENDT), by = "day"),
      size = 1
    )) %>%
    # add 1 to end of range incase both values passed to sample() are the same
    dplyr::mutate(AENDTM = sample(
      seq(lubridate::as_datetime(ASTDTM), lubridate::as_datetime(TRTENDT + 1), by = "day"),
      size = 1
    )) %>%
    dplyr::select(-TRTENDT) %>%
    dplyr::ungroup() %>%
    dplyr::arrange(STUDYID, USUBJID, ASTDTM)


  adex <- adex %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::mutate(EXSEQ = seq_len(dplyr::n())) %>%
    dplyr::mutate(ASEQ = EXSEQ) %>%
    dplyr::ungroup() %>%
    dplyr::arrange(
      STUDYID,
      USUBJID,
      PARAMCD,
      ASTDTM,
      AVISITN,
      EXSEQ
    )

  # Adding EXDOSFRQ
  adex <- adex %>%
    dplyr::mutate(EXDOSFRQ = dplyr::case_when(
      PARCAT1 == "INDIVIDUAL" ~ "ONCE",
      TRUE ~ ""
    ))

  # Adding EXROUTE
  adex <- adex %>%
    dplyr::mutate(EXROUTE = dplyr::case_when(
      PARCAT1 == "INDIVIDUAL" ~ sample(c("INTRAVENOUS", "SUBCUTANEOUS"),
        nrow(adex),
        replace = TRUE,
        prob = c(0.9, 0.1)
      ),
      TRUE ~ ""
    ))

  # Fix VISIT according to AVISIT
  adex <- adex %>%
    dplyr::mutate(VISIT = AVISIT)

  # Hack for VISITDY - to fix in ADSL
  visit_levels <- str_extract(levels(adex$VISIT), pattern = "[0-9]+")
  vl_extracted <- vapply(visit_levels, function(x) as.numeric(x[2]), numeric(1))
  vl_extracted <- c(-1, 1, vl_extracted[!is.na(vl_extracted)])

  # Adding VISITDY
  adex <- adex %>%
    dplyr::mutate(VISITDY = as.numeric(as.character(factor(VISIT, labels = vl_extracted))))

  # Exposure time stamps
  adex <- adex %>%
    dplyr::mutate(
      EXSTDTC = TRTSDTM + lubridate::days(VISITDY),
      EXENDTC = EXSTDTC + lubridate::hours(1),
      EXSTDY = VISITDY,
      EXENDY = VISITDY
    )

  # Correcting last exposure to treatment
  adex <- adex %>%
    dplyr::group_by(SUBJID) %>%
    dplyr::mutate(TRTEDTM = lubridate::as_datetime(max(EXENDTC, na.rm = TRUE))) %>%
    dplyr::ungroup()

  # Fixing Date - to add into ADSL
  adex <- adex %>%
    dplyr::mutate(
      TRTSDT = lubridate::date(TRTSDTM),
      TRTEDT = lubridate::date(TRTEDTM)
    )

  # Fixing analysis time stamps
  adex <- adex %>%
    dplyr::mutate(
      ASTDY = EXSTDY,
      AENDY = EXENDY,
      ASTDTM = EXSTDTC,
      AENDTM = EXENDTC
    )

  if (length(na_vars) > 0 && na_percentage > 0) {
    adex <- mutate_na(ds = adex, na_vars = na_vars, na_percentage = na_percentage)
  }

  # apply metadata
  adex <- apply_metadata(adex, "metadata/ADEX.yml")
}

# Equivalent of stringr::str_extract_all()
str_extract <- function(string, pattern) {
  regmatches(string, gregexpr(pattern, string))
}

#' Laboratory Data Analysis Dataset (ADLB)
#'
#' @description `r lifecycle::badge("stable")`
#'
#' Function for generating a random Laboratory Data Analysis Dataset for a given
#' Subject-Level Analysis Dataset.
#'
#' @details One record per subject per parameter per analysis visit per analysis date.
#'
#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`, `BASETYPE`, `AVISITN`, `ATPTN`, `DTYPE`, `ADTM`, `LBSEQ`, `ASPID`
#
#' @inheritParams argument_convention
#' @param lbcat (`character vector`)\cr LB category values.
#' @param max_n_lbs (`integer`)\cr Maximum number of labs per patient. Defaults to 10.
#' @template param_cached
#' @templateVar data adlb
#'
#' @return `data.frame`
#' @export
#'
#' @author tomlinsj, npaszty, Xuefeng Hou
#'
#' @examples
#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
#'
#' adlb <- radlb(adsl, visit_format = "WEEK", n_assessments = 7L, seed = 2)
#' adlb
#'
#' adlb <- radlb(adsl, visit_format = "CYCLE", n_assessments = 2L, seed = 2)
#' adlb
radlb <- function(adsl,
                  lbcat = c("CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
                  param = c(
                    "Alanine Aminotransferase Measurement",
                    "C-Reactive Protein Measurement",
                    "Immunoglobulin A Measurement"
                  ),
                  paramcd = c("ALT", "CRP", "IGA"),
                  paramu = c("U/L", "mg/L", "g/L"),
                  aval_mean = c(18, 9, 2.9),
                  visit_format = "WEEK",
                  n_assessments = 5L,
                  n_days = 5L,
                  max_n_lbs = 10L,
                  lookup = NULL,
                  seed = NULL,
                  na_percentage = 0,
                  na_vars = list(
                    LOQFL = c(NA, 0.1), ABLFL2 = c(1234, 0.1), ABLFL = c(1235, 0.1),
                    BASE2 = c(NA, 0.1), BASE = c(NA, 0.1),
                    CHG2 = c(1235, 0.1), PCHG2 = c(1235, 0.1), CHG = c(1234, 0.1), PCHG = c(1234, 0.1)
                  ),
                  cached = FALSE) {
  checkmate::assert_flag(cached)
  if (cached) {
    return(get_cached_data("cadlb"))
  }

  checkmate::assert_data_frame(adsl)
  checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(paramu, min.len = 1, any.missing = FALSE)
  checkmate::assert_character(lbcat, min.len = 1, any.missing = FALSE)
  checkmate::assert_string(visit_format)
  checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
  checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
  checkmate::assert_integer(max_n_lbs, len = 1, any.missing = FALSE)
  checkmate::assert_data_frame(lookup, null.ok = TRUE)
  checkmate::assert_number(seed, null.ok = TRUE)
  checkmate::assert_number(na_percentage, lower = 0, upper = 1)
  checkmate::assert_true(na_percentage < 1)

  # validate and initialize related variables
  lbcat_init_list <- relvar_init(param, lbcat)
  param_init_list <- relvar_init(param, paramcd)
  unit_init_list <- relvar_init(param, paramu)

  if (!is.null(seed)) {
    set.seed(seed)
  }
  study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))

  adlb <- expand.grid(
    STUDYID = unique(adsl$STUDYID),
    USUBJID = adsl$USUBJID,
    PARAM = as.factor(param_init_list$relvar1),
    AVISIT = visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days),
    stringsAsFactors = FALSE
  )

  # assign AVAL based on different tests
  adlb <- adlb %>% mutate(AVAL = case_when(
    PARAM == param[1] ~ abs(stats::rnorm(nrow(adlb), mean = aval_mean[1], sd = 10)),
    PARAM == param[2] ~ abs(stats::rnorm(nrow(adlb), mean = aval_mean[2], sd = 1)),
    PARAM == param[3] ~ abs(stats::rnorm(nrow(adlb), mean = aval_mean[3], sd = 0.1))
  ))

  # assign related variable values: PARAMxLBCAT are related
  adlb <- adlb %>% rel_var(
    var_name = "LBCAT",
    related_var = "PARAM",
    var_values = lbcat_init_list$relvar2
  )

  # assign related variable values: PARAMxPARAMCD are related
  adlb <- adlb %>% rel_var(
    var_name = "PARAMCD",
    related_var = "PARAM",
    var_values = param_init_list$relvar2
  )

  adlb <- adlb %>%
    dplyr::mutate(LBTESTCD = PARAMCD) %>%
    dplyr::mutate(LBTEST = PARAM)

  adlb <- adlb %>% dplyr::mutate(AVISITN = dplyr::case_when(
    AVISIT == "SCREENING" ~ -1,
    AVISIT == "BASELINE" ~ 0,
    (grepl("^WEEK", AVISIT) | grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
    TRUE ~ NA_real_
  ))

  adlb <- adlb %>% rel_var(
    var_name = "AVALU",
    related_var = "PARAM",
    var_values = unit_init_list$relvar2
  )

  adlb <- adlb %>%
    dplyr::mutate(AVISITN = dplyr::case_when(
      AVISIT == "SCREENING" ~ -1,
      AVISIT == "BASELINE" ~ 0,
      (grepl("^WEEK", AVISIT) | grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
      TRUE ~ NA_real_
    ))

  # order to prepare for change from screening and baseline values
  adlb <- adlb[order(adlb$STUDYID, adlb$USUBJID, adlb$PARAMCD, adlb$AVISITN), ]

  adlb <- Reduce(rbind, lapply(split(adlb, adlb$USUBJID), function(x) {
    x$STUDYID <- adsl$STUDYID[which(adsl$USUBJID == x$USUBJID[1])]
    x$ABLFL2 <- ifelse(x$AVISIT == "SCREENING", "Y", "")
    x$ABLFL <- ifelse(toupper(visit_format) == "WEEK" & x$AVISIT == "BASELINE",
      "Y",
      ifelse(toupper(visit_format) == "CYCLE" & x$AVISIT == "CYCLE 1 DAY 1", "Y", "")
    )
    x
  }))

  adlb$BASE2 <- retain(adlb, adlb$AVAL, adlb$ABLFL2 == "Y")
  adlb$BASE <- ifelse(adlb$ABLFL2 != "Y", retain(adlb, adlb$AVAL, adlb$ABLFL == "Y"), NA)

  adlb <- adlb %>%
    dplyr::mutate(CHG2 = AVAL - BASE2) %>%
    dplyr::mutate(PCHG2 = 100 * (CHG2 / BASE2)) %>%
    dplyr::mutate(CHG = AVAL - BASE) %>%
    dplyr::mutate(PCHG = 100 * (CHG / BASE)) %>%
    dplyr::mutate(BASETYPE = "LAST") %>%
    dplyr::mutate(ANRLO = dplyr::case_when(
      PARAMCD == "ALT" ~ 7,
      PARAMCD == "CRP" ~ 8,
      PARAMCD == "IGA" ~ 0.8
    )) %>%
    dplyr::mutate(ANRHI = dplyr::case_when(
      PARAMCD == "ALT" ~ 55,
      PARAMCD == "CRP" ~ 10,
      PARAMCD == "IGA" ~ 3
    )) %>%
    dplyr::mutate(ANRIND = factor(dplyr::case_when(
      AVAL < ANRLO ~ "LOW",
      AVAL > ANRHI ~ "HIGH",
      TRUE ~ "NORMAL"
    ))) %>%
    dplyr::mutate(LBSTRESC = factor(dplyr::case_when(
      PARAMCD == "ALT" ~ "<7",
      PARAMCD == "CRP" ~ "<8",
      PARAMCD == "IGA" ~ ">3"
    ))) %>%
    dplyr::rowwise() %>%
    dplyr::mutate(LOQFL = factor(
      ifelse(eval(parse(text = paste(AVAL, LBSTRESC))), "Y", "N")
    )) %>%
    dplyr::ungroup() %>%
    dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
    dplyr::mutate(BNRIND = ANRIND[ABLFL == "Y"]) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(SHIFT1 = factor(ifelse(
      AVISITN > 0,
      paste(
        retain(
          adlb, as.character(BNRIND),
          AVISITN == 0
        ),
        ANRIND,
        sep = " to "
      ),
      ""
    ))) %>%
    dplyr::mutate(ATOXGR = factor(dplyr::case_when(
      ANRIND == "LOW" ~ sample(
        c("-1", "-2", "-3", "-4", "-5"),
        nrow(adlb),
        replace = TRUE,
        prob = c(0.30, 0.25, 0.20, 0.15, 0)
      ),
      ANRIND == "HIGH" ~ sample(
        c("1", "2", "3", "4", "5"),
        nrow(adlb),
        replace = TRUE,
        prob = c(0.30, 0.25, 0.20, 0.15, 0)
      ),
      ANRIND == "NORMAL" ~ "0"
    ))) %>%
    dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
    dplyr::mutate(BTOXGR = ATOXGR[ABLFL == "Y"]) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(ATPTN = 1) %>%
    dplyr::mutate(DTYPE = NA) %>%
    dplyr::mutate(BTOXGRL = factor(dplyr::case_when(
      BTOXGR == "0" ~ "0",
      BTOXGR == "-1" ~ "1",
      BTOXGR == "-2" ~ "2",
      BTOXGR == "-3" ~ "3",
      BTOXGR == "-4" ~ "4",
      BTOXGR == "1" ~ "<Missing>",
      BTOXGR == "2" ~ "<Missing>",
      BTOXGR == "3" ~ "<Missing>",
      BTOXGR == "4" ~ "<Missing>"
    ))) %>%
    dplyr::mutate(BTOXGRH = factor(dplyr::case_when(
      BTOXGR == "0" ~ "0",
      BTOXGR == "1" ~ "1",
      BTOXGR == "2" ~ "2",
      BTOXGR == "3" ~ "3",
      BTOXGR == "4" ~ "4",
      BTOXGR == "-1" ~ "<Missing>",
      BTOXGR == "-2" ~ "<Missing>",
      BTOXGR == "-3" ~ "<Missing>",
      BTOXGR == "-4" ~ "<Missing>",
    ))) %>%
    dplyr::mutate(ATOXGRL = factor(dplyr::case_when(
      ATOXGR == "0" ~ "0",
      ATOXGR == "-1" ~ "1",
      ATOXGR == "-2" ~ "2",
      ATOXGR == "-3" ~ "3",
      ATOXGR == "-4" ~ "4",
      ATOXGR == "1" ~ "<Missing>",
      ATOXGR == "2" ~ "<Missing>",
      ATOXGR == "3" ~ "<Missing>",
      ATOXGR == "4" ~ "<Missing>",
    ))) %>%
    dplyr::mutate(ATOXGRH = factor(dplyr::case_when(
      ATOXGR == "0" ~ "0",
      ATOXGR == "1" ~ "1",
      ATOXGR == "2" ~ "2",
      ATOXGR == "3" ~ "3",
      ATOXGR == "4" ~ "4",
      ATOXGR == "-1" ~ "<Missing>",
      ATOXGR == "-2" ~ "<Missing>",
      ATOXGR == "-3" ~ "<Missing>",
      ATOXGR == "-4" ~ "<Missing>",
    ))) %>%
    rcd_var_relabel(
      STUDYID = attr(adsl$STUDYID, "label"),
      USUBJID = attr(adsl$USUBJID, "label")
    )

  # High and low descriptions of the different PARAMCD values
  # This is currently hard coded as the GDSR does not have these descriptions yet
  grade_lookup <- tibble::tribble(
    ~PARAMCD, ~ATOXDSCL, ~ATOXDSCH,
    "ALB", "Hypoalbuminemia", NA_character_,
    "ALKPH", NA_character_, "Alkaline phosphatase increased",
    "ALT", NA_character_, "Alanine aminotransferase increased",
    "AST", NA_character_, "Aspartate aminotransferase increased",
    "BILI", NA_character_, "Blood bilirubin increased",
    "CA", "Hypocalcemia", "Hypercalcemia",
    "CHOLES", NA_character_, "Cholesterol high",
    "CK", NA_character_, "CPK increased",
    "CREAT", NA_character_, "Creatinine increased",
    "CRP", NA_character_, "C reactive protein increased",
    "GGT", NA_character_, "GGT increased",
    "GLUC", "Hypoglycemia", "Hyperglycemia",
    "HGB", "Anemia", "Hemoglobin increased",
    "IGA", NA_character_, "Immunoglobulin A increased",
    "POTAS", "Hypokalemia", "Hyperkalemia",
    "LYMPH", "CD4 lymphocytes decreased", NA_character_,
    "PHOS", "Hypophosphatemia", NA_character_,
    "PLAT", "Platelet count decreased", NA_character_,
    "SODIUM", "Hyponatremia", "Hypernatremia",
    "WBC", "White blood cell decreased", "Leukocytosis",
  )

  # merge grade_lookup onto adlb
  adlb <- dplyr::left_join(adlb, grade_lookup, by = "PARAMCD")

  adlb <- rcd_var_relabel(
    adlb,
    STUDYID = "Study Identifier",
    USUBJID = "Unique Subject Identifier"
  )

  # merge ADSL to be able to add LB date and study day variables
  adlb <- dplyr::inner_join(
    adlb,
    adsl,
    by = c("STUDYID", "USUBJID")
  ) %>%
    dplyr::rowwise() %>%
    dplyr::mutate(TRTENDT = lubridate::date(dplyr::case_when(
      is.na(TRTEDTM) ~ lubridate::floor_date(lubridate::date(TRTSDTM) + study_duration_secs, unit = "day"),
      TRUE ~ TRTEDTM
    ))) %>%
    dplyr::ungroup()

  adlb <- adlb %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::arrange(USUBJID, AVISITN) %>%
    dplyr::mutate(ADTM = rep(
      sort(sample(
        seq(lubridate::as_datetime(TRTSDTM[1]), lubridate::as_datetime(TRTENDT[1]), by = "day"),
        size = nlevels(AVISIT)
      )),
      each = n() / nlevels(AVISIT)
    )) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(ADY = ceiling(difftime(ADTM, TRTSDTM, units = "days"))) %>%
    dplyr::select(-TRTENDT) %>%
    dplyr::arrange(STUDYID, USUBJID, ADTM)

  adlb <- adlb %>%
    dplyr::mutate(ASPID = sample(seq_len(dplyr::n()))) %>%
    dplyr::group_by(USUBJID) %>%
    dplyr::mutate(LBSEQ = seq_len(dplyr::n())) %>%
    dplyr::mutate(ASEQ = LBSEQ) %>%
    dplyr::ungroup() %>%
    dplyr::arrange(
      STUDYID,
      USUBJID,
      PARAMCD,
      BASETYPE,
      AVISITN,
      ATPTN,
      DTYPE,
      ADTM,
      LBSEQ,
      ASPID
    )

  adlb <- adlb %>% dplyr::mutate(ONTRTFL = factor(dplyr::case_when(
    !AVISIT %in% c("SCREENING", "BASELINE") ~ "Y",
    TRUE ~ ""
  )))

  flag_variables <- function(data,
                             apply_grouping,
                             apply_filter,
                             apply_mutate) {
    data_compare <- data %>%
      dplyr::mutate(row_check = seq_len(nrow(data)))

    data <- data_compare %>%
      {
        if (apply_grouping == TRUE) {
          dplyr::group_by(., USUBJID, PARAMCD, BASETYPE, AVISIT)
        } else {
          dplyr::group_by(., USUBJID, PARAMCD, BASETYPE)
        }
      } %>%
      dplyr::arrange(ADTM, ASPID, LBSEQ) %>%


1		#' ECG Analysis Dataset (ADEG)
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Function for generating random dataset from ECG Analysis Dataset for a given
6		#' Subject-Level Analysis Dataset.
7		#'
8		#' @details One record per subject per parameter per analysis visit per analysis date.
9		#'
10		#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`, `BASETYPE`, `AVISITN`, `ATPTN`, `DTYPE`, `ADTM`, `EGSEQ`, `ASPID`
11		#'
12		#' @inheritParams argument_convention
13		#' @param egcat (`character vector`)\cr EG category values.
14		#' @param max_n_eg (`integer`)\cr Maximum number of EG results per patient. Defaults to 10.
15		#' @template param_cached
16		#' @templateVar data adeg
17		#'
18		#' @return `data.frame`
19		#' @export
20		#'
21		#' @author tomlinsj, npaszty, Xuefeng Hou, dipietrc
22		#'
23		#' @examples
24		#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
25		#'
26		#' adeg <- radeg(adsl, visit_format = "WEEK", n_assessments = 7L, seed = 2)
27		#' adeg
28		#'
29		#' adeg <- radeg(adsl, visit_format = "CYCLE", n_assessments = 2L, seed = 2)
30		#' adeg
31		radeg <- function(adsl,
32		egcat = c("INTERVAL", "INTERVAL", "MEASUREMENT", "FINDING"),
33		param = c(
34		"QT Duration",
35		"RR Duration",
36		"Heart Rate",
37		"ECG Interpretation"
38		),
39		paramcd = c("QT", "RR", "HR", "ECGINTP"),
40		paramu = c("msec", "msec", "beats/min", ""),
41		visit_format = "WEEK",
42		n_assessments = 5L,
43		n_days = 5L,
44		max_n_eg = 10L,
45		lookup = NULL,
46		seed = NULL,
47		na_percentage = 0,
48		na_vars = list(
49		ABLFL = c(1235, 0.1), BASE = c(NA, 0.1), BASEC = c(NA, 0.1),
50		CHG = c(1234, 0.1), PCHG = c(1234, 0.1)
51		),
52		cached = FALSE) {
53	4x	checkmate::assert_flag(cached)
54	4x	if (cached) {
55	1x	return(get_cached_data("cadeg"))
56		}
57
58	3x	checkmate::assert_data_frame(adsl)
59	3x	checkmate::assert_character(egcat, min.len = 1, any.missing = FALSE)
60	3x	checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
61	3x	checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
62	3x	checkmate::assert_character(paramu, min.len = 1, any.missing = FALSE)
63	3x	checkmate::assert_string(visit_format)
64	3x	checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
65	3x	checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
66	3x	checkmate::assert_integer(max_n_eg, len = 1, any.missing = FALSE)
67	3x	checkmate::assert_data_frame(lookup, null.ok = TRUE)
68	3x	checkmate::assert_number(seed, null.ok = TRUE)
69	3x	checkmate::assert_number(na_percentage, lower = 0, upper = 1)
70	3x	checkmate::assert_true(na_percentage < 1)
71
72		# validate and initialize related variables
73	3x	egcat_init_list <- relvar_init(param, egcat)
74	3x	param_init_list <- relvar_init(param, paramcd)
75	3x	unit_init_list <- relvar_init(param, paramu)
76
77	3x	if (!is.null(seed)) {
78	3x	set.seed(seed)
79		}
80	3x	study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))
81
82	3x	adeg <- expand.grid(
83	3x	STUDYID = unique(adsl$STUDYID),
84	3x	USUBJID = adsl$USUBJID,
85	3x	PARAM = as.factor(param_init_list$relvar1),
86	3x	AVISIT = visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days),
87	3x	stringsAsFactors = FALSE
88		)
89
90		# assign related variable values: PARAMxEGCAT are related
91	3x	adeg <- adeg %>% rel_var(
92	3x	var_name = "EGCAT",
93	3x	related_var = "PARAM",
94	3x	var_values = egcat_init_list$relvar2
95		)
96
97		# assign related variable values: PARAMxPARAMCD are related
98	3x	adeg <- adeg %>% rel_var(
99	3x	var_name = "PARAMCD",
100	3x	related_var = "PARAM",
101	3x	var_values = param_init_list$relvar2
102		)
103
104	3x	adeg <- adeg %>% dplyr::mutate(AVAL = dplyr::case_when(
105	3x	PARAMCD == "QT" ~ stats::rnorm(nrow(adeg), mean = 350, sd = 100),
106	3x	PARAMCD == "RR" ~ stats::rnorm(nrow(adeg), mean = 1050, sd = 300),
107	3x	PARAMCD == "HR" ~ stats::rnorm(nrow(adeg), mean = 70, sd = 20),
108	3x	PARAMCD == "ECGINTP" ~ NA_real_
109		))
110
111	3x	adeg <- adeg %>%
112	3x	dplyr::mutate(EGTESTCD = PARAMCD) %>%
113	3x	dplyr::mutate(EGTEST = PARAM)
114
115	3x	adeg <- adeg %>% dplyr::mutate(AVISITN = dplyr::case_when(
116	3x	AVISIT == "SCREENING" ~ -1,
117	3x	AVISIT == "BASELINE" ~ 0,
118	3x	(grepl("^WEEK", AVISIT) \| grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
119	3x	TRUE ~ NA_real_
120		))
121
122	3x	adeg <- adeg %>% rel_var(
123	3x	var_name = "AVALU",
124	3x	related_var = "PARAM",
125	3x	var_values = unit_init_list$relvar2
126		)
127
128		# order to prepare for change from screening and baseline values
129	3x	adeg <- adeg[order(adeg$STUDYID, adeg$USUBJID, adeg$PARAMCD, adeg$AVISITN), ]
130
131	3x	adeg <- Reduce(rbind, lapply(split(adeg, adeg$USUBJID), function(x) {
132	30x	x$STUDYID <- adsl$STUDYID[which(adsl$USUBJID == x$USUBJID[1])]
133	30x	x$ABLFL <- ifelse(toupper(visit_format) == "WEEK" & x$AVISIT == "BASELINE",
134	30x	"Y",
135	30x	ifelse(toupper(visit_format) == "CYCLE" & x$AVISIT == "CYCLE 1 DAY 1", "Y", "")
136		)
137	30x	x
138		}))
139
140	3x	adeg$BASE <- ifelse(adeg$AVISITN >= 0, retain(adeg, adeg$AVAL, adeg$ABLFL == "Y"), adeg$AVAL)
141
142	3x	adeg <- adeg %>% dplyr::mutate(ANRLO = dplyr::case_when(
143	3x	PARAMCD == "QT" ~ 200,
144	3x	PARAMCD == "RR" ~ 600,
145	3x	PARAMCD == "HR" ~ 40,
146	3x	PARAMCD == "ECGINTP" ~ NA_real_
147		))
148
149	3x	adeg <- adeg %>% dplyr::mutate(ANRHI = dplyr::case_when(
150	3x	PARAMCD == "QT" ~ 500,
151	3x	PARAMCD == "RR" ~ 1500,
152	3x	PARAMCD == "HR" ~ 100,
153	3x	PARAMCD == "ECGINTP" ~ NA_real_
154		))
155
156	3x	adeg <- adeg %>% dplyr::mutate(ANRIND = factor(dplyr::case_when(
157	3x	AVAL < ANRLO ~ "LOW",
158	3x	AVAL >= ANRLO & AVAL <= ANRHI ~ "NORMAL",
159	3x	AVAL > ANRHI ~ "HIGH"
160		)))
161
162	3x	adeg <- adeg %>%
163	3x	dplyr::mutate(CHG = ifelse(AVISITN > 0, AVAL - BASE, NA)) %>%
164	3x	dplyr::mutate(PCHG = ifelse(AVISITN > 0, 100 * (CHG / BASE), NA)) %>%
165	3x	dplyr::mutate(BASETYPE = "LAST") %>%
166	3x	dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
167	3x	dplyr::mutate(BNRIND = ANRIND[ABLFL == "Y"]) %>%
168	3x	dplyr::ungroup() %>%
169	3x	dplyr::mutate(ATPTN = 1) %>%
170	3x	dplyr::mutate(DTYPE = NA)
171
172	3x	adeg$ANRIND <- factor(adeg$ANRIND, levels = c("LOW", "NORMAL", "HIGH"))
173	3x	adeg$BNRIND <- factor(adeg$BNRIND, levels = c("LOW", "NORMAL", "HIGH"))
174
175	3x	adeg <- rcd_var_relabel(
176	3x	adeg,
177	3x	STUDYID = "Study Identifier",
178	3x	USUBJID = "Unique Subject Identifier"
179		)
180
181		# merge ADSL to be able to add EG date and study day variables
182	3x	adeg <- dplyr::inner_join(
183	3x	adeg,
184	3x	adsl,
185	3x	by = c("STUDYID", "USUBJID")
186		) %>%
187	3x	dplyr::rowwise() %>%
188	3x	dplyr::mutate(TRTENDT = lubridate::date(dplyr::case_when(
189	3x	is.na(TRTEDTM) ~ lubridate::floor_date(lubridate::date(TRTSDTM) + study_duration_secs, unit = "day"),
190	3x	TRUE ~ TRTEDTM
191		))) %>%
192	3x	dplyr::ungroup()
193
194	3x	adeg <- adeg %>%
195	3x	dplyr::group_by(USUBJID) %>%
196	3x	dplyr::arrange(USUBJID, AVISITN) %>%
197	3x	dplyr::mutate(ADTM = rep(
198	3x	sort(sample(
199	3x	seq(lubridate::as_datetime(TRTSDTM[1]), lubridate::as_datetime(TRTENDT[1]), by = "day"),
200	3x	size = nlevels(AVISIT)
201		)),
202	3x	each = n() / nlevels(AVISIT)
203		)) %>%
204	3x	dplyr::ungroup() %>%
205	3x	dplyr::mutate(ADY = ceiling(difftime(ADTM, TRTSDTM, units = "days"))) %>%
206	3x	dplyr::select(-TRTENDT) %>%
207	3x	dplyr::arrange(STUDYID, USUBJID, ADTM)
208
209	3x	adeg <- adeg %>%
210	3x	dplyr::mutate(ASPID = sample(seq_len(dplyr::n()))) %>%
211	3x	dplyr::group_by(USUBJID) %>%
212	3x	dplyr::mutate(EGSEQ = seq_len(dplyr::n())) %>%
213	3x	dplyr::mutate(ASEQ = EGSEQ) %>%
214	3x	dplyr::ungroup() %>%
215	3x	dplyr::arrange(
216	3x	STUDYID,
217	3x	USUBJID,
218	3x	PARAMCD,
219	3x	BASETYPE,
220	3x	AVISITN,
221	3x	ATPTN,
222	3x	DTYPE,
223	3x	ADTM,
224	3x	EGSEQ,
225	3x	ASPID
226		)
227
228	3x	adeg <- adeg %>% dplyr::mutate(ONTRTFL = factor(dplyr::case_when(
229	3x	!AVISIT %in% c("SCREENING", "BASELINE") ~ "Y",
230	3x	TRUE ~ ""
231		)))
232
233	3x	adeg <- adeg %>% dplyr::mutate(AVALC = ifelse(
234	3x	PARAMCD == "ECGINTP",
235	3x	as.character(sample_fct(c("ABNORMAL", "NORMAL"), nrow(adeg), prob = c(0.25, 0.75))),
236	3x	as.character(AVAL)
237		))
238
239		# Temporarily creating a row_check column to easily match newly created
240		# observations with their row correct arrangement.
241	3x	adeg <- adeg %>%
242	3x	dplyr::mutate(row_check = seq_len(nrow(adeg)))
243
244		# Created function to add in new observations for DTYPE, "MINIMUM" & "MAXIMUM" in this case.
245	3x	get_groups <- function(data,
246	3x	minimum) {
247	6x	data <- data %>%
248	6x	dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
249	6x	dplyr::arrange(ADTM, ASPID, EGSEQ) %>%
250	6x	dplyr::filter(
251	6x	(AVISIT != "BASELINE" & AVISIT != "SCREENING") &
252	6x	(ONTRTFL == "Y" \| ADTM <= TRTSDTM)
253		) %>%
254		{
255	6x	if (minimum == TRUE) {
256	3x	dplyr::filter(., AVAL == min(AVAL)) %>%
257	3x	dplyr::mutate(., DTYPE = "MINIMUM", AVISIT = "POST-BASELINE MINIMUM")
258		} else {
259	3x	dplyr::filter(., AVAL == max(AVAL)) %>%
260	3x	dplyr::mutate(., DTYPE = "MAXIMUM", AVISIT = "POST-BASELINE MAXIMUM")
261		}
262		} %>%
263	6x	dplyr::slice(1) %>%
264	6x	dplyr::ungroup()
265
266	6x	return(data)
267		}
268
269		# Binding the new observations to the dataset from the function above and rearranging in the correct order.
270	3x	adeg <- rbind(adeg, get_groups(adeg, TRUE), get_groups(adeg, FALSE)) %>%
271	3x	dplyr::arrange(row_check) %>%
272	3x	dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
273	3x	dplyr::arrange(AVISIT, .by_group = TRUE) %>%
274	3x	dplyr::ungroup()
275
276		# Dropping the "row_check" column created above.
277	3x	adeg <- adeg[, -which(names(adeg) %in% c("row_check"))]
278
279		# Created function to easily match rows which comply to ONTRTFL derivation
280	3x	flag_variables <- function(data, worst_obs) {
281	6x	data_compare <- data %>%
282	6x	dplyr::mutate(row_check = seq_len(nrow(data)))
283
284	6x	data <- data_compare %>%
285		{
286	6x	if (worst_obs == FALSE) {
287	3x	dplyr::group_by(., USUBJID, PARAMCD, BASETYPE, AVISIT) %>%
288	3x	dplyr::arrange(., ADTM, ASPID, EGSEQ)
289		} else {
290	3x	dplyr::group_by(., USUBJID, PARAMCD, BASETYPE)
291		}
292		} %>%
293	6x	dplyr::filter(
294	6x	AVISITN > 0 & (ONTRTFL == "Y" \| ADTM <= TRTSDTM) &
295	6x	is.na(DTYPE)
296		) %>%
297		{
298	6x	if (worst_obs == TRUE) {
299	3x	dplyr::arrange(., AVALC) %>% dplyr::filter(., ifelse(
300	3x	PARAMCD == "ECGINTP",
301	3x	ifelse(AVALC == "ABNORMAL", AVALC == "ABNORMAL", AVALC == "NORMAL"),
302	3x	AVAL == min(AVAL)
303		))
304		} else {
305	3x	dplyr::filter(., ifelse(
306	3x	PARAMCD == "ECGINTP",
307	3x	AVALC == "ABNORMAL" \| AVALC == "NORMAL",
308	3x	AVAL == min(AVAL)
309		))
310		}
311		} %>%
312	6x	dplyr::slice(1) %>%
313		{
314	6x	if (worst_obs == TRUE) {
315	3x	dplyr::mutate(., new_var = dplyr::case_when(
316	3x	(AVALC == "ABNORMAL" \| AVALC == "NORMAL") ~ "Y",
317	3x	(!is.na(AVAL) & is.na(DTYPE)) ~ "Y",
318	3x	TRUE ~ ""
319		))
320		} else {
321	3x	dplyr::mutate(., new_var = dplyr::case_when(
322	3x	(AVALC == "ABNORMAL" \| AVALC == "NORMAL") ~ "Y",
323	3x	(!is.na(AVAL) & is.na(DTYPE)) ~ "Y",
324	3x	TRUE ~ ""
325		))
326		}
327		} %>%
328	6x	dplyr::ungroup()
329
330	6x	data_compare$new_var <- ifelse(data_compare$row_check %in% data$row_check, "Y", "")
331	6x	data_compare <- data_compare[, -which(names(data_compare) %in% c("row_check"))]
332
333	6x	return(data_compare)
334		}
335
336	3x	adeg <- flag_variables(adeg, FALSE) %>% dplyr::rename(WORS01FL = "new_var")
337	3x	adeg <- flag_variables(adeg, TRUE) %>% dplyr::rename(WORS02FL = "new_var")
338
339	3x	adeg <- adeg %>% dplyr::mutate(ANL01FL = factor(ifelse(
340	3x	(ABLFL == "Y" \| (is.na(DTYPE) & WORS01FL == "Y")) &
341	3x	(AVISIT != "SCREENING"),
342	3x	"Y",
343		""
344		)))
345
346	3x	adeg <- adeg %>%
347	3x	dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
348	3x	dplyr::mutate(BASEC = ifelse(
349	3x	PARAMCD == "ECGINTP",
350	3x	AVALC[AVISIT == "BASELINE"],
351	3x	as.character(BASE)
352		)) %>%
353	3x	dplyr::mutate(ANL03FL = dplyr::case_when(
354	3x	DTYPE == "MINIMUM" ~ "Y",
355	3x	ABLFL == "Y" & PARAMCD != "ECGINTP" ~ "Y",
356	3x	TRUE ~ ""
357		)) %>%
358	3x	dplyr::mutate(ANL04FL = dplyr::case_when(
359	3x	DTYPE == "MAXIMUM" ~ "Y",
360	3x	ABLFL == "Y" & PARAMCD != "ECGINTP" ~ "Y",
361	3x	TRUE ~ ""
362		)) %>%
363	3x	dplyr::ungroup()
364
365	3x	if (length(na_vars) > 0 && na_percentage > 0) {
366	!	adeg <- mutate_na(ds = adeg, na_vars = na_vars, na_percentage = na_percentage)
367		}
368
369		# apply metadata
370	3x	adeg <- apply_metadata(adeg, "metadata/ADEG.yml")
371
372	3x	return(adeg)
373		}

1		#' Time to Adverse Event Analysis Dataset (ADAETTE)
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Function to generate random Time-to-AE Dataset for a
6		#' given Subject-Level Analysis Dataset.
7		#'
8		#' @details
9		#'
10		#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`
11		#'
12		#' @inheritParams argument_convention
13		#' @param event_descr (`character vector`)\cr Descriptions of events. Defaults to `NULL`.
14		#' @param censor_descr (`character vector`)\cr Descriptions of censors. Defaults to `NULL`.
15		#' @template param_cached
16		#' @templateVar data adaette
17		#'
18		#' @return `data.frame`
19		#' @export
20		#'
21		#' @author Xiuting Mi
22		#'
23		#' @examples
24		#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
25		#'
26		#' adaette <- radaette(adsl, seed = 2)
27		#' adaette
28		radaette <- function(adsl,
29		event_descr = NULL,
30		censor_descr = NULL,
31		lookup = NULL,
32		seed = NULL,
33		na_percentage = 0,
34		na_vars = list(CNSR = c(NA, 0.1), AVAL = c(1234, 0.1)),
35		cached = FALSE) {
36	6x	checkmate::assert_flag(cached)
37	6x	if (cached) {
38	1x	return(get_cached_data("cadaette"))
39		}
40
41	5x	checkmate::assert_data_frame(adsl)
42	5x	checkmate::assert_character(censor_descr, null.ok = TRUE, min.len = 1, any.missing = FALSE)
43	5x	checkmate::assert_character(event_descr, null.ok = TRUE, min.len = 1, any.missing = FALSE)
44	5x	checkmate::assert_number(seed, null.ok = TRUE)
45	5x	checkmate::assert_number(na_percentage, lower = 0, upper = 1)
46	5x	checkmate::assert_true(na_percentage < 1)
47
48	5x	checkmate::assert_data_frame(lookup, null.ok = TRUE)
49	5x	lookup_adaette <- if (!is.null(lookup)) {
50	!	lookup
51		} else {
52	5x	tibble::tribble(
53	5x	~ARM, ~CATCD, ~CAT, ~LAMBDA, ~CNSR_P,
54	5x	"ARM A", "1", "any adverse event", 1 / 80, 0.4,
55	5x	"ARM B", "1", "any adverse event", 1 / 100, 0.2,
56	5x	"ARM C", "1", "any adverse event", 1 / 60, 0.42,
57	5x	"ARM A", "2", "any serious adverse event", 1 / 100, 0.3,
58	5x	"ARM B", "2", "any serious adverse event", 1 / 150, 0.1,
59	5x	"ARM C", "2", "any serious adverse event", 1 / 80, 0.32,
60	5x	"ARM A", "3", "a grade 3-5 adverse event", 1 / 80, 0.2,
61	5x	"ARM B", "3", "a grade 3-5 adverse event", 1 / 100, 0.08,
62	5x	"ARM C", "3", "a grade 3-5 adverse event", 1 / 60, 0.23
63		)
64		}
65
66	5x	if (!is.null(seed)) {
67	5x	set.seed(seed)
68		}
69	5x	study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))
70
71	5x	evntdescr_sel <- if (!is.null(event_descr)) {
72	!	event_descr
73		} else {
74	5x	"Preferred Term"
75		}
76
77	5x	cnsdtdscr_sel <- if (!is.null(censor_descr)) {
78	!	censor_descr
79		} else {
80	5x	c(
81	5x	"Clinical Cut Off",
82	5x	"Completion or Discontinuation",
83	5x	"End of AE Reporting Period"
84		)
85		}
86
87	5x	random_patient_data <- function(patient_info) {
88	50x	startdt <- lubridate::date(patient_info$TRTSDTM)
89	50x	trtedtm <- lubridate::floor_date(dplyr::case_when(
90	50x	is.na(patient_info$TRTEDTM) ~ lubridate::date(patient_info$TRTSDTM) + study_duration_secs,
91	50x	TRUE ~ lubridate::date(patient_info$TRTEDTM)
92	50x	), unit = "day")
93	50x	enddts <- c(patient_info$EOSDT, lubridate::date(trtedtm))
94	50x	enddts_min_index <- which.min(enddts)
95	50x	adt <- enddts[enddts_min_index]
96	50x	adtm <- lubridate::as_datetime(adt)
97	50x	ady <- as.numeric(adt - startdt + 1)
98	50x	data.frame(
99	50x	ARM = patient_info$ARM,
100	50x	STUDYID = patient_info$STUDYID,
101	50x	SITEID = patient_info$SITEID,
102	50x	USUBJID = patient_info$USUBJID,
103	50x	PARAMCD = "AEREPTTE",
104	50x	PARAM = "Time to end of AE reporting period",
105	50x	CNSR = 0,
106	50x	AVAL = lubridate::days(ady) / lubridate::years(1),
107	50x	AVALU = "YEARS",
108	50x	EVNTDESC = ifelse(enddts_min_index == 1, "Completion or Discontinuation", "End of AE Reporting Period"),
109	50x	CNSDTDSC = NA,
110	50x	ADTM = adtm,
111	50x	ADY = ady,
112	50x	stringsAsFactors = FALSE
113		)
114		}
115
116		# validate and initialize related variables for Hy's law
117	5x	paramcd_hy <- c("HYSTTEUL", "HYSTTEBL")
118	5x	param_hy <- c("Time to Hy's Law Elevation in relation to ULN", "Time to Hy's Law Elevation in relation to Baseline")
119	5x	param_init_list <- relvar_init(param_hy, paramcd_hy)
120	5x	adsl_hy <- dplyr::select(adsl, "STUDYID", "USUBJID", "TRTSDTM", "SITEID", "ARM")
121
122		# create all combinations of unique values in STUDYID, USUBJID, PARAM, AVISIT
123	5x	adaette_hy <- expand.grid(
124	5x	STUDYID = unique(adsl$STUDYID),
125	5x	USUBJID = adsl$USUBJID,
126	5x	PARAM = as.factor(param_init_list$relvar1),
127	5x	stringsAsFactors = FALSE
128		)
129
130		# Add other variables to adaette_hy
131	5x	adaette_hy <- dplyr::left_join(adaette_hy, adsl_hy, by = c("STUDYID", "USUBJID")) %>%
132	5x	rel_var(
133	5x	var_name = "PARAMCD",
134	5x	related_var = "PARAM",
135	5x	var_values = param_init_list$relvar2
136		) %>%
137	5x	dplyr::mutate(
138	5x	CNSR = sample(c(0, 1), prob = c(0.1, 0.9), size = dplyr::n(), replace = TRUE),
139	5x	EVNTDESC = dplyr::if_else(
140	5x	CNSR == 0,
141	5x	"First Post-Baseline Raised ALT or AST Elevation Result",
142	5x	NA_character_
143		),
144	5x	CNSDTDSC = dplyr::if_else(CNSR == 0, NA_character_,
145	5x	sample(c("Last Post-Baseline ALT or AST Result", "Treatment Start"),
146	5x	prob = c(0.9, 0.1),
147	5x	size = dplyr::n(), replace = TRUE
148		)
149		)
150		) %>%
151	5x	dplyr::rowwise() %>%
152	5x	dplyr::mutate(ADTM = dplyr::case_when(
153	5x	CNSDTDSC == "Treatment Start" ~ TRTSDTM,
154	5x	TRUE ~ TRTSDTM + sample(seq(0, study_duration_secs), size = dplyr::n(), replace = TRUE)
155		)) %>%
156	5x	dplyr::mutate(
157	5x	ADY_int = lubridate::date(ADTM) - lubridate::date(TRTSDTM) + 1,
158	5x	ADY = as.numeric(ADY_int),
159	5x	AVAL = lubridate::days(ADY_int) / lubridate::weeks(1),
160	5x	AVALU = "WEEKS"
161		) %>%
162	5x	dplyr::select(-TRTSDTM, -ADY_int)
163
164	5x	random_ae_data <- function(lookup_info, patient_info, patient_data) {
165	150x	cnsr <- sample(c(0, 1), 1, prob = c(1 - lookup_info$CNSR_P, lookup_info$CNSR_P))
166	150x	ae_rep_tte <- patient_data$AVAL[patient_data$PARAMCD == "AEREPTTE"]
167	150x	data.frame(
168	150x	ARM = rep(patient_data$ARM, 2),
169	150x	STUDYID = rep(patient_data$STUDYID, 2),
170	150x	SITEID = rep(patient_data$SITEID, 2),
171	150x	USUBJID = rep(patient_data$USUBJID, 2),
172	150x	PARAMCD = c(
173	150x	paste0("AETTE", lookup_info$CATCD),
174	150x	paste0("AETOT", lookup_info$CATCD)
175		),
176	150x	PARAM = c(
177	150x	paste("Time to first occurrence of", lookup_info$CAT),
178	150x	paste("Number of occurrences of", lookup_info$CAT)
179		),
180	150x	CNSR = c(
181	150x	cnsr,
182	150x	NA
183		),
184	150x	AVAL = c(
185		# We generate these values conditional on the censoring information.
186		# If this time to event is censored, then there were no AEs reported and the time is set
187		# to the AE reporting period time. Otherwise we draw from truncated distributions to make
188		# sure that we are within the AE reporting time and above 0 AEs.
189	150x	ifelse(cnsr == 1, ae_rep_tte, rtexp(1, lookup_info$LAMBDA * 365.25, r = ae_rep_tte)),
190	150x	ifelse(cnsr == 1, 0, rtpois(1, lookup_info$LAMBDA * 365.25))
191		),
192	150x	AVALU = c(
193	150x	"YEARS",
194	150x	NA
195		),
196	150x	EVNTDESC = c(
197	150x	ifelse(cnsr == 0, sample(evntdescr_sel, 1), ""),
198	150x	NA
199		),
200	150x	CNSDTDSC = c(
201	150x	ifelse(cnsr == 1, sample(cnsdtdscr_sel, 1), ""),
202	150x	NA
203		),
204	150x	stringsAsFactors = FALSE
205	150x	) %>% dplyr::mutate(
206	150x	ADY = dplyr::if_else(is.na(AVALU), NA_real_, ceiling(as.numeric(lubridate::dyears(AVAL), "days"))),
207	150x	ADTM = dplyr::if_else(
208	150x	is.na(AVALU),
209	150x	lubridate::as_datetime(NA),
210	150x	patient_info$TRTSDTM + lubridate::days(ADY)
211		)
212		)
213		}
214
215	5x	adaette <- split(adsl, adsl$USUBJID) %>%
216	5x	lapply(function(patient_info) {
217	50x	patient_data <- random_patient_data(patient_info)
218	50x	lookup_arm <- lookup_adaette %>%
219	50x	dplyr::filter(ARM == as.character(patient_info$ARMCD))
220	50x	ae_data <- split(lookup_arm, lookup_arm$CATCD) %>%
221	50x	lapply(random_ae_data, patient_data = patient_data, patient_info = patient_info) %>%
222	50x	Reduce(rbind, .)
223	50x	dplyr::bind_rows(patient_data, ae_data)
224		}) %>%
225	5x	Reduce(rbind, .) %>%
226	5x	rcd_var_relabel(
227	5x	STUDYID = "Study Identifier",
228	5x	USUBJID = "Unique Subject Identifier"
229		)
230
231	5x	adaette <- rcd_var_relabel(
232	5x	adaette,
233	5x	STUDYID = "Study Identifier",
234	5x	USUBJID = "Unique Subject Identifier"
235		)
236
237	5x	adaette <- rbind(adaette, adaette_hy)
238
239	5x	adaette <- dplyr::inner_join(
240	5x	dplyr::select(adaette, -"SITEID", -"ARM"),
241	5x	adsl,
242	5x	by = c("STUDYID", "USUBJID")
243		) %>%
244	5x	dplyr::group_by(USUBJID) %>%
245	5x	dplyr::arrange(ADTM) %>%
246	5x	dplyr::mutate(TTESEQ = seq_len(dplyr::n())) %>%
247	5x	dplyr::mutate(ASEQ = TTESEQ) %>%
248	5x	dplyr::mutate(PARAM = as.factor(PARAM)) %>%
249	5x	dplyr::mutate(PARAMCD = as.factor(PARAMCD)) %>%
250	5x	dplyr::ungroup() %>%
251	5x	dplyr::arrange(
252	5x	STUDYID,
253	5x	USUBJID,
254	5x	PARAMCD,
255	5x	ADTM,
256	5x	TTESEQ
257		)
258
259	5x	if (length(na_vars) > 0 && na_percentage > 0) {
260	!	adaette <- dplyr::mutate(ds = adaette, na_vars = na_vars, na_percentage = na_percentage)
261		}
262
263		# apply metadata
264	5x	adaette <- apply_metadata(adaette, "metadata/ADAETTE.yml")
265
266	5x	return(adaette)
267		}

1		#' Load Cached Data
2		#'
3		#' Return data attached to package.
4		#'
5		#' @keywords internal
6		#' @noRd
7		get_cached_data <- function(dataname) {
8	22x	checkmate::assert_string(dataname)
9	22x	if (!("package:random.cdisc.data" %in% search())) {
10	1x	stop("cached data can only be loaded if the random.cdisc.data package is attached.",
11	1x	"Please run library(random.cdisc.data) before loading cached data.",
12	1x	call. = FALSE
13		)
14		} else {
15	21x	get(dataname, envir = asNamespace("random.cdisc.data"))
16		}
17		}
18
19		#' Create a Factor with Random Elements of x
20		#'
21		#' Sample elements from `x` with replacement to build a factor.
22		#'
23		#' @param x (`character vector` or `factor`)\cr If character vector then it is also used
24		#' as levels of the returned factor. If factor then the levels are used as the new levels.
25		#' @param N (`numeric`)\cr Number of items to choose.
26		#' @param ... Additional arguments to be passed to `sample`.
27		#'
28		#' @return A factor of length `N`.
29		#' @export
30		#'
31		#' @examples
32		#' sample_fct(letters[1:3], 10)
33		#' sample_fct(iris$Species, 10)
34		sample_fct <- function(x, N, ...) { # nolint
35	296x	checkmate::assert_number(N)
36
37	296x	factor(sample(x, N, replace = TRUE, ...), levels = if (is.factor(x)) levels(x) else x)
38		}
39
40		#' Related Variables: Initialize
41		#'
42		#' Verify and initialize related variable values.
43		#' For example, `relvar_init("Alanine Aminotransferase Measurement", "ALT")`.
44		#'
45		#' @param relvar1 (`list` of `character`)\cr List of n elements.
46		#' @param relvar2 (`list` of `character`)\cr List of n elements.
47		#'
48		#' @return A vector of n elements.
49		#'
50		#' @keywords internal
51		relvar_init <- function(relvar1, relvar2) {
52	64x	checkmate::assert_character(relvar1, min.len = 1, any.missing = FALSE)
53	64x	checkmate::assert_character(relvar2, min.len = 1, any.missing = FALSE)
54
55	64x	if (length(relvar1) != length(relvar2)) {
56	1x	message(simpleError(
57	1x	"The argument value length of relvar1 and relvar2 differ. They must contain the same number of elements."
58		))
59	!	return(NA)
60		}
61	63x	return(list("relvar1" = relvar1, "relvar2" = relvar2))
62		}
63
64		#' Related Variables: Assign
65		#'
66		#' Assign values to a related variable within a domain.
67		#'
68		#' @param df (`data.frame`)\cr Data frame containing the related variables.
69		#' @param var_name (`character`)\cr Name of variable related to `rel_var` to add to `df`.
70		#' @param var_values (`any`)\cr Vector of values related to values of `related_var`.
71		#' @param related_var (`character`)\cr Name of variable within `df` with values to which values
72		#' of `var_name` must relate.
73		#'
74		#' @return `df` with added factor variable `var_name` containing `var_values` corresponding to `related_var`.
75		#' @export
76		#'
77		#' @examples
78		#' # Example with data.frame.
79		#' params <- c("Level A", "Level B", "Level C")
80		#' adlb_df <- data.frame(
81		#' ID = 1:9,
82		#' PARAM = factor(
83		#' rep(c("Level A", "Level B", "Level C"), 3),
84		#' levels = params
85		#' )
86		#' )
87		#' rel_var(
88		#' df = adlb_df,
89		#' var_name = "PARAMCD",
90		#' var_values = c("A", "B", "C"),
91		#' related_var = "PARAM"
92		#' )
93		#'
94		#' # Example with tibble.
95		#' adlb_tbl <- tibble::tibble(
96		#' ID = 1:9,
97		#' PARAM = factor(
98		#' rep(c("Level A", "Level B", "Level C"), 3),
99		#' levels = params
100		#' )
101		#' )
102		#' rel_var(
103		#' df = adlb_tbl,
104		#' var_name = "PARAMCD",
105		#' var_values = c("A", "B", "C"),
106		#' related_var = "PARAM"
107		#' )
108		rel_var <- function(df, var_name, related_var, var_values = NULL) {
109	64x	checkmate::assert_data_frame(df)
110	64x	checkmate::assert_string(var_name)
111	64x	checkmate::assert_string(related_var)
112	64x	n_relvar1 <- length(unique(df[, related_var, drop = TRUE]))
113	64x	checkmate::assert_vector(var_values, null.ok = TRUE, len = n_relvar1, any.missing = FALSE)
114	1x	if (is.null(var_values)) var_values <- rep(NA, n_relvar1)
115
116	64x	relvar1 <- unique(df[, related_var, drop = TRUE])
117	64x	relvar2_values <- rep(NA, nrow(df))
118	64x	for (r in seq_len(n_relvar1)) {
119	538x	matched <- which(df[, related_var, drop = TRUE] == relvar1[r])
120	538x	relvar2_values[matched] <- var_values[r]
121		}
122	64x	df[[var_name]] <- factor(relvar2_values)
123	64x	return(df)
124		}
125
126		#' Create Visit Schedule
127		#'
128		#' Create a visit schedule as a factor.
129		#'
130		#' X number of visits, or X number of cycles and Y number of days.
131		#'
132		#' @inheritParams argument_convention
133		#'
134		#' @return A factor of length `n_assessments`.
135		#' @export
136		#'
137		#' @examples
138		#' visit_schedule(visit_format = "WEeK", n_assessments = 10L)
139		#' visit_schedule(visit_format = "CyCLE", n_assessments = 5L, n_days = 2L)
140		visit_schedule <- function(visit_format = "WEEK",
141		n_assessments = 10L,
142		n_days = 5L) {
143	56x	checkmate::assert_string(visit_format, pattern = "^WEEK$\|^CYCLE$", ignore.case = TRUE)
144	56x	checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
145	56x	checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
146
147	56x	if (toupper(visit_format) == "WEEK") {
148		# numeric vector of n assessments/cycles/days
149	49x	assessments <- 1:n_assessments
150		# numeric vector for ordering including screening (-1) and baseline (0) place holders
151	49x	assessments_ord <- -1:n_assessments
152		# character vector of nominal visit values
153	49x	visit_values <- c("SCREENING", "BASELINE", paste(toupper(visit_format), assessments, "DAY", (assessments * 7) + 1))
154	7x	} else if (toupper(visit_format) == "CYCLE") {
155	7x	cycles <- sort(rep(1:n_assessments, times = 1, each = n_days))
156	7x	days <- rep(seq(1:n_days), times = n_assessments, each = 1)
157	7x	assessments_ord <- 0:(n_assessments * n_days)
158	7x	visit_values <- c("SCREENING", paste(toupper(visit_format), cycles, "DAY", days))
159		}
160
161		# create and order factor variable to return from function
162	56x	visit_values <- stats::reorder(factor(visit_values), assessments_ord)
163		}
164
165		#' Primary Keys: Retain Values
166		#'
167		#' Retain values within primary keys.
168		#'
169		#' @param df (`data.frame`)\cr Data frame in which to apply the retain.
170		#' @param value_var (`any`)\cr Variable in `df` containing the value to be retained.
171		#' @param event (`expression`)\cr Expression returning a logical value to trigger the retain.
172		#' @param outside (`any`)\cr Additional value to retain. Defaults to `NA`.
173		#' @return A vector of values where expression is true.
174		#' @keywords internal
175		retain <- function(df, value_var, event, outside = NA) {
176	31x	indices <- c(1, which(event == TRUE), nrow(df) + 1)
177	31x	values <- c(outside, value_var[event == TRUE])
178	31x	rep(values, diff(indices))
179		}
180
181		#' Primary Keys: Labels
182		#'
183		#' @description Shallow copy of `formatters::var_relabel()`. Used mainly internally to
184		#' relabel a subset of variables in a data set.
185		#'
186		#' @param x (`data.frame`)\cr Data frame containing variables to which labels are applied.
187		#' @param ... (`named character`)\cr Name-Value pairs, where name corresponds to a variable
188		#' name in `x` and the value to the new variable label.
189		#' @return x (`data.frame`)\cr Data frame with labels applied.
190		#'
191		#' @keywords internal
192		rcd_var_relabel <- function(x, ...) {
193	79x	stopifnot(is.data.frame(x))
194	79x	if (missing(...)) {
195	!	return(x)
196		}
197	79x	dots <- list(...)
198	79x	varnames <- names(dots)
199	79x	if (is.null(varnames)) {
200	1x	stop("missing variable declarations")
201		}
202	78x	map_varnames <- match(varnames, colnames(x))
203	78x	if (any(is.na(map_varnames))) {
204	!	stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found")
205		}
206	78x	if (any(vapply(dots, Negate(is.character), logical(1)))) {
207	!	stop("all variable labels must be of type character")
208		}
209	78x	for (i in seq_along(map_varnames)) {
210	155x	attr(x[[map_varnames[[i]]]], "label") <- dots[[i]]
211		}
212	78x	x
213		}
214
215		#' Apply Metadata
216		#'
217		#' Apply label and variable ordering attributes to domains.
218		#'
219		#' @param df (`data.frame`)\cr Data frame to which metadata is applied.
220		#' @param filename (`yaml`)\cr File containing domain metadata.
221		#' @param add_adsl (`logical`)\cr Should ADSL data be merged to domain.
222		#' @param adsl_filename (`yaml`)\cr File containing ADSL metadata.
223		#' @return Data frame with metadata applied.
224		#'
225		#' @export
226		#' @examples
227		#' seed <- 1
228		#' adsl <- radsl(seed = seed)
229		#' adsub <- radsub(adsl, seed = seed)
230		#' yaml_path <- file.path(path.package("random.cdisc.data"), "inst", "metadata")
231		#' adsl <- apply_metadata(adsl, file.path(yaml_path, "ADSL.yml"), FALSE)
232		#' adsub <- apply_metadata(
233		#' adsub, file.path(yaml_path, "ADSUB.yml"), TRUE,
234		#' file.path(yaml_path, "ADSL.yml")
235		#' )
236		apply_metadata <- function(df, filename, add_adsl = TRUE, adsl_filename = "metadata/ADSL.yml") {
237	90x	checkmate::assert_data_frame(df)
238	90x	checkmate::assert_string(filename)
239	90x	checkmate::assert_flag(add_adsl)
240	90x	checkmate::assert_string(adsl_filename)
241
242	90x	apply_type <- function(df, var, type) {
243	5986x	if (is.null(type)) {
244	!	return()
245		}
246
247	5986x	if (type == "character" && !is.character(df[[var]])) {
248	12x	df[[var]] <- as.character(df[[var]])
249	5974x	} else if (type == "factor" && !is.factor(df[[var]])) {
250	730x	df[[var]] <- as.factor(df[[var]])
251	5244x	} else if (type == "integer" && !is.integer(df[[var]])) {
252	225x	df[[var]] <- as.integer(df[[var]])
253	5019x	} else if (type == "numeric" && !is.numeric(df[[var]])) {
254	3x	df[[var]] <- as.numeric(df[[var]])
255	5016x	} else if (type == "logical" && !is.logical(df[[var]])) {
256	!	df[[var]] <- as.logical(df[[var]])
257	5016x	} else if (type == "datetime" && !lubridate::is.POSIXct(df[[var]])) {
258	9x	df[[var]] <- as.POSIXct(df[[var]])
259	5007x	} else if (type == "date" && !lubridate::is.Date(df[[var]])) {
260	!	df[[var]] <- as.Date(df[[var]])
261		}
262	5986x	return(df)
263		}
264
265		# remove existing attributes
266	90x	for (i in base::setdiff(names(attributes(df)), names(attributes(data.frame())))) {
267	3x	attr(df, i) <- NULL
268		}
269
270		# get metadata
271	90x	metadata <- yaml::yaml.load_file(system.file(filename, package = "random.cdisc.data"))
272	90x	adsl_metadata <- if (add_adsl) {
273	64x	yaml::yaml.load_file(system.file(adsl_filename, package = "random.cdisc.data"))
274		} else {
275	26x	NULL
276		}
277	90x	metadata_variables <- append(adsl_metadata$variables, metadata$variables)
278	90x	metadata_varnames <- names(metadata_variables)
279
280		# find variables that does not have labels and are not it metadata
281	90x	missing_vars_map <- vapply(
282	90x	names(df),
283	90x	function(x) {
284	5986x	!(x %in% c("STUDYID", "USUBJID", metadata_varnames)) && is.null(attr(df[[x]], "label"))
285		},
286	90x	logical(1)
287		)
288	90x	missing_vars <- names(df)[missing_vars_map]
289	90x	if (length(missing_vars) > 0) {
290	!	msg <- paste0(
291	!	"Following variables does not have label or are not found in ",
292	!	filename,
293		": ",
294	!	paste0(missing_vars, collapse = ", ")
295		)
296	!	warning(msg)
297		}
298
299	90x	if (!all(metadata_varnames %in% names(df))) {
300	6x	metadata_varnames <- metadata_varnames[metadata_varnames %in% names(df)]
301		}
302
303		# assign labels to variables
304	90x	for (var in metadata_varnames) {
305	5986x	df <- apply_type(df, var, metadata_variables[[var]]$type)
306	5986x	attr(df[[var]], "label") <- metadata_variables[[var]]$label
307		}
308
309		# reorder data frame columns to expected BDS order
310	90x	df <- df[, unique(c("STUDYID", "USUBJID", metadata_varnames, names(df)))]
311
312		# assign label to data frame
313	90x	attr(df, "label") <- metadata$domain$label
314
315	90x	df
316		}
317
318		#' Replace Values in a Vector by NA
319		#'
320		#' @description `r lifecycle::badge("stable")`
321		#'
322		#' Randomized replacement of values by `NA`.
323		#'
324		#' @inheritParams argument_convention
325		#' @param v (`any`)\cr Vector of any type.
326		#' @param percentage (`proportion`)\cr Value between 0 and 1 defining
327		#' how much of the vector shall be replaced by `NA`. This number
328		#' is randomized by +/- 5% to have full randomization.
329		#'
330		#' @return The input vector `v` where a certain number of values are replaced by `NA`.
331		#'
332		#' @export
333		replace_na <- function(v, percentage = 0.05, seed = NULL) {
334	9x	checkmate::assert_number(percentage, lower = 0, upper = 1)
335
336	9x	if (percentage == 0) {
337	1x	return(v)
338		}
339
340	8x	if (!is.null(seed) && !is.na(seed)) {
341	8x	set.seed(seed)
342		}
343
344		# randomize the percentage
345	8x	ind <- sample(seq_along(v), round(length(v) * percentage))
346
347	8x	v[ind] <- NA
348
349	8x	return(v)
350		}
351
352		#' Replace Values with NA
353		#'
354		#' @description `r lifecycle::badge("stable")`
355		#'
356		#' Replace column values with `NA`s.
357		#'
358		#' @inheritParams argument_convention
359		#' @param ds (`data.frame`)\cr Any data set.
360		#'
361		#' @return dataframe without `NA` values.
362		#'
363		#' @export
364		mutate_na <- function(ds, na_vars = NULL, na_percentage = 0.05) {
365	5x	if (!is.null(na_vars)) {
366	4x	stopifnot(is.list(na_vars)) # any list is OK; as values can be left NA
367	4x	stopifnot(length(names(na_vars)) == length(na_vars)) # names for all elements
368		} else {
369	1x	na_vars <- names(ds)
370		}
371
372	5x	stopifnot(is.numeric(na_percentage))
373	5x	stopifnot(na_percentage >= 0 && na_percentage < 1)
374
375	5x	for (na_var in names(na_vars)) {
376	8x	if (!is.na(na_var)) {
377	8x	if (!na_var %in% names(ds)) {
378	1x	warning(paste(na_var, "not in column names"))
379		} else {
380	7x	ds <- ds %>%
381	7x	ungroup_rowwise_df() %>%
382	7x	dplyr::mutate(
383	7x	!!na_var := ds[[na_var]] %>%
384	7x	replace_na(
385	7x	percentage = ifelse(is.na(na_vars[[na_var]][2]), na_percentage, na_vars[[na_var]][2]),
386	7x	seed = na_vars[[na_var]][1]
387		)
388		)
389		}
390		}
391		}
392	5x	return(ds)
393		}
394
395		ungroup_rowwise_df <- function(x) {
396	7x	class(x) <- c("tbl", "tbl_df", "data.frame")
397	7x	return(x)
398		}
399
400		#' Zero-Truncated Poisson Distribution
401		#'
402		#' @description `r lifecycle::badge("stable")`
403		#'
404		#' This generates random numbers from a zero-truncated Poisson distribution,
405		#' i.e. from `X \| X > 0` when `X ~ Poisson(lambda)`. The advantage here is that
406		#' we guarantee to return exactly `n` numbers and without using a loop internally.
407		#' This solution was provided in a post by
408		#' [Peter Dalgaard](https://stat.ethz.ch/pipermail/r-help/2005-May/070680.html).
409		#'
410		#' @param n (`numeric`)\cr Number of random numbers.
411		#' @param lambda (`numeric`)\cr Non-negative mean(s).
412		#'
413		#' @return The random numbers.
414		#' @export
415		#'
416		#' @examples
417		#' x <- rpois(1e6, lambda = 5)
418		#' x <- x[x > 0]
419		#' hist(x)
420		#'
421		#' y <- rtpois(1e6, lambda = 5)
422		#' hist(y)
423		rtpois <- function(n, lambda) {
424	121x	stats::qpois(stats::runif(n, stats::dpois(0, lambda), 1), lambda)
425		}
426
427		#' Truncated Exponential Distribution
428		#'
429		#' @description `r lifecycle::badge("stable")`
430		#'
431		#' This generates random numbers from a truncated Exponential distribution,
432		#' i.e. from `X \| X > l` or `X \| X < r` when `X ~ Exp(rate)`. The advantage here is that
433		#' we guarantee to return exactly `n` numbers and without using a loop internally.
434		#' This can be derived from the quantile functions of the left- and right-truncated
435		#' Exponential distributions.
436		#'
437		#' @param n (`numeric`)\cr Number of random numbers.
438		#' @param rate (`numeric`)\cr Non-negative rate.
439		#' @param l (`numeric`)\cr Positive left-hand truncation parameter.
440		#' @param r (`numeric`)\cr Positive right-hand truncation parameter.
441		#'
442		#' @return The random numbers. If neither `l` nor `r` are provided then the usual Exponential
443		#' distribution is used.
444		#' @export
445		#'
446		#' @examples
447		#' x <- stats::rexp(1e6, rate = 5)
448		#' x <- x[x > 0.5]
449		#' hist(x)
450		#'
451		#' y <- rtexp(1e6, rate = 5, l = 0.5)
452		#' hist(y)
453		#'
454		#' z <- rtexp(1e6, rate = 5, r = 0.5)
455		#' hist(z)
456		rtexp <- function(n, rate, l = NULL, r = NULL) {
457	123x	if (!is.null(l)) {
458	1x	l - log(1 - stats::runif(n)) / rate
459	122x	} else if (!is.null(r)) {
460	121x	-log(1 - stats::runif(n) * (1 - exp(-r * rate))) / rate
461		} else {
462	1x	stats::rexp(n, rate)
463		}
464		}

1		#' Hy's Law Analysis Dataset (ADHY)
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Function for generating a random Hy's Law Analysis Dataset for a given
6		#' Subject-Level Analysis Dataset.
7		#'
8		#' @details One record per subject per parameter per analysis visit per analysis date.
9		#'
10		#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`, `AVISITN`, `ADTM`, `SRCSEQ`
11		#
12		#' @inheritParams argument_convention
13		#' @template param_cached
14		#' @templateVar data adhy
15		#'
16		#' @return `data.frame`
17		#' @export
18		#'
19		#' @author wojciakw
20		#'
21		#' @examples
22		#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
23		#'
24		#' adhy <- radhy(adsl, seed = 2)
25		#' adhy
26		radhy <- function(adsl,
27		param = c(
28		"TBILI <= 2 times ULN and ALT value category",
29		"TBILI > 2 times ULN and AST value category",
30		"TBILI > 2 times ULN and ALT value category",
31		"TBILI <= 2 times ULN and AST value category",
32		"TBILI > 2 times ULN and ALKPH <= 2 times ULN and ALT value category",
33		"TBILI > 2 times ULN and ALKPH <= 2 times ULN and AST value category",
34		"TBILI > 2 times ULN and ALKPH <= 5 times ULN and ALT value category",
35		"TBILI > 2 times ULN and ALKPH <= 5 times ULN and AST value category",
36		"TBILI <= 2 times ULN and two consecutive elevations of ALT in relation to ULN",
37		"TBILI > 2 times ULN and two consecutive elevations of AST in relation to ULN",
38		"TBILI <= 2 times ULN and two consecutive elevations of AST in relation to ULN",
39		"TBILI > 2 times ULN and two consecutive elevations of ALT in relation to ULN",
40		"TBILI > 2 times ULN and two consecutive elevations of ALT in relation to Baseline",
41		"TBILI <= 2 times ULN and two consecutive elevations of ALT in relation to Baseline",
42		"TBILI > 2 times ULN and two consecutive elevations of AST in relation to Baseline",
43		"TBILI <= 2 times ULN and two consecutive elevations of AST in relation to Baseline",
44		"ALT > 3 times ULN by Period",
45		"AST > 3 times ULN by Period",
46		"ALT or AST > 3 times ULN by Period",
47		"ALT > 3 times Baseline by Period",
48		"AST > 3 times Baseline by Period",
49		"ALT or AST > 3 times Baseline by Period"
50		),
51		paramcd = c(
52		"BLAL",
53		"BGAS",
54		"BGAL",
55		"BLAS",
56		"BA2AL",
57		"BA2AS",
58		"BA5AL",
59		"BA5AS",
60		"BL2AL2CU",
61		"BG2AS2CU",
62		"BL2AS2CU",
63		"BG2AL2CU",
64		"BG2AL2CB",
65		"BL2AL2CB",
66		"BG2AS2CB",
67		"BL2AS2CB",
68		"ALTPULN",
69		"ASTPULN",
70		"ALTASTPU",
71		"ALTPBASE",
72		"ASTPBASE",
73		"ALTASTPB"
74		),
75		seed = NULL,
76		cached = FALSE) {
77	4x	checkmate::assert_flag(cached)
78
79	4x	if (cached) {
80	1x	return(get_cached_data("cadhy"))
81		}
82
83	3x	checkmate::assert_data_frame(adsl)
84	3x	checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
85	3x	checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
86	3x	checkmate::assert_number(seed, null.ok = TRUE)
87
88		# validate and initialize related variables
89	3x	param_init_list <- relvar_init(param, paramcd)
90
91	3x	if (!is.null(seed)) {
92	3x	set.seed(seed)
93		}
94	3x	study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))
95
96		# create all combinations of unique values in STUDYID, USUBJID, PARAM, AVISIT
97	3x	adhy <- expand.grid(
98	3x	STUDYID = unique(adsl$STUDYID),
99	3x	USUBJID = adsl$USUBJID,
100	3x	PARAM = as.factor(param_init_list$relvar1),
101	3x	AVISIT = as.factor(c("BASELINE", "POST-BASELINE")),
102	3x	APERIODC = as.factor(c("PERIOD 1", "PERIOD 2")),
103	3x	stringsAsFactors = FALSE
104		)
105
106		# remove records that are not needed and were created as a side product of expand.grid above
107	3x	adhy <- dplyr::filter(adhy, !(AVISIT == "BASELINE" & APERIODC == "PERIOD 2"))
108
109		# define TBILI ALT/AST params, period dependent parameters and the parameters that will be assigned values "Y" or "N"
110	3x	paramcd_tbilialtast <- c("BLAL", "BGAS", "BGAL", "BLAS", "BA2AL", "BA2AS", "BA5AL", "BA5AS")
111	3x	paramcd_by_period <- c("ALTPULN", "ASTPULN", "ALTASTPU", "ALTPBASE", "ASTPBASE", "ALTASTPB")
112	3x	paramcd_yn <- c(
113	3x	"BL2AL2CU", "BG2AS2CU", "BL2AS2CU", "BG2AL2CU", "BG2AL2CB", "BL2AL2CB", "BG2AS2CB", "BL2AS2CB",
114	3x	paramcd_by_period
115		)
116
117		# add other variables to adhy
118	3x	adhy <- adhy %>%
119	3x	rel_var(
120	3x	var_name = "PARAMCD",
121	3x	related_var = "PARAM",
122	3x	var_values = param_init_list$relvar2
123		) %>%
124	3x	dplyr::mutate(
125	3x	AVALC = dplyr::case_when(
126	3x	PARAMCD %in% paramcd_tbilialtast ~ sample(
127	3x	x = c(">3-5ULN", ">5-10ULN", ">10-20ULN", ">20ULN", "Criteria not met"), size = dplyr::n(), replace = TRUE
128		),
129	3x	PARAMCD %in% paramcd_yn ~ sample(
130	3x	x = c("Y", "N"), prob = c(0.1, 0.9), size = dplyr::n(), replace = TRUE
131		)
132		),
133	3x	AVAL = dplyr::case_when(
134	3x	AVALC == ">3-5ULN" ~ 1,
135	3x	AVALC == ">5-10ULN" ~ 2,
136	3x	AVALC == ">10-20ULN" ~ 3,
137	3x	AVALC == ">20ULN" ~ 4,
138	3x	AVALC == "Y" ~ 1,
139	3x	AVALC == "N" ~ 0,
140	3x	AVALC == "Criteria not met" ~ 0
141		),
142	3x	AVISITN = dplyr::case_when(
143	3x	AVISIT == "BASELINE" ~ 0L,
144	3x	AVISIT == "POST-BASELINE" ~ 9995L,
145	3x	TRUE ~ NA_integer_
146		),
147	3x	APERIOD = dplyr::case_when(
148	3x	APERIODC == "PERIOD 1" ~ 1L,
149	3x	APERIODC == "PERIOD 2" ~ 2L,
150	3x	TRUE ~ NA_integer_
151		),
152	3x	ABLFL = dplyr::if_else(AVISIT == "BASELINE", "Y", NA_character_),
153	3x	ONTRTFL = dplyr::if_else(AVISIT == "POST-BASELINE", "Y", NA_character_),
154	3x	ANL01FL = "Y",
155	3x	SRCSEQ = NA_integer_
156		)
157
158		# remove records for parameters with period 2 and not in paramcd_by_period
159	3x	adhy <- dplyr::filter(adhy, PARAMCD %in% paramcd_by_period \| APERIODC == "PERIOD 1")
160
161		# add baseline variables
162	3x	adhy <- adhy %>%
163	3x	dplyr::group_by(USUBJID, PARAMCD) %>%
164	3x	dplyr::mutate(
165	3x	BASEC = AVALC[AVISIT == "BASELINE"],
166	3x	BASE = AVAL[AVISIT == "BASELINE"]
167		) %>%
168	3x	dplyr::ungroup()
169
170	3x	adhy <- adhy %>%
171	3x	rcd_var_relabel(
172	3x	STUDYID = attr(adsl$STUDYID, "label"),
173	3x	USUBJID = attr(adsl$USUBJID, "label")
174		)
175
176		# merge ADSL to be able to add analysis datetime and analysis relative day variables
177	3x	adhy <- dplyr::inner_join(adhy, adsl, by = c("STUDYID", "USUBJID"))
178
179		# define a simple helper function to create ADY variable
180	3x	add_ady <- function(x, avisit) {
181	6x	if (avisit == "BASELINE") {
182	3x	dplyr::mutate(
183	3x	x,
184	3x	ADY = sample(x = -(1:14), size = dplyr::n(), replace = TRUE)
185		)
186	3x	} else if (avisit == "POST-BASELINE") {
187	3x	dplyr::rowwise(x) %>%
188	3x	dplyr::mutate(ADY = as.integer(sample(
189	3x	dplyr::if_else(
190	3x	!is.na(TRTEDTM),
191	3x	as.numeric(difftime(TRTEDTM, TRTSDTM, units = "days")),
192	3x	as.numeric(study_duration_secs, "days")
193		),
194	3x	size = 1,
195	3x	replace = TRUE
196		)))
197		} else {
198	!	dplyr::mutate(x, ADY = NA_integer_)
199		}
200		}
201
202		# add ADY and ADTM variables
203	3x	adhy <- adhy %>%
204	3x	dplyr::group_by(AVISIT, .add = FALSE) %>%
205	3x	dplyr::group_modify(~ add_ady(.x, .y$AVISIT)) %>%
206	3x	dplyr::ungroup() %>%
207	3x	dplyr::mutate(ADTM = TRTSDTM + lubridate::days(ADY))
208
209		# order columns and arrange rows; column order follows ADaM_1.1 specification
210	3x	adhy <-
211	3x	adhy[, c(
212	3x	colnames(adsl),
213	3x	"PARAM",
214	3x	"PARAMCD",
215	3x	"AVAL",
216	3x	"AVALC",
217	3x	"BASE",
218	3x	"BASEC",
219	3x	"ABLFL",
220	3x	"ADTM",
221	3x	"ADY",
222	3x	"AVISIT",
223	3x	"AVISITN",
224	3x	"APERIOD",
225	3x	"APERIODC",
226	3x	"ONTRTFL",
227	3x	"SRCSEQ",
228	3x	"ANL01FL"
229		)]
230
231	3x	adhy <- adhy %>%
232	3x	dplyr::arrange(
233	3x	STUDYID,
234	3x	USUBJID,
235	3x	PARAMCD,
236	3x	AVISITN,
237	3x	ADTM,
238	3x	SRCSEQ
239		)
240
241		# apply metadata
242	3x	adhy <- apply_metadata(adhy, "metadata/ADHY.yml")
243
244	3x	return(adhy)
245		}

1		#' Exposure Analysis Dataset (ADEX)
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Function for generating random Exposure Analysis Dataset for a given
6		#' Subject-Level Analysis Dataset.
7		#'
8		#' @details One record per each record in the corresponding SDTM domain.
9		#'
10		#' Keys: `STUDYID`, `USUBJID`, `EXSEQ`, `PARAMCD`, `PARCAT1`, `ASTDTM`, `AENDTM`, `ASTDY`, `AENDY`,
11		#' `AVISITN`, `EXDOSFRQ`, `EXROUTE`, `VISIT`, `VISITDY`, `EXSTDTC`, `EXENDTC`, `EXSTDY`, `EXENDY`
12		#'
13		#' @inheritParams argument_convention
14		#' @param parcat1 (`character vector`)\cr Dose amount categories. Defaults to "Individual" and "Overall".
15		#' @param parcat2 (`character vector`)\cr Types of drug received. Defaults to "Drug A" and "Drug B".
16		#' @param max_n_exs (`integer`)\cr Maximum number of exposures per patient. Defaults to 6.
17		#' @template param_cached
18		#' @templateVar data adex
19		#'
20		#' @return `data.frame`
21		#' @export
22		#'
23		#' @examples
24		#' adsl <- radsl(N = 10, study_duration = 2, seed = 1)
25		#'
26		#' adex <- radex(adsl, seed = 2)
27		#' adex
28		radex <- function(adsl,
29		param = c(
30		"Dose administered during constant dosing interval",
31		"Number of doses administered during constant dosing interval",
32		"Total dose administered",
33		"Total number of doses administered"
34		),
35		paramcd = c("DOSE", "NDOSE", "TDOSE", "TNDOSE"),
36		paramu = c("mg", " ", "mg", " "),
37		parcat1 = c("INDIVIDUAL", "OVERALL"),
38		parcat2 = c("Drug A", "Drug B"),
39		visit_format = "WEEK",
40		n_assessments = 5L,
41		n_days = 5L,
42		max_n_exs = 6L,
43		lookup = NULL,
44		seed = NULL,
45		na_percentage = 0,
46		na_vars = list(AVAL = c(NA, 0.1), AVALU = c(NA), 0.1),
47		cached = FALSE) {
48	4x	checkmate::assert_flag(cached)
49	4x	if (cached) {
50	1x	return(get_cached_data("cadex"))
51		}
52
53	3x	checkmate::assert_data_frame(adsl)
54	3x	checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
55	3x	checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
56	3x	checkmate::assert_character(parcat1, min.len = 1, any.missing = FALSE)
57	3x	checkmate::assert_character(parcat2, min.len = 1, any.missing = FALSE)
58	3x	checkmate::assert_string(visit_format)
59	3x	checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
60	3x	checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
61	3x	checkmate::assert_integer(max_n_exs, len = 1, any.missing = FALSE)
62	3x	checkmate::assert_data_frame(lookup, null.ok = TRUE)
63	3x	checkmate::assert_number(seed, null.ok = TRUE)
64	3x	checkmate::assert_number(na_percentage, lower = 0, upper = 1)
65	3x	checkmate::assert_true(na_percentage < 1)
66
67		# validate and initialize related variables
68	3x	param_init_list <- relvar_init(param, paramcd)
69	3x	unit_init_list <- relvar_init(param, paramu)
70
71	3x	if (!is.null(seed)) {
72	3x	set.seed(seed)
73		}
74	3x	study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))
75
76	3x	adex <- expand.grid(
77	3x	STUDYID = unique(adsl$STUDYID),
78	3x	USUBJID = adsl$USUBJID,
79	3x	PARAM = c(
80	3x	rep(
81	3x	param_init_list$relvar1[1],
82	3x	length(levels(visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days)))
83		),
84	3x	rep(
85	3x	param_init_list$relvar1[2],
86	3x	length(levels(visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days)))
87		),
88	3x	param_init_list$relvar1[3:4]
89		),
90	3x	stringsAsFactors = FALSE
91		)
92
93		# assign related variable values: PARAMxPARAMCD are related
94	3x	adex <- adex %>% rel_var(
95	3x	var_name = "PARAMCD",
96	3x	related_var = "PARAM",
97	3x	var_values = param_init_list$relvar2
98		)
99
100		# assign related variable values: AVALUxPARAM are related
101	3x	adex <- adex %>% rel_var(
102	3x	var_name = "AVALU",
103	3x	related_var = "PARAM",
104	3x	var_values = unit_init_list$relvar2
105		)
106
107	3x	adex <- adex %>%
108	3x	dplyr::group_by(USUBJID) %>%
109	3x	dplyr::mutate(PARCAT_ind = sample(c(1, 2), size = 1)) %>%
110	3x	dplyr::mutate(PARCAT2 = ifelse(PARCAT_ind == 1, parcat2[1], parcat2[2])) %>%
111	3x	dplyr::select(-"PARCAT_ind")
112
113		# Add in PARCAT1
114	3x	adex <- adex %>% dplyr::mutate(PARCAT1 = dplyr::case_when(
115	3x	(PARAMCD == "TNDOSE" \| PARAMCD == "TDOSE") ~ "OVERALL",
116	3x	PARAMCD == "DOSE" \| PARAMCD == "NDOSE" ~ "INDIVIDUAL"
117		))
118
119	3x	adex_visit <- adex %>%
120	3x	dplyr::filter(PARAMCD == "DOSE" \| PARAMCD == "NDOSE") %>%
121	3x	dplyr::mutate(
122	3x	AVISIT = rep(visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days), 2)
123		)
124
125	3x	adex <- dplyr::left_join(
126	3x	adex %>%
127	3x	dplyr::group_by(
128	3x	USUBJID,
129	3x	STUDYID,
130	3x	PARAM,
131	3x	PARAMCD,
132	3x	AVALU,
133	3x	PARCAT1,
134	3x	PARCAT2
135		) %>%
136	3x	dplyr::mutate(id = dplyr::row_number()),
137	3x	adex_visit %>%
138	3x	dplyr::group_by(
139	3x	USUBJID,
140	3x	STUDYID,
141	3x	PARAM,
142	3x	PARAMCD,
143	3x	AVALU,
144	3x	PARCAT1,
145	3x	PARCAT2
146		) %>%
147	3x	dplyr::mutate(id = dplyr::row_number()),
148	3x	by = c("USUBJID", "STUDYID", "PARCAT1", "PARCAT2", "id", "PARAMCD", "PARAM", "AVALU")
149		) %>%
150	3x	dplyr::select(-"id")
151
152		# Visit numbers
153	3x	adex <- adex %>% dplyr::mutate(AVISITN = dplyr::case_when(
154	3x	AVISIT == "SCREENING" ~ -1,
155	3x	AVISIT == "BASELINE" ~ 0,
156	3x	(grepl("^WEEK", AVISIT) \| grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
157	3x	TRUE ~ 999000
158		))
159
160
161	3x	adex2 <- split(adex, adex$USUBJID) %>%
162	3x	lapply(function(pinfo) {
163	30x	pinfo %>%
164	30x	dplyr::filter(PARAMCD == "DOSE") %>%
165	30x	dplyr::group_by(USUBJID, PARCAT2, AVISIT) %>%
166	30x	dplyr::mutate(changeind = dplyr::case_when(
167	30x	AVISIT == "SCREENING" ~ 0,
168	30x	AVISIT != "SCREENING" ~ sample(c(-1, 0, 1),
169	30x	size = 1,
170	30x	prob = c(0.25, 0.5, 0.25),
171	30x	replace = TRUE
172		)
173		)) %>%
174	30x	dplyr::ungroup() %>%
175	30x	dplyr::group_by(USUBJID, PARCAT2) %>%
176	30x	dplyr::mutate(
177	30x	csum = cumsum(changeind),
178	30x	changeind = dplyr::case_when(
179	30x	csum <= -3 ~ sample(c(0, 1), size = 1, prob = c(0.5, 0.5)),
180	30x	csum >= 3 ~ sample(c(0, -1), size = 1, prob = c(0.5, 0.5)),
181	30x	TRUE ~ changeind
182		)
183		) %>%
184	30x	dplyr::mutate(csum = cumsum(changeind)) %>%
185	30x	dplyr::ungroup() %>%
186	30x	dplyr::group_by(USUBJID, PARCAT2, AVISIT) %>%
187	30x	dplyr::mutate(AVAL = dplyr::case_when(
188	30x	csum == -2 ~ 480,
189	30x	csum == -1 ~ 720,
190	30x	csum == 0 ~ 960,
191	30x	csum == 1 ~ 1200,
192	30x	csum == 2 ~ 1440
193		)) %>%
194	30x	dplyr::select(-c("csum", "changeind")) %>%
195	30x	dplyr::ungroup()
196		}) %>%
197	3x	Reduce(rbind, .)
198
199	3x	adex_tmp <- dplyr::full_join(adex2, adex, by = names(adex))
200	3x	adex <- adex_tmp %>%
201	3x	dplyr::group_by(USUBJID) %>%
202	3x	dplyr::mutate(AVAL = ifelse(PARAMCD == "NDOSE", 1, AVAL)) %>%
203	3x	dplyr::mutate(AVAL = ifelse(
204	3x	PARAMCD == "TNDOSE",
205	3x	sum(AVAL[PARAMCD == "NDOSE"]),
206	3x	AVAL
207		)) %>%
208	3x	dplyr::ungroup() %>%
209	3x	dplyr::group_by(USUBJID, STUDYID, PARCAT2) %>%
210	3x	dplyr::mutate(AVAL = ifelse(
211	3x	PARAMCD == "TDOSE",
212	3x	sum(AVAL[PARAMCD == "DOSE"]),
213	3x	AVAL
214		))
215
216	3x	adex <- rcd_var_relabel(
217	3x	adex,
218	3x	STUDYID = "Study Identifier",
219	3x	USUBJID = "Unique Subject Identifier"
220		)
221
222		# merge ADSL to be able to add ADEX date and study day variables
223	3x	adex <- dplyr::inner_join(adex, adsl, by = c("STUDYID", "USUBJID")) %>%
224	3x	dplyr::rowwise() %>%
225	3x	dplyr::mutate(TRTENDT = lubridate::date(dplyr::case_when(
226	3x	is.na(TRTEDTM) ~ lubridate::floor_date(lubridate::date(TRTSDTM) + study_duration_secs, unit = "day"),
227	3x	TRUE ~ TRTEDTM
228		))) %>%
229	3x	dplyr::mutate(ASTDTM = sample(
230	3x	seq(lubridate::as_datetime(TRTSDTM), lubridate::as_datetime(TRTENDT), by = "day"),
231	3x	size = 1
232		)) %>%
233		# add 1 to end of range incase both values passed to sample() are the same
234	3x	dplyr::mutate(AENDTM = sample(
235	3x	seq(lubridate::as_datetime(ASTDTM), lubridate::as_datetime(TRTENDT + 1), by = "day"),
236	3x	size = 1
237		)) %>%
238	3x	dplyr::select(-TRTENDT) %>%
239	3x	dplyr::ungroup() %>%
240	3x	dplyr::arrange(STUDYID, USUBJID, ASTDTM)
241
242
243	3x	adex <- adex %>%
244	3x	dplyr::group_by(USUBJID) %>%
245	3x	dplyr::mutate(EXSEQ = seq_len(dplyr::n())) %>%
246	3x	dplyr::mutate(ASEQ = EXSEQ) %>%
247	3x	dplyr::ungroup() %>%
248	3x	dplyr::arrange(
249	3x	STUDYID,
250	3x	USUBJID,
251	3x	PARAMCD,
252	3x	ASTDTM,
253	3x	AVISITN,
254	3x	EXSEQ
255		)
256
257		# Adding EXDOSFRQ
258	3x	adex <- adex %>%
259	3x	dplyr::mutate(EXDOSFRQ = dplyr::case_when(
260	3x	PARCAT1 == "INDIVIDUAL" ~ "ONCE",
261	3x	TRUE ~ ""
262		))
263
264		# Adding EXROUTE
265	3x	adex <- adex %>%
266	3x	dplyr::mutate(EXROUTE = dplyr::case_when(
267	3x	PARCAT1 == "INDIVIDUAL" ~ sample(c("INTRAVENOUS", "SUBCUTANEOUS"),
268	3x	nrow(adex),
269	3x	replace = TRUE,
270	3x	prob = c(0.9, 0.1)
271		),
272	3x	TRUE ~ ""
273		))
274
275		# Fix VISIT according to AVISIT
276	3x	adex <- adex %>%
277	3x	dplyr::mutate(VISIT = AVISIT)
278
279		# Hack for VISITDY - to fix in ADSL
280	3x	visit_levels <- str_extract(levels(adex$VISIT), pattern = "[0-9]+")
281	3x	vl_extracted <- vapply(visit_levels, function(x) as.numeric(x[2]), numeric(1))
282	3x	vl_extracted <- c(-1, 1, vl_extracted[!is.na(vl_extracted)])
283
284		# Adding VISITDY
285	3x	adex <- adex %>%
286	3x	dplyr::mutate(VISITDY = as.numeric(as.character(factor(VISIT, labels = vl_extracted))))
287
288		# Exposure time stamps
289	3x	adex <- adex %>%
290	3x	dplyr::mutate(
291	3x	EXSTDTC = TRTSDTM + lubridate::days(VISITDY),
292	3x	EXENDTC = EXSTDTC + lubridate::hours(1),
293	3x	EXSTDY = VISITDY,
294	3x	EXENDY = VISITDY
295		)
296
297		# Correcting last exposure to treatment
298	3x	adex <- adex %>%
299	3x	dplyr::group_by(SUBJID) %>%
300	3x	dplyr::mutate(TRTEDTM = lubridate::as_datetime(max(EXENDTC, na.rm = TRUE))) %>%
301	3x	dplyr::ungroup()
302
303		# Fixing Date - to add into ADSL
304	3x	adex <- adex %>%
305	3x	dplyr::mutate(
306	3x	TRTSDT = lubridate::date(TRTSDTM),
307	3x	TRTEDT = lubridate::date(TRTEDTM)
308		)
309
310		# Fixing analysis time stamps
311	3x	adex <- adex %>%
312	3x	dplyr::mutate(
313	3x	ASTDY = EXSTDY,
314	3x	AENDY = EXENDY,
315	3x	ASTDTM = EXSTDTC,
316	3x	AENDTM = EXENDTC
317		)
318
319	3x	if (length(na_vars) > 0 && na_percentage > 0) {
320	!	adex <- mutate_na(ds = adex, na_vars = na_vars, na_percentage = na_percentage)
321		}
322
323		# apply metadata
324	3x	adex <- apply_metadata(adex, "metadata/ADEX.yml")
325		}
326
327		# Equivalent of stringr::str_extract_all()
328		str_extract <- function(string, pattern) {
329	2850x	regmatches(string, gregexpr(pattern, string))
330		}

1		#' Laboratory Data Analysis Dataset (ADLB)
2		#'
3		#' @description `r lifecycle::badge("stable")`
4		#'
5		#' Function for generating a random Laboratory Data Analysis Dataset for a given
6		#' Subject-Level Analysis Dataset.
7		#'
8		#' @details One record per subject per parameter per analysis visit per analysis date.
9		#'
10		#' Keys: `STUDYID`, `USUBJID`, `PARAMCD`, `BASETYPE`, `AVISITN`, `ATPTN`, `DTYPE`, `ADTM`, `LBSEQ`, `ASPID`
11		#
12		#' @inheritParams argument_convention
13		#' @param lbcat (`character vector`)\cr LB category values.
14		#' @param max_n_lbs (`integer`)\cr Maximum number of labs per patient. Defaults to 10.
15		#' @template param_cached
16		#' @templateVar data adlb
17		#'
18		#' @return `data.frame`
19		#' @export
20		#'
21		#' @author tomlinsj, npaszty, Xuefeng Hou
22		#'
23		#' @examples
24		#' adsl <- radsl(N = 10, seed = 1, study_duration = 2)
25		#'
26		#' adlb <- radlb(adsl, visit_format = "WEEK", n_assessments = 7L, seed = 2)
27		#' adlb
28		#'
29		#' adlb <- radlb(adsl, visit_format = "CYCLE", n_assessments = 2L, seed = 2)
30		#' adlb
31		radlb <- function(adsl,
32		lbcat = c("CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
33		param = c(
34		"Alanine Aminotransferase Measurement",
35		"C-Reactive Protein Measurement",
36		"Immunoglobulin A Measurement"
37		),
38		paramcd = c("ALT", "CRP", "IGA"),
39		paramu = c("U/L", "mg/L", "g/L"),
40		aval_mean = c(18, 9, 2.9),
41		visit_format = "WEEK",
42		n_assessments = 5L,
43		n_days = 5L,
44		max_n_lbs = 10L,
45		lookup = NULL,
46		seed = NULL,
47		na_percentage = 0,
48		na_vars = list(
49		LOQFL = c(NA, 0.1), ABLFL2 = c(1234, 0.1), ABLFL = c(1235, 0.1),
50		BASE2 = c(NA, 0.1), BASE = c(NA, 0.1),
51		CHG2 = c(1235, 0.1), PCHG2 = c(1235, 0.1), CHG = c(1234, 0.1), PCHG = c(1234, 0.1)
52		),
53		cached = FALSE) {
54	4x	checkmate::assert_flag(cached)
55	4x	if (cached) {
56	1x	return(get_cached_data("cadlb"))
57		}
58
59	3x	checkmate::assert_data_frame(adsl)
60	3x	checkmate::assert_character(param, min.len = 1, any.missing = FALSE)
61	3x	checkmate::assert_character(paramcd, min.len = 1, any.missing = FALSE)
62	3x	checkmate::assert_character(paramu, min.len = 1, any.missing = FALSE)
63	3x	checkmate::assert_character(lbcat, min.len = 1, any.missing = FALSE)
64	3x	checkmate::assert_string(visit_format)
65	3x	checkmate::assert_integer(n_assessments, len = 1, any.missing = FALSE)
66	3x	checkmate::assert_integer(n_days, len = 1, any.missing = FALSE)
67	3x	checkmate::assert_integer(max_n_lbs, len = 1, any.missing = FALSE)
68	3x	checkmate::assert_data_frame(lookup, null.ok = TRUE)
69	3x	checkmate::assert_number(seed, null.ok = TRUE)
70	3x	checkmate::assert_number(na_percentage, lower = 0, upper = 1)
71	3x	checkmate::assert_true(na_percentage < 1)
72
73		# validate and initialize related variables
74	3x	lbcat_init_list <- relvar_init(param, lbcat)
75	3x	param_init_list <- relvar_init(param, paramcd)
76	3x	unit_init_list <- relvar_init(param, paramu)
77
78	3x	if (!is.null(seed)) {
79	3x	set.seed(seed)
80		}
81	3x	study_duration_secs <- lubridate::seconds(attr(adsl, "study_duration_secs"))
82
83	3x	adlb <- expand.grid(
84	3x	STUDYID = unique(adsl$STUDYID),
85	3x	USUBJID = adsl$USUBJID,
86	3x	PARAM = as.factor(param_init_list$relvar1),
87	3x	AVISIT = visit_schedule(visit_format = visit_format, n_assessments = n_assessments, n_days = n_days),
88	3x	stringsAsFactors = FALSE
89		)
90
91		# assign AVAL based on different tests
92	3x	adlb <- adlb %>% mutate(AVAL = case_when(
93	3x	PARAM == param[1] ~ abs(stats::rnorm(nrow(adlb), mean = aval_mean[1], sd = 10)),
94	3x	PARAM == param[2] ~ abs(stats::rnorm(nrow(adlb), mean = aval_mean[2], sd = 1)),
95	3x	PARAM == param[3] ~ abs(stats::rnorm(nrow(adlb), mean = aval_mean[3], sd = 0.1))
96		))
97
98		# assign related variable values: PARAMxLBCAT are related
99	3x	adlb <- adlb %>% rel_var(
100	3x	var_name = "LBCAT",
101	3x	related_var = "PARAM",
102	3x	var_values = lbcat_init_list$relvar2
103		)
104
105		# assign related variable values: PARAMxPARAMCD are related
106	3x	adlb <- adlb %>% rel_var(
107	3x	var_name = "PARAMCD",
108	3x	related_var = "PARAM",
109	3x	var_values = param_init_list$relvar2
110		)
111
112	3x	adlb <- adlb %>%
113	3x	dplyr::mutate(LBTESTCD = PARAMCD) %>%
114	3x	dplyr::mutate(LBTEST = PARAM)
115
116	3x	adlb <- adlb %>% dplyr::mutate(AVISITN = dplyr::case_when(
117	3x	AVISIT == "SCREENING" ~ -1,
118	3x	AVISIT == "BASELINE" ~ 0,
119	3x	(grepl("^WEEK", AVISIT) \| grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
120	3x	TRUE ~ NA_real_
121		))
122
123	3x	adlb <- adlb %>% rel_var(
124	3x	var_name = "AVALU",
125	3x	related_var = "PARAM",
126	3x	var_values = unit_init_list$relvar2
127		)
128
129	3x	adlb <- adlb %>%
130	3x	dplyr::mutate(AVISITN = dplyr::case_when(
131	3x	AVISIT == "SCREENING" ~ -1,
132	3x	AVISIT == "BASELINE" ~ 0,
133	3x	(grepl("^WEEK", AVISIT) \| grepl("^CYCLE", AVISIT)) ~ as.numeric(AVISIT) - 2,
134	3x	TRUE ~ NA_real_
135		))
136
137		# order to prepare for change from screening and baseline values
138	3x	adlb <- adlb[order(adlb$STUDYID, adlb$USUBJID, adlb$PARAMCD, adlb$AVISITN), ]
139
140	3x	adlb <- Reduce(rbind, lapply(split(adlb, adlb$USUBJID), function(x) {
141	30x	x$STUDYID <- adsl$STUDYID[which(adsl$USUBJID == x$USUBJID[1])]
142	30x	x$ABLFL2 <- ifelse(x$AVISIT == "SCREENING", "Y", "")
143	30x	x$ABLFL <- ifelse(toupper(visit_format) == "WEEK" & x$AVISIT == "BASELINE",
144	30x	"Y",
145	30x	ifelse(toupper(visit_format) == "CYCLE" & x$AVISIT == "CYCLE 1 DAY 1", "Y", "")
146		)
147	30x	x
148		}))
149
150	3x	adlb$BASE2 <- retain(adlb, adlb$AVAL, adlb$ABLFL2 == "Y")
151	3x	adlb$BASE <- ifelse(adlb$ABLFL2 != "Y", retain(adlb, adlb$AVAL, adlb$ABLFL == "Y"), NA)
152
153	3x	adlb <- adlb %>%
154	3x	dplyr::mutate(CHG2 = AVAL - BASE2) %>%
155	3x	dplyr::mutate(PCHG2 = 100 * (CHG2 / BASE2)) %>%
156	3x	dplyr::mutate(CHG = AVAL - BASE) %>%
157	3x	dplyr::mutate(PCHG = 100 * (CHG / BASE)) %>%
158	3x	dplyr::mutate(BASETYPE = "LAST") %>%
159	3x	dplyr::mutate(ANRLO = dplyr::case_when(
160	3x	PARAMCD == "ALT" ~ 7,
161	3x	PARAMCD == "CRP" ~ 8,
162	3x	PARAMCD == "IGA" ~ 0.8
163		)) %>%
164	3x	dplyr::mutate(ANRHI = dplyr::case_when(
165	3x	PARAMCD == "ALT" ~ 55,
166	3x	PARAMCD == "CRP" ~ 10,
167	3x	PARAMCD == "IGA" ~ 3
168		)) %>%
169	3x	dplyr::mutate(ANRIND = factor(dplyr::case_when(
170	3x	AVAL < ANRLO ~ "LOW",
171	3x	AVAL > ANRHI ~ "HIGH",
172	3x	TRUE ~ "NORMAL"
173		))) %>%
174	3x	dplyr::mutate(LBSTRESC = factor(dplyr::case_when(
175	3x	PARAMCD == "ALT" ~ "<7",
176	3x	PARAMCD == "CRP" ~ "<8",
177	3x	PARAMCD == "IGA" ~ ">3"
178		))) %>%
179	3x	dplyr::rowwise() %>%
180	3x	dplyr::mutate(LOQFL = factor(
181	3x	ifelse(eval(parse(text = paste(AVAL, LBSTRESC))), "Y", "N")
182		)) %>%
183	3x	dplyr::ungroup() %>%
184	3x	dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
185	3x	dplyr::mutate(BNRIND = ANRIND[ABLFL == "Y"]) %>%
186	3x	dplyr::ungroup() %>%
187	3x	dplyr::mutate(SHIFT1 = factor(ifelse(
188	3x	AVISITN > 0,
189	3x	paste(
190	3x	retain(
191	3x	adlb, as.character(BNRIND),
192	3x	AVISITN == 0
193		),
194	3x	ANRIND,
195	3x	sep = " to "
196		),
197		""
198		))) %>%
199	3x	dplyr::mutate(ATOXGR = factor(dplyr::case_when(
200	3x	ANRIND == "LOW" ~ sample(
201	3x	c("-1", "-2", "-3", "-4", "-5"),
202	3x	nrow(adlb),
203	3x	replace = TRUE,
204	3x	prob = c(0.30, 0.25, 0.20, 0.15, 0)
205		),
206	3x	ANRIND == "HIGH" ~ sample(
207	3x	c("1", "2", "3", "4", "5"),
208	3x	nrow(adlb),
209	3x	replace = TRUE,
210	3x	prob = c(0.30, 0.25, 0.20, 0.15, 0)
211		),
212	3x	ANRIND == "NORMAL" ~ "0"
213		))) %>%
214	3x	dplyr::group_by(USUBJID, PARAMCD, BASETYPE) %>%
215	3x	dplyr::mutate(BTOXGR = ATOXGR[ABLFL == "Y"]) %>%
216	3x	dplyr::ungroup() %>%
217	3x	dplyr::mutate(ATPTN = 1) %>%
218	3x	dplyr::mutate(DTYPE = NA) %>%
219	3x	dplyr::mutate(BTOXGRL = factor(dplyr::case_when(
220	3x	BTOXGR == "0" ~ "0",
221	3x	BTOXGR == "-1" ~ "1",
222	3x	BTOXGR == "-2" ~ "2",
223	3x	BTOXGR == "-3" ~ "3",
224	3x	BTOXGR == "-4" ~ "4",
225	3x	BTOXGR == "1" ~ "<Missing>",
226	3x	BTOXGR == "2" ~ "<Missing>",
227	3x	BTOXGR == "3" ~ "<Missing>",
228	3x	BTOXGR == "4" ~ "<Missing>"
229		))) %>%
230	3x	dplyr::mutate(BTOXGRH = factor(dplyr::case_when(
231	3x	BTOXGR == "0" ~ "0",
232	3x	BTOXGR == "1" ~ "1",
233	3x	BTOXGR == "2" ~ "2",
234	3x	BTOXGR == "3" ~ "3",
235	3x	BTOXGR == "4" ~ "4",
236	3x	BTOXGR == "-1" ~ "<Missing>",
237	3x	BTOXGR == "-2" ~ "<Missing>",
238	3x	BTOXGR == "-3" ~ "<Missing>",
239	3x	BTOXGR == "-4" ~ "<Missing>",
240		))) %>%
241	3x	dplyr::mutate(ATOXGRL = factor(dplyr::case_when(
242	3x	ATOXGR == "0" ~ "0",
243	3x	ATOXGR == "-1" ~ "1",
244	3x	ATOXGR == "-2" ~ "2",
245	3x	ATOXGR == "-3" ~ "3",
246	3x	ATOXGR == "-4" ~ "4",
247	3x	ATOXGR == "1" ~ "<Missing>",
248	3x	ATOXGR == "2" ~ "<Missing>",
249	3x	ATOXGR == "3" ~ "<Missing>",
250	3x	ATOXGR == "4" ~ "<Missing>",
251		))) %>%
252	3x	dplyr::mutate(ATOXGRH = factor(dplyr::case_when(
253	3x	ATOXGR == "0" ~ "0",
254	3x	ATOXGR == "1" ~ "1",
255	3x	ATOXGR == "2" ~ "2",
256	3x	ATOXGR == "3" ~ "3",
257	3x	ATOXGR == "4" ~ "4",
258	3x	ATOXGR == "-1" ~ "<Missing>",
259	3x	ATOXGR == "-2" ~ "<Missing>",
260	3x	ATOXGR == "-3" ~ "<Missing>",
261	3x	ATOXGR == "-4" ~ "<Missing>",
262		))) %>%
263	3x	rcd_var_relabel(
264	3x	STUDYID = attr(adsl$STUDYID, "label"),
265	3x	USUBJID = attr(adsl$USUBJID, "label")
266		)
267
268		# High and low descriptions of the different PARAMCD values
269		# This is currently hard coded as the GDSR does not have these descriptions yet
270	3x	grade_lookup <- tibble::tribble(
271	3x	~PARAMCD, ~ATOXDSCL, ~ATOXDSCH,
272	3x	"ALB", "Hypoalbuminemia", NA_character_,
273	3x	"ALKPH", NA_character_, "Alkaline phosphatase increased",
274	3x	"ALT", NA_character_, "Alanine aminotransferase increased",
275	3x	"AST", NA_character_, "Aspartate aminotransferase increased",
276	3x	"BILI", NA_character_, "Blood bilirubin increased",
277	3x	"CA", "Hypocalcemia", "Hypercalcemia",
278	3x	"CHOLES", NA_character_, "Cholesterol high",
279	3x	"CK", NA_character_, "CPK increased",
280	3x	"CREAT", NA_character_, "Creatinine increased",
281	3x	"CRP", NA_character_, "C reactive protein increased",
282	3x	"GGT", NA_character_, "GGT increased",
283	3x	"GLUC", "Hypoglycemia", "Hyperglycemia",
284	3x	"HGB", "Anemia", "Hemoglobin increased",
285	3x	"IGA", NA_character_, "Immunoglobulin A increased",
286	3x	"POTAS", "Hypokalemia", "Hyperkalemia",
287	3x	"LYMPH", "CD4 lymphocytes decreased", NA_character_,
288	3x	"PHOS", "Hypophosphatemia", NA_character_,
289	3x	"PLAT", "Platelet count decreased", NA_character_,
290	3x	"SODIUM", "Hyponatremia", "Hypernatremia",
291	3x	"WBC", "White blood cell decreased", "Leukocytosis",
292		)
293
294		# merge grade_lookup onto adlb
295	3x	adlb <- dplyr::left_join(adlb, grade_lookup, by = "PARAMCD")
296
297	3x	adlb <- rcd_var_relabel(
298	3x	adlb,
299	3x	STUDYID = "Study Identifier",
300	3x	USUBJID = "Unique Subject Identifier"
301		)
302
303		# merge ADSL to be able to add LB date and study day variables
304	3x	adlb <- dplyr::inner_join(
305	3x	adlb,
306	3x	adsl,
307	3x	by = c("STUDYID", "USUBJID")
308		) %>%
309	3x	dplyr::rowwise() %>%
310	3x	dplyr::mutate(TRTENDT = lubridate::date(dplyr::case_when(
311	3x	is.na(TRTEDTM) ~ lubridate::floor_date(lubridate::date(TRTSDTM) + study_duration_secs, unit = "day"),
312	3x	TRUE ~ TRTEDTM
313		))) %>%
314	3x	dplyr::ungroup()
315
316	3x	adlb <- adlb %>%
317	3x	dplyr::group_by(USUBJID) %>%
318	3x	dplyr::arrange(USUBJID, AVISITN) %>%
319	3x	dplyr::mutate(ADTM = rep(
320	3x	sort(sample(
321	3x	seq(lubridate::as_datetime(TRTSDTM[1]), lubridate::as_datetime(TRTENDT[1]), by = "day"),
322	3x	size = nlevels(AVISIT)
323		)),
324	3x	each = n() / nlevels(AVISIT)
325		)) %>%
326	3x	dplyr::ungroup() %>%
327	3x	dplyr::mutate(ADY = ceiling(difftime(ADTM, TRTSDTM, units = "days"))) %>%
328	3x	dplyr::select(-TRTENDT) %>%
329	3x	dplyr::arrange(STUDYID, USUBJID, ADTM)
330
331	3x	adlb <- adlb %>%
332	3x	dplyr::mutate(ASPID = sample(seq_len(dplyr::n()))) %>%
333	3x	dplyr::group_by(USUBJID) %>%
334	3x	dplyr::mutate(LBSEQ = seq_len(dplyr::n())) %>%
335	3x	dplyr::mutate(ASEQ = LBSEQ) %>%
336	3x	dplyr::ungroup() %>%
337	3x	dplyr::arrange(
338	3x	STUDYID,
339	3x	USUBJID,
340	3x	PARAMCD,
341	3x	BASETYPE,
342	3x	AVISITN,
343	3x	ATPTN,
344	3x	DTYPE,
345	3x	ADTM,
346	3x	LBSEQ,
347	3x	ASPID
348		)
349
350	3x	adlb <- adlb %>% dplyr::mutate(ONTRTFL = factor(dplyr::case_when(
351	3x	!AVISIT %in% c("SCREENING", "BASELINE") ~ "Y",
352	3x	TRUE ~ ""
353		)))
354
355	3x	flag_variables <- function(data,
356	3x	apply_grouping,
357	3x	apply_filter,
358	3x	apply_mutate) {
359	15x	data_compare <- data %>%
360	15x	dplyr::mutate(row_check = seq_len(nrow(data)))
361
362	15x	data <- data_compare %>%
363		{
364	15x	if (apply_grouping == TRUE) {
365	9x	dplyr::group_by(., USUBJID, PARAMCD, BASETYPE, AVISIT)
366		} else {
367	6x	dplyr::group_by(., USUBJID, PARAMCD, BASETYPE)
368		}
369		} %>%
370	15x	dplyr::arrange(ADTM, ASPID, LBSEQ) %>%
371