I have an R Shiny App with a Data Table. One column contains action buttons with a unique ID. I'd like to handle clicks on those buttons, but unfortunately, my event handling code (a simple print statement) is never executed. See this self-contained example (app.R):
library(shiny)
library(DT)
ui <- shinyUI(
fluidPage(
title = "DataTable with Buttons",
fluidRow(
column(
width = 8,
dataTableOutput("employees")
)
)
)
)
server <- shinyServer(function(input, output) {
df <- data.frame(
name = c('Dilbert', 'Alice', 'Wally', 'Ashok', 'Dogbert'),
motivation = c(62, 73, 3, 99, 52),
stringsAsFactors = FALSE
)
fireButtons <- list()
fireButtonIds <- list()
for (r in rownames(df)) {
id <- paste("fire_", r, sep = "")
fireButtonIds[[r]] <- id
button <- actionButton(id, label = "Fire")
fireButtons[[r]] <- as.character(button)
}
df$actions <- fireButtons
dt <- datatable(df, colnames = c("#", "Name", "Motivation", "Actions"))
output$employees <- renderDataTable(dt)
for (id in fireButtonIds) {
# binding doesn't work
# - is the path wrong?
# - is it because the button is really a string, not an object?
observeEvent(input$employees$x$data$actions[[id]], {
print(paste("click on", i))
})
}
})
shinyApp(ui = ui, server = server)
I see two possible problems:
The path I'm using (input$employees$x$data$actions[[id]]) is just wrong
The path I'm using is correct, but it doesn't point to something that could actually be handled, i.e. it's just a HTML string and not a button object.
Or maybe there's a much better approch to put buttons inside a data table...?
Does this accomplish what you're trying to do?
library(shiny)
library(DT)
shinyApp(
ui <- fluidPage(
DT::dataTableOutput("data"),
textOutput('myText')
),
server <- function(input, output) {
myValue <- reactiveValues(employee = '')
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
df <- reactiveValues(data = data.frame(
Name = c('Dilbert', 'Alice', 'Wally', 'Ashok', 'Dogbert'),
Motivation = c(62, 73, 3, 99, 52),
Actions = shinyInput(actionButton, 5, 'button_', label = "Fire", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
stringsAsFactors = FALSE,
row.names = 1:5
))
output$data <- DT::renderDataTable(
df$data, server = FALSE, escape = FALSE, selection = 'none'
)
observeEvent(input$select_button, {
selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
myValue$employee <<- paste('click on ',df$data[selectedRow,1])
})
output$myText <- renderText({
myValue$employee
})
}
)
Related
I am working on this code where I am trying to make a new row and my existing rows has this actionbutton "Reward", after I try to insert a new row the actionbutton does not show up on the new row, is there a way I can add the actionbutton to the new row?
Also after adding a new row "1" shows up where Names would be, is there a way to get rid of that 1?
Thank you in advance! Any help is greatly appreciated.
library(shiny)
library(DT)
library(tidyverse)
dFramex <- data.frame(Name = c('Dilbert', 'Alice', 'Wally', 'Ashok', 'Dogbert'),
Motivation = c(62, 73, 3, 99, 52))
ui <- fluidPage(
fluidRow(
actionButton("save","Add Data"),
DT::dataTableOutput(outputId = "table")
)
)
server <- function(input, output, session) {
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
user_table <-
dFramex %>%
slice(1) %>%
replace(values = "")
df <- reactiveValues(data = data.frame(
dFramex,
Actions = shinyInput(actionButton, nrow(dFramex),
'button_', label = "Reward", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
stringsAsFactors = FALSE
))
output$table <-
DT::renderDataTable({DT::datatable({ df$data
},options = list(searching = FALSE, selection= FALSE)
,editable = TRUE,
escape = FALSE,
rownames = FALSE
)
}, server = FALSE)
proxy <- dataTableProxy(outputId = "table")
observeEvent(eventExpr = input$save, {
proxy %>%
addRow(user_table)
})
}
shinyApp(ui, server)
Try this
library(shiny)
library(DT)
library(tidyverse)
dFramex <- data.frame(Name = c('Dilbert', 'Alice', 'Wally', 'Ashok', 'Dogbert'),
Motivation = c(62, 73, 3, 99, 52))
ui <- fluidPage(
fluidRow(
actionButton("save","Add Data"),
DT::dataTableOutput(outputId = "table")
)
)
server <- function(input, output, session) {
shinyInput <- function(FUN, len, id, m, ...) {
if (m==1){
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
}else {
inputs <- character(1)
inputs <- as.character(FUN(paste0(id, m), ...))
}
inputs
}
df <- reactiveValues(data = data.frame(
dFramex,
Actions = shinyInput(actionButton, nrow(dFramex),
'button_', 1, label = "Reward", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
stringsAsFactors = FALSE
))
output$table <-
DT::renderDataTable({DT::datatable({ df$data
},options = list(searching = FALSE, selection= FALSE)
,editable = TRUE,
escape = FALSE,
rownames = FALSE
) }, server = FALSE)
proxy <- dataTableProxy(outputId = "table")
observeEvent(eventExpr = input$save, {
m <- nrow(dFramex) + as.numeric(input$save)
user_table <- dFramex %>% slice(1) %>%
dplyr::mutate(Actions = shinyInput(actionButton, 1,
'button_', m, label = "Reward", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ))
proxy %>% addRow(user_table)
})
}
shinyApp(ui, server)
I have an R6 class that I am using to organize my shiny application. Essentially, I want to connect different R6 classes for an experimental interface I am creating and want to reuse my code. As a simplified working example, see the code below.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 1,
#initiating the dp and desc
..dp = 'dp1',
..desc = 'problem 1',
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
private$..desc
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
initialize = function(){
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new()
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
What I want: when someone clicks the action button, the reactive ui will update and the desired text from the data frame will be sliced and displayed.
What I am getting: the internal private data fields are updating but the reactive ui elements are not.
Any ideas what could be causing this or a workaround? I thought about externally trying to use the observe event and then reinitiating the class with a new counter number. But I also can't seem to figure out that option either.
Appreciate your help!
For anyone that comes across this problem... I figured out that even though the private is updating, and even though render is technically a reactive environment, you need to have your data stored publically in a reactive field.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 0,
#initiating the dp and desc
..dp = NA,
..desc = NA,
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
self$desc$text
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
self$desc$text <- private$..desc
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
active = list(
.counter = function(value){
if(missing(value)){
private$..counter
}else{
private$..counter <- value
}
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
#Need this to update the text***************
desc = reactiveValues(text = NA),
initialize = function(counter = self$.counter){
self$.counter <- counter
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
self$desc$text <- private$..desc
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
counter <- reactiveVal(private$..counter)
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new(counter = 1)
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
I am looking to build a shiny app that dynamically creates modules (via callmodule) that returns a simple form. I have 2 loose ends on it that I would appreciate some guidance on please.
Firstly, when multiple forms are brought to the user (via a button click), the values on previously rendered forms revert to the default. How do I stop this behaviour so that values stay on the users selection?
And 2, how do I access and present ‘all’ the values from the selections into a single tibble that can be shown in a tableOutput?
I have put a simple example together below using observeEvent; I also tried a variation with eventReactive however I just can’t seem to access the callmodule outputs.
Thnx in advance!
library(shiny)
library(stringr)
gen_r_8_formUI <- function(id){
ns <- NS(id)
tagList(fluidRow(column(width = 4, selectInput(ns("slt_forename"), 'forename', choices = unique(c("john", "paul", "george", "ringo")))),
column(width = 4, selectInput(ns("slt_surname") , 'surname' , choices = unique(c("lennon", "mccartney", "harrison", "starr"))))))
}
gen_r_8_form <- function(input, output, session){
select_values <- reactiveValues(forename = NULL, surname = NULL)
observeEvent(input$slt_forename,{select_values$forename <- input$slt_forename})
observeEvent(input$slt_surname, {select_values$surname <- input$slt_surname})
select_values_all <- reactive({tibble(forename = select_values$forename, surname = select_values$surname)})
return(list(select_values_all = reactive({select_values_all()})))
}
ui <- fluidPage(
column(width = 2, actionButton("btn_gen_r_8_form", "GEN R 8 a FORM")),
column(width = 6, uiOutput("all_ui_forms")),
column(width = 4, tableOutput("all_form_values_table")))
server <- function(input, output) {
rctv_uis <- reactiveValues(all_ui = list())
gen_forms <- reactiveValues(all_form_values = list())
output$all_ui_forms <- renderUI({tagList(rctv_uis$all_ui)})
output$all_form_values_table <- renderTable({all_form_values_rctv()})
observeEvent(input$btn_gen_r_8_form, {
x_id <- paste( "ns_", str_replace_all(paste(Sys.time()), "-| |:", '') , sep = '')
gen_forms$all_form_values[[x_id]] <- callModule(module = gen_r_8_form, id = x_id)
rctv_uis$all_ui[[x_id]] <- gen_r_8_formUI(id = x_id)
})
all_form_values_rctv <- reactive({
# Question - how to make a tibble with all form values?
# tibble(
# forenames = 'all gen_forms$all_form_values forenames',
# surnames = 'all gen_forms$all_form_values surnames'
# )
})
}
shinyApp(ui = ui, server = server)
Here is a solution that uses insertUI. It has the advantage that existing UI elements stay the same (no resetting of the previous modules) and only new modules are added. To determine where the UI is added, define a tags$div(id = "tag_that_determines_the_position") in the UI function. Then, insertUI takes this as an argument. Additionally, I've changed a few things:
simplified the code for the module server function, you basically only need a reactive
use of the new module interface introduced with shiny 1.5.0
use a bit simpler reactive data structure (less nesting)
library(shiny)
library(stringr)
gen_r_8_formUI <- function(id){
ns <- NS(id)
tagList(fluidRow(column(width = 4, selectInput(ns("slt_forename"), 'forename', choices = unique(c("john", "paul", "george", "ringo")))),
column(width = 4, selectInput(ns("slt_surname") , 'surname' , choices = unique(c("lennon", "mccartney", "harrison", "starr"))))))
}
gen_r_8_form <- function(id){
moduleServer(
id,
function(input, output, session) {
select_values_all <- reactive({tibble(forename = input$slt_forename,
surname = input$slt_surname)})
return(list(select_values_all = reactive({select_values_all()})))
}
)
}
ui <- fluidPage(
column(width = 2, actionButton("btn_gen_r_8_form", "GEN R 8 a FORM")),
column(width = 6, tags$div(id = "add_UI_here")),
column(width = 4, tableOutput("all_form_values_table")))
server <- function(input, output) {
gen_forms <- reactiveValues()
current_id <- 1
observeEvent(input$btn_gen_r_8_form, {
x_id <- paste0("module_", current_id)
gen_forms[[x_id]] <- gen_r_8_form(id = x_id)
insertUI(selector = "#add_UI_here",
ui = gen_r_8_formUI(x_id))
current_id <<- current_id + 1
})
all_form_values_rctv <- reactive({
res <- lapply(reactiveValuesToList(gen_forms), function(current_module_output) {
current_module_output$select_values_all()
})
# prevent to show an error message when the first module is added
if (length(res) != 0 && !is.null(res[[1]]$forename)) {
dplyr::bind_rows(res)
} else {
NULL
}
})
output$all_form_values_table <- renderTable({
all_form_values_rctv()
})
}
shinyApp(ui = ui, server = server)
I think you want something like this
all_form_values_rctv <- reactive({
dplyr::bind_rows(lapply(gen_forms$all_form_values, function(x) {
x$select_values_all()
}))
})
You've collected all the model reactive elements in gen_forms$all_form_values so you iterate over them and get the reactive value and then bind all those tables together.
I want to create a web app, which allows user to enter input in numericInput object, which is embedded in DataTable and recalculates result (multiplication of column with some static values and a user input column) in another column.
I believe that when I set a reactive function which wraps around merging dataset and user input column and later I call it from RenderDataTable, that I somehow break the reactivity and I don't have a clue how to keep reactivity within table dependent on user input (which is also in the table). Please help.
Reproducible example to where I am stuck:
library(shiny)
library(DT)
set.seed(21)
db <- data.frame(ent = rep(x = 1,5),
group = c("G","M","O","F","L"),
val = sample(1:100, 5, replace=TRUE))
ui <- fluidPage(
titlePanel(paste0("entity - ", unique(db$ent))),
sidebarLayout(
sidebarPanel(
helpText("Shiny app calculation")
),
mainPanel(
DT::dataTableOutput("table")
))
)
numericText <- function(FUN, id_nums, id_base, label, value, ...) {
inputs <- 1:length(id_nums)
for (i in 1:length(inputs)) {
inputs[i] <- as.character(FUN(paste0(id_base,
id_nums[i]), label, value, ...))
}
return(inputs)
}
inputs <- numericText(numericInput,
id_nums = as.character(1:5),
id_base = "input_",
label = NULL,
value = 0)
db <- data.frame(db,
num = inputs)
server <- function(input, output, session) {
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
output_table <- reactive({
data.frame(db, calc = shinyValue("input_", 5))
})
output$table <- renderDataTable({
datatable(output_table(), rownames = FALSE, escape = FALSE, selection
= 'none', options = list(paging = FALSE, ordering = FALSE, searching
= FALSE, preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'), drawCallback =
JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
}
shinyApp(ui = ui, server = server)
Also maybe it helps - I was able to do this if I remove reactive expression from the dataframe and if I write result in another output type(however this is not a solution, since my main purpose is to write it in another column in DataTable):
library(shiny)
library(DT)
set.seed(21)
db <- data.frame(ent = rep(x = 1,5),
group = c("G","M","O","F","L"),
val = sample(1:100, 5, replace=TRUE))
ui <- fluidPage(
titlePanel(paste0("entity - ", unique(db$ent))),
sidebarLayout(
sidebarPanel(
helpText("Shiny app calculation")
),
mainPanel(
DT::dataTableOutput("table"),
verbatimTextOutput("text")
))
)
numericText <- function(FUN, id_nums, id_base, label, value, ...) {
inputs <- 1:length(id_nums)
for (i in 1:length(inputs)) {
inputs[i] <- as.character(FUN(paste0(id_base,
id_nums[i]), label, value, ...))
}
return(inputs)
}
inputs <- numericText(numericInput,
id_nums = as.character(1:5),
id_base = "input_",
label = NULL,
value = 0)
db <- data.frame(db,
num = inputs)
server <- function(input, output, session) {
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
output_table <- db
output$table <- renderDataTable({
datatable(output_table, rownames = FALSE, escape = FALSE, selection
= 'none', options = list(paging = FALSE, ordering = FALSE, searching
= FALSE, preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'), drawCallback =
JS('function() { Shiny.bindAll(this.api().table().node()); } ')))
})
}
output$text <- reactive({shinyValue("input_", 5) * db$val
})
shinyApp(ui = ui, server = server)
I couldn't fully understand your code so I've myself produced another reproducible example based on a bunch of other answers especially this one.
library(shiny)
library(data.table)
library(rhandsontable)
DF = data.frame(num = 1:10, qty = rep(0,10), total = 1:10,
stringsAsFactors = FALSE)
#DF = rbind(DF, c(0,0,0))
ui = fluidPage(
titlePanel("Reactive Table "),
fluidRow(box(rHandsontableOutput("table", height = 400)))
)
server = function(input, output) {
data <- reactiveValues(df=DF)
observe({
input$recalc
data$df <- as.data.frame(DF)
})
observe({
if(!is.null(input$table))
data$df <- hot_to_r(input$table)
})
output$table <- renderRHandsontable({
rhandsontable(data$df)
})
output$table <- renderRHandsontable({
data$df$total <- data$df$num * data$df$qty
print(sum(data$df$num*data$df$price) )
rhandsontable(data$df, selectCallback = TRUE)
})
}
shinyApp(ui, server)
The very first idea is to use rhandsontable which is specifically for this kind of purpose.
I've put an actionButton but I'd like to put a selectImput with three options.
With each change of option I would like you to show in the Time column the time between option 2 and option 3.
At the moment I can not put the information in the column and the time is being counted in the total not individually in each row.
ui <- fluidPage(
navbarPage(
mainPanel(
# dataTableOutput('tabela')
DT::dataTableOutput("data"),
textOutput('myText'),
actionButton("At", "Click Me")
)))
server <-function(input, output, session) {
myValue <- reactiveValues(Action = '')
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
seriet<-reactiveValues(data = data.frame(
Name = c('Laurena', 'Jennifer', 'Augusto', 'Henrique', 'Zeina','Jaque'),
Grade = c(1, 2, 3, 2, 1, 3),
Time=c(0,0,0,0,0,0),
Sport=c("Nado", "Corrida","Nado", "Corrida","Nado", "Corrida"),
Actions = shinyInput(actionButton, 6, 'button_', label = "At", onclick =
'Shiny.onInputChange(\"select_button\", this.id)' ),
stringsAsFactors = FALSE,
row.names = 1:6#prestar atencao
))
output$data <- DT::renderDataTable(
seriet$data,escape = FALSE
)
observeEvent(input$select_button, {
click <- timer()
myValue$Action <<- paste('Tempo',{print(click())*60})
})
output$myText <- renderText({
myValue$Action
})
click <- timer()
observeEvent(input$At, {print(click())})
}
shinyApp(ui, server)