R语言Shiny应用中如何等待完整JSON后处理API请求

云原生阿岚

2026-7-13

问题：Shiny应用中连续API请求的阻塞与速率控制问题

我开发了一个Shiny应用，需要连续向API发送请求。为避免出现not all data was parsed (0 chars were parsed out of a total of 160 chars错误，每个请求都必须等前一个请求完成后再发送。

我使用httr包的fromJSON(content(GET('https://...')), as = "text"))或curl包的curl_fetch_memory(fromJSON('https://...'))发送请求。但连续发送JSON请求时，几乎总会出现“未解析全部数据”的错误，目前只能通过Sys.sleep(quite_a_long_time)暂停系统来避免，但这显然不是最优方案。

如何确保数据就绪后再继续执行？我知道可以实现回调函数，但不清楚具体如何操作。

编辑：
我在lapply()调用的函数中使用GET请求，问题可能出在像for循环那样连续发起新的GET请求？是否需要创建不同的会话？

以下是我的尝试代码：

pgkbData <- reactive({
    
    # current dci filtered 
    #drugs_tmp <- dciCypInput()$x$data$Molécule # dciCypInput is made of a datatable containing drugs name
    #drugs_tmp <- dci_all_en %>% # dci_all_en is made of a dataframe containing french-english translated drug names
      filter(fr %in% drugs_tmp) %>% 
      pull(en)
    drugs_tmp <- c('acenocoumarol', 'tacrolimus') # for reproducible example
    drugs <- stri_trans_general(str = drugs_tmp, id = "Latin-ASCII") # removes accents
    drugs <- gsub(" ", "%20", drugs) # Convert white spaces to %20 to make it compatible with URL
    genes <- genoCypInput()$x$data$Enzyme

    if (length(drugs) == 0 | length(genes) == 0) {
      alert('...')
    }

    drug_id_json <- lapply(drugs, fn_pgkb_drug_id) # defined in separate .R file
    drug_ids <- sapply(drug_id_json, function(item) item$data[[1]]$id) # extract the ids

    gene_id_json <- lapply(genes, fn_pgkb_gene_id) # find genes IDs
    gene_ids <- sapply(gene_id_json, function(item) item$data[[1]]$id) # extract the ids

    drugs_genes <- expand_grid(drugs, genes)  # all drug-gene combinations
    drugsId_genesId <- expand_grid(drug_ids, gene_ids) # all drug-gene ids combinations
    final_df <- cbind(drugs_genes, drugsId_genesId)
    total <- nrow(final_df)
    
    for (source in c('cpic', 'dpwg')) { # look for CPIC and DPWG guidelines
      guidelines_json <- lapply(1:nrow(drugs_genes), # syntax to apply with multiple arguments
                                function(i) fn_pgkb_guideline(drug_id = drugsId_genesId$drug_ids[i],
                                                              drug = drugs_genes$drugs[i],
                                                              gene_id = drugsId_genesId$gene_ids[i],
                                                              gene = drugs_genes$genes[i],
                                                              source = source,
                                                              total = total,
                                                              i = i)) 
      guidelines_status <- sapply(guidelines_json,
                                  function(item) item$status) # e.g., 'fail', 'success',...
      guidelines_summary <- sapply(guidelines_json,
                                   function(item) item$data[[1]]$summaryMarkdown$html)
      guidelines_summary[sapply(guidelines_summary, function(x) length(x) == 0L)] <- NA # Replace NULL values with NA to keep a 6-element vector (otherwise NULL are dropped with unlist())

      # urls <- sapply(guidelines_json, function(item) item$data[[1]]$crossReferences[[1]]$resourceId)
      urls <- sapply(guidelines_json, function(item) {
        if (length(item$data[[1]]$crossReferences) > 0) {
          return(item$data[[1]]$crossReferences[[1]]$resourceId)
        } else {
          return(NA)
        }
      })
      
      # guidelines_url <- lapply(urls, function(url) HTML(paste0("<a href='", url, "' target='_blank'>Voir recommendation</a>")))
      guidelines_url <- lapply(urls, function(url) {
        if (!is.na(url)) {
          link_text <- "Voir recommandation"
          link_html <- HTML(paste0("<a href='", url, "' target='_blank'>", link_text, "</a>"))
          return(link_html)
        }
        else {
          return("")
        }
      })
      
      final_df <- final_df %>% 
        cbind(status = guidelines_status,
              source = unlist(guidelines_summary),
              lien = unlist(guidelines_url))
    }
    names(final_df)[5] = "status_CPIC"
    names(final_df)[6] = "CPIC"
    names(final_df)[7] = "lien (CPIC)"
    names(final_df)[8] = "status_DPWG"
    names(final_df)[9] = "DPWG"
    names(final_df)[10] = "lien (DPWG)"
    final_df <- final_df %>% 
      filter(status_CPIC == 'success' | status_DPWG == 'success')
    datatable(final_df,
              #extensions = c("Buttons"), 
              rownames = FALSE,
              filter = 'top', 
              selection = "none",
              editable = FALSE,
              escape = FALSE,
              options = list(
                #   search = list(regex = TRUE, caseInsensitive = TRUE),
                pageLength = 20,
                dom = 'lftipr'
                #   buttons = list(list(extend = "copy", text='<span class="fa-solid fa-copy"></span> Copier', title=''))
                #
              )
    )
  })

独立.R文件中的自定义方法：

