#' @importFrom graphics plot
NULL
#' Paste with Sum
#'
#' Use %+% to paste0 two strings.
#'
#' @param a,b A string.
#' @return A string.
#' @examples
#' "Now you can paste() like " %+% " in Python."
#' @export
`%+%` <- function(a, b) paste0(a, b)
#' Save Figure
#'
#' This function saves a figure.
#'
#' @param plot The figure.
#' @param file A string. The file to save.
#' @param dir A string. The directory.
#' @param width,height The figure dimensions.
#' @param res The figure resolution.
#' @examples
#' \dontrun{
#' fig.save(plot(1:5, 1:5), file = "Figure1")
#' }
#' @export
fig.save <- function(plot, file = "fig", dir = getwd(), width = 5, height = 5, res = 600){
oldwd <- getwd()
setwd(dir)
grDevices::png(file %+% ".png", width = width, height = height,
res = res, units = "in")
plot
grDevices::dev.off()
setwd(oldwd)
}
#' Vertical Join Figures
#'
#' @param plot1,plot2 The figures.
#' @inheritParams fig.save
#' @examples
#' \dontrun{
#' fig.cbind(plot(1:5, 1:5), plot(1:5, 5:1), file = "Figure2")
#' }
#' @export
fig.cbind <- function(plot1, plot2, file = "fig", dir = getwd(), width = 5, height = 5, res = 600){
oldwd <- getwd()
setwd(dir)
fig.save(plot1, file = "out9000-temp1" %+% file, width = width, height = height, res = res)
fig.save(plot2, file = "out9000-temp2" %+% file, width = width, height = height, res = res)
system("convert +append out9000-temp1* out9000-temp2* " %+% file %+% ".png")
system("rm out9000-temp*")
setwd(oldwd)
}
#' Horizontal Join Figures
#'
#' @param plot1,plot2 The figures.
#' @inheritParams fig.save
#' @examples
#' \dontrun{
#' fig.rbind(plot(1:5, 1:5), plot(1:5, 5:1), file = "Figure3")
#' }
#' @export
fig.rbind <- function(plot1, plot2, file = "fig", dir = getwd(), width = 5, height = 5, res = 600){
oldwd <- getwd()
setwd(dir)
fig.save(plot1, file = "out9000-temp1" %+% file, width = width, height = height, res = res)
fig.save(plot2, file = "out9000-temp2" %+% file, width = width, height = height, res = res)
system("convert -append out9000-temp1* out9000-temp2* " %+% file %+% ".png")
system("rm out9000-temp*")
setwd(oldwd)
}
#' Tile Join Figures
#'
#' @param ... The figures.
#' @param tile A string. Describes how to tile the figures (e.g., "1x3").
#' @inheritParams fig.save
#' @examples
#' \dontrun{
#' fig.tile(plot(1:5), plot(6:10), plot(11:15), tile = "1x3", file = "Figure 4")
#' }
#' @export
fig.tile <- function(..., tile = "2x2", file = "fig", dir = getwd(), width = 5, height = 5, res = 600){
oldwd <- getwd()
setwd(dir)
args <- as.list(substitute(list(...)))[-1]
for(i in 1:length(args)){
fig.save(eval(args[[i]]), file = "out9000-temp" %+% i %+% file,
width = width, height = height, res = res)
}
system("montage out9000-temp* -tile " %+% tile %+% " -mode concatenate " %+% file %+% ".png")
system("rm out9000-temp*")
setwd(oldwd)
}
#' Make Figure from Table
#'
#' @param mat The matrix.
#' @param colmat A matrix of colors. Specifies the colors
#' for each cell in the matrix.
#' @return A grob.
#' @examples
#' colmat <- matrix("red", 5, 5)
#' colmat[,1] <- "blue"
#' fig.fromTable(iris[1:5, 1:5], colmat)
#' @export
fig.fromTable <- function(mat, colmat = matrix("black", nrow(mat), ncol(mat))){
if(!identical(dim(mat), dim(colmat))){
stop("'mat' and 'colmat' must have same dimensions.")
}
table_theme <- gridExtra::ttheme_minimal(
core = list(fg_params = list(col = colmat)))
grid::grid.newpage()
fig <- gridExtra::tableGrob(mat, theme = table_theme)
plot(fig)
fig
}
#' Label Figure Panel
#'
#' This function adds a label to the top-left of the figure.
#'
#' @param plot The figure.
#' @param label The label.
#' @return A grob.
#' @examples
#' grob <- fig.fromTable(iris[1:5,1:5])
#' fig.label(grob, "1A) An example")
#' @export
fig.label <- function(plot, label = "1) Place Label Here"){
tryCatch(
gridExtra::grid.arrange(
gridExtra::arrangeGrob(
plot, top = grid::textGrob(
label,
x = grid::unit(0.05, "npc"),
y = grid::unit(0, "npc"),
just = c("left","top"),
gp = grid::gpar(col = "black",
fontsize = 18))
)
),
error = function(e){
stop("This method does not work with base R graphics.")
}
)
}
#' Plot Adjacency Matrix
#'
#' This function uses \code{ggraph} to make a \code{ggplot} object.
#'
#' @param A An adjacency matrix.
#' @param n.group A character vector or factor. Groupings for the nodes.
#' Used to color the nodes in viridis hues.
#' @return A \code{ggplot} object.
#' @examples
#' A <- matrix(sample(0:1, 25, replace = TRUE), 5, 5)
#' fig.fromAdj(A, n.group = c(1, 2, 1, 2, 1))
#' @export
fig.fromAdj <- function(A, n.group = 1){
packageCheck("igraph")
packageCheck("ggraph")
# Turn adjacency matrix into igraph object
graph <- igraph::graph_from_adjacency_matrix(A, mode = "undirected")
igraph::V(graph)$class <- as.character(igraph::V(graph))
igraph::V(graph)$grp <- rep_len(n.group, nrow(A))
# Get x-lim and y-lim (used later to make space for panel legend)
set.seed(1)
lay <- ggraph::create_layout(graph, "igraph", algorithm = "nicely")
Ymax <- max(lay$y)
Ymin <- min(lay$y)
# Plot ggraph object from igraph object
set.seed(1)
ggplot <-
ggraph::ggraph(graph) +
ggraph::geom_edge_link(colour = viridis::viridis(2)[1], alpha = .2) +
ggraph::geom_node_point(ggplot2::aes_string(colour = "grp"), size = 10, alpha = .1) +
ggraph::geom_node_text(ggplot2::aes_string(label = "class")) +
ggplot2::ylim(Ymin, Ymax + abs(Ymax * .05)) + # increases a negative or positive Ymax
ggplot2::theme_bw() + ggplot2::xlab("") + ggplot2::ylab("") +
ggplot2::theme(
axis.line = ggplot2::element_blank(),
axis.text.x = ggplot2::element_blank(),
axis.text.y = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank(),
axis.title.x = ggplot2::element_blank(),
axis.title.y = ggplot2::element_blank(),
legend.position = "none",
panel.background = ggplot2::element_blank(),
panel.border = ggplot2::element_blank(),
panel.grid.major = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
plot.background = ggplot2::element_blank()
)
ggplot <- tryCatch(
plot(ggplot + viridis::scale_color_viridis(discrete = FALSE)),
error = function(e) plot(ggplot + viridis::scale_color_viridis(discrete = TRUE))
)
}
#' Make \code{ggplot} Pretty
#'
#' @param ggplot A \code{ggplot} object.
#' @param col A boolean. Toggles whether to color the figure with viridis.
#' @param rotate.x A boolean. Toggles whether to rotate the x-axis.
#' @examples
#' \dontrun{
#' p <- ggplot(mtcars, aes(wt, mpg, col = cyl))
#' p <- p + geom_point()
#' fig.pretty(p, col = TRUE)
#' }
#' @export
fig.pretty <- function(ggplot, col = FALSE, rotate.x = FALSE){
ggplot <- ggplot +
ggplot2::theme(text = ggplot2::element_text(size = 18),
plot.title = ggplot2::element_text(size = 24)) +
ggplot2::theme_bw()
if(col) ggplot <- tryCatch(
plot(ggplot + viridis::scale_color_viridis(discrete = FALSE)),
error = function(e) plot(ggplot + viridis::scale_color_viridis(discrete = TRUE))
)
if(rotate.x) ggplot <- ggplot +
ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 1))
return(ggplot)
}
#' Make 3D Plot
#'
#' @param data A \code{data.frame}.
#' @param x,y,z A numeric. The x, y, and z dimensions to plot.
#' @param n.group A character vector or factor. Groupings for the points.
#' Used to color the figure.
#' @param main A string. The plot title.
#' @examples
#' \dontrun{
#' fig.quick3D(mtcars, x = 1, y = 2, z = 3, n.group = mtcars$cyl)
#' }
#' @export
fig.3D <- function(data, x = 1, y = 2, z = 3, n.group = 1, main = ""){
packageCheck("lattice")
if(is.null(colnames(data))){
stop("Provided data must have column names.")
}
data <- as.data.frame(data)
xlab <- colnames(data)[x]
ylab <- colnames(data)[y]
zlab <- colnames(data)[z]
colnames(data)[c(x, y, z)] <- c("x", "y", "z")
grp <- rep_len(n.group, nrow(data))
lattice::cloud(z ~ x * y, data = data,
group = grp, main = main, pch = 3, alpha = .8,
xlab = list(xlab, rot = 29),
ylab = list(ylab, rot = 321),
zlab = list(zlab, rot = 94+180))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.