tests/testthat/test-telemetry_notices.R

In bidux: Behavioral Insight Design: A Toolkit for Integrating Behavioral Science in UI/UX Design

# ==============================================================================
# TELEMETRY NOTICE CREATION TESTS
# ==============================================================================

test_that("create_unused_input_notice generates valid notice stage", {
  # test with zero usage
  input_info_zero <- list(
    input_id = "unused_filter",
    sessions_used = 0,
    usage_rate = 0
  )

  result_zero <- bidux:::create_unused_input_notice(input_info_zero, total_sessions = 100)

  expect_s3_class(result_zero, "bid_stage")
  expect_equal(get_stage(result_zero), "Notice")
  expect_true(grepl("unused_filter", result_zero$problem[1]))
  expect_true(grepl("0 out of 100", result_zero$evidence[1]))

  # test with low usage
  input_info_low <- list(
    input_id = "filter_button",
    sessions_used = 5,
    usage_rate = 0.05
  )

  result_low <- bidux:::create_unused_input_notice(input_info_low, total_sessions = 100)

  expect_s3_class(result_low, "bid_stage")
  expect_true(grepl("5 out of 100", result_low$evidence[1]))
  expect_true(grepl("5.0%", result_low$evidence[1]))
})

test_that("create_delay_notice generates valid notice stage", {
  delay_info <- list(
    median_delay = 45.5,
    no_action_rate = 0.15,
    rate_over_threshold = 0.25
  )

  result <- bidux:::create_delay_notice(delay_info, total_sessions = 50, threshold = 30)

  expect_s3_class(result, "bid_stage")
  expect_equal(get_stage(result), "Notice")
  expect_true(grepl("long time", result$problem[1]))
  expect_true(grepl("46 seconds", result$evidence[1])) # rounded median
  expect_true(grepl("15%.*no interactions", result$evidence[1]))
  expect_true(grepl("25%.*over 30 seconds", result$evidence[1]))
})

test_that("create_delay_notice handles missing median delay", {
  delay_info <- list(
    median_delay = NA,
    no_action_rate = 0.20,
    rate_over_threshold = 0.10
  )

  result <- bidux:::create_delay_notice(delay_info, total_sessions = 30, threshold = 60)

  expect_s3_class(result, "bid_stage")
  # should not mention median delay in evidence
  expect_false(grepl("Median time", result$evidence[1]))
  expect_true(grepl("20%.*no interactions", result$evidence[1]))
})

test_that("create_error_notice generates valid notice stage", {
  error_info <- list(
    error_message = "Database connection failed unexpectedly during query execution",
    count = 23,
    session_rate = 0.35,
    output_id = "data_table",
    associated_input = "refresh_button"
  )

  result <- bidux:::create_error_notice(error_info, total_sessions = 100)

  expect_s3_class(result, "bid_stage")
  expect_equal(get_stage(result), "Notice")
  expect_true(grepl("error", result$problem[1], ignore.case = TRUE))
  expect_true(grepl("23 times", result$evidence[1]))
  expect_true(grepl("35%", result$evidence[1]))
  expect_true(grepl("data_table", result$evidence[1]))
  expect_true(grepl("refresh_button", result$evidence[1]))
})

test_that("create_error_notice handles NULL optional fields", {
  error_info <- list(
    error_message = NULL,
    count = 10,
    session_rate = 0.10,
    output_id = NULL,
    associated_input = NULL
  )

  result <- bidux:::create_error_notice(error_info, total_sessions = 100)

  expect_s3_class(result, "bid_stage")
  expect_true(grepl("Unknown error", result$evidence[1]))
  # should not mention output_id or associated_input
  expect_false(grepl("in output", result$evidence[1]))
  expect_false(grepl("after changing", result$evidence[1]))
})

test_that("create_navigation_notice generates valid notice stage", {
  nav_info <- list(
    page = "Advanced Settings",
    unique_sessions = 12,
    visit_rate = 0.08,
    exit_rate = 0.65
  )

  result <- bidux:::create_navigation_notice(nav_info, total_sessions = 150)

  expect_s3_class(result, "bid_stage")
  expect_equal(get_stage(result), "Notice")
  expect_true(grepl("Advanced Settings", result$problem[1]))
  expect_true(grepl("12 sessions", result$evidence[1]))
  expect_true(grepl("8.0%", result$evidence[1]))
  expect_true(grepl("65%.*ended there", result$evidence[1]))
})

