Shiny学习笔记

整理shiny学习的心得
shiny
学习笔记
Author

胡林辉

Published

December 23, 2024

1 环境建设

1.1 复制文件至shinyserver

cp -r /www/wwwroot/www.mmphcrc.com/pdf/jupyter/HuLinhuiPy/Shiny学习笔记/download-word-file /srv/shiny-server/app/r/download-word-file

1.2 查看报错信息

查看最新生成文件的最后50行

latest_file=$(ls -t /var/log/shiny-server/ | head -1)
tail -n 50 /var/log/shiny-server/$latest_file

1.3 通过终端安装包

Rscript install_packages.R package1,package2,package3
Rscript install_packages.R rlang
  • install_packages.R的内容
# 安装所需的R包（不检查是否已安装）
install_packages <- function(packages) {
  for (package in packages) {
    install.packages(package, dependencies = TRUE, lib="/usr/local/lib/R/site-library")
  }
}

# 从命令行参数获取要安装的包列表
args <- commandArgs(trailingOnly = TRUE)
packages_to_install <- strsplit(args, ",")[[1]]

# 安装包
install_packages(packages_to_install)

# 加载已安装的包
for (package in packages_to_install) {
  library(package, character.only = TRUE)
}

2 示例

2.1 officer生成文档并下载

演示地址

  • 代码
library(shiny)
library(officer)
library(ggplot2)

ui <- fluidPage(

    # Application title
    titlePanel("Old Faithful Geyser Data"),
    sidebarLayout(
        sidebarPanel(
            sliderInput("bins", "Number of bins:", min = 1, max = 50, value = 30),
            downloadButton("downloadReport", "Download report")
        ),
        mainPanel(
           plotOutput("distPlot")
        )
    )
)

server <- function(input, output) {

    my_plot <- reactive({
        ggplot(faithful, aes(eruptions)) + geom_histogram(bins = input$bins)
    })
    output$distPlot <- renderPlot({
        my_plot()
    })
    output$downloadReport <- downloadHandler(
        filename = function() {
            paste("report-", Sys.Date(), ".docx", sep="")
        },
        content = function(file) {
            doc <- read_docx()
            doc <- body_add_gg(doc, value = my_plot())
            print(doc, target = file)
        }
    )
}

shinyApp(ui = ui, server = server)

2.2 quickquery

演示地址

2.2.1 index.Rmd文件内容

---
title: "快捷查询"
description: "交互性文档"
output:
  html_document:
    css: custom.css
    includes:
      in_header: icon.html   # 将网页内容添加至html头部
    link-external-icon: true
    link-external-newwindow: true
runtime: shiny
image: 'https://ts1.cn.mm.bing.net/th/id/R-C.cddc513b06b31b85a22283bc2f975fbf?rik=JUJ%2bvImS%2fC9YbA&pid=ImgRaw&r=0'
---



<!-- # 一般信息
> Shiny官网 <https://shiny.posit.co/r/getstarted/shiny-basics/lesson1/index.html>  
> 日志查看路径： `/var/log/shiny-server` -->

