Skip to contents

Compliant Pairs Table

compliant-pairs.Rmd

The risk tables are created the functions in the seg-shiny-1-3-3 repo. Through the multiple iterations of this application, different values have been used to establish these categories.

Objective

This vignette covers the development of the compliant pairs table, and performs unit tests on the output to ensure it matches the table in the application.

Load test data

The segtools package uses testthat, a common testing framework for performing unit tests. I’ll load a test data file used in the GitHub repo (VanderbiltComplete.csv) below and run it in the shiny app to generate the tables for comparison.

github_data_root <-
  "https://raw.githubusercontent.com/mjfrigaard/seg-shiny-data/master/Data/"
full_sample_repo <- base::paste0(github_data_root,
  "VanderbiltComplete.csv")
test_vand_comp_data <-
  vroom::vroom(file = full_sample_repo, delim = ",")
glimpse(test_vand_comp_data)
#> Rows: 9,891
#> Columns: 2
#> $ BGM <dbl> 121, 212, 161, 191, 189, 104, 293, 130, 261, 147, 83, 132, 146, 24…
#> $ REF <dbl> 127, 223, 166, 205, 210, 100, 296, 142, 231, 148, 81, 131, 155, 25…

Application (version 1.3.3) functions

The previous application functions are stored in the helpers.R file in the GitHub repo.

SEG Risk Variables

Create the risk_vars_tbl from seg_risk_vars():

risk_vars_tbl <- seg_risk_vars(df = test_vand_comp_data)
dplyr::glimpse(risk_vars_tbl)
#> Rows: 9,868
#> Columns: 19
#> $ BGM            <dbl> 121, 212, 161, 191, 189, 104, 293, 130, 261, 147, 83, 1…
#> $ REF            <dbl> 127, 223, 166, 205, 210, 100, 296, 142, 231, 148, 81, 1…
#> $ bgm_pair_cat   <chr> "BGM < REF", "BGM < REF", "BGM < REF", "BGM < REF", "BG…
#> $ ref_pair_2cat  <chr> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA,…
#> $ included       <chr> "Total included in SEG Analysis", "Total included in SE…
#> $ RiskPairID     <dbl> 72849, 127636, 96928, 114997, 113800, 62605, 176390, 78…
#> $ RiskFactor     <dbl> 0.0025445, 0.0279900, 0.0000000, 0.2061100, 0.2086500, …
#> $ abs_risk       <dbl> 0.0025445, 0.0279900, 0.0000000, 0.2061100, 0.2086500, …
#> $ risk_cat       <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
#> $ ABSLB          <dbl> -0.001, -0.001, -0.001, -0.001, -0.001, -0.001, -0.001,…
#> $ ABSUB          <dbl> 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, …
#> $ risk_cat_txt   <chr> "None", "None", "None", "None", "None", "None", "None",…
#> $ rel_diff       <dbl> -0.047244094, -0.049327354, -0.030120482, -0.068292683,…
#> $ abs_rel_diff   <dbl> 0.047244094, 0.049327354, 0.030120482, 0.068292683, 0.1…
#> $ sq_rel_diff    <dbl> 2.232004e-03, 2.433188e-03, 9.072434e-04, 4.663891e-03,…
#> $ iso_diff       <dbl> 4.7244094, 4.9327354, 3.0120482, 6.8292683, 10.0000000,…
#> $ iso_range      <chr> "<= 5% or 5 mg/dL", "<= 5% or 5 mg/dL", "<= 5% or 5 mg/…
#> $ risk_grade     <chr> "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", …
#> $ risk_grade_txt <chr> "0 - 0.5", "0 - 0.5", "0 - 0.5", "0 - 0.5", "0 - 0.5", …

Compliant Pairs Table

The binomialTable() function creates the compliant pairs table in the helpers.R file of the previous application (using the output from segTable()).


seg_binom_tbl()

I’ve re-written binomialTable() below as seg_binom_tbl()

seg_binom_tbl <- function(risk_vars) {
  
  compliant_pairs <- tibble(`Compliant Pairs` = 
        base::nrow(risk_vars) - base::nrow(dplyr::filter(risk_vars, iso_diff > 15)))

  # calculate the percent
  compliant_pairs_perc <-
    dplyr::mutate(compliant_pairs,
      `Compliant Pairs %` =
        base::paste0(base::round(
          100 * `Compliant Pairs` / nrow(risk_vars),
          1
        ), "%")
    )
  # create probability
  prb <- 0.95
  p_value <- 0.05
  df_size <- nrow(risk_vars)
  qbinom_vector <- qbinom(
    p = p_value,
    size = df_size,
    prob = prb
  )
    qbinom_tbl <- tibble(`Lower Bound for Acceptance` = qbinom_vector)
    # clean up this variable in the tibble for display
  # qbinom_tbl
    qbinom_tbl <- dplyr::mutate(qbinom_tbl,
      `Lower Bound for Acceptance %` =
        base::paste0(base::round(
          100 * `Lower Bound for Acceptance` / nrow(risk_vars),
          1
        ), "%")
    )

  binom_test_tbl <- dplyr::bind_cols(compliant_pairs_perc, qbinom_tbl)

  binom_table <- dplyr::mutate(binom_test_tbl,
    Result =
      dplyr::if_else(condition = `Compliant Pairs` < `Lower Bound for Acceptance`,
        true = paste0(
          binom_test_tbl$`Compliant Pairs %`[1],
          " < ",
          binom_test_tbl$`Lower Bound for Acceptance %`[1],
          " - Does not meet BGM Surveillance Study Accuracy Standard"
        ),
        false = paste0(
          binom_test_tbl$`Compliant Pairs %`[1],
          " > ",
          binom_test_tbl$`Lower Bound for Acceptance %`[1],
          " - Meets BGM Surveillance Study Accuracy Standard"
        )
      )
  )
  return(binom_table)
}


Below I check seg_binom_tbl() with the output from seg_risk_vars()

seg_binom_tbl(risk_vars = risk_vars_tbl)
Compliant Pairs Compliant Pairs % Lower Bound for Acceptance Lower Bound for Acceptance % Result
9220 93.4% 9339 94.6% 93.4% < 94.6% - Does not meet BGM Surveillance Study Accuracy Standard

Application BinomialTest table

Below is the binomial test table (aka the compliant pairs table) in the application.

I’ve re-created this table as app_binomial_tbl below:

app_binomial_tbl <- tibble::as_tibble(data.frame(
  stringsAsFactors = FALSE,
  check.names = FALSE,
  `Compliant Pairs` = c(9220L),
  `Compliant Pairs %` = c("93.4%"),
  `Lower Bound for Acceptance` = c(9339L),
  `Lower Bound for Acceptance %` = c("94.6%"),
  Result = c("93.4% < 94.6% - Does not meet BGM Surveillance Study Accuracy Standard")
))
app_binomial_tbl
Compliant Pairs Compliant Pairs % Lower Bound for Acceptance Lower Bound for Acceptance % Result
9220 93.4% 9339 94.6% 93.4% < 94.6% - Does not meet BGM Surveillance Study Accuracy Standard

Test

We’ll do a final test of the binomial test table.

testthat::test_that("Test compliant pairs table", {
testthat::expect_equal(
  # function table
  object = seg_binom_tbl(risk_vars = risk_vars_tbl),
  # application table
  expected = app_binomial_tbl
  )
})
#> Test passed 🎉