# Private Auxiliar functions. -------------------------- Not exposed in
# the public package API.
nullToNA <- function(x) {
x[unlist(lapply(x, is.null))] <- NA
x
}
urlEncode <- function(value) {
if (is.null(value)) {
out <- "null"
} else {
out <- switch(mode(value), character = paste0("\"", utils::URLencode(value),
"\""), logical = tolower(as.character(value)), value)
}
out
}
buildQueryConditions <- function(conditionList = NULL) {
if (is.null(conditionList)) {
return(NA)
}
res <- "conditions={"
prefix <- ""
for (i in 1:length(conditionList)) {
res <- paste0(res, prefix, conditionList[i])
prefix = ","
}
paste0(res, "}")
}
# encode a dataframe to a CSV string
df2csv <- function(df) {
lines <- utils::capture.output(utils::write.csv(df, stdout(), row.names = FALSE,
na = ""))
paste(lines, collapse = "\n")
}
# add quotes if text contains comma or quotes also double escape quotes
# if present
protectCommas <- function(data) {
if (grepl(",|\"", data)) {
data2 <- gsub("\"", "\"\"", data) # escape quote (') as ('')
return(paste0("\"", data2, "\"")) # wrap on quotes
}
data
}
# encode literal for CSV
quote4csv <- function(data) {
if (is.logical(data)) {
data <- ifelse(data, "true", "false")
} else {
data <- protectCommas(paste0("", data))
}
data
}
privateImport <- function(cnx, csvData, validateOnly = TRUE) {
urlbase <- httr::handle(cnx[[1L]])
aut <- httr::authenticate(cnx[[2L]], cnx[[3L]])
url <- "/api/import/dataset"
mime <- httr::add_headers(`content-type` = "text/csv")
txtData <- ifelse(is.data.frame(csvData), df2csv(csvData), csvData)
if (validateOnly) {
url <- paste0(url, "?validateOnly=true")
}
httr::with_config(aut, httr::with_config(mime, q1 <- httr::POST(path = url,
body = txtData, encode = "raw", handle = urlbase)))
out <- httr::content(q1, type = "application/json")
if(is.list(out) == FALSE){
message("The web has a 404 or 505 error")
} else{
out
}
}
privateDeleteDatasetById <- function(cnx, datasetId) {
urlbase <- httr::handle(cnx[[1L]])
aut <- httr::authenticate(cnx[[2L]], cnx[[3L]])
url <- "/api/dataSets/deleteByIds"
mime <- httr::add_headers(`content-type` = "application/json")
payload <- paste0('["', datasetId, '"]')
httr::with_config(aut, httr::with_config(mime, q1 <- httr::POST(path = url,
body = payload,
encode = "raw",
handle = urlbase)))
httr::content(q1, type = "application/json")
message(paste(httr::http_status(q1)$message))
}
#### Conversion to dataframe ####
## Converts the list of data the traitbase returs into a data frame.
toDataframe <- function(response) {
##
responseNA <- lapply(
lapply(response, nullToNA),
## _links is the only list so I remove it here
Filter, f = Negate(is.list)
)
if (length(responseNA)) {
nm <- unique(unlist(lapply(responseNA, names)))
## add names if missing + rbind
out <- as.data.frame(
do.call(rbind,
lapply(
lapply(responseNA, addNames, nm),
do.call, what = cbind
)
)
)
class(out) <- c("tbl_df", "tbl", "data.frame")
} else out <- NULL
##
out
}
addNames <- function(x, nm) {
tmp <- setdiff(nm, names(x))
if (!is.null(tmp)) x[tmp] <- NA
x[order(names(x))]
}
## parse _links columns
parseLinks <- function(response) {
if (length(response)) {
## NB _links is the only list
out <- as.data.frame(
do.call(
rbind,
lapply(
lapply(response, Filter, f = is.list),
unlist)
)
)
names(out) <- gsub("_links.", "", names(out), fixed = TRUE)
class(out) <- c("tbl_df", "tbl", "data.frame")
} else out <- NULL
out
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.