beatrina 0.8.6

package/kernel/deployment.R

@@ -0,0 +1,165 @@
+# deployment.R — where this kernel listens, and who is allowed to reach it.
+#
+# CarmaR was written for exactly one deployment: a loopback socket serving one
+# person on their own machine. Every trust rule in serve.R is an expression of
+# that, and one of them INVERTS the moment the socket leaves loopback:
+#
+#   a request with NO Origin header is currently allowed outright.
+#
+# On 127.0.0.1 that is correct and deliberate — no Origin means "not a
+# browser", i.e. the launcher, R, curl, the MCP bridge, all of which are the
+# same OS user, all of which could have run `Rscript` themselves. The socket
+# grants them nothing they did not already have.
+#
+# On 0.0.0.0 the identical rule reads: `curl` from anywhere on the network may
+# execute R as this user, without so much as a consent click. Same code, same
+# header, opposite meaning — because the premise that "no Origin" implies
+# "same user" was a fact about loopback, not a fact about HTTP.
+#
+# So this module computes the posture ONCE, at startup, and hands serve.R a
+# decided answer rather than an environment variable to re-interpret at each
+# call site. Everything here is pure: `env` is injected so the whole policy is
+# testable without a server (test/deployment.test.mjs drives it through R).
+#
+# The refusals are the point. Binding off loopback is a deployment decision
+# with consequences the operator must state out loud:
+#
+#   · no CARMAR_HOSTS            → refuse. An unset Host allow-list off
+#                                  loopback is a DNS-rebinding hole with the
+#                                  door held open.
+#   · no authentication in front → refuse, unless CARMAR_ALLOW_UNAUTHENTICATED
+#                                  is set. The variable is deliberately long
+#                                  and unpleasant to type; it is a decision,
+#                                  not a default.
+#
+# The intended P0 shape is one CarmaR per person, each as their own OS user on
+# its own port, with TLS and login in a reverse proxy (Caddy + OIDC
+# forward-auth). serve.R never sees a password; it trusts an identity header,
+# and only from the proxy address. See docs/server.md.
+
+`%||%` <- if (exists("%||%")) `%||%` else function(a, b) if (is.null(a)) b else a
+
+LOOPBACK_HOSTS <- c("127.0.0.1", "::1", "[::1]", "localhost")
+
+#' Split a comma/space-separated environment value into trimmed, non-empty parts.
+split_list <- function(value) {
+  parts <- trimws(unlist(strsplit(value %||% "", "[,[:space:]]+")))
+  parts[nzchar(parts)]
+}
+
+#' Is this bind address one of the loopback literals?
+#'
+#' Deliberately a literal comparison and not a resolve: a NAME that currently
+#' resolves to 127.0.0.1 is not the same promise as an address that cannot
+#' leave the machine, and the whole point of the flag is that it cannot be
+#' talked into being true.
+is_loopback_bind <- function(bind) tolower(bind %||% "") %in% LOOPBACK_HOSTS
+
+#' Compute the deployment posture from the environment.
+#'
+#' @param port the port the server will listen on.
+#' @param env  a getter with `Sys.getenv`'s signature; injected for tests.
+#' @return a list with `bind`, `loopback`, `origins` (exact strings that may
+#'   open a socket with no consent click), `hosts` (accepted Host headers),
+#'   `allow_native` (may an Origin-less client connect?), `trust_proxy`,
+#'   `user_header`, `proxy_addrs`, and `errors` — a character vector that is
+#'   EMPTY when the posture is safe to serve. A non-empty `errors` must abort
+#'   startup; it is never a warning.
+carmar_deployment <- function(port, env = Sys.getenv) {
+  bind <- trimws(env("CARMAR_BIND", "127.0.0.1"))
+  if (!nzchar(bind)) bind <- "127.0.0.1"
+  loopback <- is_loopback_bind(bind)
+
+  # The origin this kernel serves its own page from is always allowed: that is
+  # the same-origin case, and it is what `origin_ok` meant before this file
+  # existed. Off loopback the server is behind a proxy, so its own page
+  # arrives with the PROXY's origin — which the operator must name.
+  self_origins <- c(sprintf("http://%s:%d", bind, port),
+                    sprintf("http://127.0.0.1:%d", port),
+                    sprintf("http://localhost:%d", port))
+  origins <- unique(c(self_origins, split_list(env("CARMAR_ORIGINS", ""))))
+
+  hosts_env <- split_list(env("CARMAR_HOSTS", ""))
+  default_hosts <- c(sprintf("127.0.0.1:%d", port), sprintf("localhost:%d", port),
+                     sprintf("[::1]:%d", port))
+  # A configured host may or may not carry a port. Accept both spellings so an
+  # operator writing `stats.example.edu` is not silently refused behind a proxy
+  # that forwards the default 80/443 and therefore sends no port at all.
+  hosts_env <- unique(c(hosts_env, ifelse(grepl(":", hosts_env, fixed = TRUE),
+                                          hosts_env,
+                                          sprintf("%s:%d", hosts_env, port))))
+  hosts <- tolower(unique(c(default_hosts, hosts_env)))
+
+  # "Anyone who reaches this port is this same OS user" is the premise behind
+  # allowing an Origin-less client, and binding off loopback is the obvious way
+  # to break it — but not the only one. A shared multi-user host, or a container
+  # whose 127.0.0.1 is port-forwarded out, breaks it while still binding
+  # loopback. So the posture is declarable in its own right and the bind
+  # address merely IMPLIES it; an operator hardening a shared machine does not
+  # have to move the socket to say so.
+  require_origin <- identical(env("CARMAR_REQUIRE_ORIGIN", ""), "1") || !loopback
+
+  trust_proxy <- identical(env("CARMAR_TRUST_PROXY", ""), "1")
+  user_header <- trimws(env("CARMAR_USER_HEADER", "X-Forwarded-User"))
+  proxy_addrs <- split_list(env("CARMAR_TRUSTED_PROXY", "127.0.0.1 ::1"))
+  allow_open <- identical(env("CARMAR_ALLOW_UNAUTHENTICATED", ""), "1")
+
+  errors <- character(0)
+  if (!loopback) {
+    if (!length(hosts_env)) {
+      errors <- c(errors, paste0(
+        "CARMAR_BIND is ", bind, " but CARMAR_HOSTS is unset. Off loopback the ",
+        "Host allow-list is the only defence against DNS rebinding, so it must ",
+        "name the hostname readers will use (e.g. CARMAR_HOSTS=stats.example.edu)."))
+    }
+    if (!trust_proxy && !allow_open) {
+      errors <- c(errors, paste0(
+        "CARMAR_BIND is ", bind, " with no authentication in front of it. Put ",
+        "CarmaR behind a reverse proxy that authenticates and set ",
+        "CARMAR_TRUST_PROXY=1, or set CARMAR_ALLOW_UNAUTHENTICATED=1 to serve R ",
+        "execution to everyone who can reach this port. See docs/server.md."))
+    }
+    if (trust_proxy && !nzchar(user_header)) {
+      errors <- c(errors, "CARMAR_TRUST_PROXY=1 requires a non-empty CARMAR_USER_HEADER.")
+    }
+    if (trust_proxy && !length(proxy_addrs)) {
+      errors <- c(errors, "CARMAR_TRUST_PROXY=1 requires CARMAR_TRUSTED_PROXY to name the proxy's address.")
+    }
+  }
+
+  list(
+    bind = bind,
+    port = port,
+    loopback = loopback,
+    origins = origins,
+    hosts = hosts,
+    # THE INVERSION. On a private loopback an absent Origin is a same-user
+    # native client and is allowed; anywhere the port is reachable by someone
+    # else it is an unauthenticated stranger and is not.
+    allow_native = !require_origin,
+    require_origin = require_origin,
+    trust_proxy = trust_proxy && require_origin,
+    user_header = user_header,
+    # httpuv's Rook environment spells a header `HTTP_` + uppercase, `-`→`_`.
+    user_header_key = paste0("HTTP_", toupper(gsub("-", "_", user_header, fixed = TRUE))),
+    proxy_addrs = proxy_addrs,
+    allow_unauthenticated = allow_open,
+    errors = errors)
+}
+
+#' Who is this request, according to the proxy in front of us?
+#'
+#' Returns "" unless the posture trusts a proxy AND the request actually came
+#' from one of the named proxy addresses. That second half is what stops the
+#' header being a self-service login: anyone who can reach the port directly
+#' can set `X-Forwarded-User: root`, so the header is only ever as trustworthy
+#' as the guarantee that nobody but the proxy can reach the port.
+proxy_user <- function(req, deployment) {
+  if (!isTRUE(deployment$trust_proxy)) return("")
+  peer <- tolower(req$REMOTE_ADDR %||% "")
+  if (!nzchar(peer) || !(peer %in% tolower(deployment$proxy_addrs))) return("")
+  name <- req[[deployment$user_header_key]] %||% ""
+  # One line, printable, bounded — it reaches the audit log and the page title.
+  name <- gsub("[[:cntrl:]]", "", name)
+  trimws(substr(name, 1L, 128L))
+}

