What is the readmission risk pool?

In its simplest form, I define it as all patients currently at risk for readmission.

Typically, we think of 30 days as the important time window for readmissions (although that’s arbitrary). But if we’re working in that context, then anyone who is currently (meaning as of now) at risk for a 30-day readmission is part of the risk. Some specific examples:

• A patient was discharged 29 days ago and not yet readmitted, then they are in the risk pool (for 1 more day)
• A patient was discharged yesterday, then they are in the risk for 29 more days
• A patient was discharged 14 days ago, but were readmitted 7 days ago. They are no longer in the risk pool, since they were already readmitted as of now (at least for that initial discharge)

It all has to do with which patients have a theoretically non-zero probability of still being readmitted, as of right now.

Why is it important?

This is a very important concept to think about because it has all sorts of implications, particularly when trying to monitor/report data, and even more, trying to facilitate actual care teams with data to intervene and prevent subsequent readmissions.

The key word is action. The patients in the risk pool are those that we are still able to (even theoretically, if not practically) still intervene on to prevent the future event of another hospital admission.

It also matters for doing things like predictive analytics. When we’re trying to marry models we’ve built into systems and clinical workflows, we need to define which patients should receive risk scores from our models at which particular times. We may be able to “plug in” data to our models, but if its not in the right context, the output may be junk. This also includes the retrospective datasets we build to actually train such models: even if we’re extracting data to build a training dataset, we need it to reflect the nature of the thing we are going to try to predict in the future, so this concept currently at risk for readmission needs to be applied from the lens of the data timepoints we are extracting as well.

That’s not to say the definition above is concrete and universal. There are many conceivable nuances that may make your definition of these things vary depending on the context:

• We may be interested in something other than 30 day readmissions (e.g., 60 or 90), or want to be agnostic to the specific time frame, generalizing what a readmission is. This will make our risk pool definition differ.

• The thing we are seeking to measure may impact it. For example, we said above that a patient who has already been readmitted is no longer in the risk pool. But readmitted where? What if they were readmitted to an outside hospital, but we didn’t know that? According to our information, they haven’t been readmitted, but in reality they have been (and if it’s a Medicare patient in the Hospital Readmissions Reduction Program (HRRP), they will be counted). How should we handle this? How should we model this? Do we want to explicitly account for outside readmission risk in our models, metrics, analytics? Or are we going to define readmissions only in terms of what we measure with our systems?

• What are the pragmatic considerations we must have? If we’re building a readmission prevention system with predictive models being apart of it, we need to consider the whole solution as part of the project. This means understanding workflow logistics, resource constraints, data capture and systems issues, etc. and mapping these things out upfront, and designing the predictive modeling piece around those. It’s only a small piece of the puzzle. We can theoretically design a model that creates predictions at arbitrary timepoints, but maybe what works optimally would be a model that creates predictions at a single, fixed time point on a daily basis and gets delivered as an Excel spreadsheet into the inbox of a care team, because, for example, that would better accommodate more structure and predictability to have defined roles for what will be done with the information. How we end actually designing a model (and defining the risk pool) may differ in these scenarios.

All of these things depend on the context of the problem we’re trying to solve, the trade-offs involved in our interventions, and how things are going to be monitored and reported. Ultimately we want to create a well-oiled machine where the lineage from high level readmission rates down to individual patient intervention is clear, and how we conceptualize the readmission risk pool is certainly part of that.

The Toolbox

First, we’ll start by taking a look at what relevant functions are available to us, what they do, and how to use them. For our purposes, these are all of the functions prefixed like hsr_*. We’ll do this roughly in order of how the report is laid out, and how the HRRP results roll up.

library(readmit)

hsr_mock_reports()

[1] "FY2019_HRRP_MockHSR.xlsx" "FY2020_HRRP_MockHSR.xlsx"
[3] "FY2021_HRRP_MockHSR.xlsx" "FY2022_HRRP_MockHSR.xlsx"
[5] "FY2023_HRRP_MockHSR.xlsx" "FY2024_HRRP_MockHSR.xlsx"
[7] "FY2025_HRRP_MockHSR.xlsx"

my_report <- hsr_mock_reports("FY2025_HRRP_MockHSR.xlsx")
my_report

[1] "/Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/library/readmit/extdata/FY2025_HRRP_MockHSR.xlsx"

my_payment_summary <- hsr_payment_summary(my_report)
my_payment_summary

# A tibble: 1 × 7
  Number of Dually Eligible Stays…¹ Total Number of Stay…² `Dual Proportion [c]`
                              <dbl>                  <dbl>                 <dbl>
1                               186                    856                 0.217
# ℹ abbreviated names: ¹​`Number of Dually Eligible Stays (Numerator) [a]`,
#   ²​`Total Number of Stays(Denominator) [b]`
# ℹ 4 more variables: `Peer Group Assignment [d]` <dbl>,
#   `Neutrality Modifier [e]` <dbl>, `Payment Reduction Percentage [f]` <dbl>,
#   `Payment Adjustment Factor [g]` <dbl>

my_payment_summary |>
  tidyr::pivot_longer(dplyr::everything())

# A tibble: 7 × 2
  name                                               value
  <chr>                                              <dbl>
1 Number of Dually Eligible Stays (Numerator) [a] 186     
2 Total Number of Stays(Denominator) [b]          856     
3 Dual Proportion [c]                               0.217 
4 Peer Group Assignment [d]                         3     
5 Neutrality Modifier [e]                           0.965 
6 Payment Reduction Percentage [f]                  0.0007
7 Payment Adjustment Factor [g]                     0.999 

hsr_payment_penalty(my_report)

[1] 7e-04

hsr_dual_proportion(my_report)

[1] 0.2172897

hsr_peer_group(my_report)

[1] 3

cohort_summary <- hsr_cohort_summary(my_report)
cohort_summary

# A tibble: 6 × 10
  `Measure [a]` `Number of Eligible Discharges [b]` Number of Readmissions Amo…¹
  <chr>                                       <dbl>                        <dbl>
1 AMI                                             2                            0
2 COPD                                           18                            3
3 HF                                             25                            2
4 Pneumonia                                      32                            5
5 CABG                                           NA                           NA
6 THA/TKA                                        45                            0
# ℹ abbreviated name: ¹​`Number of Readmissions Among Eligible Discharges [c]`
# ℹ 7 more variables: `Predicted Readmission Rate [d]` <dbl>,
#   `Expected Readmission Rate [e]` <dbl>,
#   `Excess Readmission Ratio (ERR) [f]` <dbl>,
#   `Peer Group Median ERR [g]` <dbl>, `Penalty Indicator (Yes/No) [h]` <chr>,
#   `Ratio of DRG Payments Per Measure to Total Payments [i]` <dbl>,
#   `National Observed Readmission Rate [j]` <dbl>

cohort_summary |>

  # Filter to cohorts with a penalty
  dplyr::filter(`Penalty Indicator (Yes/No) [h]` == "Yes") |>
  
  # Compute the contribution of each penalized cohort
  dplyr::mutate(
    Contribution = 
      `Ratio of DRG Payments Per Measure to Total Payments [i]` *
      (
        `Excess Readmission Ratio (ERR) [f]` - 
          `Peer Group Median ERR [g]`
      )
  ) |>
  
  # Roll up into final calculation
  dplyr::summarize(
    Penalty = sum(Contribution) * hsr_neutrality_modifier(my_report)
  )

# A tibble: 1 × 1
   Penalty
     <dbl>
1 0.000746

hsr_discharges(my_report, "COPD")

# A tibble: 21 × 17
   `ID Number` MBI         `Medical Record Number` `Beneficiary DOB`
         <int> <chr>       <chr>                   <chr>            
 1           1 9AA9AA9AA99 99999A                  99/99/9999       
 2           2 9AA9AA9AA99 99999A                  99/99/9999       
 3           3 9AA9AA9AA99 99999A                  99/99/9999       
 4           4 9AA9AA9AA99 99999A                  99/99/9999       
 5           5 9AA9AA9AA99 99999A                  99/99/9999       
 6           6 9AA9AA9AA99 99999A                  99/99/9999       
 7           7 9AA9AA9AA99 99999A                  99/99/9999       
 8           8 9AA9AA9AA99 99999A                  99/99/9999       
 9           9 9AA9AA9AA99 99999A                  99/99/9999       
10          10 9AA9AA9AA99 99999A                  99/99/9999       
# ℹ 11 more rows
# ℹ 13 more variables: `Admission Date of Index Stay` <chr>,
#   `Discharge Date of Index Stay` <chr>,
#   `Cohort Inclusion/Exclusion Indicator` <chr>, `Index Stay (Yes/No)` <chr>,
#   `Principal Discharge Diagnosis of Index Stay` <chr>,
#   `Discharge Destination` <chr>,
#   `Unplanned Readmission within 30 Days (Yes/No) [a]` <chr>, …

hsr_discharges(
  file = my_report, 
  cohort = "COPD",
  eligible_only = TRUE
)

# A tibble: 18 × 17
   `ID Number` MBI         `Medical Record Number` `Beneficiary DOB`
         <int> <chr>       <chr>                   <chr>            
 1           1 9AA9AA9AA99 99999A                  99/99/9999       
 2           2 9AA9AA9AA99 99999A                  99/99/9999       
 3           3 9AA9AA9AA99 99999A                  99/99/9999       
 4           4 9AA9AA9AA99 99999A                  99/99/9999       
 5           5 9AA9AA9AA99 99999A                  99/99/9999       
 6           6 9AA9AA9AA99 99999A                  99/99/9999       
 7           7 9AA9AA9AA99 99999A                  99/99/9999       
 8           8 9AA9AA9AA99 99999A                  99/99/9999       
 9           9 9AA9AA9AA99 99999A                  99/99/9999       
10          10 9AA9AA9AA99 99999A                  99/99/9999       
11          11 9AA9AA9AA99 99999A                  99/99/9999       
12          12 9AA9AA9AA99 99999A                  99/99/9999       
13          13 9AA9AA9AA99 99999A                  99/99/9999       
14          14 9AA9AA9AA99 99999A                  99/99/9999       
15          15 9AA9AA9AA99 99999A                  99/99/9999       
16          16 9AA9AA9AA99 99999A                  99/99/9999       
17          17 9AA9AA9AA99 99999A                  99/99/9999       
18          18 9AA9AA9AA99 99999A                  99/99/9999       
# ℹ 13 more variables: `Admission Date of Index Stay` <chr>,
#   `Discharge Date of Index Stay` <chr>,
#   `Cohort Inclusion/Exclusion Indicator` <chr>, `Index Stay (Yes/No)` <chr>,
#   `Principal Discharge Diagnosis of Index Stay` <chr>,
#   `Discharge Destination` <chr>,
#   `Unplanned Readmission within 30 Days (Yes/No) [a]` <chr>,
#   `Planned Readmission within 30 Days (Yes/No)` <chr>, …

cohort_summary |>
  dplyr::filter(`Measure [a]` == "COPD") |>
  dplyr::pull(`Number of Eligible Discharges [b]`)

[1] 18

hsr_discharges(
  file = my_report, 
  cohort = "COPD",
  eligible_only = TRUE,
  risk_factors = TRUE,
  discharge_phi = FALSE
)

# A tibble: 18 × 42
   `ID Number` `Years Over 65 (continuous)` `History of Mechanical Ventilation`
         <int>                        <dbl>                               <dbl>
 1           1                            5                                   1
 2           2                            8                                   1
 3           3                           23                                   0
 4           4                           15                                   0
 5           5                            7                                   0
 6           6                            1                                   0
 7           7                           12                                   0
 8           8                           18                                   0
 9           9                            6                                   0
10          10                           11                                   0
11          11                           15                                   0
12          12                           13                                   0
13          13                            5                                   0
14          14                           12                                   0
15          15                           12                                   0
16          16                           24                                   0
17          17                           12                                   0
18          18                           11                                   0
# ℹ 39 more variables: `Sleep-Disordered Breathing` <dbl>,
#   `History of COVID-19` <dbl>,
#   `Severe Infection; Other Infectious Diseases` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>,
#   `Lung and Other Severe Cancers` <dbl>,
#   `Lymphatic, Head and Neck, Brain, and Other Major Cancers; Breast, Colorectal and Other Cancers and Tumors; Other Respiratory and Heart Neoplasms` <dbl>,
#   `Other Digestive and Urinary Neoplasms` <dbl>, …

copd_model <- hsr_coefficients(my_report, "COPD")
copd_model

# A tibble: 43 × 2
   Factor                                                                  Value
   <chr>                                                                   <dbl>
 1 Years Over 65 (continuous)                                           -0.00550
 2 History of Mechanical Ventilation                                     0.293  
 3 Sleep-Disordered Breathing                                           -0.0339 
 4 History of COVID-19                                                  -0.0200 
 5 Severe Infection; Other Infectious Diseases                           0.0381 
 6 Metastatic Cancer and Acute Leukemia                                  0.201  
 7 Lung and Other Severe Cancers                                         0.156  
 8 Lymphatic, Head and Neck, Brain, and Other Major Cancers; Breast, C… -0.00343
 9 Other Digestive and Urinary Neoplasms                                -0.0792 
10 Diabetes Mellitus (DM) or DM Complications                            0.0891 
# ℹ 33 more rows

copd_model |> tail()

# A tibble: 6 × 2
  Factor                                           Value
  <chr>                                            <dbl>
1 Renal Failure                                   0.160 
2 Decubitus Ulcer or Chronic Skin Ulcer           0.0729
3 Cellulitis, Local Skin Infection                0.0412
4 Vertebral Fractures Without Spinal Cord Injury  0.0822
5 HOSP_EFFECT                                    -2.53  
6 AVG_EFFECT                                     -2.53  

risks <- hsr_readmission_risks(my_report, "COPD")
risks

# A tibble: 18 × 3
   `ID Number` Predicted Expected
         <int>     <dbl>    <dbl>
 1           1    0.260    0.260 
 2           2    0.266    0.266 
 3           3    0.227    0.227 
 4           4    0.0990   0.0989
 5           5    0.0935   0.0935
 6           6    0.130    0.130 
 7           7    0.156    0.156 
 8           8    0.190    0.190 
 9           9    0.0842   0.0842
10          10    0.100    0.100 
11          11    0.129    0.129 
12          12    0.111    0.111 
13          13    0.350    0.349 
14          14    0.127    0.127 
15          15    0.158    0.158 
16          16    0.168    0.168 
17          17    0.118    0.118 
18          18    0.210    0.210 

risks |>
  dplyr::summarize(
    Discharges = dplyr::n(),
    Predicted = mean(Predicted),
    Expected = mean(Expected),
    ERR = Predicted / Expected
  )

