Ошибка в data.frame: объект (список) не может быть принужден к типу «логический»

Я пытаюсь удалить строку, выбранную пользователем в таблице d3table, используя функции shinjs.

Код того, что у меня есть, выглядит следующим образом:

library(shiny)
library(htmlwidgets)
library(D3TableFilter)
data(mtcars)

mtcars2 <- mtcars[,1:2]

GetTableMetadata <- function() {
  fields <- c(mpg = "mpg", 
              cyl = "cyl" )
  result <- list(fields = fields)
  return (result)
}

#R
ReadData <- function() {
  if (exists("mtcars2")) {
    mtcars2
  }
}

#D
DeleteData <- function(data) {
  mtcars2 <- mtcars2[row.names(mtcars2) != unname(data["mpg"]), ]
}

UpdateInputs <- function(data, session) {
  updateTextInput(session, "mpg", value = unname(rownames(data)))
  updateTextInput(session, "cyl", value = unname(data["name"]))
 }


CreateDefaultRecord <- function() {
  mydefault <- CastData(list(mpg = "", cyl = ""))
  return (mydefault)
}

# ui.R
# --------------------------------------------------------
ui <- shinyUI(fluidPage(
  title = 'Interactive features',
  tabsetPanel(

    tabPanel("Row selection",
             fluidRow(column(width = 12, h4("Row selection"))),
             fluidRow(
               column(width = 2,

                      wellPanel(
                        actionButton("delete", "Delete")
                      )
                     ),
               column(width = 5,
                      d3tfOutput('mtcars2', height = "2000px")
                      ),
               column(width = 5,
                      tableOutput("mtcars2Output")
                      )

                 )
    ) 
  )))

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

  formData <- reactive({
    sapply(names(GetTableMetadata()$fields), function(x) input[[x]])
  })

  # Press "Delete" button -> delete from data
  observeEvent(input$delete, {
    DeleteData(formData())
    UpdateInputs(CreateDefaultRecord(), session)
  }, priority = 1)


   output$mtcars2 <- renderD3tf({
    input$delete
    ReadData()

    # define table properties. See http://tablefilter.free.fr/doc.php

    tableProps <- list(
      btn_reset = TRUE,
      rows_counter = TRUE,  
      rows_counter_text = "Rows: ",
      sort = TRUE,
      on_keyup = TRUE,  
      on_keyup_delay = 800,
      filters_row_index = 1
      );


    d3tf(mtcars[ , 1:2],
         enableTf = TRUE,
         tableProps = tableProps,
         showRowNames = FALSE, 
         selectableRows = "multi",
         selectableRowsClass = "info",
         tableStyle = "table table-bordered table-condensed",
         rowStyles = c(rep("", 7), rep("info", 7)),
         filterInput = TRUE,
         height = 500);
      })

   output$mtcars2Output <- renderTable({
    if(is.null(input$mtcars2_select)) return(NULL);
    mtcars2[input$mtcars2_select,1:2];
  })


})

runApp(list(ui=ui,server=server))

Когда я выбираю строку и нажимаю кнопку Delete, я получаю сообщение об ошибке

Error in data.frame: (list) object cannot be coerced to type 'logical'

Цените любую помощь.


person Jill Sellum    schedule 17.05.2016    source источник
comment
что такое CastData? Эта функция, похоже, отсутствует в вашем коде.   -  person timelyportfolio    schedule 18.05.2016
comment
Я также не понимаю, как R знает, что выбрано в таблице при нажатии input$delete, поэтому formData() возвращает список из двух NULL. Я что-то пропустил?   -  person timelyportfolio    schedule 18.05.2016


Ответы (1)


См. комментарии для некоторых вопросов, которые у меня есть, но будет ли это работать с использованием reactiveValues?

library(shiny)
library(htmlwidgets)
library(D3TableFilter)
data(mtcars)

mtcars2 <- mtcars[,1:2]

GetTableMetadata <- function() {
  fields <- c(mpg = "mpg", 
              cyl = "cyl" )
  result <- list(fields = fields)
  return (result)
}

#R
ReadData <- function() {
  if (exists("mtcars2")) {
    mtcars2
  }
}

#D
DeleteData <- function(data) {
  mtcars2 <- mtcars2[row.names(mtcars2) != unname(data["mpg"]), ]
}

UpdateInputs <- function(data, session) {
  updateTextInput(session, "mpg", value = unname(rownames(data)))
  updateTextInput(session, "cyl", value = unname(data["name"]))
}


CreateDefaultRecord <- function() {
  mydefault <- CastData(list(mpg = "", cyl = ""))
  return (mydefault)
}

# ui.R
# --------------------------------------------------------
ui <- shinyUI(fluidPage(
  title = 'Interactive features',
  tabsetPanel(

    tabPanel("Row selection",
             fluidRow(column(width = 12, h4("Row selection"))),
             fluidRow(
               column(width = 2,

                      wellPanel(
                        actionButton("delete", "Delete")
                      )
               ),
               column(width = 5,
                      d3tfOutput('mtcars2', height = "2000px")
               ),
               column(width = 5,
                      tableOutput("mtcars2Output")
               )

             )
    ) 
  )))

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

  values <- reactiveValues(data=ReadData())

  # Press "Delete" button -> delete from data
  observeEvent(input$delete, {
    values$data <- values$data[-input$mtcars2_select,]
  }, priority = 1)


  output$mtcars2 <- renderD3tf({
    # define table properties. See http://tablefilter.free.fr/doc.php

    tableProps <- list(
      btn_reset = TRUE,
      rows_counter = TRUE,  
      rows_counter_text = "Rows: ",
      sort = TRUE,
      on_keyup = TRUE,  
      on_keyup_delay = 800,
      filters_row_index = 1
    );


    d3tf(values$data,
         enableTf = TRUE,
         tableProps = tableProps,
         showRowNames = FALSE, 
         selectableRows = "multi",
         selectableRowsClass = "info",
         tableStyle = "table table-bordered table-condensed",
         rowStyles = c(rep("", 7), rep("info", 7)),
         filterInput = TRUE,
         height = 500);
  })

  output$mtcars2Output <- renderTable({
    if(is.null(input$mtcars2_select)) return(NULL);
    mtcars2[input$mtcars2_select,1:2];
  })


})

runApp(list(ui=ui,server=server))
person timelyportfolio    schedule 18.05.2016