To edit a one-to-many like data structure,
I would like to create a data table (DTOutput), on which I observe cell clicks observeEvent(input$groupingsOut_cell_clicked, {...}).
Then at every cell click, I would like to generate input fields on the UI.
Finally, I would like to listen to changed on those rendered/generated UI.
I can't edit these cells directly in the DTOutput, as it doesn't support vectors within cells. (Hence, one-to-many relationship).
I have managed steps 1 and 2. I can render a DTOutput with corresponding cells. I can observe cell clicks and insert UI (insertUI()) upon cell clicks. I created observeEvent objects to observe those rendered fields. However, those observeEvents are never fired upon editing newly generated fields.
ui = fluidPage(title = titlePanel("Title"),
tags$head(tags$style(HTML("hr {border-top: 1px solid #000000;}"))),
sidebarLayout(
sidebarPanel(),
mainPanel(tabsetPanel(type = "tabs",
tabPanel("Groupings", DTOutput(outputId = "groupingsOut"),
tags$div(id = 'placeholder')),
tabPanel("Test", textOutput(outputId = "statusOut")),
tabPanel("Plot Generator", plotOutput(outputId = "distPlotOut")))
)
)
)
server = function(input, output) {
# Label reactive values
labelRVs = list()
#Example table
groupings = data.frame(names = c("cars", "mbikes", "bikes"),
labels = c("Cars", "Motor Bikes", "Bikes"),
groups = I(list(c("toyota", "vw", "tesla"), c("harley", "kawasaki"), c("somth", "anoth", "bla"))),
groupLabels = I(list(c("Toyota", "VW", "Tesla"), c("Harley Davidson", "Kawasaki"), c("Something", "Another Thing", "Bla bla"))))
#groupings = data.frame()
proxy = dataTableProxy('groupingsOut')
observeEvent(input$groupingsOut_cell_clicked, {
info = input$groupingsOut_cell_clicked
if(!is.null(info$row)){
grouping = groupings[[info$row, 1]]
groupingLabel = groupings[[info$row, 2]]
groups = groupings[[info$row, 3]]
groupLabels = groupings[[info$row, 4]]
# remove previously generated UI
removeUI(selector = paste0('#placeholder input'), multiple = TRUE)
removeUI(selector = paste0('#placeholder label'), multiple = TRUE)
# Generating ID for grouping labels
id = paste0("groupLabel_", i)
# Inserting text input for grouping label
insertUI(selector = '#placeholder', ui = textInput(id, label = "Grouping label:", value = groupingLabel))
labelRVs[[id]] <<- observeEvent(id, {
cat(paste(id, i, "\n")) # THIS LINE ONLY RUNS AT INITIALIZATION :(
})
lapply(1:length(groups), function(i){
index = sprintf("%03d", i)
id = paste0('label_', index)
insertUI(selector = '#placeholder',
ui = textInput(id, label = paste0("Group label for ", groups[i], ":"), value = groupLabels[i]))
labelRVs[[id]] <<- observeEvent(id, {
cat(paste(id, i, "\n")) # ALSO THIS LINE ONLY RUNS AT INITIALIZATION :(
})
})
}
})
output$groupingsOut = renderDT(groupings[, c(1, 3)], rownames = FALSE, editable = TRUE, selection = 'single')
}
shinyApp(ui = ui, server = server)
However, this example Shiny - Can dynamically generated buttons act as trigger for an event runs perfectly fine. In the example instead of insertUI into tags, renderUI to outputUI is used. I adapted my code above to use renderUI, which also failed. At this point, I am suspecting if DTOutput doesn't behave the same way as other input fields.
Beaware of the usage of <<- operator to assign labelRVs to keep observeEvent objects alive. This is indeed necessary, which is shown in the example.
I wonder, if there is any way to observe such fields?
Related
I understand similar questions have been asked and I've tried virtually every solution with no luck.
In my application, I've allowed the user to modify individual cells of a DT::datatable. The source of the datatable is a reactive data frame.
After the user makes changes to the clientside datatable, the datatable source is remains unchanged. This is an issue as later on, when I allow the user to add rows to the data table, the row is added onto the source datatable where the clientside datatable then reflects this change. However, this means that if the user makes a change to a cell in the clientside datatable, when the user adds a row to the same table, the change made by the user will be forgotten as it was never made to the source.
I've tried many ways to update the underlying/serverside datatable with no luck. editData keeps giving me errors/NA. I also have tried indexing the serverside table and placing the changed value inside of it, with no luck. I'll post my code below with some comments for specifics..
library(shiny)
library(DT)
library(data.table)
source('~/camo/camo/R/settings.R')
source('~/camo/camo/etl.R')
# Define UI ----
ui <- fluidPage(
titlePanel("PAlpha"),
mainPanel(
fluidRow(
tabsetPanel(id = 'tpanel',
type = "tabs",
tabPanel("Alpha", plotOutput("plot1")),
tabPanel("Beta", plotOutput("plot2")),
tabPanel("Charlie", plotOutput("plot3")),
tabPanel("Delta", plotOutput("plot4")))
),
fluidRow(
splitLayout(
dateInput("sdate", "Start Date"),
dateInput("edate", "End Date"),
textInput("gmin", "Global Minimum"),
textInput("gmax", "Global Maximum")
)
),
fluidRow(
splitLayout(
textInput("groupInp", NULL, placeholder = "New Group"),
actionButton("addGrpBtn", "Add Group"),
textInput("tickerInp", NULL, placeholder = "New Ticker"),
actionButton("addTickerBtn", "Add Ticker")
)
),
fluidRow(
splitLayout(
DT::dataTableOutput('groupsTable'),
DT::dataTableOutput('groupTickers')
),
verbatimTextOutput("print")
)
)
)
# Define server logic ----
server <- function(input, output) {
port_proxy <- dataTableProxy('groupsTable')
rv <- reactiveValues(
portfolio = data.frame('Group' = c('Portfolio'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-')),
groups = list(group1 = data.frame('Group' = c('Ticker'), 'Minimum Weight' = c(0), 'Maximum Weight' = c(0), 'Type' = c('-'))),
deletedRows = NULL,
deletedRowIndices = list()
)
output$groupsTable <- DT::renderDataTable(
# Add the delete button column
deleteButtonColumn(rv$portfolio, 'delete_button')
)
output$print <- renderPrint({
rv$portfolio
})
############## LISTENERS ################
observeEvent(input$deletePressed, {
rowNum <- parseDeleteEvent(input$deletePressed)
dataRow <- rv$portfolio[rowNum,]
# Put the deleted row into a data frame so we can undo
# Last item deleted is in position 1
rv$deletedRows <- rbind(dataRow, rv$deletedRows)
rv$deletedRowIndices <- append(rv$deletedRowIndices, rowNum, after = 0)
# Delete the row from the data frame
rv$portfolio <- rv$portfolio[-rowNum,]
})
observeEvent(input$addGrpBtn, {
row <- data.frame('Group' = c(input$groupInp),
'Minimum Weight' = c(0),
'Maximum Weight' = c(0),
'Type' = c('-'))
rv$portfolio <- addRowAt(rv$portfolio, row, nrow(rv$portfolio))
})
observeEvent(input$groupsTable_cell_edit,{
info <- str(input$groupsTable_cell_edit)
i <- info$row
j <- info$col
v <- info$value
rv$portfolio <- editData(rv$portfolio, input$groupsTable_cell_edit) # doesn't work see below
# Warning in DT::coerceValue(v, data[i, j, drop = TRUE]) :
# New value(s) "test" not in the original factor levels: "Portfolio"; will be coerced to NA.
# rv$portfolio[i,j] <- input$groupsTable_cell_edit$value
# rv$portfolio[i,j] <- v #doesn't work
})
}
addRowAt <- function(df, row, i) {
# Slow but easy to understand
if (i > 1) {
rbind(df[1:(i - 1), ], row, df[-(1:(i - 1)), ])
} else {
rbind(row, df)
}
}
deleteButtonColumn <- function(df, id, ...) {
# function to create one action button as string
f <- function(i) {
# https://shiny.rstudio.com/articles/communicating-with-js.html
as.character(actionLink(paste(id, i, sep="_"), label = 'Delete', icon = icon('trash'),
onclick = 'Shiny.setInputValue(\"deletePressed\", this.id, {priority: "event"})'))
}
deleteCol <- unlist(lapply(seq_len(nrow(df)), f))
# Return a data table
DT::datatable(cbind(' ' = deleteCol, df),
# Need to disable escaping for html as string to work
escape = FALSE,
editable = 'cell',
selection = 'single',
rownames = FALSE,
class = 'compact',
options = list(
# Disable sorting for the delete column
dom = 't',
columnDefs = list(list(targets = 1, sortable = FALSE))
))
}
parseDeleteEvent <- function(idstr) {
res <- as.integer(sub(".*_([0-9]+)", "\\1", idstr))
if (! is.na(res)) res
}
# Run the app ----
shinyApp(ui = ui, server = server)
As far as I have looked, there is no ready-to-go solution available. You could try to use rhandsontable. It does not provide all the functionality of the DT table, however it allows for the editing. Last time I tried using it there were some minor issues in some edge cases. (Trying to save different data type or something similar.)
Alternatively you can do the stuff manually, along these lines. This is the minimal working example of editing the underlying data frame. Currently I overwrite it every time the user clicks on the table, you would need to change that to handle normal user behavior. It is meant merely as a proof of concept.
library(DT)
library(shiny)
ui <- fluidPage(
DT::dataTableOutput("test")
)
myDF <- iris[1:10,]
js <- c("table.on('click.dt','tr', function() {",
" var a = table.data();",
" var data = []",
" for (i=0; i!=a.length; i++) {",
" data = data.concat(a[i]) ",
" };",
"Shiny.setInputValue('dataChange', data)",
"})")
server <- function(input, output) {
output$test <- DT::renderDataTable(
myDF,
editable='cell',
callback=JS(js)
)
observeEvent(input$dataChange, {
res <- cbind.data.frame(split(input$dataChange, rep(1:6, times=length(input$dataChange)/6)),
stringsAsFactors=F)
colNumbers <- res[,1]
res <- res[,2:ncol(res)]
colnames(res) <- colnames(myDF)
myDF <<- res
print(myDF)
})
}
shinyApp(ui = ui, server = server)
In a nutshell, I believe I need to nest uiOutputs together and cannot figure a great way to do so.
The app is large but for this part, I would like to create a survey that renders sub-surveys (new panels) based on a slider input (I've accomplished that much). These panels will all be standard and so they can be created with a loop.
However, answers within these panels should generate more UI within the panel from which they were generated and therein lies the problem... the nesting of uiOutputs. I've tried to provide the shortest example possible below, with comments - and note that the second uiOutput call works if I specify a panel for which it should work ("oh_lawd_1" in this case).
Please let me know what you think! Have been looking at this in my spare time for at least 4 days. (also I realize that this is not an ideal use of shiny).
library(shiny)
library(shinyWidgets)
ui <- fluidPage( #UI
column(6, offset = 3,
sliderInput(inputId = "my_slider", # slider to choose number of panels
label = "Choose Panels to be Displayed",
min = 0, max = 5, value = 1),
uiOutput(outputId = "update_panels") # ui output to create panels
)
)
server <- function(input, output, session) { #Server
output$update_panels <- renderUI({ # rendering all the panels called for by user
panels <- input$my_slider
if(panels == 0){
return("No panels being displayed")# returning 0 if none selected
} else {
our_ui <- list() # creating a list to store a standard panel
for(i in 1:panels){
button_id <- paste("button_id", i, sep = "_") # a unique id for each panel's radiobuttons
oh_lawd <- paste("oh_lawd", i, sep = "_") # a unique id for each panel's uiOutput
update <- wellPanel(paste("Well Panel #", i), # "update" is what each panel should START OFF looking like
radioButtons(inputId = button_id,
label = "Choose a pill",
choices = c("Red Pill", "Blue Pill")),
uiOutput(oh_lawd)) # this part is the issue - I would like to update individual panels with a
# radio button selection specific to a choice in each panel... a nested uiOutput
our_ui <- list(our_ui, update)
}}
our_ui})
output$oh_lawd_1 <- renderUI({ # this works for the first... but I need to somehow create one of these for each based on
# number of panels and the choice in each panel
if(input$button_id_1 == "Red Pill"){
radioButtons("first_output", "Next Choices", choices = c("I'm a brave boi", "Knowledge schmoledge"))
} else {
radioButtons("first_output", "Next Choices", choices = c("Gimme dat ignorance", "Mhmm yea") )
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
Is it what you want? I'm not sure.
library(shiny)
library(shinyWidgets)
ui <- fluidPage( #UI
column(6, offset = 3,
sliderInput(inputId = "my_slider", # slider to choose number of panels
label = "Choose Panels to be Displayed",
min = 0, max = 5, value = 1),
uiOutput(outputId = "update_panels") # ui output to create panels
)
)
server <- function(input, output, session) { #Server
output$update_panels <- renderUI({ # rendering all the panels called for by user
panels <- input$my_slider
if(panels == 0){
return("No panels being displayed")# returning 0 if none selected
} else {
our_ui <- list() # creating a list to store a standard panel
for(i in 1:panels){
button_id <- paste("button_id", i, sep = "_") # a unique id for each panel's radiobuttons
oh_lawd <- paste("oh_lawd", i, sep = "_") # a unique id for each panel's uiOutput
update <- wellPanel(paste("Well Panel #", i), # "update" is what each panel should START OFF looking like
radioButtons(inputId = button_id,
label = "Choose a pill",
choices = c("Red Pill", "Blue Pill")),
uiOutput(oh_lawd)) # this part is the issue - I would like to update individual panels with a
# radio button selection specific to a choice in each panel... a nested uiOutput
our_ui <- list(our_ui, update)
}}
our_ui})
observeEvent(input$my_slider, {
lapply(seq_len(input$my_slider), function(i){
uiID <- paste0("oh_lawd_", i)
buttonID <- paste0("button_id_", i)
radioID <- paste0("radio_id_", i)
output[[uiID]] <- renderUI({
if(input[[buttonID]] == "Red Pill"){
choices <- c("I'm a brave boi", "Knowledge schmoledge")
}else{
choices <- c("Gimme dat ignorance", "Mhmm yea")
}
radioButtons(radioID, "Next Choices", choices = choices)
})
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am creating an R Shiny application primarily using checkboxGroupInput where for each checkbox name I check, the corresponding table should display in the main UI panel. I have linked each checkbox option to its corresponding table (already in my previous script) in the "choices" argument of checkboxGroupInput. I use eventReactive to make a working button and renderTable to produce the appropriate tables. However, what displays in the main panel when I click the button is a list of each cell in the table rather than the table itself. This list of values looks a bit like this:
list(CUI = "C05372341", LAT = "ENG", TS = "P", LUI = "L0883457", STT = "PF", SUI = "S13423408", ISPREF = "N", AUI = "A10344304", SAUI = "21823712", SCUI = "1341953", SDUI = NA, SAB = "LKDHDS", TTY = "IN", CODE = "139433", STR = "Pramlintide", SRL = "0", SUPPRESS = "Y", CVF = "4354")
I would like this to have been printed in table form.
When I simply use renderTable({table_name}) on any given one of the tables, the table prints in the main panel how I would like it to. However, when I use eventReactive, name that variable, and renderTable on that variable, that is when the list of table values prints instead. Any ideas?
library(shiny)
ui <- fluidPage(
titlePanel("RxNorm Diabetic Drug Mapping based on Epocrates Classes"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("drugs", "Drug Class", choices = list("ALPHA GLUCOSIDASE INHIBITORS" = agi, "AMYLIN MIMETICS" = pramlintide, "BIGUANIDES" = biguanides, "DOPAMINE AGONISTS" = bromocriptine, "DPP4 INHIBITORS" = dpp4, "GLP1 AGONISTS" = glp1, "INSULINS" = insulins, "MEGLITINIDES" = meglitinides, "SGLT2 INHIBITORS" = sglt2, "SULFONYLUREAS" = sulfonylureas, "THIAZOLIDINEDIONES" = thiazolidinediones)),
actionButton("button", "Retrieve Data")
),
mainPanel(
tableOutput("results")
)
)
)
server <- function(input, output) {
table_reactive <- eventReactive(input$button, {
input$drugs
})
output$results <- renderTable({
table_reactive()
})
}
shinyApp(ui = ui, server = server)
In your choices:
choices = list("ALPHA GLUCOSIDASE INHIBITORS" = agi, "AMYLIN MIMETICS" = pramlintide ...), it's not valid if agi and pramlintide ... are pointing to tables. choices values can only be string.
You shouldn't pass variable as values in checkboxGroupInput. Instead you should pass the table name as string.
To answer your questions:
Please see the demos below:
If your tables are saved as separate variables, you should use sym() and eval_tidy() in rlang package to convert string to varaible.
library(shiny)
library(rlang)
ui <- fluidPage(
fluidRow(
checkboxGroupInput(
inputId = "checkgroup",
label = "Select Table",
choices = list(iris = "iris", mtcars = "mtcars")
),
actionButton(
inputId = "confirm",
label = "Confirm Table(s)"
)
),
fluidRow(
tags$div(id = "tables")
)
)
server <- function(input, output, session) {
observeEvent(input$confirm,{
removeUI(selector = "#tables > *",multiple = TRUE)
req(length(input$checkgroup) > 0)
for(table_name in input$checkgroup){
table_id <- paste0("mytable",table_name)
insertUI(
selector = "#tables",
ui = dataTableOutput(table_id)
)
output[[table_id]] <- renderDataTable(eval_tidy(sym(table_name)))
}
})
}
shinyApp(ui, server)
I've been trying to generate a Shiny page where elements can be added or removed by the user - based on this snippet. I tried to adapt it for UI elements rather than buttons, but I've clearly done something wrong.
I've only included the add-button part here - each time the "add" button is clicked, the correct number of UI elements are added, but they seem to all be the same element rather just appending a new one to the existing list (the number in the label is the same, whereas it should be different for each one) and the initial text values are erased (or, potentially, are just the "default" from the final element repeated however many times).
How can I just add a new UI element and keep any text input that the user has entered in the already-existing elements?
Code:
library(shiny)
# function to render UI element
renderUiElement <- function(id, nameDef) {
renderUI(box(
actionButton(paste0("rmBtn", id), label = "", icon = icon("times")),
# text initial value supplied as a variable
textInput(paste0("nameText", id), label = paste("Item", id), value = nameDef)
))
}
server <- function(input, output, session) {
rv <- reactiveValues(uiComponents = list(), uiIds = list(),
nameVals = list(), lastId = 0)
# on "Add" button click:
observe({
if(is.null(input$addBtn) || input$addBtn == 0) return()
isolate({
# store current text inputs and append new default text
rv$nameVals <- lapply(rv$uiIds, function(x) input[[paste0("nameText", x)]])
rv$nameVals <- append(rv$nameVals, "New Text")
# create (and store) new id number and add it to the list of ids in use
rv$lastId <- rv$lastId + 1 # get the new code to use for these UI elements
rv$uiIds <- append(rv$uiIds, rv$lastId)
# for each id, render the UI element using the appropriate default text
for(i in seq_along(rv$uiIds)) {
thisId <- rv$uiIds[[i]]
output[[paste0("uiEl", thisId)]] <- renderUiElement(
id = thisId, nameDef = rv$nameVals[[i]]
)
}
# add the new UI element into the reactiveValues list
rv$uiComponents <- append(
rv$uiComponents,
list(
list(
uiOutput(paste0("uiEl", rv$lastId)),
br(),br()
)
)
)
})
})
# render all the UI elements inside the container
output$container <- renderUI({
rv$uiComponents
})
}
ui <- fluidPage(
titlePanel("Dynamically Add/Remove UI Elements"),
hr(),
actionButton("addBtn", "Add"),
br(),br(),
uiOutput("container")
)
shinyApp(ui, server)
Hi to dynamicly add objects shiny has the function insertUI.
Your code would look like something similar to this
library(shiny)
library(shinydashboard)
# function to render UI element
renderUiElement <- function(id, nameDef) {
box(
actionButton(paste0("rmBtn", id), label = "", icon = icon("times")),
# text initial value supplied as a variable
textInput(paste0("nameText", id), label = paste("Item", id), value = nameDef)
)
}
server <- function(input, output, session) {
# on "Add" button click:
counter <- 0
observeEvent(
input$addBtn,
{
counter <<- counter +1
insertUI(
selector = '#container',
where = "beforeEnd",
ui = renderUiElement(
id = paste0("ui",counter),
nameDef = "New Text"
),
session = session
)
},
ignoreNULL = TRUE,
ignoreInit = TRUE
)
output$container <- renderUI({
div()
})
}
ui <- fluidPage(
titlePanel("Dynamically Add/Remove UI Elements"),
hr(),
actionButton("addBtn", "Add"),
br(),br(),
uiOutput("container")
)
shinyApp(ui, server)
Hope it helps.
I have the following code to dynamically make either Check Boxes or Sliders.
server <- shinyServer(function(input, output, session) {
# define the data frame to use
dat <- mtcars
dat <- rownames_to_column(dat, "car")
# name of availale data frame
varNames <- names(dat)
# define defaul values as the first value in each column
defaultValues <- as.numeric(dat[1,])
# store the selected variable in a reactive variable
# dynamically creates a set of sliders
output$controls <- renderUI({
div(
fluidRow(
column(9, uiOutput("rangeUI"))
)
)
})
output$rangeUI <- renderUI({
lapply(1:length(varNames), function(k) {
fluidRow(
column(12,
if (is_character(dat[1, k])) {
# a slider range will created only is the variable is selected
checkboxGroupInput(paste0("slider_", varNames[k]), label = varNames[k], choices = unique(dat[[k]]), selected = NULL,
inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL)
} else {
# otherwise uses single value with a default value
sliderInput(paste0("slider_", varNames[k]), label = varNames[k],
min = 0, max = 100, value = defaultValues[k])
}
)
)
})
})
The issue I am running into is that I would like to display the sliders and check boxes side by side until they hit the screen width and then start a new row. Currently, they are all in one column.
Is there a good way to dynamically adjust offset to accomplish this, maybe something like this?
column(12, offset = match(k, colnames(dat)), # then lead into the if else statement
Any other suggestions on building the UI are welcome.
Try to put the fluidRow outside the lapply and change the size of the column from 12 to maybe 3, otherwise you are creating multiple rows with only one column, instead on one row with multiple columns.
Below is your code modified, maybe it could help you.
library(shiny)
library(tibble)
ui <- fluidPage(
uiOutput("controls")
)
server <- shinyServer(function(input, output, session) {
# define the data frame to use
dat <- mtcars
dat <- rownames_to_column(dat, "car")
# name of availale data frame
varNames <- names(dat)
# define defaul values as the first value in each column
defaultValues <- as.numeric(dat[1,])
# store the selected variable in a reactive variable
# dynamically creates a set of sliders
output$controls <- renderUI({
fluidRow(
column(offset = 3, 9, uiOutput("rangeUI"))
)
})
# to test that a dynamically created input works with an observer
observeEvent(input$slider_mpg, {
cat("slider_mpg:", input$slider_mpg, "\n")
})
output$rangeUI <- renderUI({
fluidRow(
lapply(1:length(varNames), function(k) {
column(3,
if (is.character(dat[1, k])) {
# a slider range will created only is the variable is selected
checkboxGroupInput(paste0("slider_", varNames[k]), label = varNames[k], choices = unique(dat[[k]]), selected = NULL,
inline = FALSE, width = NULL, choiceNames = NULL, choiceValues = NULL)
} else {
# otherwise uses single value with a default value
sliderInput(paste0("slider_", varNames[k]), label = varNames[k],
min = 0, max = 100, value = defaultValues[k])
}
)
})
)
})
})
shinyApp(ui = ui, server = server)
Update:
You can get the values of dynamically created inputs by using an action button as is explained here or get them automatically by using the solution explained here.