R/UpdateKlass.R

In klassR: Classifications and Codelists for Statistics Norway

#' Update a code found in a directed graph based on a Klass-classification
#'
#' @inheritParams find_dates
#' @inheritParams klass_node
#'
#' @param output Either a character vector, containing one or more of the items
#'   in the list below, or \code{TRUE} to include all columns.
#'
#'   \describe{
#'    \item{\code{"code"}}{The Klass code.}
#'    \item{\code{"name"}}{The Klass name.}
#'    \item{\code{"validFrom"}}{The date that the code is valid from.}
#'    \item{\code{"validTo"}}{The date that the code is valid to.}
#'    \item{\code{"split"}}{Logical: Does the code split into two or more codes?}
#'    \item{\code{"combined"}}{Logical: Does two or more codes become this code?}
#'    \item{\code{"nextCode"}}{If \code{split == FALSE}, gives the code this code changed into. \code{NA} otherwise.}
#'   }
#'
#' @param combine \code{TRUE} or \code{FALSE}. See the return section.
#'
#' @param report \code{TRUE} or \code{FALSE}. See the return section.
#'
#' @return If \code{report == TRUE} and \code{length(output) > 1 | TRUE}, the
#'   result will be a \code{data.frame} with number of rows equal to the number
#'   of codes in the sequence of changes between the input code and output code.
#'   The columns in the \code{data.frame} are specified with \code{output}.
#'
#'   If \code{report == TRUE} and \code{length(output) == 1}, the result will be
#'   a character vector with length equal to the number of codes in the sequence
#'   of changes between the input code and output code. The contents of the
#'   character vector is specified with \code{output}.
#'
#'   If \code{report == FALSE} and \code{length(output) > 1 | TRUE} the result
#'   will be a \code{data.frame} with one row representing the last code
#'   in the change sequence and columns specified by \code{output}. If a code
#'   has been split, the result will be \code{NA}. If \code{combine == FALSE}
#'   and a code is the result of a combination of codes, the result will be
#'   \code{NA}.
#'
#'   If \code{report == FALSE} and \code{length(output) == 1}, the result will
#'   be a character vector of length one, containing information about the
#'   updated code specified by \code{output}. If a code has been split, the
#'   result will be \code{NA}. If \code{combine == FALSE} and a code is the
#'   result of a combination of codes, the result will be \code{NA}.
#'
#' @seealso See [update_klass] for updating multiple codes in one function call.
#'
#' @keywords internal
update_code <- function(graph,
                        code,
                        date = NA,
                        output = "code",
                        combine = TRUE,
                        report = FALSE) {
  result <- update_klass_node(
    graph = graph,
    node = klass_node(graph, code, date = date)
  )

  nextCodes <- mapply(
    function(node, split) {
      if (split | length(node) == 0) {
        return(NA_character_)
      } else if (length(node) > 1) {
        return(paste0(node$code, collapse = "/"))
      } else {
        return(node$code)
      }
    },
    node = result$nextNodes,
    split = result$split,
    SIMPLIFY = TRUE
  )

  report_df <- data.frame(
    code = result$code,
    name = result$label,
    validFrom = result$validFrom,
    validTo = result$validTo,
    split = result$split,
    combined = result$combined,
    nextCode = unname(nextCodes)
  )

  if (report) {
    return(report_df[, output])
  } else if (any(report_df$split) |
    (!combine & any(report_df$combined)) |
    length(result) == 0) {
    return(NA)
  } else {
    return(report_df[length(result), output])
  }
}

#' Update multiple Klass codes to a desired date.
#'
#' @param codes Codes to be updated.
#'
#' @param dates Optional. Can be used to specify what date each of the codes was
#'   valid in. Supply a character vector of either length 1 to specify the same
#'   valid date for all codes, or of the same length as \code{codes} to specify
#'   valid dates for each code. The character vector(s) should have a format
#'   coercible by \code{\link[base]{as.Date}}, e.g. \code{YYYY-MM-DD}. The
#'   function will return an error if a code was not valid at the specified
#'   date.
#'
#' @param date Optional. Can be used to specify the date the codes should be
#'   updated to, e.g. if you have codes that are valid in year \code{T}, but
#'   want to change the codes to the corresponding version in year \code{T-1}.
#'   If unspecified (the default), the function will update codes to the most
#'   recent version.
#'
#' @param graph Optional. A graph object generated by \code{\link{klass_graph}}.
#'   If you're making multiple calls to [update_klass], you can save some time by
#'   generating the graph beforehand and reusing it for each call to
#'   [update_klass] with this parameter. If providing the graph directly, you do
#'   not need to provide the \code{classification} and \code{date} parameters.
#'
#' @inheritParams klass_graph
#'
#' @inheritParams update_code
#'
#' @return If \code{output = "code"}, a vector of length \code{length(codes)}
#'   containing either a code if the update is successful or \code{NA} if the
#'   code has been split. If \code{combine = FALSE}, a code being combined with
#'   another code will also return \code{NA}.
#'
#'   If \code{output == TRUE}, a list of length \code{length(codes)} containing
#'   \code{data.frame}s detailing the codes visited through the node search. The
#'   tables have the following columns.
#'
#'   ---
#'
#'   If \code{report == TRUE} and \code{length(output) > 1 | TRUE}, the result
#'   will be a list of \code{data.frame}s with number of rows equal to the
#'   number of codes in the sequence of changes between the input codes and
#'   output codes. The columns in the \code{data.frame}s are specified with
#'   \code{output}.
#'
#'   If \code{report == TRUE} and \code{length(output) == 1}, the result will be
#'   a list of character vectors with length equal to the number of codes in the
#'   sequence of changes between the input code and output code. The contents of
#'   the character vectors is specified with \code{output}.
#'
#'   If \code{report == FALSE} and \code{length(output) > 1 | TRUE} the result
#'   will be a list of \code{data.frame}s with one row representing the last
#'   code in the change sequence and columns specified by \code{output}. If a
#'   code has been split, the result will be \code{NA}. If \code{combine ==
#'   FALSE} and a code is the result of a combination of codes, the result will
#'   be \code{NA}.
#'
#'   If \code{report == FALSE} and \code{length(output) == 1}, the result will
#'   be a character vector containing information about the updated codes
#'   specified by \code{output}. If a code has been split, the result will be
#'   \code{NA}. If \code{combine == FALSE} and a code is the result of a
#'   combination of codes, the result will be \code{NA}.
#'
#' @export
#'
#' @examples
#' library(klassR)
#' codes <- get_klass(131, date = "2020-01-01")[["code"]]
#'
#' \dontrun{
#' updated_codes <- update_klass(codes,
#'   dates = "2020-01-01",
#'   classification = 131
#' )
#' }
#'
update_klass <- function(codes,
                         dates = NA,
                         classification = NULL,
                         date = NULL,
                         graph = klass_graph(classification, date),
                         output = "code",
                         report = FALSE,
                         combine = TRUE) {
  if (!methods::hasArg(graph) & !methods::hasArg(classification)) {
    stop(
      "\nPlease provide either:\n",
      "- A graph with the `graph` argument\n",
      "- A classification ID with the `classification` argument"
    )
  }

  # TODO Optimize by making a table of input codes, updating those, and
  # returning an expanded vector based on input

  simplify <- length(output) == 1 & !isTRUE(output) & !report

  result <- mapply(
    FUN = update_code,
    code = codes,
    date = dates,
    SIMPLIFY = simplify,
    MoreArgs = list(
      graph = graph,
      output = output,
      combine = combine,
      report = report
    )
  )

  return(result)
}