shiny_correlation.R

library(shiny)
library(shinythemes)

someAlpha <- 1

my_red_COR <- "#F87462"
my_steelblue_COR <- "#579DFF"
my_yellow_COR <- "#FAA53D"  # Define the yellow color
my_green_COR <- "#60C6D2"   # Define the green color

# Define the UI
ui <- fluidPage(
  theme = shinytheme("journal"),
  titlePanel("Visualizing the Sample Correlation Coefficient"),
  sidebarLayout(
    sidebarPanel(
      numericInput("num_points_input", "Number of Data Points:", value = 10, min = 1, max = 100),
      actionButton("regenerate_button", "Regenerate Data", icon("refresh"), style = "color: #000000; width: 300px;background-color: #ffffff"),
      
      div("Enter Data Point Manually", style = "font-weight: bold; padding-top: 60px;"), # Static text as a label
      
      # Text input for x_coordinate without bold style
      div(
        textInput("x_coordinate", "X Coordinate:", value = ""),
        style = "font-weight: normal;"  # Remove bold style
      ),
      
      # Text input for y_coordinate without bold style
      div(
        textInput("y_coordinate", "Y Coordinate:", value = ""),
        style = "font-weight: normal;"  # Remove bold style
      ),
      
      actionButton("add_point_button", "Add Point",icon("plus"), style = "color: #000000; width:300px; background-color: #ffffff"),
      
      div("Additional Settings:", style = "font-weight: bold; padding-top: 10px; padding-top: 60px;"), # Static text as a label
      
      div("", style = "font-weight: bold; padding-top: 10px; padding-top: 10px;"), # Static text as a label
      
      actionButton("update_button", "Hide/Show Rectangles",icon("cog"), style = "color: #000000;  width:300px; background-color: #ffffff"),
      
      div("", style = "font-weight: bold; padding-top: 10px; padding-top: 20px;"), # Static text as a label
      
      radioButtons("color_pattern", "Select Color Pattern:" ,
                   choices = c("Blue/Red", "Teal/Orange"),
                   selected = "Blue/Red") # Added radio buttons for color pattern selection
    ),
    
    mainPanel(
      plotOutput("random_plot", height = "600px"),  
      div(
        textOutput("correlation_text"),  # Display Pearson Correlation
        textOutput("variance_x_text"),    # Display Variance of X
        textOutput("variance_y_text"),    # Display Variance of Y
        textOutput("covariance_text"),    # Display Covariance
        textOutput("area_text"),    # Display Covariance
        style = "font-size: 20px; font-weight: normal; margin-top: 10px;"
      ),
      
      # Add the footnote here
      div(
        HTML("For more information:<br>Wagenmakers, E. J., Godmann, H. R., de Ruiter, J.P., & van Doorn, J. (2023).<br><a href='https://psyarxiv.com/gwu8b/download?format=pdf' target='_blank'>Visualizing the Equation for the Sample Correlation Coefficient</a>."),
        style = "font-size: 12px; text-align: center; margin-top: 20px; color: #777;"
      )
    )
  )
)




