R/mod_conflict.R

In bayprior: Bayesian Prior Elicitation and Diagnostics for Clinical Trials

# -- Module: univariate conflict -----------------------------------------------

#' @noRd
mod_conflict_ui <- function(id) {
  ns <- NS(id)
  fluidRow(
    shinydashboard::box(
      width = 4, status = "primary", solidHeader = TRUE,
      title = tagList(icon("vial"), " Observed Data"),
      uiOutput(ns("prior_banner")),
      tags$hr(),
      selectInput(ns("data_type"), "Data type",
        choices = c(
          "Binary (events / n)"                 = "binary",
          "Continuous (mean, SD, n)"            = "continuous",
          "Count / Poisson (events / exposure)" = "poisson",
          "Survival (events / follow-up time)"  = "survival"
        )),
      conditionalPanel(
        condition = sprintf("input['%s'] === 'binary'", ns("data_type")),
        numericInput(ns("bin_x"), "Events (x)", 14, 0),
        numericInput(ns("bin_n"), "Sample size (n)", 40, 1)
      ),
      conditionalPanel(
        condition = sprintf("input['%s'] === 'continuous'", ns("data_type")),
        numericInput(ns("cont_mean"), "Observed mean", 0.45, step = 0.01),
        numericInput(ns("cont_sd"),   "Observed SD",   0.18, step = 0.01),
        numericInput(ns("cont_n"),    "Sample size (n)", 50, 1)
      ),
      conditionalPanel(
        condition = sprintf("input['%s'] === 'poisson'", ns("data_type")),
        numericInput(ns("pois_x"), "Event count (x)", 12, 0, step = 1),
        numericInput(ns("pois_n"), "Exposure (person-time)", 100, 0.001, step = 1),
        tags$small(style = "color:#888;",
                   "e.g. 12 adverse events over 100 person-years")
      ),
      conditionalPanel(
        condition = sprintf("input['%s'] === 'survival'", ns("data_type")),
        numericInput(ns("surv_x"), "Events (d)", 20, 0, step = 1),
        numericInput(ns("surv_n"), "Total follow-up time", 400, 0.001, step = 1),
        tags$small(style = "color:#888;",
                   "e.g. 20 deaths over 400 person-months total follow-up")
      ),
      tags$hr(),
      numericInput(ns("alpha"), "Significance level (alpha)",
                   0.05, 0.001, 0.2, 0.005),
      tags$div(
        class = "btn-tip-wrap",
        actionButton(ns("run_btn"), "Run Diagnostics",
                     icon = icon("stethoscope"), class = "btn-primary btn-block"),
        tags$span(class = "btn-tip-text", "Fit a prior in Prior Elicitation first")
      )
    ),
    column(8,
      uiOutput(ns("results_or_placeholder"))
    )
  )
}