# A tibble: 1 × 4
  Discharges Predicted Expected   ERR
       <int>     <dbl>    <dbl> <dbl>
1         18     0.165    0.165  1.00

cohort_summary |> 
  dplyr::filter(
    `Measure [a]` == "COPD"
  ) |>
  dplyr::select(
    Discharges = `Number of Eligible Discharges [b]`,
    Predicted = `Predicted Readmission Rate [d]`,
    Expected = `Expected Readmission Rate [e]`,
    ERR = `Excess Readmission Ratio (ERR) [f]`
  )

# A tibble: 1 × 4
  Discharges Predicted Expected   ERR
       <dbl>     <dbl>    <dbl> <dbl>
1         18     0.165    0.165  1.00

my_payment_summary

# A tibble: 1 × 7
  Number of Dually Eligible Stays…¹ Total Number of Stay…² `Dual Proportion [c]`
                              <dbl>                  <dbl>                 <dbl>
1                               186                    856                 0.217
# ℹ abbreviated names: ¹​`Number of Dually Eligible Stays (Numerator) [a]`,
#   ²​`Total Number of Stays(Denominator) [b]`
# ℹ 4 more variables: `Peer Group Assignment [d]` <dbl>,
#   `Neutrality Modifier [e]` <dbl>, `Payment Reduction Percentage [f]` <dbl>,
#   `Payment Adjustment Factor [g]` <dbl>

hsr_dual_stays(my_report)

# A tibble: 186 × 6
   `ID Number` MBI         `Beneficiary DOB` `Admission Date` `Discharge Date`
         <int> <chr>       <chr>             <chr>            <chr>           
 1           1 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 2           2 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 3           3 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 4           4 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 5           5 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 6           6 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 7           7 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 8           8 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
 9           9 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
10          10 9AA9AA9AA99 99/99/9999        99/99/9999       99/99/9999      
# ℹ 176 more rows
# ℹ 1 more variable: `Claim Type` <chr>

Analysis Strategies

In this section we’ll go through a collection data analyses that can be conducted, using functions in readmit as support, to validate HSR calculations and/or to gain deeper insights into HRRP results.

cohorts <- setdiff(names(hrrp_cohort_inclusion), "ProgramYear")
cohorts

[1] "AMI"  "COPD" "HF"   "PN"   "CABG" "HK"  

eligible_discharges <-
  setdiff(cohorts, "CABG") |>

    # Iterate each cohort
    purrr::map_df(

      # Import eligible discharges
      ~hsr_discharges(
        file = my_report,
        cohort = .x,
        eligible_only = TRUE
      ) |>

      # Keep the row identifiers
      dplyr::select(`ID Number`) |>

      # Add cohort identifier
      tibble::add_column(Cohort = .x)
    )
eligible_discharges

# A tibble: 122 × 2
   `ID Number` Cohort
         <int> <chr> 
 1           1 AMI   
 2           2 AMI   
 3           1 COPD  
 4           2 COPD  
 5           3 COPD  
 6           4 COPD  
 7           5 COPD  
 8           6 COPD  
 9           7 COPD  
10           8 COPD  
# ℹ 112 more rows

table(eligible_discharges$Cohort)

 AMI COPD   HF   HK   PN 
   2   18   25   45   32 

cohort_summary

# A tibble: 6 × 10
  `Measure [a]` `Number of Eligible Discharges [b]` Number of Readmissions Amo…¹
  <chr>                                       <dbl>                        <dbl>
1 AMI                                             2                            0
2 COPD                                           18                            3
3 HF                                             25                            2
4 Pneumonia                                      32                            5
5 CABG                                           NA                           NA
6 THA/TKA                                        45                            0
# ℹ abbreviated name: ¹​`Number of Readmissions Among Eligible Discharges [c]`
# ℹ 7 more variables: `Predicted Readmission Rate [d]` <dbl>,
#   `Expected Readmission Rate [e]` <dbl>,
#   `Excess Readmission Ratio (ERR) [f]` <dbl>,
#   `Peer Group Median ERR [g]` <dbl>, `Penalty Indicator (Yes/No) [h]` <chr>,
#   `Ratio of DRG Payments Per Measure to Total Payments [i]` <dbl>,
#   `National Observed Readmission Rate [j]` <dbl>

setdiff(cohorts, "CABG") |>

    # Iterate each cohort
    purrr::map(

      # Import eligible discharges
      ~hsr_discharges(
        file = my_report,
        cohort = .x,
        risk_factors = TRUE,
        discharge_phi = FALSE
      )
    )

[[1]]
# A tibble: 2 × 33
  `ID Number` `Years Over 65 (continuous)`  Male Anterior Myocardial Infarctio…¹
        <int>                        <dbl> <dbl>                           <dbl>
1           1                           31     1                               0
2           2                           27     1                               0
# ℹ abbreviated name: ¹​`Anterior Myocardial Infarction `
# ℹ 29 more variables: `Non-Anterior Location of Myocardial Infarction` <dbl>,
#   `History of Coronary Artery Bypass Graft (CABG) Surgery` <dbl>,
#   `History of Percutaneous Transluminal Coronary Angioplasty (PTCA)` <dbl>,
#   `History of COVID-19` <dbl>,
#   `Severe Infection; Other Infectious Diseases` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>, Cancer <dbl>, …

[[2]]
# A tibble: 21 × 42
   `ID Number` `Years Over 65 (continuous)` `History of Mechanical Ventilation`
         <int>                        <dbl>                               <dbl>
 1           1                            5                                   1
 2           2                            8                                   1
 3           3                           23                                   0
 4           4                           15                                   0
 5           5                            7                                   0
 6           6                            1                                   0
 7           7                           12                                   0
 8           8                           18                                   0
 9           9                            6                                   0
10          10                           11                                   0
# ℹ 11 more rows
# ℹ 39 more variables: `Sleep-Disordered Breathing` <dbl>,
#   `History of COVID-19` <dbl>,
#   `Severe Infection; Other Infectious Diseases` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>,
#   `Lung and Other Severe Cancers` <dbl>,
#   `Lymphatic, Head and Neck, Brain, and Other Major Cancers; Breast, Colorectal and Other Cancers and Tumors; Other Respiratory and Heart Neoplasms` <dbl>, …

[[3]]
# A tibble: 30 × 39
   `ID Number` `Years Over 65 (continuous)`  Male History of Coronary Artery B…¹
         <int>                        <dbl> <dbl>                          <dbl>
 1           1                            8     1                              0
 2           2                           25     1                              1
 3           3                            9     0                              0
 4           4                            9     0                              0
 5           5                           30     0                              0
 6           6                           13     0                              0
 7           7                           12     1                              1
 8           8                            7     1                              1
 9           9                           25     1                              0
10          10                           22     0                              0
# ℹ 20 more rows
# ℹ abbreviated name: ¹​`History of Coronary Artery Bypass Graft (CABG) Surgery`
# ℹ 35 more variables: `History of COVID-19` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>, Cancer <dbl>,
#   `Diabetes Mellitus (DM) or DM Complications` <dbl>,
#   `Protein-Calorie Malnutrition` <dbl>,
#   `Other Significant Endocrine and Metabolic Disorders; Disorders of Fluid/Electrolyte/Acid-base Balance` <dbl>, …

[[4]]
# A tibble: 45 × 43
   `ID Number` `Years Over 65 (continuous)`  Male History of Coronary Artery B…¹
         <int>                        <dbl> <dbl>                          <dbl>
 1           1                           13     0                              0
 2           2                           16     1                              0
 3           3                            6     1                              0
 4           4                           14     1                              0
 5           5                           16     1                              0
 6           6                           18     1                              0
 7           7                           15     1                              0
 8           8                           13     0                              0
 9           9                            9     0                              0
10          10                            4     0                              0
# ℹ 35 more rows
# ℹ abbreviated name: ¹​`History of Coronary Artery Bypass Graft (CABG) Surgery`
# ℹ 39 more variables: `History of COVID-19` <dbl>,
#   `Severe Infection; Other Infectious Diseases` <dbl>,
#   `Septicemia, Sepsis, Systemic Inflammatory Response Syndrome/Shock` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>,
#   `Lung and Other Severe Cancers` <dbl>, `Lymphoma; Other Cancers` <dbl>, …

[[5]]
# A tibble: 51 × 35
   `ID Number` `Years Over 65 (continuous)`  Male Index Admissions with an Ele…¹
         <int>                        <dbl> <dbl>                          <dbl>
 1           1                            1     1                              0
 2           2                            7     1                              1
 3           3                            1     0                              0
 4           4                            6     1                              0
 5           5                            1     1                              0
 6           6                           11     1                              0
 7           7                           14     0                              0
 8           8                           16     0                              0
 9           9                            1     0                              0
10          10                           16     0                              1
# ℹ 41 more rows
# ℹ abbreviated name: ¹​`Index Admissions with an Elective THA Procedure`
# ℹ 31 more variables: `Number of Procedures (two vs. one)` <dbl>,
#   `Other Congenital Deformity of Hip (Joint)` <dbl>,
#   `Post Traumatic Osteoarthritis` <dbl>, `History of COVID-19` <dbl>,
#   `Severe Infection; Other Infectious Diseases` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>, Cancer <dbl>, …

risk_factors <-
  setdiff(cohorts, "CABG") |>

      # Iterate each cohort
      purrr::map_df(

        # Import eligible discharges
        ~hsr_discharges(
          file = my_report,
          cohort = .x,
          risk_factors = TRUE,
          discharge_phi = FALSE
        ) |>
        
        # Send risk factors down the rows
        tidyr::pivot_longer(
          cols = -`ID Number`,
          names_to = "Factor",
          values_to = "Value"
        ) |>
        
        # Indicate cohort
        tibble::add_column(Cohort = .x)
      )
risk_factors

# A tibble: 5,689 × 4
   `ID Number` Factor                                               Value Cohort
         <int> <chr>                                                <dbl> <chr> 
 1           1 "Years Over 65 (continuous)"                            31 AMI   
 2           1 "Male"                                                   1 AMI   
 3           1 "Anterior Myocardial Infarction "                        0 AMI   
 4           1 "Non-Anterior Location of Myocardial Infarction"         0 AMI   
 5           1 "History of Coronary Artery Bypass Graft (CABG) Sur…     1 AMI   
 6           1 "History of Percutaneous Transluminal Coronary Angi…     0 AMI   
 7           1 "History of COVID-19"                                    0 AMI   
 8           1 "Severe Infection; Other Infectious Diseases"            1 AMI   
 9           1 "Metastatic Cancer and Acute Leukemia"                   0 AMI   
10           1 "Cancer"                                                 0 AMI   
# ℹ 5,679 more rows

risk_factors <-
  risk_factors |>

    # Join to get eligible only
    dplyr::inner_join(
      y = eligible_discharges,
      by = 
        c(
          "ID Number",
          "Cohort"
        )
    )
risk_factors

# A tibble: 4,626 × 4
   `ID Number` Factor                                               Value Cohort
         <int> <chr>                                                <dbl> <chr> 
 1           1 "Years Over 65 (continuous)"                            31 AMI   
 2           1 "Male"                                                   1 AMI   
 3           1 "Anterior Myocardial Infarction "                        0 AMI   
 4           1 "Non-Anterior Location of Myocardial Infarction"         0 AMI   
 5           1 "History of Coronary Artery Bypass Graft (CABG) Sur…     1 AMI   
 6           1 "History of Percutaneous Transluminal Coronary Angi…     0 AMI   
 7           1 "History of COVID-19"                                    0 AMI   
 8           1 "Severe Infection; Other Infectious Diseases"            1 AMI   
 9           1 "Metastatic Cancer and Acute Leukemia"                   0 AMI   
10           1 "Cancer"                                                 0 AMI   
# ℹ 4,616 more rows

risk_factors <-
  setdiff(cohorts, "CABG") |>

      # Iterate each cohort
      purrr::map_df(

        # Import eligible discharges
        ~hsr_discharges(
          file = my_report,
          cohort = .x,
          risk_factors = TRUE,
          discharge_phi = FALSE,
          eligible_only = TRUE
        ) |>
        
        # Send risk factors down the rows
        tidyr::pivot_longer(
          cols = -`ID Number`,
          names_to = "Factor",
          values_to = "Value"
        ) |>
        
        # Indicate cohort
        tibble::add_column(Cohort = .x)
      )
risk_factors

# A tibble: 4,626 × 4
   `ID Number` Factor                                               Value Cohort
         <int> <chr>                                                <dbl> <chr> 
 1           1 "Years Over 65 (continuous)"                            31 AMI   
 2           1 "Male"                                                   1 AMI   
 3           1 "Anterior Myocardial Infarction "                        0 AMI   
 4           1 "Non-Anterior Location of Myocardial Infarction"         0 AMI   
 5           1 "History of Coronary Artery Bypass Graft (CABG) Sur…     1 AMI   
 6           1 "History of Percutaneous Transluminal Coronary Angi…     0 AMI   
 7           1 "History of COVID-19"                                    0 AMI   
 8           1 "Severe Infection; Other Infectious Diseases"            1 AMI   
 9           1 "Metastatic Cancer and Acute Leukemia"                   0 AMI   
10           1 "Cancer"                                                 0 AMI   
# ℹ 4,616 more rows

model_weights <-
  cohorts |>

  # Iterate each cohort
  purrr::map_df(

    # Import eligible discharges
    ~hsr_coefficients(
      file = my_report,
      cohort = .x
    ) |>
    
    # Indicate cohort
    tibble::add_column(Cohort = .x)
  )
model_weights

# A tibble: 225 × 3
   Factor                                                           Value Cohort
   <chr>                                                            <dbl> <chr> 
 1 "Years Over 65 (continuous)"                                   0.00765 AMI   
 2 "Male"                                                        -0.134   AMI   
 3 "Anterior Myocardial Infarction "                              0.271   AMI   
 4 "Non-Anterior Location of Myocardial Infarction"               0.0712  AMI   
 5 "History of Coronary Artery Bypass Graft (CABG) Surgery"       0.0233  AMI   
 6 "History of Percutaneous Transluminal Coronary Angioplasty (… -0.0218  AMI   
 7 "History of COVID-19"                                         -0.0676  AMI   
 8 "Severe Infection; Other Infectious Diseases"                  0.0832  AMI   
 9 "Metastatic Cancer and Acute Leukemia"                         0.226   AMI   
10 "Cancer"                                                       0.0440  AMI   
# ℹ 215 more rows

risk_factors <-
  risk_factors |>

    # Join to get weights
    dplyr::inner_join(
      y = 
        model_weights |> 
          
        # Rename the column
        dplyr::rename(
          Weight = Value
        ),
      by = 
        c(
          "Cohort",
          "Factor"
        )
    )
risk_factors

