FILENAME <- c("R/generated_client.R")
#' Fetches and generates the client in generated_client.R
#'
#' @details
#' Skips autogeneration on windows with R < 3.4.0 and if R_CLIENT_DEV == "TRUE".
#' A valid CIVIS_API_KEY must be set.
fetch_and_generate_client <- function() {
if (Sys.getenv("R_CLIENT_DEV") != "TRUE" && windows_r_version_is_valid()) {
message("Generating API")
tryCatch({
requireNamespace('roxygen2', quietly = TRUE)
api_key()
spec <- get_spec()
client_str <- generate_client(spec)
write_client(client_str, FILENAME = FILENAME)
roxygen2::roxygenise('.')
}, error = function(e) {
message(e)
message("\nGenerating API failed, reverting to default.")
})
} else {
message("Skipping client generation")
}
}
windows_r_version_is_valid <- function(major = 3, minor = 3.4) {
valid <- TRUE
if (.Platform$OS.type == "windows") {
valid <- as.numeric(R.version$major) >= major && as.numeric(R.version$minor) >= minor
}
if (!valid) message("Autogenerating API on Windows requires R > 3.4.0")
valid
}
get_spec <- function() {
call_api("get", path = "/endpoints/", list(), list(), list())
}
write_client <- function(client_str, FILENAME) {
cat("", file = FILENAME)
cat(client_str, file = FILENAME, append = TRUE)
}
#' Generate a client
#' @param spec usually from \code{get_spec}
#' @return A string containing one documented function for each verb at each endpoint.
generate_client <- function(spec) {
client_str <- ""
paths <- spec[["paths"]]
for (i in seq_along(paths)) {
path <- paths[[i]]
for (j in seq_along(path)) {
verb <- path[[j]]
verb <- replace_ref(verb, spec, previous_ref = "")
params <- parse_params(verb)
path_name <- names(paths)[i]
verb_name <- names(path)[j]
docs <- build_docs(verb)
name <- build_function_name(verb_name, path_name)
args <- build_function_args(params)
body <- build_function_body(verb, verb_name, path_name, params)
client_str <- paste0(client_str, docs, name, args, body, "\n\n")
}
}
client_str
}
build_function_body <- function(verb, verb_name, path_name, params) {
has_params <- length(params) > 0
path_params <- if (has_params) with(params, name[http_location == "path"]) else NULL
query_params <- if (has_params) with(params, name[http_location == "query"]) else NULL
body_params <- if (has_params) with(params, name[http_location == "body"]) else NULL
path_param_str <- if (length(path_params) > 0) paste0(path_params, " = ", camel_to_snake(path_params), collapse = ", ") else ""
query_param_str <- if (length(query_params) > 0) paste0(query_params, " = ", camel_to_snake(query_params), collapse = ", ") else ""
body_param_str <- if (length(body_params) > 0) paste0(body_params, " = ", camel_to_snake(body_params), collapse = ", ") else ""
paste0(
" args <- as.list(match.call())[-1]\n",
" path <- \"", path_name, "\"\n",
" path_params <- list(", path_param_str, ")\n",
" query_params <- list(", query_param_str, ")\n",
" body_params <- list(", body_param_str, ")\n",
" path_params <- path_params[match_params(path_params, args)]\n",
" query_params <- query_params[match_params(query_params, args)]\n",
" body_params <- body_params[match_params(body_params, args)]\n",
" resp <- call_api(\"", toupper(verb_name), "\", path, path_params, query_params, body_params)\n\n",
" return(resp)\n\n }\n"
)
}
build_function_args <- function(params) {
default_arg <- ifelse(params$required, "", " = NULL")
arg_str <- paste0(camel_to_snake(params$name), default_arg, collapse = ", ")
paste0(" <- function(", arg_str, ") {\n\n")
}
#' @importFrom utils tail
build_function_name <- function(verb_name, path_name) {
parts <- strsplit(path_name, "/")[[1]]
parts <- parts[parts != '']
parts <- gsub("-", "_", parts)
args <- tail(parts, -1)
sig <- NULL
for (i in seq_along(args)) {
prev <- if (i > 1) args[i - 1] else NULL
if (!bracketed(args[i])) {
sig <- paste0(c(sig, args[i]), collapse = "_")
} else if (!is.null(prev) && bracketed(prev)) {
sig <- paste0(sig, gsub("\\{|\\}", "", prev), collapse = "_")
}
}
if (!endsWith(path_name, "}") & verb_name == "get") verb_name <- "list"
paste(c(parts[1], verb_name, sig), collapse = "_")
}
bracketed <- function(x) grepl("\\{|\\}", x)
build_docs <- function(verb) {
title <- sprintf("#' %s\n", verb$summary)
param_docs <- build_params_docs(verb)
resp_docs <- build_resp_docs(verb)
doc_str <- escape_percent(paste0(title, param_docs, "#' \n", resp_docs, "#' @export\n"))
return(doc_str)
}
build_params_docs <- function(verb) {
params <- verb$parameters
doc_str <- ""
params <- params[order(sapply(params, function(x) x$required), decreasing = T)]
if (length(params) > 0) {
for (i in seq_along(params)) {
param <- params[[i]]
if (is_obj(param)) {
p <- get_obj_properties(param)
req <- param$schema$required
if (!is.null(req)) {
# see scripts_post_sql
preq <- p[names(p) %in% req]
doc_str <- paste0(doc_str,
write_properties(preq, "required", transform_name = camel_to_snake))
popt <- p[!(names(p) %in% req)]
doc_str <- paste0(doc_str,
write_properties(popt, "optional", transform_name = camel_to_snake))
} else {
doc_str <- paste0(doc_str,
write_properties(p, get_req_str(param), transform_name = camel_to_snake))
}
} else if (is_array(param)) {
p <- get_array_properties(param)
doc_str <- paste0(doc_str,
write_properties(p, get_req_str(param), transform_name = camel_to_snake))
} else {
name <- camel_to_snake(param$name)
doc_str <- paste0(doc_str,
sprintf("#' @param %s %s %s. %s", name,
param$type, get_req_str(param), get_descr_str(param)),
"\n")
}
}
}
doc_str
}
build_resp_docs <- function(verb) {
# The magic number '1' works because only a successful return (a 200-level code) is documented.
# can be 200, 201, 202, 204.
resp <- verb$responses[[1]]
doc_str <- ""
if (length(resp) > 1) {
if (is_array(resp)) {
p <- get_array_properties(resp)
doc_str <- paste0(doc_str, " An array containing the following fields:\n",
write_properties(p, fmt = "#' \\item{%s}{%s, %s%s}"))
} else if (is_obj(resp)) {
p <- get_obj_properties(resp)
doc_str <- paste0(doc_str, " A list containing the following elements:\n",
write_properties(p, fmt = "#' \\item{%s}{%s, %s%s}"))
} else {
doc_str <- "An undocumented HTTP response\n"
}
} else {
doc_str <- " An empty HTTP response\n"
}
paste0("#' @return ", doc_str)
}
write_properties <- function(x, req_str="", fmt="#' @param %s %s %s. %s",
doc_str="", transform_name = I) {
for (j in seq_along(x)) {
if (is_nested(x[[j]])) {
descr_str <- write_nested_docs(x[[j]])
} else {
descr_str <- get_descr_str(x[[j]])
}
name <- transform_name(names(x)[j])
type <- translate_type(x[[j]]$type)
doc_str <- paste0(doc_str,
sprintf(fmt, name, type, req_str, descr_str), "\n")
}
doc_str
}
write_nested_docs <- function(x) {
doc_str <- ""
fmt <- "#' \\item %s %s, %s"
if (is_array(x)) {
ps <- get_array_properties(x)
doc_str <- paste0(doc_str,
"An array containing the following fields: \n#' \\itemize{\n")
for (i in seq_along(ps)) {
doc_str <- paste0(doc_str, sprintf(fmt, names(ps)[i], ps[[i]]$type,
get_descr_str(ps[[i]])), "\n")
}
doc_str <- paste0(doc_str, "#' }")
} else if (is_obj(x) & (length(get_obj_properties(x)) > 0)) {
ps <- get_obj_properties(x)
doc_str <- paste0(doc_str,
"A list containing the following elements: \n#' \\itemize{\n")
for (i in seq_along(ps)) {
if(is_obj(ps[[i]])) {
doc_str <- paste0(doc_str, write_properties(ps[i], fmt = "#' \\item %s %s %s. %s"))
} else {
doc_str <- paste0(doc_str,
sprintf(fmt, names(ps)[i], ps[[i]]$type, get_descr_str(ps[[i]])), "\n")
}
}
doc_str <- paste0(doc_str, "#' }")
}
doc_str
}
parse_params <- function(verb, spec) {
params <- verb$parameters
arg_names <- location <- required <- description <- type <- list()
for (i in seq_along(params)) {
param <- params[[i]]
# Case 1: param is an obj
if (!is.null(param$schema)) {
properties <- param$schema$properties
for (j in seq_along(properties)) {
arg_names <- c(arg_names, names(properties)[[j]])
descr_str <- get_descr_str(properties[[j]])
description <- c(description, descr_str)
type <- c(type, properties[[j]]$type)
location <- c(location, param$`in`)
}
required <- c(required, names(properties) %in% unlist(param$schema$required))
} else {
# Case 2: param is a list.
arg_names <- c(arg_names, param$name)
descr_str <- get_descr_str(param)
description <- c(description, descr_str)
type <- c(type, param$type)
location <- c(location, param$`in`)
required <- c(required, param$required)
}
}
df <- data.frame(name = unlist(arg_names),
http_location = unlist(location),
required = unlist(required),
description = unlist(description),
type = unlist(type), stringsAsFactors = FALSE)
# Put required arguments first.
if (length(df) > 0) df <- df[order(df$required, decreasing = TRUE), ]
df
}
# ----- References -----
# works for:
# replace_ref(verb$parameters[[1]], spec)
# replace_ref(verb$responses, spec)
replace_ref <- function(x, spec, previous_ref = "") {
x_replaced <- list()
for (i in seq_along(x)) {
val <- x[[i]]
key <- names(x)[i]
key <- if (is.null(key)) i else key
if (is_ref(val)) {
if (!same_ref(previous_ref, val)) {
ref_val <- get_ref(val, spec)
x_replaced[[key]] <- replace_ref(ref_val, spec = spec, previous_ref = val)
} else {
#x_replaced[[key]] <- val
}
} else if (is.list(val)) {
x_replaced[[key]] <- replace_ref(val, spec = spec, previous_ref = previous_ref)
} else {
x_replaced[[key]] <- val
}
}
return(x_replaced)
}
translate_type <- function(type_string) {
if (type_string == "object") "list" else type_string
}
is_ref <- function(x) {
"$ref" %in% names(x)
}
same_ref <- function(parent, child) {
if (is_ref(parent) & is_ref(child)) parent$`$ref` == child$`$ref` else FALSE
}
# ref is a list with key="$ref" and value="#/definitions/Objectx"
get_ref <- function(ref, spec) {
ref <- ref[which(names(ref) == "$ref")] # see ex5
ref_path <- strsplit(unlist(ref), "/")[[1]]
ref_path <- ref_path[-1] # the first portion of the path is `#`
spec[[ref_path]]
}
# ----- Utils -----
is_nested <- function(x) { is_array(x) | is_obj(x) }
is_array <- function(x) {
if (!is.null(x$schema)) {
flag <- (x$schema$type == "array") & (!is.null(x$schema$items$properties))
} else if (!is.null(x$type)) {
flag <- (x$type == "array") & !is.null(x$items$properties)
} else {
flag <- FALSE
}
flag
}
is_obj <- function(x) {
if (!is.null(x$schema)) {
flag <- (x$schema$type == "object" & !is.null(x$schema$properties))
} else if (!is.null(x$type)) {
flag <- (x$type == "object" & !is.null(x$properties))
} else {
flag <- FALSE
}
flag
}
get_descr_str <- function(x) {
desc <- if (!is.null(x$description)) x$description else ""
gsub("\n[[:space:]]*", " ", desc)
}
get_req_str <- function(x) {
doc_str <- ""
if (!is.null(x$required)) {
doc_str <- if (x$required) "required" else "optional"
}
doc_str
}
get_array_properties <- function(x) {
if (!is.null(x$schema)) x$schema$items$properties else x$items$properties
}
get_obj_properties <- function(x) {
if (!is.null(x$schema)) x$schema$properties else x$properties
}
returns_array <- function(verb, verb_name, path_name) {
if (verb_name == "get" & !endsWith(path_name, "}")) return(TRUE)
rtype <- verb$responses[[1]]$schema$type
if (!is.null(rtype) && (rtype == "array")) return(TRUE)
return(FALSE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.