Related
What I am trying to do?
I am building a Shiny app that imports data, runs some analysis, and allows the User to make selections regarding the analysis via drop downs in a data table. The initial choices available are specific to each row in the table based on values found in the data. I want the User to be able to augment the data so new values that weren’t found in the imported data are available as choices, too. It is this last part that is giving me trouble.
I’ve created an example based on mtcars to illustrate. The construct I have for creating an editable data table is based on ID's for each cell in a column as follows (thanks to some earlier help I had on Stack to figure it out). The snippet of code below is contained in an observeEvent when I load new data. [Note the full code is at the bottom]
selectInputIDmodel <<- paste0("sel_model", 1:nrow(v$cars()$cars_meta))
v$model_applied <- reactive({match_cars(v$cars())$model_applied})
v$initTbl <-
dplyr::tibble(
car = v$cars()$cars_meta$car,
make = v$cars()$cars_meta$make,
mpg = v$cars()$cars_meta$mpg,
model = sapply(selectInputIDmodel, function(x){as.character(selectInput(inputId = ns(x), label = "",
choices = v$model_applied()$model[v$model_applied()$car == v$cars()$cars_meta$car[which(selectInputIDmodel == x)]],
selected = v$cars()$cars_meta$model[which(selectInputIDmodel == x)]
))})
)
I've set up another observeEvent for when a new model is added. I expect I need to use updateSelectInput to update the choices under the model variable. I've tried this by recreating v$initTbl under this observeEvent, but haven't figured out how to work in the updateSelectInput instead of SelectInput. The former is calling for a "session" argument, so if I just substitute "updateSelectInput" I get an error saying that I cannot convert an environment to character. If I remove the "as.character" I get a "cannot unclass an environment" error.
Further Context
Below is further context for what I am trying to do followed by the code I have.
When running the app, the Load Data button imports the mtcars data and splits the car name into make and model fields. The model field in the display table is a drop down list and has as choices the various models that are found in the data for the specific make of car. The first one in each list is the default value. The User can select from the drop downs and use the Commit button to register the choices selected. The User can go back to make changes and Commit multiple times.
There are fields to allow the User to add a new model name for a particular make of car. Save Model should apply the new model entry as a drop down choice for the relevant make of car. This is what I haven’t been able to get working.
In order to be able to confirm the updates that were committed, once the User selects Commit the first time, I am showing the resultsTbl as verbatim output at the bottom of the page. The output refreshes every time the Commit button is clicked. It is the resultsTbl that I store and will use for onward processing in another module.
Here is a sequence of steps that should be able to be completed.
Step 1: Load Data
Step 2: Change the Model in the 2nd row from “RX4” to “RX4 Wag”
Step 3: Commit and see updates reflected in the resultsTbl
Step 4: Set Select Make to “Valiant”
Step 5: Set Add Model Name to “V”
Step 6: Save Model
Step 7: “V” should appear under “Valiant” as a selection in the drop down
Step 8: Commit and “V” should appear as the model for row 6 in resultsTbl
Step 9: Change the Model in the last row from “240D” to “280”
Step10: Commit and see update reflected in the resultsTbl
What have I tried?
The Load Data button triggers an observeEvent that does the following:
Sets up the data
Determines which models are available for which makes of car (for the drop downs)
Initiates the data table (initTbl)
I use a reactive (displayTbl) to capture the updates to feed the proxy table.
I then use a reactive (resultTbl) to store the captured values.
This all works fine.
I use Save Model as another observeEvent to update which models are available for which makes of car, to add new values to the drop downs where relevant.
I have not been able to figure how to make this work.
I believe I need some way to reinitialize the data table with the refreshed choices for the drop downs, whilst preserving any previously selected values. As noted above, I am unsure how to integrate updateSelectInput into the existing code.
Any help would be greatly appreciated.
Here is the current state of my code:
#********* LIBRARIES *************************************************
library(magrittr)
library(dplyr)
library(tidyselect)
library(shiny)
library(stringr)
library(purrr)
library(shinyjs)
library(zeallot)
library(DT)
#******** FUNCTIONS ***************************************************
# Creates the new data set / cars object
create_data2 <- function(){
#simulate data import
cars_df <- head(mtcars, 10)
#simulate creating meta table
cars_meta <- dplyr::tibble(car = rownames(cars_df), make = sub("([A-Za-z]+).*", "\\1", rownames(cars_df)), cars_df)
cars_meta$model <- NA
#simulate creating cars_list
names <- rownames(cars_df)
`%<-%` <- zeallot::`%<-%`
car <- list()
car[c("head", "m1", "m2")] %<-% data.frame(stringr::str_split(names, " ", simplify = TRUE))
car$m <- paste(car$m1, car$m2)
cars_list <- list()
for(h in car$head){
cars_list[[h]] <- list(car$m[car$head==h])
}
#simulate creating the cars_object
cars_object <- list()
cars_object$cars_df <- cars_df
cars_object$cars_meta <- cars_meta
cars_object$cars_list <- cars_list
return(cars_object)
}
# Updates the cars object with resultTbl
meta_table <- function(object, table){
tbl <- table
object$cars_meta <- tbl
return(object)
}
# Matches the models and makes of the cars
match_cars <- function(cars_object){
cv <- cars_object$cars_meta
car_match <- list()
for (car in cv$car){
x <- 1
for (model in cars_object$cars_list[[cv$make[cv$car == car]]][[1]]){
car_match[[paste0(car,"#",x)]][["model"]] <- model
x <- x + 1
}
}
model_applied <-
if(nrow(dplyr::bind_rows(car_match)) >0) {
dplyr::bind_rows(car_match) %>%
mutate(car = stringr::str_replace_all(names(car_match),"#\\d",""))
} else {
data.frame(car = "", drop = FALSE)
}
model_reduced <- model_applied %>%
dplyr::group_by(car) %>%
dplyr::slice(1) %>%
dplyr::ungroup()
cv <- cv %>%
select(-model) %>%
left_join(model_reduced, by = "car") %>%
select(car, make, mpg, model)
cars_object$cars_meta <- cv
cars_object$model_applied <- model_applied
return(cars_object)
}
# Adds a new make/model combination to cars_list of the cars object
new_model <- function(cars_object, make, new){
cars_object$cars_list[[make]] <- c(new, cars_object$cars_list[[make]][[1]])
return(cars_object)
}
#******** UI ********************************************************
mod_data_ui <- function(id) {
fluidPage(
actionButton(NS(id,"new_data"), "Load Data"),
br(),
DT::dataTableOutput(NS(id, 'dt')),
br(),
actionButton(NS(id, "commit_meta"), "Commit"),
br(),
verbatimTextOutput(NS(id,"results")),
br(),
uiOutput(NS(id,"make_set")),
br(),
uiOutput(NS(id, "model_value")),
br(),
uiOutput(NS(id, "save_model")),
br(),
verbatimTextOutput(NS(id,"meta"))
)
}
shiny_ui <- function() {
navbarPage(
title = div(span("Data",
style = "position: relative; top: 50%; transform: translateY(-50%);")),
tabPanel(
"Data Management",
mod_data_ui("data")
)
)
}
#**** SERVER ***********************************************************
mod_data_server <- function(id) {
shiny::moduleServer(id, function(input, output,session){
ns <- session$ns
v <- reactiveValues()
#place holders
selectInputIDmodel <- "model"
observeEvent(input$new_data, once = TRUE, {
data <- create_data2()
v$cars <- reactive({data})
selectInputIDmodel <<- paste0("sel_model", 1:nrow(v$cars()$cars_meta))
v$model_applied <- reactive({match_cars(v$cars())$model_applied})
v$initTbl <-
dplyr::tibble(
car = v$cars()$cars_meta$car,
make = v$cars()$cars_meta$make,
mpg = v$cars()$cars_meta$mpg,
model = sapply(selectInputIDmodel, function(x){as.character(selectInput(inputId = ns(x), label = "",
choices = v$model_applied()$model[v$model_applied()$car == v$cars()$cars_meta$car[which(selectInputIDmodel == x)]],
selected = v$cars()$cars_meta$model[which(selectInputIDmodel == x)]
))})
)
})
displayTbl <- reactive({
req(input$new_data)
dplyr::tibble(
car = v$cars()$cars_meta$car,
make = v$cars()$cars_meta$make,
mpg = v$cars()$cars_meta$mpg,
model = sapply(selectInputIDmodel, function(x){as.character(selectInput(inputId = ns(x), label = "",
choices = v$model_applied()$model[v$model_applied()$car == v$cars()$cars_meta$car[which(selectInputIDmodel == x)]],
selected = input[[x]]))})
)
})
output$dt <- DT::renderDataTable({
req(input$new_data)
DT::datatable(
v$initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
})
dt_table_proxy <- DT::dataTableProxy(outputId = "dt")
observeEvent({sapply(selectInputIDmodel, function(x){input[[x]]})}, {
DT::replaceData(proxy = dt_table_proxy, data = displayTbl(), rownames = FALSE)
}, ignoreInit = TRUE)
v$resultTbl <- reactive({
dplyr::tibble(
car = v$cars()$cars_meta$car,
make = v$cars()$cars_meta$make,
mpg = v$cars()$cars_meta$mpg,
model = sapply(selectInputIDmodel, function(x){as.character(input[[x]])})
)
})
observeEvent(input$commit_meta, {
cars_updated <- meta_table(v$cars(), v$resultTbl())
v$cars <- reactive({cars_updated})
})
# add model manually
output$make_set <- renderUI({
req(input$new_data)
make <- v$cars()$cars_meta$make
#make_sel <- unique(make)
selectInput(NS(id, "make_set"), "Select Make", multiple = FALSE, choices = make)
})
output$model_value <- renderUI({
req(input$new_data)
textInput(NS(id, "model_value"), "Add Model Name")
})
output$save_model <- renderUI({
req(input$new_data)
actionButton(NS(id, "save_model"), "Save Model", style="color: #fff; background-color: #337ab7; border-color: #2e6da4")
})
observeEvent(input$save_model,{
car <- meta_table(v$cars(), v$resultTbl()) # This is the same step as under commit
v$cars <- reactive({match_cars(
new_model(
cars_object = car,
make = input$make_set,
new = input$model_value
)
)
})
v$model_applied <- reactive({match_cars(v$cars())$model_applied})
updateTextInput(session, "model_value", value = "")
})
output$meta <- renderPrint({
req (input$commit_meta > 0)
tf <- v$cars()$cars_meta
tf %>% print(n = Inf)
})
return(reactive(v))
})
}
shiny_server <- function(input, output, session) {
v <- mod_data_server("data")
}
#********* APP *******************************
svyStudyapp_app <- function(...) {
app <- shiny::shinyApp(
ui = shiny_ui,
server = shiny_server
)
shiny::runApp(app, ...)
}
use updateSelectInput inside an observeEvent or observe function. Pass in the Shiny session object, the input ID of the selectInput element and a vector of new choices.
like this
observeEvent(input$saveModelButton, {
updateSelectInput(session, "sel_model6", choices = c("V", "Other models"))
})
I'm writing an app that will help wrangle data files into standard formats to feed reusable dashboards. Part of this effort involves creating a user interface to make it easy for users to map the random column names they have in their input files to the "standard" column names that the dashboard is going to expect.
I actually got this code working nicely. But the app needs to do this same mapping exercise for several different input files (each with their own set of standard column names), so it seemed like a good candidate to modularize!
Here's the workflow:
The user loads a "mapping input" file. If they've done this mapping
exercise before, I want to use this file to pre-populate the
drop-downs. I'm also pulling the list of standard column names from
this table. Each standard column name gets an associated drop down.
They load their file to be wrangled - the one with the wackly column
names. The column names in this file will become the options in the
drop-downs.
As the user starts mapping their column names to the different
standard name drop downs, their selections will disappear from the
other drop-down lists. This makes it easier to map columns in files
with many columns.
I feel like I am so close. The issue is when the module runs updateSelectInput. I'm using updateSelectInput to remove options from the drop-downs that have already been used. This works, but it clears out the pre-populated values that were set in the renderUI function.
Here's the code with the pre-populated values working (having removed the problematic updateSelectInput):
# Load libraries and options ----------------------------------------------
library(shiny)
library(dplyr)
library(tidyr)
options(stringsAsFactors = FALSE)
# Modules -----------------------------------------------------------------
input_ui <- function(id, row_label, file_description) {
ns <- NS(id)
fluidRow(
uiOutput(ns("colmapping")) # References the dynamic dropdowns created by the server module.
)
}
# Creates dynamic dropdowns which ultimately will be used to rename columns from a number of different files.
input_server <- function(input, output, session, parent) {
# Create a fake file with misnamed columns that need remapped.
input_file <- reactive({
return(data.frame(Account.Number = 1:2,
Account.Name = c("Account 1", "Account 2"),
Quota.2018 = c(1000, 2000)))
})
# Get a list of what the columns SHOULD be named. These will also do double-duty as the labels for our dropdown inputs.
standard_columns <- reactive({
c("AccountId", "AccountName", "SalesGoal")
})
# Get the actual column names from the file with misnamed columns.
actual_columns <- reactive({
colnames(input_file())
})
# A separate input can be loaded that documents how the misnamed columns have been mapped to the correct names in the past.
# We want to pre-populate the dropdowns with these selections.
quickstart_columns <- reactive({
c("Account.Number", "Account.Name", "Quota")
})
# Create a drop-down selectInput for each of the "standard" column names, allowing the user to choose from the column names in their own misnamed file.
output$colmapping <- renderUI({
ns <- session$ns
dropdowns = tagList()
for (i in seq_len(length(standard_columns()))) { # For i in 1:number of standard names associated with this table
dropdowns[[i]] = selectInput(ns(paste0("input_", standard_columns()[i])), # Use the standard name value for the input object name
label = paste0(standard_columns()[i]), # And for the UI label
choices = actual_columns(),
selected = quickstart_columns()[i],
multiple = FALSE) #Use choices from loaded input table
}
return(dropdowns)
})
}
# UI ----------------------------------------------------------------------
ui <- fluidPage(
input_ui("acct_info")
)
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
acct_info_mod_results <- callModule(input_server,
"acct_info",
parent = session)
}
shinyApp(ui = ui, server = server)
And here's the same code with updateSelectInput turned on (so selected-elsewhere options drop from the choices), but where the pre-populated values don't show up.
# Load libraries and options ----------------------------------------------
library(shiny)
library(dplyr)
library(tidyr)
options(stringsAsFactors = FALSE)
# Modules -----------------------------------------------------------------
input_ui <- function(id, row_label, file_description) {
ns <- NS(id)
fluidRow(
uiOutput(ns("colmapping")) # References the dynamic dropdowns created by the server module.
)
}
# Creates dynamic dropdowns which ultimately will be used to rename columns from a number of different files.
input_server <- function(input, output, session, parent) {
# Create a fake file with misnamed columns that need remapped.
input_file <- reactive({
return(data.frame(Account.Number = 1:2,
Account.Name = c("Account 1", "Account 2"),
Quota.2018 = c(1000, 2000)))
})
# Get a list of what the columns SHOULD be named. These will also do double-duty as the labels for our dropdown inputs.
standard_columns <- reactive({
c("AccountId", "AccountName", "SalesGoal")
})
# Get the actual column names from the file with misnamed columns.
actual_columns <- reactive({
colnames(input_file())
})
# A separate input can be loaded that documents how the misnamed columns have been mapped to the correct names in the past.
# We want to pre-populate the dropdowns with these selections.
quickstart_columns <- reactive({
c("Account.Number", "Account.Name", "Quota")
})
# Create a drop-down selectInput for each of the "standard" column names, allowing the user to choose from the column names in their own misnamed file.
output$colmapping <- renderUI({
ns <- session$ns
dropdowns = tagList()
for (i in seq_len(length(standard_columns()))) { # For i in 1:number of standard names associated with this table
dropdowns[[i]] = selectInput(ns(paste0("input_", standard_columns()[i])), # Use the standard name value for the input object name
label = paste0(standard_columns()[i]), # And for the UI label
choices = actual_columns(),
selected = quickstart_columns()[i],
multiple = FALSE) #Use choices from loaded input table
}
return(dropdowns)
})
# This is the chunk of code giving me trouble!
# For some of these files, there's like 20-some columns that will need renamed. That's a lot of scanning through long dropdown lists.
# As the user starts to map some of the columns, I want their selections to disappear from the other drop downs.
# The good news is, this works!
# The bad news is, it also clears out the pre-populated inputs. How can I keep the pre-populated inputs from disappearing when I apply updateSelectInput?
observe({
ns <- session$ns
n <- isolate(length(standard_columns()))
for (i in seq_len(n)) {
already_selected <- unlist(lapply((1:n)[-i], function(i)
input[[ paste0("input_",standard_columns()[i]) ]]))
print(i)
selected_i <- input[[ paste0("input_", standard_columns()[i]) ]]
print(selected_i) # For debugging. These return empty values until selections are made, but I never had the problem with analogous code until I tried to put it in the module.
updateSelectInput(session = parent,
ns(paste0("input_",standard_columns()[i])),
choices = append(c("Empty"),setdiff(actual_columns(), already_selected)),
selected = input[[ paste0("input_", standard_columns()[i]) ]]
)
}
})
}
# UI ----------------------------------------------------------------------
ui <- fluidPage(
input_ui("acct_info")
)
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
acct_info_mod_results <- callModule(input_server,
"acct_info",
parent = session)
}
shinyApp(ui = ui, server = server)
This is the first time I've gotten so totally stuck on a project!! I hugely appreciate any insight or suggestions!
EDIT: After much pain, I've figured out how to get a list of session inputs that I can loop through to create the updateSelectInput in the parent session. I've also figured out how to put it into a function in the main session. Here's a minimal example of the working fix, but I'm all ears if anyone has a smarter way to solve the problem!
# Load libraries and options ----------------------------------------------
library(shiny)
library(dplyr)
options(stringsAsFactors = FALSE)
updateDropDowns <- function(session, all_inputs) {
inputs <- setdiff(all_inputs$names, all_inputs$names %>% str_subset(pattern="selectize"))
selected <- unname(unlist(all_inputs %>% filter(names %in% inputs) %>% select(selected)))
values <- c("a", "b", "c", "d")
n <- length(inputs)
for (i in seq_len(n)) {
already_selected <- unlist(lapply((1:n)[-i], function(i)
selected[i]))
updateSelectInput(session,
inputs[i],
choices = setdiff(values, already_selected),
selected = selected[i])
}
}
# UI ----------------------------------------------------------------------
ui <- fluidPage(
uiOutput("colmapping")
)
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
output$colmapping <- renderUI({
dropdowns = tagList()
for (i in 1:3) {
dropdowns[[i]] = selectInput(paste0("input_",i),
label = paste0("input_",i),
choices = c("a", "b", "c", "d"),
selected = NULL,
multiple = FALSE)
}
return(dropdowns)
})
all_inputs <- reactive({ # get a dataframe of input names and values, else return an empty df
x <- reactiveValuesToList(input)
y <- data.frame(
names = names(x),
selected = unlist(x, use.names = FALSE)
)
empty <- as.data.frame(setNames(rbind(data.frame(matrix(ncol = 2, nrow = 1)),
c(rep("999",2))),
c("names", "selected")))
if(nrow(y) == 0) {empty} else {y}
})
observe({
updateDropDowns(session, all_inputs())
})
}
shinyApp(ui = ui, server = server)
To filter a data.frame with lots of variables I created a selectizeInput which allows you to select one of the columns of the data. This then creates another selectizeInput for the selected variable which can be used for subsetting the data. The selected value of the second selectizeInput is rendered below.
This is what it looks like
I want to render the selected values of these inputs so that these can be deleted by the user by clicking the black cross. Also a selection of var2 should not be deleted when the Filter selectizeInput is changed to var1.
So it should look like this (assuming the user previously selected value z in var2 and then value a in var1.
Anyone knows a good solution in shiny?
This is the code:
library(shiny)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output) {
observeEvent(input$filter, {
# dynamically generate selectizeInput for filter
output$filter_var <- renderUI({
selectizeInput(input$filter, label = input$filter,
choices = data[input$filter], multiple = TRUE)
})
})
# show selected filter values
# selected filter values should stay when choosing new input filter variable
# these should be deletable
observeEvent(input[[input$filter]], {
output$selected_filter_value <- renderUI({
textOutput("text_out")
})
output$text_out <- renderText({
paste0(input$filter, ": ", input[[input$filter]])
})
})
}
shinyApp(ui, server)
Well, I had to rearrange quite a lot and this whole problem is more about finding the right implementation for your case.
You can probably deduct most of it just looking at the code at the end of this post.
Main things explained: You didn't actually say what deleting means to you. So I just assumed you wanted the cells to not appear in the select boxes anymore. For that, I excluded NAs and replaced cells with an NA to show that they are deleted.
I rearranged the select values, such that we actually can delete certain cells, giving row and column names instead of just their values.
And most important, the buttons you wanted to create are dynamic UI elements with dynamic observers, which are then addressed to delete the certain cell.
Note: This solution is not optimal, since I specifically aimed to stay just on the R side of shiny. You can achieve a much more elegant and resource saving solution if you use JavaScript and shiny's custom messages.
Also: I did not address your request to let the selected values visible if the first select box changes. But this is a rather small issue, if you reconsider your setup. And I didn't want to diverge too much from you original code to not be confusing.
Code now:
library(shiny)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output) {
# Pulled out from original observeEvent
makeSecondInput <- function() {
output$filter_var <- renderUI({
# Names are not enough when wanting to delete data.frame rows (because of duplicates).
# So we instead use row numbers and set the actual values as labels.
choiceData <- na.exclude(data[input$filter])
choices <- rownames(choiceData)
names(choices) <- choiceData[, input$filter]
selectizeInput(input$filter, label = input$filter, selected = input[[input$filter]],
choices = choices, multiple = TRUE)
})
}
observeEvent(input$filter, {
makeSecondInput()
})
# Install a manual trigger to redraw input field, when an option is killed.
trigger <- reactiveVal()
observeEvent(trigger(), ignoreNULL = TRUE, {
makeSecondInput()
})
# Keep track of created observers, so dynamic creation does not wildly stack them up.
observersCreated <- character()
makeButtonObserver <- function(buttonname, colname, rowname) {
# For each delete-button created, install observer to delete data.frame cell.
observeEvent(input[[buttonname]], {
data[rowname, colname] <<- NA
# Force re-evaluation of observer above.
trigger(runif(1))
})
# Track that this button is equipped. (And re-creation of the same button does not add another obs.)
# Note: Observers DON'T get automagically removed after actionButton is no longer in the UI.
observersCreated <<- c(observersCreated, buttonname)
}
observeEvent(input[[input$filter]], {
output$selected_filter_value <- renderUI({
# Could be a list, so splitting that up.
lapply(input[[input$filter]], function(v) {
buttonname <- paste("kill", input$filter, v, sep = "_")
if (!(buttonname %in% observersCreated)) {
makeButtonObserver(buttonname, input$filter, v)
}
span(
paste0(input$filter, ": ", data[v, input$filter]),
actionButton(buttonname, "x")
)
})
})
})
}
shinyApp(ui, server)
This is what I currently have. There are still some issues which I couldn't solve.
Problems:
if I make some selections in input1, then switch from input1 to input2 and unclick one of the selections from input1 and then switch back to input1 these changes will be unmade
the checkboxes are rerendered when a new one is added and in this process sorted which changes the order
Code:
library(shiny)
library(shinyWidgets)
data <- data.frame(var1 = c("a", "b"), var2 = c("y", "z"))
ui <- fluidPage(
selectizeInput("filter", label = "Filter",
multiple = FALSE, choices = c("var1", "var2")),
uiOutput("filter_var"),
uiOutput("selected_filter_value")
)
server <- function(input, output, session) {
values <- reactiveValues(
filter_vals = list(var1 = list(), var2 = list()),
observers = NULL
)
# dynamically generate selectizeInput for variable selected in filter
# set selected values to previous selections
observeEvent(input$filter, {
output$filter_var <- renderUI({
selectInput(input$filter, label = input$filter,
selected = values$filter_vals[[input$filter]],
choices = data[input$filter], multiple = TRUE, selectize = TRUE)
})
})
# store selected values in list
observeEvent(input[[input$filter]], {
values$filter_vals[[input$filter]] <- input[[input$filter]]
})
# we need this because observeEvent is not triggered if input is empty after deleting all selections
observe({
if (is.null(input[[input$filter]])) {
values$filter_vals[[input$filter]] <- list()
}
})
# add an observer for newly created checkbox
# if checkbox is clicked delete entry in list
# keep a list of all existing observers
make_delete_observer <- function(name) {
observeEvent(input[[name]], {
req(input[[name]] == FALSE)
var <- stringr::str_split(name, "_")[[1]][1]
val <- as.integer(stringr::str_split(name, "_")[[1]][2])
values$filter_vals[[var]] <- intersect(values$filter_vals[[var]][-val],
values$filter_vals[[var]])
updateSelectInput(session, var, selected = values$filter_vals[[var]])
})
}
# render selected values which are stored in a list as checkboxes
# add an observeEvent for each checkbox
# store selected values in list
output$selected_filter_value <- renderUI({
req(values$filter_vals[[input$filter]])
req(any(sapply(values$filter_vals, length) > 0))
tag_list <- tagList()
for (i in seq_along(values$filter_vals)) {
for (j in seq_along(values$filter_vals[[i]])) {
new_input_name <- paste0(names(values$filter_vals)[i], "_", j)
new_input <- prettyCheckbox(
inputId = new_input_name, value = TRUE,
label = paste0(names(values$filter_vals)[i], ": ", values$filter_vals[[i]][j]),
icon = icon("close"), status = "danger", outline = FALSE, plain = TRUE
)
# create observer only if it does not exist yet
if (!(new_input_name %in% values$observers)) {
values$observers <- append(values$observers, new_input_name)
make_delete_observer(new_input_name)
}
tag_list <- tagAppendChild(tag_list, new_input)
}
}
tag_list
})
}
shinyApp(ui, server)
When a row in a DataTable is clicked, I would like an image in a different panel to be loaded but, I keep getting an error and not.
**Warning in widgetFunc() :
renderDataTable ignores ... arguments when expr yields a datatable object; see ?renderDataTable
Error in basename(file) : a character vector argument expected**
output$image1 <- renderImage({
s = input$table1_rows_selected
if (length(s)) list(src=paste0(imagePath,"/peak",s,".png"))},deleteFile=FALSE)
The function below works however,
output$image1 <- renderImage({list(src=paste0(imagePath,"/peak1.png"))},deleteFile=FALSE)
Here is a full version of the code:
server.R
writeLines("Please select ANY image")
imagePath = file.choose()
# break up the character vector, delete the last word
imagePath = dirname(imagePath)
server = function(input, output) {
output$table1 = renderDataTable({
# the peak table
datatable(peaksTable,
# when rowname is false each row does not have a numeric # associated with it
rownames = FALSE,
# specify the name of the column headers
colnames = c("Seqnames", "Start", "End","Width","Strand","P","Q","Effectsize",
"FDR","Keep","Gene_name","Gene.nearest","Count","Count.pred",
"Coverage","Local.mut.density","Base.context.GC","Tn.Context.TpC",
"Tn.context.CpG","Dnase","Activechrom","Hetchrom","Rept"))
},
escape = FALSE)
# render an Image based on which rows are clicked on.
output$image1 <- renderImage({
s = input$table1_rows_selected
if (length(s)) list(src=paste0(imagePath,"/peak",s,".png"))},deleteFile=FALSE)
ui.R
shinyUI(navbarPage(
title = " Nanoproject",
# first panel , create table of the peaksTable dataframe
tabPanel('Peak Table' ,
dataTableOutput('table1')),
# second panel
tabPanel('Peak Images' ,
imageOutput("image1",width = "auto",height = "auto")
))
I'm not sure where I'm going wrong.
Like it's been pointed out, without a reproducible example it's hard to help.
My guess is that your code is not dealing with the case where no rows are selected. If that's true, something like this should fix the problem:
server.R
output$image1 <- renderImage({
s <- input$table1_rows_selected
# print(s)
if(is.null(s)) return(NULL)
list(src = paste0(imagePath,"/peak",s,".png"))
}, deleteFile=FALSE)
Printing out s could help you understand better whats going on.
I´m having problems combining two features while building a data table:
I use “bSearchable” to select 1 column that I want to use the search tool to filter
I use "checkboxInput" to select the columns the user wants to see.
Both work separately, but not together. If I uncheck a column in my menu input, the data disappears - like applying a filter and no data was found. How can I fix this?
library(shiny)
runApp(list(ui=(fluidPage(
pageWithSidebar(
headerPanel('Title'),
sidebarPanel(
helpText('Text about the table'),
checkboxInput('columns','I want to select the columns' , value = FALSE),
conditionalPanel(
condition= "input.columns == true",
checkboxGroupInput('show_vars', 'Select the columns that you want to see:', names(iris[1:4]),
selected = names(iris[1:4]))
),
downloadButton('downloadData', 'Download'),width = 3
),
mainPanel(
tags$head(tags$style("tfoot {display: table-header-group;}")),
dataTableOutput("mytable1"),width = 9
)
))
)
,
server=(function(input, output) {
library(ggplot2)
library(XLConnect)
#DATA
tabel<- reactive({
iris[,c(input$show_vars,"Species"), drop = FALSE]
})
# OUTPUT
output$mytable1 = renderDataTable({
tabel()},
options = list(
aoColumns = list(list(bSearchable = FALSE), list(bSearchable = FALSE),list(bSearchable = FALSE),
list(bSearchable = FALSE),list(bSearchable = TRUE)),
bFilter=1, bSortClasses = 1,aLengthMenu = list(c(10,25,50, -1), list('10','25', '50', 'Todas')),iDisplayLength = 10
)
)
output$downloadData <- downloadHandler(
filename = function() { paste('tabela_PSU','.xlsx', sep='') },
content = function(file){
fname <- paste(file,"xlsx",sep=".")
wb <- loadWorkbook(fname, create = TRUE)
createSheet(wb, name = "Sheet1")
writeWorksheet(wb, tabel(), sheet = "Sheet1")
saveWorkbook(wb)
file.rename(fname,file)
},
)
})
))
The problem is by filtering the data iris based on input$show_vars, you are changing the number of columns of the DataTable.
However, you have defined a fixed aoColumns option, which implies your DataTable has five columns (four non-searchable, one searchable).
Therefore, when you deselect any checkbox inputs, the filtered data doesn't match the specified options. As a result, nothing is displayed.
That is, although your data in the DataTable is reactive, the options, however, are NOT reactive.
If you read the renderDataTable's document carefully, you will see that you can pass two types of variables to the options argument:
options A list of initialization options to be passed to DataTables, or a function to return such a list.
The differences are:
If you specify options as a list, Shiny assumes that the options are fixed; But since you are dynamically filtering the data based on input$show_vars, you should dynamically change the options for aoColumns as well.
If you pass a function as an argument for options, Shiny will know that the options are also reactive. Hence Shiny will also update the options when the data (in your case, the data.frame encapsulated in the reactive variable named tabel) updates.
You may already know that reactive variables are themselves functions. They are evaluated in a reactive environment and when evaluated, they return the current state/value of the data. This is why you pass tabel() instead of tabel to renderDataTable.
The solution then, is to wrap the entire options list into a reactive variable (hence a function as well). Specifically, we want to dynmaically set the aoColumns option so that the number of bSearchable toggles matches the number of columns shown in the DataTable.
Below I only show the updated server part, since there's nothing needs to be changed in the UI part.
server.R
shinyServer(function(input, output) {
library(ggplot2)
library(XLConnect)
#DATA
tabel<- reactive({
iris[,c(input$show_vars,"Species"), drop = FALSE]
})
# wrap the `options` into a reactive variable (hence a function) so that it will
# be evaluated dynamically when the data changes as well.
# `dt_options` is reactive in the sense that it will reflect the number of rows
# visible based on the checkboxInput selections.
dt_options <- reactive({
# dynamically create options for `aoColumns` depending on how many columns are selected.
toggles <- lapply(1:length(input$show_vars), function(x) list(bSearchable = F))
# for `species` columns
toggles[[length(toggles) + 1]] <- list(bSearchable = T)
list(
aoColumns = toggles,
bFilter = 1, bSortClasses = 1,
aLengthMenu = list(c(10,25,50, -1), list('10','25', '50', 'Todas')),
iDisplayLength = 10
)
})
# OUTPUT
output$mytable1 = renderDataTable({
tabel()},
options = dt_options
)
output$downloadData <- downloadHandler(
filename = function() { paste('tabela_PSU','.xlsx', sep='') },
content = function(file){
fname <- paste(file,"xlsx",sep=".")
wb <- loadWorkbook(fname, create = TRUE)
createSheet(wb, name = "Sheet1")
writeWorksheet(wb, tabel(), sheet = "Sheet1")
saveWorkbook(wb)
file.rename(fname,file)
},
)
})
(Note that I separate the UI part and server part into ui.R and server.R.)