# A tibble: 4,626 × 5
   `ID Number` Factor                                      Value Cohort   Weight
         <int> <chr>                                       <dbl> <chr>     <dbl>
 1           1 "Years Over 65 (continuous)"                   31 AMI     0.00765
 2           1 "Male"                                          1 AMI    -0.134  
 3           1 "Anterior Myocardial Infarction "               0 AMI     0.271  
 4           1 "Non-Anterior Location of Myocardial Infar…     0 AMI     0.0712 
 5           1 "History of Coronary Artery Bypass Graft (…     1 AMI     0.0233 
 6           1 "History of Percutaneous Transluminal Coro…     0 AMI    -0.0218 
 7           1 "History of COVID-19"                           0 AMI    -0.0676 
 8           1 "Severe Infection; Other Infectious Diseas…     1 AMI     0.0832 
 9           1 "Metastatic Cancer and Acute Leukemia"          0 AMI     0.226  
10           1 "Cancer"                                        0 AMI     0.0440 
# ℹ 4,616 more rows

linear_predictors <-
  risk_factors |>

    # Compute weighted sum
    dplyr::summarize(
      LP = sum(Weight * Value),
      .by = 
        c(
          Cohort,
          `ID Number`
        )
    )
linear_predictors

# A tibble: 122 × 3
   Cohort `ID Number`    LP
   <chr>        <int> <dbl>
 1 AMI              1 1.92 
 2 AMI              2 0.749
 3 COPD             1 1.49 
 4 COPD             2 1.52 
 5 COPD             3 1.31 
 6 COPD             4 0.321
 7 COPD             5 0.258
 8 COPD             6 0.633
 9 COPD             7 0.841
10 COPD             8 1.08 
# ℹ 112 more rows

model_weights |>
  dplyr::filter(
    stringr::str_detect(
      Factor,
      pattern = "EFFECT$"
    )
  )

# A tibble: 11 × 3
   Factor      Value Cohort
   <chr>       <dbl> <chr> 
 1 HOSP_EFFECT -2.96 AMI   
 2 AVG_EFFECT  -2.95 AMI   
 3 HOSP_EFFECT -2.53 COPD  
 4 AVG_EFFECT  -2.53 COPD  
 5 HOSP_EFFECT -2.46 HF    
 6 AVG_EFFECT  -2.42 HF    
 7 HOSP_EFFECT -2.51 PN    
 8 AVG_EFFECT  -2.51 PN    
 9 AVG_EFFECT  -2.70 CABG  
10 HOSP_EFFECT -4.41 HK    
11 AVG_EFFECT  -4.28 HK    

linear_predictors <-
  linear_predictors |>

    # Join to get intercepts
    dplyr::inner_join(
      y = 
        model_weights |>

        # Filter to intercepts
        dplyr::filter(
          stringr::str_detect(
            Factor,
            pattern = "_EFFECT$"
          )
        ) |>
        
        # Send over columns
        tidyr::pivot_wider(
          names_from = Factor,
          values_from = Value
        ),
      by = "Cohort"
    ) |>
    
    # Finish LP's
    dplyr::mutate(
      LP_Predicted = LP + HOSP_EFFECT,
      LP_Expected = LP + AVG_EFFECT
    )
linear_predictors

# A tibble: 122 × 7
   Cohort `ID Number`    LP HOSP_EFFECT AVG_EFFECT LP_Predicted LP_Expected
   <chr>        <int> <dbl>       <dbl>      <dbl>        <dbl>       <dbl>
 1 AMI              1 1.92        -2.96      -2.95        -1.03       -1.03
 2 AMI              2 0.749       -2.96      -2.95        -2.21       -2.20
 3 COPD             1 1.49        -2.53      -2.53        -1.04       -1.04
 4 COPD             2 1.52        -2.53      -2.53        -1.01       -1.01
 5 COPD             3 1.31        -2.53      -2.53        -1.22       -1.22
 6 COPD             4 0.321       -2.53      -2.53        -2.21       -2.21
 7 COPD             5 0.258       -2.53      -2.53        -2.27       -2.27
 8 COPD             6 0.633       -2.53      -2.53        -1.90       -1.90
 9 COPD             7 0.841       -2.53      -2.53        -1.69       -1.69
10 COPD             8 1.08        -2.53      -2.53        -1.45       -1.45
# ℹ 112 more rows

readmission_risks <-
  linear_predictors |>

    # Transform LP's
    dplyr::mutate(
      dplyr::across(
        c(LP_Predicted, LP_Expected),
        \(x) 1 / (1 + exp(-x))
      )
    ) |>
    
    # Keep a few columns
    dplyr::select(
      `ID Number`,
      Predicted = LP_Predicted,
      Expected = LP_Expected,
      Cohort
    )
readmission_risks

# A tibble: 122 × 4
   `ID Number` Predicted Expected Cohort
         <int>     <dbl>    <dbl> <chr> 
 1           1    0.262    0.264  AMI   
 2           2    0.0991   0.100  AMI   
 3           1    0.260    0.260  COPD  
 4           2    0.266    0.266  COPD  
 5           3    0.227    0.227  COPD  
 6           4    0.0990   0.0989 COPD  
 7           5    0.0935   0.0935 COPD  
 8           6    0.130    0.130  COPD  
 9           7    0.156    0.156  COPD  
10           8    0.190    0.190  COPD  
# ℹ 112 more rows

readmission_risks <-
  setdiff(cohorts, "CABG") |>

    # Iterate each cohort
    purrr::map_df(

      # Import eligible discharges
      ~hsr_readmission_risks(
        file = my_report,
        cohort = .x
      ) |>
      
      # Indicate cohort
      tibble::add_column(Cohort = .x)
    )
readmission_risks

# A tibble: 122 × 4
   `ID Number` Predicted Expected Cohort
         <int>     <dbl>    <dbl> <chr> 
 1           1    0.262    0.264  AMI   
 2           2    0.0991   0.100  AMI   
 3           1    0.260    0.260  COPD  
 4           2    0.266    0.266  COPD  
 5           3    0.227    0.227  COPD  
 6           4    0.0990   0.0989 COPD  
 7           5    0.0935   0.0935 COPD  
 8           6    0.130    0.130  COPD  
 9           7    0.156    0.156  COPD  
10           8    0.190    0.190  COPD  
# ℹ 112 more rows

cohort_rates <-
  readmission_risks |>

    # Compute cohort-level stats
    dplyr::summarize(
      Discharges = dplyr::n(),
      Predicted = mean(Predicted),
      Expected = mean(Expected),
      .by = Cohort
    )
cohort_rates

# A tibble: 5 × 4
  Cohort Discharges Predicted Expected
  <chr>       <int>     <dbl>    <dbl>
1 AMI             2    0.181    0.182 
2 COPD           18    0.165    0.165 
3 HF             25    0.159    0.164 
4 PN             32    0.142    0.141 
5 HK             45    0.0350   0.0397

cohort_summary |>
    dplyr::select(
      Cohort = `Measure [a]`,
      Discharges = `Number of Eligible Discharges [b]`,
      Predicted = `Predicted Readmission Rate [d]`,
      Expected = `Expected Readmission Rate [e]`
    )

# A tibble: 6 × 4
  Cohort    Discharges Predicted Expected
  <chr>          <dbl>     <dbl>    <dbl>
1 AMI                2    0.181    0.182 
2 COPD              18    0.165    0.165 
3 HF                25    0.159    0.164 
4 Pneumonia         32    0.142    0.141 
5 CABG              NA   NA       NA     
6 THA/TKA           45    0.0350   0.0397

cohort_rates <-
  cohort_rates |>

    # Compute the ERR
    dplyr::mutate(
      ERR = Predicted / Expected
    )
cohort_rates

# A tibble: 5 × 5
  Cohort Discharges Predicted Expected   ERR
  <chr>       <int>     <dbl>    <dbl> <dbl>
1 AMI             2    0.181    0.182  0.993
2 COPD           18    0.165    0.165  1.00 
3 HF             25    0.159    0.164  0.971
4 PN             32    0.142    0.141  1.01 
5 HK             45    0.0350   0.0397 0.882

cohort_rates <-
  cohort_rates |>

    # Join to get reference info
    dplyr::inner_join(
      y = 
        cohort_summary |>

        # Make matching names
        dplyr::mutate(
          Cohort = `Measure [a]`,
          Cohort = 
            dplyr::case_when(
              Cohort == "Pneumonia" ~ "PN",
              Cohort == "THA/TKA" ~ "HK",
              TRUE ~ Cohort
            )
        ) |>
        
        # Keep a few columns
        dplyr::select(
          Cohort,
          PeerGroupERR = `Peer Group Median ERR [g]`,
          DRGRatio = `Ratio of DRG Payments Per Measure to Total Payments [i]`
        ),
      by = "Cohort"
    )
cohort_rates

# A tibble: 5 × 7
  Cohort Discharges Predicted Expected   ERR PeerGroupERR DRGRatio
  <chr>       <int>     <dbl>    <dbl> <dbl>        <dbl>    <dbl>
1 AMI             2    0.181    0.182  0.993        0.996  0.00273
2 COPD           18    0.165    0.165  1.00         0.992  0.0226 
3 HF             25    0.159    0.164  0.971        0.996  0.0322 
4 PN             32    0.142    0.141  1.01         0.991  0.0494 
5 HK             45    0.0350   0.0397 0.882        0.996  0.104  

cohort_rates <-
  cohort_rates |>

    # Compute penalty contribution
    dplyr::mutate(
      IsPenalized = as.numeric(ERR > PeerGroupERR & Discharges >= 25),
      PenaltyContribution = (ERR - PeerGroupERR) * DRGRatio,
      PenaltyContribution = IsPenalized * PenaltyContribution
    )
cohort_rates

# A tibble: 5 × 9
  Cohort Discharges Predicted Expected   ERR PeerGroupERR DRGRatio IsPenalized
  <chr>       <int>     <dbl>    <dbl> <dbl>        <dbl>    <dbl>       <dbl>
1 AMI             2    0.181    0.182  0.993        0.996  0.00273           0
2 COPD           18    0.165    0.165  1.00         0.992  0.0226            0
3 HF             25    0.159    0.164  0.971        0.996  0.0322            0
4 PN             32    0.142    0.141  1.01         0.991  0.0494            1
5 HK             45    0.0350   0.0397 0.882        0.996  0.104             0
# ℹ 1 more variable: PenaltyContribution <dbl>

temp_penalty <- sum(cohort_rates$PenaltyContribution)
temp_penalty

[1] 0.0007729462

penalty <- temp_penalty * my_payment_summary$`Neutrality Modifier [e]`
penalty

[1] 0.0007460787

my_payment_summary$`Payment Reduction Percentage [f]`

[1] 7e-04

my_report

[1] "/Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/library/readmit/extdata/FY2025_HRRP_MockHSR.xlsx"

my_payment_period <-
  hrrp_payment_periods |>
    dplyr::filter(ProgramYear == 2025)
my_payment_period

# A tibble: 1 × 3
  ProgramYear StartDate  EndDate   
        <int> <date>     <date>    
1        2025 2024-10-01 2025-09-30

model_weights

# A tibble: 225 × 3
   Factor                                                           Value Cohort
   <chr>                                                            <dbl> <chr> 
 1 "Years Over 65 (continuous)"                                   0.00765 AMI   
 2 "Male"                                                        -0.134   AMI   
 3 "Anterior Myocardial Infarction "                              0.271   AMI   
 4 "Non-Anterior Location of Myocardial Infarction"               0.0712  AMI   
 5 "History of Coronary Artery Bypass Graft (CABG) Surgery"       0.0233  AMI   
 6 "History of Percutaneous Transluminal Coronary Angioplasty (… -0.0218  AMI   
 7 "History of COVID-19"                                         -0.0676  AMI   
 8 "Severe Infection; Other Infectious Diseases"                  0.0832  AMI   
 9 "Metastatic Cancer and Acute Leukemia"                         0.226   AMI   
10 "Cancer"                                                       0.0440  AMI   
# ℹ 215 more rows

model_weights |>
  dplyr::mutate(
    OR = exp(Value)
  )

# A tibble: 225 × 4
   Factor                                                     Value Cohort    OR
   <chr>                                                      <dbl> <chr>  <dbl>
 1 "Years Over 65 (continuous)"                             0.00765 AMI    1.01 
 2 "Male"                                                  -0.134   AMI    0.875
 3 "Anterior Myocardial Infarction "                        0.271   AMI    1.31 
 4 "Non-Anterior Location of Myocardial Infarction"         0.0712  AMI    1.07 
 5 "History of Coronary Artery Bypass Graft (CABG) Surger…  0.0233  AMI    1.02 
 6 "History of Percutaneous Transluminal Coronary Angiopl… -0.0218  AMI    0.978
 7 "History of COVID-19"                                   -0.0676  AMI    0.935
 8 "Severe Infection; Other Infectious Diseases"            0.0832  AMI    1.09 
 9 "Metastatic Cancer and Acute Leukemia"                   0.226   AMI    1.25 
10 "Cancer"                                                 0.0440  AMI    1.04 
# ℹ 215 more rows

library(ggplot2)
model_weights |>

  # Remove intercepts
  dplyr::filter(!stringr::str_detect(Factor, "_EFFECT$")) |>
  
  # Rank by group
  dplyr::mutate(
    Rank = order(order(abs(Value), decreasing = TRUE)),
    .by = "Cohort"
  ) |>
  
  # Filter to top 10
  dplyr::filter(Rank <= 5) |>
  
  # Make a plot
  ggplot() +
  geom_linerange(
    aes(
      x = stringr::str_sub(Factor, 1, 20),
      ymin = 1,
      ymax = exp(Value),
      color = stringr::str_sub(Factor, 1, 20)
    ),
    linewidth = 1,
    show.legend = FALSE
  ) +
  geom_hline(yintercept = 1) +
  facet_wrap(~Cohort, scales = "free_y", nrow = 3) +
  coord_flip() +
  theme_minimal() +
  xlab("Risk Factor") +
  ylab("Odds Ratio")

library(reactable)
model_weights |>

  # Remove intercepts
  dplyr::filter(!stringr::str_detect(Factor, "_EFFECT$")) |>
  
  # Rank by group
  dplyr::mutate(
    Rank = order(order(abs(Value), decreasing = TRUE)),
    .by = "Cohort"
  ) |>
  
  # Compute odds ratio
  dplyr::mutate(
    OR = exp(Value)
  ) |>
  
  # Rearrange
  dplyr::select(
    Cohort,
    Factor,
    Rank,
    Value,
    OR
  ) |>
  dplyr::arrange(
    Cohort,
    Rank
  ) |>
  
  # Make a table
  reactable(
    groupBy = "Cohort",
    columns = 
      list(
        Factor = colDef(name = "Risk Factor"),
        Value = colDef(name = "Coefficient", format = colFormat(digits = 2)),
        OR = colDef(name = "Odds-Ratio", format = colFormat(digits = 2))
      ),
      searchable = TRUE,
      sortable = TRUE,
      filterable = TRUE,
      resizable = TRUE
  )

