diff --git a/DESCRIPTION b/DESCRIPTION index 495726f..b01990b 100644 --- a/DESCRIPTION +++ b/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")) diff --git a/NAMESPACE b/NAMESPACE index cfcdc61..00959b1 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/fn_graph.R b/R/fn_graph.R new file mode 100644 index 0000000..6cc7d90 --- /dev/null +++ b/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, ...) +} + diff --git a/R/graph_svg.R b/R/graph_svg.R new file mode 100644 index 0000000..11750d1 --- /dev/null +++ b/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{} 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 as a + # line break in native tooltip rendering. + tip <- gsub("\n", " ", tip, fixed = TRUE) + node <- sprintf(paste0( + '<circle class="node" cx="%.1f" cy="%.1f" r="6"><title>%s', + '%s'), + x[i], y[i], tip, + x[i] + 8, y[i] + 4, label) + href <- nodes$href[i] + if (!is.na(href) && nzchar(href)) { + node <- sprintf('%s', xml_escape(href), node) + } + out <- c(out, node) + } + + c(out, "") +} + +#' Escape text for safe inclusion in SVG/XML +#' @noRd +xml_escape <- function(s) { + s <- gsub("&", "&", s, fixed = TRUE) + s <- gsub("<", "<", s, fixed = TRUE) + s <- gsub(">", ">", s, fixed = TRUE) + s <- gsub('"', """, s, fixed = TRUE) + s +} + diff --git a/R/pkg_graph.R b/R/pkg_graph.R new file mode 100644 index 0000000..54e9e62 --- /dev/null +++ b/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 +} + diff --git a/inst/tinytest/test_fn_graph.R b/inst/tinytest/test_fn_graph.R new file mode 100644 index 0000000..73e84ef --- /dev/null +++ b/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))) +expect_equal(sum(grepl("a", svg))) + +# Deterministic layout +svg1 <- graph_svg(edges, seed = 42L) +svg2 <- graph_svg(edges, seed = 42L) +expect_equal(svg1, svg2) + +svg3 <- graph_svg(edges, seed = 99L) +expect_false(identical(svg1, svg3)) + +# Hrefs wrap in anchors +nodes <- data.frame(id = c("a", "b", "c"), + label = c("Alpha", "Beta", "Gamma"), + href = c("a.html", "b.html", NA_character_), + stringsAsFactors = FALSE) +svg <- graph_svg(edges, nodes) +expect_true(any(grepl('xlink:href="a.html"', svg, fixed = TRUE))) +expect_equal(sum(grepl("x<y", svg))) +expect_true(any(grepl("z&w", svg))) + +# Custom tooltip column overrides label-based tooltip +nodes3 <- data.frame(id = c("a", "b", "c"), + label = c("a", "b", "c"), + href = NA_character_, + tooltip = c("Alpha node\nversion 1.0", + "Beta node\nversion 2.0", + NA_character_), + stringsAsFactors = FALSE) +svg <- graph_svg(edges, nodes3) +expect_true(any(grepl("Alpha node", svg, fixed = TRUE))) +expect_true(any(grepl("version 1.0", svg, fixed = TRUE))) +# NA tooltip falls back to label +expect_true(any(grepl("c", svg))) + +# Unknown node id -> clear error +expect_error(graph_svg(edges, + nodes = data.frame(id = c("a", "b"), label = c("a", "b"), + href = NA_character_, + stringsAsFactors = FALSE)), + "unknown node id") + +# Empty edges +svg <- graph_svg(edges = data.frame(from = character(), to = character(), + stringsAsFactors = FALSE), + nodes = data.frame(id = c("solo1", "solo2"), + label = c("solo1", "solo2"), + href = NA_character_, + stringsAsFactors = FALSE)) +expect_equal(sum(grepl("= 0.1.0)"), + file.path(child_dir, "DESCRIPTION")) + +svg <- pkg_graph(scan_dir = d) +# Tooltips carry title + version + dep counts +expect_true(any(grepl("parent 0.1.0", svg, fixed = TRUE))) +expect_true(any(grepl("child 0.1.0", svg, fixed = TRUE))) +expect_true(any(grepl("1 deps (1 local)", svg, fixed = TRUE))) +expect_equal(sum(grepl("= 1.0), bar, R (>= 3.5)"), + c("foo", "bar")) +expect_equal(saber:::parse_deps(""), character()) +expect_equal(saber:::parse_deps(NA_character_), character()) + +svg <- pkg_graph(scan_dir = d, packages = "parent") +expect_true(any(grepl("parent 0.1.0", svg, fixed = TRUE))) +expect_false(any(grepl("child 0.1.0", svg, fixed = TRUE))) diff --git a/man/fn_graph.Rd b/man/fn_graph.Rd new file mode 100644 index 0000000..e293c39 --- /dev/null +++ b/man/fn_graph.Rd @@ -0,0 +1,38 @@ +% tinyrox says don't edit this manually, but it can't stop you! +\name{fn_graph} +\alias{fn_graph} +\title{Function call graph} +\usage{ +fn_graph(project_dir, include_external = FALSE, ...) +} +\arguments{ +\item{project_dir}{Path to the project directory (an R package root).} + +\item{include_external}{If \code{TRUE}, also include nodes for +functions called from other packages. Default \code{FALSE}.} + +\item{...}{Passed through to \code{\link{graph_svg}} (e.g., +\code{width}, \code{height}, \code{iterations}, \code{seed}).} +} +\value{ +Character vector of SVG lines. Write with \code{writeLines()}. +} +\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. +} +\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")) +} diff --git a/man/graph_svg.Rd b/man/graph_svg.Rd new file mode 100644 index 0000000..e83d4f4 --- /dev/null +++ b/man/graph_svg.Rd @@ -0,0 +1,53 @@ +% tinyrox says don't edit this manually, but it can't stop you! +\name{graph_svg} +\alias{graph_svg} +\title{Force-directed graph rendering} +\usage{ +graph_svg(edges, nodes = NULL, width = 1200L, height = 900L, iterations = 50L, + seed = 1L) +} +\arguments{ +\item{edges}{Data frame with \code{from} and \code{to} columns +holding node ids.} + +\item{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.} + +\item{width}{SVG viewport width in pixels.} + +\item{height}{SVG viewport height in pixels.} + +\item{iterations}{Force-simulation steps. 50 is usually enough.} + +\item{seed}{Integer seed for the random initial layout (output is +deterministic given the same seed).} +} +\value{ +Character vector, one SVG element per line. Write with + \code{writeLines()}. +} +\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{} 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. +} +\examples{ +edges <- data.frame(from = c("a", "a", "b"), + to = c("b", "c", "c")) +svg <- graph_svg(edges) +writeLines(svg, tempfile(fileext = ".svg")) +} diff --git a/man/pkg_graph.Rd b/man/pkg_graph.Rd new file mode 100644 index 0000000..1adb006 --- /dev/null +++ b/man/pkg_graph.Rd @@ -0,0 +1,44 @@ +% tinyrox says don't edit this manually, but it can't stop you! +\name{pkg_graph} +\alias{pkg_graph} +\title{Package dependency graph} +\usage{ +pkg_graph(scan_dir = path.expand("~"), packages = NULL, + include_suggests = FALSE, ...) +} +\arguments{ +\item{scan_dir}{Directory to scan for project directories.} + +\item{packages}{Optional character vector limiting the graph to +these packages.} + +\item{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}).} + +\item{...}{Passed through to \code{\link{graph_svg}}.} +} +\value{ +Character vector of SVG lines. Write with \code{writeLines()}. +} +\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. +} +\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")) +}