server <- function(input, output, session) {
  # Initialize an empty dataset
  random_data <- reactiveVal(data.frame(x = numeric(0), y = numeric(0)))
  
  # Create reactive values for mean_x and mean_y
  mean_x <- reactiveVal(0)
  mean_y <- reactiveVal(0)
  
  # Create a reactive for rectangle data
  rectangle_data <- reactive({
    num_points <- input$num_points_input
    
    # Check if random_data is empty or not
    if (nrow(random_data()) == 0) {
      random_data(data.frame(
        x = runif(num_points, min = 0, max = 10),
        y = runif(num_points, min = 0, max = 10)
      ))
    }
    
    # Calculate the means of x and y
    mean_x_val <- mean(random_data()$x)
    mean_y_val <- mean(random_data()$y)
    
    # Update the mean_x and mean_y reactive values
    mean_x(mean_x_val)
    mean_y(mean_y_val)
    
    # Create a data frame with vertices for the rectangles
    rectangle_data <- data.frame(
      x = random_data()$x,
      y = random_data()$y,
      xend = mean_x_val,
      yend = mean_y_val
    )
    
    # Determine the fill color based on the quadrant and selected color pattern
    if (input$color_pattern == "Teal/Orange") {
      rectangle_data$fill <- ifelse(rectangle_data$x > mean_x_val & rectangle_data$y > mean_y_val, my_green_COR,
                                    ifelse(rectangle_data$x <= mean_x_val & rectangle_data$y <= mean_y_val, my_green_COR,
                                           ifelse(rectangle_data$x <= mean_x_val & rectangle_data$y > mean_y_val, my_yellow_COR, my_yellow_COR)))
    } else {
      rectangle_data$fill <- ifelse(rectangle_data$x > mean_x_val & rectangle_data$y > mean_y_val, my_steelblue_COR,
                                    ifelse(rectangle_data$x <= mean_x_val & rectangle_data$y <= mean_y_val, my_steelblue_COR,
                                           ifelse(rectangle_data$x <= mean_x_val & rectangle_data$y > mean_y_val, my_red_COR, my_red_COR)))
    }
    
    return(rectangle_data)
  })
  
  # Create a reactive to track whether rectangles should be updated immediately
  update_rectangles_immediately <- reactiveVal(TRUE)
  
  observeEvent(input$update_button, {
    # Toggle the update rectangles immediately flag
    update_rectangles_immediately(!update_rectangles_immediately())
  })
  
  observeEvent(input$regenerate_button, {
    # Regenerate data and update the plot immediately
    random_data(data.frame(
      x = runif(input$num_points_input, min = 0, max = 10),
      y = runif(input$num_points_input, min = 0, max = 10)
    ))
    
    # Set the flag to TRUE to update rectangles immediately
    update_rectangles_immediately(TRUE)
  })
  
  # Create the basic plot with the x and y mean lines
  output$random_plot <- renderPlot({
    # Set the plot margins to create space below
    par(mar = c(2, 2, 5, 5))
    
    plot(random_data()$x, random_data()$y, type = "n", xlab = "", ylab = "",
         xlim = c(-0.5, 10.5), ylim = c(-0.5, 10.5), main = "", xaxt = "n", yaxt = "n", bty = "n", asp = 1)
    
    abline(h = mean_y(), col = "#101214")  # Horizontal line at mean_y
    abline(v = mean_x(), col = "#101214")  # Vertical line at mean_x
    
    # Add transparent rectangles only if the flag is TRUE
    if (update_rectangles_immediately()) {
      for (i in 1:nrow(rectangle_data())) {
        polygon(c(rectangle_data()$x[i], rectangle_data()$x[i], rectangle_data()$xend[i], rectangle_data()$xend[i]),
                c(rectangle_data()$y[i], rectangle_data()$yend[i], rectangle_data()$yend[i], rectangle_data()$y[i]),
                col = adjustcolor(rectangle_data()$fill[i], alpha.f = 0.5))
      }
    }
    
    # Add custom x and y-axis labels
    axis(1, at = seq(0, 10, by = 2), labels = seq(0, 10, by = 2), lwd = 4, cex = 2, cex.axis = 1.27)
    axis(2, at = seq(0, 10, by = 2), labels = seq(0, 10, by = 2), lwd = 3, las =1, cex.axis = 1.27)
    
    # Add points with grey fill 
    points(random_data()$x, random_data()$y, pch = 19, col = "#596773", bg = "#101214", cex = 1.5, lwd = 2)
  })
  
  # Add a point when the "Add Point" button is clicked
  observeEvent(input$add_point_button, {
    x_coord <- as.numeric(input$x_coordinate)
    y_coord <- as.numeric(input$y_coordinate)
    
    # Check if the coordinates are within the allowed range (0 to 10)
    if (!is.na(x_coord) && !is.na(y_coord) && x_coord >= 0 && x_coord <= 10 && y_coord >= 0 && y_coord <= 10) {
      new_point <- data.frame(x = x_coord, y = y_coord)
      random_data(rbind(random_data(), new_point))
    } else {
      # Display a message if coordinates are out of range
      showModal(modalDialog("Coordinates must be between 0 and 10.", title = "Invalid Coordinates"))
    }
  })
  
  # Calculate and display Pearson Correlation
  output$correlation_text <- renderText({
    if (nrow(random_data()) > 1) {
      paste("Pearson correlation coefficient: ", round(cor(random_data()$x, random_data()$y), 2))
    } else {
      "Not enough data for correlation"
    }
  })
  
  # Calculate and display Variance of X
  output$variance_x_text <- renderText({
    if (nrow(random_data()) > 1) {
      paste("Variance of X :", round(var(random_data()$x), 2))
    } else {
      "Not enough data for variance of X"
    }
  })
  
  # Calculate and display Variance of Y
  output$variance_y_text <- renderText({
    if (nrow(random_data()) > 1) {
      paste("Variance of Y: ", round(var(random_data()$y), 2))
    } else {
      "Not enough data for variance of Y"
    }
  })
  
  # Calculate and display Covariance
  output$covariance_text <- renderText({
    if (nrow(random_data()) > 1) {
      paste("Covariance: ", round(cov(random_data()$x, random_data()$y), 2))
    } else {
      "Not enough data for covariance"
    }
  })
  
  # Calculate and display Blue and Red Rectangle Areas
  output$area_text <- renderText({
    if (nrow(rectangle_data()) > 1) {
      blue_area <- 0
      red_area <- 0
      
      for (i in 1:nrow(rectangle_data())) {
        if ((rectangle_data()$x[i] > mean_x() && rectangle_data()$y[i] > mean_y()) ||
            (rectangle_data()$x[i] <= mean_x() && rectangle_data()$y[i] <= mean_y())) {
          blue_area <- blue_area + abs(mean_x() - rectangle_data()$x[i]) * abs(mean_y() - rectangle_data()$y[i])
        } else {
          red_area <- red_area + abs(mean_x() - rectangle_data()$x[i]) * abs(mean_y() - rectangle_data()$y[i])
        }
      }
      
      paste("Sum of concordant areas: ", round(blue_area, 2) ,"  ;  ",
            "\nSum of discordant areas: ", round(red_area, 2))
    } else {
      "Not enough data for variance of Y"
    }
  })
  
  
}

# Run the Shiny app
shinyApp(ui, server)