Add graph_svg(), fn_graph(), pkg_graph()

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: saber
 Type: Package
 Title: Code Analysis and Project Context for R
-Version: 0.6.0
+Version: 0.7.0
 Authors@R: person("Troy", "Hernandez", role = c("aut", "cre"),
     email = "troy@cornball.ai",
     comment = c(ORCID = "0009-0005-4248-604X"))

NAMESPACE

@@ -5,7 +5,10 @@ export(blast_radius)
 export(briefing)
 export(default_exclude)
 export(find_downstream)
+export(fn_graph)
+export(graph_svg)
 export(pkg_exports)
+export(pkg_graph)
 export(pkg_help)
 export(pkg_internals)
 export(projects)

R/fn_graph.R

@@ -0,0 +1,63 @@
+#' @title Function call graph
+#' @description Render a package's internal function call graph.
+
+#' Render a function call graph for an R project
+#'
+#' Pulls the AST symbol index via \code{\link{symbols}} and renders
+#' internal function-to-function call edges as SVG. External calls
+#' (into other packages) are dropped by default.
+#'
+#' @param project_dir Path to the project directory (an R package root).
+#' @param include_external If \code{TRUE}, also include nodes for
+#'   functions called from other packages. Default \code{FALSE}.
+#' @param ... Passed through to \code{\link{graph_svg}} (e.g.,
+#'   \code{width}, \code{height}, \code{iterations}, \code{seed}).
+#' @return Character vector of SVG lines. Write with \code{writeLines()}.
+#' @examples
+#' d <- file.path(tempdir(), "fngdemo")
+#' dir.create(file.path(d, "R"), recursive = TRUE, showWarnings = FALSE)
+#' writeLines(c("Package: demo", "Version: 0.1.0"),
+#'            file.path(d, "DESCRIPTION"))
+#' writeLines("add <- function(x, y) x + y", file.path(d, "R", "add.R"))
+#' writeLines("double <- function(x) add(x, x)",
+#'            file.path(d, "R", "double.R"))
+#' svg <- fn_graph(d)
+#' writeLines(svg, tempfile(fileext = ".svg"))
+#' @export
+fn_graph <- function(project_dir, include_external = FALSE, ...) {
+    idx <- symbols(project_dir)
+    defs <- idx$defs
+    calls <- idx$calls
+
+    if (!include_external) {
+        calls <- calls[calls$callee %in% defs$name,, drop = FALSE]
+    }
+
+    node_ids <- unique(c(defs$name, calls$callee, calls$caller))
+    node_ids <- node_ids[!is.na(node_ids) & nzchar(node_ids)]
+
+    edges <- data.frame(from = calls$caller, to = calls$callee,
+                        stringsAsFactors = FALSE)
+    edges <- unique(edges[!is.na(edges$from) & !is.na(edges$to),, drop = FALSE])
+
+    def_match <- match(node_ids, defs$name)
+    file_rel <- defs$file[def_match]
+    line <- defs$line[def_match]
+    exported <- defs$exported[def_match]
+    in_deg <- tabulate(match(edges$to, node_ids), nbins = length(node_ids))
+    out_deg <- tabulate(match(edges$from, node_ids), nbins = length(node_ids))
+    visibility <- ifelse(is.na(exported), "external",
+                         ifelse(exported, "exported", "internal"))
+    tooltips <- ifelse(
+                       is.na(def_match),
+                       sprintf("%s\n(external)\ncalled by %d", node_ids, in_deg),
+                       sprintf("%s\n%s:%d\n%s\ncalled by %d | calls %d",
+                               node_ids, file_rel, line, visibility, in_deg, out_deg))
+
+    nodes <- data.frame(id = node_ids, label = node_ids,
+                        href = NA_character_, tooltip = tooltips,
+                        stringsAsFactors = FALSE)
+
+    graph_svg(edges, nodes, ...)
+}
+

R/graph_svg.R

