在 R / Shiny 中使用每个 select 输入选择不工作/崩溃的 DT DataTables 行实施反馈
Implementing Feedback in R / Shiny with DT DataTables rows per select input choice not working / crashing
我正在尝试建立一个反馈系统。这是我正在尝试构建的一个简化示例。我有一个 DT:datatable，它根据 selected 输入选择使用反馈列呈现。
通过 observeEvent 上的提交按钮提交反馈。所有 UI 和服务器组件大部分都是我想要的。
library(shiny)
library(shinydashboard)
ui <- ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
fluidPage(
fluidRow(
uiOutput('rec_ui')
))
)
)
server <- function(input, output, session) {
mtcarsData <- reactive({
req(input$cyl)
mtcars %>%
filter(cyl == input$cyl) %>%
select(am, wt, hp, mpg)
})
output$rec_ui <- renderUI({
mtcarsData()
mainPanel(
actionButton(
'feedbackButton', 'Submit Feedback', class = 'btn-primary'
),
dataTableOutput(('rec')),
width = 12
)
})
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
observeEvent(input$feedbackButton, {
mtcars <- mtcarsData()
feedbackInput <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcars), function(row_id)
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcars$mpg[row_id],
recommendation_feedback = feedbackInput[row_id],
feedback_timestamp = as.character(Sys.time())
)
)
)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- DT::renderDataTable({
df <- mtcarsData()
feedbackCol <- lapply(1:nrow(df), function(recnum)
as.character(
radioButtons(
paste0('rec', recnum), '',
choices = c('neutral' = 'Neutral', 'good' = 'Good', 'bad' = 'Bad'),
inline = TRUE
)
)
)
feedbackCol <- tibble(Feedback = feedbackCol)
df <- bind_cols(
df,
feedbackCol
)
df %>%
DT::datatable(
extensions = 'FixedColumns',
rownames = FALSE,
escape = FALSE,
class="compact cell-border",
options = list(
pageLength = 10,
lengthChange = FALSE,
scrollX = TRUE,
searching = FALSE,
dom = 't',
ordering = TRUE,
fixedColumns = list(leftColumns = 2),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); } '
),
autoWidth = TRUE,
columnDefs = list(
list(width = '250px', targets = -1)
)
)
)
})
}
shinyApp(ui = ui, server = server)
但是，提交后会发生以下两种情况之一：
- 应用程序崩溃并在
write.table 中出现以下错误。但是，根本原因是这行代码返回了一个 NULL 值列表，而不是我的反馈输入。
Warning: Error in write.table: unimplemented type 'list' in 'EncodeElement'
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
- 当应用程序没有崩溃，并且提交了反馈，但新的输入没有生效。只有第一次提交会重复写入 CSV。
知道这个应用哪里出了问题吗？
附加信息：我的预感是当我从 'fewer rows' DT 的 selection 到更多行时发生崩溃，而不是另一种方法。例如，如果我先 select 8 CYL，它有更多的汽车，然后是 4，应用程序不会在提交时崩溃。但反过来，它确实如此。顺便说一句 - 无论哪种情况，我的反馈都不会更新。
为避免应用程序崩溃，请编写以下行
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
就在write.table()
之前
请注意，lapply returns 是一个列表，因此是您的第一期。
接下来，回收单选按钮中的输入 ID 也是一个问题。通过定义唯一 ID，您可以使其工作。最后，为确保单选按钮始终有效，最好定义新的 ID。如果给定的 cyl 值的 ID 是固定的，它只会在第一次工作。随后选择 cyl 将显示初始选择，可以通过 updateradioButtons 更新，但不会反应。试试这个并根据您的需要修改显示 table。
library(DT)
library(data.table)
library(shiny)
#library(shinyjs)
library(shinydashboard)
options(device.ask.default = FALSE)
ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
#useShinyjs(),
fluidPage(
fluidRow(
actionButton('feedbackButton', 'Submit Feedback', class = 'btn-primary'),
DTOutput('rec'),
verbatimTextOutput("sel")
))
)
)
server <- function(input, output, session) {
cntr <- reactiveVal(0)
rv <- reactiveValues()
mtcarsData <- reactive({
mtcar <- mtcars %>% filter(cyl == input$cyl) %>%
select(cyl, am, wt, hp, mpg)
})
observe({
req(input$cyl,mtcarsData())
mtcar <- mtcarsData()
id <- cntr()
m = data.table(
rowid = sapply(1:nrow(mtcar), function(i){paste0('rec',input$cyl,i,id)}),
Neutral = 'Neutral',
Good = 'Good',
Bad = 'Bad',
mtcar
) %>%
mutate(Neutral = sprintf('<input type="radio" name="%s" value="%s" checked="checked"/>', rowid, Neutral),
Good = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Good),
Bad = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Bad)
)
rv$df <- m
print(id)
})
observeEvent(input$cyl, {
cntr(cntr()+1)
#print(cntr())
},ignoreInit = TRUE)
feedbackInputData <- reactive({
dfa <- req(rv$df)
list_values <- list()
for (i in unique(dfa$rowid)) {
list_values[[i]] <- input[[i]]
}
list_values
})
observeEvent(input$feedbackButton, {
req(input$cyl)
mtcar <- rv$df ## this could be mtcarsData(), if picking columns not in rv$df but only in mtcarsData()
dt <- rv$df
dt$Feedback <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcar), function(row_id){
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcar$mpg[row_id],
recommendation_feedback = dt$Feedback[row_id],
feedback_timestamp = as.character(Sys.time())
)
})
)
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- renderDT(
datatable(
rv$df,
selection = "none",
escape = FALSE,
options = list(
columnDefs = list(list(visible = FALSE, targets = c(0,4))), ## not displaying rowid and cyl
dom = 't',
paging = FALSE,
ordering = FALSE
),
callback = JS(
"table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());"
),
rownames = F
),
server = FALSE
)
### verify if the radio button values are being returned
output$sel = renderPrint({
req(feedbackInputData())
feedbackInputData()
})
}
shinyApp(ui = ui, server = server)
我正在尝试建立一个反馈系统。这是我正在尝试构建的一个简化示例。我有一个 DT:datatable，它根据 selected 输入选择使用反馈列呈现。
通过 observeEvent 上的提交按钮提交反馈。所有 UI 和服务器组件大部分都是我想要的。
library(shiny)
library(shinydashboard)
ui <- ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
fluidPage(
fluidRow(
uiOutput('rec_ui')
))
)
)
server <- function(input, output, session) {
mtcarsData <- reactive({
req(input$cyl)
mtcars %>%
filter(cyl == input$cyl) %>%
select(am, wt, hp, mpg)
})
output$rec_ui <- renderUI({
mtcarsData()
mainPanel(
actionButton(
'feedbackButton', 'Submit Feedback', class = 'btn-primary'
),
dataTableOutput(('rec')),
width = 12
)
})
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
observeEvent(input$feedbackButton, {
mtcars <- mtcarsData()
feedbackInput <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcars), function(row_id)
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcars$mpg[row_id],
recommendation_feedback = feedbackInput[row_id],
feedback_timestamp = as.character(Sys.time())
)
)
)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- DT::renderDataTable({
df <- mtcarsData()
feedbackCol <- lapply(1:nrow(df), function(recnum)
as.character(
radioButtons(
paste0('rec', recnum), '',
choices = c('neutral' = 'Neutral', 'good' = 'Good', 'bad' = 'Bad'),
inline = TRUE
)
)
)
feedbackCol <- tibble(Feedback = feedbackCol)
df <- bind_cols(
df,
feedbackCol
)
df %>%
DT::datatable(
extensions = 'FixedColumns',
rownames = FALSE,
escape = FALSE,
class="compact cell-border",
options = list(
pageLength = 10,
lengthChange = FALSE,
scrollX = TRUE,
searching = FALSE,
dom = 't',
ordering = TRUE,
fixedColumns = list(leftColumns = 2),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); } '
),
autoWidth = TRUE,
columnDefs = list(
list(width = '250px', targets = -1)
)
)
)
})
}
shinyApp(ui = ui, server = server)
但是，提交后会发生以下两种情况之一：
- 应用程序崩溃并在
write.table中出现以下错误。但是，根本原因是这行代码返回了一个NULL值列表，而不是我的反馈输入。
Warning: Error in write.table: unimplemented type 'list' in 'EncodeElement'
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
- 当应用程序没有崩溃，并且提交了反馈，但新的输入没有生效。只有第一次提交会重复写入 CSV。
知道这个应用哪里出了问题吗？
附加信息：我的预感是当我从 'fewer rows' DT 的 selection 到更多行时发生崩溃，而不是另一种方法。例如，如果我先 select 8 CYL，它有更多的汽车，然后是 4，应用程序不会在提交时崩溃。但反过来，它确实如此。顺便说一句 - 无论哪种情况，我的反馈都不会更新。
为避免应用程序崩溃，请编写以下行
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
就在write.table()
请注意，lapply returns 是一个列表，因此是您的第一期。
接下来，回收单选按钮中的输入 ID 也是一个问题。通过定义唯一 ID，您可以使其工作。最后，为确保单选按钮始终有效，最好定义新的 ID。如果给定的 cyl 值的 ID 是固定的，它只会在第一次工作。随后选择 cyl 将显示初始选择，可以通过 updateradioButtons 更新，但不会反应。试试这个并根据您的需要修改显示 table。
library(DT)
library(data.table)
library(shiny)
#library(shinyjs)
library(shinydashboard)
options(device.ask.default = FALSE)
ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
#useShinyjs(),
fluidPage(
fluidRow(
actionButton('feedbackButton', 'Submit Feedback', class = 'btn-primary'),
DTOutput('rec'),
verbatimTextOutput("sel")
))
)
)
server <- function(input, output, session) {
cntr <- reactiveVal(0)
rv <- reactiveValues()
mtcarsData <- reactive({
mtcar <- mtcars %>% filter(cyl == input$cyl) %>%
select(cyl, am, wt, hp, mpg)
})
observe({
req(input$cyl,mtcarsData())
mtcar <- mtcarsData()
id <- cntr()
m = data.table(
rowid = sapply(1:nrow(mtcar), function(i){paste0('rec',input$cyl,i,id)}),
Neutral = 'Neutral',
Good = 'Good',
Bad = 'Bad',
mtcar
) %>%
mutate(Neutral = sprintf('<input type="radio" name="%s" value="%s" checked="checked"/>', rowid, Neutral),
Good = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Good),
Bad = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Bad)
)
rv$df <- m
print(id)
})
observeEvent(input$cyl, {
cntr(cntr()+1)
#print(cntr())
},ignoreInit = TRUE)
feedbackInputData <- reactive({
dfa <- req(rv$df)
list_values <- list()
for (i in unique(dfa$rowid)) {
list_values[[i]] <- input[[i]]
}
list_values
})
observeEvent(input$feedbackButton, {
req(input$cyl)
mtcar <- rv$df ## this could be mtcarsData(), if picking columns not in rv$df but only in mtcarsData()
dt <- rv$df
dt$Feedback <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcar), function(row_id){
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcar$mpg[row_id],
recommendation_feedback = dt$Feedback[row_id],
feedback_timestamp = as.character(Sys.time())
)
})
)
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- renderDT(
datatable(
rv$df,
selection = "none",
escape = FALSE,
options = list(
columnDefs = list(list(visible = FALSE, targets = c(0,4))), ## not displaying rowid and cyl
dom = 't',
paging = FALSE,
ordering = FALSE
),
callback = JS(
"table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());"
),
rownames = F
),
server = FALSE
)
### verify if the radio button values are being returned
output$sel = renderPrint({
req(feedbackInputData())
feedbackInputData()
})
}
shinyApp(ui = ui, server = server)