我如何根据闪亮应用程序中复选框的输入来设置数据框中某些行的样式？
How can I style format some rows in a data frame depending on the input of a checkbox in a shiny app?
我正在开发一个闪亮的应用程序，用户可以在其中使用一些小部件以交互方式过滤数据框。我的复选框之一称为 "LOT"。此复选框的目的是将 x_LOT 或 Y_LOT 列的值为 "true" 的那些行涂成黄色。
我尝试在 renderTable 中包含一个条件，这样如果复选框的输入为真，相应的行就会被着色，但它没有用。我尝试为其余过滤器编写条件内部反应函数，但它也没有用。
我的代码如下：
# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
dataTableOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
req(input$file1)
df <- read.csv(input$file1$datapath)
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence), selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
output$contents <- renderDT(
filtered_df(),
class = "display nowrap compact", # style
filter = "top")
# if(input$LOT == TRUE){
# cols = names(df())[grepl( "LOT", names(filtered_df()))]
# datatable(filtered_df) %>% formatStyle(
# columns = cols,
# target = 'row',
# backgroundColor = styleEqual("TRUE", 'yellow')
# )}
}
shinyApp(ui, server)
因此，在这种情况下，我希望在按下复选框 "LOT" 时将第 4 行到第 11 行着色为黄色。
谢谢，
瑞秋
这是一个仅部分有效的解决方案。我不明白这个问题。 （编辑：问题已解决，见文末）
首先，我已经删除了您的文件上传，以便不必再上传文件。这与问题无关。我调用数据框 DF。
问题在这里：在下面的代码中，我做了 renderDT(DT, ......。如您所见，这有效。但是当我renderDT(filtered_df(), ....)时，这不起作用，我不明白为什么。
DF <- df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
#write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
# library(lazyeval)
# library(data.table)
callback <- function(rows){
c(
sprintf("var rows = [%s];", toString(rows)),
"$('#LOT').on('click', function(){",
" if($(this).prop('checked')){",
" for(var i=0; i<rows.length; ++i){",
" var row = table.row(rows[i]);",
" row.node().style.backgroundColor = 'yellow';",
" }",
" }else{",
" for(var i=0; i<rows.length; ++i){",
" var row = table.row(rows[i]);",
" row.node().style.backgroundColor = '';",
" }",
" }",
"})"
)
}
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
DTOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
# req(input$file1)
# df <- read.csv(input$file1$datapath)
DF
})
yellowRows <- reactive({
req(df())
which(df()$x_LOT == "True" | df()$y_LOT == "True") - 1L
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence",
choices = levels(df()$Consequence),
selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
output$contents <- renderDT({
req(filtered_df())
datatable(
DF,
class = "display nowrap compact",
filter = "top",
callback = JS(callback(yellowRows())),
options = list(
pageLength = 12)
)},
server = FALSE
)
}
shinyApp(ui, server)
编辑：问题已解决
只需将 yellowRows 替换为：
yellowRows <- reactive({
req(filtered_DAT())
which(filtered_DAT()$x_LOT == "True" | filtered_DAT()$y_LOT == "True") - 1L
})
output$contents <- renderDT({
req(filtered_DAT())
datatable(
filtered_DAT(),
class = "display nowrap compact",
filter = "top",
callback = JS(callback(yellowRows())),
options = list(
pageLength = 12)
)},
server = FALSE
)
编辑：适用于多个页面的版本
DF <- df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
#write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
# library(lazyeval)
# library(data.table)
callback <- function(rows){
c(
sprintf("var rows = [%s];", toString(rows)),
"$('#LOT').on('click', function(){",
" for(var i=0; i<rows.length; ++i){",
" var row = table.row(rows[i]);",
" if(row.length){",
" row.node().style.backgroundColor = ",
" $(this).prop('checked') ? 'yellow' : '';",
" }",
" }",
"})"
)
}
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
DTOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
# req(input$file1)
# df <- read.csv(input$file1$datapath)
DF
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence",
choices = levels(df()$Consequence),
selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
yellowRows <- reactive({
req(filtered_df())
which(filtered_df()$x_LOT == "True" | filtered_df()$y_LOT == "True") - 1L
})
output$contents <- renderDT({
req(filtered_df())
datatable(
filtered_df(),
class = "display nowrap compact",
filter = "top",
callback = JS(callback(yellowRows())),
options = list(
pageLength = 6)
)},
server = FALSE
)
}
shinyApp(ui, server)
好问题，学到了很多。
这是基于其他类似问题的另一种解决方案：
棘手的部分是弄清楚如何根据两列中的条件为行着色（上面的第二个 link）。结果最好创建一个单独的列来检查 *_LOT 列是否为真，按该列着色，然后在呈现 table 时隐藏它。这适用于 filtered_df() 反应式。
# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
dataTableOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
req(input$file1)
df <- read.csv(input$file1$datapath)
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence), selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
make_dt <- reactive({
if (input$LOT == TRUE) {
cols = names(df())[grepl("LOT", names(filtered_df()))]
fd <- filtered_df()
fd <- fd %>%
mutate(bg=ifelse(!!as.name(cols[1]) == "True" | !!as.name(cols[2])=="True", "True", "False"))
x <- datatable(fd, options = list(
columnDefs = list(list(targets = 7, visible = FALSE)))) %>%
formatStyle(
columns = names(fd),
valueColumns = "bg",
target = 'row',
backgroundColor = styleEqual("True", "yellow")
)
} else {
x <- datatable(filtered_df(),
class = "display nowrap compact", # style
filter = "top")
}
return(x)
})
output$contents <- renderDT({
make_dt()
})
}
shinyApp(ui, server)
编辑：概括检查名称中包含 LOT 的任何列
# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
dataTableOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
req(input$file1)
df <- read.csv(input$file1$datapath)
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence), selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
make_dt <- reactive({
if (input$LOT == TRUE) {
cols = names(df())[grepl("LOT", names(filtered_df()))]
fd <- filtered_df()
# fd <- fd %>%
# mutate(bg=ifelse(!!as.name(cols[1]) == "True" | !!as.name(cols[2])=="True", "True", "False"))
#
color_column <- fd %>%
select(contains("LOT")) %>%
# not needed if *LOT columns have TRUE/FALSE or T/F values
# you can rowSums those directly
mutate_all(.funs = list(function(x) x == "True")) %>%
# do any of the rows have TRUE? if yes, label as 'True'
mutate(check=ifelse(rowSums(.) > 0, "True", "False")) %>%
select(check)
fd$color_column <- color_column$check
x <- datatable(fd, options = list(
columnDefs = list(list(targets = 7, visible = FALSE)))) %>%
formatStyle(
columns = names(fd),
valueColumns = "color_column",
target = 'row',
backgroundColor = styleEqual("True", "yellow")
)
} else {
x <- datatable(filtered_df(),
class = "display nowrap compact", # style
filter = "top")
}
return(x)
})
output$contents <- renderDT({
make_dt()
})
}
shinyApp(ui, server)
我正在开发一个闪亮的应用程序，用户可以在其中使用一些小部件以交互方式过滤数据框。我的复选框之一称为 "LOT"。此复选框的目的是将 x_LOT 或 Y_LOT 列的值为 "true" 的那些行涂成黄色。
我尝试在 renderTable 中包含一个条件，这样如果复选框的输入为真，相应的行就会被着色，但它没有用。我尝试为其余过滤器编写条件内部反应函数，但它也没有用。
我的代码如下：
# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
dataTableOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
req(input$file1)
df <- read.csv(input$file1$datapath)
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence), selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
output$contents <- renderDT(
filtered_df(),
class = "display nowrap compact", # style
filter = "top")
# if(input$LOT == TRUE){
# cols = names(df())[grepl( "LOT", names(filtered_df()))]
# datatable(filtered_df) %>% formatStyle(
# columns = cols,
# target = 'row',
# backgroundColor = styleEqual("TRUE", 'yellow')
# )}
}
shinyApp(ui, server)
因此，在这种情况下，我希望在按下复选框 "LOT" 时将第 4 行到第 11 行着色为黄色。
谢谢，
瑞秋
这是一个仅部分有效的解决方案。我不明白这个问题。 （编辑：问题已解决，见文末）
首先，我已经删除了您的文件上传，以便不必再上传文件。这与问题无关。我调用数据框 DF。
问题在这里：在下面的代码中，我做了 renderDT(DT, ......。如您所见，这有效。但是当我renderDT(filtered_df(), ....)时，这不起作用，我不明白为什么。
DF <- df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
#write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
# library(lazyeval)
# library(data.table)
callback <- function(rows){
c(
sprintf("var rows = [%s];", toString(rows)),
"$('#LOT').on('click', function(){",
" if($(this).prop('checked')){",
" for(var i=0; i<rows.length; ++i){",
" var row = table.row(rows[i]);",
" row.node().style.backgroundColor = 'yellow';",
" }",
" }else{",
" for(var i=0; i<rows.length; ++i){",
" var row = table.row(rows[i]);",
" row.node().style.backgroundColor = '';",
" }",
" }",
"})"
)
}
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
DTOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
# req(input$file1)
# df <- read.csv(input$file1$datapath)
DF
})
yellowRows <- reactive({
req(df())
which(df()$x_LOT == "True" | df()$y_LOT == "True") - 1L
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence",
choices = levels(df()$Consequence),
selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
output$contents <- renderDT({
req(filtered_df())
datatable(
DF,
class = "display nowrap compact",
filter = "top",
callback = JS(callback(yellowRows())),
options = list(
pageLength = 12)
)},
server = FALSE
)
}
shinyApp(ui, server)
编辑：问题已解决
只需将 yellowRows 替换为：
yellowRows <- reactive({
req(filtered_DAT())
which(filtered_DAT()$x_LOT == "True" | filtered_DAT()$y_LOT == "True") - 1L
})
output$contents <- renderDT({
req(filtered_DAT())
datatable(
filtered_DAT(),
class = "display nowrap compact",
filter = "top",
callback = JS(callback(yellowRows())),
options = list(
pageLength = 12)
)},
server = FALSE
)
编辑：适用于多个页面的版本
DF <- df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
#write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
# library(lazyeval)
# library(data.table)
callback <- function(rows){
c(
sprintf("var rows = [%s];", toString(rows)),
"$('#LOT').on('click', function(){",
" for(var i=0; i<rows.length; ++i){",
" var row = table.row(rows[i]);",
" if(row.length){",
" row.node().style.backgroundColor = ",
" $(this).prop('checked') ? 'yellow' : '';",
" }",
" }",
"})"
)
}
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
DTOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
# req(input$file1)
# df <- read.csv(input$file1$datapath)
DF
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence",
choices = levels(df()$Consequence),
selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
yellowRows <- reactive({
req(filtered_df())
which(filtered_df()$x_LOT == "True" | filtered_df()$y_LOT == "True") - 1L
})
output$contents <- renderDT({
req(filtered_df())
datatable(
filtered_df(),
class = "display nowrap compact",
filter = "top",
callback = JS(callback(yellowRows())),
options = list(
pageLength = 6)
)},
server = FALSE
)
}
shinyApp(ui, server)
好问题，学到了很多。
这是基于其他类似问题的另一种解决方案：
棘手的部分是弄清楚如何根据两列中的条件为行着色（上面的第二个 link）。结果最好创建一个单独的列来检查 *_LOT 列是否为真，按该列着色，然后在呈现 table 时隐藏它。这适用于 filtered_df() 反应式。
# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
dataTableOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
req(input$file1)
df <- read.csv(input$file1$datapath)
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence), selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
make_dt <- reactive({
if (input$LOT == TRUE) {
cols = names(df())[grepl("LOT", names(filtered_df()))]
fd <- filtered_df()
fd <- fd %>%
mutate(bg=ifelse(!!as.name(cols[1]) == "True" | !!as.name(cols[2])=="True", "True", "False"))
x <- datatable(fd, options = list(
columnDefs = list(list(targets = 7, visible = FALSE)))) %>%
formatStyle(
columns = names(fd),
valueColumns = "bg",
target = 'row',
backgroundColor = styleEqual("True", "yellow")
)
} else {
x <- datatable(filtered_df(),
class = "display nowrap compact", # style
filter = "top")
}
return(x)
})
output$contents <- renderDT({
make_dt()
})
}
shinyApp(ui, server)
编辑：概括检查名称中包含 LOT 的任何列
# MY DATA FRAME
df <- data.frame(Consequence = c(rep("x",4),rep("y",4),rep("z",4)),
CANONICAL = rep(c("YES","NO"),6),
x_LOT = c(rep("False", 3), rep("True", 5), rep("False",2), "True","False"),
y_LOT = c(rep("False", 8), rep("True",2), rep("False",2)),
x3=c(12,43,64,34,93,16,32,74,84,89,45,67))
write.csv(df, "df.csv")
# MY APP
library(shiny)
library(DT) # for data tables
library(dplyr)
library(shinyWidgets)
library(lazyeval)
library(data.table)
ui <- function(request) {
fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("file1", "Upload your File",multiple = FALSE,
accept = c("text/csv", "text/comma-separated-values,text/plain",".csv")),
pickerInput("Consequence", "Consequence:", choices = NULL, options = list(`actions-box` = TRUE),
selected = NULL, multiple = TRUE ),
prettyCheckbox(inputId = "CANONICAL", label = "CANONICAL", value = FALSE,
outline = TRUE, fill = TRUE, bigger = TRUE, status = 'success',width = NULL),
prettyCheckbox(inputId="LOT", label = "LOT", value = FALSE,
outline= TRUE, fill = TRUE, status = 'success', width = NULL)),
mainPanel(
dataTableOutput("contents")
)))}
server <- function(input, output, session) {
df <- reactive({
req(input$file1)
df <- read.csv(input$file1$datapath)
})
observeEvent(df(), {
req(df())
updatePickerInput(session, inputId = "Consequence", choices = levels(df()$Consequence), selected = levels(df()$Consequence))
})
filtered_df <- reactive({
df() %>%
filter( Consequence %in% input$Consequence ) %>%
filter(if (input$CANONICAL == TRUE) CANONICAL == "YES" else !is.na(CANONICAL))
})
make_dt <- reactive({
if (input$LOT == TRUE) {
cols = names(df())[grepl("LOT", names(filtered_df()))]
fd <- filtered_df()
# fd <- fd %>%
# mutate(bg=ifelse(!!as.name(cols[1]) == "True" | !!as.name(cols[2])=="True", "True", "False"))
#
color_column <- fd %>%
select(contains("LOT")) %>%
# not needed if *LOT columns have TRUE/FALSE or T/F values
# you can rowSums those directly
mutate_all(.funs = list(function(x) x == "True")) %>%
# do any of the rows have TRUE? if yes, label as 'True'
mutate(check=ifelse(rowSums(.) > 0, "True", "False")) %>%
select(check)
fd$color_column <- color_column$check
x <- datatable(fd, options = list(
columnDefs = list(list(targets = 7, visible = FALSE)))) %>%
formatStyle(
columns = names(fd),
valueColumns = "color_column",
target = 'row',
backgroundColor = styleEqual("True", "yellow")
)
} else {
x <- datatable(filtered_df(),
class = "display nowrap compact", # style
filter = "top")
}
return(x)
})
output$contents <- renderDT({
make_dt()
})
}
shinyApp(ui, server)