Shiny articles

继续整理shiny的几个用法

Download existing file

在shiny用法整理（三）中，提到对于多个文件的下载，可在 downloadHandler 中将多个输出文件进行压缩后作为单个文件进行下载，比如我有100个文件要生成：

library(shiny)

ui <- fluidPage(
  downloadButton(outputId = "download", label = "Download Single Boxplot Plot")
)

server <- function(input, output, session) {
  output$download <- downloadHandler(
    filename = "xxx.zip",
    contentType = "application/zip",
    content = function(file){
      fs <- c()
      for (i in 1:10) {
        filepath <- paste0(tempdir(), "/", i, ".txt")
        fs <- c(fs, filepath)
        data <- matrix(1:100000, nrow = 1000)
        write.table(data, file = filepath, sep = "\t", quote = F)
      }
      zip(zipfile = file, files = fs)
      file.remove(fs)
    }
  )
}

shinyApp(ui, server)

但是，当我将输出文件设置为100或者更多时，则会出现一种BUG，浏览器在发送下载请求时，shiny还是生成并压缩该100个文件，但是由于其中生成过程时间较长，会造成连接中断（即shiny后台还在处理文件，但是下载连接却先中断了）；在这种情况下，我们需要做一些改变，将生成文件的过程从 downloadHandler 中挪出，放到一个 observeEvent 下，并将生出处理文件的过程放到临时文件夹中，这样我们相当于是将一个已生成的文件通过download按钮下载下来，如下：

library(shiny)

ui <- fluidPage(
  actionButton(inputId = "button", label = "Submit! Go!", icon = icon("refresh")),
  br(),
  downloadButton(outputId = "download", label = "Download Single Boxplot Plot")
)

server <- function(input, output, session) {
  observeEvent(input$button, {
    fs <- c()
    for (i in 1:100) {
      filepath <- paste0(tempdir(), "/", i, ".txt")
      fs <- c(fs, filepath)
      data <- matrix(1:100000, nrow = 1000)
      write.table(data, file = filepath, sep = "\t", quote = F)
    }
    zip(zipfile = paste0(tempdir(), "/xxx.zip"), files = fs)
    file.remove(fs)
  })

  output$download <- downloadHandler(
    filename = "xxx.zip",
    contentType = "application/zip",
    content = function(file){
      file.copy(paste0(tempdir(), "/xxx.zip"), file)
      file.remove(paste0(tempdir(), "/xxx.zip"))
    }
  )
}

shinyApp(ui, server)

为了增加一些体验度，使用进度条来提醒shiny工具使用者：后台正在处理文件，这种在 observeEvent 中使用shiny的 progress 即可：

library(shiny)

ui <- fluidPage(
  actionButton(inputId = "button", label = "Submit! Go!", icon = icon("refresh")),
  br(),
  downloadButton(outputId = "download", label = "Download Single Boxplot Plot")
)

server <- function(input, output, session) {
  observeEvent(input$button, {
    fs <- c()

    progress <- shiny::Progress$new()
    on.exit(progress$close())
    progress$set(message = "Begin to process files, Please wait...", value = 0)

    for (i in 1:100) {
      filepath <- paste0(tempdir(), "/", i, ".txt")
      fs <- c(fs, filepath)
      data <- matrix(1:100000, nrow = 1000)
      write.table(data, file = filepath, sep = "\t", quote = F)

      progress$inc(1/100, detail = "Please wait...")
    }

    progress$set(message = "Begin to zip files, Please wait...", value = 0.5)

    zip(zipfile = paste0(tempdir(), "/xxx.zip"), files = fs)
    file.remove(fs)

    progress$set(message = "Over...", value = 1)
  })

  output$download <- downloadHandler(
    filename = "xxx.zip",
    contentType = "application/zip",
    content = function(file){
      file.copy(paste0(tempdir(), "/xxx.zip"), file)
      file.remove(paste0(tempdir(), "/xxx.zip"))

    }
  )
}

shinyApp(ui, server)

Select rows using checkboxes in DT

DT包其实已经支持对row/column进行单选/复选的功能，如： https://yihui.shinyapps.io/DT-selection

但是如果想在DT输出的表格中有一列更加直观的checkboxes，那么可以考虑用以下这个模板：