```{r}
#| echo: false
#| warning: false
#| message: false

library(stringr)
library(magrittr)
library(DT)
library(DBI)
library(RMySQL)

# Global variables can go here
con <- dbConnect(
      MySQL(),
      user = "hulinhui2",
      password = "kJxa2TGzHTJ8C83M",
      host = "www.mmphcrc.com",
      dbname = "hulinhui2"
)

# Define the UI

ui <- fluidPage(
  includeCSS("custom.css"),
  tags$head(
    tags$style(
      HTML(
        "
        #notification {
          display: none;
          position: fixed;
          top: 50%;
          left: 50%;
          transform: translate(-50%, -50%);
          z-index: 1000;
          padding: 10px;
          background-color: #f8d7da;
          color: #721c24;
          border: 1px solid #f5c6cb;
          border-radius: 5px;
          text-align: center;
        }
        "
      )
    ),
    tags$script(
      HTML(
        "
        Shiny.addCustomMessageHandler('showNotification', function(message) {
          $('#notification').text(message);
          $('#notification').fadeIn().delay(3000).fadeOut();
        });
        "
      )
    )
  ),
  fluidRow(
    column(width = 12,
      passwordInput('authcode', '输入验证码', '')
    ),
    column(width = 12,
      textInput('keyword', '输入查询关键词', '', placeholder = '输入关键词进行查询')
    ),
  ),
  fluidRow(
    column(width = 12,
      dataTableOutput("table")
    ),
    tags$div(id = "notification", "这是一个通知")
  ),
  fluidRow(
    column(width = 12,
      textInput('rowid', 'id', '', placeholder = '输入id进行更新')

    ),
    column(width = 12,
      textInput('title', '标题', '')
    ),
    column(width = 12,
      textAreaInput("content", "内容", "", rows = 10, width = "500px"),
    ),
    column(width = 12,
      textInput("tags", "标签", ""),
    ),
    column(width = 12,
       actionButton("updateRow", "更新"),
       actionButton("addRow", "新增")
    ),
   
  )
)

server <- function(input, output, session) {
  true_authcode <- format(Sys.Date(), "%Y%m%d")
  # 监听关键词输入事件
  observeEvent(input$keyword, {
    output$table <- renderDataTable({
      authcode <- input$authcode  # 获取验证码
      keyword <- input$keyword
      if (is.null(keyword) || trimws(keyword) == "") {
        return(NULL)  # 如果关键词为空，返回空表格
      }
      
      if (authcode != true_authcode) {  # 假设验证码不正确
        session$sendCustomMessage(type = "showNotification", message = "验证码不正确") 
        return(NULL)  # 返回空表格
      }
      
      dbSendQuery(con, "SET NAMES utf8")  # 否则不能查询中文，或者查询英文时返回的中文为乱码
      # 在数据库中执行查询
      # keyword <- enc2utf8(keyword)
      query <- paste("SELECT * FROM `quickquerydb` WHERE `content` LIKE '%", keyword, "%'", sep = "")
      result <- dbGetQuery(con, query)  # 返回查询结果

      # 高亮显示关键词
      highlight_keyword_pattern <- sprintf("<span style='background-color: yellow;'>%s</span>", keyword)

      # 大小写敏感
      # result$content <- str_replace_all(result$content, keyword, highlight_keyword_pattern)   

      # 大小写不敏感
      result$content <- str_replace_all(result$content, regex(paste0('(?i)', keyword)), paste0("<span style='background-color: yellow;'>", "\\0", "</span>"))

      result$content <- str_replace_all(result$content, "\n", "<br>")  
      result
    }, 
    escape = FALSE)
  })

  
  # 监听id输入事件
  observeEvent(input$rowid, {
    authcode <- input$authcode  # 获取验证码

    rowid <- input$rowid
    if (rowid != "") {

      if (authcode != true_authcode) {  # 假设验证码不正确
        session$sendCustomMessage(type = "showNotification", message = "验证码不正确") 
        return(NULL)  # 返回空表格
      }

      dbSendQuery(con, "SET NAMES utf8")  # 否则不能查询中文，或者查询英文时返回的中文为乱码
      # 在数据库中执行查询
      query <- paste("SELECT * FROM `quickquerydb` WHERE `id` = ", rowid, sep = "")
      result <- dbGetQuery(con, query)  # 返回查询结果
      title = result$title
      content = result$content
      tags = result$tags
    } else {
      title = ''
      content = ''
      tags = ''
    }

    updateTextInput(session, "title", value = title)
    updateTextInput(session, "content", value = content)
    updateTextInput(session, "tags", value = tags)

    
  })

  
  # 监听更新按钮被点击
  observeEvent(input$updateRow, {
    authcode <- input$authcode  # 获取验证码

    rowid <- input$rowid
    title <- input$title
    content <- input$content
    tags = input$tags

    if (rowid != "") {
      if (authcode != true_authcode) {  # 验证码不正确
        session$sendCustomMessage(type = "showNotification", message = "验证码不正确") 
        updateTextInput(session, "title", value = '')
        updateTextInput(session, "content", value = '')
        updateTextInput(session, "tags", value = '')
        return(NULL)  # 返回空内容
      }

      if (title == "" | content == "") { 
        session$sendCustomMessage(type = "showNotification", message = "标题和内容不能为空") 
        return(NULL)  # 返回空内容
      }
      
      dbSendQuery(con, "SET NAMES utf8")  
      
      # 构建UPDATE语句
      query <- paste("UPDATE `quickquerydb` SET title = '", title, 
                    "', content = '", content, 
                    "', tags = '", tags, 
                    "' WHERE id = ", rowid, sep="")
      
      # 在数据库中执行更新
      result <- dbSendQuery(con, query)
      session$sendCustomMessage(type = "showNotification", message = "完成更新") 
    } else {
      session$sendCustomMessage(type = "showNotification", message = "id为空，更新失败！")
    }

    
  })


  # 监听新增按钮被点击
  observeEvent(input$addRow, {
    authcode <- input$authcode  # 获取验证码

    title <- input$title
    content <- input$content
    tags <- input$tags

    if (title == "" | content == "") { 
        session$sendCustomMessage(type = "showNotification", message = "标题和内容不能为空") 
        return(NULL)  # 返回空内容
    } else {
      if (authcode != true_authcode) {  # 验证码不正确
        session$sendCustomMessage(type = "showNotification", message = "验证码不正确") 
        return(NULL)  # 返回空内容
      }
      
      dbSendQuery(con, "SET NAMES utf8")
      # 构建INSERT语句
      query <- paste("INSERT INTO `quickquerydb` (title, content, tags) VALUES ('", title, "', '", content, "', '", tags, "')", sep="")

      # 执行INSERT语句
      result <- dbSendQuery(con, query)
      session$sendCustomMessage(type = "showNotification", message = "完成插入") 

    }
 
  })
 
  onStop(function() {
    dbDisconnect(con)  # 关闭数据库连接
  })
}




options <- list(height = 800)


# Return a Shiny app object
shinyApp(ui = ui, server = server, options = options)
```\

2.2.2 custom.css的内容

/*自定义滚动条*/
::-webkit-scrollbar {
    /*滚动条整体样式*/
    width : 6px;  /*对应竖滚动条的宽度*/
    height : 8px;  /*对应横滚动条的高度*/
  }
  ::-webkit-scrollbar-thumb {
    /*滚动条里面小方块*/
    border-radius: 6px; 
    background-color: #9e9e9e;
  }
  ::-webkit-scrollbar-track {
    /*滚动条里面轨道*/
    background: #ffffff;
    /* border-radius: 6px; */
  }

2.2.3 icon.html的内容

<link rel="icon" href="favicon.ico" type="image/x-icon">