In Shiny, How to add iconic checkboxgroup input to create datatable, based on the selection, which contain icons on the column names not text?

Question

I have created this app which contains datatable with icons or logos on the column names. Each step separately is doable but the issue is in executing them altogether. I am ok if it's not doable to add images to checkboxes but adding images to the datatables is necessary

the issue here I can't merge them to get the result as checkboxes with logos "without text if possible" to control the number of columns which also contains only logos on the column names

here are the images for each step and here is the dataset

    library(shiny)
    library(data.table)

    ui <- fluidPage(
    dataTableOutput("myTable"))

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

      logoList = data.frame(
    name = c("opel", "kia", "bmw"),
    logo = c(
      "<img height='50' title= 'opel'     src='https://i.wheelsage.org/pictures/opel/autowp.ru_opel_logo_1.jpg'></img>",
      "<img height='50' src='https://www.logospng.com/images/88/royal-azure-    blue-kia-icon-free-car-logo-88484.png'></img>",
      "<img height='50' src='https://cdn.iconscout.com/icon/free/png-256/bmw-    4-202746.png'></img>" ),
    stringsAsFactors = FALSE)
    myData = reactiveVal( {
    logo_name_match <- merge(
      x = data.frame(
        row_id = 1:length(colnames(testmatrixnew)),
        cols = colnames(testmatrixnew), 
        stringsAsFactors = FALSE), 
      y = logoList, 
      by.x = "cols", 
      by.y = "name", 
      all.x = TRUE)
     logo_name_match <- logo_name_match[with(logo_name_match, order(row_id)),]
     new_colnames <- ifelse(!is.na(logo_name_match$logo),logo_name_match$logo, logo_name_match$cols)
        colnames(testmatrixnew) <- new_colnames
    testmatrixnew})
    output$myTable = renderDataTable({
    myData = myData()
    datatable(myData, escape = FALSE)})}


#and also I created the same datatable based on the checkboxgroup input
here is the code

    library(shiny)
    library(DT)
    library(readxl)
    library(dplyr)
    library(formattable)
    library(shinydashboard)
    library(shinythemes)

    ui <- fluidPage(theme=shinytheme("yeti"),
               dashboardPage(
                  dashboardHeader(title = "title", titleWidth = 230), 
                  dashboardSidebar(),
                  dashboardBody(fluidRow(
                    checkboxGroupInput("show_vars", "Pick",
                                       names(testmatrixnew), selected =     names(testmatrixnew),inline = TRUE),
                    DT::dataTableOutput("mytable1")))))
    server <- function(input, output) {
    mydata2 = testmatrixnew[sample(nrow(testmatrixnew)), ]
      output$mytable1 <- DT::renderDataTable({
        DT::datatable(mydata2[, input$show_vars, drop = FALSE],options =     list(pageLength = 15, lengthChange = FALSE,dom = 't'))})}

#separately, I created this checkboxgroup input using this code

    brands <- c("kia", "opel", "bmw")

    logos <- c( "https://www.logospng.com/images/88/royal-azure-blue-kia-icon-    free-car-logo-88484.png",
            "https://i.wheelsage.org/pictures/opel/autowp.ru_opel_logo_1.jpg",
            "https://cdn.iconscout.com/icon/free/png-256/bmw-4-202746.png")
    ui <- fluidPage(checkboxGroupInput("brands", "Brands",
    choiceNames = mapply(brands, logos, FUN = function(brand,     logoUrl) {tagList(tags$img(src=logoUrl, width=20))}, SIMPLIFY = FALSE,     USE.NAMES = FALSE),choiceValues = brands,inline = TRUE))

MDg4J08Mlb_1A3DEmwX4DyNfU/view?usp=sharing

Answer 1

Here is one option using grep to match input$brands with myData column names

library(shiny)
library(DT)
library(shinythemes)
library(shinydashboard)
brands <- c("kia", "opel", "bmw")
logos <- c( "https://www.logospng.com/images/88/royal-azure-blue-kia-icon-free-car-logo-88484.png",
        "https://i.wheelsage.org/pictures/opel/autowp.ru_opel_logo_1.jpg",
        "https://cdn.iconscout.com/icon/free/png-256/bmw-4-202746.png")