hsr_discharges(
  file = my_report,
  cohort = "AMI",
  discharge_phi = FALSE,
  risk_factors = TRUE,
  eligible_only = TRUE
)

# A tibble: 2 × 33
  `ID Number` `Years Over 65 (continuous)`  Male Anterior Myocardial Infarctio…¹
        <int>                        <dbl> <dbl>                           <dbl>
1           1                           31     1                               0
2           2                           27     1                               0
# ℹ abbreviated name: ¹​`Anterior Myocardial Infarction `
# ℹ 29 more variables: `Non-Anterior Location of Myocardial Infarction` <dbl>,
#   `History of Coronary Artery Bypass Graft (CABG) Surgery` <dbl>,
#   `History of Percutaneous Transluminal Coronary Angioplasty (PTCA)` <dbl>,
#   `History of COVID-19` <dbl>,
#   `Severe Infection; Other Infectious Diseases` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>, Cancer <dbl>, …

risk_factors

# A tibble: 4,626 × 5
   `ID Number` Factor                                      Value Cohort   Weight
         <int> <chr>                                       <dbl> <chr>     <dbl>
 1           1 "Years Over 65 (continuous)"                   31 AMI     0.00765
 2           1 "Male"                                          1 AMI    -0.134  
 3           1 "Anterior Myocardial Infarction "               0 AMI     0.271  
 4           1 "Non-Anterior Location of Myocardial Infar…     0 AMI     0.0712 
 5           1 "History of Coronary Artery Bypass Graft (…     1 AMI     0.0233 
 6           1 "History of Percutaneous Transluminal Coro…     0 AMI    -0.0218 
 7           1 "History of COVID-19"                           0 AMI    -0.0676 
 8           1 "Severe Infection; Other Infectious Diseas…     1 AMI     0.0832 
 9           1 "Metastatic Cancer and Acute Leukemia"          0 AMI     0.226  
10           1 "Cancer"                                        0 AMI     0.0440 
# ℹ 4,616 more rows

prevalence <-
  risk_factors |>

    # Remove age (for demo purposes)
    dplyr::filter(!stringr::str_detect(Factor, "^Years")) |>

    # Compute average
    dplyr::summarize(
      N = dplyr::n(),
      Count = sum(Value),
      Rate = Count / N,
      .by = 
        c(
          Cohort,
          Factor
        )
    )
prevalence

# A tibble: 182 × 5
   Cohort Factor                                                   N Count  Rate
   <chr>  <chr>                                                <int> <dbl> <dbl>
 1 AMI    "Male"                                                   2     2   1  
 2 AMI    "Anterior Myocardial Infarction "                        2     0   0  
 3 AMI    "Non-Anterior Location of Myocardial Infarction"         2     0   0  
 4 AMI    "History of Coronary Artery Bypass Graft (CABG) Sur…     2     1   0.5
 5 AMI    "History of Percutaneous Transluminal Coronary Angi…     2     1   0.5
 6 AMI    "History of COVID-19"                                    2     0   0  
 7 AMI    "Severe Infection; Other Infectious Diseases"            2     1   0.5
 8 AMI    "Metastatic Cancer and Acute Leukemia"                   2     0   0  
 9 AMI    "Cancer"                                                 2     0   0  
10 AMI    "Diabetes Mellitus (DM) or DM Complications"             2     1   0.5
# ℹ 172 more rows

prevalence |>
  
    # Arrange
    dplyr::arrange(Cohort, desc(Rate)) |>
    
    # Make a table
    reactable(
      groupBy = "Cohort",
      columns = 
        list(
          Factor = colDef(name = "Risk Factor"),
          N = colDef(name = "Discharge Count"),
          Count = colDef(name = "Count"),
          Rate = colDef(name = "Percent", format = colFormat(digits = 1, percent = TRUE))
        ),
      columnGroups = 
        list(
          colGroup(
            name = "Risk Factor Prevalence",
            columns = c("Count", "Rate")
          )
        ),
      searchable = TRUE,
      sortable = TRUE,
      filterable = TRUE,
      resizable = TRUE
    )

prevalence |>

  # Join to get model weight
  dplyr::inner_join(
    y = model_weights,
    by = 
      c(
        "Cohort",
        "Factor"
      )
  ) |>
  
  # Make total weight
  dplyr::mutate(
    NetImpact = abs(Count * Value)
  ) |>
  
  # Arrange
  dplyr::arrange(Cohort, desc(NetImpact)) |>
  dplyr::relocate(NetImpact, .after = Factor) |>
    
  # Make a table
  reactable(
    groupBy = "Cohort",
    columns = 
      list(
        Factor = colDef(name = "Risk Factor"),
        NetImpact = colDef(name = "Net Impact", format = colFormat(digits = 2)),
        N = colDef(name = "Discharge Count"),
        Count = colDef(name = "Count"),
        Rate = colDef(name = "Percent", format = colFormat(digits = 1, percent = TRUE))
      ),
    columnGroups = 
      list(
        colGroup(
          name = "Risk Factor Prevalence",
          columns = c("Count", "Rate")
        )
      ),
    searchable = TRUE,
    sortable = TRUE,
    filterable = TRUE,
    resizable = TRUE
  )

prevalence |>

  # Join to get model weight
  dplyr::inner_join(
    y = model_weights,
    by = 
      c(
        "Cohort",
        "Factor"
      )
  ) |>
  
  ggplot() +
  geom_point(
    aes(
      x = Count,
      y = exp(Value),
      color = Cohort
    ),
    show.legend = FALSE
  ) +
  geom_hline(yintercept = 1) +
  facet_wrap(~Cohort, scales = "free_x", nrow = 3) +
  theme_minimal() +
  xlab("Risk Factor Count") +
  ylab("Odds Ratio") 

hsr_discharges(
  file = my_report,
  cohort = "HF",
  eligible_only = TRUE
) |>

  # Keep diagnosis columns
  dplyr::select(dplyr::matches("Diagnosis")) |>
  
  # Aggregate
  dplyr::summarize(
    N = dplyr::n(),
    .by = dplyr::everything()
  ) |>
  dplyr::arrange(desc(N))

# A tibble: 9 × 3
  `Principal Discharge Diagnosis of Index Stay` Principal Discharge Diag…¹     N
  <chr>                                         <chr>                      <int>
1 I110                                          <NA>                          12
2 I130                                          <NA>                           5
3 I5033                                         <NA>                           2
4 I5033                                         I130                           1
5 I130                                          A0472                          1
6 I132                                          U071                           1
7 I509                                          <NA>                           1
8 I5023                                         <NA>                           1
9 I5043                                         <NA>                           1
# ℹ abbreviated name: ¹​`Principal Discharge Diagnosis of Readmission`

hsr_discharges(
  file = my_report,
  cohort = "HF",
  eligible_only = TRUE
) |>

  # Keep diagnosis columns
  dplyr::select(dplyr::matches("Same Hospital")) |> 
  
  # Make a table
  table(useNA = "ifany")

Readmission to Same Hospital (Yes/No)
  No  Yes <NA> 
   2    1   22 

Installation

You can install readmit from CRAN:

# install.packages("pak")
install.packages("readmit")

Or the development version from GitHub with:

# install.packages("pak")
pak::pak("centralstatz/readmit")

Background

A readmission occurs when a patient is admitted to the hospital, again, after they were recently discharged (where 30 days is the typical time frame used between hospitalizations). First and foremost, it is an obvious burden to patients for multiple reasons (i.e., psychologically, financially, etc.).

Additionally, hospitals across the United States are penalized by the Centers for Medicare & Medicaid Services (CMS) on an annual basis in what is called the Hospital Readmissions Reduction Program (HRRP). In this program, up to 3% of Medicare reimbursement is witheld from hospitals for the duration of a fiscal year depending on the volume of excess readmissions in select patient populations during a preceding performance period. Readmissions also show up in other payer contracts, such as commericial insurers. Thus, it is a key area of focus for hospitals and part of the general measure of overall health of clinical and financial operations.

Typically, cross-functional teams are deployed within health systems to monitor and develop initiatives, interventions, and overall strategy to manage and prevent readmissions. This includes things like care coordination and patient outreach, as well as how to incorporate technology such as predictive analytics to identify high-risk patients and prevent readmissions before they occur.

Examples

Here are a few ways to use the package.

library(readmit)

hrrp_performance_periods

   ProgramYear  StartDate    EndDate
1         2027 2023-07-01 2025-06-30
2         2026 2021-07-01 2024-06-30
3         2025 2020-07-01 2023-06-30
4         2024 2019-07-01 2019-12-01
5         2024 2020-07-01 2022-06-30
6         2023 2018-07-01 2019-12-01
7         2023 2020-07-01 2021-06-30
8         2022 2017-07-01 2019-12-01
9         2021 2016-07-01 2019-06-30
10        2020 2015-07-01 2018-06-30
11        2019 2014-07-01 2017-06-30

hrrp_snapshot_dates

  ProgramYear SnapshotDate
1        2027   2025-09-30
2        2026   2024-10-22
3        2025   2023-10-13
4        2024   2022-09-30
5        2023   2021-09-24
6        2022   2020-09-25
7        2021   2019-09-27
8        2020   2018-09-28
9        2019   2017-09-29

hrrp_keydates

   ProgramYear PerformanceStartDate PerformanceEndDate PaymentStartDate
1         2027           2023-07-01         2025-06-30       2026-10-01
2         2026           2021-07-01         2024-06-30       2025-10-01
3         2025           2020-07-01         2023-06-30       2024-10-01
4         2024           2019-07-01         2019-12-01       2023-10-01
5         2024           2020-07-01         2022-06-30       2023-10-01
6         2023           2018-07-01         2019-12-01       2022-10-01
7         2023           2020-07-01         2021-06-30       2022-10-01
8         2022           2017-07-01         2019-12-01       2021-10-01
9         2021           2016-07-01         2019-06-30       2020-10-01
10        2020           2015-07-01         2018-06-30       2019-10-01
11        2019           2014-07-01         2017-06-30       2018-10-01
   PaymentEndDate ReviewStartDate ReviewEndDate SnapshotDate AMI COPD HF PN
1      2027-09-30            <NA>          <NA>   2025-09-30   1    1  1  1
2      2026-09-30      2025-08-12    2025-09-10   2024-10-22   1    1  1  1
3      2025-09-30      2024-08-12    2024-09-10   2023-10-13   1    1  1  1
4      2024-09-30      2023-08-08    2023-09-07   2022-09-30   1    1  1  1
5      2024-09-30      2023-08-08    2023-09-07   2022-09-30   1    1  1  1
6      2023-09-30      2022-08-08    2022-09-07   2021-09-24   1    1  1  0
7      2023-09-30      2022-08-08    2022-09-07   2021-09-24   1    1  1  0
8      2022-09-30      2021-08-09    2021-09-08   2020-09-25   1    1  1  1
9      2021-09-30      2020-08-10    2020-09-09   2019-09-27   1    1  1  1
10     2020-09-30      2019-08-09    2019-09-09   2018-09-28   1    1  1  1
11     2019-09-30      2018-08-06    2018-09-05   2017-09-29   1    1  1  1
   CABG HK
1     1  1
2     1  1
3     1  1
4     1  1
5     1  1
6     1  1
7     1  1
8     1  1
9     1  1
10    1  1
11    1  1

hrrp_get_dates(Sys.Date(), "performance", discharge = FALSE)

# A tibble: 1 × 3
  ProgramYear StartDate  EndDate   
        <dbl> <chr>      <chr>     
1        2026 2021-07-01 2024-06-30

hrrp_get_dates(as.Date("2022-01-01"), "payment", discharge = TRUE)

# A tibble: 3 × 3
  ProgramYear StartDate  EndDate   
        <int> <date>     <date>    
1        2026 2025-10-01 2026-09-30
2        2025 2024-10-01 2025-09-30
3        2024 2023-10-01 2024-09-30

# Mock report from QualityNet
my_hsr <- hsr_mock_reports("FY2025_HRRP_MockHSR.xlsx")

hsr_discharges(
  file = my_hsr,
  cohort = "HF",
  eligible_only = TRUE
)

# A tibble: 25 × 17
   `ID Number` MBI         `Medical Record Number` `Beneficiary DOB`
         <int> <chr>       <chr>                   <chr>            
 1           1 9AA9AA9AA99 99999A                  99/99/9999       
 2           2 9AA9AA9AA99 99999A                  99/99/9999       
 3           3 9AA9AA9AA99 99999A                  99/99/9999       
 4           4 9AA9AA9AA99 99999A                  99/99/9999       
 5           5 9AA9AA9AA99 99999A                  99/99/9999       
 6           6 9AA9AA9AA99 99999A                  99/99/9999       
 7           7 9AA9AA9AA99 99999A                  99/99/9999       
 8           8 9AA9AA9AA99 99999A                  99/99/9999       
 9           9 9AA9AA9AA99 99999A                  99/99/9999       
10          10 9AA9AA9AA99 99999A                  99/99/9999       
# ℹ 15 more rows
# ℹ 13 more variables: `Admission Date of Index Stay` <chr>,
#   `Discharge Date of Index Stay` <chr>,
#   `Cohort Inclusion/Exclusion Indicator` <chr>, `Index Stay (Yes/No)` <chr>,
#   `Principal Discharge Diagnosis of Index Stay` <chr>,
#   `Discharge Destination` <chr>,
#   `Unplanned Readmission within 30 Days (Yes/No) [a]` <chr>, …

hsr_discharges(
  file = my_hsr,
  cohort = "HF",
  eligible_only = TRUE,
  risk_factors = TRUE,
  discharge_phi = FALSE
)

# A tibble: 25 × 39
   `ID Number` `Years Over 65 (continuous)`  Male History of Coronary Artery B…¹
         <int>                        <dbl> <dbl>                          <dbl>
 1           1                            8     1                              0
 2           2                           25     1                              1
 3           3                            9     0                              0
 4           4                            9     0                              0
 5           5                           30     0                              0
 6           6                           13     0                              0
 7           7                           12     1                              1
 8           8                            7     1                              1
 9           9                           25     1                              0
10          10                           22     0                              0
# ℹ 15 more rows
# ℹ abbreviated name: ¹​`History of Coronary Artery Bypass Graft (CABG) Surgery`
# ℹ 35 more variables: `History of COVID-19` <dbl>,
#   `Metastatic Cancer and Acute Leukemia` <dbl>, Cancer <dbl>,
#   `Diabetes Mellitus (DM) or DM Complications` <dbl>,
#   `Protein-Calorie Malnutrition` <dbl>,
#   `Other Significant Endocrine and Metabolic Disorders; Disorders of Fluid/Electrolyte/Acid-base Balance` <dbl>, …

