R/plot.fanc.R

In fanc: Penalized Likelihood Factor Analysis via Nonconvex Penalty

##
## Plot solution paths from a fanc object.
##

plot.fanc <- function(x, Window.Height=500, type=NULL, df.method="active",
                      viewer=c("auto", "html", "base"), file=NULL,
                      rho.index=1, gamma.index=1, ...) {
    if (!inherits(x, "fanc")) {
        stop('the class of object "x" must be "fanc"')
    }
    viewer <- match.arg(viewer)
    info <- fanc_plot_info(x, Window.Height, type, df.method)
    rho.index <- fanc_clamp_index(rho.index, info$N.lambda, "rho.index")
    gamma.index <- fanc_clamp_index(gamma.index, info$N.gamma, "gamma.index")
    info$rho.index <- rho.index
    info$gamma.index <- gamma.index

    if (viewer == "auto") {
        viewer <- if (interactive() || !is.null(file)) "html" else "base"
    }

    if (viewer == "html") {
        return(invisible(fanc_plot_html(info, file=file)))
    }

    fanc_plot_base(info, rho.index, gamma.index)
    invisible(NULL)
}

fanc_plot_info <- function(x, Window.Height, type, df.method) {
    if (!is.numeric(Window.Height) || length(Window.Height) != 1 ||
        is.na(Window.Height) || !is.finite(Window.Height) ||
        Window.Height < 250 || Window.Height > 2000) {
        stop("'Window.Height' must be in [250,2000].")
    }
    if (length(df.method) != 1 || is.na(df.method) ||
        !df.method %in% c("active", "reparametrization")) {
        stop("'df.method' must be 'active' or 'reparametrization'.")
    }

    n.var <- dim(x$loadings[[1]][[1]])[1]
    n.fac <- dim(x$loadings[[1]][[1]])[2]
    if (identical(type, "path") ||
        (is.null(type) && n.var < 50 && n.fac < 7)) {
        fig.type <- "path"
    } else if (identical(type, "heatmap") ||
               (is.null(type) && (n.var >= 50 || n.fac >= 7))) {
        fig.type <- "heatmap"
    } else {
        stop("Only 'path' and 'heatmap' are available for 'type'.")
    }
    if (identical(type, "path") && n.fac >= 7) {
        warning("A path diagram with seven or more factors may be difficult to read; consider type='heatmap'.")
    }
    if (fig.type == "path" && n.var > 100) {
        stop("The number of variables must be less than or equal to 100 to plot the solution path.")
    }

    if (df.method == "reparametrization") {
        metrics <- list(GFI=x$GFI, AGFI=x$AGFI, CFI=x$CFI,
                        RMSEA=x$RMSEA, SRMR=x$SRMR, AIC=x$AIC,
                        BIC=x$BIC, CAIC=x$CAIC, EBIC=x$EBIC)
    } else {
        metrics <- list(GFI=x$GFI, AGFI=x$AGFI_dfnonzero,
                        CFI=x$CFI_dfnonzero, RMSEA=x$RMSEA_dfnonzero,
                        SRMR=x$SRMR, AIC=x$AIC_dfnonzero,
                        BIC=x$BIC_dfnonzero, CAIC=x$CAIC_dfnonzero,
                        EBIC=x$EBIC_dfnonzero)
    }

    list(
        x=x,
        type=fig.type,
        df.method=df.method,
        L=x$loadings,
        lambdas=x$rho,
        gammas=x$gamma,
        metrics=metrics,
        N.var=n.var,
        N.fac=n.fac,
        N.lambda=length(x$loadings[[1]]),
        N.gamma=length(x$loadings),
        Window.Height=Window.Height,
        Window.Width=max((n.var + 1) * 75, n.fac * 150, 750),
        max.loading=fanc_max_loading(x$loadings),
        title=fanc_plot_title(x)
    )
}

fanc_plot_title <- function(x) {
    penalty <- if (x$type == "MC") "MC+" else x$type
    model <- if (x$model == "PPCA") "Probabilistic PCA" else "Factor analysis"
    paste(model, "with", penalty)
}

fanc_clamp_index <- function(value, max.value, name) {
    if (!is.numeric(value) || length(value) != 1 || is.na(value) ||
        !is.finite(value) || value != as.integer(value)) {
        stop(sprintf("'%s' must be a single integer.", name))
    }
    value <- as.integer(value)
    if (value < 1 || value > max.value) {
        stop(sprintf("'%s' must be between 1 and %d.", name, max.value))
    }
    value
}

fanc_max_loading <- function(loadings) {
    ans <- 0
    for (gi in seq_along(loadings)) {
        for (ri in seq_along(loadings[[gi]])) {
            values <- as.matrix(loadings[[gi]][[ri]])
            if (any(!is.finite(values))) {
                stop("All factor loadings must be finite to plot.")
            }
            ans <- max(ans, abs(values))
        }
    }
    if (ans == 0) 1 else ans
}

