如何在数据表中单击时弹出单元格图像？

Question

我创建了一个数据表，其中一列包含图像，我想在单击单元格图像时弹出一个窗口以显示更大的图像。

代码如下：

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)

目标结果：

Answer 1

您可以使用tableHTML 来实现它，使用make_css() 创建一个可以在闪亮的web 应用程序中使用的css 文件。您可以查看thisvignette 了解更多详情。

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>'
  )
)

使用make_css() 创建css，允许您展开图像。它看起来像这样：

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")
)

在服务器中，创建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

如果我应该只发布链接作为评论而不是答案，请告诉我，我会删除它。