#' @noRd
mod_conflict_server <- function(id, shared, active_prior) {
  moduleServer(id, function(input, output, session) {

    output$prior_banner <- renderUI({
      p   <- active_prior()
      cls <- if (is.null(p)) "alert-warning" else "alert-success"
      msg <- if (is.null(p)) "No prior fitted yet." else
        glue::glue("{p$label} ({toupper(p$dist)})")
      tags$div(class = paste("alert", cls),
               style = "font-size:12px; padding:6px;",
               if (is.null(p)) icon("exclamation-triangle") else icon("check"),
               " ", msg)
    })

    data_sum <- reactive({
      switch(input$data_type,
        binary     = list(type = "binary",
                          x    = input$bin_x,
                          n    = input$bin_n),
        continuous = list(type = "continuous",
                          x    = input$cont_mean,
                          sd   = input$cont_sd,
                          n    = input$cont_n),
        poisson    = list(type = "poisson",
                          x    = input$pois_x,
                          n    = input$pois_n),
        survival   = list(type = "survival",
                          x    = input$surv_x,
                          n    = input$surv_n),
        # default -- shouldn't reach here
        list(type = "binary", x = input$bin_x, n = input$bin_n)
      )
    })

    res <- reactiveVal(NULL)

    # Reset results whenever ANY input changes -- prevents stale results
    observeEvent(
      list(active_prior(), input$data_type,
           input$bin_x, input$bin_n,
           input$cont_mean, input$cont_sd, input$cont_n,
           input$pois_x, input$pois_n,
           input$surv_x, input$surv_n,
           input$alpha),
      { res(NULL); shared$conflict <- NULL },
      ignoreInit = TRUE
    )

    observeEvent(input$run_btn, {
      p <- active_prior(); req(p)

      # Prior-data compatibility check
      chk <- .check_prior_data_compat(p, data_sum())
      if (!chk$ok) {
        showNotification(chk$msg, type = "error", duration = 12)
        return(invisible(NULL))
      }
      if (!is.null(chk$msg)) {
        showNotification(chk$msg, type = "warning", duration = 8)
      }

      r <- tryCatch(
        prior_conflict(p, data_sum(), alpha = input$alpha),
        error = function(e) {
          showNotification(paste("Error:", conditionMessage(e)), type = "error")
          NULL
        })
      res(r)
      shared$conflict <- r
      sev <- toupper(r$conflict_severity)
      toast_type <- if (r$conflict_flag) "warn" else "info"
      shinyjs::runjs(paste0(
        "bpToast('Diagnostics complete &#10003; &mdash; Severity: ", sev, "', '",
        toast_type, "', 3500);"
      ))
    })

    # -- Placeholder before run, full results after ---------------------------
    output$results_or_placeholder <- renderUI({
      if (is.null(res())) {
        return(tags$div(
          class = "text-center",
          style = paste0("padding:60px 20px; color:#aaa;",
                         "border:2px dashed #ddd; border-radius:8px;",
                         "margin-top:10px;"),
          icon("vial", style = "font-size:48px; margin-bottom:16px;"),
          tags$h4("No diagnostics run yet", style = "color:#bbb;"),
          tags$p("Enter observed data and click",
                 tags$b("Run Diagnostics"), "to see results.")
        ))
      }

      r  <- res()
      ns <- session$ns

      tagList(
        fluidRow(
          shinydashboard::valueBox(
            round(r$box_pvalue, 4),
            tagList("Box p-value",
              tags$span(
                class = "btn-tip-wrap",
                style = "display:inline; margin-left:4px;",
                icon("circle-info", style = "font-size:11px; color:#ccc; cursor:help;"),
                tags$span(class = "btn-tip-text",
                  "p < 0.05 indicates conflict. Tests if observed data is plausible under the prior predictive distribution.")
              )
            ),
            icon  = icon("vial"),
            color = if (r$conflict_flag) "red" else "green", width = 4),
          shinydashboard::valueBox(
            round(r$surprise_index, 3),
            tagList("Surprise index",
              tags$span(
                class = "btn-tip-wrap",
                style = "display:inline; margin-left:4px;",
                icon("circle-info", style = "font-size:11px; color:#ccc; cursor:help;"),
                tags$span(class = "btn-tip-text",
                  "Standardised distance between prior mean and observed data. > 2 = moderate surprise; > 3 = high surprise.")
              )
            ),
            icon  = icon("bolt"), color = "yellow", width = 4),
          shinydashboard::valueBox(
            round(r$overlap, 3),
            tagList("Overlap coeff.",
              tags$span(
                class = "btn-tip-wrap",
                style = "display:inline; margin-left:4px;",
                icon("circle-info", style = "font-size:11px; color:#ccc; cursor:help;"),
                tags$span(class = "btn-tip-text",
                  "Bhattacharyya overlap between prior and likelihood. 1 = identical; < 0.3 = concerning conflict.")
              )
            ),
            icon  = icon("circle-half-stroke"), color = "blue", width = 4)
        ),
        tags$div(
          class = if (r$conflict_flag) "alert alert-danger" else "alert alert-success",
          style = "margin:10px 0;",
          if (r$conflict_flag) icon("triangle-exclamation") else icon("circle-check"),
          " ",
          tags$strong(glue::glue("Severity: {toupper(r$conflict_severity)}. ")),
          r$recommendation
        ),
        shinydashboard::box(
          width = 12, status = "info", solidHeader = TRUE, collapsible = TRUE,
          title = tagList(
            icon("chart-area"), " Prior - Likelihood - Posterior overlay"
          ),
          shinycssloaders::withSpinner(
            plotly::plotlyOutput(ns("overlay_plot"), height = "300px"),
            color = "#1D9E75"
          )
        )
      )
    })

    output$overlay_plot <- plotly::renderPlotly({
      req(res(), active_prior())
      gp <- withCallingHandlers(
        plot_prior_likelihood(active_prior(), data_sum(), show_posterior = TRUE),
        warning = function(w) {
          if (grepl("different distribution families", conditionMessage(w),
                    fixed = TRUE))
            invokeRestart("muffleWarning")
        }
      )
      plotly::ggplotly(gp) |> .apply_plotly_theme()
    })
  })
}


# -- Module: multivariate Mahalanobis -----------------------------------------