pgkb_get_prefix <- 'https://api.pharmgkb.org/v1/data/'

pgkb_drugId_url <- function(chemical_name) {
  url <- paste0(pgkb_get_prefix, 'chemical?name=', chemical_name)
  return(url)
}

fn_pgkb_drug_id <- function(chemical_name) {
  pgkb_drug_id <- content(GET(paste0(pgkb_get_prefix,
                                     'chemical?name=',
                                     chemical_name)))
  short_notification(duration = 0.8, message = paste0('ID (', chemical_name, ') (1/3)'))
  Sys.sleep(0.8)
  return(pgkb_drug_id)
}

fn_pgkb_gene_id <- function(hgng_gene) {
  pgkb_gene_id <- content(GET(paste0(pgkb_get_prefix,
                                     'gene?symbol=',
                                     hgng_gene)))
  short_notification(duration = 0.8, message = paste0('ID (', hgng_gene, ') (2/3)'))
  Sys.sleep(0.8)
  return(pgkb_gene_id)
}

fn_pgkb_guideline <- function(drug_id, drug, gene_id, gene, source, total, i) {
  result <- content(GET(paste0(pgkb_get_prefix,
                               'guidelineAnnotation?source=',
                               source,
                               '&relatedChemicals.accessionId=',
                               drug_id,
                               '&relatedGenes.accessionId=',
                               gene_id)))
  
  Sys.sleep(1)
  status <- result$status
  short_notification(duration = 1, message = paste0(drug, ' / ', gene, ' (', source, ') '))
  short_notification(duration = 1, message = paste0('Status: ', status, ' (', i, '/', total, ')'))
  # if (status == "fail") {
  #   error <- result$data$errors[[1]]$message
  #   print(paste('error =', error))
  # }

  return(result)
}

我查看API文档得知，每秒仅允许2次请求（这可能是我有时无法获取数据的原因——若1秒内发送超过2次请求），也是必须暂停系统的原因。我的想法是在前一个请求的数据就绪后暂停0.5秒，确保Sys.sleep()的等待时间最短。

解决方案

1. 改用会话管理与可靠解析

使用httr::handle()创建持久会话，避免重复建立连接；同时先获取文本格式的响应再解析JSON，减少解析不完整的问题：

# 创建全局持久会话
pgkb_handle <- handle(pgkb_get_prefix)

# 修改请求函数
fn_pgkb_drug_id <- function(chemical_name) {
  url <- paste0(pgkb_get_prefix, 'chemical?name=', chemical_name)
  response <- GET(url, handle = pgkb_handle)
  
  # 检查请求状态，失败直接抛出错误
  stop_for_status(response)
  
  # 先获取文本内容再解析JSON，提升可靠性
  response_text <- content(response, as = "text", encoding = "UTF-8")
  pgkb_drug_id <- fromJSON(response_text)
  
  short_notification(duration = 0.8, message = paste0('ID (', chemical_name, ') (1/3)'))
  return(pgkb_drug_id)
}

2. 动态速率控制

实现基于时间窗口的速率控制器，自动计算等待时间，严格遵守每秒2次的限制，无需固定Sys.sleep()：

# 全局变量记录上次请求时间
last_request_time <- Sys.time()

rate_limit <- function(min_interval = 0.5) {
  current_time <- Sys.time()
  elapsed <- as.numeric(current_time - last_request_time, units = "secs")
  if (elapsed < min_interval) {
    Sys.sleep(min_interval - elapsed)
  }
  # 更新请求时间
  assign("last_request_time", Sys.time(), envir = .GlobalEnv)
}

# 在所有请求函数开头加入速率控制
fn_pgkb_drug_id <- function(chemical_name) {
  rate_limit()
  
  url <- paste0(pgkb_get_prefix, 'chemical?name=', chemical_name)
  response <- GET(url, handle = pgkb_handle)
  stop_for_status(response)
  
  response_text <- content(response, as = "text", encoding = "UTF-8")
  pgkb_drug_id <- fromJSON(response_text)
  
  short_notification(duration = 0.8, message = paste0('ID (', chemical_name, ') (1/3)'))
  return(pgkb_drug_id)
}

# fn_pgkb_gene_id、fn_pgkb_guideline函数同样添加rate_limit()调用

3. 显式循环替代lapply（可选）

显式for循环可以更直观地控制请求顺序，确保前一个请求完成后再发起下一个：

# 替换drug_id_json的lapply为for循环
drug_id_json <- list()
for (drug in drugs) {
  drug_id_json[[drug]] <- fn_pgkb_drug_id(drug)
}

4. 添加重试机制

针对临时请求失败，使用purrr::insistently()添加自动重试逻辑：

library(purrr)

# 为请求函数添加重试，最多3次，间隔指数退避
fn_pgkb_drug_id_retry <- insistently(
  fn_pgkb_drug_id,
  rate_backoff(pause_base = 0.5, pause_cap = 2, max_times = 3)
)

# 使用重试后的函数发起请求
drug_id_json <- lapply(drugs, fn_pgkb_drug_id_retry)

内容的提问来源于stack exchange，提问作者Trichophyton

R语言Shiny应用中如何等待完整JSON后处理API请求

1. 改用会话管理与可靠解析 #

2. 动态速率控制 #

3. 显式循环替代lapply（可选） #

4. 添加重试机制 #

1. 改用会话管理与可靠解析

2. 动态速率控制

3. 显式循环替代lapply（可选）

4. 添加重试机制