My question is an extension of this question:
R Shiny: Handle Action Buttons in Data Table
I am trying to add reactive buttons to a data table that is generated reactively.
Basically, my table is subsetted from a dataframe based on a search term entered by the user. I'd like to have buttons in the subsetted and displayed table, but instead of the buttons appearing as in the linked question, I get HTML code for them.
Here's the server code:
server = function(input, output, session) {
table<-reactive({
filter(evidence_test,grepl(input$search,evidence_abstract,ignore.case=TRUE))[,c(input$show_vars)]
})
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
df<-reactive({reactiveValues(
data=data.frame(
table(),
Actions = shinyInput(actionButton, nrow(table()), 'button_', label = "Fire", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
stringsAsFactors = FALSE
)
)
})
observeEvent(input$select_button, {
selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
output$tbl <- DT::renderDataTable({
df()$data
});
output$myText <- renderText({
colnames(df$data)
})
}
And here's the UI code:
ui = fluidPage(
headerPanel("Search for article terms"),
sidebarPanel(
textInput(inputId="search",value="kras",label="Search for a term", width=400),
checkboxGroupInput(inputId='show_vars', label='Columns to show:', dbListFields(database,"evidence_test"),
selected = c("evidence_title","evidence_abstract","evidence_score","evidence_priority"))
),
mainPanel(
DT::dataTableOutput("tbl")
)
)
Thanks for the help.
Related
I have a leaflet map & datatable in a shiny app and have various input boxes to select what is being mapped.
Currently the data is processed on the server based on a set of shiny inputs, and that data is passed to both leaflet and datatable.
I'd also like to have a button on the datatable (or read double clicks on the datatable) and update a shiny input (i.e., call shiny::updateSelectizeInput) based on the users interaction with the datatable.
minimal code example:
if (interactive()) {
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
selectInput("species_selection", "Select species",
choices = c("all", as.character(iris$Species)))
, dataTableOutput("dt")
)
, server = function(input, output) {
output$dt <- renderDataTable({
if ( input$species_selection != "all" ) {
for_table <- iris %>%
filter(Species == input$species_selection)
} else {
for_table <- iris
}
for_table
# but also you can click a button or double-click a row on this datatable
# to update input$species_selection above
})
}
)
}
I'm aware there's no reason for this in this minimal example but I do want to do so for in the context of my larger app.
I've seen examples (for example, superzip) where buttons on the datatable are linked to html, and I know the datatable shiny tutorials tell you how to catch selected rows with an observer. Catching the selected rows is my backup plan but I would prefer a button on the row or a double-click.
Sure, but its a bit fiddly. I used mtcars as it has more variety:
library(shiny)
library(DT)
shinyApp(
#UI
ui <- fluidPage(
selectInput('carb_selection', 'Select carb', choices = c('all', as.character(mtcars$carb))),
DT::dataTableOutput('dt'),
),
#Server
server <- function(input, output, session) {
#Function to create buttons
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
#Add buttons to the mtcars dataframe
mtcars_btn <- reactiveValues(
data = data.frame(
mtcars,
carb_selector = shinyInput(actionButton, nrow(mtcars), 'button_', label = "Select", onclick = 'Shiny.onInputChange(\"select_button\", this.id)'),
stringsAsFactors = FALSE
)
)
#Output datatable
output$dt <- DT::renderDataTable(
if (input$carb_selection == 'all'){
DT::datatable(mtcars_btn$data, escape = FALSE, selection = 'none', options = list(searching = FALSE, ordering = FALSE))
} else {
DT::datatable(mtcars_btn$data[mtcars_btn$data$carb == input$carb_selection, ], escape = FALSE, selection = 'none', options = list(searching = FALSE, ordering = FALSE))
}
)
#Observe a button being clicked
observeEvent(input$select_button, {
carb_selected <- mtcars_btn$data[as.numeric(strsplit(input$select_button, "_")[[1]][2]),]$carb
print(paste0('clicked on ', carb_selected))
updateSelectInput(session, 'carb_selection', selected = carb_selected)
})
}
)
Note that you may wish to switch between local and server processing when using large dataframes.
I am trying to create a shiny code that is able to filter a table non pre-determined number of times. When the user uploads a different (new) table, unfortunately the code breaks as I need to restart a lapply loop somehow, throwing out the previously stored column names.
I would like to create an non pre-defined filtering options for a table within Shiny. The user can select a column and filter a table choosing different categorical variables within that column. It is possible to add additional selection fields by pressing the 'Add' button.
the UI:
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- shinyUI(
pageWithSidebar(
headerPanel("testing of dynamic number of selection"),
sidebarPanel(
uiOutput("buttons")),
mainPanel(
uiOutput("drops")
,tableOutput("table")
)
))
The server:
A table (test.csv) is automatically stored in a reactive values and a first searching field appears with 3 buttons (Add = to add a new searching field by reading in the colnames and a multiselect that stores the unique variables from that columns. The filtering function is activated by the Calculate button)
server<-function(input, output, session) {
###### read in test file
values<-reactiveValues(number = 1,
upload = NULL,
input = NULL)
values$upload<-read.csv("test.csv")
#just the "add" button, in this instance it shouldn't be a uiOutput
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"), actionButton(inputId = "calc", label = "Calculate"),
actionButton(inputId = "new", label = "new table")
)
})
#pressing the add button
observeEvent(input$add, {
cat("i adding a new record\n")
values$number <- values$number + 1L })
daStuff <- function(i){
inputName<-paste0("drop", i)
inputName2<-paste0("select", i)
inputText<-if(values$number>0){input[[paste0("drop",i)]]}else{F} # previously selected value for dropdown
inputSelect <- if(values$number>1){input[[paste0("select",i)]]}else{F} # previously selected value for dropdown
fluidRow(
column(6,selectInput(inputName, inputName, c(colnames(values$upload)), selected = inputText)),
column(6,selectInput(inputName2, inputName2,
na.omit(unique(as.vector(values$upload[,input[[paste0("drop",i)]]]))),
multiple=TRUE, selectize=TRUE, selected=inputSelect)) )}
output$drops<- renderUI({
lapply(seq_len(values$number), daStuff)})
By pressing the Calculate button, the uploaded table is subjected to filtering, depending on the selected unique values and shown in the output$table
observeEvent(input$calc, {
values$input<-NULL
for (i in 1:values$number){
if(!is.null(input[[paste0("select",i)]])){
if(is.null(values$input)){
values$input<- filter(values$upload,values$upload[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
else{
values$input<- filter(values$input,values$input[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
} }
if (is.null(values$input)){values$input<-values$upload}
output$table <- renderTable({values$input})
})
My problem is when I upload a new table (test2.csv), I don't know how to erase the previously stored selections (drop* and select* values) and gives back an error message.
observeEvent(input$new,{
values$upload<-read.csv("test2.csv")
})
}
shinyApp(ui=ui, server = server)
I suppose I should stop somehow the lapply loop and restart it over, so the previously stored values are replaced depending on the new selection, but I am a bit stuck on how I could achieve that.
Just in case you might still be looking for solutions, I wanted to share something that was similar and could potentially be adapted for your needs.
This uses observeEvent for all select inputs. If it detects any changes, it will update all inputs, including the possibilities for select based on drop.
In addition, when a new file is read, the selectInput for drop and select are reset to first value.
Edit: I forgot to keep selected = input[[paste0("drop",i)]] in place for the dropdown (see revised code). It seems to keep the values now when new filters are added - let me know if this is what you had in mind.
library(shiny)
library(shinydashboard)
library(dplyr)
myDataFrame <- read.csv("test.csv")
ui <- shinyUI(
pageWithSidebar(
headerPanel("Testing of dynamic number of selection"),
sidebarPanel(
fileInput("file1", "Choose file to upload", accept = ".csv"),
uiOutput("buttons")
),
mainPanel(
uiOutput("inputs"),
tableOutput("table")
)
)
)
server <- function(input, output, session) {
myInputs <- reactiveValues(rendered = c(1))
myData <- reactive({
inFile <- input$file1
if (is.null(inFile)) {
d <- myDataFrame
} else {
d <- read.csv(inFile$datapath)
}
d
})
observeEvent(lapply(paste0("drop", myInputs$rendered), function(x) input[[x]]), {
for (i in myInputs$rendered) {
updateSelectInput(session,
paste0('select', i),
choices = myData()[input[[paste0('drop', i)]]],
selected = input[[paste0("select",i)]])
}
})
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"),
actionButton(inputId = "calc", label = "Calculate")
)
})
observeEvent(input$add, {
myInputs$rendered <- c(myInputs$rendered, max(myInputs$rendered)+1)
})
observeEvent(input$calc, {
showData <- NULL
for (i in 1:length(myInputs$rendered)) {
if(!is.null(input[[paste0("select",i)]])) {
if(is.null(showData)) {
showData <- filter(myData(), myData()[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
else {
showData <- filter(showData, showData[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
}
}
if (is.null(showData)) { showData <- myData() }
output$table <- renderTable({showData})
})
observe({
output$inputs <- renderUI({
rows <- lapply(myInputs$rendered, function(i){
fluidRow(
column(6, selectInput(paste0('drop',i),
label = "",
choices = colnames(myData()),
selected = input[[paste0("drop",i)]])),
column(6, selectInput(paste0('select',i),
label = "",
choices = myData()[1],
multiple = TRUE,
selectize = TRUE))
)
})
do.call(shiny::tagList, rows)
})
})
}
shinyApp(ui, server)
Trying to use selectInput in a form.
the choices are fetched from a collection in mongodB.
when user
completes the form and submits (which inserts to another collection
in mongo), data in selectInput is not captured.
tried to make it reactive or use observeEvent /updateSelectInput in the server but could not make it work.
here is the entire code:
library(shiny)
library(mongolite)
library(jsonlite)
# which fields get saved
fieldsAll <- c("Name", "selectOne", "tags")
saveData <- function(data) {
# Connect to the database
}
# load all responses into a data.frame
loadData <- function() {
# Connect to the database
}
fetchData <- function() {
# Connect to the database
}
shinyApp(
ui = tagList(
navbarPage(
tabPanel("Technology",
sidebarPanel(
textInput("Name",label ='Name:'),
selectInput('selectOne',
label ='Select One:',
choices=head(fetchData()),
selected = "",
multiple = FALSE),
selectizeInput("tags", "Tags:", NULL, multiple = TRUE, options=list(create=TRUE)),
actionButton("submit", "Submit", class = "btn-primary")
),
mainPanel(
tabsetPanel(
tabPanel("Table",
uiOutput("adminPanelContainer")
)
)
)
)
)
),
server = function(input, output, session) {
formData <- reactive({
fieldsAll
data <- sapply(fieldsAll, function(x) input[[x]])
data <- t(data)
data
})
observeEvent(input$submit, {
saveData(formData())
},
)
# render the admin panel
output$adminPanelContainer <- renderUI({
DT::dataTableOutput("responsesTable")
})
# Update the responses table whenever a new submission is made
responses_data <- reactive({
input$submit
data <- loadData()
data
})
# Show the responses in the admin table
output$responsesTable <- DT::renderDataTable({
DT::datatable(
responses_data(),
rownames = FALSE,
options = list(searching = TRUE, lengthChange = FALSE)
)
})
}
)
adding a column to the df with selected value worked:
formData <- reactive({
fieldsAll
data <- sapply(fieldsAll, function(x) input[[x]])
data <- c(data,selectOne= input$selectOne) #added line
data <- t(data)
data
})
I am trying to add dynamically generated links to a datatable of variable length. Clicking the link should switch the focus to the details tab. At the same time, the select input should be updated to the car brand that was clicked, so that the information on the details tab is updated. I prepared a minimal example with actionLinks. However, I couldn't figure out how to make the links do what I want.
library(shiny)
library(htmlwidgets)
library(tibble)
library(DT)
ui <- fluidPage(
title = "Examples of DataTables",
sidebarLayout(
sidebarPanel(
selectInput("car", h3("Car"),choices = rownames(mtcars))
),
mainPanel(
tabsetPanel(id = "dataset",
tabPanel("Cars", DT::dataTableOutput("mytable1")),
tabPanel("Details", DT::dataTableOutput("mytable2"))))))
server <- function(input, output) {
shinyInput = function(FUN, len, id, labels, ...) {
inputs = NULL
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = labels[i], ...))
}
return(inputs)
}
output$mytable1 <- DT::renderDataTable({
cars <- mtcars %>% rownames_to_column() %>% select(rowname, mpg, cyl)
cars$rowname <- shinyInput(actionLink, nrow(cars), "link_", labels = cars$rowname)
DT::datatable(cars, rownames = FALSE, escape = FALSE)
})
output$mytable2 <- DT::renderDataTable(DT::datatable(mtcars[input$car,]))
}
shinyApp(ui, server)
Any help would be appreciated. Thanks!
I found a solution using the onclick function of the button and JavaScript statements. To open the tab, simulate a click on it and to change the drop down menu use selectize.
shinyInput = function(FUN, len, id, labels, ...) {
inputs = NULL
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = labels[i],
onclick = paste0('$("#dataset li a")[1].click();$("#car")[0].selectize.setValue("',labels[i],'")')))
}
return(inputs)
}
I have a shiny app with two tabs, each with a DataTable that have numericInputs so I have to bind and unbind the DataTable for the numericInputs to work. Unfortunately this has created reactivity problems that I am hoping someone can help with. In the example below, if you change the input on the sidebar that determines the data in the tables, only the table in the open tab will actually update/react.
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
sidebarPanel(
# choose dataset
selectInput("select","Choose dataset",c("mtcars","iris"))),
# display table
mainPanel(
tabsetPanel(tabPanel("one",DT::dataTableOutput('x1')),
tabPanel("two",DT::dataTableOutput('x2'))),
tags$script(HTML("Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})")))),
server = function(session, input, output) {
# function for dynamic inputs in DT
shinyInput <- function(FUN,id,num,...) {
inputs <- character(num)
for (i in seq_len(num)) {
inputs[i] <- as.character(FUN(paste0(id,i),label=NULL,...))
}
inputs
}
# function to read DT inputs
shinyValue <- function(id,num) {
unlist(lapply(seq_len(num),function(i) {
value <- input[[paste0(id,i)]]
if (is.null(value)) NA else value
}))
}
# reactive dataset
data <- reactive({
req(input$select)
session$sendCustomMessage('unbind-DT', 'x1')
get(input$select)[1:5,1:3]
})
data2 <- reactive({
req(input$select)
session$sendCustomMessage('unbind-DT', 'x2')
get(input$select)[5:10,1:3]
})
# render datatable with inputs
output$x1 <- DT::renderDataTable({
data.frame(data(),ENTER = shinyInput(numericInput,"numin",nrow(data()),value=NULL))
},
server=FALSE,escape=FALSE,selection='none',
options=list(language = list(search = 'Filter:'),
preDrawCallback=JS(
'function() {
Shiny.unbindAll(this.api().table().node());}'),
drawCallback= JS(
'function(settings) {
Shiny.bindAll(this.api().table().node());}')))
output$x2 <- DT::renderDataTable({
data.frame(data2(),
ENTER = shinyInput(numericInput,"numin2",nrow(data2()),value=NULL))
},
server=FALSE,escape=FALSE,selection='none',
options=list(language = list(search = 'Filter:'),
preDrawCallback=JS(
'function() {
Shiny.unbindAll(this.api().table().node());}'),
drawCallback= JS(
'function(settings) {
Shiny.bindAll(this.api().table().node());}')))
outputOptions(output, "x1", suspendWhenHidden = FALSE)
outputOptions(output, "x2", suspendWhenHidden = FALSE)
}
)
Even though the table in the closed tab is hidden, the options are set so that it should still function like it isn't hidden. Any guidance would be appreciated.
EDIT: Now that I am older and wiser I would never add HTML to a DataTable this way. Makes more sense to write a JS callback function that writes the HTML on the client side.
Here below your updated code that works.
All credit goes to tomasreigl, I took some code from the issue he opened here https://github.com/rstudio/shiny/issues/1246
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
sidebarPanel(
# choose dataset
selectInput("select","Choose dataset",c("mtcars","iris"))),
# display table
mainPanel(
tabsetPanel(tabPanel("one",DT::dataTableOutput('x1')),
tabPanel("two",DT::dataTableOutput('x2'))),
tags$head(
tags$script('
Shiny.addCustomMessageHandler("unbinding_table_elements", function(x) {
Shiny.unbindAll($(document.getElementById(x)).find(".dataTable"));
});'
)
)
)
),
server = function(session, input, output) {
# function for dynamic inputs in DT
shinyInput <- function(FUN,id,num,...) {
inputs <- character(num)
for (i in seq_len(num)) {
inputs[i] <- as.character(FUN(paste0(id,i),label=NULL,...))
}
inputs
}
# function to read DT inputs
shinyValue <- function(id,num) {
unlist(lapply(seq_len(num),function(i) {
value <- input[[paste0(id,i)]]
if (is.null(value)) NA else value
}))
}
# reactive dataset
data <- reactive({
req(input$select)
session$sendCustomMessage('unbinding_table_elements', 'x1')
get(input$select)[1:5,1:3]
})
data2 <- reactive({
req(input$select)
session$sendCustomMessage('unbinding_table_elements', 'x2')
get(input$select)[5:10,1:3]
})
# render datatable with inputs
output$x1 <- DT::renderDataTable({
data.frame(data(),ENTER = shinyInput(numericInput,"numin",nrow(data()),value=NULL))
},
server=FALSE,escape=FALSE,selection='none',
options=list(language = list(search = 'Filter:'),
preDrawCallback=JS(
'function() {
Shiny.unbindAll(this.api().table().node());}'),
drawCallback= JS(
'function(settings) {
Shiny.bindAll(this.api().table().node());}')))
output$x2 <- DT::renderDataTable({
data.frame(data2(),
ENTER = shinyInput(numericInput,"numin2",nrow(data2()),value=NULL))
},
server=FALSE,escape=FALSE,selection='none',
options=list(language = list(search = 'Filter:'),
preDrawCallback=JS(
'function() {
Shiny.unbindAll(this.api().table().node());}'),
drawCallback= JS(
'function(settings) {
Shiny.bindAll(this.api().table().node());}')))
}
)