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

Question

I have a shiny app that prompts users to enter a USGS NWIS Site Number, and then returns a map of nearby stations and a bar chart of historical stream flow around that site. I am having a hard time validating user input of the Site Number to textInput(). I need to prompt users to try again (and not accept the input) when users either don't enter a number and hit submit, enter an incorrect number (that doesn't exist in the NWIR database), or enter a number with leading or trailing spaces. Where should I put the call to 'validate' in this app?

##############################################################################
# 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%", height="500px"),
    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)
##############################################################################

Answer 1

It would be easier to use selectInput where you restrict the choices to valid sites. selectInput can be used as a text search where the dropdown list will be filtered based on user input text.

Below image shows what I mean. Note that it works even if you have multiple = FALSE in selectInput -

As to answer your question -

You need to create a vector of valid sites and use following in an upstream reative or downstream in any relevant render* -

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

UPDATE -

Based on your comment, here's one approach -

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