Filter range doesnt update table

shiny
dt

#1

I am trying to filter the data in a datatable based from the inputs from the slider range. When this is done I get an error

object of type 'closure' is not subsettable

I see the slider range to be working fine. But the range doesnt seems to filter the data table.

Below is the code which I have used :

response_codes <- function(status_code){
  
  status_df <- tibble::tribble(
    ~status_code, ~message,
    200,	"Success",
    201,	"Successfully created item",
    204,	"Item deleted successfully",
    400,	"Something was wrong with the format of your request",
    401,	"Unauthorized - your API key is invalid",
    403,	"Forbidden - you do not have access to operate on the requested item(s)",
    404,	"Item not found",
    429,	"Request was throttled - you are sending too many requests too fast."
  )
  
  out <- status_df[status_df$status_code == status_code, "message"]
  
  out <- unlist(out, use.names = FALSE)
  
  out
}
install.packages("devtools")
library(tidyr)
lego_get <- function(url, ..., api_key){
  
  auth <- paste("key", api_key)
  
  query = list(...)
  
  # Call the apiå
  api_call <- httr::GET(url, query = query,
                        httr::add_headers(Authorization = auth))
  
  if(httr::status_code(api_call) > 204){
    stop(response_codes(httr::status_code(api_call)))
  } else {
    message(response_codes(httr::status_code(api_call)))
  }
  
  # Collect data
  out <- list()
  
  api_data <- httr::content(api_call)
  
  if(is.null(api_data$results)){
    api_data <- null_to_na(api_data)
    return(api_data)
  }
  
  if(length(api_data$results) == 0){
    api_data$results <- NA
    api_data <- null_to_na(api_data)
    return(api_data)
  }
  
  out <- c(out, list(api_data$results))
  
  # While loop to deal with pagination
  while(!is.null(api_data$`next`)){
    message(paste("Pagenating to:", api_data$`next`))
    api_call <- httr::GET(api_data$`next`, httr::add_headers(Authorization = auth))
    api_data <- httr::content(api_call)
    out <- c(out, list(api_data$results))
  }
  
  # Flatten the list
  out <- purrr::flatten(out)
  
  # Set nulls to NA
  out <- null_to_na(out)
  
  # Return data
  out
  
}

null_to_na <- function(mylist){
  purrr::map(mylist, function(x){
    if(is.list(x)){
      null_to_na(x)
    } else {
      if(is.null(x)) NA else x
    }
  })
}

color_list_to_df <- function(lego_data){
  out <- purrr::map_df(lego_data, function(color){
    
    external_ids <- names(color$external_ids)
    
    col_df <- purrr::map_df(external_ids, function(external_id){
      ext_ids <- unlist(color$external_ids[[external_id]]$ext_ids)
      
      df <- tibble::tibble(
        external_id = external_id,
        ext_ids = ext_ids
      )
      
      ext_descrs <- color$external_ids[[external_id]]$ext_descrs
      ext_descrs <- purrr::map(ext_descrs, unlist)
      
      df$ext_descrs <- ext_descrs
      
      df <- tidyr::unnest(df, ext_descrs)
      
      df
    })
    
    external <- tidyr::nest(col_df, .key = external_ids)
    
    tibble::tibble(
      id = color$id,
      name = color$name,
      rgb = color$rgb,
      is_trans = color$is_trans,
      external_ids = external$external_ids
    )
  })
  
  out
}

parts_list_to_df <- function(lego_data){
  out <- purrr::map_df(lego_data, function(parts_data){
    
    if(length(parts_data$external_ids) != 0){
      part_df <- tibble::tibble(
        external_ids = names(parts_data$external_ids)
      )
      
      part_df$ids <- purrr::map(part_df$external_ids, function(ext_name){
        unlist(parts_data$external_ids[[ext_name]])
      })
      
      part_df <- tidyr::unnest(part_df, ids)
      
      external <- tidyr::nest(part_df, .key = external_ids)
    } else {
      external <- list()
      external$external_ids <- NA
    }
    
    tibble::tibble(
      part_num = parts_data$part_num,
      name = parts_data$name,
      part_cat_id = parts_data$part_cat_id,
      part_url = parts_data$part_url,
      part_img_url = parts_data$part_img_url,
      external_ids = external$external_ids
    )
  })
  
  out
}




###############################################################
url <- "https://rebrickable.com/api/v3/lego/sets/"
api_key <- "5baf593383d5f6a7fadd264480287ac9"

lego_data <- lego_get(url = url, api_key = api_key)

message("Converting to tibble")
out <- purrr::map_df(lego_data, tibble::as_tibble)

out
###############################################################
#devtools::install_github("rstudio/shiny")
#install.packages("devtools")
#install.packages("DT")
library(shiny)
library(devtools)
library(DT)
library(yaml)
# Define UI for slider demo app ----
ui <- fluidPage(
  
  # App title ----
  titlePanel("Sliders"),
  
  # Sidebar layout with input and output definitions ----
  sidebarLayout(
    
    # Sidebar to demonstrate various slider options ----
    sidebarPanel(
      # Input: Specification of range within an interval ----
      sliderInput("range", "Range:",
                  min = min(out$year,na.rm=FALSE), max = max(out$year,na.rm=FALSE),
                  value = c(1990,1995))
    ),
    mainPanel(
            DT::dataTableOutput("mytable")
          )
  )
)
server <- function(input, output) {
  
  # sorted columns are colored now because CSS are attached to them
  # output$mytable <- DT::renderDataTable({
  #   DT::datatable(out, options = list(orderClasses = TRUE))
  # })
  minRowVal <- reactive({
    which(grepl(input$range[[1]], out$year))        #Retrieve row number that matches selected range on sliderInput
  })
  
  maxRowVal <- reactive({
    which(grepl(input$range[[2]], out$year))        #Retrieve row number that matches selected range on sliderInput
  })
  
  # observeEvent(input$range, {
  #   output$mytable <- DT::renderDataTable({
  #     DT::datatable[minRowVal():maxRowVal(), ]
  #   })
  # })

  output$mytable <- DT::renderDataTable({
    DT::datatable(out, filter = 'top', options = list(orderClasses = TRUE))
  })
  
}

shinyApp(ui, server)

#2

Your issue is that out is not a reactive object so your sliderInputs are not affecting it. You need to either move the portion of code generating the out tibble into the server code or make it a reactive with makeReactiveBinding at the beginning of the server code


#3

@tbradley is this the right way of doing it.Thank you.

  newData <- reactive({
    data <- output$mytable <- DT::renderDataTable({
      DT::datatable[minRowVal():maxRowVal(), ]
    })
  })


#4

no, DT::datatable is a function that takes a data.frame as an argument. It is not a dataset itself, so subsetting with [ will not work. You can try something like this:

server <- function(input, output) {
  
  data <- makeReactiveBinding("out")

  # sorted columns are colored now because CSS are attached to them
  # output$mytable <- DT::renderDataTable({
  #   DT::datatable(out, options = list(orderClasses = TRUE))
  # })
  minRowVal <- reactive({
    which(grepl(input$range[[1]], data()$year))        #Retrieve row number that matches selected range on sliderInput
  })
  
  maxRowVal <- reactive({
    which(grepl(input$range[[2]], data()$year))        #Retrieve row number that matches selected range on sliderInput
  })
  

  output$mytable <- DT::renderDataTable({
    DT::datatable(data()[minRowVal():maxRowVal(), ], filter = 'top', options = list(orderClasses = TRUE))
  })
  
}