R/metadata.R

In timeseriesdb: A Time Series Database for Official Statistics with R and PostgreSQL

#' Create Meta Data Objects
#' 
#' Create list based S3 objects to store meta data. Meta data objects can 
#' be passed on to a plethora of functions including storing to database. 
#' 
#' @param ... arguments passed on the respective method. 
#' @export
create_meta <- function(...) {
  UseMethod("create_meta")
}

#' @export
create_meta.list <- function(metadata, ...) {
  if(is.null(names(metadata)) || any(nchar(names(metadata)) == 0)) {
    stop("All fields of metadata objects must be named!")
  }
  class(metadata) <- c("meta", "list")
  metadata
}

#' @export
create_meta.default <- function(...) {
  create_meta.list(list(...))
}

#' Convert a List into a Metadata Object
#'
#' Create timeseriesdb specific metadata class. Typically one list per natural language
#' is converted to a meta description object.
#'
#' @param x list of meta data.
#'
#' @export
as.meta <- function(x) {
  if(is.na(x) || is.null(x)) {
    x
  } else if(!is.list(x)) {
    stop("Only lists can be converted to meta objects!")
  } else {
    create_meta(x)
  }
}

#' Meta in
#' 
#' 
#' @param ... arguments passed on the respective method. 
#' @export
create_tsmeta <- function(...) {
  l <- list(...)
  n <- names(l)
  if(is.null(n) | any(nchar(n) == 0)){
    stop("All arguments must be named.")
  }
  as.tsmeta(l)
}

#' Convert a List into a Metadata Object
#'
#' Create timeseriesdb specific metadata class. Typically one list per natural language
#' is converted to a meta description object.
#'
#' @param meta list containing meta information. List elements are character strings.
#' @param ... additional arguments, passed on to metthods below.
#' @export
as.tsmeta <- function(meta, ...) {
  UseMethod("as.tsmeta")
}

#' @export
as.tsmeta.data.table <- function(meta, ...) {
  if(nrow(meta) > 0) {
    out <- apply(meta[, -"ts_key", with = FALSE], 1, as.list)
    names(out) <- meta$ts_key
    # Remove NA elements from list
    out <- lapply(out, function(x){x[!is.na(x)]})
    as.tsmeta.list(out, check_depth = FALSE)
  } else {
    create_tsmeta()
  }
}

#' @export
as.tsmeta.list <- function(meta, check_depth = TRUE, ...) {
  if(check_depth && !has_depth_2(meta) && length(meta) > 0) {
    stop("A meta list must have exactly depth 2!")
  }
  meta <- lapply(meta, function(x) {
    class(x) <- c("meta", class(x))
    x
  })
  class(meta) <- c("tsmeta", class(meta))
  meta
}

#' @export
as.tsmeta.data.frame <- function(meta, ...) {
  as.tsmeta(as.data.table(meta))
}


#' @export
as.tsmeta.tsmeta <- function(meta, ...) {
  meta
}


# printers ----------------------------------------------------------------

#' Print Method for meta Object
#'
#' @param x a metadata object.
#' @param ... list of print options.  
#' @export
print.meta <- function(x, ...) {
  if(length(x) > 0) {
    atts <- attributes(x)
    cat("Object of class meta\n")
    n <- names(x)
    name_lengths <- sapply(n, nchar)
    max_name_length <- max(name_lengths)
    for(i in n) {
      cat(sprintf("%s%s: %s\n", i, paste(rep(" ", max_name_length - name_lengths[i]), collapse = ""), x[[i]]))
    }
  } else {
    cat("Empty object of class meta\n")
  }
}

#' @export
print.tsmeta <- function(x, ...) {
  if(length(x) > 0) {
    cat("Object of class tsmeta\n")
    print(unclass(x))
  } else {
    cat(sprintf("Empty object of class tsmeta\n"))
  }
}


# functions ---------------------------------------------------------------

# writers -----------------------------------------------------------------

