feat: export an R script that reproduces the app

NEWS.md

@@ -147,6 +147,7 @@ The article "Moving from NACHO 2" on the [package website](https://m.canouil.dev
   - feat: The Export page downloads the quality-control table as CSV, the thresholds as YAML, the object as RDS and the report, with an optional title and author.
     The report can be HTML or PDF, and it renders in the background when mirai is installed.
     If you close the app page during a render, the render stops.
+  - feat: The Export page also downloads an R script that repeats the analysis of the app with `load_rcc()`, `normalise()` and the thresholds you set, and shows it before you download it.
   - feat: A Help menu in the navbar opens About NACHO, links to the documentation, GitHub Discussions and the issue tracker, and shows how to cite NACHO.
   - feat: The "Flagged samples" page is now the "Samples" page.
     It still lists the flagged samples first, and then lists every sample.

R/mod_export.R

@@ -90,9 +90,155 @@ spreadsheet_safe <- function(data) {
   data
 }
 
+#' Write R code that reproduces an object tuned in the app
+#'
+#' The script loads the data with the settings of the object, or uses the
+#' example data when the object is the example data, then normalises it with
+#' the method, background and thresholds chosen in the app.
+#' The thresholds are written into the script and read back with
+#' [read_thresholds()], so the script is one file.
+#'
+#' @param object The `nacho` object of the app.
+#'
+#' @return The lines of the script.
+#'
+#' @noRd
+reproduce_script <- function(object) {
+  settings <- object@settings
+  thresholds <- object@thresholds
+  value <- function(x) paste(deparse(x, width.cutoff = 500L), collapse = " ")
+  argument <- function(name, x, last = FALSE) {
+    paste0("  ", name, " = ", x, if (!last) ",")
+  }
+  load <- if (identical(data_fingerprint(object), example_fingerprint())) {
+    "nacho <- GSE74821"
+  } else {
+    directory <- object@provenance[["data_directory"]]
+    uploaded <- !rlang::is_string(directory) ||
+      !dir.exists(directory) ||
+      startsWith(directory, tempdir()) ||
+      startsWith(
+        normalizePath(directory, mustWork = FALSE),
+        normalizePath(tempdir(), mustWork = FALSE)
+      )
+    c(
+      "# This loads every RCC file of the folder, so samples left out before",
+      "# the app are back.",
+      if (uploaded) {
+        c(
+          "# Point these to your RCC files and sample sheet. The sample sheet",
+          "# is a CSV file with an IDFILE column of RCC file names, and a",
+          "# plexset_id column (S1 to S8) for PlexSet files."
+        )
+      } else {
+        "# Point this to your sample sheet."
+      },
+      "nacho <- load_rcc(",
+      argument(
+        "data_directory",
+        if (uploaded) "\"path/to/rcc-files\"" else value(directory)
+      ),
+      argument("ssheet_csv", "\"path/to/samplesheet.csv\""),
+      argument("id_colname", value(settings[["id_colname"]])),
+      argument("housekeeping_genes", value(settings[["housekeeping_genes"]])),
+      argument(
+        "housekeeping_predict",
+        value(settings[["housekeeping_predict"]])
+      ),
+      argument("housekeeping_norm", value(settings[["housekeeping_norm"]])),
+      argument(
+        "instrument",
+        if (is.na(thresholds[["instrument"]])) {
+          "NULL"
+        } else {
+          value(thresholds[["instrument"]])
+        }
+      ),
+      argument("preset", value(thresholds[["preset"]])),
+      argument("n_comp", value(settings[["n_comp"]]), last = TRUE),
+      ")"
+    )
+  }
+  yaml_lines <- encodeString(
+    strsplit(thresholds_yaml(thresholds), "\n", fixed = TRUE)[[1]],
+    quote = "\""
+  )
+  c(
+    paste0(
+      "# Reproduces a NACHO app session (NACHO ",
+      utils::packageVersion("NACHO"),
+      ", ",
+      format(Sys.Date()),
+      ")."
+    ),
+    "library(NACHO)",
+    "",
+    load,
+    "",
+    "# The thresholds set in the app.",
+    "thresholds_file <- tempfile(fileext = \".yml\")",
+    "writeLines(",
+    "  c(",
+    paste0("    ", yaml_lines, c(rep(",", length(yaml_lines) - 1), "")),
+    "  ),",
+    "  thresholds_file",
+    ")",
+    "",
+    "nacho <- normalise(",
+    "  nacho,",
+    argument(
+      "normalisation_method",
+      value(settings[["normalisation_method"]])
+    ),
+    argument("background", value(settings[["background"]])),
+    argument("background_mode", value(settings[["background_mode"]])),
+    argument("ruv_k", value(settings[["ruv_k"]])),
+    argument(
+      "outliers_thresholds",
+      "read_thresholds(thresholds_file)",
+      last = TRUE
+    ),
+    ")"
+  )
+}
+
+#' Tell loaded data apart by their load time and samples
+#'
+#' `normalise()` adds to the provenance, so only the load time is compared.
+#'
+#' @noRd
+data_fingerprint <- function(object) {
+  list(object@provenance[["created"]], colnames(object@counts))
+}
+
+example_cache <- new.env(parent = emptyenv())
+
+#' The fingerprint of the example data, worked out once
+#'
+#' @noRd
+example_fingerprint <- function() {
+  if (is.null(example_cache$fingerprint)) {
+    example_cache$fingerprint <- data_fingerprint(example_data())
+  }
+  example_cache$fingerprint
+}
+
 mod_export_ui <- function(id, quarto) {
   ns <- shiny::NS(id)
-  bslib::layout_column_wrap(
+  reproduce <- bslib::card(
+    bslib::card_header("Reproduce in R"),
+    shiny::helpText(
+      "This R script repeats the analysis of the app, with the same",
+      "normalisation and thresholds."
+    ),
+    shiny::downloadButton(ns("script_r"), "R script"),
+    shiny::div(
+      class = "overflow-auto",
+      style = "max-height: 400px;",
+      shiny::verbatimTextOutput(ns("script"))
+    )
+  )
+  cards <- bslib::layout_column_wrap(
     id = ns("cards"),
     width = "320px",
     bslib::card(
@@ -136,6 +282,7 @@ mod_export_ui <- function(id, quarto) {
       }
     )
   )
+  shiny::tagList(cards, reproduce)
 }
 
 mod_export_server <- function(id, object, quarto) {
@@ -154,6 +301,12 @@ mod_export_server <- function(id, object, quarto) {
       filename = "nacho-thresholds.yml",
       content = function(file) write_thresholds(object()@thresholds, file)
     )
+    script <- shiny::reactive(reproduce_script(object()))
+    output$script <- shiny::renderText(paste(script(), collapse = "\n"))
+    output$script_r <- shiny::downloadHandler(
+      filename = "nacho-reproduce.R",
+      content = function(file) writeLines(script(), file)
+    )
     output$object_rds <- shiny::downloadHandler(
       filename = "nacho.rds",
       content = function(file) saveRDS(object(), file)

R/thresholds.R

@@ -332,14 +332,25 @@ check_thresholds <- function(
 #' unlink(file)
 write_thresholds <- function(thresholds, file) {
   check_thresholds(thresholds)
-  yaml::write_yaml(
+  writeLines(thresholds_yaml(thresholds), file, sep = "")
+  invisible(file)
+}
+
+#' Write thresholds as YAML text
+#'
+#' @inheritParams write_thresholds
+#'
+#' @return One string, with a line break after each line.
+#'
+#' @noRd
+thresholds_yaml <- function(thresholds) {
+  check_thresholds(thresholds)
+  yaml::as.yaml(
     thresholds,
-    file,
     handlers = list(numeric = function(value) {
       structure(yaml_numbers(value), class = "verbatim")
     })
   )
-  invisible(file)
 }
 
 #' @rdname write_thresholds

tests/testthat/test-mod_export.R

@@ -368,3 +368,159 @@ test_that("the thresholds download reads back exactly", {
     }
   )
 })
+
+run_script <- function(lines, data_directory = NULL, sample_sheet = NULL) {
+  lines <- lines[lines != "library(NACHO)"]
+  if (!is.null(data_directory)) {
+    lines <- sub(
+      "\"path/to/rcc-files\"",
+      deparse(data_directory),
+      lines,
+      fixed = TRUE
+    )
+    lines <- sub(
+      "\"path/to/samplesheet.csv\"",
+      deparse(sample_sheet),
+      lines,
+      fixed = TRUE
+    )
+  }
+  env <- new.env(parent = parent.frame())
+  suppressWarnings(suppressMessages(eval(parse(text = lines), envir = env)))
+  env[["nacho"]]
+}
+
+tune_app <- function(
+  x,
+  method,
+  background = "none",
+  mode = "threshold",
+  ruv_k = NULL,
+  thresholds = x@thresholds
+) {
+  chosen <- list(
+    normalisation_method = method,
+    ruv_k = ruv_k,
+    background = background,
+    background_mode = mode
+  )
+  suppressWarnings(NACHO:::tune_object(x, chosen, thresholds))
+}
+
+expect_same_result <- function(script, app) {
+  testthat::expect_identical(
+    nacho_counts(script, normalised = TRUE),
+    nacho_counts(app, normalised = TRUE)
+  )
+  testthat::expect_identical(nacho_qc(script), nacho_qc(app))
+  testthat::expect_identical(script@thresholds, app@thresholds)
+}
+
+test_that("the R script reproduces the example data as tuned in the app", {
+  thresholds <- utils::modifyList(
+    GSE74821@thresholds,
+    list(FoV = 95, BD = c(0.1, 2))
+  )
+  app <- tune_app(GSE74821, "GEO", "mean", "subtract", thresholds = thresholds)
+  script <- NACHO:::reproduce_script(app)
+  expect_true("nacho <- GSE74821" %in% script)
+  expect_same_result(run_script(script), app)
+})
+
+test_that("the R script reproduces RUVg with its number of factors", {
+  skip_if_not_installed("RUVSeq")
+  app <- tune_app(GSE74821, "RUVg", ruv_k = 2L)
+  expect_same_result(run_script(NACHO:::reproduce_script(app)), app)
+})
+
+test_that("the R script loads uploaded files from the paths the user sets", {
+  sheet <- withr::local_tempfile(fileext = ".csv")
+  utils::write.csv(
+    salmon_tidy[c("IDFILE", "plexset_id")],
+    sheet,
+    row.names = FALSE
+  )
+  app <- tune_app(salmon_nacho, "GLM")
+  script <- NACHO:::reproduce_script(app)
+  expect_false("nacho <- GSE74821" %in% script)
+  expect_true(any(grepl("load_rcc(", script, fixed = TRUE)))
+  expect_same_result(run_script(script, test_path("salmon_data"), sheet), app)
+})
+
+test_that("the example data is still known after normalise() adds provenance", {
+  x <- GSE74821
+  x@provenance[["glm_fallback"]] <- TRUE
+  expect_true("nacho <- GSE74821" %in% NACHO:::reproduce_script(x))
+})
+
+test_that("a subset of the example data is not reproduced as the example", {
+  script <- NACHO:::reproduce_script(flagged_gse())
+  expect_false("nacho <- GSE74821" %in% script)
+  expect_true(any(grepl("load_rcc(", script, fixed = TRUE)))
+})
+
+test_that("the Export page previews and downloads the R script", {
+  shiny::testServer(
+    NACHO:::mod_export_server,
+    args = list(object = shiny::reactiveVal(GSE74821), quarto = FALSE),
+    {
+      expect_identical(
+        output$script,
+        paste(NACHO:::reproduce_script(GSE74821), collapse = "\n")
+      )
+      expect_identical(
+        readLines(output$script_r),
+        NACHO:::reproduce_script(GSE74821)
+      )
+    }
+  )
+  html <- htmltools::renderTags(
+    NACHO:::mod_export_ui("export", quarto = FALSE)
+  )$html
+  expect_match(html, "Reproduce in R", fixed = TRUE)
+  expect_match(html, "id=\"export-script_r\"", fixed = TRUE)
+})
+
+test_that("the R script keeps the placeholder for an uploaded folder", {
+  x <- salmon_nacho
+  x@provenance[["data_directory"]] <- withr::local_tempdir()
+  script <- NACHO:::reproduce_script(x)
+  expect_true("  data_directory = \"path/to/rcc-files\"," %in% script)
+  expect_true(any(grepl("every RCC file of the folder", script, fixed = TRUE)))
+})
+
+test_that("the R script leaves an unknown instrument to load_rcc()", {
+  x <- salmon_nacho
+  x@thresholds[["instrument"]] <- NA_character_
+  script <- NACHO:::reproduce_script(x)
+  expect_true("  instrument = NULL," %in% script)
+  expect_no_error(parse(text = script))
+})
+
+test_that("the R script keeps the folder the object was loaded from", {
+  x <- salmon_nacho
+  x@provenance[["data_directory"]] <- R.home("bin")
+  script <- NACHO:::reproduce_script(x)
+  expect_true(
+    paste0("  data_directory = ", deparse(R.home("bin")), ",") %in% script
+  )
+  x@provenance[["data_directory"]] <- "/no/such/run1"
+  script <- NACHO:::reproduce_script(x)
+  expect_true("  data_directory = \"path/to/rcc-files\"," %in% script)
+})
+
+test_that("the R script names the sample sheet columns for an upload", {
+  x <- salmon_nacho
+  x@provenance[["data_directory"]] <- withr::local_tempdir()
+  comments <- grep("^#", NACHO:::reproduce_script(x), value = TRUE)
+  expect_true(any(grepl("IDFILE", comments, fixed = TRUE)))
+  expect_true(any(grepl("plexset_id", comments, fixed = TRUE)))
+})
+
+test_that("write_thresholds() names itself in its errors", {
+  error <- expect_error(
+    write_thresholds(list(FoV = "high"), withr::local_tempfile()),
+    class = "nacho_error"
+  )
+  expect_identical(deparse(error$call[[1]]), "write_thresholds")
+})

vignettes/articles/nacho-app.Rmd

@@ -195,6 +195,10 @@ The **Export** page saves your work.
 - **nacho object (RDS)** holds the object.
   Read it back in R with `read_nacho()`.
 - **Render the report** builds a quality-control report.
+- **R script** holds R code that repeats the analysis of the app, with the same normalisation and thresholds.
+  The **Reproduce in R** card shows the script before you download it.
+  For your own data, set the paths to your RCC files and sample sheet at the top of the script.
+  For the example data, the script runs as it is.
 
 For the report, enter a title and an author, both optional, and choose HTML or PDF (Typst).
 Then click **Render the report**.
@@ -208,7 +212,8 @@ If you have the `mirai` package, the app renders the report in the background.
 #|   The Export page. A card lists three download buttons for the data. A
 #|   second card holds the title and author fields, the HTML and PDF choice,
 #|   the Render the report button, and a button to download the finished
-#|   report.
+#|   report. Below them, the Reproduce in R card has an R script button and
+#|   the start of the script.
 knitr::include_graphics("figures/app-export.png")
 ```