Correlation Playground

#| '!! shinylive warning !!': |
#|   shinylive does not work in self-contained HTML documents.
#|   Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 1000

library(shiny)
library(bslib)

scale_to <- function(values, target_mean, target_sd) {
  scaled <- as.numeric(scale(values))
  scaled * target_sd + target_mean
}

ui <- page_sidebar(
  title = "Correlation Playground",
  sidebar = sidebar(
    sliderInput(
      "rho",
      "Target correlation (Pearson r)",
      min = -0.95,
      max = 0.95,
      value = 0.4,
      step = 0.05
    ),
    sliderInput(
      "n",
      "Sample size",
      min = 20,
      max = 400,
      value = 120,
      step = 10
    ),
    numericInput("mean_x", "Mean of X", value = 10),
    numericInput("sd_x", "SD of X", value = 3, min = 0.1, step = 0.1),
    numericInput("mean_y", "Mean of Y", value = 20),
    numericInput("sd_y", "SD of Y", value = 5, min = 0.1, step = 0.1),
    checkboxInput("lock_axes", "Use same axis ranges", value = TRUE),
    actionButton("generate", "Generate new sample", class = "btn-primary w-100 mt-2"),
    helpText("Adjust the sliders to see how Pearson's r and r² respond.")
  ),
  layout_columns(
    card(
      card_header("Scatter plot"),
      plotOutput("scatter", height = "420px")
    ),
    card(
      card_header("Correlation summary"),
      tableOutput("summary"),
      div(class = "small text-muted",
          "r is the Pearson correlation coefficient. r² shows the proportion of variance in Y explained by X.")
    )
  ),
  card(
    card_header("Sample preview"),
    tableOutput("sample_data")
  )
)

server <- function(input, output, session) {
  sample_data <- reactive({
    input$generate
    isolate({
      n <- input$n
      rho <- input$rho
      stopifnot(input$sd_x > 0, input$sd_y > 0)
      x_raw <- rnorm(n)
      z <- rnorm(n)
      y_raw <- rho * as.numeric(scale(x_raw)) + sqrt(pmax(0, 1 - rho^2)) * as.numeric(scale(z))
      data.frame(
        X = scale_to(x_raw, input$mean_x, input$sd_x),
        Y = scale_to(y_raw, input$mean_y, input$sd_y)
      )
    })
  })

  output$scatter <- renderPlot({
    df <- sample_data()
    plot_xlim <- range(df$X)
    plot_ylim <- range(df$Y)
    if (isTRUE(input$lock_axes)) {
      limits <- range(c(plot_xlim, plot_ylim))
      plot_xlim <- limits
      plot_ylim <- limits
    }
    plot(
      df$X,
      df$Y,
      pch = 19,
      col = rgb(13/255, 110/255, 253/255, alpha = 0.6),
      xlab = "X",
      ylab = "Y",
      main = "Sample with specified correlation",
      xlim = plot_xlim,
      ylim = plot_ylim
    )
    abline(lm(Y ~ X, data = df), col = "#dc3545", lwd = 2)
  })

  output$summary <- renderTable({
    df <- sample_data()
    r <- cor(df$X, df$Y)
    r_sq <- r^2
    model <- lm(Y ~ X, data = df)
    data.frame(
      Metric = c("Target r", "Observed r", "Observed r²", "Slope", "Intercept"),
      Value = c(
        round(input$rho, 2),
        round(r, 3),
        round(r_sq, 3),
        round(coef(model)[2], 3),
        round(coef(model)[1], 3)
      )
    )
  }, striped = TRUE, hover = TRUE, width = "100%")

  output$sample_data <- renderTable({
    df <- sample_data()
    head_df <- head(df, 8)
    head_df
  }, striped = TRUE, hover = TRUE, width = "100%")
}

shinyApp(ui, server)