R Shiny: Handle Action Buttons in Data Table

R Shiny: Handle Action Buttons in 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

    })

  }
)

Add format to datatable conflicts with action buttons in R shiny

You should look at this answer. Applying his advice to your problem, I move escape = FALSE, selection = 'none' in datatable(df$data) and it works (you need to remove server = FALSE, which is not accepted in datatable):

    output$data <- DT::renderDataTable(
      datatable(df$data, escape = FALSE, selection = 'none') %>% formatStyle(
        'Motivation',
        target = 'row',
        backgroundColor = styleEqual(c(3), c('yellow'))
      )
    )

In case the answer I refer above is deleted (don't know if it can be), I also put it here:

You are getting this error because you are returning a DT::datatable AND you are also specifying filter='top' as one of the ... arguments to DT::renderDataTable. As the message is trying to tell you ... arguments are ignored since you are returning a DT::datatable. This is because the ... arguments are intended to be passed through to the DT:datatable constructor.

Either move filter='top' inside the DT::datatable constructor or return a data.frame and the filter='top will be used when DT::renderDataTable constructs a DT::datatable with your specified data.frame.

Display table or chart in the same box upon clicking different buttons in R shiny

One way to do it is to use ObserveEvent(). Try this

library(shiny)
library(shinydashboard)
shinyApp(
  ui = shinydashboard::dashboardPage(
    header = dashboardHeader(),
    sidebar = dashboardSidebar(),
    body = dashboardBody(
      actionButton(inputId = 'input1', label = 'Chart'),
      actionButton(inputId = 'input2', label = 'Table'),
      box(
        uiOutput('plot_table_output'))
    ),
    title = "DashboardPage"
  ),
  server = function(input, output) {
    
    observeEvent(input$input1, {
      output$plot_table_output <- renderUI({
          plotOutput('my_plot')
      })
    })
    
    observeEvent(input$input2, {
      output$plot_table_output <- renderUI({
        dataTableOutput('mytable')
      })
    })
    
    output$my_plot <- renderPlot({
      mydf <- data.frame(X=1:10, Y=1:10)
      plot(mydf$X, mydf$Y, type = 'l')
    })
    
    output$mytable <- renderDataTable({
      mydf <-  data.frame(X=1:10, Y=1:10)
      mydf
    })   
  }
)

Adding buttons to Shiny DT to pull up modal

In your comment, you asked for the case of multiple datatables. Is it what you want ?

library(shiny)
library(DT)

button <- function(tbl){
  function(i){
    sprintf(
      '<button id="button_%s_%d" type="button" onclick="%s">Click me</button>', 
      tbl, i, "Shiny.setInputValue('button', this.id);")
  }
}

dat1 <- cbind(iris, 
              button = sapply(1:nrow(iris), button("tbl1")), 
              stringsAsFactors = FALSE)
dat2 <- cbind(mtcars, 
              button = sapply(1:nrow(mtcars), button("tbl2")), 
              stringsAsFactors = FALSE)

ui <- fluidPage(
  fluidRow(
    column(
      width = 6,
      DTOutput("tbl1", height = "500px")
    ),
    column(
      width = 6,
      DTOutput("tbl2", height = "500px")
    )
  )

)

server <- function(input, output){

  output[["tbl1"]] <- renderDT({
    datatable(dat1, escape = ncol(dat1)-1, fillContainer = TRUE)
  })

  output[["tbl2"]] <- renderDT({
    datatable(dat2, escape = ncol(dat2)-1, fillContainer = TRUE)
  })

  observeEvent(input[["button"]], {
    splitID <- strsplit(input[["button"]], "_")[[1]]
    tbl <- splitID[2]
    row <- splitID[3]
    showModal(modalDialog(
      title = paste0("Row ", row, " of table ", tbl, " clicked"),
      size = "s",
      easyClose = TRUE,
      footer = NULL
    ))
  })
}

shinyApp(ui, server)

r Shiny action button and data table output last N rows

@Tomáš - I would recommend avoiding putting your output statements inside of observeEvent. Instead, I would create an eventReactive that will be triggered by your action button. And when this happens, it will store all your needed info in a list, and all of your outputs will be dependent on this list. Here is one way to do this (below is the server function only).

server <- function(input, output) {

  aq_data <- eventReactive(input$gobutton, {
    list(data = airquality, nID = input$numericID, rID = input$radioID, sID = input$selectID, tID = input$textID)
  }) 

  output$textik <- renderText({
    vypis=c("Zobrazili ste tabuľku s", aq_data()[["nID"]], "riadkami a boxplot pre atribút Ozone ste nastavili na farbu ", aq_data()[["rID"]])
    print(vypis)
  })

  output$table <- renderTable(tail(aq_data()[["data"]], aq_data()[["nID"]]))

  output$distPlot <- renderPlot({
    dat <- aq_data()
    boxplot(reformulate("Month", dat[["sID"]]), col = dat[["rID"]], border = 'white', main = dat[["tID"]], data = dat[["data"]])
  })

}

R Shiny - saving values of function in data table after action button press

I think there may be a number of ways you could set this up differently.

One recommendation I have is to avoid putting output inside of your observers.

Another is calling your stopwatch functions only once - for data integrity, to make sure your display and data collected are the same.

In addition, it might be helpful to have a single data table store all of your open and close events, with an additional column for animal number. It would be relatively easy to work with a table like this for future analyses.

Here is a quick example you can try out, just to get a sense of the behavior. Please also add tableOutput('table') to your ui after your conditionalPanel to view the data frame.

# ui ----

ui <- fluidPage(
  titlePanel("Lymnaea stopwatch"),

  sidebarLayout(
    sidebarPanel(

      selectInput(
        "select",
        label = "Number of animals",
        choices = c(1,2,3,4,5,6,7,8,9,10),
        selected = c("1")
      )
      # action button conditionals ----      
    ),
    mainPanel(
      h4("Start/Stop Experiment:"),
      actionButton('start1',"Start"),
      actionButton('stop1', "Stop"),
      textOutput('initial1'),
      textOutput('start1'),
      textOutput('stop1'),
      textOutput('stoptime1'),

      conditionalPanel(
        h4("Animal 1"),
        condition = "input.select == '1'||input.select == '2'||input.select == '3'||input.select == '4'||input.select == '5'||input.select == '6'||input.select == '7'||input.select == '8'||input.select == '9'||input.select == '10'",
        actionButton('open1', "Open"),
        actionButton('close1', "Close"),
        textOutput('open1'),
        textOutput('opentime1'),
        textOutput('close1'),
        textOutput('closetime1'),
      ),
      tableOutput('table')
    )
  )
)

# server ----

server <- function(input, output, session) {

  values <- reactiveValues(df = data.frame(Animal = integer(),
                                           Event = character(),
                                           Time = as.POSIXct(character()),
                                           stringsAsFactors = FALSE),
                           timer = "Timer Off")

  output$initial1 <- renderText({
    values$timer
  })

  output$opentime1 <- renderText({
    paste("Opened at:", tail(values$df[values$df[["Animal"]] == 1 & values$df[["Event"]] == "Open", "Time"], 1))
  })

  output$closetime1 <- renderText({
    paste("Closed at:", tail(values$df[values$df[["Animal"]] == 1 & values$df[["Event"]] == "Close", "Time"], 1))
  })

  output$table <- renderTable({
    values$df
  })

  observeEvent(input$start1, {
    watch$start()
    values$timer <- "Timer Started"
  })

  observeEvent(input$open1, {
    values$df <- rbind(values$df, data.frame(Animal = 1, Event = "Open", Time = watch$open()))
  })

  observeEvent(input$close1, {
    values$df <- rbind(values$df, data.frame(Animal = 1, Event = "Close", Time = watch$close()))
  })

}

This could be scaled up for 10 animals, and there are alternative ways to provide feedback to user on data.

Let me know what you think, and if this is in the direction you had in mind.

Actionbutton within DataTable doesn't work, Shiny DT

Get inspired by the answer here: R Shiny: Handle Action Buttons in Data Table

I guess the key is to add the on.click parameter when creating actionLinks inside DT, so that click triggers event. And the on.click can also assign unique button id to the actionLink/button. Then in observeEvent, simply put the expression as input$selected_button. See full code below:

---
title: "Fruit Dashboard"
output: 
flexdashboard::flex_dashboard:
   orientation: columns
   vertical_layout: fill
runtime: shiny
---

```{r global, include=FALSE, echo=FALSE}

# import libraries

library(DT)
library(shiny)
library(tidyverse)
library(shinythemes)
library(shinydashboard)

df <- data.frame('Fruit' = c('apple', 'orange', 'watermelon'),
                     'Count' = c(3,4,5))

shinyInput <- function(FUN, len, id, label, ...) {
  inputs <- character(len)

  for (i in seq_len(len)) {
    label <- df$Fruit[i]
    inputs[i] <- as.character(FUN(paste0(id, i),label=label, ...))
  }
  inputs
 }

```

```{r, echo = FALSE}

shinyApp(

  ui <- fluidPage(
    titlePanel("Fruit Dashboard"), 
    theme = shinytheme("united"),
    navlistPanel(id='nav', widths = c(2, 10),
              tabPanel('Summary2', dataTableOutput('summary')),
              tabPanel("apple", dataTableOutput('apple')),
              tabPanel("orange", dataTableOutput('orange')),
              tabPanel("watermelon", dataTableOutput('watermelon'))
    )

  ),

  server <- function(input, output, session) {

    output$summary <- renderDataTable({

      data <- df %>%
        mutate(Fruit = shinyInput(actionLink, nrow(df), 'button_', label = Fruit, onclick = 'Shiny.onInputChange(\"select_button\",  this.id)' ))

  table <- datatable(data, escape = FALSE , selection = 'none')

  table
    })

observeEvent(input$select_button, {
   selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])

  updateNavlistPanel(session, 'nav', df[selectedRow, 1])
})

output$apple <- renderDataTable({

  data <- data.frame('Total#' = 3, 'Organic#'= 2, 'Conventional#'=1)

  table <- datatable(data, escape = FALSE)
  table
})


output$orange <- renderDataTable({

  data <- data.frame('Total#' = 4, 'Organic#'= 3, 'Conventional#'=1)

  table <- datatable(data, escape = FALSE)
  table
})

output$watermelon <- renderDataTable({

  data <- data.frame('Total#' = 5, 'Organic#'= 2, 'Conventional#'= 3)

  table <- datatable(data, escape = FALSE)
  table
    })
  }
)


```

actionButton in Shiny DataTable that has a Different on-click URL by Row

The problem arises from the fact that you try to pass an R object (list) (actionButton) to mutate. The list happens to has length 3 but mutate expects the same length as the dataframe. What you want is to take this object and convert it to the corresponding string. As you are anyways not using Shiny's reactivity on these buttons, I would recommend to construct the HTML yourself instead of using actionButton (untested, as you did not provide a reprex ):

library(tidyverse)
filteredData %>% 
   mutate(Amazon.button = map_chr(ASIN,
      ~ tags$button(class = "btn btn-default",
                    type  = "button",
                    icon("amazon"),
                    "Amazon",
                    onclick = paste0("window.open('https://",
                                     AmazonSiteLink,
                                     "/gp/product/",
                                     .x,
                                     "/ref=as_li_tl?ie=UTF8&tag=",
                                     AssociateTag, 
                                     "')")
                    ) %>%
         as.character()
      )
   )

button inside. DT::datatable does not render properly

That's because of the quotes. Your render function generates <span title="<button id = "xxx" ...... and this causes the issue.

You don't want to apply the span to the buttons, so add the regex test !(/button/).test(data) in the conditions:

render = JS("function(data, type, row, meta) {",
            "return type === 'display' && typeof data === 'string' && data.length > 10 && !(/button/).test(data) ? ",
            "'<span title=\"' + data + '\">' + data.substr(0,  10) + '...</span>' : data;",
            "}")

---

Related Topics