hsr_coefficients(
  file = my_hsr,
  cohort = "HF"
)

# A tibble: 40 × 2
   Factor                                                                  Value
   <chr>                                                                   <dbl>
 1 Years Over 65 (continuous)                                           -0.00589
 2 Male                                                                 -0.0359 
 3 History of Coronary Artery Bypass Graft (CABG) Surgery                0.0199 
 4 History of COVID-19                                                  -0.00239
 5 Metastatic Cancer and Acute Leukemia                                  0.149  
 6 Cancer                                                                0.0126 
 7 Diabetes Mellitus (DM) or DM Complications                            0.0968 
 8 Protein-Calorie Malnutrition                                          0.0856 
 9 Other Significant Endocrine and Metabolic Disorders; Disorders of F…  0.163  
10 Liver or Biliary Disease                                              0.0865 
# ℹ 30 more rows

hsr_readmission_risks(
  file = my_hsr,
  cohort = "HF"
)

# A tibble: 25 × 3
   `ID Number` Predicted Expected
         <int>     <dbl>    <dbl>
 1           1    0.258    0.264 
 2           2    0.186    0.192 
 3           3    0.184    0.189 
 4           4    0.188    0.193 
 5           5    0.0857   0.0885
 6           6    0.133    0.138 
 7           7    0.110    0.113 
 8           8    0.183    0.188 
 9           9    0.163    0.168 
10          10    0.179    0.184 
# ℹ 15 more rows

pdc_topics()

 [1] "Dialysis facilities"                   
 [2] "Doctors and clinicians"                
 [3] "Home health services"                  
 [4] "Hospice care"                          
 [5] "Hospitals"                             
 [6] "Inpatient rehabilitation facilities"   
 [7] "Long-term care hospitals"              
 [8] "Nursing homes including rehab services"
 [9] "Physician office visit costs"          
[10] "Supplier directory"                    

hospital_data <- pdc_datasets("Hospitals")
hospital_data

# A tibble: 69 × 7
   datasetid topic     title       description issued     modified   downloadurl
   <chr>     <chr>     <chr>       <chr>       <date>     <date>     <chr>      
 1 axe7-s95e Hospitals Ambulatory… This file … 2025-10-01 2025-10-01 https://da…
 2 wue8-3vwe Hospitals Ambulatory… This file … 2025-10-01 2025-10-01 https://da…
 3 4jcv-atw7 Hospitals Ambulatory… A list of … 2025-10-01 2025-10-01 https://da…
 4 hbf-map   Hospitals Birthing F… A list of … 2025-07-09 2025-10-14 https://da…
 5 muwa-iene Hospitals CMS Medica… This data … 2020-12-10 2025-10-14 https://da…
 6 ynj2-r877 Hospitals Complicati… Complicati… 2023-07-05 2025-10-20 https://da…
 7 qqw3-t4ie Hospitals Complicati… Complicati… 2020-12-10 2025-10-14 https://da…
 8 bs2r-24vh Hospitals Complicati… Complicati… 2020-12-10 2025-10-14 https://da…
 9 jfnd-nl7s Hospitals Complicati… Prospectiv… 2024-07-31 2025-10-14 https://da…
10 z8ax-x9j1 Hospitals Complicati… Prospectiv… 2024-07-31 2025-10-14 https://da…
# ℹ 59 more rows

readmission_data <- 
  hospital_data |>
    dplyr::filter(
      stringr::str_detect(
        title,
        pattern = "(?i)readmission"
      )
    )
readmission_data

# A tibble: 1 × 7
  datasetid topic     title        description issued     modified   downloadurl
  <chr>     <chr>     <chr>        <chr>       <date>     <date>     <chr>      
1 9n3s-kdb3 Hospitals Hospital Re… In October… 2020-12-10 2025-01-08 https://da…

hrrp_data <- pdc_read(readmission_data$datasetid)

Rows: 18510 Columns: 12
── Column specification ────────────────────────────────────────────────────────
Delimiter: ","
chr (11): Facility Name, Facility ID, State, Measure Name, Number of Dischar...
dbl  (1): Footnote

ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

hrrp_data

# A tibble: 18,510 × 12
   `Facility Name`     `Facility ID` State `Measure Name` `Number of Discharges`
   <chr>               <chr>         <chr> <chr>          <chr>                 
 1 SOUTHEAST HEALTH M… 010001        AL    READM-30-AMI-… 296                   
 2 SOUTHEAST HEALTH M… 010001        AL    READM-30-CABG… 151                   
 3 SOUTHEAST HEALTH M… 010001        AL    READM-30-HF-H… 681                   
 4 SOUTHEAST HEALTH M… 010001        AL    READM-30-HIP-… N/A                   
 5 SOUTHEAST HEALTH M… 010001        AL    READM-30-PN-H… 490                   
 6 SOUTHEAST HEALTH M… 010001        AL    READM-30-COPD… 130                   
 7 MARSHALL MEDICAL C… 010005        AL    READM-30-CABG… N/A                   
 8 MARSHALL MEDICAL C… 010005        AL    READM-30-HIP-… N/A                   
 9 MARSHALL MEDICAL C… 010005        AL    READM-30-HF-H… 176                   
10 MARSHALL MEDICAL C… 010005        AL    READM-30-PN-H… 305                   
# ℹ 18,500 more rows
# ℹ 7 more variables: Footnote <dbl>, `Excess Readmission Ratio` <chr>,
#   `Predicted Readmission Rate` <chr>, `Expected Readmission Rate` <chr>,
#   `Number of Readmissions` <chr>, `Start Date` <chr>, `End Date` <chr>

hrrp_data |>
  dplyr::filter(State == "WI") |>
  with(data = _, dplyr::n_distinct(`Facility ID`))

[1] 65

Setup

To get Positron Assitant setup initially, I followed the steps here to get it configured, which amounted to updating Positron and enabling it in the settings (as the directions say).

Supplying the code base

The code base we are going to be working with is located here (note that this commit was the last one before the changes in this article were made). It is a Shiny application exploring hospital readmissions that contains a toggle capability for the user to switch between “traditional” data filters and a natural language chat interface to interact with the data. In either case, the interactive map and visuals update accordingly:

There is also a video of how this was done:

The live application is located on Posit Connect Cloud here.

What’s the goal here then?

I want Positron Assistant to interact directly with my code and make changes on my behalf with my supervision and approval. The actual feature I want to change is simple: in the bottom-right corner of the app there is a table from the DT package showing the hospitals currently being plotted on the map (just basically a list view of the map data).

Trying it out

With everything configured, I opened up the code base in a new Positron session. Note I had to re-authenticate my API key after closing Positron, and then I chose Claude Sonnet 3.7.

I know that server.R is where this change will need to be made because that is where my dynamic dataset is fed into the DT::renderDataTable function. So I opened that file as well as the Positron Assistant chat pane:

The one really cool thing already is the Add Context button on the bottom. This means that you can add various files that the AI should consider in context to the conversation you are about to have with it. In this case, server.R is already attached (because it’s open), so I can just talk about this file as if it already knows what is in there.

The prompt I’m using is as follows:

“I don’t like the display column names in the hospital_table output table, can you make these column names cleaner, but just at the last step before it gets displayed.”

It gave a pretty good response to start.

This was the code snippet it provided.

# Show data with cleaner column names
output$hospital_table <- DT::renderDataTable({
  # Create a mapping of current names to cleaner names
  clean_names <- c(
    "FacilityName" = "Hospital Name",
    "FacilityID" = "Hospital ID",
    "City" = "City",
    "County" = "County",
    "Zip" = "ZIP Code",
    "DiagnosisCategory" = "Diagnosis Group",
    "Excess" = "Excess Readmission Ratio",
    "Predicted" = "Predicted Rate (%)",
    "Expected" = "Expected Rate (%)"
    # Add any other columns you want to rename
  )
  
  # Apply the column renaming only at display time
  DT::datatable(current_hospitals(), 
                colnames = clean_names[names(current_hospitals())[names(current_hospitals()) %in% names(clean_names)]])
})

Seems to basically give me what I want. I’d need to copy/paste into the code to enact the changes. This is because, if you notice in the bottom of the screenshot above, it is in Ask mode (one other useful thing to note is that after that one question I went back to my Claude console and saw my balance was $4.93, so that just costed me $0.07).

I changed it to Agent mode and tried again:

To no avail. I just basically got the same output in the chat (and charged another $0.08). So I guess I’ll have to mess with that a little more.

Analysis of the result

The really interesting/impressive part here is that I only used that one prompt and supplied the server.R file (and R environment). Yes it was a simple fix conceptually (i.e., just change the names of the columns). But I didn’t actually specify the column names explicitly in the place where the table is built within the code. They are implied by all the rest of the code and datasets that ship with the app. And it really only edited the columns that needed editing (which wasn’t all of them). So to be clear, it had to:

1. Connect the dots throughout the code base to infer what the current names of the columns in that table would actually be at the time the table is rendered
2. Determine (on its own) which of those current columns were not in a “nice” format (whatever that means, but it got it right)
3. Assign a new name to those columns that is in a “nice” format (which it did)
4. Place the correct code edits to make this happen in the right spot to effect the changes and not break the app (it ran fine).

This. Is. Impressive. I can imagine how powerful this would be if you used this with more than 1 prompt and for more than 10 minutes. Very fun times ahead.

Now I don’t think I’m really scratching the surface of what possibilities this brings to efficiently streamline data science workflows, assist in app development, and more. This was just the baseline integration of Positron Assitant and it’s already awesome. In this application, AI was now used for both development of the code, and in the live application itself. I didn’t even start trying to use DataBot yet, which is another add-on to Positron by Posit that will enable it to actually build analysis and explore your data with you. This, among other things, makes me very excited to be in this field.

The App

Here’s what it looks like in action:

It was deployed to Posit Connect Cloud. That, in combination with using Google Gemini as my LLM provider, made the development and deployment of this app completely free. Feel free to access the live app and/or the source code.

Some Background on Readmissions

The context of this app involves the Hospital Readmissions Reduction Program (HRRP).

Each year hospitals across the United States are penalized by CMS for having too many readmissions in one or more of the following diagnosis groups:

• AMI: Acute myocardial infarction
• CABG: Coronary artery bypass graft surgery
• COPD: Chronic obstructive pulmonary disease
• HF: Heart failure
• TKA/THA: Total hip/knee surgery
• PN: Pneumonia

It is a 3-year reporting period in which the readmissions are tallied, and then the hospital is penalized for the duration of a subsequent fiscal year (the penalty amounts to 3% maximum of all Medicare reimbursements). Only ~50% of hospitals actually receive penalty, and the program only applies to patients on Medicare.

# Load packages
library(tidyverse)

# Function to import dataset from CMS Provider Data Catalog (see https://github.com/zajichek/carecompare/blob/b1fa89382adfe77bd5f230f4162b03767ece10ea/R/FUNCTIONS.R#L99)
pdc_read <-
  function(
    datasetid = NULL,
    ...
  ) {
    
    # Check for input
    if(is.null(datasetid)) 
      stop("Please specify a dataset identifier.")
    
    # Make the url
    url <- paste0("https://data.cms.gov/provider-data/api/1/metastore/schemas/dataset/items/", datasetid, "?show-reference-ids=false")
    
    # Make the request, extract the content
    request <- httr::content(httr::GET(url))
    
    # Update the variable
    downloadurl <- request$distribution[[1]]$data$downloadURL
    
    # Import the dataset
    readr::read_csv(
      file = downloadurl,
      ...
    )
    
  }

## Import datasets

# Hospital information
hospitals <- pdc_read(datasetid = "xubh-q36u", guess_max = 10000) # https://data.cms.gov/provider-data/dataset/xubh-q36u

# HRRP outcomes
hrrp <- pdc_read(datasetid = "9n3s-kdb3", na = c("N/A", "", " ")) # https://data.cms.gov/provider-data/dataset/9n3s-kdb3

hospitals

# A tibble: 5,384 × 38
   `Facility ID` `Facility Name`            Address `City/Town` State `ZIP Code`
   <chr>         <chr>                      <chr>   <chr>       <chr> <chr>     
 1 010001        SOUTHEAST HEALTH MEDICAL … 1108 R… DOTHAN      AL    36301     
 2 010005        MARSHALL MEDICAL CENTERS   2505 U… BOAZ        AL    35957     
 3 010006        NORTH ALABAMA MEDICAL CEN… 1701 V… FLORENCE    AL    35630     
 4 010007        MIZELL MEMORIAL HOSPITAL   702 N … OPP         AL    36467     
 5 010008        CRENSHAW COMMUNITY HOSPIT… 101 HO… LUVERNE     AL    36049     
 6 010011        ST. VINCENT'S EAST         50 MED… BIRMINGHAM  AL    35235     
 7 010012        DEKALB REGIONAL MEDICAL C… 200 ME… FORT PAYNE  AL    35968     
 8 010016        SHELBY BAPTIST MEDICAL CE… 1000 F… ALABASTER   AL    35007     
 9 010018        CALLAHAN EYE HOSPITAL      1720 U… BIRMINGHAM  AL    35233     
10 010019        HELEN KELLER HOSPITAL      1300 S… SHEFFIELD   AL    35660     
# ℹ 5,374 more rows
# ℹ 32 more variables: `County/Parish` <chr>, `Telephone Number` <chr>,
#   `Hospital Type` <chr>, `Hospital Ownership` <chr>,
#   `Emergency Services` <chr>,
#   `Meets criteria for birthing friendly designation` <chr>,
#   `Hospital overall rating` <chr>, `Hospital overall rating footnote` <chr>,
#   `MORT Group Measure Count` <chr>, …

hrrp

# A tibble: 18,510 × 12
   `Facility Name`     `Facility ID` State `Measure Name` `Number of Discharges`
   <chr>               <chr>         <chr> <chr>                           <dbl>
 1 SOUTHEAST HEALTH M… 010001        AL    READM-30-AMI-…                    296
 2 SOUTHEAST HEALTH M… 010001        AL    READM-30-CABG…                    151
 3 SOUTHEAST HEALTH M… 010001        AL    READM-30-HF-H…                    681
 4 SOUTHEAST HEALTH M… 010001        AL    READM-30-HIP-…                     NA
 5 SOUTHEAST HEALTH M… 010001        AL    READM-30-PN-H…                    490
 6 SOUTHEAST HEALTH M… 010001        AL    READM-30-COPD…                    130
 7 MARSHALL MEDICAL C… 010005        AL    READM-30-CABG…                     NA
 8 MARSHALL MEDICAL C… 010005        AL    READM-30-HIP-…                     NA
 9 MARSHALL MEDICAL C… 010005        AL    READM-30-HF-H…                    176