test_that("create_navigation_notice handles low exit rate", {
  nav_info <- list(
    page = "Dashboard",
    unique_sessions = 25,
    visit_rate = 0.15,
    exit_rate = 0.20 # below 0.5 threshold
  )

  result <- bidux:::create_navigation_notice(nav_info, total_sessions = 200)

  expect_s3_class(result, "bid_stage")
  # should not mention exit rate if below 50%
  expect_false(grepl("ended there", result$evidence[1]))
})

test_that("create_confusion_notice generates valid notice stage", {
  confusion_info <- list(
    input_id = "date_range_picker",
    affected_sessions = 18,
    total_rapid_changes = 90,
    avg_time_window = 12.5
  )

  result <- bidux:::create_confusion_notice(confusion_info, total_sessions = 100)

  expect_s3_class(result, "bid_stage")
  expect_equal(get_stage(result), "Notice")
  expect_true(grepl("confusion", result$problem[1], ignore.case = TRUE))
  expect_true(grepl("date_range_picker", result$problem[1]))
  expect_true(grepl("18 sessions", result$evidence[1]))
  expect_true(grepl("5 changes", result$evidence[1])) # 90/18 = 5
  expect_true(grepl("12.5 seconds", result$evidence[1]))
})

# ==============================================================================
# BID_ISSUES CLASS HELPER FUNCTION TESTS
# ==============================================================================

test_that(".create_issues_tibble handles empty issues list", {
  result <- bidux:::.create_issues_tibble(list(), total_sessions = 50, events = data.frame())

  expect_true(tibble::is_tibble(result))
  expect_equal(nrow(result), 0)
  expect_true(all(c("issue_id", "severity", "problem", "evidence") %in% names(result)))
})

test_that(".create_issues_tibble processes valid notice issues", {
  # create mock notice issues
  notice1 <- bid_notice(
    previous_stage = bid_interpret(central_question = "Test?"),
    problem = "Users struggle with navigation",
    evidence = "50% abandon the page"
  )

  notice2 <- bid_notice(
    previous_stage = bid_interpret(central_question = "Test?"),
    problem = "Error rates are high",
    evidence = "30% encounter errors"
  )

  notice_issues <- list(
    "unused_input_test" = notice1,
    "error_pattern_critical" = notice2
  )

  events_df <- data.frame(
    session_id = c("s1", "s2", "s3"),
    event_type = c("input", "error", "input"),
    input_id = c("btn", NA, "btn"),
    stringsAsFactors = FALSE
  )

  result <- bidux:::.create_issues_tibble(notice_issues, total_sessions = 100, events = events_df)

  expect_true(tibble::is_tibble(result))
  expect_equal(nrow(result), 2)
  expect_true("unused_input_test" %in% result$issue_id)
  expect_true("error_pattern_critical" %in% result$issue_id)
  expect_true(all(c("severity", "affected_sessions", "impact_rate") %in% names(result)))
})

test_that(".classify_issue_type identifies issue types correctly", {
  expect_equal(bidux:::.classify_issue_type("unused_input_filter"), "unused_input")
  expect_equal(bidux:::.classify_issue_type("delayed_interaction_01"), "delayed_interaction")
  expect_equal(bidux:::.classify_issue_type("error_pattern_critical"), "error_pattern")
  expect_equal(bidux:::.classify_issue_type("navigation_dropoff_page2"), "navigation_dropoff")
  expect_equal(bidux:::.classify_issue_type("confusion_pattern_slider"), "confusion_pattern")
  expect_equal(bidux:::.classify_issue_type("unknown_issue_type"), "unknown")
})

test_that(".calculate_severity_metrics handles unused input issues", {
  events_df <- data.frame(
    session_id = c("s1", "s2", "s3", "s4", "s5"),
    event_type = c("input", "input", "click", "click", "click"),
    input_id = c("filter_x", "filter_x", NA, NA, NA),
    stringsAsFactors = FALSE
  )

  # create mock notice with proper problem format
  notice <- tibble::tibble(
    stage = "Notice",
    problem = "Users are not interacting with the 'filter_x' input control",
    evidence = "Test evidence"
  )

  # only 2 of 5 sessions used "filter_x", so 3 sessions didn't use it
  result <- bidux:::.calculate_severity_metrics("unused_input_filter_x", notice, events_df, total_sessions = 5)

  expect_equal(result$severity, "critical") # 60% impact >= 30% = critical
  expect_equal(result$affected_sessions, 3L)
  expect_equal(result$impact_rate, 0.6, tolerance = 0.01)
})