fanc_matrix <- function(info, rho.index, gamma.index) {
    as.matrix(info$L[[gamma.index]][[rho.index]])
}

fanc_var_names <- function(info) {
    names <- rownames(info$L[[1]][[1]])
    if (is.null(names)) paste("V", seq_len(info$N.var), sep="") else names
}

fanc_factor_names <- function(info) {
    names <- colnames(info$L[[1]][[1]])
    if (is.null(names)) paste("Factor", seq_len(info$N.fac), sep="") else names
}

fanc_loading_label <- function(info, rho.index, gamma.index) {
    sprintf("rho = %.6g, gamma = %.6g",
            info$lambdas[rho.index, gamma.index],
            info$gammas[gamma.index])
}

fanc_metric_values <- function(info, rho.index, gamma.index) {
    values <- vapply(info$metrics, function(z) {
        if (is.null(z)) return(NA_real_)
        z[rho.index, gamma.index]
    }, numeric(1))
    values
}

fanc_metric_text <- function(info, rho.index, gamma.index) {
    metrics <- fanc_metric_values(info, rho.index, gamma.index)
    lines <- c(
        tuning=fanc_loading_label(info, rho.index, gamma.index),
        gof=sprintf(
            "GFI %.3f   AGFI %.3f   CFI %.3f   RMSEA %.3f   SRMR %.3f",
            metrics["GFI"], metrics["AGFI"], metrics["CFI"],
            metrics["RMSEA"], metrics["SRMR"]
        ),
        criteria=sprintf(
            "AIC %.4f   BIC %.4f   CAIC %.4f   EBIC %.4f",
            metrics["AIC"], metrics["BIC"], metrics["CAIC"],
            metrics["EBIC"]
        )
    )
    paste(unname(lines), collapse="\n")
}

fanc_path_layout <- function(info) {
    width <- info$Window.Width
    height <- 500
    x.fac <- if (info$N.fac == 1) width / 2 else
        seq(width * 0.18, width * 0.82, length.out=info$N.fac)
    x.var <- seq(width * 0.08, width * 0.92, length.out=info$N.var)
    list(
        width=width,
        height=height,
        x.fac=x.fac,
        y.fac=height * 0.15,
        x.var=x.var,
        y.var=height * 0.85,
        rx=max(min(width / max(info$N.fac, 1) * 0.18, 45), 20),
        ry=30,
        rw=max(min(width / max(info$N.var, 1) * 0.55, 70), 25),
        rh=35
    )
}

## ====================================================================
## Self-contained HTML + JavaScript viewer (no package dependencies).
## Writes a standalone .html file with all data and code embedded, then
## opens it in the RStudio viewer / browser. Sliders, the AIC/BIC/CAIC/
## EBIC jump buttons and the overview run entirely in the browser, so it
## is fast and needs no running R session.
## ====================================================================
fanc_plot_html <- function(info, file=NULL) {
    html <- fanc_html_document(info)
    if (is.null(file)) file <- tempfile(fileext=".html")
    writeLines(enc2utf8(html), file, useBytes=TRUE)
    if (interactive()) {
        viewer <- getOption("viewer")
        if (is.function(viewer)) viewer(file) else utils::browseURL(file)
    }
    invisible(normalizePath(file))
}

