DT SearchPanes Custom Filter - r

I'm trying to do something like is seen here, but I'm having trouble figuring out how to do it in Shiny. As an example, it would be great to have a filter for mtcars of "efficient" (cars with at least 15 mpg) or "inefficient" (cars with less than 15 mpg).
Here is some code:
library(shiny)
library(DT)
ui <- shinyUI(
fluidPage(DT::dataTableOutput("mtcars_table"))
)
server <- shinyServer(function(input, output, session) {
output$mtcars_table <-
DT::renderDT({
DT::datatable(
mtcars,
options = list(dom = 'Pfrtip',
columnDefs = list(
list(
searchPanes = list(show = TRUE), targets = 1
),
list(
searchPanes = list(show = FALSE), targets = 2:11
))),
extensions = c('Select', 'SearchPanes'),
selection = 'none'
)
}, server = FALSE)
})
shinyApp(ui = ui, server = server)

Here is something to try based on the DataTables example with custom filtering options.
For the additional list options, I included a label like "Efficient", as well as a javascript function for value (rowData[1] should reference the first column, mpg).
library(shiny)
library(DT)
ui <- shinyUI(
fluidPage(DT::dataTableOutput("mtcars_table"))
)
server <- shinyServer(function(input, output, session) {
output$mtcars_table <-
DT::renderDT({
DT::datatable(
mtcars,
options = list(
dom = 'Pfrtip',
columnDefs = list(
list(
searchPanes = list(
show = TRUE,
options = list(
list(
label = "Efficient",
value = JS(
"function(rowData, rowIdx) { return rowData[1] >= 15; }"
)
),
list(
label = "Inefficient",
value = JS(
"function(rowData, rowIdx) { return rowData[1] < 15; }"
)
)
)
),
targets = 1
),
list(
searchPanes = list(show = FALSE), targets = 2:11
)
)
),
extensions = c('Select', 'SearchPanes'),
selection = 'none'
)
}, server = FALSE)
})
shinyApp(ui = ui, server = server)

Related

Shiny: how to make a reactive input for a conditional filter in this case?

