Even more factors (#38)

andrewallenbruce · Nov 10, 2023 · 2d9f8a3 · 2d9f8a3
1 parent b7210bb
commit 2d9f8a3
Show file tree

Hide file tree

Showing 5 changed files with 98 additions and 23 deletions.
diff --git a/R/globals.R b/R/globals.R
@@ -118,10 +118,14 @@ utils::globalVariables(c(
   "ep", # <nppes>
   "gender", # <nppes>
   "entity_type", # <nppes>
+  "status", # <nppes>
   "identifier", # <open_payments>
   "y", # <open_payments>
-  "change_type", # <open_payments>
   "covered_recipient_type", # <open_payments>
+  "recipient_state", # <open_payments>
+  "applicable_manufacturer_or_applicable_gpo_making_payment_state", # <open_payments>
+  "covered_recipient_license_state_code1", # <open_payments>
+  "state_of_travel", # <open_payments>
   "nature_of_payment_or_transfer_of_value", # <open_payments>
   "address", # <open_payments>
   "name_1", # <open_payments>
@@ -187,7 +191,9 @@ utils::globalVariables(c(
   "set", # <quality_payment>
   "val", # <quality_payment>
   "score", # <quality_payment>
+  "measure", # <quality_payment>
   "status", # <quality_payment>
+  "category", # <quality_payment>
   "y", # <reassignments>
   "individual_state_code", # <reassignments>
   "group_state_code", # <reassignments>

diff --git a/R/nppes.R b/R/nppes.R
@@ -205,7 +205,8 @@ nppes <- function(npi = NULL,
                       purpose     = dplyr::if_else(purpose == "LOCATION", "PRACTICE", purpose),
                       gender      = fct_gen(gender),
                       entity_type = fct_enum(entity_type),
-                      state       = fct_stabb(state)) |>
+                      state       = fct_stabb(state),
+                      status      = factor(status, levels = "A", labels = "Active")) |>
         cols_nppes(2)
 
       if (rlang::has_name(results, "tx_primary")) results$tx_primary <- as.logical(results$tx_primary)

diff --git a/R/open_payments.R b/R/open_payments.R
@@ -243,9 +243,12 @@ open_payments <- function(year,
                       # yn = c(yncols),
                       dbl = 'dollars',
                       int = c('program_year', 'pay_count')) |> #nolint
-      dplyr::mutate(change_type                            = changed_logical(change_type),
-                    covered_recipient_type                 = covered_recipient(covered_recipient_type),
-                    nature_of_payment_or_transfer_of_value = nature(nature_of_payment_or_transfer_of_value)) |>
+      dplyr::mutate(covered_recipient_type                                         = fct_cov(covered_recipient_type),
+                    recipient_state                                                = fct_stabb(recipient_state),
+                    applicable_manufacturer_or_applicable_gpo_making_payment_state = fct_stabb(applicable_manufacturer_or_applicable_gpo_making_payment_state),
+                    covered_recipient_license_state_code1                          = fct_stabb(covered_recipient_license_state_code1),
+                    state_of_travel                                                = fct_stabb(state_of_travel),
+                    nature_of_payment_or_transfer_of_value                         = nature(nature_of_payment_or_transfer_of_value)) |>
       combine(address,
               c('recipient_primary_business_street_address_line1',
                 'recipient_primary_business_street_address_line2')) |>
@@ -334,25 +337,16 @@ open_payments_error <- function(response) {
     strex::str_before_nth(":", 2)
 }
 
-#' Convert Changed column to logical
+#' Convert covered recipient types to unordered labelled factor
 #' @param x vector
 #' @autoglobal
 #' @noRd
-changed_logical <- function(x){
-  dplyr::case_match(x, "CHANGED" ~ TRUE,
-                       "UNCHANGED" ~ FALSE,
-                       .default = NA)
-}
-
-#' @param x vector
-#' @autoglobal
-#' @noRd
-covered_recipient <- function(x){
-  dplyr::case_match(x,
-        "Covered Recipient Physician" ~ "Physician",
-        "Covered Recipient Non-Physician Practitioner" ~ "Non-Physician",
-        "Covered Recipient Teaching Hospital" ~ "Teaching Hospital",
-        .default = x)
+fct_cov <- function(x) {
+  factor(x,
+         levels = c("Covered Recipient Physician",
+                    "Covered Recipient Non-Physician Practitioner",
+                    "Covered Recipient Teaching Hospital"),
+         labels = c("Physician", "NPP", "Teaching Hospital"))
 }
 
 #' @param x vector

diff --git a/R/quality_payment.R b/R/quality_payment.R
@@ -174,7 +174,8 @@ quality_payment <- function(year,
                              values_fn = list) |>
           tidyr::unnest(c(id, score)) |>
           dplyr::filter(!is.na(id)) |>
-          dplyr::mutate(score = as.double(score)) |>
+          dplyr::mutate(score = as.double(score),
+                        measure = fct_measure(measure)) |>
           tidyr::nest(.by = c(year, npi, type),
                       .key  = "measures")
 
@@ -188,6 +189,7 @@ quality_payment <- function(year,
             values_to     = "status") |>
           dplyr::mutate(x = NULL) |>
           dplyr::filter(!is.na(status) & status != FALSE) |>
+          dplyr::mutate(category = fct_status(category)) |>
           tidyr::nest(.by = c(year, npi, type),
                       .key = "statuses")
 
@@ -299,3 +301,62 @@ cols_qpp <- function(df, step = c("tidy", "nest")) {
 fct_part <- function(x) {
   factor(x, levels = c("Group", "Individual", "MIPS APM"))
 }
+
+#' @autoglobal
+#' @noRd
+fct_status <- function(x) {
+  factor(x,
+         levels = c("engaged",
+                    "opted_into_mips",
+                    "small_practitioner",
+                    "rural_clinician",
+                    "hpsa_clinician",
+                    "ambulatory_surgical_center",
+                    "hospital_based_clinician",
+                    "non_patient_facing",
+                    "facility_based",
+                    "extreme_hardship",
+                    "extreme_hardship_quality",
+                    "quality_bonus",
+                    "extreme_hardship_pi",
+                    "pi_hardship",
+                    "pi_reweighting",
+                    "pi_bonus",
+                    "extreme_hardship_ia",
+                    "ia_study",
+                    "extreme_hardship_cost"),
+         labels = c("Engaged",
+                    "Opted into MIPS",
+                    "Small Practitioner",
+                    "Rural Clinician",
+                    "HPSA Clinician",
+                    "Ambulatory Surgical Center",
+                    "Hospital-Based Clinician",
+                    "Non-Patient Facing",
+                    "Facility-Based",
+                    "Extreme Hardship",
+                    "Extreme Hardship (Quality)",
+                    "Quality Bonus",
+                    "Extreme Hardship (PI)",
+                    "PI Hardship",
+                    "PI Reweighting",
+                    "PI Bonus",
+                    "Extreme Hardship (IA)",
+                    "IA Study",
+                    "Extreme Hardship (Cost)")
+         )
+}
+
+#' @autoglobal
+#' @noRd
+fct_measure <- function(x) {
+  factor(x,
+         levels = c("quality",
+                    "pi",
+                    "ia",
+                    "cost"),
+         labels = c("Quality",
+                    "Promoting Interoperability",
+                    "Improvement Activities",
+                    "Cost"))
+}
diff --git a/vignettes/articles/qpp.Rmd b/vignettes/articles/qpp.Rmd
@@ -24,6 +24,8 @@ options(scipen = 999)
 ```{r}
 library(provider)
 library(furrr)
+library(dplyr)
+library(tidyr)
 ```
 
 ```{r}
@@ -33,8 +35,19 @@ nppes(npi = 1144544834)
 
 ```{r}
 plan(multisession, workers = 4)
-quality_payment_(npi = 1144544834)
+q <- quality_payment_(npi = 1144544834)
 plan(sequential)
+q
 ```
 
 
+```{r}
+select(q, year, statuses) |> 
+  unnest(statuses)
+```
+
+
+```{r}
+select(q, year, measures) |> 
+  unnest(measures)
+```