## ---- tiny JS serialisers (so we need no jsonlite dependency) -------
fanc_js_num <- function(v) {
    ifelse(is.na(v), "null",
    ifelse(is.infinite(v), ifelse(v > 0, "Infinity", "-Infinity"),
           formatC(v, digits=10, format="g")))
}
fanc_js_vec <- function(v) paste0("[", paste(fanc_js_num(v), collapse=","), "]")
fanc_js_mat <- function(m) {
    m <- as.matrix(m)
    rows <- vapply(seq_len(nrow(m)), function(i) fanc_js_vec(m[i, ]),
                   character(1))
    paste0("[", paste(rows, collapse=","), "]")
}
## list(gamma) of list(rho) of NV x NF matrix -> JS L[g][r][i][j]
fanc_js_loadings <- function(L) {
    g.parts <- vapply(seq_along(L), function(g) {
        r.parts <- vapply(seq_along(L[[g]]),
                          function(r) fanc_js_mat(L[[g]][[r]]), character(1))
        paste0("[", paste(r.parts, collapse=","), "]")
    }, character(1))
    paste0("[", paste(g.parts, collapse=","), "]")
}
## metric matrix [rho, gamma] -> JS m[g][r]; NULL -> "null"
fanc_js_metric <- function(m, N.gamma) {
    if (is.null(m)) return("null")
    m <- as.matrix(m)
    g.parts <- vapply(seq_len(N.gamma), function(g) fanc_js_vec(m[, g]),
                      character(1))
    paste0("[", paste(g.parts, collapse=","), "]")
}
fanc_js_string <- function(s) {
    s <- enc2utf8(as.character(s))
    s <- gsub("\\", "\\\\", s, fixed=TRUE)
    s <- gsub('"', '\\"', s, fixed=TRUE)
    s <- gsub("\b", "\\b", s, fixed=TRUE)
    s <- gsub("\f", "\\f", s, fixed=TRUE)
    s <- gsub("\n", "\\n", s, fixed=TRUE)
    s <- gsub("\r", "\\r", s, fixed=TRUE)
    s <- gsub("\t", "\\t", s, fixed=TRUE)
    for (code in setdiff(seq_len(31), c(8, 9, 10, 12, 13))) {
        s <- gsub(intToUtf8(code), sprintf("\\u%04X", code), s, fixed=TRUE)
    }
    s <- gsub("<", "\\u003C", s, fixed=TRUE)
    s <- gsub(">", "\\u003E", s, fixed=TRUE)
    s <- gsub("&", "\\u0026", s, fixed=TRUE)
    s <- gsub(intToUtf8(0x2028), "\\u2028", s, fixed=TRUE)
    s <- gsub(intToUtf8(0x2029), "\\u2029", s, fixed=TRUE)
    paste0('"', s, '"')
}
fanc_js_strvec <- function(s) {
    paste0("[", paste(vapply(s, fanc_js_string, character(1)),
                       collapse=","), "]")
}

fanc_html_data <- function(info) {
    N.gamma <- info$N.gamma
    lambdas <- as.matrix(info$lambdas)
    rhos <- paste0("[", paste(vapply(seq_len(N.gamma),
        function(g) fanc_js_vec(lambdas[, g]), character(1)),
        collapse=","), "]")
    metric <- function(name) fanc_js_metric(info$metrics[[name]], N.gamma)
    paste0(
        "{",
        '"title":', fanc_js_string(info$title), ',',
        '"type":', fanc_js_string(info$type), ',',
        '"NV":', info$N.var, ',"NF":', info$N.fac,
        ',"NR":', info$N.lambda, ',"NG":', N.gamma, ',',
        '"height":', fanc_js_num(info$Window.Height), ',',
        '"initialR":', info$rho.index - 1, ',',
        '"initialG":', info$gamma.index - 1, ',',
        '"maxAbs":', fanc_js_num(info$max.loading), ',',
        '"varNames":', fanc_js_strvec(fanc_var_names(info)), ',',
        '"facNames":', fanc_js_strvec(fanc_factor_names(info)), ',',
        '"rhos":', rhos, ',',
        '"gammas":', fanc_js_vec(info$gammas), ',',
        '"L":', fanc_js_loadings(info$L), ',',
        '"crit":{"AIC":', metric("AIC"), ',"BIC":', metric("BIC"),
        ',"CAIC":', metric("CAIC"), ',"EBIC":', metric("EBIC"), '},',
        '"gof":{"GFI":', metric("GFI"), ',"AGFI":', metric("AGFI"),
        ',"CFI":', metric("CFI"), ',"RMSEA":', metric("RMSEA"),
        ',"SRMR":', metric("SRMR"), '}',
        "}"
    )
}

fanc_html_document <- function(info) {
    paste0(fanc_html_head(), fanc_html_data(info), fanc_html_tail())
}

