函数中的依赖关系。两个函数单独工作，但在代码中组合时在 Shiny 中显示错误答案

【问题标题】：Dependencies in functions. Two functions working individually but when combined in code are showing error in Shiny函数中的依赖关系。两个函数单独工作，但在代码中组合时在 Shiny 中显示错误
【发布时间】：2017-08-28 04:53:09
【问题描述】：

我有 2 个单独工作的代码（代码 A 和代码 B）。当我使用这些代码创建单个应用程序时，当两个输入都更新时它会显示错误。不知道错误在哪里？

代码 A

library(shiny)
dfaa <- data.frame(A = c( 1L, 4L, 0L, 1L), 
                   B = c("3","*","*","2"), 
                   C = c("4","5","2","*"), 
                   D = c("*","9","*","4"),stringsAsFactors = F) 
dfbb <- data.frame(variable = c("A","B","C","D"), 
                   Value    = c( 2L, 1L, 9L, 0L),stringsAsFactors = F)

dfbb["Drop_Variable"] <- "No"                 

ui <-  fluidPage(titlePanel("Sample"),
                 sidebarLayout(
                   sidebarPanel(
                     selectInput("select2", label = h3("Select any other Variable to drop"), 
                                 choices = unique(dfbb$variable), 
                                 selected = unique(dfbb$variable)[1]),
                     selectInput("select3", label = h3("Yes/No"), 
                                 choices = list("Yes", "No"),
                                 selected = "No"),         
                     actionButton("applyChanges", "Apply Changes specified in B to A")),
                   mainPanel(
                     h3("Table A"),  dataTableOutput(outputId="tableA"),
                     h3("Table B"),  dataTableOutput(outputId="tableB")
                   )))

server <- function(input, output) {
  rv <- reactiveValues(dfA=dfaa,dfB=dfbb)
  observe({
    # update dfB immediately when the variable or value in the ui changes

    rv$dfB$Drop_Variable[rv$dfB$variable==input$select2] <- input$select3
  })

  observeEvent(input$applyChanges,{
    drop <- as.character(rv$dfB$variable[rv$dfB$Drop_Variable == "Yes"])
    rv$dfA <- rv$dfA[,!(names(rv$dfA) %in% drop)]     
  })
  output$tableB <- renderDataTable({ rv$dfB })
  output$tableA <- renderDataTable({ rv$dfA })
}
       shinyApp(ui=ui,server=server)

代码 B

library(shiny)
dfaa <- data.frame(A = c( 1L, 4L, 0L, 1L), 
                   B = c("3","*","*","2"), 
                   C = c("4","5","2","*"), 
                   D = c("*","9","*","4"),stringsAsFactors = F) 
dfbb <- data.frame(variable = c("A","B","C","D"), 
                   Value    = c( 2L, 1L, 9L, 0L),stringsAsFactors = F)

dfbb["Drop_Variable"] <- "No"                 

ui <-  fluidPage(titlePanel("Sample"),
                 sidebarLayout(
                   sidebarPanel(
                     selectInput("select", label = h3("Select Variable"), 
                                 choices = unique(dfbb$variable), 
                                 selected = unique(dfbb$variable)[1]),
                     numericInput("num", label = h3("Replace * in A with"), 
                                  value = unique(dfbb$Value)[1]),
                     actionButton("applyChanges", "Apply Changes specified in B to A")),
                   mainPanel(
                     h3("Table A"),  dataTableOutput(outputId="tableA"),
                     h3("Table B"),  dataTableOutput(outputId="tableB")
                   )))

server <- function(input, output) {
  rv <- reactiveValues(dfA=dfaa,dfB=dfbb)
  observe({
    # update dfB immediately when the variable or value in the ui changes
    rv$dfB$Value[rv$dfB$variable==input$select] <- input$num

  })

  observeEvent(input$applyChanges,{
    # Here we apply the changes that were specified
    dfAcol <-as.character(rv$dfB$variable)
    rv$dfA[dfAcol] <- 
      Map(function(x, y) replace(x, x=="*", y), rv$dfA[dfAcol], rv$dfB$Value)

  })
  output$tableB <- renderDataTable({ rv$dfB })
  output$tableA <- renderDataTable({ rv$dfA })
}
shinyApp(ui=ui,server=server)

