Dependencies in functions. Two functions working i

问题:

I have 2 separate codes which work individually (Code A and Code B). When I club these codes to create single app, it shows error when both inputs are updated. Not sure where the error is?

Code 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)

Code 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)

Combined Code A and 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)

回答1:

I made a couple of small changes, that however imply a big architectural change. I added a "root Table-A", and reinitialize table-A with that before anytime you apply changes. Otherwise the operations simply often do not make any sense and are operating on empty data.

The only changes I made (I think) were:

• added a definition of an additional data frame (rootdfaa) that we will never change.
• added rootdfaa to the ui output panel because I find it helps to see it (since it never changes it isn't really necessary). I have a very big screen too so it is no issue for me :)
• added a line to observeEvent to reinitialized rv$dfA every time we "apply changes"
• added a dror=FALSE statement to the final calculation of df$A to keep R from turning a single column result into a vector instead of a dataframe.

I do think this is the only way to approach this - trying to guard all those expressions so that they will work iteratively on potentially missing data will be a nightmare.

Here is the code:

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)

And this is what that looks like:

回答2:

You seem to be sub-setting the data-table with variable that dont exist when you update it the first time, try subsetting with %in%. Also there is small error with mappy after but you can sort that out...

Try this:

 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)]     
  })