Recently I was changing the options of a DT::datatable and because I had to use formatCurrency, I was taking the datatable function outside of renderDataTable. In this case my dynamic filter by the Alias column of the input object selected by selectInput is not working anymore.
The error suggests to wrap the expression into reactive or observeEvent. I did try some approaches which all failed. Maybe someone does get this right fast:
# shiny lib
library(shiny)
library(shinydashboard)
# core
suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(DT))
#### UI
ui <- dashboardPage(
dashboardHeader(title = "TEST"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Inspection",
tabName = "analyze"
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "analyze",
selectInput(inputId = "id",
label = "Select",
choices = "",
selected = ""),
mainPanel(width = 100,
fluidPage(
fluidRow(dataTableOutput("ts_kpi1.1")
)
)
)
)
)
)
)
#### SERVER
server <- function(input, output, session) {
data <- tibble(value = c(c(10000.33,15000.55),c(12000.99,33005.44)),
Alias = c(rep("A",2),rep("B",2))
)
updateSelectInput(session ,
"id",
choices = unique(data$Alias)
)
df_kpi1 <- data %>%
dplyr::filter(Alias == input$id) %>%
summarise(Mean = mean(value),
Median = median(value)
) %>% as_tibble() %>%
mutate_if(is.numeric, ~round(., 0)
)
DT_kpi1 <- datatable(df_kpi1,
options = list(
scrollX = FALSE,
autoWidth = TRUE,
bFilter = 0,
bInfo = FALSE,
bPaginate = FALSE,
lengthChange = FALSE,
columnDefs = list(list(searchable = FALSE, targets = "_all"),
list(targets = c(0), visible = TRUE),
list(searching = FALSE),
list(ordering=F)
)
),
rownames = FALSE ) %>%
formatCurrency(columns = c(1:2), currency = "", interval = 3, mark = ".")
output$ts_kpi1.1 <- DT::renderDataTable({
DT_kpi1
})
}
runApp(list(ui = ui, server = server),launch.browser = TRUE)
As you correctly assumed in your question R pretty much gives you the answer in the error message:
Input `..1` is `Alias == input$id`.
x Can't access reactive value 'id' outside of reactive consumer.
i Do you need to wrap inside reactive() or observe()?
you cant access the value within input$id outside of a reactive context. Just wrap your assignment of df_kpi1 into a reactive, e.g.:
df_kpi1 <- reactive(data %>%
...
...
)
This should solve your issue.
EDIT: Your example
# shiny lib
library(shiny)
library(shinydashboard)
# core
suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(DT))
#### UI
ui <- dashboardPage(
dashboardHeader(title = "TEST"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Inspection",
tabName = "analyze"
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "analyze",
selectInput(inputId = "id",
label = "Select",
choices = "",
selected = ""),
mainPanel(width = 100,
fluidPage(
fluidRow(dataTableOutput("ts_kpi1.1")
)
)
)
)
)
)
)
#### SERVER
server <- function(input, output, session) {
data <- tibble(value = c(c(10000.33,15000.55),c(12000.99,33005.44)),
Alias = c(rep("A",2),rep("B",2))
)
updateSelectInput(session ,
"id",
choices = unique(data$Alias)
)
DT_kpi1 <- reactive({
df_kpi1 <- data %>%
dplyr::filter(Alias == input$id) %>%
summarise(Mean = mean(value),
Median = median(value)
) %>% as_tibble() %>%
mutate_if(is.numeric, ~round(., 0)
)
DT_kpi1 <- datatable(df_kpi1,
options = list(
scrollX = FALSE,
autoWidth = TRUE,
bFilter = 0,
bInfo = FALSE,
bPaginate = FALSE,
lengthChange = FALSE,
columnDefs = list(list(searchable = FALSE, targets = "_all"),
list(targets = c(0), visible = TRUE),
list(searching = FALSE),
list(ordering=F)
)
),
rownames = FALSE ) %>%
formatCurrency(columns = c(1:2), currency = "", interval = 3, mark = ".")
DT_kpi1
})
output$ts_kpi1.1 <- DT::renderDataTable({
DT_kpi1()
})
}
runApp(list(ui = ui, server = server),launch.browser = TRUE)

Error in $: object of type 'closure' is not subsettable shiny R

I have problem with my Shiny App.
In my app I have many DT, Boxes, sometimes DT in Box so I decided to create functions to do my code more clean.
My function to create DT get data which I want to visualize
My function to create Box get title of box, information if is should be
collapsed, and UI - what box should contain (for example few
elements like
fluidRow(
column(6, uiOutput("aaa")),
column(6, uiOutput("bbb"))
)
I also created function to create DT in Box which is based on the previously described functions.
As I understand, the problem is the way data is transferred, but I cannot solve it.
I prepared example of functionality I would like to achieve but doesn't work.
library(shiny)
library(shinydashboard)
library(DT)
Create_DT <- function(dataSource){
datatable(
dataSource,
rownames = FALSE,
selection = 'none',
class = 'cell-border stripe',
extensions = 'Buttons',
options = list(
buttons = list('copy', 'print', list(extend = 'collection',buttons = c('csv', 'excel', 'pdf'),text = 'Download')),
dom = 'Bfrtip',
info = FALSE,
lengthChange = FALSE,
paging = FALSE,
searching = FALSE,
scrollX = TRUE,
columnDefs = list(list(className = 'dt-center', targets = "_all"))
)
) %>% formatStyle(colnames(dataSource),"white-space"="nowrap")
}
Create_Box <- function(description, collapsed, ui){
box(
width = 12,
title = strong(description),
color = "primary",
collapsible = TRUE,
collapsed = collapsed,
ui
)
}
Create_DTinBox <- function(description, collapsed, ui){
Create_Box(description, collapsed, ui)
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
uiOutput("result")
)
)
server <- function(input, output){
reactiveValues(iris = iris)
output$result <- renderUI({
Create_DTinBox(
description = "test",
collapsed = TRUE,
ui = column(6, offset = 3, Create_DT(reactiveValues$iris))
)
})
}
shinyApp(ui, server)
Any Idea how this app should look like to work fine while maintaining the structure of the function from the example?
You need to render the datatable. Also, your reactiveValues need to be defined properly. Try this
library(shiny)
library(shinydashboard)
library(DT)
Create_DT <- function(dataSource){
datatable(
dataSource,
rownames = FALSE,
selection = 'none',
class = 'cell-border stripe',
extensions = 'Buttons',
options = list(
buttons = list('copy', 'print', list(extend = 'collection',buttons = c('csv', 'excel', 'pdf'),text = 'Download')),
dom = 'Bfrtip',
info = FALSE,
lengthChange = FALSE,
paging = FALSE,
searching = FALSE,
scrollX = TRUE,
columnDefs = list(list(className = 'dt-center', targets = "_all"))
)
) %>% formatStyle(colnames(dataSource),"white-space"="nowrap")
}
Create_Box <- function(description, collapsed, ui){
box(
width = 12,
title = strong(description),
color = "primary",
collapsible = TRUE,
collapsed = collapsed,
ui
)
}
Create_DTinBox <- function(description, collapsed, ui){
Create_Box(description, collapsed, ui)
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
uiOutput("result")
)
)
server <- function(input, output){
rv <- reactiveValues(df = iris)
output$result <- renderUI({
Create_DTinBox(
description = "test",
collapsed = TRUE,
ui = column(8, offset = 3, renderDT(Create_DT(rv$df)))
)
})
}
shinyApp(ui, server)