#' @noRd
mod_mahal_ui <- function(id) {
  ns <- NS(id)
  fluidRow(
    shinydashboard::box(
      width = 4, status = "primary", solidHeader = TRUE,
      title = tagList(icon("border-all"), " Multivariate Conflict Setup"),
      tags$small(class = "text-muted",
        "Bivariate (2-endpoint) prior-data conflict check using the",
        "Mahalanobis distance. Tests both endpoints jointly,",
        "accounting for their correlation."),
      tags$br(), tags$br(),
      tags$div(
        class = "alert alert-info",
        style = "font-size:11px; padding:6px; margin-bottom:8px;",
        icon("circle-info"), " ",
        tags$strong("Assumptions:"), " Multivariate Normal summary statistics.",
        tags$br(),
        "For proportion endpoints, enter means and variances on the",
        tags$strong("log-odds scale."),
        "For hazard ratios, use the", tags$strong("log scale."),
        "Results may be unreliable if the Normal approximation is poor.",
        tags$br(), tags$br(),
        tags$strong("Current limitation:"), " Bivariate (k = 2) only.",
        "Three or more endpoints are a planned extension."
      ),
      tags$b("Prior specification"),
      fluidRow(
        column(6, numericInput(ns("pm1"), "Mean - ep.1", 0.35, step = 0.01)),
        column(6, numericInput(ns("pm2"), "Mean - ep.2", 0.60, step = 0.01))
      ),
      fluidRow(
        column(6, numericInput(ns("pv1"), "Var - ep.1",  0.010, step = 0.001)),
        column(6, numericInput(ns("pv2"), "Var - ep.2",  0.015, step = 0.001))
      ),
      numericInput(ns("pcov"), "Covariance (off-diag)", 0.003, step = 0.001),
      tags$hr(),
      tags$b("Observed data"),
      fluidRow(
        column(6, numericInput(ns("om1"), "Mean - ep.1", 0.55, step = 0.01)),
        column(6, numericInput(ns("om2"), "Mean - ep.2", 0.58, step = 0.01))
      ),
      fluidRow(
        column(6, numericInput(ns("ov1"), "Var/n - ep.1", 0.0002, step = 0.00005)),
        column(6, numericInput(ns("ov2"), "Var/n - ep.2", 0.0002, step = 0.00005))
      ),
      numericInput(ns("ocov"), "Covariance/n", 0.00004, step = 0.000005),
      tags$hr(),
      textInput(ns("lbl1"), "Endpoint 1 label", "Response rate"),
      textInput(ns("lbl2"), "Endpoint 2 label", "OS rate"),
      numericInput(ns("alpha"), "Alpha", 0.05, step = 0.005),
      actionButton(ns("run_btn"), "Run Mahalanobis Check",
                   icon = icon("border-all"), class = "btn-primary btn-block")
    ),
    column(8,
      uiOutput(ns("results_or_placeholder"))
    )
  )
}

#' @noRd
mod_mahal_server <- function(id) {
  moduleServer(id, function(input, output, session) {

    res <- reactiveVal(NULL)

    observeEvent(input$run_btn, {
      pm   <- c(input$pm1, input$pm2)
      pcov <- matrix(c(input$pv1, input$pcov, input$pcov, input$pv2), 2, 2)
      om   <- c(input$om1, input$om2)
      ocov <- matrix(c(input$ov1, input$ocov, input$ocov, input$ov2), 2, 2)
      r    <- tryCatch(
        conflict_mahalanobis(pm, pcov, om, ocov,
                             alpha  = input$alpha,
                             labels = c(input$lbl1, input$lbl2)),
        error = function(e) {
          showNotification(paste("Error:", conditionMessage(e)), type = "error")
          NULL
        })
      res(r)
    })

    output$results_or_placeholder <- renderUI({
      if (is.null(res())) {
        return(tags$div(
          class = "text-center",
          style = paste0("padding:60px 20px; color:#aaa;",
                         "border:2px dashed #ddd; border-radius:8px;",
                         "margin-top:10px;"),
          icon("border-all", style = "font-size:48px; margin-bottom:16px;"),
          tags$h4("No check run yet", style = "color:#bbb;"),
          tags$p("Enter prior and observed data, then click",
                 tags$b("Run Mahalanobis Check"), "to see results.")
        ))
      }

      r   <- res()
      col <- if (r$conflict_flag) "red" else "green"

      tagList(
        fluidRow(
          shinydashboard::valueBox(
            round(r$mahal_distance, 3), "Mahalanobis D",
            icon = icon("ruler"), color = "blue", width = 4),
          shinydashboard::valueBox(
            round(r$pvalue, 4), "Chi-sq p-value",
            icon = icon("chart-pie"), color = col, width = 4),
          shinydashboard::valueBox(
            if (r$conflict_flag) "CONFLICT" else "OK", "Status",
            icon = icon("flag"), color = col, width = 4)
        ),
        shinydashboard::box(
          width = 12, status = "info", solidHeader = TRUE, collapsible = TRUE,
          title = tagList(icon("table"), " Per-parameter marginal z-scores"),
          DT::dataTableOutput(session$ns("z_tbl"))
        ),
        tags$div(
          class = if (r$conflict_flag) "alert alert-danger" else "alert alert-success",
          style = "margin:10px 0;",
          if (r$conflict_flag) icon("triangle-exclamation") else icon("check"),
          " ", r$interpretation
        )
      )
    })

    output$z_tbl <- DT::renderDataTable({
      req(res())
      df <- data.frame(
        Endpoint     = res()$labels,
        `Marginal z` = round(res()$marginal_z, 3),
        check.names  = FALSE
      )
      DT::datatable(df, rownames = FALSE,
                    options = list(dom = "t"), class = "compact stripe")
    })
  })
}