Wsrtjtyk

In R Shiny, I have been able to realize the function of freely inserting input fields with an actionButton, using this technique: R Shiny: How to create an "Add Field" Button (call it Section A). Now within Section A, I want to add another section that allows users to freely insert fields with another actionButton (Section B). So Section B is within Section A.

Using the technique quoted above, it looks like I need to nest an observeEvent({}) within an observeEvent({}), but when I did so, I got this error: Error in as.vector: cannot coerce type 'environment' to vector of type 'character'.

Anyone has got any ideas how to get around? Here is the relevant code:

server part:

  ################################# Additional Tables ############################

  ### UI part

  ids <<- NULL  



  idsR <- reactiveValues(v=c())



  idsa <<- NULL



  idsaR <- reactiveValues(v=c())



  observeEvent(input$addTable,{

    if (is.null(ids)){

      ids <<- 1

      idsR$v <- c()





    }else{

      ids <<- c(ids, max(ids)+1)

    }

    idsR$v <- ids

    output$additionalTables <- renderUI({  

      lapply(1:length(ids),function(i){

        ## Input: Joining condition 1 for the first table

        output[[paste0("joinCondition_1_a_additional",ids[i])]] <- renderUI({

          selectInput(paste0("joinCondition_1_a_additional",ids[i]), HTML("Column to Join (1st Table)  <font size = '3' color = 'red'>*</font>"), multiple = FALSE, choices = as.list(sort(unique(partColumnNames()[partColumnNames()[, 1] == trimws(input$table) & condition1(), 2]))))

        })



        ## Input: Joining condition 1 for the additional table

        output[[paste0("joinCondition_1_b_additional",ids[i])]] <- renderUI({

          selectInput(paste0("joinCondition_1_b_additional",ids[i]), HTML("Column to Join (Additional Table)  <font size = '3' color = 'red'>*</font>"), multiple = FALSE, choices = as.list(sort(unique(partColumnNames()[partColumnNames()[, 1] == trimws(input[[paste0("additional_table",ids[i])]]) & condition1(), 2]))))

        })





        ## Input: Tables in the first table's schema

        output[[paste0("additional_table",ids[i])]] <- renderUI({

          selectInput(paste0("additional_table",ids[i]), HTML("Table  <font size = '3' color = 'red'>*</font>"), choices = as.list(sort(unique(allTableNames[allTableNames[,1] == trimws(input$schema), 2]))))

        })



        ## Input: Columns in the additional table

        output[[paste0("additional_column",ids[i])]] <- renderUI({

          selectInput(paste0("additional_column",ids[i]), HTML("Non-aggregate columns  <font size = '3' color = 'red'>*</font>"), multiple = TRUE, choices = as.list(c(

            ####Bill suggested not allowing users to select all columns                  #"*", 

            sort(unique(partColumnNames()[partColumnNames()[, 1] == trimws(input[[paste0("additional_table",ids[i])]])  & condition1(), 2 ])))))

        })



        tagList(



          tags$hr(style="height:1px;border:none;background-color:#D1D1D1;" ),

          tags$h4(sprintf("Additional Table #%d",ids[i]),align = "center", style="color:#2955A0;font-weight:bold; font-family:times;"),



          fluidRow(



            column(

              # Input: joining method

              radioButtons(inputId = paste0("joiningMethod",ids[i]), label = HTML("Method  <font size = '3' color = 'red'>*</font>"), choices = c("left", "inner")), width = 4),



            column( 

              # Input: the origin of the additional table

              radioButtons(inputId = paste0("tableOrigin",ids[i]), label = HTML("Is the additional table in CCW or external?  <font size = '3' color = 'red'>*</font>"), choices = c("CCW", "external")), width = 8)),





          # If CCW

          conditionalPanel(

            condition = paste0("input.",paste0("tableOrigin",ids[i]),"== 'CCW'"),



            # Input: table for the additional table

            uiOutput(outputId = paste0("additional_table",ids[i])), 



            # Input: columns for the additional table

            uiOutput(outputId = paste0("additional_column",ids[i])),



            tags$h4("Joining Condition",align = "center", style="color:#2955A0;font-weight:bold; font-family:times;"),



            fluidRow(

              column(

                # Input: joining condition for the first table

                uiOutput(outputId = paste0("joinCondition_1_a_additional",ids[i])), width = 6),

              column(

                # Input: joining condition for the additional table

                uiOutput(outputId = paste0("joinCondition_1_b_additional",ids[i])), width = 6)

            ),



            uiOutput(outputId = paste0("additionaljoinCondition_additionalTable",ids[i])),

            fluidRow(

              column(12, align="center", offset = 0, actionButton(inputId = paste0("addjoiningCondition_additionalTable", ids[i]),"Add Another Joining Condition?", style="color: #fff; text-align: center; background-color: #337ab7; border-color: #2e6da4"))

            )

          ),



          # If External

          conditionalPanel(

            condition = paste0("input.",paste0("tableOrigin",ids[i]),"== 'external'"),



            # file upload UI for the additional table

            fileInput(inputId = paste0("additionalTable",ids[i]), label = "Table to join with (csv file, with header in the first row)", accept = c(

              "text/csv",

              "text/comma-separated-values,text/plain",

              ".csv"))

          )

        )







      ## Additional Joining conditions for Additional Tables ##

  observeEvent(input[[paste0("addjoiningCondition_additionalTable", ids[i])]],{

    if (is.null(idsa)){

      idsa <<- 1

      idsaR$v <- c()



    }else{

      idsa <<- c(idsa, max(idsa)+1)

    }



    idsaR$v <- idsa





    output[[paste0("additionaljoinCondition_additionalTable", ids[i])]] <- renderUI({

      lapply(1:length(idsa),function(i){



        ## Input: Joining condition 1 for the first table

         output[[paste0("joinCondition_1_a_additional_additionaltable_idsa",idsa[i])]] <- renderUI({

           selectInput(paste0("joinCondition_1_a_additional_additionaltable_idsa",idsa[i]), HTML("Column to Join (1st Table)  <font size = '3' color = 'red'>*</font>"), multiple = FALSE, choices = as.list(sort(unique(partColumnNames()[partColumnNames()[, 1] == trimws(input$table) & condition1(), 2]))))

        })



        ## Input: Joining condition 1 for the additional table

        output[[paste0("joinCondition_1_b_additional_additionaltable_idsa",idsa[i])]] <- renderUI({

          selectInput(paste0("joinCondition_1_b_additional_additionaltable_idsa",idsa[i]), HTML("Column to Join (Additional Table)  <font size = '3' color = 'red'>*</font>"), multiple = FALSE, choices = as.list(sort(unique(partColumnNames()[partColumnNames()[, 1] == trimws(input[[paste0("additional_table",ids[i])]]) & condition1(), 2]))))

        })





        tagList(



          fluidRow(

            column(

              # Input: joining condition for the first table  --> Input: "output$joinCondition_1_a"

              uiOutput(outputId = paste0("joinCondition_1_a_additional_additionaltable_idsa",idsa[i])), width = 6),

            column(

              # Input: joining condition for the second table  --> Input: "output$joinCondition_1_b"

              uiOutput(outputId = paste0("joinCondition_1_b_additional_additionaltable_idsa",idsa[i])), width = 6)



          )

        )

       })

    })

  })



  })



    }) 

  })

