Initial feature for starting: bps_list_* functions family

.Rbuildignore

@@ -0,0 +1,2 @@
+^rstadata\.Rproj$
+^\.Rproj\.user$

.gitignore

@@ -0,0 +1,44 @@
+# History files
+.Rhistory
+.Rapp.history
+
+# Session Data files
+.RData
+.RDataTmp
+
+# User-specific files
+.Ruserdata
+
+# Example code in package build process
+*-Ex.R
+
+# Output files from R CMD build
+/*.tar.gz
+
+# Output files from R CMD check
+/*.Rcheck/
+
+# RStudio files
+.Rproj.user/
+
+# produced vignettes
+vignettes/*.html
+vignettes/*.pdf
+
+# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3
+.httr-oauth
+
+# knitr and R markdown default cache directories
+*_cache/
+/cache/
+
+# Temporary files created by R markdown
+*.utf8.md
+*.knit.md
+
+# R Environment Variables
+.Renviron
+
+# pkgdown site
+docs/
+.Rproj.user

DESCRIPTION

@@ -0,0 +1,28 @@
+Package: rstadata
+Title: Interface Access Data Badan Pusat Statistik Indonesia
+Version: 0.0.0.9000
+Authors@R:
+    c(person(given = "Muhammad Aswan",
+             family = "Syahputra",
+             role = c("aut", "cre"),
+             email = "[email protected]"),
+      person(given = "Aep",
+             family = "Hidayatuloh",
+             email = "[email protected]",
+             role = "ctb"),
+      person(given = "Andi",
+             family = "Herlan",
+             role = c("aut", "ctb"),
+             email = "[email protected]"))
+Description: Access to BPS Indonesia Data via WebAPI v1.
+License: LICENSE
+URL: https://github.com/indo-r/rstadata
+BugReports: https://github.com/indo-r/rstadata/issues
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.2.3
+Imports:
+    httr2,
+    dplyr
+Depends:
+    R (>= 4.1.0)

NAMESPACE

@@ -0,0 +1,9 @@
+# Generated by roxygen2: do not edit by hand
+
+export(bps_list_domain)
+export(bps_list_subject)
+export(bps_list_table)
+import(httr2)
+importFrom(dplyr,as_tibble)
+importFrom(dplyr,case_when)
+importFrom(dplyr,mutate)

R/bps_list_domain.R

@@ -0,0 +1,45 @@
+#' Get list of domain
+#'
+#' @description Retrieve list of nation wide BPS domain.
+#' @param type Type to show domain
+#' @param ... Any acceptable WebAPI parameters: prov
+#' @param token App ID
+#'
+#' @examples
+#' \dontrun{
+#' bps_list_domain() # return all domains
+#' bps_list_domain(type = "prov")
+#' bps_list_domain(type = "kabbyprov", prov = 3200)
+#' }
+#'
+#' @import httr2
+#' @importFrom dplyr mutate case_when
+#' @export
+#'
+bps_list_domain <- function(type = "all", ..., token) {
+  if (missing(token)) token <- get_token()
+  allowed_type <- c("all", "prov", "kab", "kabbyprov")
+  match.arg(type, allowed_type)
+  resp <- build_query(service = "domain", token = token, type = type, ...) |>
+    req_perform()
+  if (resp_status(resp) != 200) {
+    stop(sprintf("Response status %s", resp_status(resp)))
+  } else {
+    body <- resp_body_json(resp)
+    if (body$status != "OK") {
+      stop(body$message)
+    } else {
+      data <- body$data[[2]] |>
+        build_dataframe() |>
+        mutate(level = "kota/kabupaten") |>
+        mutate(
+          level = case_when(
+            domain_id == "0000" ~ "nasional",
+            grepl("^.*00$", domain_id) ~ "provinsi",
+            TRUE ~ "kota/kabupaten"
+          )
+        )
+      return(data)
+    }
+  }
+}

R/bps_list_subject.R

@@ -0,0 +1,44 @@
+#' Get list of subject data
+#'
+#' @description Retrieve list of available subject data
+#' @param domain_id Domain id for single BPS website
+#' @param ... Any acceptable WebAPI parameters for subject data: page, subcat, lang
+#' @param token App ID
+#'
+#' @examples
+#' \dontrun{
+#' bps_list_subject(domain_id = 1100)
+#' }
+#'
+#' @import httr2
+#' @export
+#'
+bps_list_subject <- function(domain_id = "0000", ..., token) {
+  if (missing(token)) token <- get_token()
+  if (!grepl("^\\d{4}$", domain_id)) stop(message_domain())
+  query <- build_query(
+    service = "list",
+    model = "subject",
+    domain = domain_id,
+    ...
+  )
+  query_ready <- add_token(query, token)
+  resp <- req_perform(query_ready)
+  if (resp_status(resp) != 200) {
+    stop(message_resp_error(resp_status(resp)))
+  } else {
+    body <- resp_body_json(resp)
+    if (body$status != "OK") {
+      stop(body$message)
+    } else {
+      data <- build_dataframe(body$data[[2]])
+      meta <- body$data[[1]]
+      if (as.integer(meta$pages) == 1L) {
+        return(data)
+      } else {
+        data_more <- get_more_pages(query, meta$pages, token)
+        return(rbind(data, data_more))
+      }
+    }
+  }
+}

R/bps_list_table.R

@@ -0,0 +1,81 @@
+#' Get list of table
+#'
+#' @description Retrieve list of table based on model
+#' @param keyword Search parameter
+#' @param model Table model can be static or dynamic
+#' @param var Variable ID selected to display dynamic table data
+#' @param domain_id Domain id for single BPS website
+#' @param ... Any acceptable WebAPI for table: page, year, month, lang
+#' @param token App ID
+#'
+#' @examples
+#' \dontrun{
+#' bps_list_table(keyword = "penduduk")
+#' bps_list_table("penduduk", domain_id = "1100")
+#' }
+#'
+#' @import httr2
+#' @export
+#'
+bps_list_table <- function(
+    keyword,
+    model = "static",
+    var,
+    domain_id = "0000",
+    ...,
+    token
+  ) {
+  if (missing(token)) token <- get_token()
+  allowed_model <- c("static", "dynamic")
+  match.arg(model, allowed_model)
+  if (identical(model, "dynamic") & missing(var)) {
+    stop("Missing `var` argument for model dynamic")
+  }
+  if (identical(model, "static") & missing(keyword)) {
+    stop("Missing `keyword` argument for model static")
+  }
+  if (identical(model, "dynamic")) {
+    params <- list(model = model, var = var, domain = domain_id, ...)
+  }
+  if (identical(model, "static")) {
+    params <- list(model = model, keyword = keyword, domain = domain_id, ...)
+  }
+  arguments <- paste(
+    paste(
+      names(params),
+      sapply(params, c, USE.NAMES = FALSE),
+      sep = " = "
+    ),
+    collapse = ", "
+  )
+  params$model <- paste0(model, "table")
+  params$service <- "list"
+  query <- do.call(build_query, params)
+  query_ready <- add_token(query, token)
+  resp <- req_perform(query_ready)
+  if (resp_status(resp) != 200) {
+    stop(message_resp_error(resp_status(resp)))
+  } else {
+    body <- resp_body_json(resp)
+    if (body$status != "OK") {
+      stop(body$message)
+    } else {
+      if (body$`data-availability` != "available") {
+        stop(
+          sprintf("Not available data for: %s", arguments)
+        )
+      } else {
+        tryCatch(
+          {
+            data <- build_dataframe(body$data[[2]])
+            meta <- body$data[[1]]
+            message_snippet_tbl(arguments, meta)
+            return(data)
+          }, error = function(e) {
+            stop(e$message)
+          }
+        )
+      }
+    }
+  }
+}

R/utils.R

@@ -0,0 +1,90 @@
+#' Query builder
+#'
+#' @description Construct query for request
+#' @param service Service being used
+#' @param ... Any acceptable WebAPI parameters
+#' @param token App ID
+#'
+build_query <- function(service, ..., token = NULL) {
+  arg_params <- names(list(...))
+  arg_values <- unlist(list(...), use.names = FALSE)
+  paths <- arg_params |>
+    sapply(build_path, USE.NAMES = FALSE) |>
+    sprintf(arg_values) |>
+    paste(collapse = "/")
+  query <- request(base_uri()) |>
+    req_url_path_append(service) |>
+    req_url_path_append(paths)
+  if (!is.null(token)) {
+    query <- add_token(query, token)
+  }
+  return(query)
+}
+
+#' Path builder
+#'
+#' @description Construct path for query
+#' @param param Query parameter name
+#' @param value Query parameter value. Used if replace = FALSE
+#' @param replace Replacable value, default to TRUE
+#'
+build_path <- function(param, value = NULL, replace = TRUE) {
+  if (replace) value = "%s" else value
+  return(paste(param, value, sep = "/"))
+}
+
+#' Dataframe builder
+#'
+#' @description Construct tibble dataframe from list of JSON
+#' @param listdata List data from JSON
+#' @importFrom dplyr as_tibble
+#'
+build_dataframe <- function(listdata) {
+  rows <- lapply(listdata, function(row) {
+    row |>
+      unlist() |>
+      t() |>
+      dplyr::as_tibble()
+  })
+  return(do.call(rbind, rows))
+}
+
+#' Add token
+#'
+#' @description Add token to the end of query
+#' @param query Full query without token
+#' @param token App ID
+#'
+add_token <- function(query, token = get_token()) {
+  req_url_path_append(query, build_path("key", token, replace = FALSE))
+}
+
+#' Get token
+#'
+#' @description Handle missing token and get from system environment
+get_token <- function() {
+  token <- Sys.getenv("BPS_APP_ID")
+  if (token == "") stop(message_token()) else token
+}
+
+#' Retrieve more pages
+#'
+#' @description Add token to the end of query
+#' @param query Full query without token
+#' @param pages Number of pages
+#' @param token App ID
+#'
+get_more_pages <- function(query, pages, token = get_token()) {
+  data_more <- list()
+  for (i in 2L:as.integer(pages)) {
+    path <- build_path("page", as.character(i), replace = FALSE)
+    next_query <- query |>
+      req_url_path_append(path)
+    next_body <- next_query |>
+      add_token(token) |>
+      req_perform() |>
+      resp_body_json()
+    data_more[[i]] <- build_dataframe(next_body$data[[2]])
+  }
+  return(do.call(rbind, data_more))
+}

R/variables.R

@@ -0,0 +1,44 @@
+#' Base URI
+#'
+#' RestAPI service base URI
+#'
+base_uri <- function() {
+  return("https://webapi.bps.go.id/v1/api/")
+}
+
+#' Message for asking token
+#'
+#' Asking to BPS WebAPI token and registration message
+#'
+message_token <- function() {
+  url_regist = "https://webapi.bps.go.id/developer/register"
+  return(sprintf("Register to %s and use `bps_set_token()`", url_regist))
+}
+
+#' Message to refuse domain pattern
+#'
+#' Asking to input acceptable value for domain
+#'
+message_domain <- function() {
+  return("Not acceptable `domain_id`")
+}
+
+#' Message to request failure
+#'
+#' Return information about request failure
+#' @param status Response status
+#'
+message_resp_error <- function(status) {
+  return(sprintf("Response status %s", status))
+}
+
+#' Snippet message for list result
+#'
+#' Return information about list search result
+#' @param params string to key-value pair of arguments
+#' @param meta metadata from response
+#'
+message_snippet_tbl <- function(params, meta) {
+  message_tbl <- "Arguments: %s\nPage %i of %i. Use argument `page` to access."
+  message(sprintf(message_tbl, params, meta$page, meta$pages))
+}