library(shiny)
library(DT)
shinyApp(
  ui = fluidPage(DT::dataTableOutput('x1'), verbatimTextOutput('x2')),

  server = function(input, output) {
    # create a character vector of shiny inputs
    shinyInput = function(FUN, len, id, ...) {
      inputs = character(len)
      for (i in seq_len(len)) {
        inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
      }
      inputs
    }

    # obtain the values of inputs
    shinyValue = function(id, len) {
      unlist(lapply(seq_len(len), function(i) {
        value = input[[paste0(id, i)]]
        if (is.null(value)) NA else value
      }))
    }

    # a sample data frame
    res = data.frame(
      v1 = shinyInput(numericInput, 100, 'v1_', value = 0),
      v2 = shinyInput(checkboxInput, 100, 'v2_', value = TRUE),
      v3 = rnorm(100),
      v4 = sample(LETTERS, 100, TRUE),
      stringsAsFactors = FALSE
    )

    # render the table containing shiny inputs
    output$x1 = DT::renderDataTable(
      res, server = FALSE, escape = FALSE, selection = 'none', options = list(
        preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      )
    )
    # print the values of inputs
    output$x2 = renderPrint({
      data.frame(v1 = shinyValue('v1_', 100), v2 = shinyValue('v2_', 100))
    })
  }
)

感谢 谢益辉大神的提供的解决方案 https://github.com/rstudio/DT/issues/93

Shiny table rendering html

shiny app中对于表格的展示，除了DT包外，还有常规函数 tableOutput ，但是其默认参数是不会将单元格中R代码渲染成HTML代码，比如：

library(shiny)

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

server <- function(input, output, session) {
  output$table <- renderTable({
    r <- data.frame(ID = 1, url = as.character(tags$a(href = "www.baidu.com", "r")))
  })
}

shinyApp(ui, server)

其结果表格中url是以 <a href="www.baidu.com">r</a> 显示的，说明html代码未被渲染；这时需要xtable包中 print.xtable 函数的一个参数 sanitize.text.function ，其能将上述html渲染为一个超链接

两者的区别，网上给出的说法是（我的理解是 renderTable 是将R对象转化为html，可供 xtable 来渲染， renderTable 默认情况下， sanitize.text.function 是关闭的，可看 print.xtable 函数的帮助文档）：

It looks unlikely, as sanitize.text.function is from the xtable package which itself writes the html – renderTable is just passing parameters to it. It is probably possible to embed html in a way that renderDataTable will properly display it…

因此解决方法如下：

library(shiny)

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

server <- function(input, output, session) {
  output$table <- renderTable({
    r <- data.frame(ID = 1, url = as.character(tags$a(href = "https://www.baidu.com/", "r")))
  }, sanitize.text.function = function(x) x)
}

shinyApp(ui, server)

参考自： r shiny table not rendering html

Display checkboxGroupInput horizontally

checkboxGroupInput 函数本身复选框是垂直 排序 的，可以使用其 inline = TRUE 将复选框变成水平排布，但是其有个问题是有时会不对齐，这不太美观

网上搜下了，解决办法如下，添加一个CSS，相当于修改shiny默认的 checkbox 的inline样式

tags$head(
    tags$style(
        HTML(
            ".checkbox-inline { 
            margin-left: 0px;
            margin-right: 10px;
            }
            .checkbox-inline+.checkbox-inline {
            margin-left: 0px;
            margin-right: 10px;
            }
            "
        )
    ) 
)

可以从这里 https://github.com/rstudio/shiny/blob/master/inst/www/shared/bootstrap/css/bootstrap.css 看到，其属于bootstrap的样式，shiny默认于bootstrap的CSS是这样的：

.checkbox-inline {
  position: relative;
  display: inline-block;
  padding-left: 20px;
  margin-bottom: 0;
  font-weight: normal;
  vertical-align: middle;
  cursor: pointer;
}

.checkbox-inline + .checkbox-inline {
  margin-top: 0;
  margin-left: 10px;
}

总是shiny想要学的好，HTML/CSS/JS还是必不可少。。要学的还是有好多诶

本文出自于 http://www.bioinfo-scrounger.com 转载请注明出处