R/path-visual.R

In Dynet: Tidy Temporal Network Analysis

# ===========================================================================
# Honest visual representations of endpoint-local temporal path families
# ===========================================================================

#' Consecutive vertex pairs of every expanded optimal route
#'
#' The steps accessor gives one row per vertex visited; a drawing needs the
#' hops between them. Routes are grouped by session, endpoint and `path_id`
#' so a hop is never assembled across two different routes, and a route of
#' fewer than two vertices contributes none.
#'
#' @param x A result from [paths()].
#' @return A data frame with one row per hop: `from`, `to`, the `time` the hop
#'   reaches `to`, `endpoint`, `path_id`, `path_session`, and `session` when
#'   the path result carries one. Zero rows when no route has a hop.
#' @noRd
.path_hops <- function(x) {
  steps <- as.data.frame(x, what = "steps")
  if (!nrow(steps)) return(data.frame(
    from = character(), to = character(), time = numeric(),
    endpoint = character(), path_id = numeric(), path_session = character(),
    stringsAsFactors = FALSE
  ))
  session <- if ("session" %in% names(steps)) steps$session else
    rep("all", nrow(steps))
  key <- paste(session, steps$endpoint, steps$path_id, sep = "\r")
  groups <- split(seq_len(nrow(steps)), key)
  rows <- lapply(groups, function(index) {
    one <- steps[index, , drop = FALSE]
    one <- one[order(one$step), , drop = FALSE]
    if (nrow(one) < 2L) return(NULL)
    out <- data.frame(
      from = utils::head(one$node, -1L), to = utils::tail(one$node, -1L),
      time = utils::tail(one$time, -1L), endpoint = one$endpoint[[1L]],
      path_id = one$path_id[[1L]], path_session = one$path_session[[1L]],
      stringsAsFactors = FALSE
    )
    if ("session" %in% names(one)) out$session <- one$session[[1L]]
    out
  })
  rows <- Filter(Negate(is.null), rows)
  if (!length(rows)) return(data.frame(
    from = character(), to = character(), time = numeric(),
    endpoint = character(), path_id = numeric(), path_session = character(),
    stringsAsFactors = FALSE
  ))
  out <- do.call(rbind, rows)
  rownames(out) <- NULL
  out
}

