#' Generate sample params object using defaults specified in Rmd file
#'
#' Can also be used to create an inputs.json file that can then be modified with other paramter values
#'
#' @param rmd_filename the analysis template to use
#' @param save_as the json filename to save the resulting params to
#' @return the params object
#'
#' @export
#' @importFrom knitr knit_params
#' @importFrom jsonlite toJSON
params_from_rmd <- function(rmd_filename, save_as=NULL){
lines <- readLines(rmd_filename, warn = FALSE)
params_raw <- knit_params(lines)
# pull out defaults
params <- list()
for (param in params_raw) {
params[[param$name]] <- param$value
}
# pull out default script params
script_params_raw <- params$script_params
script_params <- lapply(script_params_raw, `[[`, "value")
names(script_params) <- names(script_params_raw)
params$script_params <- script_params
if(!is.null(save_as)){
params_json <- toJSON(params)
writeLines(params_json, save_as)
}
return(params)
}
#' Script helpers
#'
#' Get relevant objects from script parameters
#' @param params_object the object to use, defaults to the global \code{params} object
#' @export
#'
#' @importFrom stringr str_extract str_to_lower
#' @importFrom data.table setDT
#' @rdname script_helpers
get_tl_data <- function(params_object = NULL){
if(is.null(params_object)){
params_object <- get("params", envir=parent.frame())
}
uri <- params_object$data$uri
#check if file exists before proceeding (but not for web urls)
if(!(file.exists(uri)||grepl("^http(s)*://",uri))){
stop('File does not exist: ', uri)
}
extension <- str_to_lower(str_extract(uri,"\\.([^\\.]+)$"))
if(extension==".csv"){
data <- fread(uri)
} else if(extension==".rds"){
data <- readRDS(uri)
setDT(data)
} else if(extension==".rdata"){
vars <- load(file(uri, "rb"))
#use first object that's a data.frame
dfs <- sapply(vars,function(var)is.data.frame(get(var)))
if(length(which(dfs))==0){
stop("rdata file does not contain a data frame")
}
var <- vars[which(dfs)][1]
data <- get(var)
setDT(data)
} else {
stop("unrecognized data file extension: ",extension)
}
return(data)
}
#' @rdname script_helpers
#' @export
get_tl_nodes <- function(params_object = NULL){
if(is.null(params_object)){
params_object <- get("params", envir=parent.frame())
}
nodes <- params_object$nodes
data <- get_tl_data(params_object=params_object)
missing_cols <- setdiff(unlist(nodes), colnames(data))
if(length(missing_cols) > 0){
stop('Column(s) missing from data: ', missing_cols)
}
#drop exclude list
nodes$exclude <- NULL
return(nodes)
}
#' @rdname script_helpers
#' @export
get_tl_params <- function(params_object = NULL){
if(is.null(params_object)){
params_object <- get("params", envir=parent.frame())
}
script_params <- params_object$script_params
# in rstudio these get passed in from YAML not as their value,
# but as the whole object, so subset value if that's what we have
values <- lapply(script_params, function(script_param){
if(is.list(script_param)){
return(script_param$value)
} else {
return(NULL)
}
})
if(any(sapply(values,is.null))){
return(script_params)
} else {
return(values)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.