Since I used uiOutput to display the objects, a lot of the inputs were moved to server.R as wrapped in renderUI({}). The relevant ui part of the code only has the following:

  uiOutput("additionaljoinCondition"),

  fluidRow(

  column(12, align="center", offset = 0, actionButton("addjoiningCondition","Add Another Joining Condition?", style="color: #fff; text-align: center; background-color: #337ab7; border-color: #2e6da4")))

  ),

More Info from the OP: I made a mockup app using the example in the quoted thread. For this particular example, the goal is to allow users to add multiple comments by hitting the "Add Comment" button under each textbox that they have created using the "Add Text" button. Now, with observeEvent({}) nested, I got the same error: Error in as.vector: cannot coerce type 'environment' to vector of type 'character'. If you can figure out the solution for the mockup, I can extend it to my original code.

ui <- shinyUI(fluidPage(

  titlePanel(""),

  sidebarLayout(

    sidebarPanel(

      actionButton("addText","Add Text"),

      uiOutput("txtOutput"),

      actionButton("getTexts","Get Input Values")

    ),



    # Show a plot of the generated distribution

    mainPanel(

      verbatimTextOutput("txtOut"),

      verbatimTextOutput("cmtOut")

    )

  )))



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



  ids <<- NULL



  observeEvent(input$addText,{

    if (is.null(ids)){

      ids <<- 1

    }else{

      ids <<- c(ids, max(ids)+1)

    }



    idsa <<- NULL



    output$txtOutput <- renderUI({

        lapply(1:length(ids),function(i){

          textInput(paste0("txtInput",ids[i]), sprintf("Text Input #%d",ids[i]))



          uiOutput(outputId = paste0("cmtOutput", ids[i]))

          actionButton(inputId = paste0("addComment", ids[i]), "Add Comment")





          observeEvent(input[[paste0("addComment",ids[i])]],{

            if (is.null(idsa)){

              idsa <<- 1

            }else{

              idsa <<- c(idsa, max(idsa)+1)

            }

            output[[paste0("cmtOutput",ids[i])]] <- renderUI({

                lapply(1:length(idsa), function(i){

                  textInput(paste0("cmtInput", ids[i], "_", idsa[i]), sprintf("Comment Input #%d", idsa[i]))

                })

            })

          })

          })

    })

  })



  observeEvent(input$getTexts,{

    if(is.null(ids)){

      output$txtOut <- renderPrint({"No textboxes"})

      output$cmtOut <- renderPrint({"No comments"})

    }else{

      txtOut <- list()



      # Get ids for textboxes

      txtbox_ids <- sapply(1:length(ids),function(i){

        paste0("txtInput",ids[i],sep="")

      })



      # Get values

      for(i in 1:length(txtbox_ids)){

        txtOut[[i]] <- sprintf("Txtbox #%d has value: %s",i,input[[ txtbox_ids[i] ]])

      }

        output$txtOut <- renderPrint({txtOut})

        if(is.null(idsa)){

          output$cmtOut <- renderPrint({"No comments"})

        }else{

          cmtOut <- list()



          # Get ids for textboxes

          cmtbox_ids <- sapply(1:length(idsa),function(i){

            paste0("cmtInput",ids[i], "_", idsa[i],sep="")

          })



          # Get values

          for(i in 1:length(cmtbox_ids)){

            cmtOut[[i]] <- sprintf("Comment box #%d has value: %s",i,input[[ cmtbox_ids[i] ]])

          }



      output$cmtOut <- renderPrint({cmtOut})

        }

    }

  })



})



