box::use( testthat[ expect_equal, expect_false, expect_null, expect_true, skip_if_not_installed, test_that ] ) box::use( artma / data / external_mapping[ build_mapping_request, external_mapper_command, external_mapping_proposals, parse_mapper_response, verify_external_proposal ], artma / data / interactive_mapping[interactive_column_mapping] ) # The opt-in external mapping hook. With no command configured none of this # runs; with one configured, nothing it proposes is trusted before it passes # the same checks an auto-detected candidate faces. #' A dataset whose effect column carries no name signal, next to the #' identifier-flavored decoys a proposal must not be allowed to pick. make_hook_df <- function(n_studies = 20, k = 5) { study <- rep(seq_len(n_studies), each = k) n <- length(study) effect <- round(stats::rnorm(n, 0.2, 0.5), 3) data.frame( study = rep(sprintf("Author%02d", seq_len(n_studies)), each = k), idcoeff = rep(seq_len(k), times = n_studies), eis = effect, se = pmax(round(exp(stats::rnorm(n, log(0.15), 0.5)), 3), 0.001), nobs = rep(sample(80:2000, n_studies, replace = TRUE), each = k) ) } #' The mapping recognition arrives at on that dataset: everything but effect. hook_mapping <- function() { list(se = "se", study_id = "study", n_obs = "nobs") } #' Write an Rscript stub that reads the payload on stdin and behaves as `body` #' says. Returns the command vector to configure the hook with. write_stub <- function(dir, name, body) { path <- file.path(dir, name) writeLines(c('input <- paste(readLines(file("stdin"), warn = FALSE), collapse = "")', body), path) c(file.path(R.home("bin"), "Rscript"), "--vanilla", path) } #' Run the hook against a stub command and return the roles it accepted. propose_with <- function(df, command) { external_mapping_proposals( df = df, mapping = hook_mapping(), roles = "effect", declined = list(effect = list(role = "effect", reason = "no candidate cleared the bar", candidates = list())), command = command, timeout = 60 ) } test_that("nothing runs when no external command is configured", { withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) df <- make_hook_df() expect_null(external_mapper_command(NULL)) expect_null(external_mapper_command(NA_character_)) expect_null(external_mapper_command(" ")) proposals <- external_mapping_proposals( df = df, mapping = hook_mapping(), roles = "effect", command = external_mapper_command(NULL), run_fn = function(...) stop("the hook must not run a command when it is off") ) expect_equal(proposals, list()) # And the mapping flow is untouched: the declined role stays unmapped. result <- interactive_column_mapping( df = df, auto_mapping = hook_mapping(), is_interactive = FALSE ) expect_false("effect" %in% names(result)) }) test_that("a command line is split into an executable and its arguments", { expect_equal(external_mapper_command("Rscript --vanilla mapper.R"), c("Rscript", "--vanilla", "mapper.R")) expect_equal(external_mapper_command('"/opt/my tools/Rscript" mapper.R'), c("/opt/my tools/Rscript", "mapper.R")) # Already split by the caller: taken as is. expect_equal(external_mapper_command(c("Rscript", "mapper.R")), c("Rscript", "mapper.R")) # And it is the option that turns the hook on. withr::local_options(list("artma.data.mapping.external_command" = "Rscript mapper.R")) expect_equal(external_mapper_command(), c("Rscript", "mapper.R")) }) test_that("a verified proposal is accepted", { skip_if_not_installed("jsonlite") withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) dir <- withr::local_tempdir() df <- make_hook_df() command <- write_stub(dir, "good.R", 'cat(\'{"schema":"artma.column_mapping_response/1","mappings":{"effect":"eis"}}\')') proposals <- propose_with(df, command) expect_equal(names(proposals), "effect") expect_equal(proposals$effect$column, "eis") expect_equal(proposals$effect$source, "external") # It read the payload rather than ignoring stdin. expect_true(proposals$effect$evidence > 0.5) }) test_that("an implausible proposal is rejected", { skip_if_not_installed("jsonlite") withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) dir <- withr::local_tempdir() df <- make_hook_df() # idcoeff is a per-study counter: whole numbers, no measured values in it. command <- write_stub(dir, "bad.R", 'cat(\'{"mappings":{"effect":"idcoeff"}}\')') expect_equal(propose_with(df, command), list()) }) test_that("malformed output falls back to the decline", { skip_if_not_installed("jsonlite") withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) dir <- withr::local_tempdir() df <- make_hook_df() command <- write_stub(dir, "malformed.R", 'cat("effect -> eis, probably")') expect_equal(propose_with(df, command), list()) }) test_that("a nonzero exit falls back to the decline", { skip_if_not_installed("jsonlite") withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) dir <- withr::local_tempdir() df <- make_hook_df() command <- write_stub(dir, "fails.R", c('cat("no api key\\n", file = stderr())', "quit(status = 3)")) expect_equal(propose_with(df, command), list()) }) test_that("a timeout falls back to the decline", { skip_if_not_installed("jsonlite") withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) dir <- withr::local_tempdir() df <- make_hook_df() command <- write_stub(dir, "slow.R", c("Sys.sleep(30)", 'cat(\'{"mappings":{"effect":"eis"}}\')')) proposals <- external_mapping_proposals( df = df, mapping = hook_mapping(), roles = "effect", command = command, timeout = 1 ) expect_equal(proposals, list()) }) test_that("the payload carries column names and summaries, never raw values", { skip_if_not_installed("jsonlite") withr::local_seed(11) df <- make_hook_df() request <- build_mapping_request( df = df, mapping = hook_mapping(), declined = list(effect = list(role = "effect", reason = "no candidate cleared the bar")), roles = "effect" ) expect_equal(request$schema, "artma.column_mapping_request/1") expect_equal(request$requested_roles, "effect") expect_equal(request$dataset$n_rows, nrow(df)) expect_equal(vapply(request$columns, function(col) col$name, character(1)), names(df)) expect_equal(names(request$declined), "effect") eis <- Filter(function(col) identical(col$name, "eis"), request$columns)[[1]] expect_equal(eis$n, nrow(df)) expect_equal(eis$coverage, 1) expect_true(eis$numeric) expect_equal(eis$quantiles$median, stats::median(df$eis)) # No column of the payload holds the values themselves: a summary is at most # a handful of numbers, never a row per observation. json <- as.character(jsonlite::toJSON(request, auto_unbox = TRUE, na = "null")) for (value in as.character(df$study)) { expect_false(grepl(sprintf('"%s"', value), json, fixed = TRUE)) } }) test_that("proposals are verified against the data, not taken on trust", { withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) df <- make_hook_df() mapping <- hook_mapping() expect_true(verify_external_proposal(df, "effect", "eis", mapping)$ok) unknown <- verify_external_proposal(df, "effect", "not_a_column", mapping) expect_false(unknown$ok) expect_true(grepl("no column named", unknown$reason)) counter <- verify_external_proposal(df, "effect", "idcoeff", mapping) expect_false(counter$ok) expect_true(grepl("value plausibility", counter$reason)) taken <- verify_external_proposal(df, "effect", "se", mapping) expect_false(taken$ok) expect_true(grepl("already mapped", taken$reason)) # A column of plausible measurements that does not pair with the mapped se. df$noise <- round(stats::rnorm(nrow(df), 0, 1e6), 3) pair <- verify_external_proposal(df, "effect", "noise", mapping) expect_false(pair$ok) expect_true(grepl("pair consistency", pair$reason)) }) test_that("both documented response shapes are read", { skip_if_not_installed("jsonlite") withr::local_options(list("artma.verbose" = 1)) expect_equal( parse_mapper_response('{"mappings":{"effect":"eis"}}'), c(effect = "eis") ) expect_equal( parse_mapper_response('{"effect":"eis","n_obs":"nobs"}'), c(effect = "eis", n_obs = "nobs") ) expect_equal( parse_mapper_response('{"mappings":{"effect":{"column":"eis","confidence":0.8}}}'), c(effect = "eis") ) expect_null(parse_mapper_response("not json at all")) expect_null(parse_mapper_response('{"mappings":{}}')) }) test_that("a verified proposal is applied non-interactively and confirmed interactively", { withr::local_seed(11) withr::local_options(list("artma.verbose" = 1)) df <- make_hook_df() stub <- function(...) '{"mappings":{"effect":"eis"}}' hook <- function(df, mapping, roles, declined) { external_mapping_proposals( df = df, mapping = mapping, roles = roles, declined = declined, command = c("mapper"), run_fn = stub ) } # Non-interactive: configuring the command is the consent. applied <- interactive_column_mapping( df = df, auto_mapping = hook_mapping(), is_interactive = FALSE, external_fn = hook ) expect_equal(applied$effect, "eis") # Interactive: the same proposal becomes one confirmation question. asked <- list() confirmed <- interactive_column_mapping( df = df, auto_mapping = hook_mapping(), is_interactive = TRUE, external_fn = hook, select_fn = function(choices, prompt) { asked[[length(asked) + 1]] <<- prompt choices[1] } ) expect_equal(confirmed$effect, "eis") expect_true(any(grepl("effect", unlist(asked), fixed = TRUE))) })