10 MARSHALL MEDICAL C… 010005        AL    READM-30-PN-H…                    305
# ℹ 18,500 more rows
# ℹ 7 more variables: Footnote <dbl>, `Excess Readmission Ratio` <dbl>,
#   `Predicted Readmission Rate` <dbl>, `Expected Readmission Rate` <dbl>,
#   `Number of Readmissions` <chr>, `Start Date` <chr>, `End Date` <chr>

Code summary

This article is mainly focusing on the part of the code that enables the connection and use of LLM’s to chat with the data, but I wanted to make a few notes about the rest of the app. Feel free to browse the complete app source code here.

First, the global.R file creates the objects that are available during the app runtime. It is executed once at app launch. This is where the datasets are imported and cleaned, and the base map of Wisconsin is created (using leaflet). This is done so the app doesn’t have to redraw the map everytime from scratch, only the points need be updated as things change (with leafletProxy). This file is also where the first step for setting up querychat occurs.

Second, the bslib package is used to drive the app layout in ui.R, and works well with querychat. The plots in the app are made with the highcharter package, which I just discovered as an alternative to plotly and I think it may be my new favorite plotting library (but don’t worry, I’ll always continue using the latter + ggplot2). Also, I found the datamods package to be really useful for creating the dynamic group filters in the traditional inputs, which is what makes the hospital filters simultaneously update as other columns are filtered. This is done with the select_group_* functions.

Finally, the general strategy in server.R to implement the toggle between traditional filters and the “chat-mode” was to have a reactive data frame that updates based on conditional logic via the status of the toggle input (via input_switch). We either apply the set of filters to the master dataset in the app, or just provide the dataset returned by the chat object.

Implementing chat functionality

There are two main packages you need to have installed to make this work:

• ellmer: The package drives the backend for sending and receiving messages to the LLM
• querychat: Sets up the UI components and server (using ellmer internally) to chat within your app, build and execute SQL statements on your dataset, and return the result to be used within the app.

# Configure the chat object
querychat_config <- 
  querychat_init(
    df = master_dat,
    tbl_name = "HospitalHRRP",
    create_chat_func = purrr::partial(ellmer::chat_gemini),
    greeting = "Ask me a question about the HRRP in Wisconsin",
    data_description = readLines("data_description.md")
  )

# Chat input
conditionalPanel(
  condition = "input.chat_mode",
  
  # The chat user interface
  querychat_ui(id = "chat")
)

# Make the chat server
querychat <- querychat_server("chat", querychat_config)

# Filter to current hospitals (with metric criteria)
current_hospitals <- 
  reactive({
    
    # Use dataset based on app mode
    if(input$chat_mode) {
      
      # Get the dataset being returned by the chat
      temp_hospitals <- querychat$df()
      
    } else {
      
      # Use the dataset filtered manually
      temp_hospitals <- 
        current_hospitals_temp() |>
        
        # Filter to the specified metric ranges
        filter(
          DiagnosisCategory == input$diagnosis,
          Excess >= min(input$excess), Excess <= max(input$excess),
          Predicted >= min(input$predicted), Predicted <= max(input$predicted),
          Expected >= min(input$expected), Expected <= max(input$expected)
        )
    }
    
    temp_hospitals
    
  })

Deploying the app

As mentioned previously, the app was deployed to Posit Connect Cloud for free (you can have up to 5 live Shiny applications in the free tier). I gave a more detailed description on how you deploy an app to this platform with the LLM API configured in this blog post, so check there for more detail. The main things you need to remember for deployment are to:

• Create your manifest.json file after you’ve completed app development by running rsconnect::writeManifest() so you can capture your app’s dependencies
• Put your code in a public GitHub repository (unless you want to upgrade to a paid tier then you can deploy from private repos)
• Add your GOOGLE_API_KEY (or whatever API you’re using) to the environment variable list while you are configuring your deployment on Posit Connect Cloud

Other than that, things will likely run smooth.

Live app + source code

First, if you wanted to see how the app works and the full code behind it, you can find these here:

• Live app
• Source code

Now on to the tutorial 👇

1. Install the libraries

Of course, we need to make sure shiny is installed.

install.packages("shiny")

Then the brunt of the work here is going to be done by:

• ellmer: What we use to send prompts and receive responses from an LLM
• shinychat: How we create the chat user interface for our application

Both of these are on CRAN, so we can also install them easily.

install.packages("ellmer")
install.packages("shinychat")

2. Choose an LLM provider

You need to choose which LLM you want to facilitate the chat function in your application. ellmer supports all the major ones, and you can scan through the list here.

Many of these require some sort of payment for API usage, but Google Gemini offers free-tier usage, so that’s what I went with. So from that list above, I chose the chat_gemini option.

GOOGLE_API_KEY=XXXXXXXXXXXXXXXXXXXXXXXX <-- FILL IN WITH YOUR KEY

# Load package
library(ellmer)

# Set up chat
chat <- chat_gemini()

Using model = "gemini-2.0-flash".

# Send a prompt
chat$chat("What's a word that rhymes with orange?")

This is a classic riddle! The truth is, there aren't any perfect rhymes for 
"orange" in the English language. 

However, people sometimes use near rhymes or words that rhyme in specific 
dialects. For example:

*   **"Door hinge"** - If you combine two words, you can get a near rhyme.
*   **"Lozenge"** - This is the closest near rhyme you'll find as it sounds 
almost like "lore-inj"

**So, the best answer is: There isn't a perfect rhyme for "orange."**

3. Initialize a new R project

I store my code on GitHub, so I first went there to create a new public repository (you can see mine here).

Then in RStudio, you can create a new project (File -> New Project -> Version Control -> Git). Clone the repository you just made so that your local project is pre-configured to push changes to the remote repo (see here).

4. Develop the system prompt

One of the most important concepts during ShinyConf 2025 was the system prompt. It is how you shape the broader LLM that you’ll be using (in my case, Gemini) to take on a given behavior or persona that you’d like for your application. You set this once upon application start up.

For my purposes, I wanted the chatbot to act like a statistical consultant. Not just any statistical consultant, but one that was very focused on practical application (not statistical significance), as if a business owner was interacting with it trying to use data to make a decision that they needed to take action on soon. This was my system prompt:

“You are a statistical consultant. You are interacting subject matter experts and/or business leaders who are trying to use statistics to take action and make decisions. The person you are talking to is interested in tangible, real-world results and outcomes, so you should problem solve with insofar as to help them achieve those goals. We are not necessarily concerned with things like statistical signifcance or just running tests, unless it is actually relevant to the action or decision point. Instead, focus on the practical steps this person may take, in the context of their problem, to move closer to their desired goal. To do this, you will ask questions about what they are trying to solve, and how we know that what we’ve done provides real value. Then once you’ve gained enough information, you can develop a pragmatic strategy for how they should get started, and what the roadmap may look like. You’re suggestions may include technical things where it makes sense (like tools, methodology, etc.), but should very much be focused on what a non-statistical person might be able to do to further this effort (e.g., better data collection, personnell, etc.)”

You can see the raw file here.

system_prompt <- readLines("system_prompt.txt") 

chat <- chat_gemini(system_prompt = paste(system_prompt, collapse = ""))

5. Put the app together

We haven’t talked about the shinychat package yet, so we’ll do that here as we build the main application file, which you can find here.

# Load packages
library(shiny)
library(bslib)
library(ellmer)
library(shinychat)

# Import system prompt
system_prompt <- readLines("system_prompt.txt") 

ui <- page_fluid(
  chat_ui(
    id = "chat",
    placeholder = "Hi, I'm a statistical consultant, how can I help you?"
  )
)

stream <- chat$stream_async(input$chat_user_input)

server <- function(input, output, session) {
  
  # Setup the chat
  chat <- chat_gemini(system_prompt = paste(system_prompt, collapse = ""))
  
  # Stream responses as they come
  observeEvent(input$chat_user_input, {
    stream <- chat$stream_async(input$chat_user_input)
    chat_append("chat", stream)
  })
  
}

6. Deploy the app

The live app is here.

I used Posit Connect Cloud, which is an awesome platform for deploying data science apps to the web. Basically all complex configuration is done there, we just need to supply the code. And you can do it for free.

rsconnect::writeManifest()

Adding spline terms

Now suppose from the plot above we argue there may be a nonlinear relationship between age and blood pressure, such that it only slightly increases at lower ages and then accelerates in higher ages. So we choose to use a restricted cubic spline with 3 knots:

mod2 <- lm(BP ~ rms::rcs(Age, 3), data = dat)
summary(mod2)

Call:
lm(formula = BP ~ rms::rcs(Age, 3), data = dat)

Residuals:
    Min      1Q  Median      3Q     Max 
-37.817 -11.576  -1.212   9.642  66.782 

Coefficients:
                     Estimate Std. Error t value Pr(>|t|)    
(Intercept)           94.8089    11.2104   8.457 1.22e-15 ***
rms::rcs(Age, 3)Age    0.7016     0.2351   2.984  0.00308 ** 
rms::rcs(Age, 3)Age'  -0.1854     0.2640  -0.702  0.48305    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Residual standard error: 16.91 on 300 degrees of freedom
Multiple R-squared:  0.0827,    Adjusted R-squared:  0.07659 
F-statistic: 13.52 on 2 and 300 DF,  p-value: 2.38e-06

We can see there are now 2 parameters in the model to capture the age effect. We can again plot this to see what it looks like:

# Make a plot
dat |>
  ggplot() +
  geom_point(
    aes(
      x = Age,
      y = BP
    ),
    shape = 21,
    size = 3,
    fill = "brown",
    alpha = .5
  ) +
  geom_line(
    data = tibble(Age = unique(dat$Age), Fitted = predict(mod2, newdata = tibble(Age = unique(dat$Age)))),
    aes(
      x = Age,
      y = Fitted
    ),
    linewidth = 2
  ) +
  xlab("Age (years)") +
  ylab("Systolic blood pressure") +
  theme(
    panel.background = element_blank(),
    axis.title = element_text(size = 16),
    axis.text = element_text(size = 12)
  )

The estimated curve didn’t take the shape of what we suspected (and maybe with more flexibility (i.e., knots), it would), but we’ll run with it anyway.

Writing the regression equation

The question is: how do we write out the formula for this model such that we input an age (in years) and get a predicted blood pressure?

If we did what we did before with simple linear regression and just blindly plug in age to what is given from the model output above, we’d have:

Now if we again compare the output of that equation with what the correct fitted values are from the predict function:

# Gather set of predicted values
preds <-
  tibble(
    BP1 = predict(mod2, newdata = dat),
    BP2 = mod2$coefficients[[1]] + mod2$coefficients[[2]] * dat$Age + mod2$coefficients[[3]] * dat$Age
  )

# Check concordance
with(data = preds, paste0(round(100 * mean(near(BP1, BP2))), "% of fitted values match."))

[1] "0% of fitted values match."

It turns out none of them are correct. So obviously something is wrong.

Find the knot locations

First, we need to figure out what gets inputted into the equation. The coefficient for the second age term in the model output (-0.185) is not multiplied by the raw age value, but rather by some transformation of it.

Specifically, we can recall that age on the original scale will be transformed by a truncated power basis at each knot:

where is the knot location and means we take if and 0 otherwise.

In our example, we have 3 knot locations:

# Extract knot locations
knots <- attr(rms::rcs(dat$Age, 3), "parms")
knots

[1] 42 56 66

We can verify that these are the , and percentiles of the age distribution (which is the default).

quantile(dat$Age, c(.1, .5, .9))

10% 50% 90% 
 42  56  66 

Then, we can write out the full transformation for the spline term using the formula:

Plugging in our quantities, we get:

Ahhh okay. So we need to take our raw age value, first plug it into that formula, and then multiply it by the coefficient from the model’s output. In sloppy notation, something like this:

So we’ll do that, again comparing with the correct output of the predict function:

# Compute the spline value
age_spline <- 
  pmax((dat$Age-knots[1]), 0)^3 - 
  (knots[3] - knots[1])/(knots[3] - knots[2]) * pmax((dat$Age-knots[2]), 0)^3 + 
  (knots[2] - knots[1])/(knots[3] - knots[2]) * pmax((dat$Age-knots[3]), 0)^3

# Add new calculation
preds$BP3 <- mod2$coefficients[[1]] + mod2$coefficients[[2]] * dat$Age + mod2$coefficients[[3]] * age_spline

# Check concordance
with(data = preds, paste0(round(100 * mean(near(BP1, BP3))), "% of fitted values match."))

[1] "12% of fitted values match."

We’re still having problems. It looks like some of the predictions from our new formula match the correct output, but most don’t.

Normalizing the transformation

In the rms::rcs documentation, it states that the default behavior (seen by the norm argument) is to “normalize by the square of the spacing between the first and last knots”. Applying this to our age transformation, our normalization factor is:

So in finding the basis vectors for the spline term, this value was implicitly multiplied through, causing our apparent equation above to be miscalibrated from the original age scale. To remedy this, we simply need to divide the model coefficient for the spline term (-0.185) by the normalization factor. So our equation becomes:

We can again check to see how this compares to the (correct) output of the predict function:

# Compute the normalizing factor
norm_factor <- (knots[3] - knots[1])^2

# Add new calculation
preds$BP4 <- mod2$coefficients[[1]] + mod2$coefficients[[2]] * dat$Age + mod2$coefficients[[3]] / norm_factor * age_spline 

# Check concordance
with(data = preds, paste0(round(100 * mean(near(BP1, BP4))), "% of fitted values match."))

[1] "100% of fitted values match."

Finally, all of our calculated predicted values are correct!

The final formula

We already wrote this out above, if you want to piece together the various components, but we’ll do it again here in one fell swoop.

Now we have an equation that takes an age value as input (in years) and outputs the predicted systolic blood pressure. Finally, we understand exactly how this model works.

Why is this useful?

First, it’s obviously important to understand how modeling software is getting to the results it gives you, so that you can correctly interpret it, among other things. Second, from a pragmatic point of view, the ability to write out the full regression equation allows you embed your model into any application (even Excel if you wanted), instead of requiring the predict function to be run, which in turn would require R to be a part of the application’s server. In this case, it’s unnecessary for that to be a requirement, since we can simply reconcile our model into an easily understandable equation. Luckily, there are also some functions that can extract these formulas for you for this exact purpose so you don’t have to go through the cumbersome calculations above.

Bayesian Thinking

The way I like to think about how Bayesian statistics differs from frequentist methods is that the model is everything. Here, we focus on the model and treat it as a living, breathing object. The data becomes secondary, sometimes an afterthought, and only used as needed in order to update our knowledge about the world as new information comes in.

