Question

我正在尝试根据滑块范围的输入过滤数据表中的数据。完成后，我收到错误subscript out of bounds。我看到滑块范围工作正常。但范围似乎并不过滤数据表。

以下是我使用过的代码：

    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)

更新我从中获取要运行的数据的代码，在应用程序上显示它。

Answer 1

有两种类型的闪亮滑块，它们可以有一个或两个值。滑块栏中的值数量将取决于在ui中的定义方式。

因为你只是在ui的启动中定义了一个单一的滑块，所以当你试图在反应中稍后提取它时，没有第二个输入input$range[[2]]。因此，您需要在ui中设置第二个值，否则您将只获得一个滑块而不是一个范围。例如：

sliderInput("range", "Range:",
              min = min(out$year,na.rm=FALSE), max = max(out$year,na.rm=FALSE),
              value = c(1990,1991))

有关两者（滑动条与滑块范围）之间差异的示例，请查看here

并注意：

如果value是两个数字的向量，Shiny将在条形图上放置两个滑块，这将允许您的用户选择范围的端点。如果value是单个数字，Shiny将创建一个如上所示的基本滑块。

滑块更新数据表R Shiny中的值

1 个答案: