BrushedPoints in plot cause error in coercion to logical(1)

20 Views Asked by At

Could you please point out where is the bug in this code:

library(shiny)
library(shinyWidgets)
library(shinyjs)
library(plotly)
library(ggplot2)
library(ggiraph)
library(thematic)
library(ragg)
library(showtext)
library(extrafont)
library(dplyr)
library(lubridate)
library(grDevices)



#Simulate Data for Reproducible Code
# Set the number of observations
{n <- 512

  # Define channel names
  channels <- c("Channel_A", "Channel_B", "Channel_C", "Channel_D")

  # Define months and days of the week
  months <- c("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
  days <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")

  # Create a data frame to store the data
  df <- data.frame()

  # Generate data for each channel
  for (channel in channels) {
    # Generate data for each year
    for (year in 2017:2024) {
      # Generate data for each month
      for (month in months) {
        # Sample durations for each day of the month
        for (day in 1:30) {  # Assuming 30 days per month
          # Sample duration for the specific channel, year, month, and day
          viewCount <- round(runif(n = 1, min = 0, max = 20*1e6))
          commentCount <- round(runif(n = 1, min = 0, max = 16*1e3))
          likeCount <- round(runif(n = 1, min = 0, max = .6*1e6))
          durations <- round(runif(n = 1, min = 4.59, max = 30.7), 1)
          # Sample a random day of the week
          day_of_week <- sample(days, 1)
          # Append the data to the data frame
          df <- rbind(df, data.frame(channel = channel, Year = year, month = month, day = day, publishedDayName = day_of_week, viewCount = viewCount, commentCount = commentCount, likeCount = likeCount, durationMins = durations))
        }
      }
    }
  }
}

thematic_shiny(font = "Pacifico")

# Plotly plotting ####

ui <- fluidPage(
  
  # Select theme
  theme = shinythemes::shinytheme('journal'),
  
  #Style for fonts
  tags$style(HTML("
    body {
      font-family: 'Pacifico', 15px; /*Set up fonts for the page*/
    }
  ")),
  
  # Fix widgets
  tags$head(
    tags$script(HTML('
       $(document).ready(function() {
        // Get the position of the sidebar
        var sidebarPosition = $(".sidebar").offset().top;

        // Function to fix or unfix the sidebar based on scrolling
        function fixSidebar() {
          var scrollTop = $(window).scrollTop();

          if (scrollTop > sidebarPosition) {
            $(".sidebar").addClass("fixed-sidebar");
          } else {
            $(".sidebar").removeClass("fixed-sidebar");
          }
        }

        // Attach the function to the scroll event
        $(window).scroll(fixSidebar);

        // Call the function once to set the initial state
        fixSidebar();
      })
    '))
  ),
  
  # Application title
  titlePanel("Youtube Data science Channels Analytics"),
  
  # Sidebar with a slider input for number of bins
  sidebarLayout(
    sidebarPanel(
      sliderTextInput(
        inputId = "year_slider",
        label = "Select Year",
        choices = as.character(2017:2024),
        selected = "2023",
        width = "300px"
      ),
      # Select variable for x-axis
      selectInput(
        inputId = "x",
        label = "X-axis:",
        choices = c('viewCount', 'commentCount', 'likeCount'),
        selected = 'commentCount'
      ),
      # Select variable for y-axis
      selectInput(
        inputId = "y",
        label = "Y-axis:",
        choices = c('viewCount', 'commentCount', 'likeCount'),
        selected = 'viewCount'
      ),
      h3('Chosen points'),
      verbatimTextOutput('brushed_data'),
      h3('Model coeffcients'),
      verbatimTextOutput('model'),
      actionButton("clear_pipeline", "Clear Pipeline")
    ),
    # Show a plot of the generated distribution
    mainPanel(
      #Scatter block
      fluidRow(
        column(12,
               plotOutput('scatter_Plot',
                          brushOpts(id = 'brush')))
      )
    )
  )
)


server <- function(input, output) {
  
  df$channel <- as.factor(df$channel)
  
  # View_comments_likes
  views_comments_likes_pipeline <- reactive({
    df %>%
      filter(Year == input$year_slider) %>%
      group_by(channel, month, viewCount) %>%
      summarise(viewCount = mean(viewCount),
                commentCount = mean(commentCount),
                likeCount = mean(likeCount))
  })
  
  # View grabbed data sample
  output$brush_data <- renderPrint({
    brushed_data <- brushedPoints(views_comments_likes_pipeline(), input$brush,
                                                xvar = input$x, yvar = input$y)
    print(brushed_data)
  })
  
  # Create Brushed data
  model <- reactive({

    #Brushed data
    brushed_data <- brushedPoints(views_comments_likes_pipeline(), input$brush,
                                  xvar = input$x, yvar = input$y)
    if(nrow(brushed_data) < 2) {
      return(NULL)
    }

    model.formula <- as.formula(paste0(input$y, '~ 1 +', input$x))
    lm_model <-
      lm(data = brushed_data,  model.formula) #%>%
      summary()
    lm_model$coefficients
    lm_model
  })
  
  
  # Scatter Plot
  output$scatter_Plot <- renderPlot({
    par(bg = 'gray', family = 'sans', cex = 1.5)
    
    # model_data <- model()
    # if (is.null(model_data)) {
    #   return(NULL)
    # }
    
    # Create a custom palette to add alpha transparency to colors
    
    # Color palette 
    spectral <- c("#FF000060", "#FFA50060", "#FFFF0060", "#00FF0060")
    
    # Assign colors with transparency to each channel
    Color <- with(views_comments_likes_pipeline(), {
      unique_channels <- unique(channel)
      color_mapping <- setNames(spectral[1:length(unique_channels)], unique_channels)
      color_mapping[channel]
    })
    
    
    p <- plot(x = views_comments_likes_pipeline()[[input$x]], 
              y = views_comments_likes_pipeline()[[input$y]], 
              col = Color, pch = 19, bg = 'gray', 
              main = 'Relationships between views, comments and likes', 
              xlab = input$x,
              ylab = input$y)
      p + grid(col = 'white', lty = 'solid') #+ 
      # abline(intercept = model()[['coefficients']][1], slope = model()[['coefficients']][2], color = 'blue', size = .3, alpha = .6, lty = 'dashed')
  })
  
  
  # Model coefficients
  output$model <- renderPrint({
    model()
  })
}

shinyApp(ui, server)

I want to get brushed data sample from brushedPoints function to calculate linear regression and plot prediction in abline. Although I got an error warning: "Error in is.null(x) || is.na(x) : 'length = 9' in coercion to 'logical(1)'". Can you correct my logic somewhere and point out the bug.

0

There are 0 best solutions below