#' Store Time Series Metadata to PostgreSQL
#'
#' The most basic way to store meta information is to assign non-translated (unlocalized) descriptions, but it also can be stored in different languages (localized) using the parameter \strong{locale}. See also \href{https://mbannert.github.io/timeseriesdb/articles/a01_basic_usage.html#basic-metadata}{basic usage}.
#'
#'
#' @param metadata object of class tsmeta that contains the metadata to be stored.
#' @param valid_from \strong{character} representation of a date in the form of 'YYYY-MM-DD'. It should always be explicitly specified.
#' @param on_conflict \strong{character} either "update": add new fields and update existing ones or "overwrite": completely replace existing record.
#'
#' @inheritParams param_defs
#' @family metadata functions
#'
#' @return status list created from DB status return JSON.
#'
#' @importFrom jsonlite fromJSON toJSON
#' @export
#'
#' @examples
#'
#' \dontrun{
#' sum("a")
#' }
db_metadata_store <- function(con,
                          metadata,
                          valid_from,
                          locale = NULL,
                          on_conflict = "update",
                          schema = "timeseries") {
  if(!on_conflict %in% c("update", "overwrite")) {
    stop("on_conflict must be one of c(\"update\", \"overwrite\")")
  }

  metadata <- lapply(metadata, toJSON, auto_unbox = TRUE, digits = NA)

  if(!is.null(locale)) {
    md_table <- data.frame(
      ts_key = names(metadata),
      locale = locale,
      metadata = unlist(metadata),
      stringsAsFactors = FALSE
    )


    db_return <- db_with_temp_table(con,
                                    "tmp_md_insert",
                                    md_table,
                                    field.types = c(
                                      ts_key = "text",
                                      locale = "text",
                                      metadata = "jsonb"),
                                      db_call_function(con,
                                                       "metadata_localized_upsert",
                                                       list(as.Date(valid_from), on_conflict),
                                                       schema = schema),
                                     schema = schema)
  } else {
    md_table <- data.frame(
      ts_key = names(metadata),
      metadata = unlist(metadata),
      stringsAsFactors = FALSE
    )


    db_return <- db_with_temp_table(con,
                                   "tmp_md_insert",
                                   md_table,
                                   field.types = c(
                                     ts_key = "text",
                                     metadata = "jsonb"),
                                     db_call_function(con,
                                                      "metadata_unlocalized_upsert",
                                                      list(as.Date(valid_from), on_conflict),
                                                      schema = schema),
                                   schema = schema)
  }

  out <- fromJSON(db_return, simplifyDataFrame = FALSE)

  if(out$status == 'warning') {
    for(w in out$warnings) {
      warning(w$message)
    }
  }

  out
}


# readers -----------------------------------------------------------------

#' Read Time Series Metadata
#'
#' Read meta information given a vector of time series identifiers.
#'
#' @inheritParams param_defs
#' @family metadata functions
#'
#' @return list of tsmeta objects.
#' @importFrom jsonlite fromJSON
#' @export
db_metadata_read <- function(con,
                                ts_keys,
                                valid_on = NULL,
                                regex = FALSE,
                                locale = NULL,
                                schema = "timeseries") {

  # To obtain a proper NA Date thingy
  if(is.null(valid_on)) {
    valid_on <- NA
  }
  db_return <- db_with_tmp_read(con,
                                ts_keys,
                                regex,
                                {
                                  if(is.null(locale)) {
                                    db_call_function(con,
                                                     "metadata_read_raw",
                                                     list(
                                                       valid_on = as.Date(valid_on)
                                                     ),
                                                     schema = schema)
                                  } else {
                                    db_call_function(con,
                                                     "metadata_localized_read_raw",
                                                     list(
                                                       valid_on = as.Date(valid_on),
                                                       loc = locale
                                                     ),
                                                     schema = schema)
                                  }
                                },
                                schema = schema)

  out <- fromJSON(paste0("[",
                         paste(db_return$metadata, collapse = ","),
                         "]"),
                  simplifyDataFrame = FALSE)
  names(out) <- db_return$ts_key
  out <- as.tsmeta.list(out)

  out
}

