R/utils.R

In nachocab/clickme: Straight from R to JS: Create interactive visualizations from R

is_integer <- function(x){
    x %% 1 == 0
}

#' Return a C-style format given the type of data
#'
#' Ex: ".2f" for decimal values, "s" for everything else
#' It also allows to set a custom format
#'
#' @export
#' @keywords internal
get_tooltip_format <- function(variable_value){
    if (is.numeric(variable_value) && any(!is_integer(variable_value))) {
        format <- ".2f"
    } else {
        format <- "s"
    }
    format
}

# Create a dataframe by rows instead of by column
#' @export
data.frame.by.rows <- function(...){
    dots <- list(...)
    row.names <- dots$row.names; dots$row.names <- NULL
    check.rows <- dots$check.rows; dots$check.rows <- NULL
    check.names <- dots$check.names; dots$check.names <- NULL
    stringsAsFactors <- dots$stringsAsFactors; dots$stringsAsFactors <- NULL
    as.data.frame(do.call(rbind, dots), row.names = row.names,
                                        check.rows = check.rows,
                                        check.names = check.names,
                                        stringsAsFactors = stringsAsFactors)
}

#' Returns NULL if the list is empty
#'
#' @export
null_if_empty <- function(input_list){
    if (length(input_list))
        input_list
    else
        NULL
}

get_attrs <- function(my_list, names){
    lapply(my_list, function(line) {
        lapply(line, function(x) x[names])
    })
}

#' Extract function names from a list of placeholder expressions
#' @export
#' @keywords internal
extract_functions <- function(expressions){
    functions <- as.character(na.omit(str_match(expressions, "^\\s*(([[:alpha:]]|[.][._[:alpha:]])[._[:alnum:]]*)\\(.+|\\n\\)")[,2]))
    functions
}

#' Title Case
#' @export
title_case <- function(strings){
    first_letter <- toupper(substring(strings, 1, 1))
    everything_else <- substring(strings, 2, nchar(strings))
    title_case <- paste0(first_letter, everything_else)
    title_case
}

#' Convert to CamelCase
#' @export
camel_case <- function(strings){
    strings <- gsub("_", ".", strings)
    strings <- strsplit(strings, "\\.")
    strings <- sapply(strings, title_case, simplify = FALSE)
    camel_case <- sapply(strings, paste, collapse = "")
    camel_case
}

#' Convert to snake_case
#' @export
snake_case <- function(strings){
    strings <- gsub("^[^[:alnum:]]+|[^[:alnum:]]+$", "", strings)
    strings <- gsub("(?!^)(?=[[:upper:]])", " ", strings, perl = TRUE)
    strings <- strsplit(tolower(strings), " ")
    snake_case <- sapply(strings, paste, collapse = "_")
    snake_case
}

#' @export
is.valid <- function(x){
    !is.na(x) & !is.nan(x) & !is.infinite(x)
}

separator <- function(n = 70){
    paste0(rep("=", n, collapse = ""))
}

#' Split up two vectors into their intersecting sets
#' @param a first vector
#' @param b second vector
#'
#' It returns a list of three elements, those that are only in a, those that are in both, and those that are only in b.
#'
#' @export
disjoint_sets <- function(a, b, names = c("a", "b", "both")) {
    sets <- list(setdiff(a,b), setdiff(b,a), intersect(a,b))
    names(sets) <- names
    sets
}

# move elements to the front of an array
move_in_front <- function(first_elements, all_elements) {
    if (any(first_elements %notin% all_elements)){
        stop(sprintf("\n\tThe following elements don't appear in \"%s\":\n%s\n",
             deparse(substitute(all_elements)),
             enumerate(first_elements[any(first_elements %notin% all_elements)])), call. = FALSE)
    }
    all_elements <- all_elements[c(which(all_elements %in% first_elements), which(all_elements %notin% first_elements))]
    all_elements
}

error_title <- function(message){
    paste0("\n\n*** ", message, " ***\n\n")
}

#' Return the elements of a character vector separated by newlines
#'
#' @export
enumerate <- function(x) {
    paste0("\t", x, collapse = "\n")
}

#' Match elements to groups
#' @param subset vector of elements
#' @param groups list of groups
#' @param replace_nas how to handle elements that don't appear in any of the groups. If a string is provided, it uses it as a new group for these elements.
#' @param strict_dups how to handle elements that appear in multiple groups. By default, the first matching group is reported and a warning is issued. If TRUE, it raises an error.
#'
#' It returns the name of the group where each element in the subset appears. If not in any group, it combines them into the "other " group (intentional space, in case "other" exists)
#'
#' @export
match_to_groups <- function(subset, groups, replace_nas = "Other", strict_dups = FALSE) {
    if (any(duplicated(unlist(groups)))){
        duplicated_elements <- unname(unlist(groups)[duplicated(unlist(groups))])
        message <- sprintf("\tThe following elements appear in more than one group:\n%s", paste(duplicated_elements, collapse = "\n"), "\n")
        if (strict_dups){
            stop(message, call. = FALSE)
        } else {
            message(message)
        }
    }

    group_ranges <- cumsum(c(1, sapply(groups, length)))
    match_indexes <- match(subset, unlist(groups))
    group_indexes <- findInterval(match_indexes, group_ranges)
    group_names <- names(groups)[group_indexes]

    if (!is.null(replace_nas)){
        group_names[is.na(group_names)] <- replace_nas
    }

    group_names
}


