Datasets
Models
Diff of
/R/auxiliary.R
[000000]
..
[413088]
Switch to side-by-side view
--- a +++ b/R/auxiliary.R @@ -0,0 +1,1209 @@ +#### +# Matrix Operations #### +#### + +getMin <- function(data, ...){ + if(inherits(data, "IterableMatrix")){ + data <- as(data, "dgCMatrix") + } + return(min(data, ...)) +} + +getMax <- function(data, ...){ + if(inherits(data, "IterableMatrix")){ + data <- as(data, "dgCMatrix") + } + return(max(data, ...)) +} + +getRange <- function(data, ...){ + return(c(getMin(data, ...), getMax(data, ...))) +} + +getColQuantiles <- function(data, desiredQuantile){ + if(inherits(data, "IterableMatrix")){ + return(BPCells::colQuantiles(data, probs = desiredQuantile)) + } else { + return(apply(data, 2, function(x) stats::quantile(x, desiredQuantile))) + } +} + + +#### +# Nanostring Auxiliary tools #### +#### + +generate_pkc_lookup <- function (jsons_vec) +{ + lookup_df <- data.frame(RTS_ID = character(), Target = character(), + Module = character(), CodeClass = character(), ProbeID = character(), + GeneID = character(), SystematicName = character(), stringsAsFactors = FALSE) + for (curr_idx in seq_len(length(jsons_vec))) { + curr_module <- names(jsons_vec)[curr_idx] + curr_json <- jsons_vec[[curr_idx]] + for (targ in curr_json[["Targets"]]) { + curr_targ <- targ[["DisplayName"]] + curr_code_class <- gsub("\\d+$", "", targ[["CodeClass"]]) + for (prb in targ[["Probes"]]) { + if (curr_json[["AnalyteType"]] == "Protein") { + curr_RTS_ID <- targ$RTS_ID + } + else { + curr_RTS_ID <- prb$RTS_ID + } + curr_probe_ID <- prb$ProbeID + curr_gene_ID <- paste(prb$GeneID, collapse = ", ") + if (length(prb$GeneID) < 1) { + curr_gene_ID <- NA + } + curr_syst_name <- paste(prb$SystematicName, collapse = ", ") + lookup_df[nrow(lookup_df) + 1, ] <- list(curr_RTS_ID, + curr_targ, curr_module, curr_code_class, curr_probe_ID, + curr_gene_ID, curr_syst_name) + } + } + } + return(lookup_df) +} + +.dccMetadata <- + list(schema = + list("Header" = + data.frame(labelDescription = + c("The version of the file", + "The version of the software used to create the file", + "The date of the sample"), + minVersion = numeric_version(c("0.01", "0.01", "0.01")), + row.names = + c("FileVersion", "SoftwareVersion", "Date"), + stringsAsFactors = FALSE), + "Scan_Attributes" = + data.frame(labelDescription = + c("The sample ID", + "The plate ID", + "The well ID"), + row.names = + c("ID", "Plate_ID", "Well"), + minVersion = numeric_version(c(rep("0.01", 3L))), + stringsAsFactors = FALSE), + "NGS_Processing_Attributes" = + data.frame(labelDescription = + c(NA_character_, + NA_integer_, + NA_integer_, + NA_integer_, + NA_integer_, + NA_real_, + NA_real_), + minVersion = numeric_version(c(rep("0.01", 7L))), + row.names = + c("SeqSetId", "Raw", "Trimmed", + "Stitched", "Aligned", "umiQ30", "rtsQ30"), + stringsAsFactors = FALSE), + "Code_Summary" = + data.frame(labelDescription = + c(NA_character_, NA_integer_), + minVersion = numeric_version(c(rep("0.01", 2L))), + row.names = c("RTS_ID", "Count"), + stringsAsFactors = FALSE) + ) + ) + + +.dccMetadata[["protocolData"]] <- + do.call(rbind, + unname(head(.dccMetadata[["schema"]], 3L)))[, "labelDescription", + drop = FALSE] + +rownames(.dccMetadata[["protocolData"]])[rownames(.dccMetadata[["protocolData"]]) == "ID"] <- "SampleID" + + +.codeClassMetadata <- + c("CodeClass,IsControl,Analyte", + "Endogenous,FALSE,gx|cnv|fusion", + "Housekeeping,TRUE,gx|fusion", + "Positive,TRUE,general", + "Negative,TRUE,general", + "Binding,TRUE,general", + "Purification,TRUE,general", + "Reserved,TRUE,general", + "SNV_INPUT_CTL,TRUE,SNV", + "SNV_NEG,TRUE,SNV", + "SNV_POS,TRUE,SNV", + "SNV_UDG_CTL,TRUE,SNV", + "SNV_PCR_CTL,TRUE,SNV", + "SNV_REF,FALSE,SNV", + "SNV_VAR,FALSE,SNV", + "PROTEIN,FALSE,protein", + "PROTEIN_NEG,TRUE,protein", + "PROTEIN_CELL_NORM,TRUE,protein", + "Restriction Site,TRUE,CNV", + "Invariant,TRUE,CNV") +.codeClassMetadata <- + utils::read.csv(textConnection(paste0(.codeClassMetadata, collapse = "\n")), + colClasses = c("character", "logical", "character"), + stringsAsFactors = FALSE) + + +.validDccSchema <- + function(x, fileVersion, + section = c("Header", "Scan_Attributes", "NGS_Processing_Attributes", "Code_Summary")) + { + section <- match.arg(section) + schema <- .dccMetadata[["schema"]][[section]] + expectedNames <- row.names(schema)[schema[,"minVersion"] <= fileVersion] + if (all(expectedNames %in% colnames(x))) { + TRUE + } else { + sprintf("<%s> section must contain %s", section, + paste0("\"", expectedNames, "\"", collapse = ", ")) + } + } + + +.allNA <- function(x) { + all(is.na(x)) +} + +.allTRUE <- function(x) { + is.logical(x) && !anyNA(x) && all(x) +} + +.allFALSE <- function(x) { + is.logical(x) && !anyNA(x) && !any(x) +} + +.allZero <- function(x) { + is.numeric(x) && !anyNA(x) && identical(range(x), c(0, 0)) +} + +.validNonNegativeInteger <- function(x) { + is.integer(x) && !anyNA(x) && min(x) >= 0L +} + +.validNonNegativeNumber <- function(x) { + is.numeric(x) && !anyNA(x) && min(x) >= 0 +} + +.validPositiveNumber <- function(x) { + is.numeric(x) && !anyNA(x) && min(x) > 0 +} + + +#### +# Basilisk Environment #### +#### + +#' get the Python Basilisk environment +#' +#' Defines a conda environment via Basilisk, which is used to convert R objects to Zarr stores. +#' +#' @export +getBasilisk <- function(){ + + if(!requireNamespace('basilisk')) + stop("Please install basilisk package!: BiocManager::install('basilisk')") + + basilisk.packages=c( + "numpy==1.*", + "pandas==1.*", + "anndata==0.8.*", + "h5py==3.*", + "hdf5==1.*", + "natsort==7.*", + "packaging==20.*", + "scipy==1.*", + "sqlite==3.*", + "zarr==2.*", + "numcodecs==0.*", + "tifffile==2024.2.12" + ) + basilisk.pip=c( + "ome-zarr==0.2.1" + ) + + py_env <- basilisk::BasiliskEnvironment( + envname="VoltRon_basilisk_env", + pkgname="VoltRon", + packages=basilisk.packages, + pip=basilisk.pip + ) + + py_env +} + +#### +# Other Auxiliary tools #### +#### + +fill.na <- function(x, i = 5) { + if (is.na(x)[i]) { + return(round(mean(x, na.rm = TRUE), 0)) + } + else { + return(round(x[i], 0)) + } +} + +#' slotApply +#' +#' apply to slots +#' +#' @param x object +#' @param FUN function +#' @param ... arguments passed to \code{FUN} +#' +#' @importFrom methods slot slotNames +#' +slotApply <- function(x,FUN,...){ + cl <- class(x) + result <- list() + for(i in methods::slotNames(cl)){ + result[[i]] <- FUN(methods::slot(x,i),...) + } + result +} + +#' slotToList +#' +#' slot to list +#' +#' @param x object +#' +#' @importFrom methods slot slotNames +#' +slotToList <- function(x){ + returnlist <- list() + namesslot <- methods::slotNames(x) + for(cur_slot in namesslot) + returnlist[[cur_slot]] <- methods::slot(x, name = cur_slot) + returnlist +} + +ggname <- function(prefix, grob) { + grob$name <- grid::grobName(grob, prefix) + grob +} + +quiet <- function(x) { + sink(tempfile()) + on.exit(sink()) + invisible(force(x)) +} + +stopQuietly <- function(...) { + blankMsg <- sprintf("\r%s\r", paste(rep(" ", getOption("width")-1L), collapse=" ")); + stop(simpleError(blankMsg)); +} + +#' make_css +#' +#' make_css from \code{tableHTML} package +#' +#' @param ... css style definitions. Each object you provide must be a list of three elements. The first element will be a vector of the selectors to be styled (e.g. table, th, an id or html class). If the first element is a vector of length greater than one then the selectors will be comma separated in the css. The second element will be a vector of the css definitions and the third element will a vector of the values of those definitions. +#' @param file Character sting. If a file name is provided then the css code will be printed into that file. If the argument is NULL (default) then a string will be returned. +#' +#' @importFrom shiny HTML +#' +#' @noRd +make_css <- function (..., file = NULL) +{ + css_defs <- list(...) + for (x in css_defs) { + if ((!is.list(x)) | (length(x) != 3L)) { + stop("Each element in ... needs to be a list of three elements") + } + if (length(x[[2]]) != length(x[[3]])) { + stop("The second and third elements of each list need to have the same length") + } + } + all_css <- vapply(css_defs, function(x) { + css_comp <- paste0(x[[2]], ": ", x[[3]], ";") + style <- paste(css_comp, collapse = "\n ") + to_be_styled <- paste(x[[1]], collapse = ",\n") + paste0(to_be_styled, " {\n ", style, "\n}\n") + }, FUN.VALUE = character(1)) + css_string <- shiny::HTML(paste(all_css, collapse = "\n")) + if (is.null(file)) { + css_string + } + else { + message(css_string, file = file) + invisible(NULL) + } +} + +#' Fast creation of dummy variables +#' +#' Quickly create dummy (binary) columns from character and +#' factor type columns in the inputted data (and numeric columns if specified.) +#' This function is useful for statistical analysis when you want binary +#' columns rather than character columns. Adapted from the \code{fastDummies} package (https://jacobkap.github.io/fastDummies/) +#' +#' @param .data +#' An object with the data set you want to make dummy columns from. +#' @param select_columns +#' Vector of column names that you want to create dummy variables from. +#' If NULL (default), uses all character and factor columns. +#' @param remove_first_dummy +#' Removes the first dummy of every variable such that only n-1 dummies remain. +#' This avoids multicollinearity issues in models. +#' @param remove_most_frequent_dummy +#' Removes the most frequently observed category such that only n-1 dummies +#' remain. If there is a tie for most frequent, will remove the first +#' (by alphabetical order) category that is tied for most frequent. +#' @param ignore_na +#' If TRUE, ignores any NA values in the column. If FALSE (default), then it +#' will make a dummy column for value_NA and give a 1 in any row which has a +#' NA value. +#' @param split +#' A string to split a column when multiple categories are in the cell. For +#' example, if a variable is Pets and the rows are "cat", "dog", and "turtle", +#' each of these pets would become its own dummy column. If one row is "cat, dog", +#' then a split value of "," this row would have a value of 1 for both the cat +#' and dog dummy columns. +#' @param remove_selected_columns +#' If TRUE (not default), removes the columns used to generate the dummy columns. +#' @param omit_colname_prefix +#' If TRUE (not default) and `length(select_columns) == 1`, omit pre-pending the +#' name of `select_columns` to the names of the newly generated dummy columns +#' +#' @return +#' A data.frame (or tibble or data.table, depending on input data type) with +#' same number of rows as inputted data and original columns plus the newly +#' created dummy columns. +#' +#' @importFrom data.table as.data.table is.data.table chmatch alloc.col set +#' @importFrom stringr str_sort str_order +#' +dummy_cols <- function(.data, select_columns = NULL, remove_first_dummy = FALSE, + remove_most_frequent_dummy = FALSE, ignore_na = FALSE, split = NULL, + remove_selected_columns = FALSE, omit_colname_prefix = FALSE) +{ + stopifnot(is.null(select_columns) || is.character(select_columns), + select_columns != "", is.logical(remove_first_dummy), + length(remove_first_dummy) == 1, is.logical(remove_selected_columns)) + if (remove_first_dummy == TRUE & remove_most_frequent_dummy == + TRUE) { + stop("Select either 'remove_first_dummy' or 'remove_most_frequent_dummy'\n to proceed.") + } + if (is.vector(.data)) { + .data <- data.frame(.data = .data, stringsAsFactors = FALSE) + } + data_type <- check_type(.data) + if (!data.table::is.data.table(.data)) { + .data <- data.table::as.data.table(.data) + } + if (!is.null(select_columns)) { + char_cols <- select_columns + cols_not_in_data <- char_cols[!char_cols %in% names(.data)] + char_cols <- char_cols[!char_cols %in% cols_not_in_data] + if (length(char_cols) == 0) { + stop("select_columns is/are not in data. Please check data and spelling.") + } + } + else if (ncol(.data) == 1) { + char_cols <- names(.data) + } + else { + char_cols <- sapply(.data, class) + char_cols <- char_cols[char_cols %in% c("factor", "character")] + char_cols <- names(char_cols) + } + if (length(char_cols) == 0 && is.null(select_columns)) { + stop("No character or factor columns found. ", + "Please use select_columns to choose columns.") + } + if (!is.null(select_columns) && length(cols_not_in_data) > + 0) { + warning("NOTE: The following select_columns input(s) ", + "is not a column in data:\n", names(cols_not_in_data), "\t") + } + for (col_name in char_cols) { + if (is.factor(.data[[col_name]])) { + unique_vals <- levels(.data[[col_name]]) + if (any(is.na(.data[[col_name]]))) { + unique_vals <- c(unique_vals, NA) + } + } + else { + unique_vals <- unique(.data[[col_name]]) + unique_vals <- stringr::str_sort(unique_vals, na_last = TRUE, + locale = "en_US", numeric = TRUE) + } + unique_vals <- as.character(unique_vals) + if (!is.null(split)) { + unique_vals <- unique(trimws(unlist(strsplit(unique_vals, + split = split)))) + } + if (ignore_na) { + unique_vals <- unique_vals[!is.na(unique_vals)] + } + if (remove_most_frequent_dummy) { + vals <- as.character(.data[[col_name]]) + vals <- data.frame(sort(table(vals), decreasing = TRUE), + stringsAsFactors = FALSE) + top_vals <- vals[vals$Freq %in% max(vals$Freq), ] + other_vals <- vals$vals[!vals$Freq %in% max(vals$Freq)] + other_vals <- as.character(other_vals) + top_vals <- top_vals[stringr::str_order(top_vals$vals, + na_last = TRUE, locale = "en_US", numeric = TRUE), + ] + if (nrow(top_vals) == 1) { + top_vals <- NULL + } + else { + top_vals <- as.character(top_vals$vals[2:nrow(top_vals)]) + } + unique_vals <- c(top_vals, other_vals) + unique_vals <- stringr::str_sort(unique_vals, na_last = TRUE, + locale = "en_US", numeric = TRUE) + } + if (remove_first_dummy) { + unique_vals <- unique_vals[-1] + } + data.table::alloc.col(.data, ncol(.data) + length(unique_vals)) + .data[, paste0(col_name, "_", unique_vals)] <- 0L + for (unique_value in unique_vals) { + data.table::set(.data, i = which(data.table::chmatch(as.character(.data[[col_name]]), + unique_value, nomatch = 0) == 1L), j = paste0(col_name, + "_", unique_value), value = 1L) + if (!is.na(unique_value)) { + data.table::set(.data, i = which(is.na(.data[[col_name]])), + j = paste0(col_name, "_", unique_value), value = NA) + } + if (!is.null(split)) { + max_split_length <- max(sapply(strsplit(as.character(.data[[col_name]]), + split = split), length)) + for (split_length in seq_len(max_split_length)) { + data.table::set(.data, i = which(data.table::chmatch(as.character(trimws(sapply(strsplit(as.character(.data[[col_name]]), + split = split), `[`, split_length))), unique_value, + nomatch = 0) == 1L), j = paste0(col_name, + "_", unique_value), value = 1L) + } + if (is.na(unique_value)) { + .data[[paste0(col_name, "_", unique_value)]][which(!is.na(.data[[col_name]]))] <- 0 + } + } + } + } + if (remove_selected_columns) { + .data <- .data[-which(names(.data) %in% char_cols)] + } + .data <- fix_data_type(.data, data_type) + if (omit_colname_prefix) { + if (length(select_columns) == 1) { + new_col_index <- as.logical(rowSums(sapply(unique_vals, + function(x) grepl(paste0(select_columns, "_", + x), names(.data))))) + names(.data)[new_col_index] <- gsub(paste0(select_columns, + "_"), "", names(.data)[new_col_index]) + } + else { + message("Can't omit the colname prefix when recoding more than one column.") + message("Returning prefixed dummy columns.") + } + } + return(.data) +} + +#' @importFrom data.table is.data.table +#' @noRd +check_type <- function(.data) { + if (data.table::is.data.table(.data)) { + data_type <- "is_data_table" + } else if (inherits(.data, "tbl_df")) { + data_type <- "is_tibble" + } else { + data_type <- "is_data_frame" + } + + return(data_type) +} + +#' @importFrom dplyr as_tibble +#' @noRd +fix_data_type <- function(.data, data_type) { + if (data_type == "is_data_frame") { + .data <- as.data.frame(.data, stringsAsFactors = FALSE) + } else if (data_type == "is_tibble") { + .data <- dplyr::as_tibble(.data) + } + + return(.data) +} + +#' CSS string helper +#' +#' Convenience function for building CSS style declarations (i.e. the string +#' that goes into a style attribute, or the parts that go inside curly braces in +#' a full stylesheet). +#' +#' CSS uses `'-'` (minus) as a separator character in property names, but +#' this is an inconvenient character to use in an R function argument name. +#' Instead, you can use `'.'` (period) and/or `'_'` (underscore) as +#' separator characters. For example, `css(font.size = "12px")` yields +#' `"font-size:12px;"`. +#' +#' To mark a property as `!important`, add a `'!'` character to the end +#' of the property name. (Since `'!'` is not normally a character that can be +#' used in an identifier in R, you'll need to put the name in double quotes or +#' backticks.) +#' +#' Argument values will be converted to strings using +#' `paste(collapse = " ")`. Any property with a value of `NULL` or +#' `""` (after paste) will be dropped. +#' +#' @param ... Named style properties, where the name is the property name and +#' the argument is the property value. See Details for conversion rules. +#' @param collapse_ (Note that the parameter name has a trailing underscore +#' character.) Character to use to collapse properties into a single string; +#' likely `""` (the default) for style attributes, and either `"\n"` +#' or `NULL` for style blocks. +#' +#' @importFrom rlang dots_list +#' +#' @noRd +css <- function(..., collapse_ = "") { + props <- rlang::dots_list(...) + if (length(props) == 0) { + return(NULL) + } + + if (is.null(names(props)) || any(names(props) == "")) { + stop("cssList expects all arguments to be named") + } + + # Necessary to make factors show up as level names, not numbers + props[] <- lapply(props, paste, collapse = " ") + + # Drop null args + props <- props[!sapply(props, empty)] + if (length(props) == 0) { + return(NULL) + } + + # Translate camelCase, snake_case, and dot.case to kebab-case + # For standard CSS properties only, not CSS variables + is_css_var <- grepl("^--", names(props)) + names(props)[!is_css_var] <- standardize_property_names(names(props)[!is_css_var]) + + # Create "!important" suffix for each property whose name ends with !, then + # remove the ! from the property name + important <- ifelse(grepl("!$", names(props), perl = TRUE), " !important", "") + names(props) <- sub("!$", "", names(props), perl = TRUE) + + paste0(names(props), ":", props, important, ";", collapse = collapse_) +} + +empty <- function(x) { + length(x) == 0 || (is.character(x) && !any(nzchar(x))) +} + +standardize_property_names <- function(x) { + # camelCase to kebab-case + x <- gsub("([A-Z])", "-\\1", x) + x <- tolower(x) + # snake_case and dot.case to kebab-case + gsub("[._]", "-", x) +} + +#' @importFrom grDevices hcl +hue_pal <- function(n, h = c(0, 360) + 15, c = 100, l = 65, h.start = 0, direction = 1) +{ + if (n == 0) { + stop("Must request at least one colour from a hue palette.") + } + if ((diff(h)%%360) < 1) { + h[2] <- h[2] - 360/n + } + hues <- seq(h[1], h[2], length.out = n) + hues <- (hues + h.start)%%360 + hcl <- cbind(hues, c, l) + pal <- apply(hcl, 1, function(x){ + grDevices::hcl(x[1], x[2], x[3]) + }) + if (direction == -1) { + rev(pal) + } + else { + pal + } +} + +rescale_numeric <- function(x, to = c(0, 1), from = range(x, na.rm = TRUE, finite = TRUE), ...) { + (x - from[1]) / diff(from) * diff(to) + to[1] +} + +as.raster_array <- function (x, max = 1, ...) +{ + if (!is.numeric(x)) { + if (is.raw(x)) { + storage.mode(x) <- "integer" + max <- 255L + } + else stop("a raster array must be numeric") + } + if (length(d <- dim(x)) != 3L) + stop("a raster array must have exactly 3 dimensions") + r <- array(if (d[3L] == 3L) + rgb(t(x[, , 1L]), t(x[, , 2L]), t(x[, , 3L]), maxColorValue = max) + else if (d[3L] == 4L) + rgb(t(x[, , 1L]), t(x[, , 2L]), t(x[, , 3L]), t(x[, , 4L]), maxColorValue = max) + else if (d[3L] == 1L) + rgb(t(x[, , 1L]), t(x[, , 1L]), t(x[, , 1L]), maxColorValue = max) + else stop("a raster array must have exactly 1, 3 or 4 planes"), + dim = d[seq_len(2)]) + class(r) <- "raster" + r +} + +avgHexColor <- function(colors){ + rgb(t(Reduce(`+`, lapply(colors, col2rgb))/3), maxColorValue=255) +} + +#### +## ggedit tools #### +## See https://github.com/yonicd/ggedit/tree/master/R +#### + +#' @title ggplot2 layer proto extraction +#' @description Extract geom, stat and position protos from a ggplot2 layer +#' @param l ggproto +#' @noRd +proto_features <- function(l) { + a <- sapply(c("position", "geom", "stat"), function(x) { + class(l[[x]])[1] + }) + + data.frame(t(a), stringsAsFactors = FALSE) +} + +# forked from https://github.com/yihui/knitr/blob/master/R/defaults.R +#' @importFrom stats setNames +#' @noRd +new_defaults <- function(value = list()) { + defaults <- value + + get <- function(name, default = FALSE, drop = TRUE, regex=FALSE, ...) { + if (default) defaults <- value # this is only a local version + if (missing(name)) { + defaults + } else { + if (drop && length(name) == 1) { + if (regex) { + name_grep <- grep(name, names(defaults), value = TRUE, ...) + stats::setNames(defaults[name_grep], name_grep) + } else { + defaults[[name]] + } + } else { + stats::setNames(defaults[name], name) + } + } + } + + set <- function(...) { + dots <- list(...) + if (length(dots) == 0) return() + if (is.null(names(dots)) && length(dots) == 1 && is.list(dots[[1]])) { + if (length(dots <- dots[[1]]) == 0) { + return() + } + } + defaults <<- merge(dots) + invisible(NULL) + } + + # merge <- function(values) merge_list(defaults, values) + + restore <- function(target = value) defaults <<- target + + append <- function(...) { + dots <- list(...) + if (length(dots) == 0) return() + if (is.null(names(dots)) && length(dots) == 1 && is.list(dots[[1]])) { + if (length(dots <- dots[[1]]) == 0) { + return() + } + } + dots <- sapply(names(dots), function(x) dots[[x]] <- c(defaults[[x]], dots[[x]]), simplify = FALSE) + defaults <<- merge(dots) + invisible(NULL) + } + + list(get = get, set = set, append = append, merge = merge, restore = restore) +} + +#' @title Creates an independent copy of a ggplot layer object +#' @description Creates copies of ggplot layers from within ggplot objects that +#' are independent of the parent object. +#' @details ggplot objects are comprimsed of layer objects. Once compiled they +#' are part of the plot object environment and if they are changed internally +#' regardless of where they are in the (ie different environment) it will change +#' the original plot. This function allows to create replicates of the plot layers +#' and edit them independent of the original plot. When setting verbose to TRUE +#' function returns the ggplot2 call as a string to paste in regular ggplot script +#' to generate the layer. +#' @param l ggplot2 object layer +#' @param verbose toggle to control if the output is ggproto object (verbose==FALSE,default) or string of layer call (verbose==TRUE) +#' @param showDefaults toggle to control if the verbose output shows all the input arguments passed to the proto object (if verbose==FALSE then ignored) +#' @return ggproto or string object (conditional on verbose) +#' +#' @importFrom utils capture.output +#' @importFrom rlang sym '!!' +#' @noRd +cloneLayer <- function (l, verbose = FALSE, showDefaults = TRUE) +{ + geom_opts <- ggedit_opts$get("session_geoms") + parent.layer <- dplyr::left_join(proto_features(l), dplyr::filter(geom_opts, + !grepl("^stat", !!rlang::sym("fn"))), by = c("position", + "geom", "stat")) + if (is.na(parent.layer$fn)) + parent.layer$fn <- paste0(tolower(strsplit(parent.layer$stat, + "(?<=Stat)", perl = TRUE)[[1]]), collapse = "_") + layer.names <- c("mapping", "data", "geom", "position", "stat", + "show.legend", "inherit.aes", "aes_params", "geom_params", + "stat_params") + x <- sapply(layer.names, function(y) { + b <- l[[y]] + if ("waiver" %in% class(b)) + b <- NULL + if (y == "geom") + b <- eval(parse(text = parent.layer$geom)) + if (y == "position") + b <- gsub(y, "", tolower(class(b)[1])) + if (y == "stat") + b <- eval(parse(text = parent.layer$stat)) + b + }) + x$params <- append(x$stat_params, x$geom_params) + x$params <- append(x$params, x$aes_params) + x$params <- x$params[!duplicated(names(x$params))] + x$geom_params <- x$aes_params <- x$stat_params <- NULL + if (verbose) { + nm <- names(x) + nm <- nm[!sapply(x, typeof) %in% c("environment", "closure", + "list")] + geom_aes <- list(geom = parent.layer$fn, mapping = sapply(names(x$mapping), + build_map, y = x$mapping), params = sapply(names(x$params), + build_map, y = x$params), layer = sapply(rev(nm), + build_map, y = x[rev(nm)]), data = paste0("data = ", + paste0(capture.output(dput(x$data)), collapse = "\n"))) + strRet <- sprintf("%s(mapping=aes(%s),%s,%s)", paste0(geom_aes$geom, + collapse = ","), paste0(geom_aes$mapping, collapse = ","), + paste0(geom_aes$params, collapse = ","), paste0(geom_aes$layer, + collapse = ",")) + if (!showDefaults) { + geom_proto <- cloneProto(eval(parse(text = paste0(geom_aes$geom, + "()")))) + geom_diff <- sapply(names(geom_aes)[-1], function(x) geom_aes[[x]][!geom_aes[[x]] %in% + geom_proto[[x]]]) + strRet <- sprintf("%s(aes(%s),%s,%s,%s)", paste0(geom_aes$geom, + collapse = ","), paste0(geom_diff$mapping, collapse = ","), + paste0(geom_diff$params, collapse = ","), paste0(geom_diff$layer, + collapse = ","), geom_aes$data) + } + strRet <- gsub("aes()", "", strRet, fixed = T) + strRet <- gsub("[,]{2,}", ",", strRet) + strRet <- gsub("data=NULL", "", strRet) + strRet <- gsub(",)", ")", strRet) + strRet <- gsub("\\(,", "(", strRet) + strRet + } + else { + do.call(layer, x) + } +} + +#' @importFrom dplyr filter left_join +#' @importFrom rlang sym '!!' +#' @noRd +cloneProto <- function(l) { + + geom_opts <- ggedit_opts$get("session_geoms") + + parent.layer <- proto_features(l) |> + dplyr::left_join( + geom_opts |> dplyr::filter(!grepl("^stat", !!rlang::sym('fn'))), + by = c("position", "geom", "stat") + ) + + if (is.na(parent.layer$fn)) { + parent.layer$fn <- paste0(tolower(strsplit(parent.layer$stat, "(?<=Stat)", perl = TRUE)[[1]]), collapse = "_") + } + + layer.names <- c("mapping", "data", "geom", "position", "stat", "show.legend", "inherit.aes", "aes_params", "geom_params", "stat_params") + + x <- sapply(layer.names, function(y) { + b <- l[[y]] + + if ("waiver" %in% class(b)) { + b = NULL + } + + if (y == "geom") { + b <- eval(parse(text = parent.layer$geom)) + } + + if (y == "position") { + b <- gsub(y, "", tolower(class(b)[1])) + } + + if (y == "stat") { + b <- eval(parse(text = parent.layer$stat)) + } + + b + }) + + x$params <- append(x$stat_params, x$geom_params) + x$params <- append(x$params, x$aes_params) + x$params <- x$params[!duplicated(names(x$params))] + + x$geom_params <- x$aes_params <- x$stat_params <- NULL + + fn <- parent.layer$fn + + g <- paste0(fn, "()") + g <- eval(parse(text = g)) + nm <- names(x) + + nm <- nm[!sapply(x, typeof) %in% c("environment", "closure", "list")] + + geom_aes <- list( + geom = fn, + mapping = sapply(names(x$mapping), build_map,y = x$mapping), + params = sapply(names(x$params), build_map, y = x$params), + layer = sapply(rev(nm), build_map, y = x[rev(nm)]) + ) + + nDF <- cbind(names(g$geom$default_aes), paste(g$geom$default_aes)) + nDF[grep("colour|fill|color", nDF[, 1]), 2] <- paste0("'", col2hcl(nDF[grep("colour|fill|color", nDF[, 1]), 2], alpha = NULL), "'") + + geom_aes$default <- paste0(apply(nDF, 1, function(x) paste0(x, collapse = "="))) + + geom_aes +} + +#' @title Default and current ggedit options +#' +#' @description Options for functions in the ggedit package. When running R code, the object \code{ggedit_opts} +#' (default options) is not modified by chunk headers (local chunk options are +#' merged with default options), whereas \code{ggedit_opts_current} (current options) +#' changes with different chunk headers and it always reflects the options for +#' the current chunk. +#' +#' Normally we set up the global options once in the first code chunk in a +#' document using \code{ggedit_opts$set()}, so that all \emph{latter} chunks will +#' use these options. Note the global options set in one chunk will not affect +#' the options in this chunk itself, and that is why we often need to set global +#' options in a separate chunk. +#' +#' @note \code{ggedit_opts_current} is read-only in the sense that it does nothing if +#' you call \code{ggedit_opts_current$set()}; you can only query the options via +#' \code{ggedit_opts_current$get()}. +#' @rdname ggeditOpts +#' @noRd +ggedit_opts <- new_defaults(list( + fontDefaults = c( + "sans", + "Canonical", + "mono", + "Courier", + "Helvetica", + "serif", + "Times", + "AvantGarde", + "Bookman", + "Helvetica-Narrow", + "NewCenturySchoolbook", + "Palatino", + "URWGothic", + "URWBookman", + "NimbusMon", + "URWHelvetica", + "NimbusSan", + "NimbusSanCond", + "CenturySch", + "URWPalladio", + "URWTimes", + "NimbusRom" + ), + slideDefaults = list( + alpha = c(min = 0, max = 1), + size = c(min = 0, max = 10), + shape = c(min = 1, max = 25), + stroke = c(min = 0, max = 10), + weight = c(min = 0, max = 10), + linetype = c(min = 1, max = 5), + width = c(min = 0, max = 1), + angle = c(min = 0, max = 360), + hjust = c(min = -10, max = 10), + vjust = c(min = -10, max = 10), + stroke = c(min = 0, max = 10), + lineheight = c(min = 0, max = 10), + linewidth = c(min = 0, max = 5), + fontface = c(min = 1, max = 4), + rel_min_height = c(min = 0, max = 1), + scale = c(min = 0, max = 100) + ), + themeTips = list( + element_rect = list( + fill = "fill colour", + colour = "border colour", + size = "border size (in pts)", + linetype = paste0( + paste( + seq(0, 6), + c( + "blank", "solid", "dashed", "dotted", "dotdash", + "longdash", "twodash" + ), sep = ": " + ), + collapse = ", " + ) + ), + element_line = list( + colour = "line colour", + size = "numeric (in pts) or \n relative to global size rel(numeric)", + linetype = paste0( + paste( + seq(0, 6), + c( + "blank", "solid", "dashed", "dotted", "dotdash", + "longdash", "twodash" + ), sep = ": " + ), + collapse = ", " + ), + lineend = c("butt(default),round,square") + ), + element_text = list( + family = shiny::HTML('<a href="http://www.cookbook-r.com/Graphs/Fonts/" target="_blank">font family</a>'), + face = 'font face ("plain", "italic", "bold", "bold.italic")', + colour = "text colour", + size = "text size (in pts)", + hjust = "horizontal justification (in [0, 1])", + vjust = "vertical justification (in [0, 1])", + angle = "angle (in [0, 360])", + lineheight = "numeric line height" + ), + justification = list(justification = 'anchor point for positioning legend inside plot <br/> "center" or two-element numeric vector'), + position = list(position = 'the position of legends. <br/> "left", "right", "bottom", "top", or two-element numeric vector') + ), + + ThemeDefaultClass = + data.frame( + item = c("angle", "background", "caption", "colour", "face", "family", "fill", "grid.major", "grid.minor", "hjust", "justification", "key", "key.size", "line", "lineheight", "linetype", "margin", "ontop", "position", "size", "subtitle", "switch.pad.grid", "switch.pad.wrap", "text", "text.x", "text.y", "ticks", "ticks.length", "title", "title.x", "title.y", "vjust", "placement"), + class = c("numeric", "character", "character", "character", "character", "character", "character", "character", "character", "numeric", "character", "character", "character", "character", "numeric", "numeric", "numeric", "character", "character", "numeric", "character", "character", "character", "character", "character", "character", "numeric", "numeric", "character", "character", "character", "numeric", "character"), stringsAsFactors = FALSE + ), + session_geoms = + data.frame( + fn = c("annotation_custom", "annotation_logticks", + "annotation_map", "annotation_raster", "geom_abline", "geom_area", + "geom_bar", "geom_bin2d", "geom_blank", "geom_boxplot", "geom_col", + "geom_contour", "geom_count", "geom_crossbar", "geom_curve", + "geom_density", "geom_density_2d", "geom_density2d", "geom_dotplot", + "geom_errorbar", "geom_errorbarh", "geom_freqpoly", "geom_hex", + "geom_histogram", "geom_hline", "geom_jitter", "geom_label", + "geom_line", "geom_linerange", "geom_map", "geom_path", "geom_point", + "geom_pointrange", "geom_polygon", "geom_qq", "geom_qq_line", + "geom_quantile", "geom_raster", "geom_rect", "geom_ribbon", "geom_rug", + "geom_segment", "geom_sf", "geom_smooth", "geom_spoke", "geom_step", + "geom_text", "geom_tile", "geom_violin", "geom_vline", "stat_bin", + "stat_bin_2d", "stat_bin_hex", "stat_bin2d", "stat_binhex", "stat_boxplot", + "stat_contour", "stat_count", "stat_density", "stat_density_2d", + "stat_density2d", "stat_ecdf", "stat_ellipse", "stat_function", + "stat_identity", "stat_qq", "stat_qq_line", "stat_quantile", + "stat_sf", "stat_smooth", "stat_sum", "stat_summary", "stat_summary_2d", + "stat_summary_bin", "stat_summary_hex", "stat_unique", "stat_ydensity"), + geom = c("GeomCustomAnn", "GeomLogticks", "GeomAnnotationMap", + "GeomRasterAnn", "GeomAbline", "GeomArea", "GeomBar", "GeomTile", + "GeomBlank", "GeomBoxplot", "GeomCol", "GeomContour", "GeomPoint", + "GeomCrossbar", "GeomCurve", "GeomDensity", "GeomDensity2d", + "GeomDensity2d", "GeomDotplot", "GeomErrorbar", "GeomErrorbarh", + "GeomPath", "GeomHex", "GeomBar", "GeomHline", "GeomPoint", "GeomLabel", + "GeomLine", "GeomLinerange", "GeomMap", "GeomPath", "GeomPoint", + "GeomPointrange", "GeomPolygon", "GeomPoint", "GeomPath", "GeomQuantile", + "GeomRaster", "GeomRect", "GeomRibbon", "GeomRug", "GeomSegment", + "GeomSf", "GeomSmooth", "GeomSpoke", "GeomStep", "GeomText", + "GeomTile", "GeomViolin", "GeomVline", "GeomBar", "GeomTile", + "GeomHex", "GeomTile", "GeomHex", "GeomBoxplot", "GeomContour", + "GeomBar", "GeomArea", "GeomDensity2d", "GeomDensity2d", "GeomStep", + "GeomPath", "GeomPath", "GeomPoint", "GeomPoint", "GeomPath", + "GeomQuantile", "GeomRect", "GeomSmooth", "GeomPoint", "GeomPointrange", + "GeomTile", "GeomPointrange", "GeomHex", "GeomPoint", "GeomViolin"), + position = c("PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionStack", "PositionStack", + "PositionIdentity", "PositionIdentity", "PositionDodge2", "PositionStack", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionStack", "PositionIdentity", "PositionJitter", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionDodge", "PositionIdentity", "PositionStack", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionDodge2", "PositionIdentity", "PositionStack", "PositionStack", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionIdentity", "PositionIdentity", "PositionIdentity", + "PositionIdentity", "PositionDodge"), + stat = c("StatIdentity", "StatIdentity", "StatIdentity", "StatIdentity", "StatIdentity", + "StatIdentity", "StatCount", "StatBin2d", "StatIdentity", "StatBoxplot", + "StatIdentity", "StatContour", "StatSum", "StatIdentity", "StatIdentity", + "StatDensity", "StatDensity2d", "StatDensity2d", "StatBindot", + "StatIdentity", "StatIdentity", "StatBin", "StatBinhex", "StatBin", + "StatIdentity", "StatIdentity", "StatIdentity", "StatIdentity", + "StatIdentity", "StatIdentity", "StatIdentity", "StatIdentity", + "StatIdentity", "StatIdentity", "StatQq", "StatQqLine", "StatQuantile", + "StatIdentity", "StatIdentity", "StatIdentity", "StatIdentity", + "StatIdentity", "StatSf", "StatSmooth", "StatIdentity", "StatIdentity", + "StatIdentity", "StatIdentity", "StatYdensity", "StatIdentity", + "StatBin", "StatBin2d", "StatBinhex", "StatBin2d", "StatBinhex", + "StatBoxplot", "StatContour", "StatCount", "StatDensity", "StatDensity2d", + "StatDensity2d", "StatEcdf", "StatEllipse", "StatFunction", "StatIdentity", + "StatQq", "StatQqLine", "StatQuantile", "StatSf", "StatSmooth", + "StatSum", "StatSummary", "StatSummary2d", "StatSummaryBin", + "StatSummaryHex", "StatUnique", "StatYdensity"), + pkg = rep("ggplot2", 77),stringsAsFactors = FALSE) +)) + +# Function to convert color to HCL and adjust components +#' @importFrom grDevices col2rgb rgb2hsv hcl rgb +col2hcl <- function(colour, h = NULL, c = NULL, l = NULL, alpha = NULL) { + # Convert color to RGB + rgb_col <- grDevices::col2rgb(colour) / 255 + + # Convert RGB to HSV + hsv_col <- grDevices::rgb2hsv(rgb_col) + + # Convert HSV to HCL + hue <- hsv_col[1] * 360 # Convert hue to degrees (0-360) + chroma <- hsv_col[2] * 100 # Chroma is similar to saturation + luminance <- hsv_col[3] * 100 # Luminance is related to value + + # Allow user to override H, C, or L values + if (!is.null(h)) hue <- h + if (!is.null(c)) chroma <- c + if (!is.null(l)) luminance <- l + + # Create the HCL color with potentially modified components + hcl_col <- grDevices::hcl(h = hue, c = chroma, l = luminance) + + # Convert HCL back to RGB to apply alpha + rgb_col_with_alpha <- grDevices::col2rgb(hcl_col) / 255 + + # Add alpha transparency if provided + if (!is.null(alpha)) { + rgba_col <- grDevices::rgb(rgb_col_with_alpha[1], rgb_col_with_alpha[2], rgb_col_with_alpha[3], alpha = alpha) + } else { + rgba_col <- grDevices::rgb(rgb_col_with_alpha[1], rgb_col_with_alpha[2], rgb_col_with_alpha[3]) + } + + # Return the final RGBA color + return(rgba_col) +} + +#' @importFrom stats as.formula +#' @importFrom rlang quo_name +#' @noRd +build_map <- function(item,y) { + + y <- y[[item]] + + if (inherits(y,'quosure')){ + return(sprintf('%s = %s',item,rlang::quo_name(y))) + } + + if (inherits(y,'character')){ + return(sprintf("%s = '%s'",item,y)) + } + + if (inherits(y, "formula")){ + return(sprintf("formula=stats::as.formula('%s')", + paste0(as.character(y)[-1], collapse = "~"))) + } + + + if (inherits(y,'NULL')) { + return(sprintf('%s = NULL',item)) + } + + + if (inherits(y, c("function", "call", "ggproto"))) { + return(sprintf("%s = %s", + item, + paste(capture.output( + dput(y)), + collapse = "\n") + )) + } + + if (inherits(y, c("data.frame"))) { + return(paste0("=", paste(capture.output(dput(y)), collapse = "\n"))) + } + + + return(sprintf('%s = %s',item, y)) + +} + +#' @noRd +capture.output <- function (..., file = NULL, append = FALSE, type = c("output", "message"), split = FALSE) +{ + type <- match.arg(type) + rval <- NULL + closeit <- TRUE + if (is.null(file)) + file <- textConnection("rval", "w", local = TRUE) + else if (is.character(file)) + file <- file(file, if (append) + "a" + else "w") + else if (inherits(file, "connection")) { + if (!isOpen(file)) + open(file, if (append) + "a" + else "w") + else closeit <- FALSE + } + else stop("'file' must be NULL, a character string or a connection") + sink(file, type = type, split = split) + on.exit({ + sink(type = type, split = split) + if (closeit) close(file) + }) + for (i in seq_len(...length())) { + out <- withVisible(...elt(i)) + if (out$visible) + print(out$value) + } + on.exit() + sink(type = type, split = split) + if (closeit) + close(file) + if (is.null(rval)) + invisible(NULL) + else rval +} + +avgHexColor <- function(colors, ctrlcolor){ + colors <- lapply(colors, col2rgb) + rgb(t(Reduce(`+`, colors)/length(colors)), maxColorValue=255) +} + +fill_na_with_preceding <- function(x) { + if (all(is.na(x))) return(x) + for (i in 2:length(x)) { + if (is.na(x[i])) { + x[i] <- x[i - 1] + } + } + return(x) +} \ No newline at end of file