Nothing
#' @noRd
checkInterval <- function(interval, call = parent.frame()) {
omopgenerics::assertCharacter(interval, length = 1, na = FALSE, null = FALSE, call = call)
if (!interval %in% c("year", "month")) {
cli::cli_abort("Interval argument {interval} is not valid. Valid options are either `year` or `month`.", call = call)
}
}
validateIntervals <- function(interval, call = parent.frame()) {
omopgenerics::assertCharacter(interval, length = 1, na = FALSE, null = FALSE, call = call)
if (!interval %in% c("overall", "years", "months", "quarters")) {
cli::cli_abort("Interval argument {interval} is not valid. Valid options are either `overall`, `years`, `quarters` or `months`.", call = call)
}
unitInterval <- dplyr::case_when(
interval == "overall" ~ NA,
interval == "quarters" ~ 3,
interval == "months" ~ 1,
interval == "years" ~ 1
)
if (interval == "quarters") {
quarters <- "month"
} else {
interval <- gsub("s$", "", interval)
}
return(list("interval" = interval, "unitInterval" = unitInterval))
}
#' @noRd
checkCategory <- function(category, overlap = FALSE, type = "numeric", call = parent.frame()) {
omopgenerics::assertList(
category,
types = type, any.missing = FALSE, unique = TRUE,
min.len = 1
)
if (is.null(names(category))) {
names(category) <- rep("", length(category))
}
# check length
category <- lapply(category, function(x) {
if (length(x) == 1) {
x <- c(x, x)
} else if (length(x) > 2) {
cli::cli_abort(
paste0(
"Categories should be formed by a lower bound and an upper bound, ",
"no more than two elements should be provided."
),
call. = FALSE
)
}
invisible(x)
})
# check lower bound is smaller than upper bound
checkLower <- unlist(lapply(category, function(x) {
x[1] <= x[2]
}))
if (!(all(checkLower))) {
cli::cli_abort("Lower bound should be equal or smaller than upper bound", call = call)
}
# built tibble
result <- lapply(category, function(x, call = parent.frame()) {
dplyr::tibble(lower_bound = x[1], upper_bound = x[2])
}) |>
dplyr::bind_rows() |>
dplyr::mutate(category_label = names(.env$category)) |>
dplyr::mutate(category_label = dplyr::if_else(
.data$category_label == "",
dplyr::case_when(
is.infinite(.data$lower_bound) & is.infinite(.data$upper_bound) ~ "any",
is.infinite(.data$lower_bound) ~ paste(.data$upper_bound, "or below"),
is.infinite(.data$upper_bound) ~ paste(.data$lower_bound, "or above"),
TRUE ~ paste(.data$lower_bound, "to", .data$upper_bound)
),
.data$category_label
)) |>
dplyr::arrange(.data$lower_bound)
# check overlap
if (!overlap) {
if (nrow(result) > 1) {
lower <- result$lower_bound[2:nrow(result)]
upper <- result$upper_bound[1:(nrow(result) - 1)]
if (!all(lower > upper)) {
cli::cli_abort("There can not be overlap between categories", call = call)
}
}
}
invisible(result)
}
#' @noRd
validateStudyPeriod <- function(cdm, studyPeriod, call = parent.frame()) {
if (is.null(studyPeriod)) {
return(NULL)
}
# First date checks
if (!is.na(studyPeriod[1]) & !is.na(studyPeriod[2]) & studyPeriod[1] > studyPeriod[2]) {
cli::cli_abort("The studyPeriod ends at a date earlier than the start provided.", call = call)
}
if (!is.na(studyPeriod[1]) & is.na(as.Date(studyPeriod[1], format = "%d/%m/%Y")) && is.na(as.Date(studyPeriod[1], format = "%Y-%m-%d"))) {
cli::cli_abort("Please ensure that dates provided are in the correct format.", call = call)
}
if (!is.na(studyPeriod[2]) & is.na(as.Date(studyPeriod[2], format = "%d/%m/%Y")) && is.na(as.Date(studyPeriod[2], format = "%Y-%m-%d"))) {
cli::cli_abort("Please ensure that dates provided are in the correct format.", call = call)
}
studyPeriod <- as.character(studyPeriod)
omopgenerics::assertCharacter(studyPeriod, length = 2, na = TRUE)
observationRange <- cdm$observation_period |>
dplyr::summarise(
minobs = min(.data$observation_period_start_date, na.rm = TRUE),
maxobs = max(.data$observation_period_end_date, na.rm = TRUE)
) |>
dplyr::collect()
if (is.na(studyPeriod[1])) {
studyPeriod[1] <- observationRange |>
dplyr::pull("minobs") |>
as.character()
} else {
if (observationRange |>
dplyr::pull("minobs") > studyPeriod[1]) {
cli::cli_alert(paste0("The observation period in the cdm starts in ", observationRange |>
dplyr::pull("minobs")))
}
if (studyPeriod[1] < "1800-01-01") {
cli::cli_alert(paste0("The observation period in the cdm starts at a very early date."))
}
}
if (is.na(studyPeriod[2])) {
studyPeriod[2] <- observationRange |>
dplyr::pull("maxobs") |>
as.character()
} else {
if (observationRange |>
dplyr::pull("maxobs") < studyPeriod[2]) {
cli::cli_alert(paste0("The observation period in the cdm ends in ", observationRange |>
dplyr::pull("maxobs")))
}
if (studyPeriod[2] > clock::date_today(zone = "GMT")) {
cli::cli_alert(paste0("The given date range ends after current date."))
}
}
return(studyPeriod |> as.Date())
}
#' @noRd
validateFacet <- function(facet, result, call = parent.frame()) {
if (rlang::is_formula(facet)) {
facet <- as.character(facet)
facet <- unlist(strsplit(facet, " \\+ "))
facet <- facet[facet != "~" & facet != "+" & facet != "."]
}
facet <- as.character(facet)
omopgenerics::assertChoice(facet, visOmopResults::tidyColumns(result), null = TRUE, call = call)
return(invisible(NULL))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.