How to make pop-up with images on click in datatable format?

Question

I am creating a datatable, one column includes images, I want to get a popup to display a larger image when I click on the images on the cell.

Code below:

library(shiny)
library(DT)

dat <- data.frame(
  country = c('USA', 'China'),
  flag = c('<img src="http://bpic.588ku.com//element_origin_min_pic/16/11/14/2f4de8bcf22409518c2fe2d74a49d9c7.jpg" height="52"></img>',
           '<img src="http://upload.wikimedia.org/wikipedia/commons/thumb/f/fa/Flag_of_the_People%27s_Republic_of_China.svg/200px-Flag_of_the_People%27s_Republic_of_China.svg.png" height="52"></img>'
  )
)

ui<-fluidPage(
  DT::dataTableOutput('mytable')
)

server<-function(input, output){
  output$mytable <- DT::renderDataTable({

    DT::datatable(dat, escape = FALSE)
  })
}

shinyApp(ui=ui,server=server)

Final result:

Answer 1

You can use tableHTMLto achieve it with the help make_css()that creates a css file that can be used in a brilliant web application. You can check this vignette for more details.

library(shiny)
library(tableHTML)

dat <- data.frame(
  country = c('USA', 'China'),
  flag = c('<img src="http://bpic.588ku.com//element_origin_min_pic/16/11/14/2f4de8bcf22409518c2fe2d74a49d9c7.jpg" height="52"></img>',
           '<img src="http://upload.wikimedia.org/wikipedia/commons/thumb/f/fa/Flag_of_the_People%27s_Republic_of_China.svg/200px-Flag_of_the_People%27s_Republic_of_China.svg.png" height="52"></img>'
  )
)

Use make_css()to create css, which allows you to expand the image. It will look like this:

img {
  transition: transform 0.25s ease;;
}
img:hover {
  transform: scale(1.5);
}

ui<-fluidPage(
  br(),
  tags$style(make_css(list(c('img'),
                           c('transition'),
                           c('transform 0.25s ease;')))),
  tags$style(make_css(list(c('img:hover'),
                           c('transform'),
                           c('scale(10) translate(50%, 50%)')))),
  uiOutput("mytable")
)

On the server, create tableHTML:

server<-function(input, output){
  output$mytable <- renderUI({

    tableHTML(dat, 
              escape = FALSE, 
              rownames = FALSE) 
  })
}

shinyApp(ui=ui,server=server)

:

, :

. theme css . . tableHTML vignette examples,

Answer 2

, , .

library("shiny")
library("datasets")
library("DT")
library("shinyBS")

ui = shinyUI(fluidPage(
  DT::dataTableOutput("mtcarsTable"),
  bsModal("mtCarsModal", "My Modal", "",textOutput('mytext'), size = "small")
))

on_click_js = "
Shiny.onInputChange('mydata', '%s');
$('#mtCarsModal').modal('show')
"

convert_to_link = function(x) {
  as.character(tags$a(href = "#", onclick = sprintf(on_click_js,x), x))
}

shinyApp(
  ui = ui,
  server = function(input, output, session) {

    mtcarsLinked <- reactive({   
      mtcars$mpg <- sapply(
        datasets::mtcars$mpg,convert_to_link)
      return(mtcars)
    })

    output$mtcarsTable <- DT::renderDataTable({
      DT::datatable(mtcarsLinked(), 
                           class = 'compact',
                           escape = FALSE, selection='none'
      )
    })
    output$mytext = renderText(sprintf('mpg value is %s',input$mydata))
  }
)

: https://github.com/ebailey78/shinyBS/issues/26

, , , , .