r_worker.R

#!/usr/bin/env Rscript
# figure_editor R 工作进程
# 协议:stdin 每行一个 JSON 命令,stdout 每行一个 JSON 响应。
# 命令: inspect {path, subplot} / render {path, subplot, patches, width, height, out}
#       save {path, patches_all, width, height, outdir, prefix}
# patches 为扁平 named list,id 形如:
#   label|title                      文字内容
#   text|plot.title|size             主题文字属性 (size/colour/face/hjust/vjust/angle)
#   theme|legend.position            图例位置
#   global|text.size                 全局基准字号(只影响未被单独覆盖的文字)
#   layer|<i>|<slot>|<param>         图层参数, slot = aes_params/geom_params/stat_params
#   palette|<i>|<key>                离散 scale 的颜色值
#   scalelabel|<i>|<key>             离散 scale 的刻度/图例文字
#   strip|<显示文字>                 分面标签文字
#   ylim|min / ylim|max              y 轴范围

suppressPackageStartupMessages({
  library(ggplot2)
  library(jsonlite)
  library(svglite)
})

`%||%` <- function(a, b) if (is.null(a)) b else a

plot_cache <- new.env()

load_plot <- function(path) {
  mt <- file.info(path)$mtime
  if (exists(path, envir = plot_cache)) {
    ent <- get(path, envir = plot_cache)
    if (identical(ent$mtime, mt)) return(ent$plot)
  }
  p <- readRDS(path)
  assign(path, list(plot = p, mtime = mt), envir = plot_cache)
  p
}

is_pw   <- function(p) inherits(p, "patchwork")
is_surv <- function(p) inherits(p, c("ggsurvplot", "ggsurv"))

get_child <- function(p, subplot) {
  subplot <- suppressWarnings(as.integer(subplot))
  if (is.na(subplot) || subplot < 1) subplot <- 1L
  if (is_pw(p)) {
    n <- length(p$patches$plots)
    if (n == 0) stop("patchwork 中没有子图")
    p$patches$plots[[min(subplot, n)]]
  } else if (is_surv(p)) {
    p$plot
  } else p
}

set_child <- function(p, subplot, child) {
  subplot <- suppressWarnings(as.integer(subplot))
  if (is.na(subplot) || subplot < 1) subplot <- 1L
  if (is_pw(p)) {
    p$patches$plots[[min(subplot, length(p$patches$plots))]] <- child
    p
  } else if (is_surv(p)) {
    p$plot <- child
    p
  } else child
}

subplot_info <- function(p) {
  if (is_pw(p)) {
    lapply(seq_along(p$patches$plots), function(i) {
      t <- tryCatch(p$patches$plots[[i]]$labels$title, error = function(e) NULL)
      list(index = i,
           label = if (!is.null(t) && nzchar(as.character(t)[1])) paste0(i, ": ", as.character(t)[1]) else paste("子图", i))
    })
  } else if (is_surv(p)) {
    list(list(index = 1L, label = "生存曲线主图"))
  } else {
    list(list(index = 1L, label = "整图"))
  }
}

# ---- 主题读取 -------------------------------------------------------------

ELEM_INHERIT <- list(
  "plot.title"    = c("plot.title", "title", "text"),
  "plot.subtitle" = c("plot.subtitle", "text"),
  "plot.caption"  = c("plot.caption", "text"),
  "axis.title.x"  = c("axis.title.x", "axis.title", "text"),
  "axis.title.y"  = c("axis.title.y", "axis.title", "text"),
  "axis.text.x"   = c("axis.text.x", "axis.text", "text"),
  "axis.text.y"   = c("axis.text.y", "axis.text", "text"),
  "strip.text"    = c("strip.text", "text"),
  "legend.text"   = c("legend.text", "text"),
  "legend.title"  = c("legend.title", "text"),
  "text"          = c("text")
)

eff_theme <- function(p) {
  th <- theme_get()
  if (!is.null(p$theme)) th <- th + p$theme
  th
}

el_prop <- function(th, elem, prop, default = NULL) {
  for (cand in ELEM_INHERIT[[elem]]) {
    e <- th[[cand]]
    if (!is.null(e) && inherits(e, "element_text")) {
      v <- e[[prop]]
      if (!is.null(v) && length(v) > 0 && !anyNA(v[1])) return(v[1])
    }
  }
  default
}