test_that(".calculate_severity_metrics preserves underscores in input_id", {
  # regression test for lossy conversion bug fix
  events_df <- data.frame(
    session_id = c("s1", "s2", "s3"),
    event_type = c("input", "input", "click"),
    input_id = c("multi_word_filter", "multi_word_filter", NA),
    stringsAsFactors = FALSE
  )

  notice <- tibble::tibble(
    stage = "Notice",
    problem = "Users are not interacting with the 'multi_word_filter' input control",
    evidence = "Test evidence"
  )

  # 2 sessions used it, 1 didn't
  result <- bidux:::.calculate_severity_metrics("unused_input_multi_word_filter", notice, events_df, total_sessions = 3)

  # verify underscores were preserved (not converted to spaces)
  expect_equal(result$affected_sessions, 1L)
  expect_equal(result$impact_rate, 1 / 3, tolerance = 0.01)
})

test_that(".calculate_severity_metrics handles error patterns", {
  events_df <- data.frame(
    session_id = c("s1", "s1", "s2", "s2", "s3"),
    event_type = c("click", "error", "click", "error", "click"),
    stringsAsFactors = FALSE
  )

  # create mock notice (not used for error patterns, but required parameter)
  notice <- tibble::tibble(stage = "Notice", problem = "Test error", evidence = "Test")

  result <- bidux:::.calculate_severity_metrics("error_pattern_1", notice, events_df, total_sessions = 3)

  expect_equal(result$severity, "critical") # 2/3 = 66% >= 30% threshold = critical
  expect_equal(result$affected_sessions, 2L)
  expect_gt(result$impact_rate, 0.5)
})

test_that(".calculate_severity_metrics returns correct severity levels", {
  events_df <- data.frame(session_id = character(0), event_type = character(0))

  # create mock notice (not used for delay/navigation patterns, but required parameter)
  notice <- tibble::tibble(stage = "Notice", problem = "Test", evidence = "Test")

  # test critical (>= 30%)
  result_critical <- bidux:::.calculate_severity_metrics("delayed_01", notice, events_df, total_sessions = 100)
  expect_equal(result_critical$severity, "critical")
  expect_equal(result_critical$impact_rate, 0.3)

  # test high (20% = high since >= 10%)
  result_high <- bidux:::.calculate_severity_metrics("navigation_page1", notice, events_df, total_sessions = 100)
  expect_equal(result_high$severity, "high") # 20% >= 10% threshold = high
  expect_equal(result_high$impact_rate, 0.2)
})

test_that(".calculate_severity_metrics handles invalid input_id safely", {
  events_df <- data.frame(
    session_id = c("s1", "s2"),
    event_type = c("input", "input"),
    input_id = c("valid", "valid")
  )

  # create notice with missing/invalid problem format
  notice_bad <- tibble::tibble(
    stage = "Notice",
    problem = "Malformed problem text without quotes",
    evidence = "Test"
  )

  # test with notice that doesn't have extractable input_id
  result <- bidux:::.calculate_severity_metrics("unused_input_", notice_bad, events_df, total_sessions = 10)

  # should fallback to conservative estimate
  expect_equal(result$affected_sessions, 1L) # 10% of 10
  expect_equal(result$impact_rate, 0.1)
})

test_that(".flags_from_issues creates correct flag structure", {
  issues_tbl <- tibble::tibble(
    issue_id = c("unused_input_x", "error_pattern_1", "navigation_page2"),
    issue_type = c("unused_input", "error_pattern", "navigation_dropoff"),
    severity = c("critical", "high", "medium")
  )

  events_df <- data.frame(
    session_id = c("s1", "s2", "s3"),
    event_type = c("input", "error", "navigation")
  )

  thresholds <- list(
    unused_input_threshold = 0.05,
    delay_threshold_seconds = 30,
    error_rate_threshold = 0.1
  )

  result <- bidux:::.flags_from_issues(issues_tbl, events_df, thresholds)

  expect_true(is.list(result))
  expect_true(result$has_issues)
  expect_true(result$has_critical_issues)
  expect_true(result$has_input_issues)
  expect_true(result$has_navigation_issues)
  expect_true(result$has_error_patterns)
  expect_false(result$has_confusion_patterns)
  expect_equal(result$session_count, 3)
  expect_equal(result$unused_input_threshold, 0.05)
})