ui <- fluidPage(theme=shinytheme("yeti"),
                dashboardPage(
                  dashboardHeader(title = "title", titleWidth = 230), 
                  dashboardSidebar(),
                  dashboardBody(fluidRow(
                    checkboxGroupInput("brands", "Brands",
                                       choiceNames = mapply(brands, logos, FUN = function(brand,logoUrl) {tagList(tags$img(src=logoUrl, width=20))}, 
                                                            SIMPLIFY = FALSE, USE.NAMES = FALSE),
                                       choiceValues = brands, 
                                       inline = TRUE,
                                       #All values i.e. brands will be initially/pre selected. 
                                       #With brands[1] the first value in brands will be pre selected. 
                                       #selected = brands             
                                       ),
                    DT::dataTableOutput("myTable")))))
server <- function(input, output, session) {

  logoList = data.frame(
    name = c("opel", "kia", "bmw"),
    logo = c(
      "<img height='50' title= 'opel'     src='https://i.wheelsage.org/pictures/opel/autowp.ru_opel_logo_1.jpg'></img>",
      "<img height='50' src='https://www.logospng.com/images/88/royal-azure-    blue-kia-icon-free-car-logo-88484.png'></img>",
      "<img height='50' src='https://cdn.iconscout.com/icon/free/png-256/bmw-    4-202746.png'></img>" ),
    stringsAsFactors = FALSE)
  myData = reactiveVal( {
    logo_name_match <- merge(
      x = data.frame(
        row_id = 1:length(colnames(testmatrixnew)),
        cols = colnames(testmatrixnew), 
        stringsAsFactors = FALSE), 
      y = logoList, 
      by.x = "cols", 
      by.y = "name", 
      all.x = TRUE)
    logo_name_match <- logo_name_match[with(logo_name_match, order(row_id)),]
    new_colnames <- ifelse(!is.na(logo_name_match$logo),logo_name_match$logo, logo_name_match$cols)
    colnames(testmatrixnew) <- new_colnames
    testmatrixnew})
  observe(print(myData()))  #To see what we're working with
  output$myTable = renderDataTable({
    req(input$brands) #Show the Table only after one box at least is checked 
    myData = myData()
    #browser()
    #DT::datatable(myData, escape = FALSE)
    col_names = grep(paste(input$brands,collapse = '|'), names(myData), value = TRUE)
    DT::datatable(myData[, c('brand', col_names), drop = FALSE], options = list(pageLength = 15, lengthChange = FALSE,dom = 't'), escape = FALSE)
    })}

shinyApp(ui, server)

Data

#Using dput
testmatrixnew <- structure(list(brand = c("generation_x", "generation_y", "generation_z"
), kia = c(80, 94, 37), vw = c(59, 4, 66), mit = c(56, 1, 72), 
bmw = c(64, 7, 37), audi = c(98, 47, 2), lw = c(91, 99, 32
), lada = c(92, 34, 19), RR = c(55, 68, 88), opel = c(67, 
81, 49), LBGN = c(85, 69, 83), Jeep = c(56, 97, 43)), row.names = c(NA, -3L), class = c("tbl_df", "tbl", "data.frame"))

Update

output$myTable = renderDataTable({
    req(input$brands) #Show the Table only after one box at least is checked 
    myData = myData()
    #browser()
    #DT::datatable(myData, escape = FALSE)
    #Transpose myData to myData_trans
    #Here is simple example you can run R console using testmatrixnew
    #t_testm <- data.frame(cbind(colnames(testmatrixnew)[-1], t(testmatrixnew[,-1])), row.names = NULL)
    #names(t_testm) <- c('brand','generation_x','generation_y','generation_z')
    myData_trans <- data.frame(cbind(colnames(myData)[-1], t(myData[,-1])), row.names = NULL)
    names(myData_trans) <- c('brand','generation_x','generation_y','generation_z')
    #Match input$brands with column brand
    rw_names <- grep(paste(input$brands,collapse = '|'), myData_trans$brand)
    DT::datatable(myData_trans[rw_names, , drop = FALSE], options = list(pageLength = 15, lengthChange = FALSE,dom = 't'), escape = FALSE)
  })