R/utils.R

In mctq: Tools to Process the Munich ChronoType Questionnaire (MCTQ)

# Sort by type or alphabetical order.

flat_posixt <- function(posixt, base = as.Date("1970-01-01"),
                        force_tz = TRUE, tz = "UTC") {
    assert_posixt(posixt, null.ok = FALSE)
    checkmate::assert_date(base, len = 1, all.missing = FALSE)
    checkmate::assert_flag(force_tz)
    checkmate::assert_choice(tz, OlsonNames())

    lubridate::date(posixt) <- base

    if (isTRUE(force_tz)) {
        lubridate::force_tz(posixt, tz)
    } else {
        posixt
    }
}

midday_change <- function(time) {
    checkmate::assert_multi_class(time, c("hms", "POSIXct", "POSIXlt"))

    if (hms::is_hms(time)) time <- as.POSIXct(time)
    time <- flat_posixt(time)

    dplyr::case_when(
        lubridate::hour(time) < 12 ~ lubridate::`day<-`(time, 2),
        TRUE ~ time
    )
}

interval_mean <- function(start, end, ambiguity = 24) {
    classes <- c("Duration", "difftime", "hms", "POSIXct", "POSIXlt")

    checkmate::assert_multi_class(start, classes)
    checkmate::assert_multi_class(end, classes)
    checkmate::assert_choice(ambiguity, c(0, 24 , NA))

    start <- cycle_time(hms::hms(extract_seconds(start)),
                        cycle = lubridate::ddays())
    end <- cycle_time(hms::hms(extract_seconds(end)),
                      cycle = lubridate::ddays())
    interval <- shush(assign_date(start, end, ambiguity = ambiguity))
    mean <- as.numeric(start) + (as.numeric(interval) / 2)

    hms::hms(mean)
}

extract_seconds <- function(x) {
    classes <- c("Duration", "difftime", "hms", "POSIXct", "POSIXlt",
                 "Interval")

    checkmate::assert_multi_class(x, classes)

    if (lubridate::is.POSIXt(x) || lubridate::is.difftime(x)) {
        as.numeric(hms::as_hms(x))
    } else {
        as.numeric(x)
    }
}

swap <- function(x, y, condition = TRUE) {
    assert_identical(x, y, type = "class")
    assert_identical(x, y, condition, type = "length")
    checkmate::assert_logical(condition)

    first_arg <- x
    second_arg <- y

    x <- dplyr::if_else(condition, second_arg, first_arg)
    y <- dplyr::if_else(condition, first_arg, second_arg)

    list(x = x, y = y)
}

class_collapse <- function(x) single_quote_(paste0(class(x), collapse = "/"))

count_na <- function(x) {
    checkmate::assert_atomic(x)

    length(which(is.na(x)))
}

get_class <- function(x) {
    if (is.list(x)) {
        vapply(x, function(x) class(x)[1], character(1))
    } else {
        class(x)[1]
    }
}

get_names <- function(...) {
    out <- lapply(substitute(list(...))[-1], deparse) %>%
        vapply(unlist, character(1)) %>%
        noquote()

    gsub("\\\"","", out)
}

single_quote_ <- function(x) paste0("'", x, "'")
double_quote_ <- function(x) paste0("\"", x, "\"")

str_extract_ <- function(string, pattern, ignore_case = FALSE, perl = TRUE,
                         fixed = FALSE, use_bytes = FALSE, invert = FALSE) {
    checkmate::assert_string(pattern)
    checkmate::assert_flag(ignore_case)
    checkmate::assert_flag(perl)
    checkmate::assert_flag(fixed)
    checkmate::assert_flag(use_bytes)
    checkmate::assert_flag(invert)

    match <- regexpr(pattern, string, ignore.case = ignore_case, perl = perl,
                     fixed = fixed, useBytes = use_bytes)
    out <- rep(NA, length(string))
    out[match != -1 & !is.na(match)] <- regmatches(string, match,
                                                   invert = invert)
    out
}

require_pkg <- function(...) {
    out <- list(...)

    lapply(out, checkmate::assert_string,
           pattern = "^[A-Za-z][A-Za-z0-9.]+[A-Za-z0-9]$")

    if (!identical(unique(unlist(out)), unlist(out))) {
        cli::cli_abort("'...' cannot have duplicated values.")
    }

    pkg <- unlist(out)
    namespace <- vapply(pkg, require_namespace, logical(1),
                        quietly = TRUE, USE.NAMES = FALSE)
    pkg <- pkg[!namespace]

    if (length(pkg) == 0) {
        invisible(NULL)
    } else {
        cli::cli_abort(paste0(
            "This function requires the {single_quote_(pkg)} package{?s} ",
             "to run. You can install {?it/them} by running:", "\n\n",
             "install.packages(",
             "{paste(double_quote_(pkg), collapse = ', ')})"
            ))
    }
}

shush <- function(x, quiet = TRUE) {
    if (isTRUE(quiet)) {
        suppressMessages(suppressWarnings(x))
    } else {
        x
    }
}