Warning: Error in [<-.data.frame: replacement has 2 rows, data has 1 - Shiny

shiny

#1

I have this code in which i do some calculations, but when i change the input$alternatives to 2 it shows me the following error message

Warning: Error in [<-.data.frame: replacement has 2 rows, data has 1

    library(shiny)
    library(shinydashboard)
    library(htmlwidgets) 
    library(data.table) 
    
    ui <- dashboardPage(
      
      skin="blue",
      
      dashboardHeader(
        title="sth",
        titleWidth = 300),
    
      dashboardSidebar(
        width = 300,
        sidebarMenu(
          menuItem(
            "Gathering Information",
            tabName = "gatheringinformation",
            icon=icon("github")
          ),
          menuItem(
            "Calculation",
            tabName = "linguisticaggregation",
            icon=icon("github")
          ))),
    
      
      dashboardBody(
        tabItems(
          tabItem(tabName = "gatheringinformation",
                  h2("Gathering Information"),
                  
                  # 1st row of boxes
                  fluidRow(
                    box(
                      width = 4, 
                      title = "Inputs",
                      status= "primary",
                      solidHeader = TRUE,
                      h5("Please specify the number of alternatives, criteria and experts"),
                      
                      numericInput("alternatives", h3("Alternatives"), 
                                   value = "1"),
                      numericInput("criteria", h3("Criteria"), 
                                   value = "1"),
                      numericInput("experts", h3("Experts"), 
                                   value = "1")  
                    ))),
                  tabItem(tabName = "linguisticaggregation",
                          h2("2-TUPLE Linguistic Aggregation"),
                          fluidRow(
                            box(title = "View Data", 
                                width = 12,
                                status = "primary", 
                                solidHeader = TRUE,
                                collapsible = TRUE,
                                div(style = 'overflow-x: scroll'),
                                splitLayout(tableOutput("informationtableflv"))
                            ),
                            
                            box(title = "Alternative Rankings", 
                                width = 12,
                                status = "primary", 
                                solidHeader = TRUE,
                                collapsible = TRUE,
                                div(style = 'overflow-x: scroll'),
                                splitLayout(tableOutput("alternativerankings"))
                                
                            ))))))
                  ####################################
                  ############   SERVER   ############
                  ####################################
                  
    server <- function(input, output, session) {
      
    datalistflv<<- list()
     output$informationtableflv <- renderUI({lapply(1:input$experts,function(j){
      renderTable({
        num.inputs.col1 <-  paste0(1)
        df <- data.frame(num.inputs.col1)
        for (m in 1:input$criteria){
          for (n in 1:input$alternatives){
            df[n,m] <-paste0(5)
          }
        }
        colnames(df) <- paste0("Criteria ",as.numeric(1:input$criteria))
        df
        datalistflv[[j]] <<- df
      },caption = paste("Expert " ,j), caption.placement = getOption("xtable.caption.placement", "top"), sanitize.text.function = function(x) x)})})
    
    
    
    output$alternativerankings <- renderUI({lapply(1:input$experts,function(j){
      renderTable({
        a <- na.omit(a)
        a = as.data.frame(lapply(datalistflv[[j]],as.numeric))
        num.inputs.col1 <-  paste0(1)
        df <- data.frame(num.inputs.col1)
        for (m in 1:input$alternatives){
          df[m,1] <-as.numeric(rowSums(a))
          df[m,2] <-round(as.numeric(df[m,1]))
          df[m,3] <-as.numeric(df[m,1]) - as.numeric(df[m,2])
          df[m,4] <-paste0("M")
          df[m,5] <-as.numeric(df[m,1]) - as.numeric(df[m,2])}
        colnames(df) <- paste0("Criteria ",as.numeric(1:input$criteria))
        df
      },caption = paste("Expert " ,j), caption.placement = getOption("xtable.caption.placement", "top"), sanitize.text.function = function(x) x)})})
    
    }
    
    # Run the application 
    shinyApp(ui = ui, server = server)

If i make this modification : df[m,1] <-as.numeric(rowSums(a)) ---->df[m,1] <-1 it is ok

    library(shiny)
     library(shinydashboard)
     library(htmlwidgets) 
     library(data.table) 
    ui <- dashboardPage(
      
      skin="blue",
      
      dashboardHeader(
        title="sth",
        titleWidth = 300),
    
      dashboardSidebar(
        width = 300,
        sidebarMenu(
          menuItem(
            "Gathering Information",
            tabName = "gatheringinformation",
            icon=icon("github")
          ),
          menuItem(
            "Calculation",
            tabName = "linguisticaggregation",
            icon=icon("github")
          ))),
    
      
      dashboardBody(
        tabItems(
          tabItem(tabName = "gatheringinformation",
                  h2("Gathering Information"),
                  
                  # 1st row of boxes
                  fluidRow(
                    box(
                      width = 4, 
                      title = "Inputs",
                      status= "primary",
                      solidHeader = TRUE,
                      h5("Please specify the number of alternatives, criteria and experts"),
                      
                      numericInput("alternatives", h3("Alternatives"), 
                                   value = "1"),
                      numericInput("criteria", h3("Criteria"), 
                                   value = "1"),
                      numericInput("experts", h3("Experts"), 
                                   value = "1")  
                    ))),
                  tabItem(tabName = "linguisticaggregation",
                          h2("2-TUPLE Linguistic Aggregation"),
                          fluidRow(
                            box(title = "View Data", 
                                width = 12,
                                status = "primary", 
                                solidHeader = TRUE,
                                collapsible = TRUE,
                                div(style = 'overflow-x: scroll'),
                                splitLayout(tableOutput("informationtableflv"))
                            ),
                            
                            box(title = "Alternative Rankings", 
                                width = 12,
                                status = "primary", 
                                solidHeader = TRUE,
                                collapsible = TRUE,
                                div(style = 'overflow-x: scroll'),
                                splitLayout(tableOutput("alternativerankings"))
                                
                            ))))))
                  ####################################
                  ############   SERVER   ############
                  ####################################
                  
    server <- function(input, output, session) {
      
    datalistflv<<- list()
     output$informationtableflv <- renderUI({lapply(1:input$experts,function(j){
      renderTable({
        num.inputs.col1 <-  paste0(1)
        df <- data.frame(num.inputs.col1)
        for (m in 1:input$criteria){
          for (n in 1:input$alternatives){
            df[n,m] <-paste0(5)
          }
        }
        colnames(df) <- paste0("Criteria ",as.numeric(1:input$criteria))
        df
        datalistflv[[j]] <<- df
      },caption = paste("Expert " ,j), caption.placement = getOption("xtable.caption.placement", "top"), sanitize.text.function = function(x) x)})})
    
    
    
    output$alternativerankings <- renderUI({lapply(1:input$experts,function(j){
      renderTable({
        a <- na.omit(a)
        a = as.data.frame(lapply(datalistflv[[j]],as.numeric))
        num.inputs.col1 <-  paste0(1)
        df <- data.frame(num.inputs.col1)
        for (m in 1:input$alternatives){
          df[m,1] <-1
          df[m,2] <-round(as.numeric(df[m,1]))
          df[m,3] <-as.numeric(df[m,1]) - as.numeric(df[m,2])
          df[m,4] <-paste0("M")
          df[m,5] <-as.numeric(df[m,1]) - as.numeric(df[m,2])}
        colnames(df) <- paste0("Criteria ",as.numeric(1:input$criteria))
        df
      },caption = paste("Expert " ,j), caption.placement = getOption("xtable.caption.placement", "top"), sanitize.text.function = function(x) x)})})
    
    }
    
    # Run the application 
    shinyApp(ui = ui, server = server)

Can you please help me to understand the problem?


#2

Hi @nikos,

rowSums() does not return a single numeric value, but a vector of values. This vector can not be set in a single cell, which is why you get the warning of "Replacement has 2 rows, data has 1".

Similar to

> myData <- matrix(1, 3,3)
> myData
     [,1] [,2] [,3]
[1,]    1    1    1
[2,]    1    1    1
[3,]    1    1    1
> myData[1,1] <- c(4,4,4)
Error in myData[1, 1] <- c(4, 4, 4) : 
  number of items to replace is not a multiple of replacement length

If you are looking to take the sum of the data, you could supply the data.frame a to sum(a) to get a single numeric value.

To make the error go away, make sure that what you are storing into d[m,1] is a single numeric value (not a vector).

Best,
Barret