R/distlearn.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# ============================================================================
# R4VN Distribution Learning Studio
# ============================================================================

.r4vn_distlearn_require <- function(package) {
  if (!requireNamespace(package, quietly = TRUE)) {
    stop("Package `", package, "` is required for distlearn(). Install it with install.packages(\"", package, "\").", call. = FALSE)
  }
  invisible(TRUE)
}

#' R4VN Distribution Learning Studio
#'
#' Launches an interactive Shiny application for learning probability
#' distributions. The interface is inspired by the idea of a distribution
#' explorer, but is designed around the R4VN teaching workflow: change
#' parameters, immediately see the distribution, calculate commonly used
#' probability statements, read historical and practical context, simulate
#' data, and copy an equivalent [distdata()] command.
#'
#' @param distribution Initial distribution name. Defaults to `"normal"`.
#' @param launch.browser Passed to [shiny::runApp()].
#' @param port Optional port passed to [shiny::runApp()].
#' @param host Host passed to [shiny::runApp()].
#'
#' @details
#' The Studio currently includes the continuous distributions Normal,
#' Log-normal, Uniform, Exponential, Gamma, Beta, Chi-square, Student's t, F,
#' Weibull, Logistic, Cauchy, Laplace, Gumbel, Pareto, Rayleigh, Triangular,
#' Kumaraswamy, Log-logistic, and Half-normal; and the discrete distributions
#' Bernoulli, Binomial, Poisson, Geometric, Negative binomial,
#' Hypergeometric, Discrete uniform, Beta-binomial, Zero-inflated Poisson,
#' finite Zipf, and Logarithmic series.
#'
#' Each distribution has an interactive probability/density plot and CDF,
#' numerical characteristics, parameter explanations, a historical note,
#' typical applications, cautions, probability/quantile calculation, and
#' simulation. Parameter values may be controlled with sliders or typed
#' directly using numeric inputs.
#'
#' @return Invisibly returns the result of [shiny::runApp()] when the app exits.
#' @export
#'
#' @examples
#' if (interactive()) {
#'   distlearn("binomial")
#' }
distlearn <- function(distribution = "normal", launch.browser = interactive(),
                      port = NULL, host = "127.0.0.1") {
  .r4vn_distlearn_require("shiny")
  registry <- .r4vn_dist_registry()
  start <- tryCatch(.r4vn_dist_find(distribution)$id, error = function(e) "normal")

  grouped_choices <- split(
    vapply(registry, `[[`, character(1), "id"),
    vapply(registry, `[[`, character(1), "category")
  )
  grouped_choices <- lapply(grouped_choices, function(ids) {
    setNames(ids, vapply(registry[ids], `[[`, character(1), "label"))
  })

  css <- "
  :root{--r4vn:#17324d;--r4vn2:#24567a;--soft:#f5f7fa;--line:#dce3ea;--muted:#66727c;}
  body{background:#f5f7fa;font-size:14px;}
  .navbar{box-shadow:0 1px 8px rgba(0,0,0,.08);}
  .r4vn-card{background:#fff;border:1px solid var(--line);border-radius:10px;padding:16px;margin-bottom:14px;box-shadow:0 2px 8px rgba(0,0,0,.035);}
  .r4vn-title{font-size:26px;font-weight:800;color:var(--r4vn);margin-bottom:4px;}
  .r4vn-subtitle{color:#5f6b76;margin-bottom:12px;}
  .r4vn-kpis{display:grid;grid-template-columns:repeat(3,1fr);gap:10px;margin-bottom:12px;}
  .r4vn-kpi{background:#f8fbfd;border-left:4px solid var(--r4vn2);padding:10px 12px;min-height:68px;}
  .r4vn-kpi .k{font-size:12px;color:#66727c;text-transform:uppercase;letter-spacing:.3px;}
  .r4vn-kpi .v{font-size:19px;font-weight:800;color:var(--r4vn);overflow-wrap:anywhere;}
  .r4vn-learn h3{font-size:17px;color:var(--r4vn);font-weight:800;margin-top:6px;}
  .r4vn-param{padding:9px 0;border-bottom:1px solid #edf1f4;}
  .r4vn-param:last-child{border-bottom:0;}
  .r4vn-code{background:#16222d;color:#f5f7fa;border-radius:8px;padding:12px;font-family:monospace;white-space:pre-wrap;overflow-x:auto;}
  .small-note{color:#68747f;font-size:12px;}
  .form-group{margin-bottom:12px;}
  table{background:white;}
  @media(max-width:850px){.r4vn-kpis{grid-template-columns:1fr}.col-sm-4,.col-sm-8{width:100%}}
  "

  ui <- shiny::navbarPage(
    title = shiny::span(class = "r4vn-brand", "R4VN Distribution Learning Studio"),
    id = "main_tab", inverse = FALSE, collapsible = TRUE,
    header = shiny::tagList(shiny::tags$head(shiny::tags$style(shiny::HTML(css)))),

    shiny::tabPanel("Explore",
      shiny::fluidPage(
        shiny::div(class="r4vn-card",
          shiny::div(class="r4vn-title", "Understand a distribution by changing it"),
          shiny::div(class="r4vn-subtitle", "Choose a distribution, move a parameter, and immediately connect the numerical properties with the shape.")),
        shiny::fluidRow(
          shiny::column(4,
            shiny::div(class="r4vn-card",
              shiny::selectInput("distribution", "Distribution", choices=grouped_choices, selected=start, width="100%"),
              shiny::radioButtons("control_mode", "Parameter entry", choices=c("Sliders"="slider","Type values"="numeric"), selected="slider", inline=TRUE),
              shiny::uiOutput("parameter_ui"),
              shiny::radioButtons("plot_type", "Plot", choices=c("Density / mass"="density","CDF"="cdf"), selected="density", inline=TRUE),
              shiny::checkboxInput("show_moments", "Show mean and SD on plot", TRUE)
            )
          ),
          shiny::column(8,
            shiny::div(class="r4vn-card",
              shiny::uiOutput("kpis"),
              shiny::plotOutput("distribution_plot", height="410px"),
              shiny::div(class="small-note", shiny::textOutput("support_note"))
            ),
            shiny::div(class="r4vn-card",
              shiny::tags$h3("Equivalent R4VN command"),
              shiny::div(class="r4vn-code", shiny::textOutput("command_code"))
            )
          )
        )
      )
    ),

    shiny::tabPanel("Probability & quantile",
      shiny::fluidPage(
        shiny::fluidRow(
          shiny::column(4,
            shiny::div(class="r4vn-card",
              shiny::tags$h3("Ask a probability question"),
              shiny::numericInput("prob_x", "Value x", value=0),
              shiny::numericInput("prob_lower", "Lower bound", value=0),
              shiny::numericInput("prob_upper", "Upper bound", value=1),
              shiny::numericInput("quant_prob", "Cumulative probability for quantile", value=.95, min=0, max=1, step=.01),
              shiny::p(class="small-note", "For a discrete distribution, R4VN distinguishes =, <, <=, >, and >=. For a continuous distribution P(X=x)=0, while f(x) is a density."))
          ),
          shiny::column(8,
            shiny::div(class="r4vn-card", shiny::tags$h3("At x"), shiny::tableOutput("point_table")),
            shiny::div(class="r4vn-card", shiny::tags$h3("Interval"), shiny::tableOutput("range_table")),
            shiny::div(class="r4vn-card", shiny::tags$h3("Quantile"), shiny::tableOutput("quantile_table"))
          )
        )
      )
    ),

    shiny::tabPanel("Learn",
      shiny::fluidPage(
        shiny::uiOutput("learn_header"),
        shiny::fluidRow(
          shiny::column(6,
            shiny::div(class="r4vn-card r4vn-learn",
              shiny::tags$h3("History and origin"), shiny::uiOutput("history_text"),
              shiny::tags$h3("When is it used?"), shiny::uiOutput("use_text"),
              shiny::tags$h3("Important interpretation"), shiny::uiOutput("notes_text")
            )
          ),
          shiny::column(6,
            shiny::div(class="r4vn-card r4vn-learn",
              shiny::tags$h3("Parameters"), shiny::uiOutput("parameter_help"),
              shiny::tags$h3("Formula / definition"), shiny::uiOutput("formula_text")
            )
          )
        )
      )
    ),

    shiny::tabPanel("Simulate",
      shiny::fluidPage(
        shiny::fluidRow(
          shiny::column(4,
            shiny::div(class="r4vn-card",
              shiny::numericInput("sim_n", "Sample size", value=1000, min=10, max=100000, step=10),
              shiny::checkboxInput("sim_seed_on", "Use a reproducible seed", FALSE),
              shiny::conditionalPanel("input.sim_seed_on", shiny::numericInput("sim_seed", "Seed", value=1, min=1, step=1)),
              shiny::actionButton("simulate", "Generate sample", class="btn-primary"),
              shiny::p(class="small-note", "R4VN does not set a fixed seed unless you explicitly request one.")
            )
          ),
          shiny::column(8,
            shiny::div(class="r4vn-card", shiny::tableOutput("simulation_summary"), shiny::plotOutput("simulation_plot",height="390px"))
          )
        )
      )
    ),

    shiny::tabPanel("Catalogue",
      shiny::fluidPage(
        shiny::div(class="r4vn-card",
          shiny::tags$h3("Distribution catalogue"),
          shiny::textInput("catalog_search","Search",placeholder="normal, count, survival, heavy tail..."),
          shiny::tableOutput("catalog_table")
        )
      )
    )
  )

  server <- function(input, output, session) {
    spec <- shiny::reactive(registry[[input$distribution]])

    shiny::observeEvent(input$distribution, {
      sp <- registry[[input$distribution]]
      # Useful starting probability questions based on support and median.
      a <- setNames(lapply(sp$params, `[[`, "default"), vapply(sp$params, `[[`, character(1), "name"))
      a <- .r4vn_dist_validate(sp,a)
      med <- suppressWarnings(sp$q(.5,a))
      q25 <- suppressWarnings(sp$q(.25,a)); q75 <- suppressWarnings(sp$q(.75,a))
      if(is.finite(med)) shiny::updateNumericInput(session,"prob_x",value=if(sp$type=="discrete")round(med) else signif(med,4))
      if(is.finite(q25)) shiny::updateNumericInput(session,"prob_lower",value=if(sp$type=="discrete")floor(q25) else signif(q25,4))
      if(is.finite(q75)) shiny::updateNumericInput(session,"prob_upper",value=if(sp$type=="discrete")ceiling(q75) else signif(q75,4))
    }, ignoreInit=TRUE)

    output$parameter_ui <- shiny::renderUI({
      sp <- spec(); mode <- input$control_mode %||% "slider"
      shiny::tagList(lapply(sp$params,function(pa){
        id <- paste0("par_",pa$name)
        if(mode=="numeric") {
          shiny::numericInput(id,pa$label,value=pa$default,min=pa$min,max=pa$max,step=pa$step %||% "any",width="100%")
        } else {
          mn<-pa$min;mx<-pa$max
          if(is.null(mn)||is.null(mx)) shiny::numericInput(id,pa$label,value=pa$default,step=pa$step %||% "any",width="100%")
          else shiny::sliderInput(id,pa$label,min=mn,max=mx,value=pa$default,step=pa$step %||% NULL,width="100%")
        }
      }))
    })

    params <- shiny::reactive({
      sp<-spec(); vals<-setNames(vector("list",length(sp$params)),vapply(sp$params,`[[`,character(1),"name"))
      for(pa in sp$params){v<-input[[paste0("par_",pa$name)]];if(is.null(v))v<-pa$default;vals[[pa$name]]<-v}
      .r4vn_dist_validate(sp,vals)
    })

    result <- shiny::reactive({
      do.call(distdata,c(list(distribution=spec()$id),params(),list(plot=TRUE,show=FALSE,console=FALSE)))
    })

    output$kpis <- shiny::renderUI({
      r<-result();m<-r$raw$moments
      fmt<-function(z)if(is.na(z))"Not defined" else if(is.infinite(z))"Infinite" else format(signif(z,5),trim=TRUE)
      shiny::div(class="r4vn-kpis",
        shiny::div(class="r4vn-kpi",shiny::div(class="k","Mean"),shiny::div(class="v",fmt(m["mean"]))),
        shiny::div(class="r4vn-kpi",shiny::div(class="k","Standard deviation"),shiny::div(class="v",fmt(m["sd"]))),
        shiny::div(class="r4vn-kpi",shiny::div(class="k","Type"),shiny::div(class="v",tools::toTitleCase(spec()$type)))
      )
    })

    output$distribution_plot <- shiny::renderPlot({
      r<-result();plot(r,type=input$plot_type)
      if(isTRUE(input$show_moments)){
        m<-r$raw$moments
        if(is.finite(m["mean"]))graphics::abline(v=m["mean"],lty=2,lwd=1.5)
        if(is.finite(m["mean"])&&is.finite(m["sd"]))graphics::abline(v=c(m["mean"]-m["sd"],m["mean"]+m["sd"]),lty=3)
      }
    })

    output$support_note <- shiny::renderText({paste0("Support: ",.r4vn_dist_support_text(spec(),params()),". Parameters: ",.r4vn_dist_param_text(spec(),params()))})

    output$command_code <- shiny::renderText({
      a<-params();args<-paste(vapply(names(a),function(nm)paste0(nm," = ",format(signif(a[[nm]],6),trim=TRUE)),character(1)),collapse=", ")
      paste0('distdata("',spec()$id,'", ',args,')')
    })

    probability_result <- shiny::reactive({
      do.call(distdata,c(list(distribution=spec()$id),params(),list(x=input$prob_x,lower=input$prob_lower,upper=input$prob_upper,probs=input$quant_prob,plot=FALSE,show=FALSE)))
    })
    output$point_table <- shiny::renderTable(probability_result()$raw$point, digits=7, striped=TRUE, bordered=TRUE, spacing="s")
    output$range_table <- shiny::renderTable(probability_result()$raw$range, digits=7, striped=TRUE, bordered=TRUE, spacing="s")
    output$quantile_table <- shiny::renderTable(probability_result()$raw$quantiles, digits=7, striped=TRUE, bordered=TRUE, spacing="s")

    output$learn_header <- shiny::renderUI({shiny::div(class="r4vn-card",shiny::div(class="r4vn-title",spec()$label),shiny::div(class="r4vn-subtitle",paste(spec()$category," | ",tools::toTitleCase(spec()$type))))})
    output$history_text <- shiny::renderUI(shiny::p(spec()$history))
    output$use_text <- shiny::renderUI(shiny::p(spec()$use))
    output$notes_text <- shiny::renderUI(shiny::p(spec()$notes %||% "No additional caution is recorded."))
    output$formula_text <- shiny::renderUI({if(is.null(spec()$formula))shiny::p("Use the probability/density and cumulative plots to study this distribution; a compact formula is not displayed for this parameterization.") else shiny::div(class="r4vn-code",spec()$formula)})
    output$parameter_help <- shiny::renderUI({
      shiny::tagList(lapply(spec()$params,function(pa)shiny::div(class="r4vn-param",shiny::tags$b(pa$label),shiny::tags$br(),shiny::span(pa$description),shiny::tags$br(),shiny::span(class="small-note",paste0("R4VN argument: `",pa$name,"`")))))
    })

    sim_data <- shiny::eventReactive(input$simulate,{
      a<-params();n<-as.integer(input$sim_n)
      if(!is.finite(n)||n<1L)stop("Simulation sample size must be positive.")
      sp<-spec()
      if(isTRUE(input$sim_seed_on)){
        sd<-as.integer(input$sim_seed)
        had<-exists(".Random.seed",envir=.GlobalEnv,inherits=FALSE);if(had)old<-get(".Random.seed",envir=.GlobalEnv,inherits=FALSE)
        on.exit({if(had)assign(".Random.seed",old,envir=.GlobalEnv)else if(exists(".Random.seed",envir=.GlobalEnv,inherits=FALSE))rm(".Random.seed",envir=.GlobalEnv)},add=TRUE)
        set.seed(sd)
      }
      sp$r(n,a)
    },ignoreInit=FALSE)

    output$simulation_summary <- shiny::renderTable({
      z<-sim_data();data.frame(n=length(z),Mean=mean(z),SD=stats::sd(z),Minimum=min(z),Q1=unname(stats::quantile(z,.25)),Median=stats::median(z),Q3=unname(stats::quantile(z,.75)),Maximum=max(z),check.names=FALSE)
    },digits=5,striped=TRUE,bordered=TRUE)
    output$simulation_plot <- shiny::renderPlot({
      z<-sim_data();sp<-spec();a<-params()
      if(sp$type=="discrete"){
        tb<-table(z);graphics::barplot(tb/sum(tb),xlab="x",ylab="Observed proportion",main=paste0("Simulated ",sp$label," data"))
      } else {
        graphics::hist(z,probability=TRUE,breaks="FD",xlab="x",main=paste0("Simulated ",sp$label," data"))
        grid<-.r4vn_dist_grid(sp,a);graphics::lines(grid,sp$d(grid,a),lwd=2)
      }
    })

    catalog <- data.frame(
      Distribution=vapply(registry,`[[`,character(1),"label"),
      Type=tools::toTitleCase(vapply(registry,`[[`,character(1),"type")),
      Category=vapply(registry,`[[`,character(1),"category"),
      Typical.use=vapply(registry,`[[`,character(1),"use"),
      stringsAsFactors=FALSE,check.names=FALSE
    )
    output$catalog_table <- shiny::renderTable({
      q<-tolower(trimws(input$catalog_search %||% ""));z<-catalog
      if(nzchar(q)){keep<-apply(z,1,function(r)grepl(q,tolower(paste(r,collapse=" ")),fixed=TRUE));z<-z[keep,,drop=FALSE]}
      z
    },striped=TRUE,bordered=TRUE,spacing="xs",sanitize.text.function=function(x)x)
  }

  app <- shiny::shinyApp(ui=ui,server=server)
  shiny::runApp(app,launch.browser=launch.browser,port=port,host=host)
}