Shiny 验证不显示错误信息

Question

My R Shiny app has two textAreaInput() , one for x values and the other for y values. When a button is pressed a simple linear regression model is fit and the results is printed on the mainPanel. This works perfectly fine.

I am trying to validate the textAreaInput() so I can show an error message

--- when the length(x) != length(y)

--- when the x or y boxes are empty

--- when the x or y boxes contains not enough values (less than two data pairs)

--- when the x or y boxes contains NA or invalid characters

Here a minimal reprex code. I see the Shiny validations for the above requirements are not properly displaying on the mainPanel when the conditions met. EDITED CODE BELOW: Made the reprex code minimal and removed all reactive() as advised

library(shiny)
library(shinythemes)
library(shinyjs)
library(shinyvalidate)

ui <- fluidPage(theme = bs_theme(version = 4, bootswatch = "minty"),
           
  navbarPage(title = div(span("Simple Linear Regression", style = "color:#000000; font-weight:bold; font-size:18pt")),

                tabPanel(title = "",
                  sidebarLayout(
                    sidebarPanel(
                      shinyjs::useShinyjs(),
                      id = "sideBar", 

                      textAreaInput("x", label = strong("x (Independent Variable)"), value = "87, 92, 100, 103, 107, 110, 112, 127", placeholder = "Enter values separated by a comma with decimals as points", rows = 3),
                      textAreaInput("y", label = strong("y (Dependent Variable)"), value = "39, 47, 60, 50, 60, 65, 115, 118", placeholder = "Enter values separated by a comma with decimals as points", rows = 3),

                      actionButton(inputId = "goRegression", label = "Calculate",
                                   style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
                      actionButton("resetAllRC", label = "Reset Values",
                                   style="color: #fff; background-color: #337ab7; border-color: #2e6da4"), #, onclick = "history.go(0)"
                    ),
                    
                    mainPanel(
                      div(id = "RegCorMP",
                            textOutput("xArray"),
                            
                            textOutput("yArray"),
                          
                            textOutput("arrayLengths"),

                            verbatimTextOutput("linearRegression"),
                      ) # RegCorMP
                  ) # mainPanel
               ) # sidebarLayout
          )
      )
  )
  
server <- function(input, output) {
    
    # Data validation
    iv <- InputValidator$new()

    iv$add_rule("x", sv_required())
    iv$add_rule("y", sv_required())

    iv$enable()
    
    # String List to Numeric List
    createNumLst <- function(text) {
      text <- gsub("","", text)
      split <- strsplit(text, ",", fixed = FALSE)[[1]]
      as.numeric(split)
    }

    observeEvent(input$goRegression, {
      
      datx <- createNumLst(input$x)
      daty <- createNumLst(input$y)

      if(length(datx)<2){
        output$xArray <- renderPrint({
          "Not enough x values"
        })
      }
      
      else if(length(daty)<2){
        output$yArray <- renderPrint({
          "Not enough y values"
        })
      }
      
      if (length(datx) != length(daty)) {
        print(length(datx))
        print(length(daty))
        
        output$arrayLengths <- renderPrint({
          "Length of x and length of y must be the same"
        })
      }
     
      else if (length(datx) == length(daty)) {
          output$linearRegression <- renderPrint({ 
            summary(lm(daty ~ datx))
          })
      }
    })

    observeEvent(input$goRegression, {
      show(id = "RegCorMP")
    })
    
    observeEvent(input$resetAllRC, {
      hide(id = "RegCorMP")
      shinyjs::reset("RegCorMP")
    })
}
  
shinyApp(ui = ui, server = server)```

Answer 1

I think this comes close to what you want. Note how every reactive is defined in the body of the server function, not within the body of another reactive . This is critical . And also removes the need for your observeEvent entirely.

I have removed more material ( div s, theme s, etc) that is not relevant to your question. I'm not sure shinyjs is necessary either. Also, I'm not sure what you're trying to do with your reset button (it appears to do nothing at the moment), so I've left it in.

I've added validation to ensure there are no NAs in either input, but have left it to you to implement a check for equality of length.

As an aside, there's no need to comma separate your inputs: spaces would suffice... ;=)

library(shiny)
library(shinyjs)
library(shinyvalidate)

ui <- fluidPage(
        useShinyjs(),
        navbarPage(
          title = "Simple Linear Regression",
          tabPanel(
            title = "",
            sidebarLayout(
            sidebarPanel(
              id = "sideBar", 
              textAreaInput(
                "x", 
                label = strong("x (Independent Variable)"), 
                value = "87, 92, 100, 103, 107, 110, 112, 127", 
                placeholder = "Enter values separated by a comma with decimals as points", 
                rows = 3
              ),
              textAreaInput(
                "y", 
                label = strong("y (Dependent Variable)"), 
                value = "39, 47, 60, 50, 60, 65, 115, 118", 
                placeholder = "Enter values separated by a comma with decimals as points", 
                rows = 3
              ),
              actionButton(
                inputId = "goRegression", 
                label = "Calculate",
              ),
              actionButton(
                "resetAllRC", 
                label = "Reset Values",
              )
            ),
            mainPanel(
              div(
                textOutput("xArray"),
                textOutput("yArray"),
                textOutput("arrayLengths"),
                verbatimTextOutput("linearRegression"),
              ) # RegCorMP
            ) # mainPanel
          ) # sidebarLayout
        )
      )
    )

server <- function(input, output) {
  # Data validation
  iv <- InputValidator$new()
  iv$add_rule("x", sv_required())
  iv$add_rule("x", ~ if (any(is.na(as.numeric(strsplit(., ",", fixed = FALSE)[[1]])))) "NAs are not allowed")
  iv$add_rule("y", sv_required())
  iv$add_rule("y", ~ if (any(is.na(as.numeric(strsplit(., ",", fixed = FALSE)[[1]])))) "NAs are not allowed")
  iv$enable()
  # See https://rstudio.github.io/shinyvalidate/articles/advanced.html for clues on
  # how to implement length(x) == length(y) validation

  createNumLst <- function(text) {
    text <- gsub("","", text)
    split <- strsplit(text, ",", fixed = FALSE)[[1]]
    d <- as.numeric(split)
    if (length(d) < 2) "Not enough values"
    d
  }
  
  xData <- reactive({
    createNumLst(input$x)
  })
  
  yData <- reactive({
    createNumLst(input$y)
  })
  
  output$xArray <- renderPrint({ xData() })

    output$yArray <- renderPrint({ yData() })
  
  output$arrayLengths <- renderPrint({
    if (length(xData()) != length(yData())) "Length of x and length of y must be the same"
  })
  
  # Use isolate to ensure that results are updated only when action button is clicked, not 
  # every time the input data changes
  output$linearRegression <- renderPrint({
    input$goRegression
    isolate({
      summary(lm(yData() ~ xData()))
    })
  })
  
  observeEvent(input$goRegression, {
    show(id = "RegCorMP")
  })
  
  # Not sure what you are trying to do here
  observeEvent(input$resetAllRC, {
    hide(id = "RegCorMP")
    shinyjs::reset("RegCorMP")
  })
}

shinyApp(ui = ui, server = server)