feat(transmission): general-purpose tree reconstruction from observed…

… events (M13, #78)
USCCANA · aoliveram · Dec 10, 2025 · Dec 10, 2025 · Dec 27, 2025 · Dec 27, 2025
commit 688001a037bf2e659adb6a9f331c409afb471be1
diff --git a/NAMESPACE b/NAMESPACE
@@ -230,6 +230,7 @@ export(tod)
 export(tod_all)
 export(transformGraphBy)
 export(transmission_tree)
+export(transmission_tree_from_events)
 export(vertex_covariate_compare)
 export(vertex_covariate_dist)
 export(vertex_mahalanobis_dist)

diff --git a/R/diffnet-epi.R b/R/diffnet-epi.R
@@ -17,6 +17,16 @@
 #' @param pars Optional named list stored verbatim in
 #'   \code{x$transmission$pars}. Only consulted when \code{transmission} is
 #'   \code{NULL} or carries no \code{pars} of its own.
+#' @param attribution Optional source-attribution rule. When non-\code{NULL},
+#'   the tree is reconstructed from \code{x}'s graph slices and \code{toa}
+#'   via \code{\link{transmission_tree_from_events}} using this rule. Accepts
+#'   one of \code{"uniform"} / \code{"weighted"} / \code{"earliest"} or a
+#'   function with the \code{\link{source_attribution}} contract. Mutually
+#'   exclusive with \code{transmission}.
+#' @param seed Optional integer forwarded to
+#'   \code{\link{transmission_tree_from_events}} so the stochastic
+#'   attribution rules (\code{"uniform"}, \code{"weighted"}) produce a
+#'   reproducible tree. Ignored when \code{attribution} is \code{NULL}.
 #' @param ... Further arguments. Accepted for compatibility with the
 #'   \code{\link[base]{print}} generic; currently ignored by
 #'   \code{print.diffnet_epi}.
@@ -85,18 +95,39 @@
 #' is.diffnet_epi(dn_epi)              # TRUE (promoted automatically)
 #' transmission_tree(dn_epi)            # 2 rows
 #'
+#' # Reconstruct the tree from x's graph + toa via source-attribution
+#' # (general primitive — useful when you have observed adoption times
+#' # but no transmission log, like contact-tracing or experiment data).
+#' dn_epi <- as_diffnet_epi(dn, attribution = "uniform", seed = 2026)
+#' transmission_tree(dn_epi)
+#'
 #' @name diffnet_epi
 #' @aliases diffnet_epi
 #' @author Aníbal Olivera M.
 NULL
 
 #' @rdname diffnet_epi
 #' @export
-as_diffnet_epi <- function(x, transmission = NULL, pars = list()) {
+as_diffnet_epi <- function(x, transmission = NULL, pars = list(),
+                           attribution = NULL, seed = NULL) {
 
   if (!inherits(x, "diffnet"))
     stop("-x- must be a diffnet object.")
 
+  if (!is.null(attribution) && !is.null(transmission))
+    stop("Pass either -transmission- (pre-built tree) or -attribution- ",
+         "(reconstruct tree from x's graph and toa), not both.")
+
+  # M13: reconstruct the tree from x's graph + toa using the chosen
+  # source-attribution rule. Returns a data.frame in canonical schema
+  # which we then wrap into the standard transmission = list(tree, pars).
+  if (!is.null(attribution)) {
+    tree <- transmission_tree_from_events(
+      x, attribution = attribution, pars = pars, seed = seed
+    )
+    transmission <- list(tree = tree, pars = pars)
+  }
+
   # Monotone promotion: prepend diffnet_epi to the class vector if absent.
   if (!inherits(x, "diffnet_epi"))
     class(x) <- c("diffnet_epi", class(x))

diff --git a/R/transmission.R b/R/transmission.R
@@ -129,6 +129,188 @@ as_transmission_tree <- function(x, tree, pars = list()) {
   x
 }
 
+#' Reconstruct a transmission tree from observed adoption times (M13)
+#'
+#' Given a dynamic contact network and per-node times of adoption, infer a
+#' transmission tree by source-attribution: for each infection event, pick
+#' the most plausible infector among the target's adopted neighbours at the
+#' slice where the target was infected. The selection rule is the user's
+#' choice (one of the bundled \code{\link{source_attribution}} kernels or a
+#' user-supplied function that follows the same contract).
+#'
+#' This is the general-purpose primitive behind \code{rdiffnet()}'s
+#' lineage-tracking (M8): the same algorithm that constructs the tree
+#' during simulation also constructs it post-hoc from observed data, which
+#' is what makes data products like \code{\link{epigamesDiffNet}} possible
+#' without bespoke parsing code.
+#'
+#' @param x Either a \code{\link{diffnet}} object (graphs and \code{toa}
+#'   read from its slots), or a list of adjacency matrices — one per
+#'   time slice. When a list, \code{toa} must be supplied.
+#' @param toa Times-of-adoption. Integer vector of length \eqn{n}
+#'   (single-behaviour) or \eqn{n \times Q} integer matrix (multi-behaviour).
+#'   \code{NA} marks a node that never adopted. Ignored when \code{x} is a
+#'   diffnet (read from \code{x$toa} instead).
+#' @param attribution The source-attribution rule. Either a string —
+#'   \code{"uniform"}, \code{"weighted"}, or \code{"earliest"} (the
+#'   bundled kernels) — or a function with the same signature as
+#'   \code{\link{source_attribution_uniform}}.
+#' @param pars Optional named list. Stored verbatim in
+#'   \code{x$transmission$pars} when the result is wired into
+#'   \code{\link{as_diffnet_epi}}; also forwarded to the attribution
+#'   function as its \code{pars} argument.
+#' @param behavior Optional character vector of length \eqn{Q} naming
+#'   each diffusion process. Used to populate the \code{virus} column of
+#'   the returned tree. Defaults to \code{"behavior_1"}, \code{"behavior_2"},
+#'   ... when \code{NULL}.
+#' @param seed Optional integer. When non-\code{NULL}, calls
+#'   \code{\link{set.seed}} once before reconstruction so the stochastic
+#'   attribution rules (\code{"uniform"}, \code{"weighted"}) produce a
+#'   reproducible tree.
+#'
+#' @return A \code{data.frame} with the canonical transmission-tree
+#'   schema: \code{date}, \code{source}, \code{target},
+#'   \code{source_exposure_date}, \code{virus_id}, \code{virus}.
+#'   One row per infection event (seeds included, with
+#'   \code{source = NA}). Suitable to pass straight to
+#'   \code{\link{as_transmission_tree}}.
+#'
+#' @details
+#' For every \code{(target, virus_id)} pair with non-\code{NA} \code{toa},
+#' the algorithm inspects the slice \code{x$graph[[toa[target, q]]]} and
+#' picks the source among target's neighbours that were already adopted
+#' (\code{toa[v, q] < toa[target, q]}). Targets with no adopted neighbour
+#' at the moment of their adoption become seeds (\code{source = NA}).
+#' Multi-behaviour diffnets are handled one behaviour at a time; the
+#' resulting rows are concatenated.
+#'
+#' Under SIRS-style re-infection \code{toa[target, q]} only stores the
+#' \emph{latest} infection time, so the reconstructed tree will only carry
+#' one row per node per virus. To capture every entry into I, build the
+#' tree at simulation time via
+#' \code{rdiffnet(..., source_attribution = ...)} instead — that path
+#' records each fresh adoption as it happens.
+#'
+#' @examples
+#' set.seed(2026)
+#' # Build a tiny absorbing diffnet, then reconstruct its tree post-hoc.
+#' g  <- lapply(1:5, function(t) rgraph_ba(t = 4L))
+#' toa <- c(1L, 2L, 3L, NA, 5L)
+#' dn  <- new_diffnet(g, toa = toa, t0 = 1L, t1 = 5L)
+#'
+#' tree <- transmission_tree_from_events(dn, attribution = "uniform",
+#'                                       seed = 2026)
+#' head(tree)
+#'
+#' # Promote to diffnet_epi in one step:
+#' dn_epi <- as_diffnet_epi(dn, attribution = "uniform")
+#' is.diffnet_epi(dn_epi)
+#'
+#' @seealso \code{\link{source_attribution}},
+#'   \code{\link{as_transmission_tree}}, \code{\link{as_diffnet_epi}}
+#' @author Aníbal Olivera M.
+#' @export
+transmission_tree_from_events <- function(x,
+                                          toa         = NULL,
+                                          attribution = "uniform",
+                                          pars        = list(),
+                                          behavior    = NULL,
+                                          seed        = NULL) {
+
+  # 1. Coerce inputs.
+  if (inherits(x, "diffnet")) {
+    graphs <- x$graph
+    if (is.null(toa)) toa <- x$toa
+  } else if (is.list(x)) {
+    graphs <- x
+    if (is.null(toa))
+      stop("-toa- is required when -x- is a list of graphs.")
+  } else {
+    stop("-x- must be a diffnet or a list of adjacency matrices.")
+  }
+
+  # 2. Normalize attribution -> function.
+  attr_fn <- if (is.character(attribution)) {
+    switch(attribution,
+      "uniform"  = source_attribution_uniform,
+      "weighted" = source_attribution_weighted,
+      "earliest" = source_attribution_earliest,
+      stop("Unknown -attribution-: ", attribution,
+           ". Expected \"uniform\", \"weighted\", or \"earliest\".")
+    )
+  } else if (is.function(attribution)) {
+    attribution
+  } else {
+    stop("-attribution- must be a function or a string.")
+  }
+
+  # 3. Normalize toa to n x Q integer matrix.
+  if (is.null(dim(toa)))
+    toa <- matrix(as.integer(toa), ncol = 1L)
+  else
+    storage.mode(toa) <- "integer"
+
+  n <- nrow(toa)
+  Q <- ncol(toa)
+
+  # 4. Normalize behavior labels.
+  if (is.null(behavior))
+    behavior <- paste0("behavior_", seq_len(Q))
+  else
+    behavior <- as.character(behavior)
+  if (length(behavior) != Q)
+    stop("-behavior- must have length ", Q,
+         " (one entry per column of -toa-).")
+
+  # 5. Seed once for reproducibility of stochastic attributors.
+  if (!is.null(seed)) set.seed(seed)
+
+  # 6. Walk adopters in chronological order per behaviour.
+  T_slices <- length(graphs)
+  tree_rows <- list()
+
+  for (q in seq_len(Q)) {
+    adopters <- which(!is.na(toa[, q]))
+    if (!length(adopters)) next
+    adopters <- adopters[order(toa[adopters, q])]
+
+    for (target in adopters) {
+      t_inf <- toa[target, q]
+      if (is.na(t_inf) || t_inf < 1L || t_inf > T_slices) next
+
+      g_slice <- graphs[[t_inf]]
+      row_i   <- as.vector(g_slice[target, ])
+      col_i   <- as.vector(g_slice[, target])
+      nbrs    <- which((row_i != 0) | (col_i != 0))
+      # Keep only neighbours adopted strictly before the target.
+      nbrs    <- nbrs[!is.na(toa[nbrs, q]) & toa[nbrs, q] < t_inf]
+
+      if (length(nbrs)) {
+        # Sort by ascending toa so attributors that exploit ordering
+        # (e.g. source_attribution_earliest) see the same contract as
+        # they do inside rdiffnet's M8 path.
+        nbrs    <- nbrs[order(toa[nbrs, q])]
+        weights <- pmax(row_i[nbrs], col_i[nbrs])
+        src     <- attr_fn(target, nbrs, weights, t_inf, pars)
+      } else {
+        src <- NA_integer_
+      }
+
+      sed <- if (is.na(src)) NA_integer_ else as.integer(toa[src, q])
+      tree_rows[[length(tree_rows) + 1L]] <- list(
+        date                 = as.integer(t_inf),
+        source               = as.integer(src),
+        target               = as.integer(target),
+        source_exposure_date = sed,
+        virus_id             = as.integer(q),
+        virus                = behavior[[q]]
+      )
+    }
+  }
+
+  rdiffnet_tree_rows_to_df(tree_rows)
+}
+
 #' Retrieve the transmission tree of a \code{\link{diffnet_epi}} object
 #'
 #' Returns the data.frame stored in \code{x$transmission$tree} for objects

diff --git a/data-raw/epigamesDiffNet.R b/data-raw/epigamesDiffNet.R
@@ -74,5 +74,13 @@ epigamesDiffNet <- as_diffnet(
   t1 = N_DAYS
 )
 
+# Reconstruct a transmission tree from the observed daily contact
+# network and the per-node times of adoption.
+epigamesDiffNet <- as_diffnet_epi(
+  epigamesDiffNet,
+  attribution = "uniform",
+  seed        = 2026
+)
+
 # Save
 usethis::use_data(epigamesDiffNet, overwrite = TRUE, compress = "xz")
diff --git a/data/epigamesDiffNet.rda b/data/epigamesDiffNet.rda
diff --git a/man/diffnet_epi.Rd b/man/diffnet_epi.Rd
diff --git a/man/secondary_attack_rate.Rd b/man/secondary_attack_rate.Rd