to_hex <- function(col) {
  if (is.null(col) || length(col) == 0 || anyNA(col)) return("#000000")
  col <- as.character(col)[1]
  if (grepl("^#", col)) return(toupper(substr(col, 1, 7)))
  toupper(tryCatch({
    m <- grDevices::col2rgb(col)
    grDevices::rgb(m[1], m[2], m[3], maxColorValue = 255)
  }, error = function(e) "#000000"))
}

# ---- 控件构造 -------------------------------------------------------------

ctl_num <- function(id, label, value, step = 0.5)
  list(id = id, label = label, type = "number", value = round(as.numeric(value)[1], 4), step = step)
ctl_col <- function(id, label, value)
  list(id = id, label = label, type = "color", value = to_hex(value))
ctl_txt <- function(id, label, value)
  list(id = id, label = label, type = "text", value = as.character(value)[1])
ctl_sel <- function(id, label, value, options)
  list(id = id, label = label, type = "select", value = as.character(value)[1], options = as.list(options))
ctl_chk <- function(id, label, value)
  list(id = id, label = label, type = "checkbox", value = isTRUE(value))

text_group <- function(th, elem, label, content = NULL, angle = FALSE) {
  items <- list()
  if (!is.null(content)) items[[length(items) + 1]] <- ctl_txt(paste0("label|", content$id), "内容", content$value)
  items[[length(items) + 1]] <- ctl_num(paste0("text|", elem, "|size"), "字号", el_prop(th, elem, "size", 11), 0.5)
  items[[length(items) + 1]] <- ctl_col(paste0("text|", elem, "|colour"), "颜色", el_prop(th, elem, "colour", "grey20"))
  items[[length(items) + 1]] <- ctl_sel(paste0("text|", elem, "|face"), "字形", el_prop(th, elem, "face", "plain"),
                                        c("plain", "bold", "italic", "bold.italic"))
  items[[length(items) + 1]] <- ctl_num(paste0("text|", elem, "|hjust"), "水平对齐", el_prop(th, elem, "hjust", 0.5), 0.1)
  if (angle) {
    items[[length(items) + 1]] <- ctl_num(paste0("text|", elem, "|angle"), "角度", el_prop(th, elem, "angle", 0), 5)
    items[[length(items) + 1]] <- ctl_num(paste0("text|", elem, "|vjust"), "垂直对齐", el_prop(th, elem, "vjust", 0.5), 0.1)
  }
  list(group = label, items = items)
}

GEOM_CN <- c(
  GeomCol = "柱子", GeomBar = "柱子", GeomErrorbar = "误差线", GeomPoint = "点",
  GeomText = "文字", GeomLabel = "标签", GeomHline = "水平线", GeomVline = "竖线",
  GeomAbline = "参考线", GeomLine = "线", GeomPath = "线", GeomSmooth = "平滑线",
  GeomRibbon = "色带", GeomRect = "矩形", GeomSegment = "线段", GeomDensity = "密度",
  GeomBoxplot = "箱线图", GeomArea = "面积", GeomHistogram = "直方图",
  GeomCrossbar = "横杠", GeomViolin = "小提琴", GeomTile = "色块", GeomCurve = "曲线"
)

