Nothing
# @file Args.R
#
# Copyright 2022 Observational Health Data Sciences and Informatics
#
# This file is part of ParallelLogger
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#' Create an argument function
#'
#' @details
#' This function can be used to create a function that has (almost) the same interface as the
#' specified function, and the output of this function will be a list of argument values.
#'
#' @param functionName The name of the function for which we want to create an args function.
#' @param excludeArgs Exclude these arguments from appearing in the args function.
#' @param includeArgs Include these arguments in the args function.
#' @param addArgs Add these arguments to the args functions. Defined as a list with format name
#' = default.
#' @param rCode A character vector representing the R code where the new function should be
#' appended to.
#' @param newName The name of the new function. If not specified, the new name will be
#' automatically derived from the old name.
#'
#' @return
#' A character vector with the R code including the new function.
#'
#' @examples
#' createArgFunction("read.csv", addArgs = list(exposureId = "exposureId"))
#' @export
createArgFunction <- function(functionName,
excludeArgs = c(),
includeArgs = NULL,
addArgs = list(),
rCode = c(),
newName) {
args <- formals(functionName)
if (!is.null(includeArgs)) {
args <- args[names(args) %in% includeArgs]
}
args <- args[!(names(args) %in% excludeArgs)]
args <- append(args, addArgs)
toChar <- function(x) {
if (is.null(x)) {
"NULL"
} else if (is(x, "call")) {
paste(capture.output(x), collapse = "")
} else if (is(x, "character")) {
paste("\"", x, "\"", sep = "")
} else {
as.character(x)
}
}
args <- sapply(args, toChar)
argInfo <- data.frame(name = names(args))
argInfo$default <- NULL
for (i in 1:length(args)) {
argInfo$default[argInfo$name == names(args)[[i]]] <- args[[i]]
}
html <- capture.output(tools::Rd2HTML(.getHelpFile(help(functionName))))
argsStartPos <- grep("<h3>Arguments</h3>", html) + 1
tableEndPos <- grep("</table>", html)
argInfo$help <- ""
if (length(argsStartPos) == 1 && length(tableEndPos) > 0) {
argsEndPos <- min(tableEndPos[tableEndPos > argsStartPos])
parameterHelp <- xml2::read_html(paste(html[argsStartPos:argsEndPos], collapse = "\n"))
parameterHelp <- xml2::xml_find_all(parameterHelp, "//table//tr//td")
parameterHelp <- xml2::xml_text(parameterHelp)
parameterHelp <- iconv(parameterHelp, from = "UTF-8", to = "ASCII")
for (i in 1:(length(parameterHelp) / 2)) {
argInfo$help[argInfo$name == parameterHelp[i * 2 - 1]] <- gsub("\n", " ", parameterHelp[i * 2])
}
}
if (length(rCode) != 0) {
rCode <- c(rCode, "")
}
rCode <- c(rCode, paste("#' Create a parameter object for the function", functionName))
rCode <- c(rCode, "#'")
rCode <- c(rCode, "#' @details")
rCode <- c(rCode, "#' Create an object defining the parameter values.")
rCode <- c(rCode, "#'")
for (i in 1:nrow(argInfo)) {
rCode <- c(rCode, paste("#' @param", argInfo$name[i], argInfo$help[i]))
}
rCode <- c(rCode, "#'")
rCode <- c(rCode, "#' @export")
if (missing(newName)) {
createFunArgsName <- paste("create",
toupper(substr(functionName, 1, 1)),
substr(functionName, 2, nchar(functionName)),
"Args",
sep = ""
)
} else {
createFunArgsName <- newName
}
header <- paste(createFunArgsName, "<- function(")
for (i in 1:nrow(argInfo)) {
if (i == 1) {
start <- header
} else {
start <- paste(rep(" ", nchar(header)), collapse = "")
}
if (argInfo$default[i] == "") {
end <- ""
} else {
end <- paste(" = ", argInfo$default[i], sep = "")
}
if (i == nrow(argInfo)) {
end <- paste(end, ") {", sep = "")
} else {
end <- paste(end, ",", sep = "")
}
rCode <- c(rCode, paste(start, argInfo$name[i], end, sep = ""))
}
rCode <- c(rCode, " analysis <- list()")
rCode <- c(rCode, paste0(" for (name in names(formals(", createFunArgsName, "))) {"))
rCode <- c(rCode, " analysis[[name]] <- get(name)")
rCode <- c(rCode, " }")
rCode <- c(rCode, " class(analysis) <- \"args\"")
rCode <- c(rCode, " return(analysis)")
rCode <- c(rCode, "}")
return(rCode)
}
# copied from utils:::.getHelpFile because triple : not allowed
.getHelpFile <- function(file) {
path <- dirname(file)
dirpath <- dirname(path)
if (!file.exists(dirpath)) {
stop(gettextf("invalid %s argument", sQuote("file")), domain = NA)
}
pkgname <- basename(dirpath)
RdDB <- file.path(path, pkgname)
if (!file.exists(paste0(RdDB, ".rdx"))) {
stop(gettextf(
"package %s exists but was not installed under R >= 2.10.0 so help cannot be accessed",
sQuote(pkgname)
), domain = NA)
}
fetchRdDB(RdDB, basename(file))
}
# Copied from tools:::fetchRdDB
fetchRdDB <- function(filebase, key = NULL) {
fun <- function(db) {
vals <- db$vals
vars <- db$vars
datafile <- db$datafile
compressed <- db$compressed
envhook <- db$envhook
fetch <- function(key) lazyLoadDBfetch(vals[key][[1L]], datafile, compressed, envhook)
if (length(key)) {
if (!key %in% vars) {
stop(gettextf("No help on %s found in RdDB %s", sQuote(key), sQuote(filebase)), domain = NA)
}
fetch(key)
} else {
res <- lapply(vars, fetch)
names(res) <- vars
res
}
}
res <- lazyLoadDBexec(filebase, fun)
if (length(key)) {
res
} else {
invisible(res)
}
}
#' Select variables from a list of objects of the same type
#'
#' @param x A list of objects of the same type.
#' @param select A character vector of names of variables to select.
#'
#' @examples
#'
#' x <- list(
#' a = list(name = "John", age = 25, gender = "M"),
#' b = list(name = "Mary", age = 24, gender = "F")
#' )
#' selectFromList(x, c("name", "age"))
#'
#' # $a
#' # $a$name
#' # [1] "John"
#' #
#' # $a$age
#' # [1] 25
#' #
#' #
#' # $b
#' # $b$name
#' # [1] "Mary"
#' #
#' # $b$age
#' # [1] 24
#' @export
selectFromList <- function(x, select) {
return(sapply(x, function(x) {
x[names(x)[names(x) %in% select]]
}, simplify = FALSE))
}
#' Exclude variables from a list of objects of the same type
#'
#' @param x A list of objects of the same type.
#' @param exclude A character vector of names of variables to exclude.
#'
#' @export
excludeFromList <- function(x, exclude) {
return(sapply(x, function(x) {
x[names(x)[!(names(x) %in% exclude)]]
}, simplify = FALSE))
}
#' In a list of object of the same type, find those that match the input
#'
#' @details
#' Typically, toMatch will contain a subset of the variables that are in the objects in the list. Any
#' object matching all variables in \code{toMatch} will be included in the result.
#'
#' @param x A list of objects of the same type.
#' @param toMatch The object to match.
#'
#' @return
#' A list of objects that match the \code{toMatch} object.
#'
#' @examples
#' x <- list(
#' a = list(name = "John", age = 25, gender = "M"),
#' b = list(name = "Mary", age = 24, gender = "F")
#' )
#'
#' matchInList(x, list(name = "Mary"))
#'
#' # $a
#' # $a$name
#' # [1] "John"
#' #
#' # $a$age
#' # [1] 25
#' #
#' #
#' # $b
#' # $b$name
#' # [1] "Mary"
#' #
#' # $b$age
#' # [1] 24
#' @export
matchInList <- function(x, toMatch) {
selected <- selectFromList(x, names(toMatch))
result <- list()
for (i in 1:length(x)) {
if (isTRUE(all.equal(selected[[i]], toMatch))) {
result[[length(result) + 1]] <- x[[i]]
}
}
return(result)
}
convertAttrToMember <- function(object) {
if (is.function(object)) {
return(list(serialized_code = as.character(serialize(object, NULL))))
} else if (is.list(object)) {
if (length(object) > 0) {
for (i in 1:length(object)) {
if (!is.null(object[[i]])) {
object[[i]] <- convertAttrToMember(object[[i]])
}
}
}
a <- names(attributes(object))
a <- a[!a %in% c("names", "class")]
class <- class(object)
if (length(class) > 1 || class != "list") {
class(object) <- "list"
object$attr_class <- class
}
if (length(a) > 0) {
object[paste("attr", a, sep = "_")] <- attributes(object)[a]
}
}
return(object)
}
convertMemberToAttr <- function(object) {
if (is.list(object)) {
if (length(object) > 0) {
if (length(object) == 1 && !is.null(names(object)) && names(object) == "serialized_code") {
return(unserialize(as.raw(sapply(object$serialized_code, strtoi, base = 16L))))
}
for (i in 1:length(object)) {
if (!is.null(object[[i]])) {
object[[i]] <- convertMemberToAttr(object[[i]])
}
}
attrNames <- names(object)[grep("^attr_", names(object))]
cleanNames <- gsub("^attr_", "", attrNames)
if (any(cleanNames == "class")) {
class(object) <- object$attr_class
object$attr_class <- NULL
attrNames <- attrNames[attrNames != "attr_class"]
cleanNames <- cleanNames[cleanNames != "class"]
}
attributes(object)[cleanNames] <- object[attrNames]
object[attrNames] <- NULL
}
}
return(object)
}
#' Convert a settings object to a JSON string
#'
#' @details
#' Convert a settings object to a JSON string, using pretty formatting and preserving object classes
#' and attributes.
#'
#' @param object R object to be converted.
#'
#' @return
#' A JSON string representing the R object.
#'
#' @export
convertSettingsToJson <- function(object) {
object <- convertAttrToMember(object)
json <- jsonlite::toJSON(object, pretty = TRUE, force = TRUE, null = "null", auto_unbox = TRUE)
return(json)
}
#' Save a settings object as JSON file
#'
#' @details
#' Save a setting object as a JSON file, using pretty formatting and preserving object classes and
#' attributes.
#'
#' @param object R object to be saved.
#' @param fileName File name where the object should be saved.
#'
#' @export
saveSettingsToJson <- function(object, fileName) {
fileName <- normalizePath(fileName, mustWork = FALSE)
json <- convertSettingsToJson(object)
write(json, fileName)
}
#' Converts a JSON string to a settings object
#'
#' @details
#' Converts a JSON string generated using the \code{\link{convertSettingsToJson}} function to a
#' settings object, restoring object classes and attributes.
#'
#' @param json A JSON string.
#'
#' @return
#' An R object as specified by the JSON.
#'
#' @export
convertJsonToSettings <- function(json) {
object <- jsonlite::fromJSON(json, simplifyVector = TRUE, simplifyDataFrame = FALSE)
object <- convertMemberToAttr(object)
# object <- restoreDataFrames(object)
return(object)
}
#' Load a settings object from a JSON file
#'
#' @details
#' Load a settings object from a JSON file, restoring object classes and attributes.
#'
#' @param fileName Name of the JSON file to load.
#'
#' @return
#' An R object as specified by the JSON.
#'
#' @export
loadSettingsFromJson <- function(fileName) {
fileName <- normalizePath(fileName)
if (!file.exists(fileName))
stop(sprintf("File '%s' not found", fileName))
json <- readChar(fileName, file.info(fileName)$size)
object <- convertJsonToSettings(json)
return(object)
}
# restoreDataFrames <- function(object) {
# if (is.list(object)) {
# if (length(object) > 0) {
# if (is(object[[1]], "data.frame")) {
# object <- do.call("rbind", object)
# } else {
# for (i in 1:length(object)) {
# if (!is.null(object[[i]])) {
# object[[i]] <- restoreDataFrames(object[[i]])
# }
# }
# }
# }
# }
# return(object)
# }
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.