#' Classify the elements of a vector into Venn categories
#' @export
vennize <- function(a, b, only_in_a = "Only in A", only_in_b = "Only in B", in_both = "In both") {
    results <- list()
    results[[only_in_a]] <- setdiff(a,b)
    results[[in_both]] <- intersect(a,b)
    results[[only_in_b]] <- setdiff(b,a)

    results
}

percentage <- function(x){
    x/sum(x)*100
}

#' Return the levels of a factor, or the unique elements of a character vector
#' @param elements values
#' @export
get_unique_elements <- function(elements) {
    if (is.factor(elements)){
        unique_elements <- levels(elements)
    } else {
        unique_elements <- unique(elements)
    }

    unique_elements <- na.omit(unique_elements)
    unique_elements
}

#' Remove whitespace from a string
#'
#'
no_whitespace <- function(str){
    gsub("\\s","", str)
}

#' Sample with replacement
#'
#' @export
sample_r <- function(input, n){
    sample(input, n, replace = TRUE)
}

#' Type of scale
#'
#' @param elements values
#'
#' Quantitative scales are treated differently than categorical scales by D3.
#' If elements is numeric and has a length greater than one, it returns "quantitative".
#' If elements is NULL, or not numeric, or has a length of one, it returns "categorical".
#'
#' @export
scale_type <- function(elements) {
    if (!is.null(elements) && is.numeric(elements) && length(elements) > 1){
        type <- "quantitative"
    } else {
        type <- "categorical"
    }

    type
}



#' Default colors
#'
#' @param n number of colors
#'
#' @export
default_colors <- function(n){
    # too similar purples: "#9467bd", "#8c564b"
    retro_tulips <- c(
      "#0F808C", # blue
      "#6C8C26", # green
      "#F2A71B", # orange
      "#F26A1B", # dark orange
      "#D91818" # red
    )

    set3 <- c(
        "#FB8072", # red
        "#80B1D3", # blueish
        "#B3DE69", # green
        "#FDB462", # orange
        "#8DD3C7", # teal green
        "#FFFFB3", # yellow
        "#BEBADA", # grey
        "#FCCDE5", # salmon
        "#D9D9D9" # lightgrey
    )

    d3_category9 <- c(
                       "#24A5F9", # blue
                       "#d62728", # red
                       "#ff7f0e", # orange
                       "#9467bd", # purple
                       "#3CCB23", # green
                       "#E027E4", # pink
                       "#5711AC", # plum
                       "#bcbd22" # pale olive
                       )
    # d3_category10 <- c("#1f77b4", "#d62728", "#2ca02c", "#ff7f0e", "#9467bd", "#17becf", "#8c564b", "#e377c2", "#7f7f7f", "#bcbd22")
    d3_category19 <- c(d3_category9, "#aec7e8","#ffbb78","#98df8a","#ff9896","#c5b0d5","#c49c94","#f7b6d2","#c7c7c7","#dbdb8d","#9edae5")
    # d3_category10b <- c("#aec7e8", "#ffbb78", "#98df8a", "#ff9896", "#c5b0d5", "#c49c94", "#f7b6d2", "#c7c7c7", "#dbdb8d", "#9edae5")
    if (n <= 9){
        colors <- d3_category9[1:n]
    } else if (n <= 19) {
        colors <- d3_category19[1:n]
    } else {
        colors <- gsub("..$", "", rainbow(n)) # d3 doesn't like the transparency bytes #000000FF, so we remove them
    }
    colors
}

#' @export
is_coffee_installed <- function() {
    system("coffee -v", ignore.stdout = TRUE, ignore.stderr = TRUE) == 0
}

readContents <- function(path) {
    paste(readLines(path, warn = FALSE), collapse = "\n")
}

#' Inverse Value Matching
#'
#' Complement of \code{\%in\%}. Returns the elements of \code{a} that are not in \code{b}.
#' @usage a \%notin\% b
#' @param a a vector
#' @param b a vector
#' @export
#' @rdname notin
"%notin%" <- function(a, b) {
    !(a %in% b)
}

# this operator has low priority (use parentheses)
#' Set default value
#'
#' If a is not null, return a. Otherwise, return b.
#' @usage a \%||\% b
#' @param a an object
#' @param b an object
#' @export
#' @rdname nulldefault
#' @examples
#' a <- "a"
#' b <- "b"
#' d <- a %or% b # d == "a"
#' a <- NULL
#' d <- a %or% b # d == "b"
"%or%" <- function(a, b) {
  if (!is.null(a)) a else b
}

