Adding model prediction dashboard

JBris · JBris · commit 38b95b2bf129 · 2025-10-07T14:13:00.000+13:00
diff --git a/R/stan_vetiver.R b/R/stan_vetiver.R
@@ -44,10 +44,15 @@ handler_predict.brmsfit <- function(vetiver_model, ...) {
     newdata <- req$body
     newdata <- vetiver::vetiver_type_convert(newdata, ptype)
     newdata <- hardhat::scream(newdata, ptype)
-    ret <- predict(vetiver_model$model, new_data = newdata, ...)
-    list(.pred = ret[, "Estimate"],
-         "Q2.5" = ret[, "Q2.5"],
-         "Q97.5" = ret[, "Q97.5"])
+    ret <- predict(vetiver_model$model, new_data = newdata, ndraws = 50, ...)
+    
+    list(.pred = list(
+      list(
+        .pred = ret[, "Estimate"] |> mean(),
+        .pred_lower = ret[, "Q2.5"] |> mean(),
+        .pred_upper = ret[, "Q97.5"] |> mean()
+      )
+    ))
   }
   
 }
diff --git a/app/R/globals.R b/app/R/globals.R
@@ -9,3 +9,4 @@ library(jsonlite)
 library(tibble)
 library(xml2)
 library(tools)
