R/locale.R

In vroom: Read and Write Rectangular Text Data Quickly

#' Create locales
#'
#' A locale object tries to capture all the defaults that can vary between
#' countries. You set the locale in once, and the details are automatically
#' passed on down to the columns parsers. The defaults have been chosen to
#' match R (i.e. US English) as closely as possible. See
#' `vignette("locales")` for more details.
#'
#' @param date_names Character representations of day and month names. Either
#'   the language code as string (passed on to [date_names_lang()])
#'   or an object created by [date_names()].
#' @param date_format,time_format Default date and time formats.
#' @param decimal_mark,grouping_mark Symbols used to indicate the decimal
#'   place, and to chunk larger numbers. Decimal mark can only be `,` or
#'   `.`.
#' @param tz Default tz. This is used both for input (if the time zone isn't
#'   present in individual strings), and for output (to control the default
#'   display). The default is to use "UTC", a time zone that does not use
#'   daylight savings time (DST) and hence is typically most useful for data.
#'   The absence of time zones makes it approximately 50x faster to generate
#'   UTC times than any other time zone.
#'
#'   Use `""` to use the system default time zone, but beware that this
#'   will not be reproducible across systems.
#'
#'   For a complete list of possible time zones, see [OlsonNames()].
#'   Americans, note that "EST" is a Canadian time zone that does not have
#'   DST. It is *not* Eastern Standard Time. It's better to use
#'   "US/Eastern", "US/Central" etc.
#' @param encoding Default encoding.
#' @export
#' @examples
#' locale()
#' locale("fr")
#'
#' # South American locale
#' locale("es", decimal_mark = ",")
locale <- function(
  date_names = "en",
  date_format = "%AD",
  time_format = "%AT",
  decimal_mark = ".",
  grouping_mark = ",",
  tz = "UTC",
  encoding = "UTF-8"
) {
  if (is.character(date_names)) {
    date_names <- date_names_lang(date_names)
  }
  if (!is.date_names(date_names)) {
    cli::cli_abort(
      "{.arg date_names} must be a language code like {.val en} or an object created by {.fun date_names}."
    )
  }

  if (missing(grouping_mark) && !missing(decimal_mark)) {
    grouping_mark <- if (decimal_mark == ".") "," else "."
  } else if (missing(decimal_mark) && !missing(grouping_mark)) {
    decimal_mark <- if (grouping_mark == ".") "," else "."
  }

  check_string(decimal_mark)
  check_string(grouping_mark)
  if (decimal_mark == grouping_mark) {
    cli::cli_abort(
      c(
        "{.arg decimal_mark} and {.arg grouping_mark} must be different.",
        "i" = "Both were specified as {.val {decimal_mark}}."
      )
    )
  }

  tz <- check_tz(tz)
  check_encoding(encoding)

  structure(
    list(
      date_names = date_names,
      date_format = date_format,
      time_format = time_format,
      decimal_mark = decimal_mark,
      grouping_mark = grouping_mark,
      tz = tz,
      encoding = encoding
    ),
    class = "locale"
  )
}

is.locale <- function(x) inherits(x, "locale")

# Conditionally exported in zzz.R
#' @noRd
# @export
print.locale <- function(x, ...) {
  cat("<locale>\n")
  cat(
    "Numbers:  ",
    prettyNum(
      123456.78,
      big.mark = x$grouping_mark,
      decimal.mark = x$decimal_mark,
      digits = 8
    ),
    "\n",
    sep = ""
  )
  cat("Formats:  ", x$date_format, " / ", x$time_format, "\n", sep = "")
  cat("Timezone: ", x$tz, "\n", sep = "")
  cat("Encoding: ", x$encoding, "\n", sep = "")
  print(x$date_names)
}

#' @export
#' @rdname locale
default_locale <- function() {
  loc <- getOption("vroom.default_locale")
  if (is.null(loc)) {
    loc <- locale()
    options("vroom.default_locale" = loc)
  }

  loc
}

check_tz <- function(x, call = caller_env()) {
  check_string(x, arg = caller_arg(x), call = call)

  tz_source <- ""

  if (identical(x, "")) {
    x <- Sys.timezone()
    tz_source <- "system "

    if (identical(x, "") || identical(x, NA_character_)) {
      x <- "UTC"
    }
  }

  if (x %in% tzdb::tzdb_names()) {
    x
  } else {
    cli::cli_abort("Unknown {tz_source}timezone: {.val {x}}.", call = call)
  }
}

# see https://github.com/tidyverse/readr/pull/1537 for why this is more relaxed
# than you might expect (and than it used to be)
check_encoding <- function(x, call = caller_env()) {
  check_string(x, arg = caller_arg(x), call = call)

  # portable encoding names
  if (x %in% c("latin1", "UTF-8")) {
    return(TRUE)
  }

  # 'iconvlist' could be incomplete (musl) or even unavailable
  known <- tryCatch(iconvlist(), error = identity)
  if (inherits(known, "error")) {
    cli::cli_warn("Could not check {.arg encoding} against {.fun iconvlist}.")
  } else if (tolower(x) %in% tolower(known)) {
    TRUE
  } else {
    cli::cli_warn("{.arg encoding} not found in {.fun iconvlist}: {.val {x}}.")
  }
}