组合代码 A 和 B

library(shiny)

dfaa <- data.frame(A = c( 1L, 4L, 0L, 1L), 
                   B = c("3","*","*","2"), 
                   C = c("4","5","2","*"), 
                   D = c("*","9","*","4"),stringsAsFactors = F) 

dfbb <- data.frame(variable = c("A","B","C","D"), 
                   Value    = c( 2L, 1L, 9L, 0L),stringsAsFactors = F)

dfbb["Drop_Variable"] <- "No"                 

ui <-  fluidPage(titlePanel("Sample"),
                 sidebarLayout(
                   sidebarPanel(
                     selectInput("select", label = h3("Select Variable"), 
                                 choices = unique(dfbb$variable), 
                                 selected = unique(dfbb$variable)[1]),
                     numericInput("num", label = h3("Replace * in A with"), 
                                  value = unique(dfbb$Value)[1]),
                     selectInput("select2", label = h3("Select any other Variable to drop"), 
                                 choices = unique(dfbb$variable), 
                                 selected = unique(dfbb$variable)[1]),
                     selectInput("select3", label = h3("Yes/No"), 
                                 choices = list("Yes", "No"),
                                 selected = "No"),         
                     actionButton("applyChanges", "Apply Changes specified in B to A")),
                   mainPanel(
                     h3("Table A"),  dataTableOutput(outputId="tableA"),
                     h3("Table B"),  dataTableOutput(outputId="tableB")
                   )))

server <- function(input, output) {
  rv <- reactiveValues(dfA=dfaa,dfB=dfbb)
  observe({
    # update dfB immediately when the variable or value in the ui changes
    rv$dfB$Value[rv$dfB$variable==input$select] <- input$num
    rv$dfB$Drop_Variable[rv$dfB$variable==input$select2] <- input$select3
  })

  observeEvent(input$applyChanges,{
    # Here we apply the changes that were specified
    dfAcol <-as.character(rv$dfB$variable)
    rv$dfA[dfAcol] <- 
      Map(function(x, y) replace(x, x=="*", y), rv$dfA[dfAcol], rv$dfB$Value)
    drop <- as.character(rv$dfB$variable[rv$dfB$Drop_Variable == "Yes"])
    rv$dfA <- rv$dfA[,!(names(rv$dfA) %in% drop)]     
  })
  output$tableB <- renderDataTable({ rv$dfB })
  output$tableA <- renderDataTable({ rv$dfA })
}
shinyApp(ui=ui,server=server)

【问题讨论】：

是的，那是行不通的——也许只有一次。您可能需要处理三个表，一个永远不会更改的根表，并始终将表 B 中指定的更改应用于该根表以获取表 A。
此外，base R 在空条件下也不能很好地工作。这就是为什么人们倾向于使用像 dplyr 和 data.table 这样对程序员更友好的库。
你能告诉我你所说的空条件是什么意思吗？仍在尝试学习 R 和 Shiny :D
处理结果，例如没有 data.frame 列被留下，或者只剩下一列。
注意这篇文章。如果您只留下一列不被删除，您的程序将失败。 stackoverflow.com/questions/10737452/…。您需要像我刚才那样在rv$dfA 的最终计算中添加,drop=TRUE。

标签： r shiny reactive-programming reactive

【解决方案1】：

您似乎在使用第一次更新时不存在的变量对数据表进行子设置，请尝试使用 %in% 进行子设置。 mappy 之后也有小错误，但你可以解决它...

试试这个：

 observeEvent(input$applyChanges,{
    print("two")
    # Here we apply the changes that were specified
    dfAcol <-as.character(rv$dfB$variable)

    rv$dfA[dfAcol] <- 
      Map(function(x, y) replace(x, x=="*", y), rv$dfA[rv$dfA %in% dfAcol,], rv$dfB$Value)
    drop <- as.character(rv$dfB$variable[rv$dfB$Drop_Variable == "Yes"])
    rv$dfA <- rv$dfA[,!(names(rv$dfA) %in% drop)]     
  })