test_that(".flags_from_issues handles empty issues", {
  empty_issues <- tibble::tibble(
    issue_id = character(0),
    issue_type = character(0),
    severity = character(0)
  )

  events_df <- data.frame(session_id = c("s1"))

  thresholds <- list(
    unused_input_threshold = 0.05,
    delay_threshold_seconds = 30,
    error_rate_threshold = 0.1
  )

  result <- bidux:::.flags_from_issues(empty_issues, events_df, thresholds)

  expect_false(result$has_issues)
  expect_false(result$has_critical_issues)
  expect_false(result$has_input_issues)
  expect_equal(result$session_count, 1)
})

# ==============================================================================
# BID_ISSUES S3 METHOD TESTS (additional edge cases)
# ==============================================================================

test_that("print.bid_issues handles empty issues gracefully", {
  # create mock empty bid_issues object
  empty_issues <- list()
  attr(empty_issues, "issues_tbl") <- tibble::tibble(
    issue_id = character(0),
    severity = character(0),
    problem = character(0),
    evidence = character(0)
  )
  attr(empty_issues, "flags") <- list(
    has_issues = FALSE,
    session_count = 10
  )
  attr(empty_issues, "created_at") <- Sys.time()
  class(empty_issues) <- c("bid_issues", "list")

  # main test: print method should not error
  expect_no_error(print(empty_issues))
})

test_that("as_tibble.bid_issues validates object structure", {
  # create invalid bid_issues object (missing issues_tbl)
  invalid_obj <- list()
  class(invalid_obj) <- c("bid_issues", "list")

  expect_error(
    as_tibble(invalid_obj),
    "missing issues_tbl attribute"
  )
})

test_that("bid_flags.bid_issues validates object structure", {
  # create invalid bid_issues object (missing flags)
  invalid_obj <- list()
  attr(invalid_obj, "issues_tbl") <- tibble::tibble()
  class(invalid_obj) <- c("bid_issues", "list")

  expect_error(
    bid_flags(invalid_obj),
    "missing flags attribute"
  )
})

test_that("bid_flags.default extracts flags from list element", {
  # object with flags as list element
  obj_with_flags <- list(
    flags = list(
      has_issues = TRUE,
      session_count = 5
    )
  )

  result <- bid_flags(obj_with_flags)

  expect_true(is.list(result))
  expect_equal(result$has_issues, TRUE)
  expect_equal(result$session_count, 5)
})

# ==============================================================================
# CONCISE TELEMETRY API TESTS (additional coverage)
# ==============================================================================

test_that("bid_notice_issue validates input structure", {
  # test with multiple rows (should error)
  multi_row_issue <- tibble::tibble(
    issue_id = c("issue1", "issue2"),
    problem = c("Problem 1", "Problem 2")
  )

  interpret <- bid_interpret(central_question = "Test?")

  expect_error(
    bid_notice_issue(multi_row_issue, previous_stage = interpret),
    "exactly one row"
  )
})

test_that("bid_notice_issue validates override parameter", {
  issue <- tibble::tibble(
    issue_id = "test",
    problem = "Test problem"
  )

  interpret <- bid_interpret(central_question = "Test?")

  # test with invalid override (not a list)
  expect_error(
    bid_notice_issue(issue, previous_stage = interpret, override = "not a list"),
    "override must be a list"
  )
})

test_that("bid_notice_issue creates default interpret stage if missing", {
  issue <- tibble::tibble(
    issue_id = "test",
    problem = "Test problem",
    severity = "medium"
  )

  # call without previous_stage - should create default internally
  result <- bid_notice_issue(issue, previous_stage = NULL)

  expect_s3_class(result, "bid_stage")
  expect_equal(get_stage(result), "Notice")
  # should have problem and evidence populated
  expect_true(nchar(result$problem[1]) > 0)
  expect_true(nchar(result$evidence[1]) > 0)
})