Black background with white font for first column in DT::DataTables

I have a shiny app with a DT::DataTable element in which the first column is a row header and the second column contains data. How can I change the color of the first column to be white text on a black background? If found ways to change the column headers (section 4.3 here), but I how do I get the same effect applied to the first column?
Here's some example code showing a very simplified version of the table without the desired effect. I'm certain that adding something to the options list in the renderDataTable function will solve it, but I don't know what to add.
EDIT: Below is a solution suggested by #Stéphane Laurent, which answers my original question. However, it makes the change to all tables present on the app. In my modified code, below, the global change is shown, but how do I target just one of the two tables?
library(shiny)
library(DT)
CSS <- HTML(
"td.firstcol {color: white; background-color: black}"
)
ui <- fluidPage(
tags$head(
tags$style(CSS)
),
fluidRow(
column(3,
DTOutput(outputId = 'tbl')
),
column(3,
DTOutput(outputId = 'tbl2')
)
)
)
server <- function(input, output) {
output$tbl<- renderDT({
datatable(
data.frame(
Label = c('Label1', 'Label2', 'Label3', 'Label4'),
Data = c('Data1', 'Data2', 'Data3', 'Data4')
),
rownames = FALSE,
colnames = "",
options = list(
dom = 't',
columnDefs = list(
list(targets = 0, className = "firstcol")
)
)
)
})
output$tbl2 <- renderDT({
datatable(
data.frame(
Label = c('Label1', 'Label2', 'Label3', 'Label4'),
Data = c('Data1', 'Data2', 'Data3', 'Data4')
),
rownames = FALSE,
colnames = "",
options = list(
dom = 't',
columnDefs = list(
list(targets = 0, className = "firstcol")
)
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
library(shiny)
library(DT)
CSS <- HTML(
"td.firstcol {color: white; background-color: black}"
)
ui <- fluidPage(
tags$head(
tags$style(CSS)
),
fluidRow(
column(3,
DTOutput(outputId = 'tbl')
)
)
)
server <- function(input, output) {
output$tbl<- renderDT({
datatable(
data.frame(
Label = c('Label1', 'Label2', 'Label3', 'Label4'),
Data = c('Data1', 'Data2', 'Data3', 'Data4')
),
rownames = FALSE,
colnames = "",
options = list(
dom = 't',
columnDefs = list(
list(targets = 0, className = "firstcol")
)
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)

render option inside renderDT conditional on Input selection in shiny

When using renderDT with buttons to download the data table, it can be set to download the whole data table, or only the data shown in the current view of the table. I would like to be able to set one way or the other based on the value of one of the input selections by the user.
In the example below, as it is, when clicking on the copy, pdf, or excel buttons, you only get the table in the current view (50 records). If I had render = TRUE in renderDT, then you would download the 200 records for that Type (see example). I would like it to be that when the selection is Type 1, the download would be of only the 50 records in the view, but when Type 2 is selected then it would download all the 200 records for Type 2.
library(shiny)
library(shinydashboard)
library(ggplot2)
library(data.table)
library(DT)
library(dplyr)
library(leaflet)
library(scales)
library(shinythemes)
# UI -----------------------------------------------------------------------------------
dataCM <- data.table(variable = 1:400,
type = c(rep('Type 1', 200), rep('Type 2', 200)))
ui <- fluidPage(
dashboardPage(
# Header ================================
dashboardHeader(
title = span(h3('Shiny App')
)
),
# Side bar ==============================
dashboardSidebar(width = 250,
sidebarMenu(id = 'sidebar',
# Tabs #
menuItem('Table', tabName = 'tables', icon = icon('bars'))
),
fluidRow(
box(width = 12, background = 'black',
radioButtons(inputId = 'checksubspecialty',
label = 'Choose Row',
choices = list('Type 1',
'Type 2')))
)
),
# Body ==================================
dashboardBody(
tabItems(
tabItem(tabName = 'tables',
fluidRow(
box(width = 12,
DTOutput('tableSurg')))
))
)
)
)
# Server --------------------------------------------------------------------------------
server <- function(input, output) {
data_subset <- reactive({
req(input$checksubspecialty)
dataM <- data.table(dataCM %>% filter(type %in% input$checksubspecialty))
dataM
})
output$tableSurg <- renderDT( # adding render = TRUE or FALSE in here is what sets if the download is of all or only the viewed data
{
dt <- data_subset()
dt
},
rownames = FALSE,
extensions = 'Buttons',
options = list(
pageLength = 50,
scrollY= '500px',
scrollX = TRUE,
dom = 'Bfrtip',
columnDefs = list(list(className = 'dt-left', targets = '_all')),
buttons = list(
list(extend = 'copy', title = "Title"),
list(extend = 'excel', title = "Title"),
list(extend = 'pdf', title = "Title")
)
))
}
# Run the application -------------------------------------------------------------------
shinyApp(ui = ui, server = server)
Try this
# Server --------------------------------------------------------------------------------
server <- function(input, output) {
data_subset <- reactive({
req(input$checksubspecialty)
dataM <- data.table(dataCM %>% filter(type %in% input$checksubspecialty))
dataM
})
TORF <- reactive({
if (input$checksubspecialty == "Type 1") TRUE else FALSE
})
output$tableSurg <- renderDT( server = TORF(), # adding server = TRUE or FALSE in here is what sets if the download is of all or only the viewed data
{
dt <- data_subset()
dt
},
rownames = FALSE,
extensions = 'Buttons',
options = list(
pageLength = 50,
scrollY= '500px',
scrollX = TRUE,
dom = 'Bfrtip',
columnDefs = list(list(className = 'dt-left', targets = '_all')),
buttons = list(
list(extend = 'copy', title = "Title"),
list(extend = 'excel', title = "Title"),
list(extend = 'pdf', title = "Title")
)
))
}

DT rows_selected doesn't work with FixedColumns extension

When using the FixedColumns extension in DT, the rows_selected doesn't register any selections in Sepel.Length
Please see the below example...
Any suggestions on how to get around this would be appreciated.
library(DT)
library(shiny)
ui=shinyUI(
fluidPage(
DT::dataTableOutput("x3")
)
)
server=shinyServer(function(input, output) {
output$x3 = DT::renderDataTable(
DT:::datatable(
iris, rownames=FALSE,
extensions = c('FixedColumns'),
options = list(
fixedColumns = list(leftColumns = 1),
scrollX = TRUE)
))
observe({
s = input$x3_rows_selected
print(s)
})
})
shinyApp(ui=ui,server=server)

Resources