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

时间：2017-04-03 10:49:50

标签： r shiny reactive-programming reactive

我有两个单独的代码（代码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)

2 个答案:

答案 0 :(得分：1)

我做了一些小改动，但这意味着一个重大的架构变化。我添加了一个＆＃34;根表-A＆＃34;，并在应用更改之前随时重新初始化表-A。否则，操作通常没有任何意义，并且对空数据进行操作。

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

  • 添加了一个我们永远不会改变的附加数据框（rootdfaa）的定义。
  • 将rootdfaa添加到ui输出面板，因为我发现它有助于查看它（因为它永远不会改变它不是非常必要的）。我的屏幕非常大，所以对我来说没问题：）
  • 每次我们＆＃34;应用更改时，都会在observeEvent添加一行重新初始化的rv$dfA＆＃34;
  • 在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)

这就是看起来的样子：

enter image description here

答案 1 :(得分：0)

您似乎使用第一次更新时不存在的变量对数据表进行子设置，尝试使用%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)]     
  })
相关问题
最新问题