test_that("bid_notice_issue builds evidence from telemetry data", {
  issue <- tibble::tibble(
    issue_id = "test_id",
    problem = "Test problem",
    severity = "high",
    affected_sessions = 42L,
    impact_rate = 0.35
  )

  interpret <- bid_interpret(central_question = "Test?")

  result <- bid_notice_issue(issue, previous_stage = interpret)

  # check that telemetry data was incorporated into evidence
  expect_true(grepl("42", result$evidence[1]))
  expect_true(grepl("35", result$evidence[1])) # 35% impact rate
  expect_true(grepl("high", result$evidence[1]))
})

test_that("bid_notice_issue adds telemetry metadata to result", {
  issue <- tibble::tibble(
    issue_id = "nav_issue_01",
    issue_type = "navigation_dropoff",
    problem = "Navigation problem"
  )

  interpret <- bid_interpret(central_question = "Test?")

  result <- bid_notice_issue(issue, previous_stage = interpret)

  # check for telemetry metadata
  metadata <- attr(result, "metadata")
  expect_true("telemetry_issue_type" %in% names(metadata))
  expect_equal(metadata$telemetry_issue_type, "navigation_dropoff")
  expect_equal(metadata$telemetry_issue_id, "nav_issue_01")
})

test_that("bid_notices validates input data frame", {
  # test with non-data.frame input
  expect_error(
    bid_notices(issues = "not a data frame"),
    "must be a data frame"
  )
})

test_that("bid_notices limits results based on max_issues", {
  issues <- tibble::tibble(
    issue_id = paste0("issue_", 1:10),
    severity = rep(c("critical", "high"), 5),
    impact_rate = seq(0.5, 0.05, length.out = 10),
    problem = paste("Problem", 1:10)
  )

  interpret <- bid_interpret(central_question = "Test?")

  # capture the inform message
  expect_message(
    result <- bid_notices(issues, previous_stage = interpret, max_issues = 3),
    "Limiting to top 3"
  )

  expect_equal(length(result), 3)
})

test_that("bid_notices sorts by severity and impact_rate", {
  issues <- tibble::tibble(
    issue_id = c("low_impact", "high_impact", "critical_impact"),
    severity = c("low", "high", "critical"),
    impact_rate = c(0.02, 0.15, 0.35),
    problem = c("Low problem", "High problem", "Critical problem")
  )

  interpret <- bid_interpret(central_question = "Test?")

  result <- bid_notices(issues, previous_stage = interpret)

  # should be sorted by severity (critical first), then impact
  expect_true(grepl("Critical", result[[1]]$problem))
  expect_true(grepl("High", result[[2]]$problem))
  expect_true(grepl("Low", result[[3]]$problem))
})

test_that("bid_pipeline validates input and sorts by priority", {
  # test validation
  expect_error(
    bid_pipeline(issues = "not a data frame", previous_stage = NULL),
    "must be a data frame"
  )

  # test sorting behavior
  issues <- tibble::tibble(
    issue_id = paste0("i", 1:5),
    severity = c("low", "critical", "high", "medium", "high"),
    impact_rate = c(0.02, 0.40, 0.20, 0.08, 0.25),
    problem = paste("Problem", letters[1:5])
  )

  interpret <- bid_interpret(central_question = "Pipeline?")

  result <- bid_pipeline(issues, interpret, max = 3)

  # should prioritize: critical (b), then high by impact (e > c), etc
  expect_true(grepl("b", result[[1]]$problem)) # critical
  expect_true(grepl("e", result[[2]]$problem)) # high, 0.25 impact
  expect_true(grepl("c", result[[3]]$problem)) # high, 0.20 impact
})

test_that("bid_pipeline handles issues without impact_rate", {
  issues <- tibble::tibble(
    issue_id = c("i1", "i2"),
    severity = c("high", "low"),
    problem = c("High severity", "Low severity")
    # no impact_rate column
  )

  interpret <- bid_interpret(central_question = "Test?")

  # should still work, sorting only by severity
  expect_no_error(
    result <- bid_pipeline(issues, interpret, max = 2)
  )

  expect_equal(length(result), 2)
  expect_true(grepl("High", result[[1]]$problem))
})