Slider update values in datatable R Shiny - r

Question

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 subscript out of bounds. 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(), ]
})
})
}
shinyApp(ui, server)
Update the code from where I fetch the data to run display it on the app.

Answer 1

There are two types of shiny slider bars and they can have either one or two values. The number of values in the slider bar will be determined by how it is defined in the ui.
Because you only defined a singular slider in the initiation of the ui, there is not a second input input$range[[2]] when you try to extract it later in the reactive. Therefore, you need to set a second value in your ui or you will only get a single slider instead of a range. For example:
sliderInput("range", "Range:",
min = min(out$year,na.rm=FALSE), max = max(out$year,na.rm=FALSE),
value = c(1990,1991))
For an example of the difference between the two (slider bar vs. slider range) look here
And note:
If value is a vector of two numbers, Shiny will place two sliders on the bar, which will let your user select the endpoints of a range. If value is a single number, Shiny will create a basic slider like the one shown above.