R/code_writing.R

In iNZightTools: Tools for 'iNZight'

as_call <- function(x) {
    if (is.null(x)) {
        return(x)
    }

    if (inherits(x, "formula")) {
        stopifnot(length(x) == 2)
        x[[2]]
    } else if (is.atomic(x) || is.name(x) || is.call(x)) {
        x
    } else {
        stop("Unknown input")
    }
}

#' @importFrom methods substituteDirect
interpolate <- function(code, ..., comment = character(),
                        `_env` = parent.frame(2)) {
    if (length(list(...)) > 0) {
        args <- lapply(list(...), as_call)
        expr <- methods::substituteDirect(as_call(code), args)
    } else {
        expr <- as_call(code)
    }

    res <- eval(expr, `_env`)
    if (length(comment) > 0) {
        comment <- paste("##", comment)
    }
    attr(res, "code") <- c(comment, capture.output(expr))
    res
}


#' Used to grab code from a data.frame generated by this package.
#'
#' This is simply a helper function to grab the contents
#' of the `code` attribute contained in the data object.
#'
#' @title Get Data's Code
#' @param data dataset you want to extract the code from
#' @return The code used to generate the data.frame, if available (else NULL)
#' @author Tom Elliott
#' @export
code <- function(data) {
    code <- attr(data, "code")
    if (is.null(code)) {
        return(NULL)
    }
    class(code) <- c("inzcode", class(code))
    code
}

#' @export
print.inzcode <- function(x, ...) {
    c <- paste(x, collapse = " ")
    c <- tidy_all_code(c, ...)
    cat(c, sep = "\n")
    cat("\n")
    invisible(NULL)
}

#' Tidy-printing of the code attached to an object
#'
#' @param x a dataframe with code attached
#' @param ... additional arguments passed to tidy_all_code()
#' @return Called for side-effect of printing code to the console.
#' @export
#' @examples
#' iris_agg <- aggregate_data(iris, group_vars = "Species", summaries = "mean")
#' print_code(iris_agg)
print_code <- function(x, ...) {
    c <- code(x)
    if (is.null(c)) {
        message("No code attached to this object.")
        return(invisible(NULL))
    }

    print(c, ...)
}

replaceVars <- function(exp, ...) {
    sub_list <- list(...)
    exp_str <- as.character(exp)
    for (i in seq_along(sub_list)) {
        exp_str <- gsub(names(sub_list)[i],
            sub_list[i],
            exp_str,
            fixed = TRUE
        )
    }
    exp <- as.formula(paste(exp_str, collapse = " "))
    exp
}


pasteFormulae <- function(formulae, sep = " %>% ") {
    combined_formulae <- c()
    for (i in seq_along(formulae)) {
        combined_formulae[i] <- as.character(formulae[[i]])[2]
    }
    output_formula <- as.formula(
        paste("~",
            paste(combined_formulae, collapse = sep),
            collapse = " "
        )
    )
    output_formula
}


#' Create variable name
#'
#' Convert a given string to a valid R variable name,
#' converting spaces to underscores (_) instead of dots.
#'
#' @param x a string to convert
#' @return a string, which is also a valid variable name
#' @author Tom Elliott
#' @export
#' @examples
#' create_varname("a new variable")
#' create_varname("8d4-2q5")
create_varname <- function(x) {
    # create a valid R variable name from a given string
    x <- gsub("\\(|\\)", "", gsub(" ", "_", x))
    make.names(x)
}