绘图中的BrushedPoints导致强制逻辑错误（1）

Question

请您指出这段代码中的错误在哪里：

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)

我想从 BrushedPoints 函数获取刷数据样本，以计算 abline 中的线性回归和绘图预测。虽然我收到了错误警告： “ is.null(x) || is.na(x) 中的错误： 'length = 9' 强制转换为 '逻辑(1)'”。 你能在某个地方纠正我的逻辑并指出错误吗？

Answer 1

如果没有我们可以用来解决这个问题的最小工作示例，这是一个相当棘手的问题（无论如何，这对我来说是:)）

您可以尝试这些修改：

# Server code
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$brushed_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 <- 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, '~', input$x))
    lm_model <- lm(model.formula, data = brushed_data)
    return(lm_model)
  })
  
  # Scatter Plot
  output$scatter_Plot <- renderPlot({
    # Get the pipeline data
    data <- views_comments_likes_pipeline()
    
    # Get the brushed data
    brushed_data <- brushedPoints(data, input$brush, xvar = input$x, yvar = input$y)
    
    # Color palette 
    spectral <- c("#FF000060", "#FFA50060", "#FFFF0060", "#00FF0060")
    
    # Assign colors with transparency to each channel
    Color <- with(data, {
      unique_channels <- unique(channel)
      color_mapping <- setNames(spectral[1:length(unique_channels)], unique_channels)
      color_mapping[channel]
    })
    
    # Plot the scatter plot
    plot(data[[input$x]], 
         data[[input$y]], 
         col = Color, pch = 19, bg = 'gray', 
         main = 'Relationships between views, comments and likes', 
         xlab = input$x,
         ylab = input$y)
    grid(col = 'white', lty = 'solid')
    
    # Add regression line if model is available
    if (!is.null(model())) {
      abline(model(), col = 'blue', lwd = 2, lty = 'dashed')
    }
  })
  
  # Model coefficients
  output$model <- renderPrint({
    if (!is.null(model())) {
      summary(model())$coefficients
    } else {
      "No model available. Please select more points."
    }
  })
}

这里我们尝试确保

brushed_data

反应式表达式正确检索用户通过刷选选择的数据。然后使用该数据来使用

lm

计算线性模型。

scatter_Plot

渲染函数绘制数据并（如果我们有有效的模型）使用

abline

覆盖回归线。如果选择了足够的数据点，模型反应表达式将返回线性模型系数，否则返回

NULL

。

在用户界面中：

output$brushed_data <- renderPrint({
  brushed_data <- brushedPoints(views_comments_likes_pipeline(), input$brush,
                                xvar = input$x, yvar = input$y)
  print(brushed_data)
})

在这里，我们现在有了用于显示刷出的数据样本的输出变量名称，以匹配服务器逻辑。侧边栏包含用于选择年份、x 轴和 y 轴变量的输入，主面板显示散点图和回归线（如果适用）。

为了检查这一点，我模拟了一些数据并使用与我的答案相同的服务器逻辑创建了一个简单的应用程序：

df <- data.frame(
  ID = 1:100,
  x = rnorm(100),
  y = rnorm(100)
)

ui <- fluidPage(
  titlePanel("Brushing Example: After Changes"),
  sidebarLayout(
    sidebarPanel(
      h3('Chosen points'),
      verbatimTextOutput('brushed_data')
    ),
    mainPanel(
      plotOutput('scatter_plot', brush = brushOpts(id = 'brush')),
      h3('Model coefficients'),
      verbatimTextOutput('model')
    )
  )
)

server <- function(input, output) {
  output$scatter_plot <- renderPlot({
    plot(df$x, df$y)
    
    # Add regression line (if model exists)
    if (!is.null(model())) {
      abline(model(), col = 'blue', lwd = 2, lty = 'dashed')
    }
  })
  
  output$brushed_data <- renderPrint({
    brushed_data <- brushedPoints(df, input$brush, xvar = 'x', yvar = 'y')
    print(brushed_data)
  })
  
  model <- reactive({
    brushed_data <- brushedPoints(df, input$brush, xvar = 'x', yvar = 'y')
    if(nrow(brushed_data) < 2) {
      return(NULL)
    }
    model.formula <- y ~ x
    lm_model <- lm(model.formula, data = brushed_data)
    lm_model
  })
  
  output$model <- renderPrint({
    if (!is.null(model())) {
      summary(model())$coefficients
    } else {
      "No model available. Please select more points."
    }
  })
}

shinyApp(ui, server)

以下是一些截图：

所以，从图中来看，它似乎按要求工作了:)