package/kernel/examples/NOTICE.md

@@ -0,0 +1,38 @@
+# Test files shipped with CarmaR
+
+## tna-complete-tutorial.Rmd
+
+"A showcase of the main tna functions" — the `complete_tutorial.Rmd` vignette of
+the **tna** R package, copied unmodified.
+
+- Source: https://github.com/sonsoleslp/tna/blob/main/vignettes/complete_tutorial.Rmd
+- Revision: `5c08ec9dbed28d47f67f6c9c79e58aee152fcc9a` (2026-03-03)
+- License: MIT (the package's DESCRIPTION: `MIT + file LICENSE`)
+
+```
+YEAR: 2025-2026
+COPYRIGHT HOLDER: tna authors
+```
+
+MIT License
+
+Copyright (c) 2025-2026 tna authors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+To run it, R needs the packages it loads: `tna`, `tibble`, `dplyr` and `gt`.

package/kernel/examples/tna-complete-tutorial.Rmd

@@ -0,0 +1,210 @@
+---
+title: "A showcase of the main tna functions"
+output: rmarkdown::html_vignette
+vignette: >
+  %\VignetteIndexEntry{A showcase of the main tna functions}
+  %\VignetteEngine{knitr::rmarkdown}
+  %\VignetteEncoding{UTF-8}
+---
+
+```{r, include = FALSE}
+knitr::opts_chunk$set(
+  collapse = TRUE,
+  fig.width = 6,
+  fig.height = 4,
+  out.width = "100%",
+  dev = "jpeg",
+  dpi = 100,
+  comment = "#>"
+)
+suppressPackageStartupMessages({
+  library("tna")
+  library("tibble")
+  library("dplyr")
+  library("gt")
+})
+options(scipen = 99)
+options(digits = 2)
+options(max.print = 30)
+options(width = 83)
+```
+
+
+# Tutorial of TNA with R
+
+This is a short tutorial of the `tna` package. We begin by loading the package and the example data set `group_regulation`.
+
+```{r}
+library("tna")
+data("group_regulation", package = "tna")
+```
+
+## Building `tna` Model
+
+TNA models can be built with the `tna` function, which accepts several types of data such a sequence data, data frames or matrices.
+```{r, message = FALSE, results = FALSE}
+model <- tna(group_regulation)
+print(model)
+```
+
+
+## Plotting and interpreting `tna` models
+
+### Interpretation of the model
+
+```{r fig.height=6, fig.width=6, fig.align='center', layout = c(1,1)}
+# TNA visualization
+plot(model)
+```
+
+### Pruning and retaining edges that "matter"
+
+
+```{r, fig.show='hold', fig.width=5, fig.height=5 }
+layout(matrix(1:4, ncol = 2, byrow = TRUE))
+# Pruning with different methods (using comparable parameters)
+pruned_threshold <- prune(model, method = "threshold", threshold = 0.15)
+pruned_lowest <- prune(model, method = "lowest", lowest = 0.15)
+pruned_disparity <- prune(model, method = "disparity", level = 0.5)
+
+# Plotting for comparison
+plot(pruned_threshold)
+plot(pruned_lowest)
+plot(pruned_disparity)
+plot(model)
+```
+
+## Patterns
+
+```{r }
+layout(t(1:2))
+# Identify 2-cliques (dyads) from the TNA model, excluding loops in the visualization
+# A clique of size 2 is essentially a pair of connected nodes
+cliques_of_two <- cliques(
+  model, 
+  size = 2, 
+  threshold = 0.15  # Only consider edges with weight > 0.15
+)
+print(cliques_of_two)
+plot(cliques_of_two, ask = FALSE)
+```
+
+```{r, fig.width=6,fig.height=2}
+layout(t(1:3))
+# Identify 3-cliques (triads) from the TNA_Model
+# A clique of size 3 means a fully connected triplet of nodes
+cliques_of_three <- cliques(
+  model, 
+  size = 3, 
+  threshold = 0.05 # Only consider edges with weight > 0.05
+)
+print(cliques_of_three)
+plot(cliques_of_three, ask = FALSE)
+```
+
+```{r, fig.width=5}
+# Identify 4-cliques (quadruples) from the TNA_Model
+# A clique of size 4 means four nodes that are all mutually connected
+cliques_of_four <- cliques(
+  model, 
+  size = 4, 
+  threshold = 0.035 # Only consider edges with weight > 0.03
+)
+print(cliques_of_four)
+plot(cliques_of_four, ask = FALSE)
+```
+
+
+### Centralities
+
+#### Node-level measures
+
+```{r fig.height=8, fig.width=8, fig.align='center'}
+# Compute centrality measures for the TNA model
+Centralities <- centralities(model)
+
+# Visualize the centrality measures
+plot(Centralities)
+```
+
+
+```{r}
+# Calculate hub scores and the authority scores for the network
+hits_scores <- igraph::hits_scores(as.igraph(model))
+hub_scores <- hits_scores$hub
+authority_scores <- hits_scores$authority
+
+# Print the calculated hub and authority scores for further analysis
+print(hub_scores)
+print(authority_scores)
+```
+
+
+#### Edge-level measures
+
+
+```{r, fig.align='center', fig.width=6, fig.height=5.5, out.width="60%"}
+# Edge betweenness
+Edge_betweeness <- betweenness_network(model)
+plot(Edge_betweeness)
+```
+
+### Community finding
+
+```{r}
+communities <- communities(model)
+print(communities)
+plot(communities, method = "leading_eigen")
+```
+
+## Network inference
+
+### Bootstrapping
+
+```{r}
+# Perform bootstrapping on the TNA model with a fixed seed for reproducibility
+set.seed(265)
+boot <- bootstrap(model, threshold = 0.05)
+
+# Print a summary of the bootstrap results
+print(summary(boot))
+
+# Show the non-significant edges (p-value >= 0.05 in this case)
+# These are edges that are less likely to be stable across bootstrap samples
+print(boot, type = "nonsig")
+```
+
+### Permutation
+
+```{r, fig.align='center', fig.width = 5, fig.height = 5, layout = c(1,1)}
+# Create TNA for the high-achievers subset (rows 1 to 1000)
+Hi <- tna(group_regulation[1:1000, ])
+
+# Create TNA for the low-achievers subset (rows 1001 to 2000)
+Lo <- tna(group_regulation[1001:2000, ])
+
+# Plot a comparison of the "Hi" and "Lo" models
+# The 'minimum' parameter is set to 0.001, so edges with weights >= 0.001 are shown
+plot_compare(Hi, Lo, minimum = 0.01)
+
+# Run a permutation test to determine statistical significance of differences
+# between "Hi" and "Lo"
+# The 'iter' argument is set to 1000, meaning 1000 permutations are performed
+Permutation <- permutation_test(Hi, Lo, iter = 1000, measures = "Betweenness")
+
+# Plot the significant differences identified in the permutation test
+plot(Permutation, minimum = 0.01)
+```
+
+```{r}
+print(Permutation$edges$stats)
+print(Permutation$centralities$stats)
+```
+
+### Interpreting the Results of the Case-Dropping Bootstrap for Centrality Indices
+
+```{r, fig.align='center', fig.width=7, fig.height=4}
+# Results of the Case-Dropping Bootstrap for Centrality Indices
+Centrality_stability <- estimate_centrality_stability(model, iter = 100)
+plot(Centrality_stability)
+```