@@ -0,0 +1,159 @@
+#' @title Force-directed graph rendering
+#' @description Render a graph as static SVG using a base R
+#'   Fruchterman-Reingold force simulation.
+
+#' Render a graph as static SVG
+#'
+#' Runs a Fruchterman-Reingold force simulation to lay out nodes, then
+#' emits SVG with baked coordinates. Output is interactive via native
+#' browser features: hover tooltips from \code{<title>} elements, click
+#' navigation from \code{<a xlink:href>} wrappers, CSS \code{:hover}
+#' highlighting. No JavaScript.
+#'
+#' Suitable for graphs up to roughly a few hundred nodes. The repulsion
+#' step is vectorized via \code{outer()} but allocates an
+#' \code{n x n} matrix per iteration; larger graphs should pre-filter.
+#'
+#' @param edges Data frame with \code{from} and \code{to} columns
+#'   holding node ids.
+#' @param nodes Optional data frame with \code{id}, \code{label},
+#'   \code{href} columns. Optionally a \code{tooltip} column (plain
+#'   text, may contain newlines) that overrides the default hover
+#'   text (which is the label). \code{id} must cover every node
+#'   mentioned in \code{edges}. If \code{NULL}, ids from \code{edges}
+#'   are used as labels with no hrefs or tooltips.
+#' @param width SVG viewport width in pixels.
+#' @param height SVG viewport height in pixels.
+#' @param iterations Force-simulation steps. 50 is usually enough.
+#' @param seed Integer seed for the random initial layout (output is
+#'   deterministic given the same seed).
+#' @return Character vector, one SVG element per line. Write with
+#'   \code{writeLines()}.
+#' @examples
+#' edges <- data.frame(from = c("a", "a", "b"),
+#'                     to = c("b", "c", "c"))
+#' svg <- graph_svg(edges)
+#' writeLines(svg, tempfile(fileext = ".svg"))
+#' @export
+graph_svg <- function(edges, nodes = NULL, width = 1200L, height = 900L,
+                      iterations = 50L, seed = 1L) {
+    ids <- unique(c(edges$from, edges$to))
+    if (is.null(nodes)) {
+        nodes <- data.frame(id = ids, label = ids, href = NA_character_,
+                            stringsAsFactors = FALSE)
+    }
+    if (!all(ids %in% nodes$id)) {
+        missing <- setdiff(ids, nodes$id)
+        stop("Edge refers to unknown node id: ",
+             paste(head(missing, 5L), collapse = ", "))
+    }
+
+    n <- nrow(nodes)
+    from_i <- match(edges$from, nodes$id)
+    to_i <- match(edges$to, nodes$id)
+
+    set.seed(seed)
+    x <- runif(n, width / 4, 3 * width / 4)
+    y <- runif(n, height / 4, 3 * height / 4)
+    # FR's ideal edge length. Cap at min-dim/4 so small graphs don't
+    # stretch to the viewport bounds.
+    k <- min(sqrt(width * height / max(n, 1L)), min(width, height) / 4)
+    temp <- width / 20
+    cx <- width / 2
+    cy <- height / 2
+    # Gravity pulls nodes toward the center each iteration. Without it,
+    # repulsion wins and nodes pile up on the clamp at the edges.
+    gravity <- 0.05
+    margin <- 40
+
+    for (iter in seq_len(iterations)) {
+        dx_m <- outer(x, x, "-")
+        dy_m <- outer(y, y, "-")
+        dist_m <- sqrt(dx_m ^ 2 + dy_m ^ 2) + 1e-6
+        rep_f <- k ^ 2 / dist_m
+        diag(rep_f) <- 0
+        dx <- rowSums(dx_m / dist_m * rep_f)
+        dy <- rowSums(dy_m / dist_m * rep_f)
+
+        if (length(from_i)) {
+            evx <- x[from_i] - x[to_i]
+            evy <- y[from_i] - y[to_i]
+            edist <- sqrt(evx ^ 2 + evy ^ 2) + 1e-6
+            att_f <- edist ^ 2 / k
+            ax <- evx / edist * att_f
+            ay <- evy / edist * att_f
+            for (e in seq_along(from_i)) {
+                dx[from_i[e]] <- dx[from_i[e]] - ax[e]
+                dy[from_i[e]] <- dy[from_i[e]] - ay[e]
+                dx[to_i[e]] <- dx[to_i[e]] + ax[e]
+                dy[to_i[e]] <- dy[to_i[e]] + ay[e]
+            }
+        }
+
+        dx <- dx - (x - cx) * gravity * k
+        dy <- dy - (y - cy) * gravity * k
+
+        disp <- sqrt(dx ^ 2 + dy ^ 2) + 1e-6
+        x <- x + dx / disp * pmin(disp, temp)
+        y <- y + dy / disp * pmin(disp, temp)
+        x <- pmin(pmax(x, margin), width - margin)
+        y <- pmin(pmax(y, margin), height - margin)
+        temp <- temp * 0.95
+    }
+
+    out <- c(
+             sprintf('<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" viewBox="0 0 %d %d">',
+                     width, height),
+             "<style>",
+             "  .node { fill: #4c78a8; stroke: #fff; stroke-width: 1.5; cursor: pointer; }",
+             "  .node:hover { fill: #f58518; }",
+             "  .edge { stroke: #999; stroke-opacity: 0.4; }",
+             "  .label { font: 11px sans-serif; pointer-events: none; fill: #333; }",
+             "</style>"
+    )
+
+    for (e in seq_along(from_i)) {
+        out <- c(out, sprintf(
+                              '<line class="edge" x1="%.1f" y1="%.1f" x2="%.1f" y2="%.1f"/>',
+                              x[from_i[e]], y[from_i[e]], x[to_i[e]], y[to_i[e]]))
+    }
+
+    has_tooltip <- "tooltip" %in% names(nodes)
+    for (i in seq_len(n)) {
+        label <- xml_escape(as.character(nodes$label[i]))
+        tip_raw <- if (has_tooltip && !is.na(nodes$tooltip[i]) &&
+            nzchar(nodes$tooltip[i])) {
+            nodes$tooltip[i]
+        } else {
+            nodes$label[i]
+        }
+        tip <- xml_escape(as.character(tip_raw))
+        # Preserve newlines in tooltip via XML numeric entity so the
+        # SVG stays on one line on disk; browsers render &#10; as a
+        # line break in native tooltip rendering.
+        tip <- gsub("\n", "&#10;", tip, fixed = TRUE)
+        node <- sprintf(paste0(
+                               '<circle class="node" cx="%.1f" cy="%.1f" r="6"><title>%s</title></circle>',
+                               '<text class="label" x="%.1f" y="%.1f">%s</text>'),
+                        x[i], y[i], tip,
+                        x[i] + 8, y[i] + 4, label)
+        href <- nodes$href[i]
+        if (!is.na(href) && nzchar(href)) {
+            node <- sprintf('<a xlink:href="%s">%s</a>', xml_escape(href), node)
+        }
+        out <- c(out, node)
+    }
+
+    c(out, "</svg>")
+}
+
+#' Escape text for safe inclusion in SVG/XML
+#' @noRd
+xml_escape <- function(s) {
+    s <- gsub("&", "&amp;", s, fixed = TRUE)
+    s <- gsub("<", "&lt;", s, fixed = TRUE)
+    s <- gsub(">", "&gt;", s, fixed = TRUE)
+    s <- gsub('"', "&quot;", s, fixed = TRUE)
+    s
+}
+