shinyApp(ui=ui,server=server)

I figured it out myself. Just posting for anyone who encounters similar issues. Below is the code for the mockup.
Notice the use of
if (idsc[i] != input[[paste0("addComment", idsR$v[i])]])
With this syntax missing, when you click "Add Text" twice, and "Add Comment" once for the first textbox, you will see two comments been added.
Also notice the use of
if (length(idsaR$v[[i]]) != 0){
idsaR$v[[i]] <<- c(idsaR$v[[i]], max(idsaR$v[[i]])+1)
}
else{
idsaR$v[[i]] <<- c(1)
}, if omitting that, after you add comments for textbox #2 and want to go back add comments for textbox #1, there will be an error.

ui <- shinyUI(









  fluidPage(

  titlePanel(""),

  sidebarLayout(

    sidebarPanel(

      actionButton("addText","Add Text"),

      uiOutput("txtOutput"),

      actionButton("getTexts","Get Input Values")

    ),



    # Show a plot of the generated distribution

    mainPanel(

      verbatimTextOutput("txtOut"),

      verbatimTextOutput("cmtOut")

    )

  )))



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



  ids <<- NULL

  idsR <<- reactiveValues(v = c())

  idsaR <<- reactiveValues(v = list())

  idsc <<- c()





  observeEvent(input$addText,{

    if (is.null(ids)){

      ids <<- 1

    }else{

      ids <<- c(ids, max(ids)+1)

    }

    idsR$v <<- ids



    output$txtOutput <- renderUI({

        lapply(1:length(ids),function(i){

         tagList(

         textInput(paste0("txtInput",idsR$v[i]), sprintf("Text Input #%d",idsR$v[i])),



         uiOutput(outputId = paste0("cmtOutput", idsR$v[i])),

         actionButton(inputId = paste0("addComment", idsR$v[i]), "Add Comment")

          )







          })

    })

  })



  idsc <<- c()