#' Read Metadata for a Collection
#'
#'
#'
#' @param collection_name character name of the collection.
#' @param collection_owner character name of the collection owner.
#' @inheritParams param_defs
#' @family metadata functions
#'
#' @return list of all available meta descriptions for a particular collection and language.
#' @export
db_collection_read_metadata <- function(con,
                                    collection_name,
                                    collection_owner,
                                    valid_on = NULL,
                                    locale = NULL,
                                    schema = "timeseries") {

  # To obtain a proper NA Date thingy
  if(is.null(valid_on)) {
    valid_on <- NA
  }

  db_return <- if(is.null(locale)) {
    db_call_function(con,
                     "metadata_collection_read_raw",
                     list(
                       p_collection_name = collection_name,
                       p_owner = collection_owner,
                       p_valid_on = as.Date(valid_on)
                     ),
                     schema = schema)
  } else {
    db_call_function(con,
                     "metadata_collection_localized_read_raw",
                     list(
                       p_collection_name = collection_name,
                       p_owner = collection_owner,
                       p_valid_on = as.Date(valid_on),
                       p_loc = locale
                     ),
                     schema = schema)
  }
  out <- fromJSON(paste0("[",
                         paste(db_return$metadata, collapse = ","),
                         "]"),
                  simplifyDataFrame = FALSE)
  names(out) <- db_return$ts_key
  out <- as.tsmeta.list(out)
  out
}


#' Read Dataset Meta Information
#'
#' @param dataset_id character name of the dataset.
#' @param locale character ISO-2 country locale.
#'
#' @inheritParams param_defs
#' @family metadata functions
#'
#' @export
db_dataset_read_metadata <- function(con,
                                 dataset_id,
                                 valid_on = NULL,
                                 locale = NULL,
                                 schema = "timeseries") {
  # To obtain a proper NA Date thingy
  if(is.null(valid_on)) {
    valid_on <- NA
  }

  db_return <- if(is.null(locale)) {
    db_call_function(con,
                     "metadata_dataset_read_raw",
                     list(
                       p_dataset = dataset_id,
                       p_valid_on = as.Date(valid_on)
                     ),
                     schema = schema)
  } else {
    db_call_function(con,
                     "metadata_dataset_localized_read_raw",
                     list(
                       p_dataset = dataset_id,
                       p_valid_on = as.Date(valid_on),
                       p_loc = locale
                     ),
                     schema = schema)
  }

  out <- fromJSON(paste0("[",
                         paste(db_return$metadata, collapse = ","),
                         "]"),
                  simplifyDataFrame = FALSE)
  names(out) <- db_return$ts_key
  out <- as.tsmeta.list(out)

  out
}

#' Get Latest Validity for Metadata of a Given Time Series
#'
#' Because metadata are only loosely coupled with their respective time series
#' in order to keep metadata records constant over multiple version of
#' time series if the data description does not change, it comes in
#' handy to find out the last time meta information was updated. This function
#' automagickally finds exactly this date.
#'
#' @inheritParams param_defs
#' @family metadata functions
#'
#' @return data.table of latest validity
#' @export
db_meta_get_latest_validity <- function(con,
                                        ts_keys,
                                        regex = FALSE,
                                        locale = NULL,
                                        schema = "timeseries") {
  out <- db_with_tmp_read(con,
                          ts_keys,
                          regex,
                          {
                            if(is.null(locale)) {
                              out <- db_call_function(con,
                                                      "metadata_get_latest_vintages",
                                                      schema = schema)
                            } else {
                              out <- db_call_function(con,
                                                      "metadata_localized_get_latest_vintages",
                                                      list(locale),
                                                      schema = schema)
                            }
                          },
                          schema = schema)

  as.data.table(out)
}