#' names of the sides in gsplot object
#'
#' @param object a gsplot object
#' @return a character vector of side names
#' @keywords internal
side_names <- function(object){
names(sides(object))
}
#' take a view name and extract the numeric x side
#'
#' @param view.name a chracter vector of view names
#' @return an integer vector of x sides
#' @keywords internal
as.x_side <- function(view.name){
sapply(view.name, function(x) get_sides_x(as.side(x)), USE.NAMES = FALSE)
}
#' take a view name and extract the named x sides
#'
#' @param view.name a chracter vector of view names
#' @return an character vector of x side names
#' @keywords internal
as.x_side_name <- function(view.name){
as.side_name(as.x_side(view.name))
}
#' take a view name and extract the numeric y sides
#'
#' @param view.name a chracter vector of view names
#' @return an integer vector of y sides
#' @keywords internal
as.y_side <- function(view.name){
sapply(view.name, function(x) get_sides_y(as.side(x)), USE.NAMES = FALSE)
}
#' take a view name and extract the named y sides
#'
#' @param view.name a chracter vector of view names
#' @return an character vector of s side names
#' @keywords internal
as.y_side_name <- function(view.name){
as.side_name(as.y_side(view.name))
}
#' get the side names
#'
#' @param x a numeric vector of sides or character vector of view names
#' @return a character vector of side names
#' @keywords internal
#' @export
as.side_name <- function(x) UseMethod("as.side_name")
#' @keywords internal
#' @export
as.side_name.numeric <- function(x){
paste('side.',x, sep='')
}
#' @keywords internal
#' @export
as.side_name.character <- function(x){
as.side_name(sapply(x, function(x) as.numeric(tail(strsplit(x,'[.]')[[1]],-1L)), USE.NAMES = FALSE))
}
#' take a named side and turn it into numeric
#'
#' @param x a character vector of side of view names (length 1)
#' @return numeric values for \code{side}
#' @keywords internal
as.side <- function(x){
c_unname(lapply(x, function(x) as.numeric(tail(strsplit(x,'[.]')[[1]],-1L))))
}
#' take a named or numbered side and give whether it is an x or y axis
#'
#' @param side numeric or named \code{side}
#' @return "x" or "y" character vector
#' @keywords internal
as.axis <- function(x) UseMethod("as.axis")
#' @keywords internal
#' @export
as.axis.character <- function(side) {
side <- as.side(side)
axis <- as.axis(side)
return(axis)
}
#' @keywords internal
#' @export
as.axis.numeric <- function(side) {
axis <- rep("x", length(side))
is.y <- side %% 2 == 0
axis[is.y] <- "y"
return(axis)
}
#' which indices in the gsplot object are sides
#'
#' @param gsplot a gsplot object
#' @return indices of sides
#' @keywords internal
which_sides <- function(gsplot){
grep('side.', names(gsplot))
}
#' subset the gsplot object to return only sides
#'
#' @param gsplot a gsplot object
#' @param by.index retrieve specific indices (NA returns all)
#' @return a sides list
#' @keywords internal
sides <- function(gsplot, by.index=NA){
mySides <- gsplot[which_sides(gsplot)]
if (!all(is.na(by.index))) {
indices <- as.side(names(mySides))
mySides <- mySides[indices %in% by.index]
}
return(mySides)
}
#' sets the user-defined limits to sides
#'
#' @param lims the usr.lims
#' @param side a side
#' @return the modified side
#' @keywords internal
set_usr_lim <- function(lims, side){
to.set <- !is.na(lims)
if(any(to.set)) class(side$lim) <- class(lims)
side$lim[to.set] <- lims[to.set]
side$usr.lim[to.set] <- TRUE
return(side)
}
#' set the axes logical on a side
#'
#' @param args arguments to pull log info from
#' @param side the side for the gsplot object (see \code{\link{sides}})
#' @return a modified \code{side}
#' @keywords internal
set_side_axes <- function(args, side, side.num){
stopifnot(length(side.num) == 1)
side$axes <- ifelse(exists("axes", args), args$axes, side$axes)
return(side)
}
#' set the log value on a side
#'
#' @param args arguments to pull log info from
#' @param side the side for the gsplot object (see \code{\link{sides}})
#' @return a modified \code{side}
#' @keywords internal
set_side_log <- function(args, side, side.num){
stopifnot(length(side.num) == 1)
axis <- as.axis(side.num)
log <- ifelse(exists("log", args), args$log, "")
if (log == "")
return(side) # // do nothing
side$log <- grepl(axis,log) || side$log
return(side)
}
#' set the label value on a side
#'
#' @param args arguments to pull label from
#' @param side the side for the gsplot object (see \code{\link{sides}})
#' @param side.num which side are we talking about
#' @return a modified \code{sides} list
#' @keywords internal
set_side_lab <- function(args, side, side.num){
stopifnot(length(side.num) == 1)
axis <- as.axis(side.num)
lab.arg <- paste0(axis, "lab")
if (exists(lab.arg, args)) {
lab <- args[[lab.arg]]
side$label <- ifelse(is.expression(lab) || !is.na(lab), lab, side$label)
}
return(side)
}
#' sets the side limits according to a new addition
#'
#' @param args pass through args from graphics call
#' @param side the side for the gsplot object (see \code{\link{as.side}})
#' @param side.num number of side being worked on
#' @return a modified \code{sides} list
#' @keywords internal
set_side_lim <- function(args, side, side.num){
stopifnot(length(side.num) == 1)
axis <- as.axis(side.num)
include <- switch(axis,
x = c('x','x1','x0','xleft','xright', 'data', 'v'),
y = c('y','y1','y0','ytop','ybottom', 'data', 'h'))
# // need value arguments, need yaxs/xaxs args, need user-specified ylim/xlim values
usr.lims <- c(NA, NA)
lim.arg = paste0(axis,"lim")
if (exists(lim.arg, args)) {
usr.lims <- args[[lim.arg]]
}
side <- set_usr_lim(usr.lims, side)
free.lim <- !side$usr.lim
if(any(free.lim)){
side.vals <- strip_pts(args, include)
if (any(!is.na(side.vals))){
data.range <- range(append_keep_tz(base.vals=side.vals[is.finite(side.vals)],
append.vals=side$lim,
tz=attr(side.vals, 'tzone')),
na.rm = TRUE)
data.range[!free.lim] <- side$lim[!free.lim]
side$lim <- data.range
}
}
return(side)
}
#' add a new default side to gsplot
#'
#' @param object a gsplot object
#' @param side.name a character for side name, in the form of 'side.1'
#' @return a modifies gsplot object
add_new_side <- function(object, side.name){
stopifnot(length(side.name) == 1)
if (side.name %in% side_names(object))
stop(side.name, ' already exists, cannot add it.', call. = FALSE)
side.template <- list(list(
axis = set_args('axis', side=as.side(side.name),
custom.config = object[["global"]][["config"]][["config.file"]],
package='graphics'),
lim = c(NA, NA), log=FALSE, label="", axes = TRUE, reverse = FALSE, usr.lim=c(FALSE, FALSE), usr.axes=FALSE))
names(side.template) <- side.name
last.side.i <- max(which_sides(object), 0)
object <- append(object, side.template, after = last.side.i)
object <- modify_side_par(object, arguments=list(c()), side=as.side(side.name))
return(object)
}
#' automatically fill in sides as pairs if they are single vals
#'
#' @param sides an integer vector of length one or two
#' @return a side integer vector of length two
#' @keywords internal
set_sides <- function(sides){
if (length(sides)==1){
if(sides %% 2 == 0)
sides = c(1,sides)
else
sides = c(sides,2)
}
return(sides)
}
#' return sides that are either x (odd)
#'
#' @param sides an integer vector of any length
#' @return the side that corresponds to x
#' @keywords internal
get_sides_x <- function(sides){
sides[sides %% 2 != 0]
}
#' return sides that are either y (even)
#'
#' @param sides an integer vector of any length
#' @return the side that corresponds to y
#' @keywords internal
get_sides_y <- function(sides){
sides[sides %% 2 == 0]
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.