# Get the density values
x <- seq(0, 1, .01)
y <- dbeta(x, 4.5, 7.5)

# Make the plot
data.frame(x, y) |>
  ggplot() +
  geom_line(
    aes(
      x = x,
      y = y
    )
  ) +
  geom_vline(
    xintercept = c(.2, .5),
    color = "red"
  ) +
  theme(
    panel.background = element_blank(),
    axis.text = element_text(size = 12),
    axis.title = element_text(size = 14),
    axis.title.y = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank()
  ) +
  scale_x_continuous(
    name = "p",
    labels = scales::percent
  )

# Set sample stats
H <- sum(dat$HeartDisease == "Yes")
n <- nrow(dat)

# Get the density values
x <- seq(0, 1, .01)
y <- dbeta(x, 4.5 + H, 7.5 + n - H)

# Make the plot
data.frame(x, y) |>
  ggplot() +
  geom_line(
    aes(
      x = x,
      y = y
    )
  ) +
  geom_vline(
    xintercept = c(.4, .5),
    color = "red"
  ) +
  theme(
    panel.background = element_blank(),
    axis.text = element_text(size = 12),
    axis.title = element_text(size = 14),
    axis.title.y = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank()
  ) +
  scale_x_continuous(
    name = "p",
    labels = scales::percent
  )

# Set values
p <- seq(0, 1, .01)
results <- data.frame(n = 0, p = p, y = dbeta(p, 4.5, 7.5))

# Iterate the grid
for(i in 1:length(n_obs)) {
  
  # Compute estimates
  temp_n <- n_obs[i]
  temp_H<- sum(dat$HeartDisease[1:temp_n] == "Yes")
  temp_y <- dbeta(p, 4.5 + temp_H, 7.5 + temp_n - temp_H)
  
  # Store values
  results <-
    results |>
    rbind(
      data.frame(
        n = temp_n,
        p = p,
        y = temp_y
      )
    )
  
}

# Make the plot
results |>
  ggplot() +
  geom_line(
    aes(
      x = p,
      y = y
    )
  ) + 
  facet_wrap(~paste0("n = ", n) |> forcats::fct_reorder(y, max)) +
  geom_vline(
    xintercept = c(.4, .5),
    color = "red"
  ) +
  theme(
    panel.background = element_blank(),
    axis.text = element_text(size = 10),
    axis.title = element_text(size = 14),
    axis.title.y = element_blank(),
    axis.text.y = element_blank(),
    axis.ticks.y = element_blank()
  ) +
  scale_x_continuous(
    name = "p",
    labels = scales::percent
  )

Benefits

A blog workflow

In short, my preferred approach is based on the Quarto framework, and you can see a step-by-step tutorial here. That’s actually how this very website is built/maintained, which you can find the source code for here. I’ll just touch on some of the steps involved:

Get started

My advice is to get your website workflow up and running first: create the local (default) application, push the code to GitHub, configure Netlify to host the website, and, if you choose, set up your custom domain (again, this last part costs money). Then you can start to make tweaks to your website and make sure everything operates as expected for general maintenance. From there, you can then focus on customizing your website in any way you want, and more importantly, developing the actual content for your blog.

A Shiny intro

One of those tools, which I use almost everyday, is Shiny. It is a free toolkit built primarily for the R programming language (also free), but has recently been made available in Python as well (another free programming language), that enables you to build completely custom analytical web applications for whatever your purpose may be, whether that is for data exploration, dashboards, reporting, predictive modeling, mapping…the possibilities are endless.

Given these are code-first data science tools, there is of course a learning curve. It will take some effort to figure out. The main advantage is that it is free, allowing you to start slow, learn as you go, and progress iteratively. You can start realizing incremental, tangible impact without having to invest tons of money in a product upfront. Additionally, doing this can build the fundamental skills needed to continue maturing the path toward advanced analytics. Cost incurs as it financially makes sense from a value perspective, because you are in total control of what you are producing. In this article, we provide a brief overview of where you can start building and sharing these applications for free.

Where can I share my app?

This is not a tutorial on how to build Shiny apps, as there are tons of resources available to help you begin doing so. However, a big hurdle is often how to get that app off of your computer and in the hands of others for consumption. I’m here to tell you that even that part can be easily done with no cost.

Bottom line: There is infrastructure out there that allows you to easily build and share completely custom, powerful web applications for $0.

Thus, if you are an individual, part of a small team, someone in a big organization, a leader, etc., and want to find better ways to interact with your data, you can begin developing and sharing useful applications with people (or the world). All for free. Which makes it feasible for anyone to begin experimenting, prototyping, and building with minimal risk. Here some of the options for doing so:

git clone https://github.com/centralstatz/ExampleApps.git

# Install the configuration library
install.packages("rsconnect")

# Setup account information
my_user_name <- "<GET_FROM_ACCOUNT>"
my_token <- "<GET_FROM_ACCOUNT>"
my_secret <- "<GET_FROM_ACCOUNT>"
rsconnect::setAccountInfo(
  name = my_user_name,         
  token = my_token,     
  secret = my_secret
)

# Assume we're working in the repo just cloned
rsconnect::deployApp("ReadmissionRiskPool")

rsconnect::writeManifest()

Conclusion

There are many different ways (and this list probably doesn’t come close to covering the possible ones (e.g., Azure App Service)) to start building and sharing data science products for no cost. So, what are you waiting for? Give them a try!

First, what is the readmission risk pool?

We’ll go with a very simple definition:

All patients at risk for hospital readmission at a given point in time.

Let’s use 30-day readmissions as an example. This would be all patients who were discharged from the hospital in the past 30 days who are still at risk for readmission. Meaning that up until the current point in time (i.e., now), they have not already been readmitted or had an otherwise exclusionary event. These are the patients we can still do something about.

From here on out, when we talk about the risk pool, this is what we mean. You can assume in general we’re talking about 30-day readmissions, although nothing about this framework necessarily restricts us to that.

Step 1: Build a (near) real-time data tool

This is simply a data problem.

Before we even begin the conversation about prediction, we should exhaust all efforts to optimize the ability to know what has already happened as close to now as we can. That means purposefully designing a tool that encapsulates the full picture of readmissions for the hospital (system), tying the contributions of individual patients back to aggregated hospital metrics, in (near) real-time. We can think of the types of questions that this would facilitate on-demand, up-to-date answers to, from different areas of hospital administration:

Care Management

• Who is currently in the risk pool?
• Has a patient already received, or is going to receive, a certain intervention?
• What are the patient’s socioeconomic conditions?
• Have they filled their prescriptions?
• What are the payor rules for the services they may need?

Coding/Billing

• Which patients contribute towards the HRRP and/or other relevant metrics?
• What is the readmission risk according to CMS’ (or other programs’) models?
• What risk factors from CMS (or other programs) are currently documented (and are there discrepancies)?

Executive/Leadership

• What is the current (estimated) HRRP penalty amount?
• What share of patients in the (past and present) risk pool affect readmission penalty?
• What is the real-time readmission rate, where has it been, and how will it change under various scenarios with the patients who may affect it?

The goal is to make it actionable for all stakeholders involved by giving them the most pertinent information they need when they need to know it. But doing so in a common, representative, well-connected tool so that the lineage is clear, and everyone is working from the same source of information. I strongly believe that putting in the cross-functional time, nuance, and rigor needed to design and implement tools like this, that mostly consists of figuring out how to move existing data points to a certain location at the right time, would relieve a lot of disconnect and probably give people most of what they need to make effective, informed decisions in a timely manner. Note that existing data points may include determining new ways to collect information as well, not necessarily only sticking with systems in place, as time may be better well-spent establishing new data collection mechanisms that actually measure the thing of interest, rather than jumping through hoops to force conformity of existing sources.

Step 2: What is going to happen?

Now suppose in the tool above, when we click on an individual patient, we want to know what their current risk of readmission is, given everything that has happened since they were discharged. Some patients may only have 5 days left in the risk pool, while others were just recently discharged. Some have had post-discharge clinic visits, some have not. Things have changed since they left the hospital, and we want to find a way to prioritize which ones still need our attention the most. This is where predictive analytics comes in.

Step 3: What should we do about it?

If we’ve gotten to this point, there’s probably some good stuff happening, but we can always go further. Readmission reduction doesn’t necessarily have a one-size-fits-all solution, across different hospital systems or even patient populations within a hospital. Process improvement is a big component of how hospitals operate, and it would be beneficial to have the ability to customize and “try out” various interventions to see what does and doesn’t work and on which patients. Thus, we can use experimentation to rapidly test interventions to help inform what should done for an individual patient. Then, as this data is collected, can feed back into subsequent iterations of the predictive models to better quantify risk for individual patients.

For example, we may want to know whether a text or a phone call is more effective, or if we should auto-schedule follow-up appointments, or send transportation resources to be able to get patients’ prescriptions filled. In considering these things, we want to carefully design a robust infrastructure and data collection mechanisms to enable teams to rapidly test new ideas, but ensure it feeds seamlessly into the overall readmission management strategy, the central tool, and maintains statistical soundness.

Some considerations

• It is important to identify the guiding measures that will objectively indicate if these efforts are paying off. Whether it’s just the overall readmission rate, the HRRP penalty amount, or a much more complex calculation of cost/benefit–allow that to guide development.

• Having cross-functional involvement and buy in is essential. Someone can grab data from a database and build a model on their computer that is really accurate (statistically), but if it doesn’t fit into any clinical/operational workflow or doesn’t have the support it needs to work well in the system, does it really have value? Most of the success of a model in realizing real impact probably has little to do with the math, and mostly to do with the people and implementation.

• Finding ways to leverage previously-established information can provide a head start. If another hospital has developed models that partially work for your patients, can we develop methods such that we augment that with what is needed for our purposes, instead of starting from scratch?

Forming a model

A typical approach for modeling likert-like data is to use a proportional-odds logistic regression model. It is an extension of the widely-used binary logistic regression model, with one key assumption: the ratio of odds between two groups (e.g., ages 35-44 versus 18-34) of being at or above a response level (e.g., satisfied or very satisfied versus neutral, dissatisfied, or very dissatisfied) are proportional (i.e., the same) regardless of where we make that comparison in the outcome. So this odds ratio would also be the same if we instead compared, for example, very satisfied versus everything else.

# Fit the model
mod <-
  MASS::polr(
    formula = QOL ~ Age + Income + Sex,
    data = dat,
    Hess = TRUE
  )

# Make a table of odds-ratios
mod$coefficients |>
  
  # Convert to data frame
  enframe(
    name = "Term",
    value = "Estimate"
  ) |>
  
  # Join to get the CI
  inner_join(
    y = 
      # Get the 95% confidence intervals
      confint(mod) |> 
      
      # Convert to tibble, add the coefficient names
      as_tibble() |> 
      add_column(Term = names(mod$coefficients)),
    by = "Term"
  ) |> 
  
  # Filter to age factor only
  filter(str_detect(Term, "^Age")) |>
  
  # Clean up
  mutate(
    Term = str_remove(Term, "^Age"),
    across(
      where(is.numeric),
      \(x) sprintf("%.2f", 1 / exp(x))
    )
  ) |> 
  
  # Rename
  rename(
    `Age (years)` = Term,
    `Odds-ratio` = Estimate,
    Lower = `97.5 %`,
    Upper = `2.5 %`
  ) |>
  
  # Change location
  relocate(Lower, .before = Upper) |>
  
  # Add the reference row
  add_row(
    `Age (years)` = "18-34",
    `Odds-ratio` = "-",
    Lower = "-",
    Upper = "-",
    .before = 1
  ) |>
  
  # Make a table
  knitr::kable(format = "html") |>
  kableExtra::kable_styling() |>
  kableExtra::add_header_above(c("", "", "95% CI" = 2))

Does the assumption hold?

The question becomes whether that big assumption of proportional-odds actually holds. We may have reason to think, from the data or gut instinct, that it might not. Well, one simple way to check is by directly assessing what it implies.

# Set the number of comparisons
n_comp <- n_distinct(dat$QOL) - 1

# Make each data set
1:n_comp |>
  
  # For each set
  map_df(
    function(.index) {
      
      # Extract the current response set
      temp_resp <- levels(dat$QOL)[1:.index]
      
      # Create binary outcome in the data
      temp_dat <- 
        dat |>
        
        # Create target
        mutate(
          Response = 
            case_when(
              QOL %in% temp_resp ~ 1,
              TRUE ~ 0
            )
        )
      
      # Fit the binary logistic regression model
      temp_mod <-
        glm(
          formula = Response ~ Age + Income + Sex,
          data = temp_dat,
          family = "binomial"
        )
      
      # Make a table of odds-ratios
      temp_mod$coefficients |>
        
        # Convert to data frame
        enframe(
          name = "Term",
          value = "Estimate"
        ) |>
        
        # Join to get the CI
        inner_join(
          y = 
            # Get the 95% confidence intervals
            confint.default(temp_mod) |> 
            
            # Convert to tibble, add the coefficient names
            as_tibble() |> 
            add_column(Term = names(temp_mod$coefficients)),
          by = "Term"
        ) |> 
        
        # Filter to age factor only
        filter(str_detect(Term, "^Age")) |>
        
        # Clean up
        mutate(
          Term = str_remove(Term, "^Age"),
          across(
            where(is.numeric),
            \(x) exp(x)
          )
        ) |>
        
        # Rename
        rename(
          Age = Term,
          OR = Estimate,
          Lower = `2.5 %`,
          Upper = `97.5 %`
        ) |>
        
        # Add the reference row
        add_row(
          Age = "18-34",
          OR = 1,
          Lower = 1,
          Upper = 1,
          .before = 1
        ) |>
        
        # Attach outcome level
        add_column(QOL = levels(dat$QOL)[.index])
      
    },
    .id = "Order"
  ) |>
  
  # Make the factor
  mutate(
    Order = as.numeric(Order),
    QOL = factor(QOL) |> fct_reorder(Order)
  ) |>
  
  # Make a plot
  ggplot(
    aes(
      x = QOL,
      y = OR,
      group = 1
    )
  ) +
  geom_line(
    aes(
      color = Age
    ),
    linewidth = 1.5
  ) +
  geom_point(
    aes(
      color = Age
    ),
    size = 3
  ) +
  geom_ribbon(
    aes(
      ymin = Lower,
      ymax = Upper,
      fill = Age
    ),
    alpha = .25
  ) +
  geom_hline(yintercept = 1, color = "gray") +
  facet_wrap(~paste0(Age, " years")) +
  coord_cartesian(ylim = c(0, 4)) +
  theme(
    panel.background = element_blank(),
    panel.grid.major.y = element_line(color = "gray"),
    legend.position = "none",
    axis.title = element_text(size = 12),
    axis.text = element_text(size = 12),
    axis.text.x = element_text(angle = 45, size = 10),
    plot.title = element_text(hjust = .5),
    strip.text = element_text(size = 14)
  ) +
  xlab("Response") +
  ylab("Odds-ratio (95% CI) for being at or below response level")

