R/c14_date_list_basic.R

In c14bazAAR: Download and Prepare C14 Dates from Different Source Databases

##### as ####

#' @name c14_date_list
#'
#' @title \strong{c14_date_list}
#'
#' @description The \strong{c14_date_list} is the central data structure of the
#' \code{c14bazAAR} package. It's a tibble with set of custom methods and
#' variables. Please see the
#' \href{https://github.com/ropensci/c14bazAAR/blob/master/data-raw/variable_reference.csv}{variable_reference}
#' table for a description of the variables. Further available variables are ignored. \cr
#' If an object is of class data.frame or tibble (tbl & tbl_df), it can be
#' converted to an object of class \strong{c14_date_list}. The only requirement
#' is that it contains the essential columns \strong{c14age} and \strong{c14std}.
#' The \code{as} function adds the string "c14_date_list" to the classes vector
#' of the object and applies \code{order_variables()}, \code{enforce_types()} and
#' the helper function \code{clean_latlon()} to it.
#'
#' @param x an object
#' @param ... further arguments passed to or from other methods
#'
#' @rdname c14_date_list
#'
#' @examples
#' as.c14_date_list(data.frame(c14age = c(2000, 2500), c14std = c(30, 35)))
#' is.c14_date_list(5) # FALSE
#' is.c14_date_list(example_c14_date_list) # TRUE
#'
#' print(example_c14_date_list)
#' plot(example_c14_date_list)
#'
#' @export
as.c14_date_list <- function(x, ...) {

  # define expectations
  necessary_vars <- c("c14age","c14std")

  # check input data type
  if("data.frame" %in% class(x) | all(c("tbl", "tbl_df") %in% class(x))){
    # check if necessary vals are present
    present <- necessary_vars %in% colnames(x)
    if (all(present)) {
      # do the actual conversion!
      x %>%
        tibble::new_tibble(., nrow = nrow(.), class = "c14_date_list") %>%
        c14bazAAR::order_variables() %>%
        c14bazAAR::enforce_types() %>%
        clean_latlon() %>%
        clean_labnr() %>%
        return()
    } else {
      stop(
        "The following variables (columns) are missing: ",
        paste(necessary_vars[!present], collapse = ", ")
      )
    }
  } else {
    stop("x is not an object of class data.frame or tibble")
  }

}

#### is ####

#' @rdname c14_date_list
#' @export
is.c14_date_list <- function(x, ...) {"c14_date_list" %in% class(x)}

#### format ####

#' @rdname c14_date_list
#' @export
format.c14_date_list <- function(x, ...) {
  out_str <- list()
  out_str$header <- paste0("\tRadiocarbon date list")
  out_str$dates <- paste0("\t", "dates: ", nrow(x))
  if("site" %in% colnames(x)) {
    out_str$sites <- paste0("\t", "sites: ", length(unique(x[["site"]])))
  }
  if("country" %in% colnames(x)) {
    out_str$country <- paste0("\t", "countries: ", length(unique(x[["country"]])))
  }
  if("c14age" %in% colnames(x)) {
    out_str$range_uncal <- paste0(
      "\t", "uncalBP: ",
      round(max(x[["c14age"]], na.rm = TRUE), -2), " \u2015 ", round(min(x[["c14age"]], na.rm = TRUE), -2)
    )
  }
  if("calage" %in% colnames(x)) {
    out_str$range_cal <- paste0(
      "\t", "calBP: ",
      round(max(x[["calage"]], na.rm = TRUE), -2), " \u2015 ", round(min(x[["calage"]], na.rm = TRUE), -2)
    )
  }
  return_value <- paste(out_str, collapse = "\n", sep = "")
  invisible(return_value)
}

#### print ####

#' @rdname c14_date_list
#' @export
print.c14_date_list <- function(x, ...) {
  # own format function
  cat(format(x, ...), "\n\n")
  # add table printed like a tibble
  x %>% `class<-`(c("tbl", "tbl_df", "data.frame")) %>% print
}

#### plot ####

#' @rdname c14_date_list
#' @export
plot.c14_date_list <- function(x, ...) {

  check_if_packages_are_available("globe")

  # store par settings
  old.par <- graphics::par(no.readonly = TRUE)

  # set plot layout
  graphics::layout(matrix(c(1,2,3,3), 2, 2, byrow = TRUE))

  # plot 1: text
  header <- as.character(format(x)) %>%
    strsplit("\n") %>% unlist %>%
    sub("\t", "", .) %>%
    sub("\t\t", "\t", .) %>%
    trimws
  graphics::plot(0, type = 'n', axes = FALSE, ann = FALSE, xlim = c(0, 1), ylim = c(length(header) + 1, 0))
  for (i in 1:length(header)) {
    if (i == 1) {
      graphics::text(0, i, bquote(bold(.(header[i]))), adj = 0)
    } else {
      graphics::text(0, i, header[i], adj = 0)
    }
  }

  # plot 2: globe
  graphics::par(mar = c(0, 0, 0, 0))
  globe::globeearth(eye = list(mean(x[["lon"]], na.rm = T), mean(x[["lat"]], na.rm = T)))
  globe::globepoints(
    loc = x[,c("lon", "lat")],
    col = "red",
    cex = 0.01,
    pch = 20
  )

  # plot 3: histogram
  graphics::par(mar = c(4.2, 4.2, 0, 0))
  graphics::hist(
    x[["c14age"]],
    breaks = 100,
    main = NULL,
    xlim = rev(range(x[["c14age"]], na.rm = T)),
    xlab = "Uncalibrated Age BP in years (c14age)",
    ylab = "Amount of dates"
  )


  # reset par setting on exit
  on.exit(graphics::par(old.par))
}

#### accessor functions ####