+library(dplyr)
diff --git a/app/api/R/vetiver_integration.R b/app/api/R/vetiver_integration.R
@@ -21,21 +21,22 @@ predict.int_conformal_split <- function(object, new_data, level = 0.95, ...) {
 }
 
 handler_predict.int_conformal_split <- function(vetiver_model, ...) {
-    ptype <- vetiver_model$prototype
-    
-    function(req) {
-      newdata <- req$body
-      newdata <- vetiver::vetiver_type_convert(newdata, ptype)
-      newdata <- hardhat::scream(newdata, ptype)
-      ret <- predict(vetiver_model$model, new_data = newdata, ...)
-      list(.pred = ret)
-    }
-    
+  ptype <- vetiver_model$prototype
+  
+  function(req) {
+    newdata <- req$body
+    newdata <- vetiver::vetiver_type_convert(newdata, ptype)
+    newdata <- hardhat::scream(newdata, ptype)
+    ret <- predict(vetiver_model$model, new_data = newdata, ...)
+    list(.pred = ret)
+  }
+  
 }
 
 vetiver_create_meta.int_conformal_split <-
   function(model, metadata) {
-    vetiver::vetiver_meta(metadata, required_pkgs = c("probably", "workflows", "stacks", "workflowsets"))
+    vetiver::vetiver_meta(metadata,
+                          required_pkgs = c("probably", "workflows", "stacks", "workflowsets"))
   }
 
 vetiver_create_description.brmsfit <- function(model) {
@@ -57,36 +58,37 @@ handler_predict.brmsfit <- function(vetiver_model, ...) {
     newdata <- req$body
     newdata <- vetiver::vetiver_type_convert(newdata, ptype)
     newdata <- hardhat::scream(newdata, ptype)
-    ret <- predict(vetiver_model$model, new_data = newdata, ...)
-    list(
-      .pred = ret[,"Estimate"],
-      "Q2.5" = ret[, "Q2.5"],
-      "Q97.5" = ret[, "Q97.5"]
-    )
+    ret <- predict(vetiver_model$model, new_data = newdata, ndraws = 50, ...)
+    
+    list(.pred = list(
+      list(
+        .pred = ret[, "Estimate"] |> mean(),
+        .pred_lower = ret[, "Q2.5"] |> mean(),
+        .pred_upper = ret[, "Q97.5"] |> mean()
+      )
+    ))
   }
   
 }
 
 predict.cmdstanr_container <- function(model, new_data) {
   data <- list()
-  variable_names <- model$model$variables()$data |> 
+  variable_names <- model$model$variables()$data |>
     names()
   
-  for(variable_name in variable_names) {
-    if(variable_name == "N") {
+  for (variable_name in variable_names) {
+    if (variable_name == "N") {
       data["N"] <- nrow(new_data)
     } else {
       data[[variable_name]] <- new_data[[variable_name]]
       indx_var <- paste0(variable_name, "_J")
-      if(indx_var %in% variable_names) {
+      if (indx_var %in% variable_names) {
         data[[indx_var]] <- model$data[[indx_var]]
       }
     }
   }
   
-  model$model$generate_quantities(
-    model$fit, data = data
-  )$summary() |> dplyr::select(-variable)
+  model$model$generate_quantities(model$fit, data = data)$summary() |> dplyr::select(-variable)
 }
 
 vetiver_create_description.cmdstanr_container <- function(model) {
@@ -110,7 +112,7 @@ handler_predict.cmdstanr_container <- function(vetiver_model, ...) {
     newdata <- hardhat::scream(newdata, ptype)
     ret <- predict(vetiver_model$model, new_data = newdata, ...)
     list(
-      .pred = ret[,"mean"],
+      .pred = ret[, "mean"],
       "sd" = ret[, "sd"],
       "q5" = ret[, "q5"],
       "q95" = ret[, "q95"]
diff --git a/app/server.R b/app/server.R
@@ -26,6 +26,14 @@ server <- function(input, output, session) {
     model_endpoints[[idx]]
   })
   
+  df_features <- reactive({
+    paste(model_endpoint(), "prototype", sep = "/") |>
+      GET() |>
+      content("text") |>
+      fromJSON()
+  }) |>
+    bindCache(input$model_choice)
+  
   df <- reactive({
     paste(model_endpoint(), "data", sep = "/") |>
       GET() |>
@@ -35,6 +43,8 @@ server <- function(input, output, session) {
   }) |>
     bindCache(input$model_choice)
   
+  prediction_df <- reactiveVal(tibble())
+  
   model_card <- reactive({
     paste(model_endpoint(), "card", sep = "/") |>
       GET() |>
@@ -95,6 +105,18 @@ server <- function(input, output, session) {
       model_card_content()
     })
     
+    output$dynamic_features <- renderUI({
+      lapply(names(df_features()), function(feature_name) {
+        feature_type <- df_features()[[feature_name]]$type
+        switch(feature_type,
+               character = textInput(feature_name, label = feature_name, value = "None"),
+               numeric = numericInput(feature_name, label = feature_name, value = 0),
+               select = selectInput(feature_name, label = feature_name, choices = c()),
+               NULL
+        )
+      })
+    })
+
     updateSelectizeInput(
       session, "plot_choice", choices = plot_choices(), server = FALSE,
       selected = plot_choices()[1]
@@ -128,6 +150,51 @@ server <- function(input, output, session) {
     })
   })
   
+  observeEvent(input$clear_predict, { 
+    prediction_df(tibble())
+  })
+  
+  observeEvent(input$predict, {
+    req_body <- reactiveValuesToList(input)[names(df_features())] |>
+      as.tibble()
+
+    preds <- paste(model_endpoint(), "predict", sep = "/") |>
+      POST(
+        body = req_body,
+        encode = "json"
+      ) |>
+      content("text") |>
+      fromJSON()
+    
+    req_body$.pred <- preds$.pred$.pred
+    req_body$.pred_lower <- preds$.pred$.pred_lower
+    req_body$.pred_upper <- preds$.pred$.pred_upper
+    print(req_body)
+    prediction_df(bind_rows(prediction_df(), req_body))
+    
+    output$predictions <- renderPlotly({
+      axes_choices <- axes_choices()
+      x_ax <- x_ax()
+      
+      if((!x_ax %in% axes_choices)) {
+        return()  
+      }
+      
+      if(nrow(prediction_df()) == 0) {
+        return()
+      }
+      
+      (
+        prediction_df() |>
+          ggplot(aes(x=.data[[x_ax]], y=.data[[".pred"]])) +
+          geom_point() +
+          geom_line() +
+          geom_errorbar(aes(ymin = .data[[".pred_lower"]], ymax = .data[[".pred_upper"]]), width = 0.3)
+      ) |>
+        ggplotly()
+    })
+  })
+  
   output$scatter <- renderPlotly({
     axes_choices <- axes_choices()
     x_ax <- x_ax()
diff --git a/app/ui.R b/app/ui.R
@@ -42,6 +42,19 @@ ui <- page_sidebar(
           selectize = TRUE
         )
       ),
+      accordion_panel(
+        "Predictions",
+        tags$style(HTML("
+        #predict {
+          position: sticky;
+          top: 10px;
+          z-index: 1000;
+        }
+      ")),
+        actionButton("predict", "Predict"),
+        htmlOutput("dynamic_features"),
+        actionButton("clear_predict", "Clear Predictions")
+      ),
       accordion_panel(
         "Downloads",
         downloadButton("download_data", "Download Data"),
@@ -60,6 +73,13 @@ ui <- page_sidebar(
         full_screen = TRUE
       )
     ),
+    nav_panel(
+      "Predictions", 
+      card(
+        plotlyOutput("predictions"),
+        full_screen = TRUE
+      )
+    ),
     nav_panel(
       "Histograms", 
       layout_columns(
diff --git a/deployments/k8s/pfr/r-deployment.yaml b/deployments/k8s/pfr/r-deployment.yaml
@@ -18,21 +18,6 @@ spec:
         app: r-pipelines
     spec:
       containers:
-        - image: ghcr.io/plant-food-research-open/shiny-rpipelines:0.1.0
-          imagePullPolicy: Always
-          name: shiny
-          ports:
-            - containerPort: 3838
-              protocol: TCP
-          args:
-            - R
-            - -e
-            - shiny::runApp('/app', launch.browser = FALSE, host = '0.0.0.0', port = 3838)
-          env:
-            - name: AWS_ACCESS_KEY_ID
-              value: user
-            - name: AWS_SECRET_ACCESS_KEY
-              value: password
         - image: h2oai/h2o-open-source-k8s:3.44.0.3
           resources:
             requests:
diff --git a/deployments/k8s/pfr/r-ingress.yaml b/deployments/k8s/pfr/r-ingress.yaml
@@ -17,16 +17,6 @@ spec:
         app: r-pipelines
   ingressClassName: nginx
   rules:
-    - host: shiny.r-pipelines.k8s.dev.pfr.co.nz
-      http:
-        paths:
-          - backend:
-              service:
-                name: r-pipelines
-                port:
-                  name: port-3838
-            path: /
-            pathType: Prefix
     - host: minio.r-pipelines.k8s.dev.pfr.co.nz
       http:
         paths:
@@ -69,7 +59,6 @@ spec:
             pathType: Prefix
   tls:
     - hosts:
-        - "shiny.r-pipelines.k8s.dev.pfr.co.nz"
         - "minio.r-pipelines.k8s.dev.pfr.co.nz"
         - "minio-api.r-pipelines.k8s.dev.pfr.co.nz"
         - "h2o.r-pipelines.k8s.dev.pfr.co.nz"
diff --git a/deployments/k8s/pfr/r-models-deployment.yaml b/deployments/k8s/pfr/r-models-deployment.yaml
@@ -18,6 +18,25 @@ spec:
         app: r-pipelines
     spec:
       containers:
+        - image: ghcr.io/plant-food-research-open/shiny-rpipelines:0.1.0
+          imagePullPolicy: Always
+          name: shiny
+          ports:
+            - containerPort: 3838
+              protocol: TCP
+          args:
+            - R
+            - -e
+            - shiny::runApp('/app', launch.browser = FALSE, host = '0.0.0.0', port = 3838)
+          env:
+            - name: AWS_ACCESS_KEY_ID
+              value: user
+            - name: AWS_SECRET_ACCESS_KEY
+              value: password
+            - name: MODEL_CHOICES
+              value: random_forest,gompertz
+            - name: MODEL_ENDPOINTS
+              value: https://random-forest.model.r-pipelines.k8s.dev.pfr.co.nz,https://gompertz.model.r-pipelines.k8s.dev.pfr.co.nz
         - image: ghcr.io/plant-food-research-open/shiny-rpipelines:0.1.0
           imagePullPolicy: Always
           name: random-forest
diff --git a/deployments/k8s/pfr/r-models-ingress.yaml b/deployments/k8s/pfr/r-models-ingress.yaml
@@ -17,6 +17,16 @@ spec:
         app: r-pipelines
   ingressClassName: nginx
   rules:
+    - host: shiny.r-pipelines.k8s.dev.pfr.co.nz
+      http:
+        paths:
+          - backend:
+              service:
+                name: r-pipelines-models
+                port:
+                  name: port-3838
+            path: /
+            pathType: Prefix
     - host: random-forest.model.r-pipelines.k8s.dev.pfr.co.nz
       http:
         paths:
@@ -39,6 +49,7 @@ spec:
             pathType: Prefix
   tls:
     - hosts:
+        - "shiny.r-pipelines.k8s.dev.pfr.co.nz"
         - "random-forest.model.r-pipelines.k8s.dev.pfr.co.nz"
         - "gompertz.model.r-pipelines.k8s.dev.pfr.co.nz"
       secretName: r-pipelines-models-tls-secret
diff --git a/deployments/k8s/pfr/r-models-services.yaml b/deployments/k8s/pfr/r-models-services.yaml
@@ -14,6 +14,10 @@ spec:
     app: r-pipelines
   type: LoadBalancer
   ports:
+    - name: port-3838
+      protocol: TCP
+      port: 3838
+      targetPort: 3838
     - name: port-8089
       protocol: TCP
       port: 8089
diff --git a/deployments/k8s/pfr/r-services.yaml b/deployments/k8s/pfr/r-services.yaml
@@ -30,10 +30,6 @@ spec:
       protocol: TCP
       port: 9001
       targetPort: 9001
-    - name: port-3838
-      protocol: TCP
-      port: 3838
-      targetPort: 3838
     - name: port-8088
       protocol: TCP
       port: 8088