Some takeaways

1. Statistical significance only pertains to the existence of a relationship (under the implied assumptions), not the size of it.

2. You must pay attention to the magnitude of the relationship to gain any meaningful insight.

3. The magnitudes should be translated to the real-world implications of using the information for different decisions or courses of action. In the example above, the market age distribution looks like this:

sim_dat |>
  
  # Make a paneled scatterplot
  ggplot() +
  geom_histogram(
    aes(
      x = Age
    ),
    fill = "gray",
    color = "black",
    alpha = .5
  ) +
  theme(
    panel.background = element_blank(),
    legend.position = "none",
    strip.text = element_blank(),
    axis.text = element_text(size = 14),
    axis.title = element_text(size = 16)
  ) +
  xlab("Customer Age (years)") +
  ylab("Customers")

Although older customers yield higher sales, it may cost more marketing dollars to acquire any given individual from such a small segment, ultimately making the juice not worth the squeeze. Feeding estimates into cost-benefit or what-if scenarios can greatly increase confidence in how a proposed course of action would actually play out, instead of implementing things on the basis of mere existence (i.e., statistical significance).

1. Assemble your team…early

It’s often a misconception that the statistician’s role is to simply analyze, or “run the tests on”, the data at the end once it is collected. This is far from optimal. Statistical analysis is not systematic or mechanical. Rather, it requires knowledge and intuition about the subject matter context. Add in a lack of transparency to the data collection itself, the chances of lost insight definitely increase. In fact, it might be the case that a few poor design choices end up adding huge complexities in answering the original question, or maybe even make it impossible altogether. So, if you have a project idea, consult your statistician! Early and often during the development phase.

Now, data people are certainly not the only ones you need involved early. Far from it. Who better to help shape the final product than the end-users—the people who will actually be using the information and know what works? If you want to integrate models into your operational workflow, what sort of resource or technical constraints may there be? Well, we probably have to talk to systems and IT people who will also likely need to commit their own resources for upkeep. And it comes full circle, because all of these nuances may even affect the statistical choices made from a mathematical perspective (i.e., design, modeling framework, etc.). There are plenty more important roles that could be described here, but the bottom line is that cross-functional collaboration, from the beginning, is crucial.

2. Make the goals clear, then plan accordingly

There is a common issue in data projects of ambiguous or non-specific objectives. Statistics is inherently “gray”, by definition, because there is no right answer. Uncertainty always exists. So unless you already know exactly what you’re looking for in the data, without a clearly defined goal, you can find yourself spinning in circles and never know when what you’ve done is sufficient to move on.

My recommendation is to have multiple levels: the statistical goals and the real-world goals that they are supporting. The statistical goals should be stated as clear, specific questions with quantitative answers that data (among other things) will be used to estimate. However, we have to think about how these statistical quantities will be used afterwards. For example, the approach taken to estimate the likelihood of a customer buying a product (a statistical goal) may differ if we’re trying to decrease costs versus increase retention, especially when thinking about the solution as a whole. The question comes down to what we are trying to accomplish with the new information. Once that is clear, we can envision the roadmap for how it will be used, which can be an anchor for developing the right methodology, making analytic decisions easier to manage.

3. Think about taking action

Once you obtain the new information you set out to find, what are you going to do about it? Under what circumstances? Based on which results? Having some inkling as to what it is going to enable (or disable) someone to do–not just in general, but a specific example–adds clarity to the practical implications of investing the time and money into finding the answers. These things can unravel many of the nuances that were originally an oversight, and may end up causing changes to how the information gets disseminated, who gets involved and when, or even the math itself. All in all, it allows for more proper design at the beginning, a reduction of wasted time/resources, and a better chance of finding the right solution. The reason we perform statistical analysis is (or should be) to inform some action or decision. If it doesn’t, then you may need to think about why that is and adjust. My favorite way to frame this to someone is by asking a simple question: “If you knew X at time Y then you could do Z. What are X, Y and Z?”.

4. Create a tangible product

It may sound trivial, but it’s worth thinking about (and even explicitly defining). By what means will the result or solution be delivered? To whom? When? How? Is it going to be a comprehensive report or just a number sent in an email? It might even be a model deployed in the organization’s systems and workflows, or an application hosted on the web. These tell you all sorts of things about who should get involved (see #1) and what it will take to get there. It is about ensuring that the right information gets to the right people at the right time in an expected and predictable manner. It can be the case that a data project fails not because of bad statistics or models, but because it wasn’t disseminated optimally. Having a tangible end-product that you can work towards keeps everyone’s eye on the ball, exposes where the problems are, helps you plan deliverables, create milestones, and makes it clear when you are veering off course.

5. Answer the question, “did it work?”

Oftentimes when you look at a statistic like a p-value, it leaves an empty feeling like you haven’t been convinced. That’s because it does not yet directly translate to the real-world impact the new insight is supposed to address. Maybe it’s useful during data analysis, but we should be thinking beyond the inferences made from the sample at hand to what we need to see to convince us that the results really matter. If the information we’ve garnered is actually useful, then we should expect improvements to play out where the rubber meets the road once it is utilized. The most direct way to do this: test it.

Some background

We can represent the state of qubits (like a bit, but in quantum), at a given point in time, as state vectors, which (loosely) correspond to the probability they will be measured in a particular state.

For example, suppose we have a qubit, , that has the following state vector:

The positions of the vector represent the possible states the qubit can be in. Namely, since it’s basically just a bit, 0 (position 1) or 1 (position 2). The entries in the vector represent (again, loosely) the probability that the qubit will take on that state when measured. So in this example,

It will always be measured in the 0 state.

Now suppose we introduce another qubit, . And remember, computers just store information as sequences of bits. This qubit can also only be measured in states 0 or 1. Thus, the possible bit strings are:

	Represents the number…
00
01
10
11

So one possible two-qubit state vector is:

where, again, the positions represent the possible sequences of qubits (00, 01, 10, 11; there will always be possible states, where is the number of qubits), and the entries (for the third time, loosely) represent the probability of measuring that sequence. In this case,

So now we can imagine the more interesting case where more than one entry is non-zero, that is, multiple different states have a positive probability of being measured. Given it still has to lead to a valid probability distribution, this means that the 100% must be distributed amongst the possibilities.

The final thing I’ll leave here is that the entries actually represent the square root of the probability, which is why I’ve been emphasizing probability “loosely”. So the “valid probability distribution” constraint applies to the square of the vector entries. In the first example above, a more complete way to write this would be:

What is entanglement?

The tutorial has us consider a couple of two-qubit state vectors:

If we let , that is, the bit string measured from the qubits, these imply the following:

Notice how both bits change in , but only one changes in . The former is entangled, the latter is not. This is because we cannot separate into superpositions of two individual, one-qubit state vectors. But in , we can:

Implying that will always be measured to 0, and all uncertainty (random variability) lies in measuring . This is known as a product state, because the probabilities in the two-qubit state vector can be determined by a cross-product of the individual ones.

It’s just independence

Statistical independence occurs when the probability of observing an event does not change once we know something about another one. In our case, we can pretty clearly see this holds for but not . Let’s look at the latter case.

From the the two-qubit state vector, we know the possible measurements are 00 or 11. Thus,

Marginally, each qubit has an equal chance of being measured 0 or 1. But once we know something about the state of the other qubit, this changes:

We could flip those around and condition on and we’d end up with the same result. What this shows is that in the entangled state,

implying

and therefore are not independent. Once we know (measure) one qubit, we automatically know what the other one will be. If you go through the same math for , you’ll see the marginal and conditional probabilities are in fact equal, and thus independent.

Now I don’t know if/how this might change once you start introducing more qubits or allow for the full range of phase, but to keep things intuitive, my working definition of quantum entanglement is:

Does the probability of a qubit being measured to a particular state depend on the state of another qubit? If yes, they are entangled; otherwise, they are not.

An experimentation context

Much of the methodology related to hypothesis testing that Fisher developed (along with other fundamental concepts (in 1922) like consistency, efficiency, and sufficiency) was motivated by the specific context he started out in as an agricultural statistician in 1919 at Rothamstead Experimental Station: that of small-sample, randomized experimentation. It is clear in his writings, though maybe implicit, that there were practical things he considered that played into the overall validity of inference, not only whether the p-value crossed a threshold:

“…it is not known whether heterogeneity [of the soil] will be more pronounced in the one or the other direction in which the field is ordinarily cultivated…The effects are sufficiently widespread to make apparent the importance of eliminating the major effects of soil heterogeneity not only in one direction across the field, but at the same time in the direction at right angles to it.”₃

He wasn’t proposing that his methods be mechanically applied, or that the method itself is what proves valid inference. Rather, inherent in that quote is the intuition Fisher had about the subject, the “soil heterogeneity”, that made the implications of the design useful for that situation. This, in combination with his obviously deep statistical knowledge, is what I believe ultimately made the usage of seemingly arbitrary significance thresholds valid in Fisher’s eyes. It’s not that he didn’t want statistical analysis to be “easier” for researchers (and he was somewhat back and forth on this):

“However, his early recommendation and life-long practice prevailed. The desire for standardization trumped the advantages of considering each case on its own merit.”₄

I think he probably just put too much confidence in the implementers of his work to be as critical, meticulous, and simply as brilliant as he was. He never conceived of the erroneous ways his statistical and design principles would later be used.

He had a mentor

One of the most fascinating aspects of the history of classical statistics is the role of William Sealy Gosset (a.k.a. “Student”, as in Student’s t-test). For his entire career, he was a beer brewer at Arthur Guinness Son and Co. (one of my favorites), yet he is credited with putting forth, through his own curiosity, intelligence, and need of practical solutions for quality control efforts, the ideas of which Fisher would ultimately bring to fruition:

“After a small-sample (”exact”) approach to testing was initiated by Gosset (“Student”) in 1908 with his t-test, Fisher in the 1920’s, under frequent prodding by Gosset, developed a battery of such tests, all based on the assumption of normality. These tests today still constitute the bread and butter of much of statistical practice.”₄

That “frequent prodding” Lehmann is talking about, in addition to the timeline, is why I characterize Gosset more like a mentor. Fisher was 14 years younger, but incredibly gifted intellectually.

“He [Gosset] then had the crucial insight that exact results [for a t-test] could be obtained by making an additional assumption…although he was not able to give a rigorous proof. The first proof was obtained (although not published) by Fisher in 1912…as a result of constant prodding and urging by Gosset, he found a number of additional small-sample distributions, and in 1925 presented the totality of these results in his book…getting Fisher to develop this methodology much further than he (Fisher) had originally intended.”₄

Fisher was only 22 years old in 1912. It seems Gosset’s wisdom helped him pinpoint the arguments he would come to make, and ultimately gave him the encouragement and motivation to see it through. Without that, who knows if any of it would have been done.

“This passage suggests that Fisher thought these problems to be difficult, and that he had no plans to work on them himself. However, in April 1922 he received two letters from Gosset that apparently changed his mind.”₄

Not to mention Gosset’s influence on Neyman’s (and Egon Pearson’s) foundational work regarding the “consideration of the alternatives (suggested by Gosset)”, Fisher did acknowledge his contributions and spoke highly of him.

“…an exact solution of the distribution of regression coefficients…has been outstanding for many years; but the need for its solution was recently brought home to the writer by correspondence with ‘Student’, whose brilliant researches in 1908 form the basis of the exact solution”₅

He was in fact, a genius

Despite their “disdain” for one another:

“Both Fisher and Neyman believed that they had made important contributions to the philosophy of science, but each felt that the other’s views were completely wrong-headed.”₄

Much of their foundational work was complimentary. Fisher supplied the methodology, Neyman put the rubber stamp on it with mathematical proofs.

The thing that caught my attention that Lehmann mentions multiple times in the book is the way Fisher came up with those methods.

“Fisher’s tests were solely based on his intuition. The right choice of test statistics was obvious to him. A theory that would justify his choices was developed by Neyman and Pearson in their papers in 1928 and 1933.”₄

As you read about the progression of his work, it’s like all the fundamental statistical concepts pop-up one by one, and you realize the breadth and depth of Fisher’s accomplishments. The idea that this can be attributed to his “intuition” is just remarkable. It wasn’t just in testing, but also in design:

“…the designs in DOE [The Design of Experiments, 1935] were presented without much justification, based entirely on his intuitive understanding of what the situation demanded. But again later writers found justifications by showing that Fisher’s procedures possessed certain optimality properties.”₄

Even when you read Fisher’s passages directly, you get the feeling that it just rolled off his tongue and he was writing down what flowed from his mind. Though what he was writing turned out to be fundamental to statistical practice:

“…much caution should be used before claiming significance for special comparisons… Comparisons suggested by scrutiny of the results themselves are open to suspicion; for if the variants are numerous, a comparison of the highest with the lowest observed value will often appear to be significant, even from undifferentiated material.”₃

In this case, the problem with multiple comparisons. This is the general tone of Fisher’s writings, just nonchalantly bringing up things like power, creating block designs, etc. as “obvious” considerations.

Unfortunately, despite all Fisher did achieve, his stubbornness prevented him from achieving more.

“…Fisher rarely gave an inch. Those holding different views from his own had ‘misread’ him and their statements were ‘incorrect’.”₄

And subsequently, even though he hinted at it with his idea of “sensitiveness”:

“By not utilizing the idea of power, Fisher deprives himself of the ability to resolve one of the most important issues of experimental design, the determination of sample size.”₄

It seems he grew bitter and resentful in older age. For one, Fisher, “the creator of modern statistics”, in his role at University College under Egon Pearson, was “not permitted to teach statistics”. Also, all the progress and innovation in statistics shifted to the United States after Neyman moved there in 1938. People appreciated his foundational work, but they were taking it in a different direction and he was too far away to continue having influence. Nevertheless, his legacy is set in stone.

References

1. Fisher, R.A. (1925). Statistical methods for research workers. Oliver and Boyd: Edinburgh.

2. Fisher, R.A. (1926). The arrangement of field experiments. J. Min. Agric. G. Br. 33:503-513

3. Fisher, R.A. (1935). The Design of Experiments. Oliver and Boyd: Edinburgh.

4. Lehmann, Erich L (2011). Fisher, Neyman, and the Creation of Classical Statistics. Springer New York, NY. https://doi.org/10.1007/978-1-4419-9500-1

5. Fisher, R.A. (1922). The goodness of fit of regression formulae, and the distribution of regression coefficients. J. Roy. Statist. Soc., 85: 597-612