请您指出这段代码中的错误在哪里:
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)'”。 你能在某个地方纠正我的逻辑并指出错误吗?
如果没有我们可以用来解决这个问题的最小工作示例,这是一个相当棘手的问题(无论如何,这对我来说是:))
您可以尝试这些修改:
# 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)
以下是一些截图:
所以,从图中来看,它似乎按要求工作了:)