Nothing
# skip if during devtools::check() or rcmdcheck::rcmdcheck()
skip_on_check <- function() {
on_check <- !identical(Sys.getenv("_R_CHECK_PACKAGE_NAME_"), "")
testthat::skip_if(on_check, "On devtools::check() / rcmdcheck::rcmdcheck()")
}
# mock up dummy data.frame -> soma_adat
# minimal set of attributes to trick `is_intact_attr()` to be TRUE
mock_adat <- function() {
data <- data.frame(
PlateId = rep_len("Set A", 6),
SlideId = (12345 + 0:5),
Subarray = rep(1:3, 2),
SampleId = sprintf("%03i", 1:6),
SampleGroup = rep(c("A", "B"), 3),
TimePoint = rep(c("before", "after"), each = 3),
NormScale = round(withr::with_seed(1, runif(6, 0, 2)), 1L),
seq.1234.56 = round(withr::with_seed(2, rnorm(6, 2500, 500)), 1L),
seq.3333.33 = round(withr::with_seed(3, rnorm(6, 3000, 500)), 1L),
seq.9898.99 = round(withr::with_seed(4, rnorm(6, 3500, 500)), 1L)
)
rownames(data) <- genRowNames(data)
structure(
data,
class = c("soma_adat", "data.frame"),
Header.Meta = list(HEADER = list(Version = "1.2",
AssayVersion = "V4",
AssayRobot = "Fluent 1",
AssayType = "PharmaServices",
StudyMatrix = "EDTA Plasma",
Title = "SL-99-999"),
COL_DATA = list(Name = c("SeqId", "UniProt",
"EntrezGeneSymbol", "Target",
"Organism","Units", "Type",
"Dilution", "CalReference"),
Type = rep_len("String", 9)
),
ROW_DATA = list(Name = getMeta(data),
Type = rep_len("String",
getMeta(data, n = TRUE))
)
),
Col.Meta = tibble::tibble(
SeqId = c("1234-56", "3333-33", "9898-99"),
UniProt = paste0("P0", 4321:4323),
EntrezGeneSymbol = c("MMP1", "MMP2", "MMP3"),
Target = c("MMP-1", "MMP-2", "MMP-3"),
Organism = rep_len("Human", 3L),
Units = rep_len("RFU", 3L),
Type = rep_len("Protein", 3L),
Dilution = c("0.005", "1", "40"),
CalReference = seq(0.4, 0.8, length.out = 3L)),
file_specs = list(empty_adat = FALSE,
table_begin = 20,
col_meta_start = 21,
col_meta_shift = 15,
data_begin = 21 + 9,
old_adat = FALSE),
row_meta = getMeta(data)
)
}
# temporarily mask the base::interactive function
# with new value: lgl
with_interactive <- function(lgl, code) {
old <- base::interactive # save the old function
new <- function() return(lgl) # set new hard-coded return value
unlockBinding("interactive", as.environment("package:base")) # unlock
# hack base::interactive with 'new'
assign("interactive", new, envir = as.environment('package:base'))
on.exit({
# undo cleanup when closes
unlockBinding("interactive", as.environment("package:base"))
assign("interactive", old, envir = as.environment('package:base'))
})
force(code) # execute code in new state
}
# temporarily modify internal pkg object
# for testing edge cases
with_pkg_object <- function(new, code, obj = "ver_dict") {
old <- getFromNamespace(obj, ns = "SomaDataIO") # save the old obj
assignInNamespace(obj, new, ns = "SomaDataIO")
on.exit(assignInNamespace(obj, old, ns = "SomaDataIO"))
force(code)
}
# Inspired by `expect_snapshot_file()` documentation
save_png <- function(code, ..., gg = TRUE) {
path <- figure(tempfile(fileext = ".png"), ...)
on.exit(close_figure(path))
if ( gg ) {
print(force(code))
} else {
force(code)
}
path
}
expect_snapshot_plot <- function(code, name, ...) {
name <- paste0(name, ".png")
withr::defer(unlink(name, force = TRUE))
# Announce the file before touching `code`. This way, if `code`
# unexpectedly fails or skips, testthat will not auto-delete the
# corresponding snapshot file
announce_snapshot_file(name = name)
# only run on MacOS
skip_on_os(c("linux", "windows"))
path <- save_png(code, ...)
expect_snapshot_file(path, name)
}
#' Saves a Figure (Plot) to File
#'
#' A wrapper for [png()], [pdf()], or [jpeg()] to save plots to
#' disk. If a file path is passed to [figure()], it
#' opens a plotting device based on the file extension,
#' passing the same file name to [close_figure()].
#' If `file = NULL`, output is directed to the default plotting device.
#'
#' The [figure()] and [close_figure()] functions
#' are most useful when used inside of another function that creates a plot.
#' By adding a `file =` pass-through argument to a function that creates a plot,
#' the user can toggle between plotting to file or to a graphics device.
#' Supported plotting devices:
#' \itemize{
#' \item [png()]
#' \item [pdf()]
#' \item [jpeg()]
#' \item [postscript()] (`*.eps`)
#' }
#'
#' @family base R
#' @param file Character. The path of the output file passed to [png()],
#' [pdf()], or [jpeg()]. Plot type determined by file extension.
#' @param height Double. The height of the plot in pixels.
#' @param width Double. The width of the plot in pixels.
#' @param scale A re-scaling of the output to resize window better.
#' @param ... Additional arguments passed to [png()], [pdf()], or [jpeg()].
#' @note The `fontsize` of the plots are constant. If you would like to
#' increase the font size relative to the plot, you can decrease the plot size.
#' Alternatively, you can pass `pointsize` as an additional argument.
#' @author Stu Field
#' @return The `file` argument, invisibly.
#' @seealso [png()], [pdf()], [dev.off()]
#' @examples
#' # Create enclosing plotting function
#' createPlot <- function(file = NULL) {
#' figure(file = file)
#' on.exit(close_figure(file = file))
#' plot_data <- withr::with_seed(1, matrix(rnorm(30), ncol = 2))
#' plot(as.data.frame(plot_data), col = unlist(soma_colors), pch = 19, cex = 2)
#' }
#'
#' # default; no file saved
#' createPlot()
#'
#' if ( interactive() ) {
#' # Save as *.pdf
#' createPlot("example.pdf")
#'
#' # Save as *.png
#' createPlot("example.png")
#' }
#' @importFrom grDevices pdf png jpeg postscript
figure <- function(file, height = 480, width = 480, scale = 1, ...) {
if ( !is.null(file) ) {
ext <- file_ext(file)
if ( isTRUE(ext == "pdf") ) {
pdf(file = file,
height = (height / 96) * scale, # assume 96 px / in
width = (width / 96) * scale,
useDingbats = FALSE,
title = basename(file), ...)
} else if ( isTRUE(ext == "png") ) {
png(filename = file,
height = height * scale,
width = width * scale, ...)
} else if ( isTRUE(ext == "eps") ) {
postscript(file = file,
height = height * scale * 100,
width = width * scale * 100,
horizontal = FALSE,
onefile = FALSE,
paper = "special", ...)
} else if ( isTRUE(ext == "jpeg") ) {
jpeg(filename = file, height = height * scale, width = width * scale, ...)
} else {
stop(
"Could not find file extension ", value(ext),
" in provided file path: ", value(file), call. = FALSE
)
}
}
invisible(file)
}
#' Closes the currently active plotting device with a
#' [dev.off()] call if a file name is passed. If
#' `file = NULL`, nothing happens. This function is typically used in
#' conjunction with [figure()] inside the enclosing function. See example.
close_figure <- function(file) {
if ( !is.null(file) ) {
grDevices::dev.off()
}
invisible(file)
}
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.