【讨论】：

这里还有更多的问题。请参阅我的评论。
是的，我明白了，重写代码更容易，因为它太乱了
谢谢@Pork Chop。但这并不能消除错误。我是 R 和闪亮的新手，这是我的第一个代码。将尝试阅读更多内容以编写更好的代码！

【解决方案2】：

我做了几个小改动，但这意味着架构上的大改动。我添加了一个“根表-A”，并在您应用更改之前用它重新初始化表-A。否则，这些操作通常没有任何意义，而是对空数据进行操作。

我所做的唯一更改（我认为）是：

添加了我们永远不会更改的附加数据框 (rootdfaa) 的定义。
将rootdfaa 添加到ui 输出面板，因为我发现它有助于查看它（因为它永远不会改变它并不是真正必要的）。我的屏幕也很大，所以对我来说没问题:)
在observeEvent 中添加一行以在我们每次“应用更改”时重新初始化rv$dfA
在 df$A 的最终计算中添加了 dror=FALSE 语句，以防止 R 将单列结果转换为向量而不是数据帧。

我确实认为这是解决此问题的唯一方法 - 试图保护所有这些表达式，以便它们可以迭代地处理可能丢失的数据将是一场噩梦。

代码如下：

library(shiny)

rootdfaa <- data.frame(A = c( 1L, 4L, 0L, 1L), 
                       B = c("3","*","*","2"), 
                       C = c("4","5","2","*"), 
                       D = c("*","9","*","4"),stringsAsFactors = F) 

dfaa <- rootdfaa

dfbb <- data.frame(variable = c("A","B","C","D"), 
                   Value    = c( 2L, 1L, 9L, 0L),stringsAsFactors = F)

dfbb["Drop_Variable"] <- "No"                 

ui <-  fluidPage(titlePanel("Sample"),
                 sidebarLayout(
                   sidebarPanel(
                     selectInput("select", label = h3("Select Variable"), 
                                 choices = unique(dfbb$variable), 
                                 selected = unique(dfbb$variable)[1]),
                     numericInput("num", label = h3("Replace * in Tab-A with"), 
                                  value = unique(dfbb$Value)[1]),
                     selectInput("select2", label = h3("Select any other Variable to drop"), 
                                 choices = unique(dfbb$variable), 
                                 selected = unique(dfbb$variable)[1]),
                     selectInput("select3", label = h3("Yes/No"), 
                                 choices = list("Yes", "No"),
                                 selected = "No"),         
                     actionButton("applyChanges", "Apply changes in Tab-B to Tab-A")),
                   mainPanel(
                     h3("Root Tab-A"),  dataTableOutput(outputId="roottableA"),
                     h3("Tab-A"),  dataTableOutput(outputId="tableA"),
                     h3("Tab-B"),  dataTableOutput(outputId="tableB")
                   )))

server <- function(input, output) {
  rv <- reactiveValues(dfA=dfaa,dfB=dfbb)
  observe({
    # update dfB immediately when the variable or value in the ui changes
    rv$dfB$Value[rv$dfB$variable==input$select ] <- input$num
    rowstochange <- rv$dfB$variable==input$select2
    rv$dfB$Drop_Variable[rv$dfB$variable==input$select2] <- input$select3
  })

  observeEvent(input$applyChanges,{
    rv$dfA <- rootdfaa # reinitialze dfA
    # Here we apply the changes that were specified
    dfAcol <-as.character(rv$dfB$variable)
    rv$dfA[dfAcol] <- 
      Map(function(x, y) replace(x, x=="*", y), rv$dfA[dfAcol], rv$dfB$Value)
    drop <- as.character(rv$dfB$variable[rv$dfB$Drop_Variable == "Yes"])
    rv$dfA <- rv$dfA[,!(names(rv$dfA) %in% drop),drop=FALSE]     
  })
  output$roottableA <- renderDataTable({ rootdfaa })
  output$tableB <- renderDataTable({ rv$dfB })
  output$tableA <- renderDataTable({ rv$dfA })
}
shinyApp(ui=ui,server=server)

这就是它的样子：

【讨论】：

谢谢迈克。您始终提供正确的解决方案！