如何在 Shiny 应用程序中验证 textInput？

Posted 2023-04-18

【中文标题】如何在 Shiny 应用程序中验证 textInput？

【英文标题】：How do I Validate textInput in a Shiny app?

【发布时间】：2019-12-15 04:35:23

【问题描述】：

我有一个闪亮的应用程序，它会提示用户输入 USGS NWIS 站点编号，然后返回附近站点的地图和该站点周围历史流量的条形图。我很难将站点编号的用户输入验证为 textInput()。当用户不输入数字并点击提交、输入不正确的数字（在 NWIR 数据库中不存在）或输入带有前导的数字时，我需要提示用户重试（并且不接受输入）或尾随空格。我应该在这个应用程序的哪里调用“验证”？

##############################################################################
# Libraries
##############################################################################
rm(list=ls())
list.of.packages <- c("RColorBrewer",
                      "dataRetrieval",
                      "curl",
                      "repr",
                      "maps",
                      "dplyr",
                      "ggplot2",
                      "leaflet",
                      "leafem",
                      "raster",
                      "raster",
                      "shiny",
                      "htmlwidgets",
                      "devtools",
                      "shinycustomloader",
                      "shinydashboard",
                      "shinyjs",
                      "DT",
                      "spData",
                      "sf",
                      "shinythemes",
                      "plotly")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)
lapply(list.of.packages, require, character.only = TRUE)

