tests/testthat/test-apply_prm.R

In fluxtools: A 'shiny' App for Reproducible QA/QC of Eddy Covariance Data

test_that("get_prm_rules shape + a few canonical entries", {
  rules <- get_prm_rules()
  expect_s3_class(rules, "tbl_df")
  expect_true(all(c("family","min","max","units") %in% names(rules)))
  expect_gt(nrow(rules), 10)
  expect_false(anyNA(rules$family))
  expect_equal(nrow(rules), length(unique(rules$family)))

  swc <- subset(rules, family == "^SWC($|_)")
  expect_equal(nrow(swc), 1)
  expect_equal(unname(swc$min), 0)      # <- unname to ignore any names attr
  expect_equal(unname(swc$max), 100)
  expect_match(swc$units, "%", fixed = TRUE)

  co2c13 <- subset(rules, family == "^CO2C13($|_)")
  expect_equal(nrow(co2c13), 1)
  expect_true(is.na(co2c13$min))
  expect_equal(unname(co2c13$max), -6)
})

test_that("summarize = FALSE returns data.frame", {
  df <- tibble::tibble(SWC_1_1_1 = c(10, 101, 50))
  d_only <- apply_prm(df, summarize = FALSE, note = FALSE)

  # It's a data.frame/tibble…
  expect_s3_class(d_only, "data.frame")

  # …and definitely NOT the list(data=..., summary=...) shape
  expect_false(all(c("data","summary") %in% names(d_only)))
})




test_that("apply_prm basic clamping + QC untouched", {
  df <- tibble::tibble(
    TIMESTAMP_START = seq.POSIXt(as.POSIXct("2024-01-01", tz = "UTC"),
                                 length.out = 6, by = "30 min"),
    SWC_1_1_1 = c(10, 101, -3, 50, NA, 0.5),  # 101, -3 -> NA
    P         = c(0, 60, 10, NA, -1, 3),      # 60, -1 -> NA
    RH_1_1_1  = c(10, 110, 50, NA, 0, 101),   # 110, 101 -> NA
    SWC_QC    = c(0,1,2,0,1,2)                # should be ignored
  )
  res <- apply_prm(df, note = FALSE)
  expect_true(is.list(res) && all(c("data","summary") %in% names(res)))

  d <- res$data
  expect_true(is.data.frame(d))
  # SWC
  expect_true(is.na(d$SWC_1_1_1[2]))
  expect_true(is.na(d$SWC_1_1_1[3]))
  expect_false(is.na(d$SWC_1_1_1[1]))
  # P
  expect_true(is.na(d$P[2]))
  expect_true(is.na(d$P[5]))
  # RH
  expect_true(is.na(d$RH_1_1_1[2]))
  expect_true(is.na(d$RH_1_1_1[6]))
  # QC untouched
  expect_identical(d$SWC_QC, df$SWC_QC)
})

test_that("include= filters families", {
  df <- tibble::tibble(
    SWC_1_1_1 = c(10, 101),
    P         = c(0, 60)
  )
  res <- apply_prm(df, include = "SWC", note = FALSE)
  d <- res$data
  # SWC clamped
  expect_true(is.na(d$SWC_1_1_1[2]))
  # P unaffected
  expect_identical(d$P, df$P)
})

test_that("NA bound semantics (only lower or only upper)", {
  # N2O lower bound 0, no upper => negatives NA, large positives OK
  # CO2C13 only UPPER = -6 => > -6 is NA, <= -6 OK
  df <- tibble::tibble(
    N2O = c(-1, 0, 1000),
    CO2C13 = c(-8, -6, -4)
  )
  res <- apply_prm(df, note = FALSE)
  d <- res$data

  # N2O
  expect_true(is.na(d$N2O[1]))
  expect_identical(d$N2O[2], 0)
  expect_identical(d$N2O[3], 1000)

  # CO2C13
  expect_identical(d$CO2C13[1], -8)  # below the max OK
  expect_identical(d$CO2C13[2], -6)  # at the max OK
  expect_true(is.na(d$CO2C13[3]))    # above the max -> NA
})

test_that("summarize = FALSE returns data.frame", {
  df <- tibble::tibble(SWC_1_1_1 = c(10, 101, 50))
  d_only <- apply_prm(df, summarize = FALSE, note = FALSE)

  # It's a data.frame/tibble…
  expect_s3_class(d_only, "data.frame")

  # …and definitely NOT the list(data=..., summary=...) shape
  expect_false(all(c("data","summary") %in% names(d_only)))
})


test_that("message includes units and PRM range", {
  df <- tibble::tibble(
    SWC_1_1_1 = c(10, 101, 50, -3),
    P         = c(0, 60, 10, -1)
  )

  # 1) Capture messages
  msgs <- testthat::capture_messages(apply_prm(df, note = TRUE))
  msg  <- paste(msgs, collapse = "\n")

  # 2) Get return value in a separate call
  out <- apply_prm(df, note = TRUE)

  expect_match(msg, "expected units: %, PRM range: 0 to 100", fixed = TRUE)
  expect_match(msg, "expected units: mm, PRM range: 0 to 50", fixed = TRUE)
  expect_s3_class(out$summary, "tbl_df")   # sanity check return shape
})

test_that("no replacements -> informative message & empty summary", {
  df <- tibble::tibble(SWC_1_1_1 = c(0, 1, 50))

  # 1) Capture messages
  msgs <- testthat::capture_messages(apply_prm(df, note = TRUE))
  msg  <- paste(msgs, collapse = "\n")

  # 2) Get the return value in a separate call
  out <- apply_prm(df, note = TRUE)

  expect_true(grepl("no replacements made", msg, fixed = TRUE))
  expect_s3_class(out$summary, "tbl_df")
  expect_equal(nrow(out$summary), 0)
})






test_that("non data.frame input errors clearly", {
  expect_error(apply_prm(1:5), "is.data.frame\\(.data\\) is not TRUE")
})


test_that("skips _QC and _SSITC_TEST columns by default", {
  df <- tibble::tibble(
    SWC_1_1_1      = c(-3, 10, 101),   # should clamp -3, 101
    SWC_QC         = c(0, 1, 2),       # should be ignored
    FC             = c(-200, 0, 50),   # should clamp -200
    FC_SSITC_TEST  = c(0, 1, 2)        # should be ignored
  )

  out <- apply_prm(df, note = FALSE)   # default skip_qc = TRUE
  expect_true(is.na(out$data$SWC_1_1_1[1]))
  expect_true(is.na(out$data$SWC_1_1_1[3]))
  expect_identical(out$data$SWC_QC, df$SWC_QC)               # unchanged
  expect_true(is.na(out$data$FC[1]))                         # clamped
  expect_identical(out$data$FC_SSITC_TEST, df$FC_SSITC_TEST) # unchanged

  # And ensure summary doesn’t include the skipped cols
  expect_false(any(out$summary$column %in% c("SWC_QC","FC_SSITC_TEST")))
})


test_that("units/desc cover all families", {
  fam <- names(.prm_rules())
  expect_true(all(fam %in% names(.prm_units())))
  expect_true(all(fam %in% names(.prm_desc())))
})