rshinydtaction-button

Toggle actionButton color (between Orange & Green) on click within Shiny DT and create new data frame from selected rows


I am developing a Shiny App, where the user can upload data, do some manipulations & create new df from selected rows. I have got till where I can add actionButtons per row in DT but cant make selections work. Selections work as expected if actionButtons are not included in the DT rows. What am I looking for?

1. To be able to toggle between two colors on click within each of the DT row (Orange = not selected; Green = selected, when clicked)

2. Create new data frame from selected rows of the datatable on another actionButton click (Ex: Category 01 or Category 02).

Once any of the Category 01 or Category 02 actionButton is clicked. I get this error Error: incorrect number of dimensions. As shown at the bottom of Image 2.

I have added reproducible code below.

Any help is much appreciated

As in screenshot1, actionbuttons are Orange And in screenshot2 they are Green image, image

Data

data <- data.frame(Name = rep(paste("RIS", 1:20, sep = "_")),
                   Gender = rep(c("Male", "Female"), each = 10),
                   CDC = rnorm(20),
                   FDC = rnorm(20),
                   RDC = rnorm(20), 
                   LDC = rnorm(20)
                   )

Example Code

library(shiny)
library(DT)

ui <- fluidPage(
  titlePanel("simpleApp"),
  sidebarLayout(
    sidebarPanel(fileInput("file1", "Upload Input file", accept = ".csv"), width = 2,
                 actionButton("calc", "Calculate"),
                 hr(style = "border-color: red; height: 5px"),
                 actionButton("gen1", "Category 01"),
                 actionButton("gen2", "Category 02")),
    mainPanel (
      dataTableOutput("table"),
      dataTableOutput("table2"),
      dataTableOutput("select_table1"),
      dataTableOutput("select_table2"))))

server <- function(input, output, session) {
  
  addButtonColumn <- function(df, id, ...) {
    f <- function(i) {
      as.character(
        actionButton(paste(id, i, sep = "_"), class = "btn-warning btn-sm", label = tags$strong("Select"),
          onclick = 'Shiny.setInputValue(\"addPressed\", this.id, {priority: "event"})'))
    }
    
    addCol <- unlist(lapply(seq_len(nrow(df)), f))
    
    DT::datatable(cbind(Decision = addCol, df), 
                  escape = FALSE, filter = "top", options = list(columnDefs = list(list(targets = 1, sortable = FALSE))))
  }
  
data <- reactive({
    df <- input$file1
    if(is.null(df))
      return(NULL)
   df <- read.csv(df$datapath, header = TRUE, sep = ",", row.names = NULL)
    return(df)
   })
  
  output$table <- DT::renderDataTable(data(), options = list(paging = t, pageLength = 6))
  
  table2 <- eventReactive(input$calc, {
    df2 <- input$file1
    if(is.null(df2))
      return(NULL)
    table2 <- data() %>%
      mutate("Selection" = CDC * RDC + FDC * LDC) %>%
      mutate(across(where(is.numeric), round, 3)) %>%
      addButtonColumn("Button")
    })
 
  output$table2 <- DT::renderDataTable(table2(), options = list(paging = t, pageLength = 6))
  
  select_table1 <- eventReactive(input$gen1, {
    if(is.null(table2)){
       return(NULL)
    } else {
      select_table1 <- table2()[input$table2_rows_selected,]
    } 
  })
  
  select_table2 <- eventReactive(input$gen2, {
    if(is.null(table2)){
      return(NULL)
    } else {
      select_table2 <- table2()[input$table2_rows_selected,]
    } 
  })
  
  output$select_table1 <- DT::renderDataTable(select_table1(), options = list(paging = t, pageLength = 6))
  output$select_table2 <- DT::renderDataTable(select_table2(), options = list(paging = t, pageLength = 6))
}

shinyApp(ui = ui, server = server)


Solution

    1. Some simple CSS can do it.
    2. You called DT::datatable too early in the eventReactive. You need to call it within renderDataTable, otherwise, the render function can't recognize it properly (it can, but table2_rows_selected will not work).
    df <- data.frame(Name = rep(paste("RIS", 1:20, sep = "_")),
                       Gender = rep(c("Male", "Female"), each = 10),
                       CDC = rnorm(20),
                       FDC = rnorm(20),
                       RDC = rnorm(20), 
                       LDC = rnorm(20)
    )
    
    library(shiny)
    library(DT)
    
    ui <- fluidPage(
        titlePanel("simpleApp"),
        sidebarLayout(
            sidebarPanel(fileInput("file1", "Upload Input file", accept = ".csv"), width = 2,
                         actionButton("calc", "Calculate"),
                         hr(style = "border-color: red; height: 5px"),
                         actionButton("gen1", "Category 01"),
                         actionButton("gen2", "Category 02")),
            mainPanel (
                dataTableOutput("table"),
                dataTableOutput("table2"),
                dataTableOutput("select_table1"),
                dataTableOutput("select_table2"))),
        tags$style(
            '
            table.dataTable tr.selected button {
                background-color: green;
                border-color: green;
            }
            '
        )
    )
    
    server <- function(input, output, session) {
        
        addButtonColumn <- function(df, id, ...) {
            f <- function(i) {
                as.character(
                    actionButton(paste(id, i, sep = "_"), class = "btn-warning btn-sm", label = tags$strong("Select"),
                                 onclick = 'Shiny.setInputValue(\"addPressed\", this.id, {priority: "event"})'))
            }
            
            addCol <- unlist(lapply(seq_len(nrow(df)), f))
            
            cbind(Decision = addCol, df)
        }
        
        data <- reactive({
            df
        })
        
        output$table <- DT::renderDataTable(data(), options = list(paging = t, pageLength = 6))
        
        table2 <- eventReactive(input$calc, {
            df2 <- df
            if(is.null(df2))
                return(NULL)
            data() %>%
                mutate("Selection" = CDC * RDC + FDC * LDC) %>%
                mutate(across(where(is.numeric), round, 3)) %>%
                addButtonColumn("Button")
        })
        
        output$table2 <- DT::renderDataTable(DT::datatable(
            table2(), escape = FALSE, filter = "top", 
            options = list(columnDefs = list(list(targets = 1, sortable = FALSE, paging = t, pageLength = 6)))
        ))
        
        select_table1 <- eventReactive(input$gen1, {
            if(is.null(table2)){
                return(NULL)
            } else {
                print(input$table2_rows_selected)
                select_table1 <- table2()[input$table2_rows_selected,]
            } 
        })
        
        select_table2 <- eventReactive(input$gen2, {
            if(is.null(table2)){
                return(NULL)
            } else {
                select_table2 <- table2()[input$table2_rows_selected,]
            } 
        })
        
        output$select_table1 <- DT::renderDataTable(DT::datatable(select_table1(),  escape = FALSE, options = list(paging = t, pageLength = 6)))
        output$select_table2 <- DT::renderDataTable(select_table2(), escape = FALSE, options = list(paging = t, pageLength = 6))
    }
    
    shinyApp(ui = ui, server = server)
    

    Disabled your uploading part. You need to change it back.

    enter image description here