Related
I'm trying to store user input into a pre-existing dataframe in shiny.
In this simplified example I have a dataframe with a column labelled 'colour' and I want radio choice buttons to be able to assign values to each row in the dataframe, starting with row 1, then row 2 then row 3 etc. But it seems the dataframe always resets to the original value. What am I misunderstanding about shiny here?
library(shiny)
library(tidyverse)
library(DT)
dataframe <- tibble(row_id = c(1,2,3),
colour = c("","",""))
ui <- fluidPage(
radioButtons("colour",
"Pick a colour:",
choices = c("blue","green","red")),
actionButton("next_button", "Pick the next colour"),
DTOutput("dataframe")
)
server <- function(input, output) {
vals <- reactiveValues(active_row = 1)
observeEvent(input$next_button,{
dataframe[vals$active_row, "colour"] = input$colour
# view(dataframe)
# print(vals$active_row)
vals$active_row = vals$active_row + 1
output$dataframe <- renderDataTable(dataframe)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I would store your data also in reactiveValues. In addition, you can move your output outside of your observeEvent. This server function should work based on your description.
server <- function(input, output) {
vals <- reactiveValues(active_row = 1, data = dataframe)
observeEvent(input$next_button,{
vals$data[vals$active_row, "colour"] = input$colour
vals$active_row = vals$active_row + 1
})
output$dataframe <- renderDataTable(vals$data)
}
UPDATE
I am trying to make an app using shiny and DT, similar to the accepted answer from Shree here. I would like, thou, to have the following additions to it:
Extend the solution from Shree, so that items from the DT on the left (source) can be moved to more than one table on the right and back and be extensible, so that I can decide how many tables I want to put on the right. That is, different items from the table on the left can go in a different table on the right.
In addition, to have double arrow buttons next to each table on the right, so that all items in a table can be added or removed by click on the double arrow buttons, not only the single arrow buttons for moving just selected variables, like here, but still be able to decide whether to display them or not.
Tables on the right to be visible even when empty.
Can someone help with these?
As already mentioned shiny modules are an elegant way to solve this issue. You have to pass in some reactives for receiving rows and you have to return some reactives to send rows / tell the main table that it should remove the rows it just sent.
A fully working example looks as follows:
library(shiny)
library(DT)
receiver_ui <- function(id, class) {
ns <- NS(id)
fluidRow(
column(width = 1,
actionButton(ns("add"),
label = NULL,
icon("angle-right")),
actionButton(ns("add_all"),
label = NULL,
icon("angle-double-right")),
actionButton(ns("remove"),
label = NULL,
icon("angle-left")),
actionButton(ns("remove_all"),
label = NULL,
icon("angle-double-left"))),
column(width = 11,
dataTableOutput(ns("sink_table"))),
class = class
)
}
receiver_server <- function(input, output, session, selected_rows, full_page, blueprint) {
## data_exch contains 2 data.frames:
## send: the data.frame which should be sent back to the source
## receive: the data which should be added to this display
data_exch <- reactiveValues(send = blueprint,
receive = blueprint)
## trigger_delete is used to signal the source to delete the rows whihc just were sent
trigger_delete <- reactiveValues(trigger = NULL, all = FALSE)
## render the table and remove .original_order, which is used to keep always the same order
output$sink_table <- renderDataTable({
dat <- data_exch$receive
dat$.original_order <- NULL
dat
})
## helper function to move selected rows from this display back
## to the source via data_exch
shift_rows <- function(selector) {
data_exch$send <- data_exch$receive[selector, , drop = FALSE]
data_exch$receive <- data_exch$receive[-selector, , drop = FALSE]
}
## helper function to add the relevant rows
add_rows <- function(all) {
rel_rows <- if(all) req(full_page()) else req(selected_rows())
data_exch$receive <- rbind(data_exch$receive, rel_rows)
data_exch$receive <- data_exch$receive[order(data_exch$receive$.original_order), ]
## trigger delete, such that the rows are deleted from the source
old_value <- trigger_delete$trigger
trigger_delete$trigger <- ifelse(is.null(old_value), 0, old_value) + 1
trigger_delete$all <- all
}
observeEvent(input$add, {
add_rows(FALSE)
})
observeEvent(input$add_all, {
add_rows(TRUE)
})
observeEvent(input$remove, {
shift_rows(req(input$sink_table_rows_selected))
})
observeEvent(input$remove_all, {
shift_rows(req(input$sink_table_rows_current))
})
## return the send reactive to signal the main app which rows to add back
## and the delete trigger to remove rows
list(send = reactive(data_exch$send),
delete = trigger_delete)
}
ui <- fluidPage(
tags$head(tags$style(HTML(".odd {background: #DDEBF7;}",
".even {background: #BDD7EE;}",
".btn-default {min-width:38.25px;}",
".row {padding-top: 15px;}"))),
fluidRow(
actionButton("add", "Add Table")
),
fluidRow(
column(width = 6, dataTableOutput("source_table")),
column(width = 6, div(id = "container")),
)
)
server <- function(input, output, session) {
orig_data <- mtcars
orig_data$.original_order <- seq(1, NROW(orig_data), 1)
my_data <- reactiveVal(orig_data)
handlers <- reactiveVal(list())
selected_rows <- reactive({
my_data()[req(input$source_table_rows_selected), , drop = FALSE]
})
all_rows <- reactive({
my_data()[req(input$source_table_rows_current), , drop = FALSE]
})
observeEvent(input$add, {
old_handles <- handlers()
n <- length(old_handles) + 1
uid <- paste0("row", n)
insertUI("#container", ui = receiver_ui(uid, ifelse(n %% 2, "odd", "even")))
new_handle <- callModule(
receiver_server,
uid,
selected_rows = selected_rows,
full_page = all_rows,
## select 0 rows data.frame to get the structure
blueprint = orig_data[0, ])
observeEvent(new_handle$delete$trigger, {
if (new_handle$delete$all) {
selection <- req(input$source_table_rows_current)
} else {
selection <- req(input$source_table_rows_selected)
}
my_data(my_data()[-selection, , drop = FALSE])
})
observe({
req(NROW(new_handle$send()) > 0)
dat <- rbind(isolate(my_data()), new_handle$send())
my_data(dat[order(dat$.original_order), ])
})
handlers(c(old_handles, setNames(list(new_handle), uid)))
})
output$source_table <- renderDataTable({
dat <- my_data()
dat$.original_order <- NULL
dat
})
}
shinyApp(ui, server)
Explanation
A module contains the UI and the server and thanks to the namespacing techniques, names need only to be unique within one module (and each module must later have also a unique name). The module can communicate with the main app via reactives which are either passed to callModule (please note that I am still using the old functions as I have not yet updated my shiny library), or which are returned from the server function.
In the main app, we have a button, which dynamically inserts the UI and calls callModule to activate the logic. observers are also generated in the same call to make the server logic work.
To get double arrow buttons, you can use:
actionButton("add_all", label = NULL, icon("angle-double-right"),
lib = "font-awesome")
Note that ?icon links to the fontawesome page, which provides double arrow icons: https://fontawesome.com/icons?d=gallery&q=double%20arrow&m=free.
To remove all items you can just switch to the default state:
observeEvent(input$remove_all, {
mem$selected <- select_init
mem$pool <- pool_init
})
where the default state was defined as:
pool_init <- data.frame(data = LETTERS[1:10])
select_init <- data.frame(data = "")
To add all rows you can basically just switch the states:
mem$selected <- pool_init
mem$pool <- select_init
Note that i use an (almost) empty data.frame to ensure that a datatable is shown even if it is empty. That is not very elegant as it has an empty string in it. There might be better ways for that. E.g. if you add a row and deselect it again, so that the table is empty it shows No data available in table. That actually looks better.
Full reproducible example:
library(shiny)
library(DT)
ui <- fluidPage(
br(),
splitLayout(cellWidths = c("40%", "10%", "40%", "10%"),
DTOutput("pool"),
list(
br(),br(),br(),br(),br(),br(),br(),
actionButton("add", label = NULL, icon("arrow-right")),
br(),br(),
actionButton("remove", label = NULL, icon("arrow-left"))
),
DTOutput("selected"),
list(
br(),br(),br(),br(),br(),br(),br(),
actionButton("add_all", label = NULL, icon("angle-double-right"),
lib = "font-awesome"),
br(),br(),
actionButton("remove_all", label = NULL, icon("angle-double-left"),
lib = "font-awesome")
)
)
)
pool_init <- data.frame(data = LETTERS[1:10])
select_init <- data.frame(data = "")
server <- function(input, output, session) {
mem <- reactiveValues(
pool = pool_init, selected = select_init
)
observeEvent(input$add, {
req(input$pool_rows_selected)
mem$selected <- rbind(isolate(mem$selected), mem$pool[input$pool_rows_selected, , drop = F])
mem$selected <- mem$selected[sapply(mem$selected, nchar) > 0, , drop = FALSE]
mem$pool <- isolate(mem$pool[-input$pool_rows_selected, , drop = F])
})
observeEvent(input$remove, {
req(input$selected_rows_selected)
mem$pool <- rbind(isolate(mem$pool), mem$selected[input$selected_rows_selected, , drop = F])
mem$pool <- mem$pool[sapply(mem$pool, nchar) > 0, , drop = FALSE]
mem$selected <- isolate(mem$selected[-input$selected_rows_selected, , drop = F])
})
observeEvent(input$add_all, {
mem$selected <- pool_init
mem$pool <- data.frame(data = "")
})
observeEvent(input$remove_all, {
mem$selected <- select_init
mem$pool <- pool_init
})
output$pool <- renderDT({
mem$pool
})
output$selected <- renderDT({
mem$selected
})
}
shinyApp(ui, server)
Concerning the requirements for multiple tables, please see my comment.
To generalise to an arbitrary number of tables, I'd use a module. The module would contain the GUI and logic for a single DT. It would have arguments for the "input DT" (the table from which rows are received) and the "output DT" (the table to which rows are sent). Either or both could be NULL. The GUI would display the DT and have a widgets to initiate the various "send rows" commands. See here for more details on modules.
As for your inability to remove rows from the source table: I'm not overly familiar with DT, but I believe you need to use a proxy: as this page says "After a table has been rendered in a Shiny app, you can use the proxy object returned from dataTableProxy() to manipulate it. Currently supported methods are selectRows(), selectColumns(), selectCells(), selectPage(), and addRow().".
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)
The goal
I am working on a Shiny app that allows the user to upload their own data and focus on the entire data or a subset by providing data filtering widgets described by the below graph
The select input "Variable 1" will display all the column names of the data uploaded by the user and the selectize input "Value" will display all the unique values of the corresponding column selected in "Variable 1". Ideally, the user will be able to add as many such rows ("Variable X" + "Value") as possible by some sort of trigger, one possibility being clicking the "Add more" action button.
A possible solution
After looking up online, I've found one promising solution given by Nick Carchedi pasted below
ui.R
library(shiny)
shinyUI(pageWithSidebar(
# Application title
headerPanel("Dynamically append arbitrary number of inputs"),
# Sidebar with a slider input for number of bins
sidebarPanel(
uiOutput("allInputs"),
actionButton("appendInput", "Append Input")
),
# Show a plot of the generated distribution
mainPanel(
p("The crux of the problem is to dynamically add an arbitrary number of inputs
without resetting the values of existing inputs each time a new input is added.
For example, add a new input, set the new input's value to Option 2, then add
another input. Note that the value of the first input resets to Option 1."),
p("I suppose one hack would be to store the values of all existing inputs prior
to adding a new input. Then,", code("updateSelectInput()"), "could be used to
return inputs to their previously set values, but I'm wondering if there is a
more efficient method of doing this.")
)
))
server.R
library(shiny)
shinyServer(function(input, output) {
# Initialize list of inputs
inputTagList <- tagList()
output$allInputs <- renderUI({
# Get value of button, which represents number of times pressed
# (i.e. number of inputs added)
i <- input$appendInput
# Return if button not pressed yet
if(is.null(i) || i < 1) return()
# Define unique input id and label
newInputId <- paste0("input", i)
newInputLabel <- paste("Input", i)
# Define new input
newInput <- selectInput(newInputId, newInputLabel,
c("Option 1", "Option 2", "Option 3"))
# Append new input to list of existing inputs
inputTagList <<- tagAppendChild(inputTagList, newInput)
# Return updated list of inputs
inputTagList
})
})
The downside
As pointed by Nick Carchedi himself, all the existing input widgets will undesirably get reset every time when a new one is added.
A promising solution for data subsetting/filtering in Shiny
As suggested by warmoverflow, the datatable function in DT package provides a nice way to filter the data in Shiny. See below a minimal example with data filtering enabled.
library(shiny)
shinyApp(
ui = fluidPage(DT::dataTableOutput('tbl')),
server = function(input, output) {
output$tbl = DT::renderDataTable(
iris, filter = 'top', options = list(autoWidth = TRUE)
)
}
)
If you are going to use it in your Shiny app, there are some important aspects that are worth noting.
Filtering box type
For numeric/date/time columns: range sliders are used to filter rows within ranges
For factor columns: selectize inputs are used to display all possible categories
For character columns: ordinary search boxes are used
How to obtain the filtered data
Suppose the table output id is tableId, use input$tableId_rows_all as the indices of rows on all pages (after the table is filtered by the search strings). Please note that input$tableId_rows_all returns the indices of rows on all pages for DT (>= 0.1.26). If you use the DT version by regular install.packages('DT'), only the indices of the current page are returned
To install DT (>= 0.1.26), refer to its GitHub page
Column width
If the data have many columns, column width and filter box width will be narrow, which makes it hard to see the text as report here
Still to be solved
Despite some known issues, datatable in DT package stands as a promising solution for data subsetting in Shiny. The question itself, i.e. how to dynamically append arbitrary number of input widgets in Shiny, nevertheless, is interesting and also challenging. Until people find a good way to solve it, I will leave this question open :)
Thank you!
are you looking for something like this?
library(shiny)
LHSchoices <- c("X1", "X2", "X3", "X4")
#------------------------------------------------------------------------------#
# MODULE UI ----
variablesUI <- function(id, number) {
ns <- NS(id)
tagList(
fluidRow(
column(6,
selectInput(ns("variable"),
paste0("Select Variable ", number),
choices = c("Choose" = "", LHSchoices)
)
),
column(6,
numericInput(ns("value.variable"),
label = paste0("Value ", number),
value = 0, min = 0
)
)
)
)
}
#------------------------------------------------------------------------------#
# MODULE SERVER ----
variables <- function(input, output, session, variable.number){
reactive({
req(input$variable, input$value.variable)
# Create Pair: variable and its value
df <- data.frame(
"variable.number" = variable.number,
"variable" = input$variable,
"value" = input$value.variable,
stringsAsFactors = FALSE
)
return(df)
})
}
#------------------------------------------------------------------------------#
# Shiny UI ----
ui <- fixedPage(
verbatimTextOutput("test1"),
tableOutput("test2"),
variablesUI("var1", 1),
h5(""),
actionButton("insertBtn", "Add another line")
)
# Shiny Server ----
server <- function(input, output) {
add.variable <- reactiveValues()
add.variable$df <- data.frame("variable.number" = numeric(0),
"variable" = character(0),
"value" = numeric(0),
stringsAsFactors = FALSE)
var1 <- callModule(variables, paste0("var", 1), 1)
observe(add.variable$df[1, ] <- var1())
observeEvent(input$insertBtn, {
btn <- sum(input$insertBtn, 1)
insertUI(
selector = "h5",
where = "beforeEnd",
ui = tagList(
variablesUI(paste0("var", btn), btn)
)
)
newline <- callModule(variables, paste0("var", btn), btn)
observeEvent(newline(), {
add.variable$df[btn, ] <- newline()
})
})
output$test1 <- renderPrint({
print(add.variable$df)
})
output$test2 <- renderTable({
add.variable$df
})
}
#------------------------------------------------------------------------------#
shinyApp(ui, server)
Now, I think that I understand better the problem.
Suppose the user selects the datasets::airquality dataset (here, I'm showing only the first 10 rows):
The field 'Select Variable 1' shows all the possible variables based on the column names of said dataset:
Then, the user selects the condition and the value to filter the dataset by:
Then, we want to add a second filter (still maintaining the first one):
Finally, we get the dataset filtered by the two conditions:
If we want to add a third filter:
You can keep adding filters until you run out of data.
You can also change the conditions to accommodate factors or character variables. All you need to do is change the selectInput and numericInput to whatever you want.
If this is what you want, I've solved it using modules and by creating a reactiveValue (tmpFilters) that contains all selections (variable + condition + value). From it, I created a list with all filters (tmpList) and from it I created the proper filter (tmpListFilters) to use with subset.
This works because the final dataset is "constantly" being subset by this reactiveValue (the tmpFilters). At the beginning, tmpFilters is empty, so we get the original dataset. Whenever the user adds the first filter (and other filters after that), this reactiveValue gets updated and so does the dataset.
Here's the code for it:
library(shiny)
# > MODULE #####################################################################
## |__ MODULE UI ===============================================================
variablesUI <- function(id, number, LHSchoices) {
ns <- NS(id)
tagList(
fluidRow(
column(
width = 4,
selectInput(
inputId = ns("variable"),
label = paste0("Select Variable ", number),
choices = c("Choose" = "", LHSchoices)
)
),
column(
width = 4,
selectInput(
inputId = ns("condition"),
label = paste0("Select condition ", number),
choices = c("Choose" = "", c("==", "!=", ">", ">=", "<", "<="))
)
),
column(
width = 4,
numericInput(
inputId = ns("value.variable"),
label = paste0("Value ", number),
value = NA,
min = 0
)
)
)
)
}
## |__ MODULE SERVER ===========================================================
filter <- function(input, output, session){
reactive({
req(input$variable, input$condition, input$value.variable)
fullFilter <- paste0(
input$variable,
input$condition,
input$value.variable
)
return(fullFilter)
})
}
# Shiny ########################################################################
## |__ UI ======================================================================
ui <- fixedPage(
fixedRow(
column(
width = 5,
selectInput(
inputId = "userDataset",
label = paste0("Select dataset"),
choices = c("Choose" = "", ls("package:datasets"))
),
h5(""),
actionButton("insertBtn", "Add another filter")
),
column(
width = 7,
tableOutput("finalTable")
)
)
)
## |__ Server ==================================================================
server <- function(input, output) {
### \__ Get dataset from user selection ------------------------------------
originalDF <- reactive({
req(input$userDataset)
tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
if (!class(tmpData) == "data.frame") {
stop("Please select a dataset of class data.frame")
}
tmpData
})
### \__ Get the column names -----------------------------------------------
columnNames <- reactive({
req(input$userDataset)
tmpData <- eval(parse(text = paste0("datasets::", input$userDataset)))
names(tmpData)
})
### \__ Create Reactive Filter ---------------------------------------------
tmpFilters <- reactiveValues()
### \__ First UI Element ---------------------------------------------------
### Add first UI element with column names
observeEvent(input$userDataset, {
insertUI(
selector = "h5",
where = "beforeEnd",
ui = tagList(variablesUI(paste0("var", 1), 1, columnNames()))
)
})
### Update Reactive Filter with first filter
filter01 <- callModule(filter, paste0("var", 1))
observe(tmpFilters[['1']] <- filter01())
### \__ Other UI Elements --------------------------------------------------
### Add other UI elements with column names and update the filter
observeEvent(input$insertBtn, {
btn <- sum(input$insertBtn, 1)
insertUI(
selector = "h5",
where = "beforeEnd",
ui = tagList(variablesUI(paste0("var", btn), btn, columnNames()))
)
newFilter <- callModule(filter, paste0("var", btn))
observeEvent(newFilter(), {
tmpFilters[[paste0("'", btn, "'")]] <- newFilter()
})
})
### \__ Dataset with Filtered Results --------------------------------------
resultsFiltered <- reactive({
req(filter01())
tmpDF <- originalDF()
tmpList <- reactiveValuesToList(tmpFilters)
if (length(tmpList) > 1) {
tmpListFilters <- paste(tmpList, "", collapse = "& ")
} else {
tmpListFilters <- unlist(tmpList)
}
tmpResult <- subset(tmpDF, eval(parse(text = tmpListFilters)))
tmpResult
})
### \__ Print the Dataset with Filtered Results ----------------------------
output$finalTable <- renderTable({
req(input$userDataset)
if (is.null(tmpFilters[['1']])) {
head(originalDF(), 10)
} else {
head(resultsFiltered(), 10)
}
})
}
#------------------------------------------------------------------------------#
shinyApp(ui, server)
# End
If you are looking for a data subsetting/filtering in Shiny Module :
filterData from package shinytools can do the work. It returns an expression as a call but it can also return the data (if your dataset is not too big).
library(shiny)
# remotes::install_github("ardata-fr/shinytools")
library(shinytools)
ui <- fluidPage(
fluidRow(
column(
3,
filterDataUI(id = "ex"),
actionButton("AB", label = "Apply filters")
),
column(
3,
tags$strong("Expression"),
verbatimTextOutput("expression"),
tags$br(),
DT::dataTableOutput("DT")
)
)
)
server <- function(input, output) {
x <- reactive({iris})
res <- callModule(module = filterDataServer, id = "ex", x = x, return_data = FALSE)
output$expression <- renderPrint({
print(res$expr)
})
output$DT <- DT::renderDataTable({
datatable(data_filtered())
})
data_filtered <- eventReactive(input$AB, {
filters <- eval(expr = res$expr, envir = x())
x()[filters,]
})
}
shinyApp(ui, server)
You can also use lazyeval or rlang to evaluate the expression :
filters <- lazyeval::lazy_eval(res$expr, data = x())
filters <- rlang::eval_tidy(res$expr, data = x())
You need to check for existing input values and use them if available:
# Prevent dynamic inputs from resetting
newInputValue <- "Option 1"
if (newInputId %in% names(input)) {
newInputValue <- input[[newInputId]]
}
# Define new input
newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)
A working version of the gist (without the reset problem) can be found here: https://gist.github.com/motin/0d0ed0d98fb423dbcb95c2760cda3a30
Copied below:
ui.R
library(shiny)
shinyUI(pageWithSidebar(
# Application title
headerPanel("Dynamically append arbitrary number of inputs"),
# Sidebar with a slider input for number of bins
sidebarPanel(
uiOutput("allInputs"),
actionButton("appendInput", "Append Input")
),
# Show a plot of the generated distribution
mainPanel(
p("This shows how to add an arbitrary number of inputs
without resetting the values of existing inputs each time a new input is added.
For example, add a new input, set the new input's value to Option 2, then add
another input. Note that the value of the first input does not reset to Option 1.")
)
))
server.R
library(shiny)
shinyServer(function(input, output) {
output$allInputs <- renderUI({
# Get value of button, which represents number of times pressed (i.e. number of inputs added)
inputsToShow <- input$appendInput
# Return if button not pressed yet
if(is.null(inputsToShow) || inputsToShow < 1) return()
# Initialize list of inputs
inputTagList <- tagList()
# Populate the list of inputs
lapply(1:inputsToShow,function(i){
# Define unique input id and label
newInputId <- paste0("input", i)
newInputLabel <- paste("Input", i)
# Prevent dynamic inputs from resetting
newInputValue <- "Option 1"
if (newInputId %in% names(input)) {
newInputValue <- input[[newInputId]]
}
# Define new input
newInput <- selectInput(newInputId, newInputLabel, c("Option 1", "Option 2", "Option 3"), selected=newInputValue)
# Append new input to list of existing inputs
inputTagList <<- tagAppendChild(inputTagList, newInput)
})
# Return updated list of inputs
inputTagList
})
})
(The solution was guided on Nick's hints in the original gist from where you got the code of the promising solution)
I am trying to make a basic program in R shiny framework so that I can display an interactive data table. The basic function I need to perform but can't is getting the row and column index of any selected/clicked cell. I have done research online and followed the tutorials exactly, but what is shown in the tutorials does not appear to be working. Since I think getting clicks is harder, I have settled with getting the row and column index of whatever cell is selected. Here is what I currently have for the ui.R and server.R files:
library(shiny)
library(shinyTable)
library(DT)
server <- function(input, output, session) {
lastTransToMat = data.table(cbind(c(.5,.5),c(.8,.2)))
output$transtable = DT::renderDataTable(lastTransToMat,options = list(target = 'column+row'))
output$response <-DT::renderDataTable({
rows= as.numeric(input$transtable_rows_selected)
cols = as.numeric(input$transtable_columns_selected)
print(rows)
print(cols)
response = data.table(cbind(c(paste0("rows: ",rows),c(paste0("cols: " ,cols)))))
print(response)
return(response)
})
}
shinyUI(fluidPage(
titlePanel("transition table"),
mainPanel(
DT::dataTableOutput('transtable'),
DT::dataTableOutput('response')
)
))
When I runApp() on this, I am only able to get the index of the row, but not the index of the column. See output below:
numeric(0)
V1
1: rows: 1
2: cols:
There is a similar data.table output in the shiny app itself.
Does anyone know why this is happening?
How can I get both the row and column index of a selection? And what about clicks?
Best,
Paul
EDIT:
As per user5029763's suggestion, I replaced my server.R function with the following:
#ui.R
library(shiny)
library(shinyTable)
library(DT)
shinyUI(fluidPage(
titlePanel("transition table"),
mainPanel(
DT::dataTableOutput('transtable'),
DT::dataTableOutput('response'),
htmlOutput('response2')
)
))
#server.R
server <- function(input, output, session) {
lastTransToMat = data.table(cbind(c(.5,.5),c(.8,.2)))
output$transtable = DT::renderDataTable(lastTransToMat,server = F,options = list(target = 'cell'))
output$response <-DT::renderDataTable({
cell= as.numeric(input$transtable_cell_clicked)
print(cell)
response = data.table(cbind(c(paste0("cell: "),c(paste0(cell)))))
print(response)
return(response)
})
output$response2 <- renderUI({
cells <- input$transtable_cell_clicked
if(length(cells) == 0) return( div('No cell is selected') )
cells <- data.frame(cells)[-3]
response <- paste0(c('Row', 'Column'), ': ', cells, collapse = ' / ')
div(response)
})
}
Output before any click:
Output after click/selection:
Is this the same as the output you get when you runApp() on this?
EDIT: Also just FYI, I tried this on another computer with the most updated version of R and got the same output, so I don't think it has to do with my version/computer.
If what you want is to get the index of clicked cells you could go with:
output$transtable = DT::renderDataTable(
lastTransToMat,
server = F,
selection = list(target = 'cell')
)
Then, input$transtable_cell_clicked will be a list with row/column index and the value within the cell. Just remember that the column index starts at 0.
EDIT: one way to print out
#server.R
output$response2 <- renderUI({
cells <- input$transtable_cell_clicked
if(length(cells) == 0) return( div('No cell is selected') )
cells <- data.frame(cells)[-3]
response <- paste0(c('Row', 'Column'), ': ', cells, collapse = ' / ')
div(response)
})
#ui.R
htmlOutput('response2')