更改输入时闪亮会抛出警告：错误：无法提取不存在的列
Posted
技术标签:
【中文标题】更改输入时闪亮会抛出警告：错误：无法提取不存在的列【英文标题】：When changing input Shiny throws Warning: Error in : Can't extract columns that don't exist 【发布时间】：2021-09-26 11:17:27 【问题描述】：我有一个仪表板，用户可以在其中上传 .xlsx 文件，然后选择列。此外，您可以从全局变量中选择另一列。如果第二列的值与第一列不匹配，则第二列行的单元格将突出显示。在应用程序启动时，一切正常，但是当我再次选择列并点击操作按钮时，我在控制台中看到此错误Warning: Error in : Can't extract columns that don't exist. 但同样，只要我点击操作按钮，数据表就会在@987654322 中呈现@就好了。
我的dput 的iris.xlsx 看起来像这样-
structure(list(date = structure(c(15706, 15707, 15708, 15723,
15740, 15741, 15742, 15771, 15791, 15792, 15855), class = "Date"),
Sepal.Length = c(5.1, 4.9, 4.7, 5.1, 4.9, 5, 5.5, 6.7, 6,
6.7, 5.9), Sepal.Width = c(3.5, NA, NA, NA, NA, NA, NA, 3.1,
3.4, 3.1, 3), Petal.Length = c(1.4, 1.4, 1.3, 1.4, 1.5, 1.2,
1.3, 4.4, 4.5, 4.7, 5.1), Petal.Width = c(0.2, 0.2, 0.2,
0.3, 0.2, 0.2, 0.2, 1.4, 1.6, 1.5, 1.8), Species = c("setosa",
"setosa", "setosa", "setosa", "setosa", "setosa", "setosa",
"versicolor", "versicolor", "versicolor", "virginica")), row.names = c(NA,
11L), class = "data.frame")
这是我的代表-
library(shiny)
library(openxlsx)
library(shinyjs)
library(htmltools)
library(lubridate)
library(DT)
library(dplyr)
#--------------------
#global.R
local_iris <- data.frame(Date= lubridate::mdy(c("1/1/2013","1/2/2013","3/27/2013","3/28/2013",
"1/18/2013","2/4/2013","2/5/2013","2/6/2013")),
SPECLENTH= c(5.1,4.9,4.7,4.6,5,5.4,4.6,5.1),
SPECWIDTH= c(3,7,6, 8,8,9,5,1))
#-------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("xlsxfile", "Choose an xlsx file",
accept = c(".xlsx")),
tags$hr(),
# Input: Select number of rows to display ----
selectInput("disp", "Display",
choices = c(All = "all",
Head = "head"),
selected = "all"),
# Select variables to display ----
uiOutput("checkbox"),
uiOutput("checkbox_2"),
tags$hr(),
uiOutput("joinnow") # instead of conditionalPanel
),
mainPanel(
DT::DTOutput("contents")
)
)
)
server <- function(input, output)
# File handler ----
mydata <- reactive(
req(input$xlsxfile)
inFile <- input$xlsxfile
req(input$xlsxfile,
file.exists(input$xlsxfile$datapath))
openxlsx::read.xlsx(xlsxFile = inFile$datapath,
sheet = 1 ,
detectDates = TRUE,
sep.names = "_")
)
# Dynamically generate UI input when data is uploaded, only sow numeric columns ----
output$checkbox <- renderUI(
selectInput(inputId = "select_var",
label = "Select variables",
choices = c("", names(mydata() %>%
dplyr::select_if(is.numeric))),
selected = NULL,
multiple = FALSE)
)
# Select columns to print ----
df_sel <- reactive(
req(input$select_var)
df_sel <- mydata() %>%
dplyr::select(input$select_var, date)
)
# Same as above but for global.R variable ----
output$checkbox_2 <- renderUI(
if (is.null(mydata())) return(NULL)
selectInput(inputId = "select_var_2",
label = "Select variables",
choices = c("", names(local_iris %>%
dplyr::select_if(is.numeric))),
selected = NULL,
multiple = FALSE)
)
df_sel_global <- reactive(
req(input$select_var_2)
df_sel_global <- local_iris %>%
dplyr::select(input$select_var_2, Date)
)
output$joinnow <- renderUI(
if (is.null(input$xlsxfile)) return()
actionButton("action", "Press after selecting variables")
)
# Join the dataframes together based on a key ----
joined_dfs <- eventReactive(input$action,
df_joi <- dplyr::inner_join(df_sel(), df_sel_global(), by= c("date" = "Date")) %>%
dplyr::select(date,input$select_var,input$select_var_2)
)
# Render data frame ----
matched_val <- reactive(
req(input$action, input$select_var, input$select_var_2)
ifelse(joined_dfs()%>%
dplyr::pull(input$select_var) != joined_dfs()%>%
dplyr::pull(input$select_var_2),
yes= joined_dfs()%>%
dplyr::pull(input$select_var_2),
no= -979025189201)
)
output$contents <- DT::renderDT(server = FALSE,
req(input$action)
DT::datatable(
if(input$disp == "head")
head(joined_dfs())
else
joined_dfs()
, filter = 'top',
extensions = c('Buttons'),
options = list(scrollY = 600,
scrollX = TRUE,
pageLength = 20,
dom = '<"float-left"l><"float-right"f>rt<"row"<"col-sm-4"B><"col-sm-4"i><"col-sm-4"p>>',
lengthMenu= list(c(20, 40, 60, -1),
c('20', '40', '60','All')),
scrollCollapse= TRUE,
lengthChange = TRUE,
widthChange= TRUE,
rownames = TRUE)
) %>%
formatStyle(
columns = 3,
backgroundColor = styleEqual(levels = matched_val(), values = rep("yellow", length(matched_val())))
)
)
# Run ----
shinyApp(ui, server)
感谢您的帮助。
【问题讨论】：
【参考方案1】：有几个问题-
openxlsx::read.xlsx 不读取 xlsx 文件的列名。我已经切换到readxl::read_excel。
当您在反应式表达式中select 时，它会更改数据，因此新列不可用于下一次选择。因此，您会收到警告。在DT::renderDT 中显示表格时在最后执行选择。
local_iris <- data.frame(Date= lubridate::mdy(c("1/1/2013","1/2/2013","3/27/2013","3/28/2013",
"1/18/2013","2/4/2013","2/5/2013","2/6/2013")),
SPECLENTH= c(5.1,4.9,4.7,4.6,5,5.4,4.6,5.1),
SPECWIDTH= c(3,7,6, 8,8,9,5,1))
#-------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("xlsxfile", "Choose an xlsx file",
accept = c(".xlsx")),
tags$hr(),
# Input: Select number of rows to display ----
selectInput("disp", "Display",
choices = c(All = "all",
Head = "head"),
selected = "all"),
# Select variables to display ----
uiOutput("checkbox"),
uiOutput("checkbox_2"),
tags$hr(),
uiOutput("joinnow") # instead of conditionalPanel
),
mainPanel(
DT::DTOutput("contents")
)
)
)
server <- function(input, output)
# File handler ----
mydata <- reactive(
req(input$xlsxfile)
inFile <- input$xlsxfile
req(input$xlsxfile,
file.exists(input$xlsxfile$datapath))
readxl::read_excel(inFile$datapath)
)
# Dynamically generate UI input when data is uploaded, only sow numeric columns ----
output$checkbox <- renderUI(
selectInput(inputId = "select_var",
label = "Select variables",
choices = c("", names(mydata() %>%
dplyr::select_if(is.numeric))),
selected = NULL,
multiple = FALSE)
)
# Select columns to print ----
df_sel <- reactive(
req(input$select_var)
df_sel <- mydata()
df_sel
)
# Same as above but for global.R variable ----
output$checkbox_2 <- renderUI(
if (is.null(mydata())) return(NULL)
selectInput(inputId = "select_var_2",
label = "Select variables",
choices = c("", names(local_iris %>%
dplyr::select_if(is.numeric))),
selected = NULL,
multiple = FALSE)
)
df_sel_global <- reactive(
req(input$select_var_2)
local_iris
)
output$joinnow <- renderUI(
if (is.null(input$xlsxfile)) return()
actionButton("action", "Press after selecting variables")
)
# Join the dataframes together based on a key ----
joined_dfs <- eventReactive(input$action,
df_joi <- dplyr::inner_join(df_sel(), df_sel_global(), by= c("date" = "Date"))
df_joi
)
# Render data frame ----
matched_val <- reactive(
req(input$action, input$select_var, input$select_var_2)
ifelse(joined_dfs()%>%
dplyr::pull(input$select_var) != joined_dfs()%>%
dplyr::pull(input$select_var_2),
yes= joined_dfs()%>%
dplyr::pull(input$select_var_2),
no= -979025189201)
)
output$contents <- DT::renderDT(server = FALSE,
req(input$action)
DT::datatable(
if(input$disp == "head")
head(joined_dfs()%>%
dplyr::select(date,input$select_var,input$select_var_2))
else
joined_dfs() %>%
dplyr::select(date,input$select_var,input$select_var_2)
, filter = 'top',
extensions = c('Buttons'),
options = list(scrollY = 600,
scrollX = TRUE,
pageLength = 20,
dom = '<"float-left"l><"float-right"f>rt<"row"<"col-sm-4"B><"col-sm-4"i><"col-sm-4"p>>',
lengthMenu= list(c(20, 40, 60, -1),
c('20', '40', '60','All')),
scrollCollapse= TRUE,
lengthChange = TRUE,
widthChange= TRUE,
rownames = TRUE)
) %>%
formatStyle(
columns = 3,
backgroundColor = styleEqual(levels = matched_val(), values = rep("yellow", length(matched_val())))
)
)
# Run ----
shinyApp(ui, server)
【讨论】：
嗨罗纳克！谢谢您的帮助。此方法使action 按钮在初次使用后变得毫无意义。在文件上传后每次选择后，表格会立即加载/更新，而无需点击按钮。在这种情况下，我应该删除按钮——现在没有意义。少一件事点击效果更好。
您认为在初始上传后我们仍然可以使用“按下按钮显示表格”功能吗？我把它放在那里的原因是原始数据集中的一些不一致的列。所以按钮背后的想法是，在用户选择列之后，他们可能会在点击按钮之前检查他们的选择——导致连接在重要的列上正常工作。
在您的情况下，彼此之间有太多的反应性依赖关系，但通常我会在observeEvent(input$action ...) 中加载output$contents，因此单击操作按钮时输出会发生变化。
哦，我明白你的意思了。该死的，希望我能设计得更好。无论如何，感谢您的帮助伙伴。保重 :) 再次感谢您！以上是关于更改输入时闪亮会抛出警告：错误：无法提取不存在的列的主要内容，如果未能解决你的问题，请参考以下文章