R/dates.R

In neatR: Neat Data for Presentation

#' neat alias of the week day with reference based on current date
#' @param date a Date or POSIX time stamp
#' @param show_relative_day a Boolean. If set to TRUE, a reference alias of week
#' day is shown based on current date such as
#' Today/Yesterday/Tomorrow/Last/Coming.
#' @return week day of the date in a readable format with reference alias based
#' on current date
#' @examples
#' # Get day of the week of current date without reference alias
#' x <- Sys.Date()
#' nday(x, show_relative_day = FALSE)
#' # Get day of the week with reference alias
#' nday(x, show_relative_day = TRUE)
#' @param reference_alias Deprecated. Use 'show_relative_day' instead.
#' @export

nday <- function(date, show_relative_day = FALSE, reference_alias = NULL) {
  show_relative_day <- .handle_deprecated_args(
    reference_alias,
    show_relative_day,
    "reference_alias",
    "show_relative_day"
  )
  date_check(date)
  bool_singleton_check(show_relative_day)
  udate <- unique(date)
  is_na_udate <- is.na(udate)
  udate <- unique(date)
  is_na_udate <- is.na(udate)

  # Handle case where input is purely logical NA (not Date/POSIXt)
  if (!inherits(udate, c("Date", "POSIXt"))) {
    # If it passed date_check, it must be all NA
    out <- rep(NA_character_, length(udate))
  } else {
    out <- format(udate, "%a")
  }
  if (show_relative_day) {
    today <- Sys.Date()
    day_delta <- today - as.Date(udate)
    day_alias <- data.table::fcase(
      day_delta >= 2 & day_delta <= 8, "Last ",
      day_delta == 1, "Yesterday, ",
      day_delta == 0, "Today, ",
      day_delta == -1, "Tomorrow, ",
      day_delta >= -8 & day_delta <= -2, "Coming ",
      default = ""
    )
    out <- paste0(day_alias, out)
  }
  out[is_na_udate] <- NA_character_
  out[match(date, udate)]
}


#' neat representation of dates
#' @param date a Date or POSIX time stamp
#' @param show_weekday a Boolean. Whether the weekday of the date
#' to be included.
#' @param show_month_year a Boolean variable representing if the date
#' represents month. If this set to TRUE,
#' the function returns 'MMMM'YY' as the output which is a neater
#' representation of month.
#' @return String representation of the date
#' @examples
#' # Neat representation of current date
#' x <- Sys.Date()
#' ndate(x)
#' # Neat representation of current date with day of week.
#' ndate(x, show_weekday = FALSE)
#' # Neat representation of current date with only month and year
#' ndate(x, show_weekday = FALSE, show_month_year = TRUE)
#' @param display_weekday Deprecated. Use 'show_weekday' instead.
#' @param is_month Deprecated. Use 'show_month_year' instead.
#' @export

ndate <- function(date, show_weekday = TRUE, show_month_year = FALSE,
                  display_weekday = NULL, is_month = NULL) {
  show_weekday <- .handle_deprecated_args(
    display_weekday, show_weekday,
    "display_weekday", "show_weekday"
  )
  show_month_year <- .handle_deprecated_args(
    is_month, show_month_year,
    "is_month", "show_month_year"
  )
  date_check(date)
  bool_singleton_check(show_weekday)
  bool_singleton_check(show_month_year)
  udate <- unique(date)
  is_na_udate <- is.na(udate)

  if (!inherits(udate, c("Date", "POSIXt"))) {
    out <- rep(NA_character_, length(udate))
  } else if (show_month_year) {
    out <- format(udate, "%b'%y")
  } else {
    if (show_weekday) {
      wd <- inpar(nday(udate, show_relative_day = FALSE))
    } else {
      wd <- rep("", length(udate))
    }
    out <- paste0(format(udate, "%b %d, %Y"), wd)
  }

  # Restore NAs
  out[is_na_udate] <- NA_character_

  out[is_na_udate] <- NA_character_
  out[match(date, udate)]
}