layer_group <- function(L, i) {
  gname <- class(L$geom)[1] %||% "Geom"
  cn <- if (gname %in% names(GEOM_CN)) unname(GEOM_CN[[gname]]) else gsub("^Geom", "", gname)
  items <- list()
  for (slot in c("aes_params", "geom_params", "stat_params")) {
    params <- L[[slot]]
    if (is.null(params)) next
    for (nm in names(params)) {
      if (nm == "family") next
      # 逐个参数隔离失败:ggplot2 3.5 会用 missing-arg symbol 占位(如 fatten),
      # 强制求值即报 "argument v is missing",必须 tryCatch 兜住
      item <- tryCatch({
        v <- params[[nm]]
        if (is.null(v) || is.symbol(v) || is.language(v) || is.list(v) || length(v) != 1) NULL
        else if (is.atomic(v) && anyNA(v)) NULL
        else {
          id <- paste("layer", i, slot, nm, sep = "|")
          lab <- if (slot == "aes_params") nm else paste0(nm, " (", sub("_params", "", slot), ")")
          if (is.logical(v)) ctl_chk(id, lab, v)
          else if (is.numeric(v)) ctl_num(id, lab, v, if (abs(v) <= 1) 0.05 else 0.5)
          else if (is.character(v)) {
            if (grepl("^#", v) || v %in% grDevices::colors()) ctl_col(id, lab, v)
            else if (nm == "linetype") ctl_sel(id, lab, v, c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash", "blank"))
            else ctl_txt(id, lab, v)
          } else NULL
        }
      }, error = function(e) NULL)
      if (!is.null(item)) items[[length(items) + 1]] <- item
    }
  }
  if (length(items) == 0) return(NULL)
  list(group = sprintf("图层%d · %s", i, cn), items = items)
}

# 在 scale$palette 相关闭包环境中寻找 manual values
# (ggproto 方法包装环境的 f 绑定的闭包环境里有 values/pal/limits 等)
pal_values_env <- function(sc) {
  tryCatch({
    cands <- list(environment(sc$palette))
    f <- tryCatch(get("f", envir = cands[[1]], inherits = FALSE), error = function(e) NULL)
    if (is.function(f)) cands[[length(cands) + 1]] <- environment(f)
    for (ce in cands) {
      if (exists("values", envir = ce, inherits = FALSE)) {
        v <- get("values", envir = ce)
        if (is.character(v) && length(v) > 0 &&
            all(grepl("^#", v) | v %in% grDevices::colors())) return(ce)
      }
    }
    NULL
  }, error = function(e) NULL)
}

pal_values <- function(sc) {
  e <- pal_values_env(sc)
  if (is.null(e)) return(NULL)
  get("values", envir = e)
}

disc_keys <- function(sc, b = NULL) {
  v <- pal_values(sc)
  if (!is.null(v) && !is.null(names(v))) return(names(v))
  k <- tryCatch({
    kk <- sc$get_limits()
    if (is.character(kk) && length(kk) > 0) kk else NULL
  }, error = function(e) NULL)
  if (!is.null(k)) return(k)
  if (!is.null(b) && any(sc$aesthetics %in% c("x", "y"))) {
    pp <- b$layout$panel_params[[1]]
    vs <- if ("x" %in% sc$aesthetics) pp$x else pp$y
    kk <- tryCatch(vs$get_breaks(), error = function(e) NULL)
    if (!is.null(kk) && is.character(kk) && length(kk) > 0) return(kk)
  }
  NULL
}

# 当前配色:named character vector (可能为空)
disc_values <- function(sc, keys) {
  v <- pal_values(sc)
  if (is.null(v)) return(NULL)
  v <- as.character(v)
  if (!is.null(names(v))) return(v)
  if (!is.null(keys) && length(v) >= length(keys)) return(setNames(v[seq_along(keys)], keys))
  NULL
}

scales_groups <- function(p, b = NULL) {
  groups <- list()
  scs <- p$scales$scales
  for (i in seq_along(scs)) {
    sc <- scs[[i]]
    if (!isTRUE(tryCatch(sc$is_discrete(), error = function(e) FALSE))) next
    keys <- disc_keys(sc, b)
    if (is.null(keys) || length(keys) == 0) next
    aes_name <- paste(sc$aesthetics, collapse = "/")
    items <- list()
    if (any(sc$aesthetics %in% c("colour", "color", "fill"))) {
      vals <- disc_values(sc, keys)
      if (!is.null(vals)) {
        for (k in keys) {
          v <- vals[[k]]
          if (is.null(v) || anyNA(v)) next
          items[[length(items) + 1]] <- ctl_col(paste0("palette|", i, "|", k), paste0("颜色: ", k), v)
        }
      }
    }
    labs <- tryCatch({
      l <- sc$labels
      if (is.character(l) && length(l) == length(keys)) {
        if (is.null(names(l))) names(l) <- keys
        l
      } else setNames(as.character(keys), keys)
    }, error = function(e) setNames(as.character(keys), keys))
    for (k in keys) {
      cur <- tryCatch({ v <- labs[[k]]; if (is.null(v)) k else as.character(v)[1] }, error = function(e) k)
      items[[length(items) + 1]] <- ctl_txt(paste0("scalelabel|", i, "|", k), paste0("文字: ", k), cur)
    }
    if (length(items) > 0)
      groups[[length(groups) + 1]] <- list(group = paste0("配色 / 刻度文字 (", aes_name, ")"), items = items)
  }
  groups
}

strip_group <- function(p, b = NULL) {
  if (!inherits(p$facet, c("FacetWrap", "FacetGrid"))) return(NULL)
  items <- tryCatch({
    lab <- p$facet$params$labeller
    fvars <- names(p$facet$params$facets)
    if (length(fvars) == 0) {
      fvars <- c(names(p$facet$params$rows), names(p$facet$params$cols))
    }
    if (is.null(b)) b <- ggplot_build(p)
    ly <- b$layout$layout
    fvars <- intersect(fvars, names(ly))
    if (length(fvars) == 0) stop("no facet vars")
    df <- unique(ly[, fvars, drop = FALSE])
    its <- list()
    for (r in seq_len(nrow(df))) {
      disp_parts <- character(0)
      for (fv in fvars) {
        one <- df[r, fv, drop = FALSE]
        out <- tryCatch(lab(one), error = function(e) one)
        v <- tryCatch(as.character(unlist(out[[1]]))[1], error = function(e) as.character(one[[1]]))
        disp_parts <- c(disp_parts, v)
      }
      disp <- paste(disp_parts, collapse = ", ")
      its[[length(its) + 1]] <- ctl_txt(paste0("strip|", disp), paste0("分面: ", disp), disp)
    }
    its
  }, error = function(e) NULL)
  if (is.null(items) || length(items) == 0) return(NULL)
  list(group = "分面标签文字", items = items)
}

y_limits <- function(p, b = NULL) {
  yl <- tryCatch(p$coordinates$params$limits$y, error = function(e) NULL)
  if (is.null(yl) && !is.null(b)) {
    yl <- tryCatch({
      r <- b$layout$panel_params[[1]]$y.range
      if (is.null(r)) NULL else as.numeric(r)
    }, error = function(e) NULL)
  }
  if (is.null(yl) || length(yl) != 2 || anyNA(yl)) return(NULL)
  yl
}

# inspect 结果缓存:同一张图(rds 未变)重复打开秒回
inspect_cache <- new.env()

cmd_inspect <- function(msg) {
  key <- paste0(msg$path, "|", msg$subplot %||% 1, "|", file.info(msg$path)$mtime)
  if (exists(key, envir = inspect_cache)) return(get(key, envir = inspect_cache))
  res <- cmd_inspect_real(msg)
  if (isTRUE(res$ok)) assign(key, res, envir = inspect_cache)
  res
}

cmd_inspect_real <- function(msg) {
  p <- load_plot(msg$path)
  subs <- subplot_info(p)
  child <- get_child(p, msg$subplot %||% 1)
  if (!inherits(child, "ggplot")) stop("该对象(子图)不是 ggplot,暂不支持编辑")

  th <- eff_theme(child)
  labval <- function(nm) {
    v <- tryCatch(child$labels[[nm]], error = function(e) NULL)
    if (is.null(v)) "" else as.character(v)[1]
  }

  groups <- list(
    text_group(th, "plot.title", "标题", list(id = "title", value = labval("title"))),
    text_group(th, "plot.subtitle", "副标题", list(id = "subtitle", value = labval("subtitle"))),
    text_group(th, "axis.title.x", "X 轴标题", list(id = "x", value = labval("x"))),
    text_group(th, "axis.title.y", "Y 轴标题", list(id = "y", value = labval("y"))),
    text_group(th, "plot.caption", "图注 caption", list(id = "caption", value = labval("caption"))),
    text_group(th, "axis.text.x", "X 轴刻度文字", angle = TRUE),
    text_group(th, "axis.text.y", "Y 轴刻度文字"),
    text_group(th, "strip.text", "分面标题样式"),
    text_group(th, "legend.text", "图例文字")
  )

  lp <- tryCatch(th[["legend.position"]], error = function(e) NULL)
  if (is.null(lp)) lp <- "right"
  if (length(lp) > 1) lp <- "inside"
  groups[[length(groups) + 1]] <- list(group = "图例", items = list(
    ctl_sel("theme|legend.position", "图例位置", lp, c("none", "left", "right", "top", "bottom"))
  ))

  for (i in seq_along(child$layers)) {
    g <- layer_group(child$layers[[i]], i)
    if (!is.null(g)) groups[[length(groups) + 1]] <- g
  }

  b <- tryCatch(ggplot_build(child), error = function(e) NULL)
  groups <- c(groups, scales_groups(child, b))

  sg <- strip_group(child, b)
  if (!is.null(sg)) groups[[length(groups) + 1]] <- sg

  yl <- y_limits(child, b)
  if (!is.null(yl)) {
    groups[[length(groups) + 1]] <- list(group = "Y 轴范围", items = list(
      ctl_num("ylim|min", "下限", yl[1], 0.05),
      ctl_num("ylim|max", "上限", yl[2], 0.05)
    ))
  }

  groups[[length(groups) + 1]] <- list(group = "全局", items = list(
    ctl_num("global|text.size", "全局基准字号", el_prop(th, "text", "size", 11), 0.5)
  ))

  list(ok = TRUE, class = class(p)[1], subplots = subs, groups = groups)
}

# ---- 文本拖拽(PPT 式自由移动) ----------------------------------------------
# 机制:ggplotGrob 得到 gtable,按 draw 顺序遍历收集 text grob,
# 路径编码如 "g6.c2.g2.c1#3"(g=grobs[[k]], c=children[[k]], #i=多标签中的第 i 个)。
# 前端把 SVG 里的 <text> 与遍历结果配对,拖动后传回 {dx,dy}(单位 pt),
# 这里在 grob 的 x/y 上叠加 unit(d,"pt"),重渲染即改变位置。

to_gtable <- function(p) {
  if (is_pw(p)) return(patchwork::patchworkGrob(p))
  if (is_surv(p)) {
    if (!is.null(p$table.survplot)) stop("带风险表的生存曲线不支持拖拽")
    return(ggplotGrob(p$plot))
  }
  ggplotGrob(p)
}

collect_texts <- function(g) {
  out <- list()
  walk <- function(node, path) {
    if (inherits(node, "text")) {
      if (!is.null(node$x) && !is.null(node$y)) {
        nl <- max(1L, length(node$label))
        for (i in seq_len(nl)) {
          lab <- tryCatch(as.character(node$label[[min(i, length(node$label))]]),
                          error = function(e) "")
          out[[length(out) + 1]] <<- list(k = paste0(path, "#", i), text = lab)
        }
      }
      return(invisible())
    }
    if (!is.null(node$children)) {
      for (j in seq_along(node$children)) walk(node$children[[j]], paste0(path, ".c", j))
    }
    if (inherits(node, "gtable")) {
      zord <- tryCatch(order(node$layout$z), error = function(e) seq_along(node$grobs))
      for (j in zord) walk(node$grobs[[j]], paste0(path, ".g", j))
    }
    invisible()
  }
  zord <- tryCatch(order(g$layout$z), error = function(e) seq_along(g$grobs))
  for (k in zord) walk(g$grobs[[k]], paste0("g", k))
  out
}

rec_set <- function(node, segs, fn) {
  if (length(segs) == 0) return(fn(node))
  s <- segs[1]
  slot <- if (startsWith(s, "g")) "grobs" else "children"
  i <- as.integer(substring(s, 2))
  node[[slot]][[i]] <- rec_set(node[[slot]][[i]], segs[-1], fn)
  node
}

shift_unit <- function(u, i, d) {
  if (i <= 0 || length(u) < i) return(u + grid::unit(d, "pt"))
  lst <- lapply(seq_along(u), function(j) if (j == i) u[j] + grid::unit(d, "pt") else u[j])
  do.call(grid::unit.c, lst)
}

shift_grob <- function(gr, i, dx, dy) {
  if (!inherits(gr, "text") || is.null(gr$x) || is.null(gr$y)) return(gr)
  gr$x <- shift_unit(gr$x, i, dx)
  gr$y <- shift_unit(gr$y, i, dy)
  gr
}

apply_moves <- function(g, moves) {
  for (key in names(moves)) {
    mv <- moves[[key]]
    dx <- suppressWarnings(as.numeric(mv$dx))
    dy <- suppressWarnings(as.numeric(mv$dy))
    if (!is.finite(dx) || !is.finite(dy)) next
    parts <- strsplit(key, "#", fixed = TRUE)[[1]]
    li <- suppressWarnings(as.integer(parts[2]))
    if (is.na(li)) li <- 1L
    segs <- strsplit(parts[1], ".", fixed = TRUE)[[1]]
    g <- tryCatch(rec_set(g, segs, function(gr) shift_grob(gr, li, dx, dy)),
                  error = function(e) g)
  }
  g
}

# 出图入口:gtable 路线(支持拖拽映射)失败则退回 print
draw_plot <- function(p, moves = list()) {
  g <- tryCatch(to_gtable(p), error = function(e) NULL)
  if (is.null(g)) { print(p); return(list()) }
  g <- apply_moves(g, moves)
  texts <- tryCatch(collect_texts(g), error = function(e) list())
  grid::grid.newpage()
  grid::grid.draw(g)
  texts
}

# ---- 补丁应用 -------------------------------------------------------------

TEXT_NUM_PROPS <- c("size", "hjust", "vjust", "angle", "lineheight")

apply_one <- function(child, id, value) {
  parts <- strsplit(id, "|", fixed = TRUE)[[1]]
  kind <- parts[1]
  if (kind == "label") {
    if (nzchar(value)) child$labels[[parts[2]]] <- value
    else child$labels[[parts[2]]] <- NULL
  } else if (kind == "text") {
    el <- parts[2]; prop <- parts[3]
    if (prop %in% TEXT_NUM_PROPS) value <- as.numeric(value)
    args <- setNames(list(value), prop)
    th <- setNames(list(do.call(element_text, args)), el)
    child <- child + do.call(theme, th)
  } else if (kind == "theme") {
    if (parts[2] == "legend.position") child <- child + theme(legend.position = value)
  } else if (kind == "global") {
    if (parts[2] == "text.size") child <- child + theme(text = element_text(size = as.numeric(value)))
  } else if (kind == "layer") {
    i <- as.integer(parts[2]); slot <- parts[3]
    param <- paste(parts[4:length(parts)], collapse = "|")
    child$layers[[i]][[slot]][[param]] <- value
  } else if (kind == "palette") {
    i <- as.integer(parts[2])
    key <- paste(parts[3:length(parts)], collapse = "|")
    sc <- child$scales$scales[[i]]
    e <- pal_values_env(sc)
    if (!is.null(e)) {
      cur <- get("values", envir = e)
      keys <- names(cur)
      if (is.null(keys)) {
        keys <- tryCatch({ kk <- sc$get_limits(); if (is.character(kk) && length(kk) >= length(cur)) kk[seq_along(cur)] else NULL },
                         error = function(e) NULL)
      }
      if (!is.null(keys) && key %in% keys) {
        v <- setNames(as.character(cur), keys)
        v[[key]] <- value
        assign("values", v, envir = e)
      }
    }
  } else if (kind == "scalelabel") {
    i <- as.integer(parts[2])
    key <- paste(parts[3:length(parts)], collapse = "|")
    sc <- child$scales$scales[[i]]
    # 用函数形式替换 labels,无需知道全部 breaks,未改动的键保持原样
    sc$labels <- function(br) {
      v <- as.character(br)
      v[v == key] <- value
      v
    }
    child$scales$scales[[i]] <- sc
  }
  child
}

apply_strip_map <- function(child, strip_map) {
  old_lab <- tryCatch(child$facet$params$labeller, error = function(e) NULL)
  new_lab <- as_labeller(function(df) {
    out <- tryCatch(old_lab(df), error = function(e) df)
    out <- as.data.frame(out, stringsAsFactors = FALSE)
    for (cn in names(out)) {
      v <- as.character(unlist(out[[cn]]))
      for (k in names(strip_map)) v[v == k] <- strip_map[[k]]
      out[[cn]] <- v
    }
    out
  })
  child$facet$params$labeller <- new_lab
  child
}

apply_child <- function(child, patches) {
  if (length(patches) == 0) return(child)
  ymin <- patches[["ylim|min"]]
  ymax <- patches[["ylim|max"]]
  strip_map <- list()
  for (nm in names(patches)) {
    if (nm %in% c("ylim|min", "ylim|max")) next
    if (startsWith(nm, "strip|")) {
      strip_map[[sub("^strip\\|", "", nm)]] <- patches[[nm]]
      next
    }
    child <- tryCatch(apply_one(child, nm, patches[[nm]]), error = function(e) child)
  }
  if (!is.null(ymin) && !is.null(ymax)) {
    tryCatch(child$coordinates$params$limits$y <- c(as.numeric(ymin), as.numeric(ymax)),
             error = function(e) NULL)
  }
  if (length(strip_map) > 0) {
    child <- tryCatch(apply_strip_map(child, strip_map), error = function(e) child)
  }
  child
}

apply_all <- function(p, msg) {
  if (!is.null(msg$patches_all)) {
    # 保存:应用所有子图的补丁
    for (k in names(msg$patches_all)) {
      child <- get_child(p, as.integer(k))
      child <- apply_child(child, msg$patches_all[[k]])
      p <- set_child(p, as.integer(k), child)
    }
    p
  } else {
    child <- get_child(p, msg$subplot %||% 1)
    child <- apply_child(child, msg$patches %||% list())
    set_child(p, msg$subplot %||% 1, child)
  }
}

cmd_render <- function(msg) {
  p <- load_plot(msg$path)
  p <- apply_all(p, msg)
  svglite::svglite(msg$out, width = as.numeric(msg$width), height = as.numeric(msg$height),
                   bg = "white", fix_text_size = FALSE)
  on.exit(grDevices::dev.off(), add = TRUE)
  texts <- draw_plot(p, msg$moves %||% list())
  list(ok = TRUE, texts = texts)
}

cmd_save <- function(msg) {
  p <- load_plot(msg$path)
  p <- apply_all(p, msg)
  moves <- msg$moves %||% list()
  w <- as.numeric(msg$width); h <- as.numeric(msg$height)
  prefix <- file.path(msg$outdir, msg$prefix)
  files <- character(0)

  grDevices::cairo_pdf(paste0(prefix, ".pdf"), width = w, height = h)
  draw_plot(p, moves); grDevices::dev.off()
  files <- c(files, paste0(msg$prefix, ".pdf"))

  svglite::svglite(paste0(prefix, ".svg"), width = w, height = h, bg = "white", fix_text_size = FALSE)
  draw_plot(p, moves); grDevices::dev.off()
  files <- c(files, paste0(msg$prefix, ".svg"))

  grDevices::png(paste0(prefix, ".png"), width = w, height = h, units = "in", res = 350, bg = "white")
  draw_plot(p, moves); grDevices::dev.off()
  files <- c(files, paste0(msg$prefix, ".png"))

  grDevices::tiff(paste0(prefix, ".tiff"), width = w, height = h, units = "in", res = 350,
                  compression = "lzw", bg = "white")
  draw_plot(p, moves); grDevices::dev.off()
  files <- c(files, paste0(msg$prefix, ".tiff"))

  jsonlite::write_json(list(
    subplots = msg$patches_all %||% list(),
    moves = moves,
    canvas = list(width = w, height = h)
  ), paste0(prefix, ".patches.json"), auto_unbox = TRUE, pretty = TRUE, null = "null")
  files <- c(files, paste0(msg$prefix, ".patches.json"))

  list(ok = TRUE, files = as.list(files))
}

handle <- function(msg) {
  switch(msg$cmd,
    inspect = cmd_inspect(msg),
    render  = cmd_render(msg),
    save    = cmd_save(msg),
    list(ok = FALSE, error = paste0("未知命令: ", msg$cmd))
  )
}

# ---- 主循环(socket 服务;stdin 会被 readRDS 干扰,不能用) -------------------

port <- as.integer(Sys.getenv("FIG_WORKER_PORT", "19999"))
cat(sprintf("WORKER_READY port=%d\n", port), file = stderr())

repeat {
  con <- NULL
  # bind 可能因端口短暂占用失败,重试 30 秒再放弃
  for (attempt in 1:30) {
    con <- tryCatch(
      socketConnection(host = "127.0.0.1", port = port, server = TRUE, blocking = TRUE, open = "r+"),
      error = function(e) NULL
    )
    if (!is.null(con)) break
    Sys.sleep(1)
  }
  if (is.null(con)) {
    cat(sprintf("WORKER_BIND_FAIL port=%d\n", port), file = stderr())
    quit(save = "no", status = 1)
  }
  # 每个连接只服务一个请求,回完即关,避免长连接两端状态错位
  line <- tryCatch(readLines(con, n = 1, warn = FALSE), error = function(e) character(0))
  if (length(line) > 0) {
    res <- tryCatch(
      handle(jsonlite::fromJSON(line, simplifyVector = FALSE)),
      error = function(e) {
        while (grDevices::dev.cur() > 1) grDevices::dev.off()
        list(ok = FALSE, error = conditionMessage(e))
      }
    )
    out <- jsonlite::toJSON(res, auto_unbox = TRUE, null = "null")
    tryCatch({ writeLines(out, con); flush(con) }, error = function(e) NULL)
  }
  tryCatch(close(con), error = function(e) NULL)
}