## Static top of the document: HTML, CSS and the opening of the <script>
## up to (and including) "const DATA = ". fanc_html_data() supplies the
## object literal, fanc_html_tail() supplies the JS engine.
fanc_html_head <- function() {
r"----(<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1">
<title>fanc viewer</title>
<style>
  :root{
    --ink:#1a1a1a; --muted:#6b7280; --line:#e5e7eb; --panel:#f7f8fa;
    --accent:#2563eb; --neg:#d62728;
    --mono: ui-monospace, "SF Mono", Menlo, Consolas, monospace;
    --sans: -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, sans-serif;
  }
  *{box-sizing:border-box}
  body{font-family:var(--sans);color:var(--ink);margin:0;padding:18px 22px;background:#fff}
  h1{font-size:20px;margin:0 0 10px}
  .metrics{font-family:var(--mono);font-size:15px;color:#374151;
       border:1px solid var(--line);border-radius:10px;background:var(--panel);
       padding:12px 16px;margin-bottom:12px}
  .mtop{font-weight:700;color:var(--ink);margin-bottom:6px}
  .mgrid{display:grid;grid-template-columns:repeat(5,max-content);
       column-gap:30px;row-gap:5px}
  .controls{display:flex;flex-wrap:wrap;align-items:center;justify-content:space-between;
       gap:12px;margin-bottom:14px}
  .jump{display:flex;align-items:center;gap:8px}
  .jump button{border:1px solid var(--accent);background:#fff;color:var(--accent);
       border-radius:7px;padding:6px 14px;font-size:13px;font-weight:600;cursor:pointer}
  .jump button:hover{background:var(--accent);color:#fff}
  .jump button:disabled{border-color:#d1d5db;color:#9ca3af;background:#f9fafb;cursor:not-allowed}
  .seg{display:inline-flex;border:1px solid var(--line);border-radius:8px;overflow:hidden}
  .seg button{border:0;background:#fff;padding:7px 16px;font-size:13px;cursor:pointer;color:var(--muted)}
  .seg button.on{background:var(--accent);color:#fff;font-weight:600}
  .sliders{display:flex;flex-wrap:wrap;gap:22px 34px;align-items:flex-end;padding:10px 4px 4px}
  .ctl{display:flex;flex-direction:column;gap:5px}
  .ctl .val{font-family:var(--mono);font-weight:600;font-size:14px}
  input[type=range]{width:280px;accent-color:var(--accent);cursor:pointer}
  .stage{border:1px solid var(--line);border-radius:10px;padding:8px;background:#fff}
  .grid{display:grid;gap:8px}
  .cell svg{display:block;width:100%;height:auto}
  .cell{border:1px solid var(--line);border-radius:8px;padding:4px 4px 2px;cursor:pointer;background:#fff;
        transition:border-color .12s,box-shadow .12s}
  .cell:hover{border-color:#c7d2fe}
  .cell.cur{border-color:var(--accent);box-shadow:0 0 0 2px rgba(37,99,235,.15);background:#f5f8ff}
  .cell .cap{font-family:var(--mono);font-size:11px;text-align:center;color:var(--muted);margin-top:1px}
  .cell.cur .cap{color:var(--accent);font-weight:700}
</style>
</head>
<body>
  <h1 id="title"></h1>
  <div class="metrics" id="metrics"></div>
  <div class="controls">
    <div class="jump">
      <button data-c="AIC">AIC</button>
      <button data-c="BIC">BIC</button>
      <button data-c="CAIC">CAIC</button>
      <button data-c="EBIC">EBIC</button>
    </div>
    <div class="seg" id="seg">
      <button data-v="detail" class="on">Detail</button>
      <button data-v="overview">Overview</button>
    </div>
  </div>
  <div class="sliders">
    <div class="ctl" id="rhoCtl">
      <span class="val" id="rhoVal">rho = -</span>
      <input type="range" id="rho" min="0" step="1">
    </div>
    <div class="ctl" id="gamCtl">
      <span class="val" id="gamVal">gamma = -</span>
      <input type="range" id="gam" min="0" step="1">
    </div>
  </div>
  <div class="stage" id="stage"></div>
<script>
"use strict";
const DATA = )----"
}

## The JavaScript engine: reads DATA, draws the path diagram or heatmap
## as SVG, and wires up the sliders, jump buttons and overview.
fanc_html_tail <- function() {
r"----(;
const NV=DATA.NV, NF=DATA.NF, NR=DATA.NR, NG=DATA.NG, maxAbs=DATA.maxAbs||1;
const fmt=(v,d=4)=> v==null?"NA":(!isFinite(v)?"Inf":Number(v).toPrecision(d).replace(/\.?0+$/,""));
const fmt3=v=> v==null?"NA":(!isFinite(v)?"Inf":Number(v).toFixed(3));
const num2=v=> v==null?"NA":Number(v).toFixed(2);

function colorFor(v){
  const t=Math.max(-1,Math.min(1,(v||0)/maxAbs)),L=(a,b,u)=>Math.round(a+(b-a)*u);
  let a,b,u; if(t<0){a=[178,24,43];b=[255,255,255];u=t+1;}else{a=[255,255,255];b=[17,17,17];u=t;}
  return `rgb(${L(a[0],b[0],u)},${L(a[1],b[1],u)},${L(a[2],b[2],u)})`;
}

function esc(s){return String(s).replace(/&/g,'&amp;').replace(/</g,'&lt;').replace(/>/g,'&gt;');}
// Fit a label inside a box of width maxW (viewBox units): shrink the font,
// and if it still cannot fit at the minimum size, truncate with an ellipsis.
// Works at every window size because the whole SVG scales with its viewBox.
function fitText(label,maxW,maxFont,minFont){
  minFont=minFont||7; const cw=0.60; label=String(label);
  let size=Math.min(maxFont,maxW/(cw*Math.max(label.length,1))), text=label;
  if(size<minFont){
    size=minFont;
    const maxChars=Math.max(1,Math.floor(maxW/(cw*size)));
    if(label.length>maxChars) text=label.slice(0,Math.max(1,maxChars-1))+'\u2026';
  }
  return {size:size,text:text};
}

function pathSVG(Lm,opts){
  opts=opts||{}; const W=900,H=opts.mini?300:440,mini=opts.mini;
  const yF=H*0.16,yV=H*0.86,rF=mini?40:34;
  const xF=Array.from({length:NF},(_,j)=>W*(0.30+0.40*(NF===1?0.5:j/(NF-1))));
  const xV=Array.from({length:NV},(_,i)=>W*(0.06+0.88*(NV===1?0.5:i/(NV-1))));
  const rw=Math.min(W/NV*0.6,64),rh=mini?34:30;
  let s=`<svg viewBox="0 0 ${W} ${H}" xmlns="http://www.w3.org/2000/svg" preserveAspectRatio="xMidYMid meet" font-family="-apple-system,Segoe UI,Roboto,sans-serif">`;
  for(let i=0;i<NV;i++)for(let j=0;j<NF;j++){
    const v=Lm[i][j],w=Math.abs(v*10);
    if(w>0.05){const lw=Math.max(1,Math.min(w,12));
      s+=`<line x1="${xV[i].toFixed(1)}" y1="${(yV-rh/2).toFixed(1)}" x2="${xF[j].toFixed(1)}" y2="${(yF+rF).toFixed(1)}" stroke="${v<0?'#d62728':'#222'}" stroke-width="${lw.toFixed(1)}" stroke-linecap="round" opacity="0.92"><title>${esc(DATA.varNames[i])}, ${esc(DATA.facNames[j])}: ${v.toFixed(3)}</title></line>`;}
  }
  for(let j=0;j<NF;j++){
    const f=fitText(DATA.facNames[j], rF*1.7, mini?14:17);
    s+=`<circle cx="${xF[j].toFixed(1)}" cy="${yF.toFixed(1)}" r="${rF}" fill="#fff" stroke="#222" stroke-width="2"/>`;
    s+=`<text x="${xF[j].toFixed(1)}" y="${(yF+f.size*0.34).toFixed(1)}" text-anchor="middle" font-size="${f.size.toFixed(1)}" font-weight="600">${esc(f.text)}<title>${esc(DATA.facNames[j])}</title></text>`;
  }
  for(let i=0;i<NV;i++){
    const vt=fitText(DATA.varNames[i], rw*0.88, mini?12:15);
    s+=`<rect x="${(xV[i]-rw/2).toFixed(1)}" y="${(yV-rh/2).toFixed(1)}" width="${rw.toFixed(1)}" height="${rh}" rx="3" fill="#fff" stroke="#222" stroke-width="1.6"/>`;
    s+=`<text x="${xV[i].toFixed(1)}" y="${(yV+vt.size*0.34).toFixed(1)}" text-anchor="middle" font-size="${vt.size.toFixed(1)}">${esc(vt.text)}<title>${esc(DATA.varNames[i])}</title></text>`;
  }
  return s+`</svg>`;
}

function heatSVG(Lm,opts){
  opts=opts||{}; const mini=opts.mini,W=900;
  const mL=mini?3:90,mR=mini?3:20,mT=mini?3:12,mB=mini?3:96;
  const cellH=mini?Math.max(4,Math.min(16,140/NF)):Math.max(16,Math.min(46,360/NF));
  const plotH=NF*cellH,plotW=W-mL-mR,cellW=plotW/NV,H=mT+plotH+mB;
  let s=`<svg viewBox="0 0 ${W} ${H}" xmlns="http://www.w3.org/2000/svg" preserveAspectRatio="xMidYMid meet" font-family="-apple-system,Segoe UI,Roboto,sans-serif">`;
  for(let i=0;i<NV;i++)for(let j=0;j<NF;j++){
    s+=`<rect x="${(mL+i*cellW).toFixed(1)}" y="${(mT+j*cellH).toFixed(1)}" width="${cellW.toFixed(2)}" height="${cellH.toFixed(1)}" fill="${colorFor(Lm[i][j])}" ${mini?'':'stroke="#eee" stroke-width="0.4"'}><title>${esc(DATA.varNames[i])}, ${esc(DATA.facNames[j])}: ${Lm[i][j].toFixed(3)}</title></rect>`;
  }
  if(!mini){
    for(let j=0;j<NF;j++){const f=fitText(DATA.facNames[j], mL-10, 13);
      s+=`<text x="${mL-6}" y="${(mT+(j+0.5)*cellH+4).toFixed(1)}" text-anchor="end" font-size="${f.size.toFixed(1)}">${esc(f.text)}<title>${esc(DATA.facNames[j])}</title></text>`;}
    const step=Math.ceil(NV/40);
    for(let i=0;i<NV;i+=step){const cx=mL+(i+0.5)*cellW,cy=mT+plotH+8;
      const f=fitText(DATA.varNames[i], mB-8, 11);
      s+=`<text x="${cx.toFixed(1)}" y="${cy.toFixed(1)}" font-size="${f.size.toFixed(1)}" text-anchor="end" transform="rotate(-45 ${cx.toFixed(1)} ${cy.toFixed(1)})">${esc(f.text)}<title>${esc(DATA.varNames[i])}</title></text>`;}
  }
  s+=`<rect x="${mL}" y="${mT}" width="${plotW.toFixed(1)}" height="${plotH.toFixed(1)}" fill="none" stroke="#222" stroke-width="1"/>`;
  return s+`</svg>`;
}

const diagSVG=(Lm,opts)=> DATA.type==='heatmap'?heatSVG(Lm,opts):pathSVG(Lm,opts);

const els={rho:document.getElementById('rho'),gam:document.getElementById('gam'),
  rhoVal:document.getElementById('rhoVal'),gamVal:document.getElementById('gamVal'),
  metrics:document.getElementById('metrics'),stage:document.getElementById('stage'),
  seg:document.getElementById('seg')};
document.getElementById('title').textContent=DATA.title;
els.rho.max=NR-1; els.gam.max=NG-1;
els.rho.value=DATA.initialR; els.gam.value=DATA.initialG;
if(NG<2) document.getElementById('gamCtl').style.display='none';
let view='detail';

function argmin(name){
  const m=DATA.crit[name]; if(m==null) return null;
  let best=Infinity,bg=0,br=0;
  for(let g=0;g<NG;g++)for(let r=0;r<NR;r++){const v=m[g][r]; if(v!=null&&v<best){best=v;bg=g;br=r;}}
  return isFinite(best)?{g:bg,r:br}:null;
}

function val(o,name,g,r){const m=o[name]; return m==null?null:m[g][r];}
function metricsLine(g,r){
  const G=DATA.gof, c=DATA.crit;
  const top=`<div class="mtop">rho = ${fmt(DATA.rhos[g][r])},&nbsp;&nbsp;gamma = ${fmt(DATA.gammas[g])}</div>`;
  // 5 grid columns; row 1 = fit indices, row 2 = information criteria.
  // The grid keeps each column the same width across both rows, so e.g.
  // CFI sits above CAIC and RMSEA above EBIC.
  const row1=[['GFI','GFI'],['AGFI','AGFI'],['CFI','CFI'],['RMSEA','RMSEA'],['SRMR','SRMR']]
      .map(k=>`<span>${k[0]} = ${fmt3(val(G,k[1],g,r))}</span>`).join('');
  const row2=[['AIC','AIC'],['BIC','BIC'],['CAIC','CAIC'],['EBIC','EBIC']]
      .map(k=>`<span>${k[0]} = ${num2(val(c,k[1],g,r))}</span>`).join('')+'<span></span>';
  return top+`<div class="mgrid">${row1}${row2}</div>`;
}

function render(){
  const r=+els.rho.value, g=+els.gam.value;
  els.rhoVal.textContent=`rho = ${fmt(DATA.rhos[g][r])}`;
  els.gamVal.textContent=`gamma = ${fmt(DATA.gammas[g])}`;
  els.metrics.innerHTML=metricsLine(g,r);
  if(view==='detail'){
    els.stage.classList.remove('grid');
    els.stage.innerHTML=diagSVG(DATA.L[g][r]);
    const svg=els.stage.querySelector('svg');
    const displayHeight=`min(66vh, ${DATA.height}px)`;
    if(DATA.type==='heatmap'){svg.style.width='100%';svg.style.height='auto';svg.style.maxHeight=displayHeight;}
    else{svg.style.height=displayHeight;svg.style.width='auto';svg.style.maxWidth='100%';svg.style.margin='0 auto';}
  }else{
    els.stage.classList.add('grid');
    const minCell=DATA.type==='heatmap'?'220px':'150px';
    els.stage.style.gridTemplateColumns=`repeat(auto-fit,minmax(${minCell},1fr))`;
    let html='';
    for(let rr=0;rr<NR;rr++)
      html+=`<div class="cell ${rr===r?'cur':''}" data-r="${rr}">${diagSVG(DATA.L[g][rr],{mini:true})}<div class="cap">rho=${fmt(DATA.rhos[g][rr],3)}</div></div>`;
    els.stage.innerHTML=html;
    els.stage.querySelectorAll('.cell').forEach(c=>c.onclick=()=>{els.rho.value=c.dataset.r;render();});
  }
}

document.querySelectorAll('.jump button').forEach(b=>{
  b.disabled=argmin(b.dataset.c)==null;
  b.onclick=()=>{const s=argmin(b.dataset.c); if(!s)return; els.rho.value=s.r; els.gam.value=s.g; render();};
});
els.seg.querySelectorAll('button').forEach(b=>{
  b.onclick=()=>{view=b.dataset.v; els.seg.querySelectorAll('button').forEach(x=>x.classList.toggle('on',x===b)); render();};
});
els.rho.addEventListener('input',render);
els.gam.addEventListener('input',render);
render();
</script>
</body>
</html>
)----"
}

## annotate=TRUE draws the title + goodness-of-fit text inside the
## standalone base figure.
fanc_plot_base <- function(info, rho.index, gamma.index, annotate=TRUE) {
    old.par <- graphics::par(no.readonly=TRUE)
    on.exit(graphics::par(old.par))
    if (info$type == "path") {
        graphics::par(mar=c(1.5, 1.5, 7, 1.5) + 0.1)
        fanc_base_path(info, rho.index, gamma.index, annotate)
    } else {
        graphics::par(mar=c(8, 6, 7, 2) + 0.1)
        fanc_base_heatmap(info, rho.index, gamma.index, annotate)
    }
}

fanc_base_annotation <- function(info, rho.index, gamma.index) {
    metrics <- fanc_metric_values(info, rho.index, gamma.index)
    gof <- sprintf(
        "GFI %.3f   AGFI %.3f   CFI %.3f   RMSEA %.3f   SRMR %.3f",
        metrics["GFI"], metrics["AGFI"], metrics["CFI"],
        metrics["RMSEA"], metrics["SRMR"]
    )
    criteria <- sprintf(
        "AIC %.4f   BIC %.4f   CAIC %.4f   EBIC %.4f",
        metrics["AIC"], metrics["BIC"], metrics["CAIC"],
        metrics["EBIC"]
    )
    graphics::mtext(info$title, side=3, line=5.4, adj=0.5,
                    cex=1.1, font=2)
    graphics::mtext(fanc_loading_label(info, rho.index, gamma.index),
                    side=3, line=3.9, adj=0.5, cex=0.9, font=2)
    graphics::mtext(gof, side=3, line=2.1, adj=0, cex=0.7)
    graphics::mtext(criteria, side=3, line=0.9, adj=0, cex=0.7)
}

## ---- overview: small multiples across the whole rho path -----------
## One mini diagram per rho value (for the current gamma); the panel
## matching current.rho is highlighted in red.
fanc_overview <- function(info, gamma.index, current.rho=NA) {
    old.par <- graphics::par(no.readonly=TRUE)
    on.exit(graphics::par(old.par))
    n <- info$N.lambda
    ncol <- ceiling(sqrt(n))
    nrow <- ceiling(n / ncol)
    graphics::par(mfrow=c(nrow, ncol), mar=c(0.6, 0.6, 1.8, 0.6),
                  oma=c(0, 0, 2.6, 0))
    for (ri in seq_len(n)) {
        if (info$type == "path") {
            fanc_base_path_core(info, ri, gamma.index, labels=FALSE)
        } else {
            fanc_mini_heatmap(info, ri, gamma.index)
        }
        highlight <- isTRUE(ri == current.rho)
        graphics::title(
            main=sprintf("rho=%.3g", info$lambdas[ri, gamma.index]),
            cex.main=0.85, font.main=if (highlight) 2 else 1,
            col.main=if (highlight) "#d62728" else "black")
        if (highlight) graphics::box(col="#d62728", lwd=3)
    }
    header <- if (info$N.gamma > 1)
        sprintf("%s   (gamma = %.5g)", info$title, info$gammas[gamma.index])
    else info$title
    graphics::mtext(header, outer=TRUE, cex=1.1, font=2)
}

fanc_mini_heatmap <- function(info, rho.index, gamma.index) {
    loadings <- fanc_matrix(info, rho.index, gamma.index)
    graphics::image(
        seq_len(info$N.var), seq_len(info$N.fac), loadings,
        col=fanc_heatmap_colours(256),
        zlim=c(-info$max.loading, info$max.loading),
        axes=FALSE, xlab="", ylab="")
    graphics::box()
}

fanc_base_heatmap <- function(info, rho.index, gamma.index, annotate=TRUE) {
    loadings <- fanc_matrix(info, rho.index, gamma.index)
    graphics::image(
        seq_len(info$N.var), seq_len(info$N.fac), loadings,
        col=fanc_heatmap_colours(256),
        zlim=c(-info$max.loading, info$max.loading),
        xlab="", ylab="", axes=FALSE
    )
    variable.at <- seq(1, info$N.var, by=ceiling(info$N.var / 40))
    variable.labels <- vapply(
        fanc_var_names(info)[variable.at],
        fanc_base_abbreviate_label,
        character(1),
        max.chars=14
    )
    factor.labels <- vapply(
        fanc_factor_names(info),
        fanc_base_abbreviate_label,
        character(1),
        max.chars=18
    )
    factor.cex <- max(0.45, min(0.8, 12 / info$N.fac))
    graphics::axis(1, at=variable.at, labels=variable.labels,
                   las=2, cex.axis=0.7)
    graphics::axis(2, at=seq_len(info$N.fac), labels=factor.labels,
                   las=1, cex.axis=factor.cex)
    graphics::mtext("variables", side=1, line=6.5)
    graphics::mtext("factors", side=2, line=4.5)
    graphics::box()
    if (annotate) fanc_base_annotation(info, rho.index, gamma.index)
}

fanc_heatmap_colours <- function(n) {
    c(grDevices::colorRampPalette(c("#b2182b", "#ffffff"))(n),
      grDevices::colorRampPalette(c("#ffffff", "#111111"))(n))
}

fanc_base_clean_label <- function(label) {
    label <- enc2utf8(as.character(label))
    for (code in c(seq_len(31), 127, 0x2028, 0x2029)) {
        label <- gsub(intToUtf8(code), " ", label, fixed=TRUE)
    }
    trimws(gsub(" +", " ", label))
}

fanc_base_abbreviate_label <- function(label, max.chars) {
    label <- fanc_base_clean_label(label)
    if (nchar(label, type="chars") <= max.chars) return(label)
    paste0(substr(label, 1, max(1, max.chars - 3)), "...")
}

fanc_base_fit_label <- function(label, max.width, max.cex, min.cex=0.45) {
    label <- fanc_base_clean_label(label)
    if (!nzchar(label)) return(list(text="", cex=max.cex))
    measure <- function(text, cex) {
        suppressWarnings(graphics::strwidth(text, cex=cex, units="user"))
    }
    width <- measure(label, max.cex)
    if (is.finite(width) && width <= max.width) {
        return(list(text=label, cex=max.cex))
    }
    width.at.one <- measure(label, 1)
    fitted.cex <- if (is.finite(width.at.one) && width.at.one > 0) {
        min(max.cex, max.width / width.at.one)
    } else {
        min.cex
    }
    if (fitted.cex >= min.cex) {
        return(list(text=label, cex=fitted.cex))
    }
    n <- nchar(label, type="chars")
    for (keep in rev(seq_len(n))) {
        candidate <- paste0(substr(label, 1, keep), "...")
        candidate.width <- measure(candidate, min.cex)
        if (is.finite(candidate.width) && candidate.width <= max.width) {
            return(list(text=candidate, cex=min.cex))
        }
    }
    list(text="...", cex=min.cex)
}

## Core path diagram (nodes + edges) shared by the detail view and the
## overview small multiples. labels=FALSE skips the node text for the
## tiny overview panels.
fanc_base_path_core <- function(info, rho.index, gamma.index, labels=TRUE) {
    layout <- fanc_path_layout(info)
    loadings <- fanc_matrix(info, rho.index, gamma.index)
    graphics::plot(
        NULL, NULL, xlim=c(0, layout$width), ylim=c(layout$height, 0),
        axes=FALSE, ann=FALSE, xaxs="i", yaxs="i"
    )
    for (j in seq_len(info$N.fac)) {
        graphics::symbols(layout$x.fac[j], layout$y.fac,
                          circles=layout$rx, inches=FALSE, add=TRUE)
        if (labels) {
            fitted <- fanc_base_fit_label(
                fanc_factor_names(info)[j],
                max.width=layout$rx * 1.7,
                max.cex=0.8
            )
            graphics::text(layout$x.fac[j], layout$y.fac,
                           labels=fitted$text, cex=fitted$cex)
        }
    }
    for (i in seq_len(info$N.var)) {
        graphics::rect(layout$x.var[i] - layout$rw / 2,
                       layout$y.var - layout$rh / 2,
                       layout$x.var[i] + layout$rw / 2,
                       layout$y.var + layout$rh / 2)
        if (labels) {
            fitted <- fanc_base_fit_label(
                fanc_var_names(info)[i],
                max.width=layout$rw * 0.88,
                max.cex=0.7
            )
            graphics::text(layout$x.var[i], layout$y.var,
                           labels=fitted$text, cex=fitted$cex)
        }
    }
    for (i in seq_len(info$N.var)) {
        for (j in seq_len(info$N.fac)) {
            value <- loadings[i, j]
            width <- abs(value * 10)
            if (width > 0.05) {
                graphics::lines(
                    c(layout$x.var[i], layout$x.fac[j]),
                    c(layout$y.var - layout$rh / 2, layout$y.fac + layout$ry),
                    col=if (value < 0) "red" else "black",
                    lwd=max(1, min(width, 12))
                )
            }
        }
    }
}

fanc_base_path <- function(info, rho.index, gamma.index, annotate=TRUE) {
    fanc_base_path_core(info, rho.index, gamma.index, labels=TRUE)
    if (annotate) fanc_base_annotation(info, rho.index, gamma.index)
}