observe({

if (length(idsR$v)!= 0){

lapply(1:length(idsR$v), function(i){

  idsc[i] <<- 0

  observeEvent(input[[paste0("addComment", idsR$v[i])]],{



    if (idsc[i] != input[[paste0("addComment", idsR$v[i])]]){

      if (length(idsaR$v) < i ){

        idsaR$v[[i]] <<- c(1)

      }else{

        if (length(idsaR$v[[i]]) != 0){

        idsaR$v[[i]] <<- c(idsaR$v[[i]], max(idsaR$v[[i]])+1)

        }

        else{

        idsaR$v[[i]] <<- c(1)

      }

      }

    }



    idsc[i] <<- input[[paste0("addComment", idsR$v[i])]]





    output[[paste0("cmtOutput",idsR$v[i])]] <- renderUI({

      lapply(1:length(idsaR$v[[i]]), function(j){

        textInput(paste0("cmtInput", idsR$v[i], "_", idsaR$v[[i]][j]), sprintf("Comment Input #%d, #%s", idsR$v[i], idsaR$v[[i]][j]))

      })

    })

  })

})

}

})









  observeEvent(input$getTexts,{

    if(is.null(idsR$v)){

      output$txtOut <- renderPrint({"No textboxes"})

      output$cmtOut <- renderPrint({"No comments"})

    }else{

      txtOut <- list()

      cmtOut <- list()

      cmtbox_ids <- list()



      # Get ids for textboxes

      txtbox_ids <- sapply(1:length(idsR$v),function(i){

        paste0("txtInput",idsR$v[i],sep="")

      })



      # Get values

      for(i in 1:length(txtbox_ids)){

        txtOut[[i]] <- sprintf("Txtbox #%d has value: %s",i,input[[ txtbox_ids[i] ]])



        if(is.null(idsaR$v)){

          cmtOut <- list("No comments")

        }else{

          cmtOut[[i]] <- list()

          if (length(idsaR$v) >= i){

          # Get ids for commentboxes for the ith textbox

          cmtbox_ids[[i]] <- sapply(1:length(idsaR$v[[i]]),function(j){

            paste0("cmtInput",idsR$v[i], "_", idsaR$v[[i]][j])

          })



          # Get values

          for (j in 1:length(cmtbox_ids[[i]])){

            if(is.null(idsaR$v[[i]])){

            cmtOut[[i]] <- c("No comments")

              }else{

            cmtOut[[i]][j] <- sprintf("Comment box #%d has value: %s",j,input[[ cmtbox_ids[[i]][j] ]])

              }

          }

        }else{

          cmtOut[[i]] <- c("No comments")

        }





        }

      }

        output$txtOut <- renderPrint({txtOut})

        output$cmtOut <- renderPrint({cmtOut})



    }

  })



})



shinyApp(ui=ui,server=server)