##############################################################################
# UI Side
##############################################################################
ui <- fluidPage(
  shinyjs::useShinyjs(),
  #titlePanel("USGS Gages Annual Flow Peak Tool"),
  h1(id="big-heading", "USGS Gages Annual Flow Peak Tool"),
  tags$style(HTML("
      @import url('//fonts.googleapis.com/css?family=Lobster|Cabin:400,700');

      h1 
        font-family: 'Lobster', cursive;
        font-weight: 500;
        line-height: 1.1;
        color: #006F41;
      

    ")),

  # side panel
  sidebarPanel(


    textInput(inputId ="site_no", 
              label = "Site Number", 
              width = '400px',
              #value=01615000,
              placeholder = "Please enter the NWIS Site Number."),
    textInput(inputId ="years_of_records", 
              label = "Years of Records", 
              width = '400px',
              value = 30,
              placeholder = "How many years of Records would you like?"),
    textInput(inputId ="da_epsilon", 
              label = "Drainage Area Epsilon", 
              width = '400px',
              value = 0.25,
              placeholder = "What is the Drainage Area Epsilon?"),
    textInput(inputId ="bbox_delta", 
              label = "Bounding Box Delta - Degrees", 
              width = '400px',
              value = 1,
              placeholder = "What is the Bounding Box delta?"),

    actionButton(
      inputId = "submit_loc",
      label = "Submit"
    ),
    downloadButton('downloadData', 'Download Data'),
    h4(''),
    dataTableOutput('table01'),
    width = 3),

  # main panel
  mainPanel(
    leafletOutput('map01', width = "110%", ),
    br(),
    plotlyOutput('hist01', width = "110%")
      )
)

##############################################################################
# Server Side
##############################################################################
server <- function(input,output, session)
  shinyjs::hide("downloadData")
  observeEvent(input$submit_loc, 

    cat("START\n")

    validate(
      need(input$site_no, 'Enter a Site Number!')
    )

    SITE_NUM=input$site_no
    SITE_URL <- paste0("https://waterdata.usgs.gov/nwis/inventory/?site_no=",SITE_NUM,"&agency_cd=USGS")
    paraCode <- "00060"
    years_of_records <- as.numeric(input$years_of_records)
    da_epsilon <- as.numeric(input$da_epsilon)
    bbox_delta <- as.numeric(input$bbox_delta) # Degrees
    cat("Showing", SITE_NUM, "NWIS id",
        "\nUsing URL:", SITE_URL,
        "\nwith ", years_of_records, "years of records",
        "\n& Drainage Area of: ", da_epsilon,
        "\n& Bounding Box delta of: ", bbox_delta, "\n")
    # CODE TO MAKE DATA FRAME

    # Get site coordinates to build Bbox
    site_data <- whatNWISsites(siteNumber=SITE_NUM, parameterCd=paraCode)
    site_lat <- site_data$dec_lat_va
    site_long <- site_data$dec_long_va
    site_data$site_url <- SITE_URL

    # Get site drainage area
    site_summary <- readNWISsite(siteNumber=SITE_NUM)
    site_da <- site_summary$drain_area_va


    # need to use SIG FIGS --- Otherwise the curl command gets confused.
    bBox <- c(signif(site_long - bbox_delta,7),
              signif(site_lat - bbox_delta,7),
              signif(site_long + bbox_delta,7),
              signif(site_lat + bbox_delta,7))

    bbox_shiny <- c(bBox[1],bBox[3],bBox[2],bBox[4])

    # Get site metadata for the Bbox
    para_sites <- as.data.frame(whatNWISsites(bBox=bBox, parameterCd=paraCode))
    para_sites$gtype = paraCode #gtype: gage type (stage, flow, ...etc)

    # Filter the retrieved USGS gages based on the defined criteria
    sites_meta <- whatNWISdata(siteNumber=para_sites$site_no, parameterCd=paraCode)
    sites_meta_years <- sites_meta[(sites_meta['end_date'] - sites_meta['begin_date']) > (years_of_records * 365.0),]
    sites_summary <- readNWISsite(siteNumber=sites_meta_years$site_no)
    sites_selected <- sites_summary[((1-da_epsilon)* site_da) <= sites_summary['drain_area_va'] & sites_summary['drain_area_va'] <= ((1+da_epsilon)* site_da), ]
    # Separate surrounding sites
    site_surrounding <- sites_selected[sites_selected$site_no != SITE_NUM, ]

    # Append URL 
    for(i in 1:nrow(sites_selected))
      sites_selected_no <- as.character(sites_selected$site_no)
      sites_selected$site_url <- paste0("https://waterdata.usgs.gov/nwis/inventory/?site_no=",sites_selected_no,"&agency_cd=USGS")
    

    # Separate central site
    red_site <- sites_selected[sites_selected$site_no == paste(SITE_NUM),]

    # GET PEAK STREAMFLOW DATA
    peak_ts <- readNWISpeak(input$site_no)
    cols = c("site_no","peak_dt","peak_va","gage_ht")
    peak_ts <- peak_ts[,cols]
    names(peak_ts) <- c("Site Number", "Peak Streamflow: Date", "Peak streamflow (cfs)", "Gage Height (feet)")
    output$table01 <- renderDataTable(
    DT::datatable(peak_ts, 
                  selection = "single",
                  extensions = 'Responsive',
                  rownames=FALSE,
                  options=list(stateSave = FALSE, 
                               autoWidth = TRUE,
                               lengthMenu = c(10, 10)))
    )

    shinyjs::show("downloadData")

    data <- sites_selected
    # Downloadable csv of selected dataset ----
    output$downloadData <- downloadHandler(
      filename = function() 
        paste0(input$site_no, "_data.csv")
      ,
      content = function(file) 
        write.csv(data, file, row.names = FALSE)
      
    )


    output$map01 <- renderLeaflet(

      leaflet(sites_selected) %>% 
        clearShapes() %>%
        addTiles() %>% 
        leafem::addMouseCoordinates() %>% 
        leafem::addHomeButton(extent(us_states),"Zoom to Home")%>%
        fitBounds(~min(dec_long_va), ~min(dec_lat_va), ~max(dec_long_va), ~max(dec_lat_va)) %>% 
        addCircleMarkers(data = red_site,
                         lng= ~dec_long_va,
                         lat = ~dec_lat_va,
                         color='red',
                         popup= paste0( red_site$station_nm,
                                        "<br>", "USGS site: ", red_site$site_no,
                                        "<br>", "<a href='", red_site$site_url,
                                        "' target='_blank'>", "USGS URL</a>"),
                         label = red_site$station_nm) %>% 
        addCircleMarkers(data = site_surrounding,
                         lng= ~dec_long_va,
                         lat = ~dec_lat_va,
                         color='blue',
                         popup= paste0( site_surrounding$station_nm,
                                        "<br>", "USGS site: ", site_surrounding$site_no,
                                        "<br>", "<a href='", site_surrounding$site_url,
                                        "' target='_blank'>", "USGS URL</a>"),
                         label = site_surrounding$station_nm)
    )

    peak_named <- cbind(red_site[,"station_nm"], peak_ts)
    names(peak_named[1]) <- c("Station Name")
    chart_title=paste(peak_named[1,1], peak_named[1,2],': Peak streamflow (cfs)')
    qSub <-  reactive(
      peak_named
    )

    # histogram
    output$hist01 <- renderPlotly(

      ggplot(data=qSub()) +
        geom_bar(aes(x=peak_ts[,"Peak Streamflow: Date"],y=peak_ts[,"Peak streamflow (cfs)"]),
                 stat="identity", 
                 width=125) +
        ylab('Peak streamflow (cfs)') +
        xlab('Date') +
        # xlim(min(qDat$drain_area_va), max(qDat$drain_area_va))+
        ggtitle(chart_title)+
        theme(text = element_text(family = "Arial", color = "grey20", size=12, face="bold"))

    )
  )



  output$map01 <- renderLeaflet(
    leaflet() %>% setView(-93.65, 42.0285, zoom = 4) %>% addTiles()
  )


##############################################################################
shinyApp(ui = ui, server = server)
##############################################################################

【问题讨论】：

为什么不使用selectInput，您可以将选择限制为仅有效站点？

很好的建议 - 不幸的是，有成千上万的有效网站。用户会对编号系统有一定的了解，主要是因为错误而输入了错误的值

但用户实际上可以像textInput 一样使用selectInput，并且下拉选项将根据输入的文本进行过滤。如果键入的文本与任何内容都不匹配，则下拉选项将不会显示任何内容。基本上用户无法输入不良数据。

有趣...我会试一试。谢谢！

【参考方案1】：

使用selectInput 将选择限制为有效站点会更容易。 selectInput 可用作文本搜索，其中将根据用户输入的文本过滤下拉列表。

下图显示了我的意思。请注意，即使您在 selectInput 中有 multiple = FALSE，它也可以工作 -

至于回答你的问题-

您需要创建一个有效sites 的向量，并在上游reative 或下游在任何相关render* 中使用关注-

validate(
  need(input$site_no %in% sites, 'Site does not exist!')
)

更新 -

根据您的评论，这是一种方法 -

test <- reactive(
  some inexpensive function to check if input$site_no exists in data source
  if(site exists) return("Good")
  return("Bad")
)

validate(
  need(test() == "Good", "Site does not exist!")
)

【讨论】：

再次感谢 - 虽然我认为这种方法不适用于我的用例（有太多 NWIS 站点编号（成千上万）加载到闪亮的应用程序中以保存为有效的网站），我确实了解了 selectInput，所以很感激。我将转向 tryCatch 错误处理解决方案。

@JasonMatney 看看我的更新是否有帮助。这避免了一次性提取 100 多个站点，但现在您必须处理一个函数，该函数将在每次站点更改时检查数据源，如果此函数很快，应该没问题。希望这会有所帮助。