Drop down when clicked on action button in R

shiny
1

I have a simple DT table that is summarised as shown below. Wanted to check we can add html table drop down when clicked on respective rows (on action button).

library(dplyr)
samdt <- structure(list(ColA = c("a", "a", "b", "b", "b"), 
                        ColB = c("a1", "a1", "b1", "b2", "b2"), 
                        ColC = c(1, 2, 3, 4, 5)), row.names = c(NA,-5L), 
                   class = c("tbl_df", "tbl", "data.frame"))
new_sam <- samdt %>% group_by(ColA) %>% summarise(new_colc = n())
asd <- data.frame(a = c(HTML('<button id="as" type="button" class="btn btn-default action-button">More Info</button>'),
                        HTML('<button id="as1" type="button" class="btn btn-default action-button">More Info</button>')))
datatable(cbind(asd, new_sam),rownames = F,escape = F,
          options = list(
            columnDefs = list(
              list(orderable = FALSE, className = 'details-control', targets = c(0))
          )))

For example when clicked on row 1, we need to have drop down showing details of ColB and ColC like below

ColB    ColC
a1      1
a1      2

Similarly when clicked on row 2, we need to have

ColB    ColC
b1         3
b2         4
b2         5
2

the add_collapse_content function I gave you, I should have explained, it uses 'data-toggle' and 'data-target' to work, these are defined in bootstrap (4 I think?).
Therefore they wont work in datatable alone, but youd need to bring in bootstrap code, easiest way for me is to use in shiny. For example

library(tidyverse)
library(DT)
library(xtable)
library(shiny)
samdt <- structure(list(ColA = c("a", "a", "b", "b", "b"), 
                        ColB = c("a1", "a1", "b1", "b2", "b2"), 
                        ColC = c(1, 2, 3, 4, 5)), row.names = c(NA,-5L), 
                   class = c("tbl_df", "tbl", "data.frame"))
new_sam <- samdt %>% group_by(ColA) %>% summarise(new_colc = n())
subs <- samdt %>% group_by(ColA) %>% nest() %>% rowwise() %>% mutate(
  htmltab = HTML(print(xtable(data),type="HTML"))
)

samdt_x <- left_join(new_sam,subs)

add_collapse_content <- function(x, id) {
  tagList(
    tags$button(
      "data-toggle" = "collapse",
      "data-target" = paste0("#", id),
      "More Info"
    ),
    div(
      "id" = id,
      "class" = "collapse",
      x
    )
  )  %>% as.character()
}

samdt_x2 <- samdt_x %>% rowwise() %>% mutate(html_buttons = 
                                               add_collapse_content(htmltab,ColA)) %>%
  relocate(html_buttons) %>% select(-data,-htmltab)


library(shiny)

ui <- fluidPage(
  DTOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderDT({
  datatable(samdt_x2,rownames = F,escape = F,
            options = list(
              columnDefs = list(
                list(orderable = FALSE, className = 'details-control', targets = c(0))
              )))})
}

shinyApp(ui, server)
3

Thanks a lot for the help

4

It helped for me. But I just added another column with html tags to open another window. But the tags are gettting printed as it is and open another window. (Click on more info)

library(tidyverse)
library(DT)
library(xtable)
library(shiny)
samdt <- structure(list(Domain = c("a", "a", "b", "b", "b"), 
                        sub_domain = c("a1", "a1", "b1", "a1", "b1"), 
                        Reviews = c(1234, 2311, 3123, 4311, 5211),
                        Ratings = c(1,2,1,2,1),
                        text = c("asd","dfdsf","sdfs","sdfs","sdf")), row.names = c(NA,-5L), class = c("tbl_df", "tbl", "data.frame"))
new_sam <- samdt %>% group_by(Domain) %>% summarise(nReviews = n())
subs <- samdt %>% group_by(Domain, sub_domain) %>% summarise(nReviews = n(),Ratings = toString(Ratings), Text = toString(text),
                                                             html = HTML("<body>
        <table border='1'>
        <tr onclick='window.open(\"http://www.google.com\")'>
            <td>Open Another Window</td>
        </tr>
        </table>
    </body>")) %>% nest() %>% rowwise() %>% mutate(
  htmltab = HTML(print(xtable(data),type="HTML"))
)

samdt_x <- left_join(new_sam,subs)

add_collapse_content <- function(x, id) {
  tagList(
    tags$button(
      "data-toggle" = "collapse",
      "data-target" = paste0("#", id),
      "More Info"
    ),
    div(
      "id" = id,
      "class" = "collapse",
      x
    )
  )  %>% as.character()
}

samdt_x2 <- samdt_x %>% rowwise() %>% mutate(html_buttons = 
                                               add_collapse_content(htmltab,Domain)) %>%
  relocate(html_buttons) %>% select(-data,-htmltab)


library(shiny)

ui <- fluidPage(
  DTOutput("table")
)

server <- function(input, output, session) {
  output$table <- renderDT({
    datatable(samdt_x2,rownames = F,escape = F
              ,options = list(
                columnDefs = list(
                  list(orderable = FALSE, className = 'details-control', targets = c(0))
                ))
    )})
}

shinyApp(ui, server)
5

your issue is with the print of the xtable.
following the info at :https://stackoverflow.com/a/45911620/11726436
I found that changing to

      htmltab = HTML(print(xtable(data),type="HTML",
                           sanitize.text.function=function(x)x))

worked.
I think you can drop the body tags around your table tags though, they don't add anything.

6

Perfect thanks a lot..........

7

This topic was automatically closed 54 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.