#' neat representation of time stamp
#' @param timestamp a POSIX time stamp
#' @param show_date a Boolean representing if the date of time stamp
#' to be included. By default it is set to TRUE.
#' @param show_weekday a Boolean representing if the weekday of the timestamp
#' to be included. By default it is set to TRUE
#' @param show_hours a Boolean representing if the hours to be included.
#' By default it is set to TRUE
#' @param show_minutes a Boolean representing if the minutes to be included.
#' By default it is set to TRUE
#' @param show_seconds a Boolean representing if the seconds to be included.
#' By default it is set to TRUE
#' @param show_timezone a Boolean variable representing if the
#' timezone of the date variable to be included. By default it is set to TRUE.
#' @return String representation of time stamp
#' @examples
#' # Neat representation of time stamp
#' x <- Sys.time()
#' ntimestamp(x)
#' # Neat representation of time from a time stamp
#' ntimestamp(x,
#'   show_date = FALSE, show_seconds = FALSE,
#'   show_timezone = FALSE
#' )
#' @param display_weekday Deprecated. Use 'show_weekday' instead.
#' @param include_date Deprecated. Use 'show_date' instead.
#' @param include_hours Deprecated. Use 'show_hours' instead.
#' @param include_minutes Deprecated. Use 'show_minutes' instead.
#' @param include_seconds Deprecated. Use 'show_seconds' instead.
#' @param include_timezone Deprecated. Use 'show_timezone' instead.
#' @export

ntimestamp <- function(
  timestamp, show_weekday = TRUE, show_date = TRUE,
  show_hours = TRUE, show_minutes = TRUE, show_seconds = TRUE,
  show_timezone = TRUE,
  display_weekday = NULL, include_date = NULL,
  include_hours = NULL, include_minutes = NULL, include_seconds = NULL,
  include_timezone = NULL
) {
  show_weekday <- .handle_deprecated_args(
    display_weekday, show_weekday,
    "display_weekday", "show_weekday"
  )
  show_date <- .handle_deprecated_args(
    include_date, show_date,
    "include_date", "show_date"
  )
  show_hours <- .handle_deprecated_args(
    include_hours, show_hours,
    "include_hours", "show_hours"
  )
  show_minutes <- .handle_deprecated_args(
    include_minutes, show_minutes,
    "include_minutes", "show_minutes"
  )
  show_seconds <- .handle_deprecated_args(
    include_seconds, show_seconds,
    "include_seconds", "show_seconds"
  )
  show_timezone <- .handle_deprecated_args(
    include_timezone, show_timezone,
    "include_timezone", "show_timezone"
  )

  timestamp_check(timestamp)
  bool_singleton_check(show_weekday)
  bool_singleton_check(show_date)
  bool_singleton_check(show_hours)
  bool_singleton_check(show_minutes)
  bool_singleton_check(show_seconds)
  bool_singleton_check(show_timezone)
  uts <- unique(timestamp)
  is_na_uts <- is.na(uts)
  defaults <- rep("", length(uts))

  if (show_hours && inherits(uts, c("Date", "POSIXt"))) {
    hour <- format(uts, "%IH")
  } else {
    hour <- defaults
  }
  if (show_minutes && inherits(uts, c("Date", "POSIXt"))) {
    mins <- format(uts, " %MM")
  } else {
    mins <- defaults
  }
  if (show_seconds && inherits(uts, c("Date", "POSIXt"))) {
    secs <- format(uts, " %SS")
  } else {
    secs <- defaults
  }
  if (show_timezone && inherits(uts, c("Date", "POSIXt"))) {
    tz <- toupper(format(uts, " %Z"))
  } else {
    tz <- defaults
  }
  if (show_date && inherits(uts, c("Date", "POSIXt"))) {
    date <- format(uts, "%b %d, %Y ")
  } else {
    date <- defaults
  }

  if (inherits(uts, c("Date", "POSIXt"))) {
    am_pm <- gsub("\\.", "", toupper(format(uts, " %p")))
  } else {
    am_pm <- rep("", length(uts))
  }

  out <- paste0(date, hour, mins, secs, am_pm, tz)
  if (show_weekday) {
    wd <- inpar(nday(uts, show_relative_day = FALSE))
    out <- paste0(out, wd)
  }
  out[is_na_uts] <- NA_character_
  out[match(timestamp, uts)]
}