R/UpdateKlass-graph-navigate.R

In klassR: Classifications and Codelists for Statistics Norway

#' Given a Klass graph, find the node corresponding to a code and (optionally) a
#' date.
#'
#' @param graph A graph generated by \code{\link{klass_graph}}.
#' @param x The code to search for.
#' @param date Optional. The specific date the supplied code is valid in.
#'
#' @return The node in the graph corresponding to the supplied code. If date is
#'   not provided, the node with the most recent code is returned. If date is
#'   provided, the code with date between \code{validFrom} and \code{validTo} is
#'   returned.
#' @export
#'
#' @examples
#'
#' # Build a graph directed towards the most recent codes.
#' library(klassR)
#' \dontrun{
#' klass_131 <- klass_graph(131)
#' }
#'
#' # Find the most recent node in the graph representing the code "0101" (Halden,
#' # valid to 2020.)
#' \dontrun{
#' halden_node <- klass_node(klass_131, "0101")
#' }
klass_node <- function(graph, x, date = NA) {
  if (!is.na(date)) {
    date <- as.Date(date[[1]])

    node <- igraph::V(graph)[igraph::V(graph)$code == x &
      date >= igraph::V(graph)$validFrom &
      (date < igraph::V(graph)$validTo | is.na(igraph::V(graph)$validTo))]
  } else {
    x_indices <- which(igraph::V(graph)$code == x)

    highest_variant_index <-
      suppressWarnings(
        x_indices[which(igraph::V(graph)[x_indices]$variant ==
          max(igraph::V(graph)[x_indices]$variant))]
      )

    node <- igraph::V(graph)[highest_variant_index]
  }

  if (length(node) > 1) {
    stop("More than one node found.")
  } else {
    return(node)
  }
}

#' Count the neighbors of a node.
#'
#' @inheritParams update_klass_node
#' @inheritParams igraph::neighbors
#'
#' @return A numeric vector of length one giving the number of neighbors.
#'
#' @keywords internal
#'
count_neighbors <- function(graph, node, mode) {
  length(igraph::neighbors(graph, node, mode))
}

#' Given a graph and a node, determine if the node is a split code.
#'
#' @inheritParams update_klass_node
#'
#' @return \code{TRUE} if the node is split, otherwise \code{FALSE}.
#'
#' @details The function will attempt to reconcile nodes that have split and
#'   then later merged again. A node is considered to be split if there is more
#'   than one node that does not itself have children (i.e. nodes at the end of
#'   a sequence of changes) that can be reached from \code{node}
#'
#' @keywords internal
#'
is_split <- function(graph, node) {
  bfs_result <- igraph::bfs(
    graph = graph,
    root = node,
    mode = "out",
    unreachable = FALSE
  )

  end_nodes <- bfs_result$order[vapply(bfs_result$order,
    count_neighbors,
    graph = graph,
    mode = "out",
    FUN.VALUE = integer(1)
  ) == 0]

  length(unique(end_nodes)) > 1
}

#' Given a graph and a node, determine if the node is a result of combinations
#' of multiple codes.
#'
#' @inheritParams update_klass_node
#'
#' @param compare_node Optional. A node to compare \code{node} with when
#'   determining whether \code{node} is combined. See details.
#'
#' @return \code{TRUE} if the node is a combination of two or more nodes,
#'   otherwise \code{FALSE}.
#'
#' @details The function will attempt to reconcile nodes that have split and
#'   then later merged again when evaluating a node's combinedness.
#'
#'   If \code{compare_node == NULL}, a node is considered to be combined if more
#'   than one node that does not itself have a parent (i.e. codes at the start
#'   of a sequence of changes) contribute to \code{node}.
#'
#'   If \code{compare_node != NULL}, a node is considered to be combined if any
#'   node that is not an ancestor of \code{compare_node} contributes to
#'   \code{node}, i.e. all paths from \code{node} to the parents of \code{node}
#'   pass through \code{compare_node}.
#'
#' @keywords internal
#'
is_combined <- function(graph, node, compare_node = NULL) {
  bfs_result <- igraph::bfs(
    graph = graph,
    root = node,
    mode = "in",
    unreachable = FALSE
  )

  start_nodes <- bfs_result$order[vapply(bfs_result$order,
    count_neighbors,
    graph = graph,
    mode = "in",
    FUN.VALUE = integer(1)
  ) == 0]

  if (is.null(compare_node)) {
    length(unique(start_nodes)) > 1
  } else {
    paths <- igraph::all_simple_paths(graph, node, start_nodes, mode = "in")

    return(!all(vapply(paths, function(path) compare_node %in% path, logical(1))))
  }
}

#' Given a node and a graph, find the node at the end of a sequence of changes.
#'
#' @inheritParams klass_node
#' @param node A node as returned by \code{\link{klass_node}} or
#'   \code{\link[igraph]{V}}.
#'
#' @return A sequence of vertices, starting with \code{node} and ending with the
#'   last visited node.
#'
#' @export
#'
#' @examples
#'
#' # Build a graph directed towards the most recent codes.
#' library(klassR)
#' klass_131 <- klass_graph(131)
#'
#' # Find the most recent node in the graph representing the code "0101" (Halden,
#' # valid to 2020.)
#' halden_node <- klass_node(klass_131, "0101")
#'
#' # Find the most recent code corresponding to 0101 Halden
#' halden_node_updated <- update_klass_node(klass_131, halden_node)
#'
update_klass_node <- function(graph, node) {
  bfs_result <- igraph::bfs(
    graph = graph,
    root = node,
    mode = "out",
    unreachable = FALSE
  )


  end_nodes <- bfs_result$order[vapply(bfs_result$order,
    count_neighbors,
    graph = graph,
    mode = "out",
    FUN.VALUE = integer(1)
  ) == 0]

  visited <- unique(c(
    node,
    bfs_result$order[!bfs_result$order$name %in% unique(end_nodes)$name],
    end_nodes
  ))

  igraph::vertex_attr(graph, "split", visited$name) <-
    unname(vapply(visited, is_split, graph = graph, FUN.VALUE = logical(1)))

  igraph::vertex_attr(graph, "combined", visited$name) <-
    unname(vapply(visited,
      is_combined,
      graph = graph,
      compare_node = node,
      FUN.VALUE = logical(1)
    ))

  igraph::vertex_attr(graph, "nextNodes", visited$name) <-
    lapply(visited, igraph::neighbors, graph = graph, mode = "out")

  visited <- igraph::V(graph)[visited$name]

  return(visited)
}