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)