R/pkg_graph.R

@@ -0,0 +1,103 @@
+#' @title Package dependency graph
+#' @description Render the dependency graph across a set of R packages.
+
+#' Render a package-level dependency graph
+#'
+#' Discovers R packages under \code{scan_dir} via \code{\link{projects}},
+#' parses each one's \code{Depends} and \code{Imports} fields, and
+#' renders edges between packages that both live in \code{scan_dir}.
+#' External CRAN dependencies are dropped.
+#'
+#' @param scan_dir Directory to scan for project directories.
+#' @param packages Optional character vector limiting the graph to
+#'   these packages.
+#' @param include_suggests If \code{TRUE}, also include edges for
+#'   packages in each project's \code{Suggests} field. Default
+#'   \code{FALSE} (only \code{Depends} and \code{Imports}).
+#' @param ... Passed through to \code{\link{graph_svg}}.
+#' @return Character vector of SVG lines. Write with \code{writeLines()}.
+#' @examples
+#' d <- file.path(tempdir(), "pkgdemo")
+#' dir.create(file.path(d, "parent"), recursive = TRUE, showWarnings = FALSE)
+#' dir.create(file.path(d, "child"), showWarnings = FALSE)
+#' writeLines(c("Package: parent", "Title: P", "Version: 0.1.0"),
+#'            file.path(d, "parent", "DESCRIPTION"))
+#' writeLines(c("Package: child", "Title: C", "Version: 0.1.0",
+#'              "Imports: parent"),
+#'            file.path(d, "child", "DESCRIPTION"))
+#' svg <- pkg_graph(scan_dir = d)
+#' writeLines(svg, tempfile(fileext = ".svg"))
+#' @export
+pkg_graph <- function(scan_dir = path.expand("~"), packages = NULL,
+                      include_suggests = FALSE, ...) {
+    projs <- projects(scan_dir = scan_dir)
+    if (!is.null(packages)) {
+        projs <- projs[projs$package %in% packages,, drop = FALSE]
+    }
+    if (nrow(projs) == 0L) {
+        stop("No packages found under ", scan_dir)
+    }
+
+    known <- projs$package
+    edges <- list()
+    dep_counts <- integer(nrow(projs))
+    local_counts <- integer(nrow(projs))
+    for (i in seq_len(nrow(projs))) {
+        all_deps <- c(parse_deps(projs$depends[i]),
+                      parse_deps(projs$imports[i]))
+        if (include_suggests) {
+            all_deps <- c(all_deps, read_suggests(projs$path[i]))
+        }
+        local <- intersect(all_deps, known)
+        dep_counts[i] <- length(unique(all_deps))
+        local_counts[i] <- length(local)
+        if (length(local)) {
+            edges[[i]] <- data.frame(from = projs$package[i], to = local,
+                                     stringsAsFactors = FALSE)
+        }
+    }
+    edges <- do.call(rbind, edges)
+    if (is.null(edges)) {
+        edges <- data.frame(from = character(), to = character(),
+                            stringsAsFactors = FALSE)
+    }
+
+    tooltips <- sprintf("%s %s\n%s\n%d deps (%d local)",
+                        projs$package, projs$version,
+                        ifelse(is.na(projs$title) | !nzchar(projs$title),
+                               "(no title)", projs$title),
+                        dep_counts, local_counts)
+
+    nodes <- data.frame(id = projs$package, label = projs$package,
+                        href = NA_character_, tooltip = tooltips,
+                        stringsAsFactors = FALSE)
+
+    graph_svg(edges, nodes, ...)
+}
+
+#' Read the Suggests field from a package's DESCRIPTION, returning a
+#' character vector of package names with version constraints stripped.
+#' @noRd
+read_suggests <- function(pkg_path) {
+    desc_path <- file.path(pkg_path, "DESCRIPTION")
+    if (!file.exists(desc_path)) {
+        return(character())
+    }
+    fields <- read.dcf(desc_path, fields = "Suggests")
+    parse_deps(fields[1L, "Suggests"])
+}
+
+#' Parse a comma-separated dependency field from a DESCRIPTION column,
+#' stripping version constraints and whitespace.
+#' @noRd
+parse_deps <- function(s) {
+    if (is.null(s) || is.na(s) || !nzchar(s)) {
+        return(character())
+    }
+    parts <- strsplit(s, ",", fixed = TRUE)[[1L]]
+    parts <- sub("\\s*\\(.*\\)\\s*$", "", parts)
+    parts <- trimws(parts)
+    parts <- parts[parts != "R" & nzchar(parts)]
+    parts
+}
+

inst/tinytest/test_fn_graph.R

@@ -0,0 +1,19 @@
+# Tests for fn_graph.R
+
+library(saber)
+
+d <- file.path(tempdir(), paste0("fngraph-", format(Sys.time(), "%H%M%S")))
+dir.create(file.path(d, "R"), recursive = TRUE, showWarnings = FALSE)
+writeLines(c("Package: demo", "Version: 0.1.0"), file.path(d, "DESCRIPTION"))
+writeLines("add <- function(x, y) x + y", file.path(d, "R", "add.R"))
+writeLines("double <- function(x) add(x, x)", file.path(d, "R", "double.R"))
+
+svg <- fn_graph(d)
+expect_true(is.character(svg))
+expect_true(any(grepl("^<svg", svg)))
+# Tooltips carry name + file:line + visibility + degree
+expect_true(any(grepl("add.R:1", svg, fixed = TRUE)))
+expect_true(any(grepl("double.R:1", svg, fixed = TRUE)))
+expect_true(any(grepl("called by 1", svg, fixed = TRUE)))
+expect_true(any(grepl("calls 1", svg, fixed = TRUE)))
+expect_equal(sum(grepl("<line ", svg)), 1L)