Rework scoring algorithm to apply globally first and then by site, fi…

…x incorrect interpolation of predicted_risk into predicted_risk_7day
AMPATH · Sep 20, 2024 · 651d160 · 651d160
1 parent 843e79f
commit 651d160
Showing 1 changed file with 14 additions and 12 deletions.
diff --git a/docker-resources/plumber.R b/docker-resources/plumber.R
@@ -361,7 +361,6 @@ predict_risk <- function(.data, cohort, age_category) {
   # the scoring system is that the 90th percentile of risk score are "High Risk" and the 80th percentile are "Medium Risk"
   # we also break this down by location, so every location should have about 20% of its weekly visits flagged
   .data %>%
-    group_by(location_id) %>%
     mutate(
       percentile = percent_rank(predicted_prob_disengage),
       predicted_risk =
@@ -371,10 +370,8 @@ predict_risk <- function(.data, cohort, age_category) {
           .default = NA_character_
         ),
       .keep = "all"
-    ) %>%
-    ungroup() %>%
+    )%>%
     select(-c(percentile)) %>%
-    group_by(location_id) %>%
     mutate(
       percentile = percent_rank(predicted_prob_disengage_7day),
       predicted_risk_7day =
@@ -384,27 +381,32 @@ predict_risk <- function(.data, cohort, age_category) {
           .default = NA_character_
         ),
       .keep = "all"
-    ) %>%
-    ungroup() %>%
+    )%>%
     select(-c(percentile)) %>%
+    group_by(location_id) %>%
     mutate(
       percentile = percent_rank(predicted_prob_disengage),
       predicted_risk =
         case_when(
           percentile >= .9 ~ "High Risk",
           percentile >= .8 & (is.na(predicted_risk) | predicted_risk != "High Risk") ~ "Medium Risk",
           .default = predicted_risk
-        )
-    )%>%
+        ),
+      .keep = "all"
+    ) %>%
+    ungroup() %>%
     select(-c(percentile)) %>%
+    group_by(location_id) %>%
     mutate(
       percentile = percent_rank(predicted_prob_disengage_7day),
       predicted_risk_7day =
         case_when(
           percentile >= .9 ~ "High Risk",
-          percentile >= .8 & (is.na(predicted_risk_7day) | predicted_risk_7day != "High Risk") ~ "Medium Risk",
-          .default = predicted_risk
-        )
-    )%>%
+          percentile >= .8 & (is.na(predicted_risk_7day) | predicted_risk_7day != "High Risk") ~ ~ "Medium Risk",
+          .default = predicted_risk_7day
+        ),
+      .keep = "all"
+    ) %>%
+    ungroup() %>%
     select(-c(percentile))
 }