#' Build the union network of optimal temporal paths
#'
#' `paths()` uses an endpoint-local foremost-then-shortest criterion, so
#' its routes need not form one predecessor tree. This function therefore
#' returns the honest union of all expanded optimal route hops. Edge `weight`
#' is the number of endpoint/path families using the hop; `first_time` and
#' `last_time` retain its temporal range.
#'
#' @param x A result from [paths()].
#' @return A static `dynet_path_network` cograph netobject, whose two tidy
#'   tables are reached with `as.data.frame(x, what = "edges")` and
#'   `as.data.frame(x, what = "nodes")`. The edge table has one row per hop
#'   used by at least one optimal route, with `from`, `to`, `weight` (how many
#'   endpoint/path families use the hop), `first_time` and `last_time` (the
#'   hop's temporal range) and `n_endpoints` (how many distinct endpoints it
#'   serves). The node table has one row per vertex the source actually
#'   reaches, the source included, with `name`, `arrival_time`, `latency`,
#'   `n_hops`, `n_paths` and `groups` (hop count as a grouping label for
#'   plotting). Unreachable vertices are absent, not present with `NA`.
#'   The network is always directed, because a route hop has an orientation
#'   even when the temporal network does not; hops of a backward path result
#'   still point the way time runs, from the sender towards the queried
#'   target, and its `arrival_time` is that vertex's latest-departure
#'   supremum, as in [paths()].
#'
#'   A result that is not from [paths()] raises `dynet_bad_input`; a path
#'   result with no reachable vertex raises `dynet_empty_result`.
#' @examples
#' dn <- dynet(school_contacts)
#' routes <- paths(dn, from = "Ana")
#' union_network <- path_network(routes)
#' as.data.frame(union_network)
#' as.data.frame(union_network, what = "nodes")
#' @export
path_network <- function(x) {
  if (!inherits(x, "dynet_paths")) {
    stop(errorCondition("`x` must be a result from `paths()`.",
                        class = "dynet_bad_input", call = NULL))
  }
  hops <- .path_hops(x)
  paths <- as.data.frame(x)
  nodes <- paths[paths$reachable, c("node", "arrival_time", "latency",
                                    "n_hops", "n_paths"), drop = FALSE]
  if (!nrow(nodes)) {
    stop(errorCondition("The path result has no reachable vertices.",
                        class = "dynet_empty_result", call = NULL))
  }
  if (nrow(hops)) {
    key <- paste(hops$from, hops$to, sep = "\r")
    groups <- split(seq_len(nrow(hops)), key)
    edges <- do.call(rbind, lapply(groups, function(index) data.frame(
      from = hops$from[index[[1L]]], to = hops$to[index[[1L]]],
      weight = length(index), first_time = min(hops$time[index]),
      last_time = max(hops$time[index]),
      n_endpoints = length(unique(hops$endpoint[index])),
      stringsAsFactors = FALSE
    )))
    edges <- edges[order(edges$from, edges$to), , drop = FALSE]
    rownames(edges) <- NULL
  } else {
    edges <- data.frame(
      from = character(), to = character(), weight = numeric(),
      first_time = numeric(), last_time = numeric(), n_endpoints = integer(),
      stringsAsFactors = FALSE
    )
  }
  names <- nodes$node
  from_id <- match(edges$from, names)
  to_id <- match(edges$to, names)
  weights <- matrix(0, nrow(nodes), nrow(nodes),
                    dimnames = list(names, names))
  if (nrow(edges)) weights[cbind(from_id, to_id)] <- edges$weight
  node_table <- data.frame(
    id = seq_len(nrow(nodes)), label = names, name = names,
    x = NA_real_, y = NA_real_,
    arrival_time = nodes$arrival_time, latency = nodes$latency,
    n_hops = nodes$n_hops, n_paths = nodes$n_paths,
    groups = as.character(nodes$n_hops), stringsAsFactors = FALSE
  )
  edge_table <- data.frame(
    from = from_id, to = to_id, weight = edges$weight,
    edges[, setdiff(names(edges), c("from", "to", "weight")), drop = FALSE],
    stringsAsFactors = FALSE
  )
  structure(list(
    nodes = node_table, edges = edge_table,
    directed = TRUE, weights = weights, data = edges,
    meta = list(
      source = "dynet", type = "temporal_path_union",
      path_source = attr(x, "source"), direction = attr(x, "direction"),
      criterion = attr(x, "criterion"), path_mode = attr(x, "path_mode"),
      time_unit = attr(x, "time_unit")
    ),
    node_groups = data.frame(node = names, group = as.character(nodes$n_hops),
                             stringsAsFactors = FALSE)
  ), class = c("dynet_path_network", "netobject", "cograph_network"))
}

#' Tidy tables from a temporal path-union network
#' @param x A network returned by [path_network()].
#' @param row.names,optional Ignored.
#' @param what `"edges"`, the default, or `"nodes"`.
#' @param ... Ignored.
#' @return A plain `data.frame`. For `"edges"`, one row per hop used by an
#'   optimal route, with `from`, `to`, `weight`, `first_time`, `last_time` and
#'   `n_endpoints`. For `"nodes"`, one row per reached vertex, with `name`,
#'   `arrival_time`, `latency`, `n_hops`, `n_paths` and `groups`. See
#'   [path_network()] for what each column means.
#' @examples
#' dn <- dynet(school_contacts)
#' routes <- paths(dn, from = "Ana")
#' union_network <- path_network(routes)
#' as.data.frame(union_network, what = "edges")
#' as.data.frame(union_network, what = "nodes")
#' @export
as.data.frame.dynet_path_network <- function(
    x, row.names = NULL, optional = FALSE, what = c("edges", "nodes"), ...) {
  what <- match.arg(what)
  out <- if (identical(what, "edges")) x$data else
    x$nodes[, setdiff(names(x$nodes), c("id", "label", "x", "y")), drop = FALSE]
  rownames(out) <- NULL
  out
}