is.installed <- function(package) {
    is.element(package, installed.packages()[,1])
}

#' Surround with escaped quotes
#'
#' @param data object to surround with escaped quotes
#' @export
quote_escaped <- function(data) {
    paste0("\"", data, "\"")
}

#' Run a local server
#'
#' @param path path where server is started
#' @param port port used to start the server
#' @export
server <- function(path = getOption("clickme_templates_path"), port = 8000){
    system(paste0("cd ", path, "; python -m SimpleHTTPServer ", port))
    message("Server running at ", path)
}

#' Test the translator of a given template
#'
#' @param template name of template
#' @export
test_template <- function(template_name, filter = NULL){
    if (!is.character(template_name))
        template_name <- as.character(substitute(template_name))

    template <- Chart$new()
    template$internal$file$names$template <- camel_case(template_name)
    template$get_default_names_and_paths()

    library("testthat")
    reload_translators()
    env <- new.env()
    with_envvar(r_env_vars(), test_dir(template$internal$file$paths$tests, filter = filter, env = env))
}

source_dir <- function(path){
    # This order ensures that Points.R comes before Points-helper.R
    files <- sort(list.files(path, full.names = TRUE), decreasing = TRUE)
    sapply(files, source)
}

mat <- function(elements = NULL, num_elements = nrow*ncol, nrow = 5, ncol = 2, scale_by = 100, rownames = NULL, colnames = NULL){
    if (is.null(elements)){
        elements <- runif(num_elements) * scale_by
    }
    if (!is.null(ncol)){
        mat <- matrix(elements, ncol = ncol, byrow = T)
    } else {
        mat <- matrix(elements, nrow = nrow, byrow = T)
    }

    if (!is.null(rownames)) rownames(mat) <- rownames
    if (!is.null(colnames)) colnames(mat) <- colnames

    mat
}

#' Show which templates are available
#'
#' @export
list_templates <- function() {
    message("Available templates at: ", getOption("clickme_templates_path"))
    write(plain_list_templates(), "")
}

plain_list_templates <- function() {
    basename(list.dirs(getOption("clickme_templates_path"), recursive = F))
}


titleize <- function(str){
    str <- str_replace(str,"_"," ")
    words_in_str <- strsplit(str, " ")[[1]]
    title <- paste0(toupper(substring(words_in_str, 1, 1)), substring(words_in_str, 2), collapse=" ")
    names(title) <- NULL
    title
}

#' Open an HTML file in the browser
#'
#' By default it will open \code{get_opts(template)$url}
#'
#' @param template template name
#' @param ... additional fields for \code{get_opts}
#' @export
open_html <- function(template, ...) {
    opts <- get_opts(template, ...)
    browseURL(opts$url)
}

open_all_html <- function(){
    for (template in plain_list_templates()){
        open_html(template)
    }
}

open_all_demos <- function(){
    for (template in plain_list_templates()){
        demo_template(template)
    }
}

#' Run a template demo
#'
#' @param template name of template
# demo_template <- function(template) {
#     opts <- get_default_opts(template)
#     opts$config <- yaml.load_file(internal$file$paths$config_file)
#     if (is.null(opts$internal$config$demo)){
#         message("The ", template, " template didn't provide a demo example.")
#     } else {
#         message("Running demo for the ", template, " template:\n\n", opts$internal$config$demo)
#         eval(parse(text = opts$internal$config$demo))
#     }
# }

#' Demo mode makes params$dir="./clickme_demo" (in the current directory)
#' it calls clickme with cme(...)$iframe()$hide()
#' and it adds a random string to the output file
#' @export
demo_mode <- function(on = NULL,
                      iframe_src = "src",
                      iframe_height = 800,
                      iframe_width = 1000,
                      demo_path = "."){
    if (is.null(on)){
        getOption("clickme_demo_mode") %or% FALSE
    } else {
        if (on){
            options(clickme_demo_mode = TRUE)
            options(clickme_demo_path = demo_path)
            options(clickme_demo_iframe_src = iframe_src)
            options(clickme_demo_iframe_height = iframe_height)
            options(clickme_demo_iframe_width = iframe_width)
            message("Demo mode on.\n")
        } else {
            options(clickme_demo_mode = FALSE)
            options(clickme_demo_count = NULL)
            message("Demo mode off.\n")
        }
    }
}

#' @export
increase_demo_count <- function(){
    if (!demo_mode())
        demo_mode(TRUE)

    if (is.null(getOption("clickme_demo_count"))){
        new_count <- 1
    } else {
        new_count <- getOption("clickme_demo_count") + 1
    }
    options("clickme_demo_count" = new_count)
    new_count
}

#' @export
is_character_or_factor <- function(x) {
    is.character(x) || is.factor(x)
}


#' @export
is_data_frame_or_matrix <- function(x) {
    is.data.frame(x) || is.matrix(x)
}

#' @export
is_list_of_data_frames <- function(x) {
    is.list(x) && all(sapply(x, class) == "data.frame")
}