html - 图像 for 单选按钮 r Shiny

Question

我正在学习如何使用图像作为单选按钮。

我找到了这个页面并一直在玩它: Can you have an image as a radioButton choice in shiny?

这里的答案非常有用，但应用程序不会加载单选按钮的 Rlogo(当使用答案的第二部分使用功能时)。我已将图像保存到 www 文件中。我尝试过不同的写法 '<img src="Rlogo.png">' = 'logo'比如删除引号，将其替换为 img(src='Rlogo.png') = 'logo' ，用网页链接替换，但一直不成功。请有人指出我哪里出错了或者原始代码是否适合您!

Logo 在这里:http://i1.wp.com/www.r-bloggers.com/wp-content/uploads/2016/02/Rlogo.png?resize=300%2C263

代码是从页面复制过来的:

library(shiny)

radioButtons_withHTML <- function (inputId, label, choices, selected = NULL, inline = FALSE, 
          width = NULL) 
{
        choices <- shiny:::choicesWithNames(choices)
        selected <- if (is.null(selected)) 
                choices[[1]]
        else {
                shiny:::validateSelected(selected, choices, inputId)
        }
        if (length(selected) > 1) 
                stop("The 'selected' argument must be of length 1")
        options <- generateOptions_withHTML(inputId, choices, selected, inline, 
                                   type = "radio")
        divClass <- "form-group shiny-input-radiogroup shiny-input-container"
        if (inline) 
                divClass <- paste(divClass, "shiny-input-container-inline")
        tags$div(id = inputId, style = if (!is.null(width)) 
                paste0("width: ", validateCssUnit(width), ";"), class = divClass, 
                shiny:::controlLabel(inputId, label), options)
}

generateOptions_withHTML <- function (inputId, choices, selected, inline, type = "checkbox") 
{
        options <- mapply(choices, names(choices), FUN = function(value, 
                                                                  name) {
                inputTag <- tags$input(type = type, name = inputId, value = value)
                if (value %in% selected) 
                        inputTag$attribs$checked <- "checked"
                if (inline) {
                        tags$label(class = paste0(type, "-inline"), inputTag, 
                                   tags$span(HTML(name)))
                }
                else {
                        tags$div(class = type, tags$label(inputTag, tags$span(HTML(name))))
                }
        }, SIMPLIFY = FALSE, USE.NAMES = FALSE)
        div(class = "shiny-options-group", options)
}

    choices <- c('\\( e^{i \\pi} + 1 = 0 \\)' = 'equation',
                 '<img src="Rlogo.png">' = 'logo')


  ui <- shinyUI(fluidPage(
    withMathJax(),
    img(src='Rlogo.png'),
    fluidRow(column(width=12,
        radioButtons('test', 'Radio buttons with MathJax choices',
                     choices = choices, inline = TRUE),
        br(),
        h3(textOutput('selected'))
    ))
))

server <- shinyServer(function(input, output) {
    output$selected <- renderText({
        paste0('You selected the ', input$test)
    })
})

shinyApp(ui = ui, server = server)

Answer 1

这里有一个方法。

library(shiny)

radioImages <- function(inputId, images, values){
  radios <- lapply(
    seq_along(images),
    function(i) {
      id <- paste0(inputId, i)
      tagList(
        tags$input(
          type = "radio",
          name = inputId,
          id = id,
          class = "input-hidden",
          value = as.character(values[i])
        ),
        tags$label(
          `for` = id,
          tags$img(
            src = images[i]
          )
        )
      )
    }
  )
  do.call(
    function(...) div(..., class = "shiny-input-radiogroup", id = inputId), 
    radios
  )
}

css <- HTML(
  ".input-hidden {",
  "  position: absolute;",
  "  left: -9999px;",
  "}",
  "input[type=radio] + label>img {",
  "  width: 50px;",
  "  height: 50px;",
  "  transition: 500ms all;",
  "}",
  "input[type=radio]:checked + label>img {",
  "  border: 1px solid #fff;",
  "  box-shadow: 0 0 3px 3px #090;",
  "  transform: rotateZ(-10deg) rotateX(10deg);", 
  "}"
)


ui <- fluidPage(
  tags$head(tags$style(css)),
  br(),
  wellPanel(
    tags$label("Choose a language:"),
    radioImages(
      "radio",
      images = c("java.svg", "javascript.svg", "julia.svg"),
      values = c("java", "javascript", "julia")
    )
  ),
  verbatimTextOutput("language")
)

server <- function(input, output, session){
  output[["language"]] <- renderPrint({
    input[["radio"]]    
  })
}

shinyApp(ui, server)

Credit .