Shiny模块单元测试结果异常，请求排查错误原因

问题背景 #

我开发了一个包含两个模块的Shiny应用：

• dataselect & table模块：根据第一个selectInput的选择更新第二个selectInput的选项，并展示筛选后的数据表
• plot模块：基于选中的数据行绘制时间线图表

尝试用testthat包对dataselect & table模块做单元测试，预期测试通过但实际失败，作为单元测试新手，希望排查问题原因。

初始测试代码 #

library(testthat)
library(shiny)
library(shinytest)
test_that("the right rows of data are selected ", {
  testServer(dataselect_server, {
    session$setInputs(Nametype = Name1, Name="Aix galericulata")
  df<-data.frame(Name1<-"Aix galericulata",
               Name2<-"Mandarin Duck",
               eventDate<-"2015-03-11",
               individualCount<-1
  )
expect_true(identical(finalDf(), df))
  })
})

初始测试错误结果 #

-- Warning (Line 2): the right rows of data are selected -----------------------
the condition has length > 1 and only the first element will be used
Backtrace:
  1. shiny::testServer(...)
 26. shiny:::finalDf()
 28. self$.updateValue()
 29. ctx$run(...)
 36. env$runWith(self, func)
 37. shiny:::contextFunc()
 40. shiny:::.func()
 42. `<reactive:finalDf>`(...)

-- Warning (Line 2): the right rows of data are selected -----------------------
the condition has length > 1 and only the first element will be used
Backtrace:
  1. shiny::testServer(...)
 26. shiny:::finalDf()
 28. self$.updateValue()
 29. ctx$run(...)
 36. env$runWith(self, func)
 37. shiny:::contextFunc()
 40. shiny:::.func()
 42. `<reactive:finalDf>`(...)

-- Warning (Line 2): the right rows of data are selected -----------------------
the condition has length > 1 and only the first element will be used
Backtrace:
  1. shiny::testServer(...)
 26. shiny:::finalDf()
 28. self$.updateValue()
 29. ctx$run(...)
 36. env$runWith(self, func)
 37. shiny:::contextFunc()
 40. shiny:::.func()
 42. `<reactive:finalDf>`(...)

-- Failure (Line 2): the right rows of data are selected -----------------------
identical(finalDf(), df) is not TRUE

`actual`:   FALSE
`expected`: TRUE 
Backtrace:
  1. shiny::testServer(...)
 22. testthat::expect_true(identical(finalDf(), df))


Error: Test failed

模块及主应用代码 #

Dataselect & table模块 #

# Dataselect & table module
dataselect_ui<- function(id) {
  ns<-NS(id)
  tagList(
    selectInput(ns("Nametype"),"Select a name type",
                choices=c("Name1","Name2","choose"),selected = "choose"),

    selectInput(ns("Name"),"Select a name",
                choices="",selected = "",selectize=TRUE),

    DT::DTOutput(ns("tab"))
  )
}
dataselect_server <- function(id) {
  moduleServer(id, function(input, output, session) {
    # Data preparation
    df<-data.frame(Name1<-c("Aix galericulata","Grus grus","    Alces alces"),
                   Name2<-c("Mandarin Duck","Common Crane" ,"Elk"),
                   eventDate<-c("2015-03-11","2015-03-10","2015-03-10"),
                   individualCount<-c(1, 10, 1)
    )
    colnames(df)<-c("Name1","Name2","eventDate","individualCount")

    # Putting columns Name1 and Nam2 of df in one column called nameType using melt()function
    # This format of data is needed for the choices argument of updateSelectizeInput()
    df2<-reshape2::melt(df,id=c("eventDate","individualCount"))
    colnames(df2)<-c("eventDate","individualCount","nameType","Name")

    observeEvent(
      input$Nametype,
      updateSelectizeInput(session, "Name", "Select a name",
                           choices = unique(df2$Name[df2$nameType==input$Nametype]),selected = ""))


    # finalDf() is the data used to plot the table and plot
    finalDf<-reactive({
      if(input$Name=="choose"){
        return(NULL)

      }
      if(input$Name==""){
        return(NULL)

      }
      if(input$Nametype=="choose"){
        return(NULL)

      }

      # if the first selectInput is set to Name1, from df select rows their Name1 column are
      # equal to the second selectInput value
      else if(input$Nametype=="Name1"){
        finalDf<-df[which(df$Name1==input$Name) ,]

      }
      # if the first selectInput is set to Name2, from df select rows their Name2 column are
      # equal to the second selectInput value
      else if(input$Nametype=="Name2"){
        finalDf<-df[which(df$Name2==input$Name) ,]

      }
      return(finalDf)
    })

    output$tab<-DT::renderDT({
      req(input$Name)
      datatable(finalDf(), filter = 'top',
                options = list(pageLength = 5, autoWidth = TRUE),
                rownames= FALSE)
    })

    return(
      list("finalDf" = finalDf, "input_Name" = reactive(input$Name))
    )
  })
}

Plot模块 #

# Plot module
plot_ui <- function(id) {
  ns<-NS(id)
  tagList(
    plotlyOutput(ns("plot"))
  )
}

plot_server <- function(id,input_Name ,finalDf) {
  moduleServer(id, function(input, output, session) {

    output$plot <- renderPlotly({
      req(input_Name())
      p<-ggplot(finalDf(),aes(x=eventDate,y=individualCount)) +geom_point(alpha=0.2, shape=21, color="black",fill="red",size=5)+
        labs( x = "Date Event",y= "Individual Count") +theme_bw()
      p<-ggplotly(p)
      p
    })
  })
}

主应用代码 #

source('modules/dataselect & table_module.R')
source('modules/plot_module.R')


library(shiny)
library(plotly)
library(reshape2)

# application
ui <- fluidPage(
               dataselect_ui("dataselect"),
               plot_ui("plot1")
    )


server <- function(session,input, output) {

  dataselect_outputs <- dataselect_server("dataselect")
  plot_server("plot1",input_Name = dataselect_outputs$input_Name
                            ,finalDf= dataselect_outputs$finalDf)

}

shinyApp(ui = ui, server = server)

修改后的测试代码及新错误 #

修改后的测试代码 #

test_that("the right rows of data are selected", {
  testServer(dataselect_server, {
    session$setInputs(Nametype = "Name1", Name="Aix galericulata")
  df<-data.frame(Name1="Aix galericulata",
               Name2="Mandarin Duck",
               eventDate="2015-03-11",
               individualCount=1
  )
  expect_identical(finalDf(), df)
  })
})

新错误结果 #

-- Error (Line 2): the right rows of data are selected -------------------------
Error in `module(childScope$input, childScope$output, childScope, ...)`: attempt to apply non-function
Backtrace:
  1. shiny::testServer(...)
 23. shiny::moduleServer(...)
 25. shiny::callModule(module, id, session = session)
 30. module(childScope$input, childScope$output, childScope, ...)

Error: Test failed

内容的提问来源于stack exchange，提问作者Maryam Momeni