Nothing
# Copyright (C) 2021 Brodie Gaslam
#
# This file is part of "diffobj - Diffs for R Objects"
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
#' @include html.R
#' @include finalizer.R
#' @include pager.R
NULL
# maybe this shouldn't be an S4 class since the function slot doesn't work
# for classed functions (e.g. the ones produced by crayon)
#' Functions Used for Styling Diff Components
#'
#' Except for \code{container} every function specified here should be
#' vectorized and apply formatting to each element in a character vectors. The
#' functions must accept at least one argument and require no more than one
#' argument. The text to be formatted will be passed as a character vector
#' as the first argument to each function.
#'
#' These functions are applied in post processing steps. The \code{diff*}
#' methods do not do any of the formatting. Instead, the formatting is done
#' only if the user requests to \code{show} the object. Internally, \code{show}
#' first converts the object to a character vector using \code{as.character},
#' which applies every formatting function defined here except for
#' \code{container}. Then \code{show} applies \code{container} before
#' forwarding the result to the screen or pager.
#'
#' @note the slots are set to class \dQuote{ANY} to allow classed functions
#' such as those defined in the \code{crayon} package. Despite this seemingly
#' permissive slot definition, only functions are allowed in the slots by
#' the validation functions.
#' @param container function used primarily by HTML styles to generate an
#' outermost \code{DIV} that allows for CSS targeting of its contents
#' (see \code{\link{cont_f}} for a function generator appropriate for use
#' here)
#' @param line function
#' @param line.insert function
#' @param line.delete function
#' @param line.match function
#' @param line.guide function formats guide lines (see \code{\link{guides}})
#' @param text function
#' @param text.insert function
#' @param text.delete function
#' @param text.match function
#' @param text.guide function formats guide lines (see \code{\link{guides}})
#' @param gutter function
#' @param gutter.insert function
#' @param gutter.delete function
#' @param gutter.match function
#' @param gutter.guide function
#' @param gutter.pad function
#' @param header function to format each hunk header with
#' @param banner function to format entire banner
#' @param banner.insert function to format insertion banner
#' @param banner.delete function to format deletion banner
#' @param meta function format meta information lines
#' @param context.sep function to format the separator used to visually
#' distinguish the A and B hunks in \dQuote{context} \code{mode}
#' @return a StyleFuns S4 object
#' @seealso \code{\link{Style}}
#' @rdname StyleFuns
#' @export StyleFuns
#' @exportClass StyleFuns
StyleFuns <- setClass(
"StyleFuns",
slots=c(
container="ANY", row="ANY",
line="ANY", line.insert="ANY", line.delete="ANY", line.match="ANY",
line.guide="ANY", line.fill="ANY",
text="ANY", text.insert="ANY", text.delete="ANY", text.match="ANY",
text.guide="ANY", text.fill="ANY",
banner="ANY", banner.insert="ANY", banner.delete="ANY",
gutter="ANY",
gutter.insert="ANY", gutter.insert.ctd="ANY",
gutter.delete="ANY", gutter.delete.ctd="ANY",
gutter.match="ANY", gutter.match.ctd="ANY",
gutter.guide="ANY", gutter.guide.ctd="ANY",
gutter.fill="ANY", gutter.fill.ctd="ANY",
gutter.context.sep="ANY", gutter.context.sep.ctd="ANY",
gutter.pad="ANY",
word.insert="ANY", word.delete="ANY",
context.sep="ANY", header="ANY", meta="ANY", trim="ANY"
),
prototype=list(
container=identity, row=identity,
banner=identity, banner.insert=identity, banner.delete=identity,
line=identity, line.insert=identity, line.delete=identity,
line.match=identity, line.guide=identity, line.fill=identity,
text=identity, text.insert=identity, text.delete=identity,
text.match=identity, text.guide=identity, text.fill=identity,
gutter=identity, gutter.pad=identity,
gutter.insert=identity, gutter.insert.ctd=identity,
gutter.delete=identity, gutter.delete.ctd=identity,
gutter.match=identity, gutter.match.ctd=identity,
gutter.guide=identity, gutter.guide.ctd=identity,
gutter.fill=identity, gutter.fill.ctd=identity,
gutter.context.sep=identity, gutter.context.sep.ctd=identity,
word.insert=identity, word.delete=identity,
header=identity,
context.sep=identity,
meta=identity,
trim=identity
),
validity=function(object){
for(i in slotNames(object)) {
if(!is.function(slot(object, i)))
return(paste0("Argument `", i, "` should be a function."))
if(has_non_def_formals(tail(formals(slot(object, i)), -1L)))
return(
paste0(
"Argument `", i,
"` may not have non-default formals argument after the first."
) )
}
TRUE
}
)
StyleFunsAnsi <- setClass(
"StyleFunsAnsi", contains="StyleFuns",
prototype=list(
word.insert=crayon::green, word.delete=crayon::red,
gutter.insert=crayon::green, gutter.insert.ctd=crayon::green,
gutter.delete=crayon::red, gutter.delete.ctd=crayon::red,
gutter.guide=crayon::silver, gutter.guide.ctd=crayon::silver,
gutter.fill=crayon::silver, gutter.fill.ctd=crayon::silver,
gutter.context.sep=crayon::silver, gutter.context.sep.ctd=crayon::silver,
header=crayon::cyan,
meta=crayon::silver,
line.guide=crayon::silver,
context.sep=crayon::silver,
trim=crayon::silver
)
)
#' Character Tokens Used in Diffs
#'
#' Various character tokens are used throughout diffs to provide visual cues.
#' For example, gutters will contain characters that denote deletions and
#' insertions (\code{<} and \code{>} by default).
#'
#' @param gutter.insert character(1L) text to use as visual cue to indicate
#' whether a diff line is an insertion, defaults to \dQuote{> }
#' @param gutter.insert.ctd character(1L) if a diff line is wrapped, the
#' visual cue shifts to this character to indicate wrapping occured
#' @param gutter.delete character(1L) see \code{gutter.insert} above
#' @param gutter.delete.ctd character(1L) see \code{gutter.insert.ctd} above
#' @param gutter.match character(1L) see \code{gutter.insert} above
#' @param gutter.match.ctd character(1L) see \code{gutter.insert.ctd} above
#' @param gutter.guide character(1L) see \code{gutter.insert} above
#' @param gutter.guide.ctd character(1L) see \code{gutter.insert.ctd} above
#' @param gutter.fill character(1L) see \code{gutter.insert} above
#' @param gutter.fill.ctd character(1L) see \code{gutter.insert.ctd} above
#' @param gutter.pad character(1L) separator between gutter characters and the
#' rest of a line in a diff
#' @param pad.col character(1L) separator between columns in side by side mode
#' @return a StyleText S4 object
#' @seealso \code{\link{Style}}
#' @rdname StyleText
#' @export StyleText
#' @exportClass StyleText
StyleText <- setClass(
"StyleText",
slots=c(
gutter.insert="character", gutter.insert.ctd="character",
gutter.delete="character", gutter.delete.ctd="character",
gutter.match="character", gutter.match.ctd="character",
gutter.guide="character", gutter.guide.ctd="character",
gutter.fill="character", gutter.fill.ctd="character",
gutter.context.sep="character", gutter.context.sep.ctd="character",
gutter.pad="character",
context.sep="character",
pad.col="character",
line.break="character"
),
prototype=list(
gutter.insert=">", gutter.insert.ctd=":",
gutter.delete="<", gutter.delete.ctd=":",
gutter.match=" ", gutter.match.ctd=" ",
gutter.guide="~", gutter.guide.ctd="~",
gutter.fill="~", gutter.fill.ctd="~",
gutter.context.sep="~", gutter.context.sep.ctd="~",
gutter.pad=" ", context.sep="----------",
pad.col=" ",
line.break="\n"
),
validity=function(object){
for(i in slotNames(object)) if(!is.chr.1L(slot(object, i)))
return(paste0("Argument `", i, "` must be character(1L) and not NA."))
TRUE
}
)
#' Styling Information for Summaries
#'
#' @export
#' @rdname StyleSummary
#' @slot container function applied to entire summary
#' @slot body function applied to everything except the actual map portion of
#' the summary
#' @slot detail function applied to section showing how many deletions /
#' insertions, etc. occurred
#' @slot map function applied to the map portion of the summary
StyleSummary <- setClass("StyleSummary",
slots=c(container="ANY", body="ANY", map="ANY", detail="ANY"),
prototype=list(
container=function(x) sprintf("\n%s\n", paste0(x, collapse="")),
body=identity,
detail=function(x) sprintf("\n%s\n", paste0(" ", x, collapse="")),
map=function(x) sprintf("\n%s", paste0(" ", x, collapse="\n"))
),
validity=function(object) {
fun.slots <- c("container", "body", "map", "detail")
for(i in fun.slots) {
if(!isTRUE(is.one.arg.fun(slot(object, i))))
return(
"Slot ", i, " must contain a function that accepts at least one ",
"argument and requires no more than one argument."
)
}
TRUE
}
)
#' @rdname StyleSummary
#' @export
StyleSummaryHtml <- setClass("StyleSummaryHtml", contains="StyleSummary",
prototype=list(
container=function(x) div_f("diffobj-summary")(paste0(x, collapse="")),
body=div_f("body"),
detail=div_f("detail"),
map=div_f("map")
) )
#' Customize Appearance of Diff
#'
#' S4 objects that expose the formatting controls for \code{Diff}
#' objects. Many predefined formats are defined as classes that extend the
#' base \code{Style} class. You may fine tune styles by either extending
#' the pre-defined classes, or modifying an instance thereof.
#'
#' @section Pre-defined Classes:
#'
#' Pre-defined classes are used to populate the \code{\link{PaletteOfStyles}}
#' object, which in turn allows the \code{diff*} methods to pick the
#' appropriate \code{Style} for each combination of the \code{format},
#' \code{color.mode}, and \code{brightness} parameters when the \code{style}
#' parameter is set to \dQuote{auto}. The following classes are pre-defined:
#'
#' \itemize{
#' \item \code{StyleRaw}: No styles applied
#' \item \code{StyleAnsi8NeutralRgb}
#' \item \code{StyleAnsi8NeutralYb}
#' \item \code{StyleAnsi256LightRgb}
#' \item \code{StyleAnsi256LightYb}
#' \item \code{StyleAnsi256DarkRgb}
#' \item \code{StyleAnsi256DarkYb}
#' \item \code{StyleHtmlLightRgb}
#' \item \code{StyleHtmlLightYb}
#' }
#' Each of these classes has an associated constructor function with the
#' same name (see examples). Objects instantiated from these classes
#' may also be used directly as the value for the \code{style} parameter to the
#' \code{diff*} methods. This will override the automatic selection process
#' that uses \code{\link{PaletteOfStyles}}. If you wish to tweak an
#' auto-selected style rather than explicitly specify one, pass a parameter
#' list instead of a \code{Style} objects as the \code{style} parameter to the
#' \code{diff*} methods (see examples).
#'
#' There are predefined classes for most combinations of
#' \code{format/color.mode/brightness}, but not all. For example, there are
#' only \dQuote{light} \code{brightness} defined for the \dQuote{html}
#' \code{format}, and those classes are re-used for all possible
#' \code{brightness} values, and the 8 color ANSI neutral classes are used
#' for the 256 color neutral selections as well.
#'
#' To get a preview of what a style looks like just instantiate
#' an object; the \code{show} method will output a trivial diff to screen with
#' styles applied. Note that for ANSI styles of the dark and light variety
#' the show method colors the terminal background and foregrounds in compatible
#' colors. In normal usage the terminal background and foreground colors are
#' left untouched so you should not expect light styles to look good on dark
#' background and vice versa even if they render correctly when showing the
#' style object.
#'
#' @section Style Structure:
#'
#' Most of the customization is done by specifying functions that operate on
#' character vectors and return a modified character vector of the same length.
#' The intended use case is to pass \code{crayon} functions such as
#' \code{crayon::red}, although you may pass any function of your liking
#' that behaves as described. Formatting functions are expected to return their
#' inputs formatted in such a way that their \emph{display} width is unchanged.
#' If your formatting functions change display width output may not render
#' properly, particularly when using \code{mode="sidebyside"}.
#'
#' The visual representation of the diff has many nested components. The
#' functions you specify here will be applied starting with the innermost ones.
#' A schematic of the various component that represent an inserted line follows
#' (note \dQuote{insert} abbreviated to \dQuote{ins}, and \dQuote{gutter}
#' abbreviated to \dQuote{gtr}):
#' \preformatted{+- line ---------------------------------------------------+
#' |+- line.ins ---------------------------------------------+|
#' ||+- gtr ------------------------++- text ---------------+||
#' |||+- gtr.ins ---++- gtr.pad ---+||+- text.ins ---------+|||
#' |||| || |||| +- word.ins -+||||
#' |||| gtr.ins.txt || gtr.pad.txt |||| DIFF | TEXT HERE |||||
#' |||| || |||| +------------+||||
#' |||+-------------++-------------+||+--------------------+|||
#' ||+------------------------------++----------------------+||
#' |+--------------------------------------------------------+|
#' +----------------------------------------------------------+
#' }
#' A similar model applies to deleted and matching lines. The boxes represent
#' functions. \code{gutter.insert.txt} represents the text to use in the gutter
#' and is not a function. \code{DIFF TEXT HERE} is text from the objects being
#' diffed, with the portion that has different words inside the
#' \code{word.insert}. \code{gutter.pad} and \code{gutter.pad.txt} are used to
#' separate the gutter from the text and usually end up resolving to a space.
#'
#' Most of the functions defined here default to \code{\link{identity}}, but
#' you are given the flexibility to fully format the diff. See
#' \code{\link{StyleFuns}} and \code{\link{StyleText}} for a full listing of
#' the adjustable elements.
#'
#' In side-by-side mode there are two \dQuote{lines} per screen line, each with
#' the structure described here.
#'
#' The structure described here may change in the future.
#'
#' @section HTML Styles:
#'
#' If you use a \code{Style} that inherits from \code{StyleHtml} the
#' diff will be wrapped in HTML tags, styled with CSS, and output to
#' \code{getOption("viewer")} if your IDE supports it (e.g. Rstudio), or
#' directly to the browser otherwise, assuming that the default
#' \code{\link{Pager}} or a correctly configured pager that inherits from
#' \code{\link{PagerBrowser}} is in effect. Otherwise, the raw HTML will be
#' output to your terminal.
#'
#' By default HTML output sent to the viewer/browser is a full stand-alone
#' webpage with CSS styles to format and color the diff, and JS code to
#' handle scaling. The CSS and JS is read from the
#' \link[=webfiles]{default files} and injected into the HTML to simplify
#' packaging of the output. You can customize the CSS and JS by using the
#' \code{css} and \code{js} arguments respectively, but read the rest of this
#' documentation section if you plan on doing so.
#'
#' Should you want to capture the HTML output for use elsewhere, you can do
#' so by using \code{as.character} on the return value of the \code{diff*}
#' methods. If you want the raw HTML without any of the headers, CSS, and
#' JS use \code{html.ouput="diff.only"} when you instantiate the
#' \code{StyleHtml} object (see examples), or disable the \code{\link{Pager}}.
#' Another option is \code{html.output="diff.w.style"} which will add
#' \code{<style>} tags with the CSS, but without wrapping those in \code{<head>}
#' tags. This last option results in illegal HTML with a \code{<style>} block
#' outside of the \code{<head>} block, but appears to work and is useful if you
#' want to embed HTML someplace but do not have access to the headers.
#'
#' If you wish to modify the CSS styles you should do so cautiously. The
#' HTML and CSS work well together out of the box, but may not take to kindly
#' to modifications. The safest changes you can make are to the colors of the
#' scheme. You also probably should not modify the functions in the
#' \code{@funs} slot of the \code{StyleHtml} object. If you want to provide
#' your own custom styles make a copy of the file at the location returned by
#' \code{diffobj_css()}, modify it to your liking, and pass the location of your
#' modified sheet back via the \code{css} argument (see examples).
#'
#' The javascript controls the scaling of the output such that its width fits
#' in the viewport. If you wish to turn of this behavior you can do so via the
#' \code{scale} argument. You may need to modify the javascript if you modify
#' the \code{@funs} functions, but otherwise you are probably best off leaving
#' the javascript untouched. You can provide the location of a modified
#' javascript file via the \code{js} argument.
#'
#' Both the CSS and JS files can be specified via options,
#' \dQuote{diffobj.html.css}, and \dQuote{diffobj.html.js} respectively.
#'
#' If you define your own custom \code{StyleHtml} object you may want to modify
#' the slot \code{@funs@container}. This slot contains a function that is
#' applied to the entire diff output. For example, \code{StyleHtmlLightRgb}
#' uses \code{@funs@container <- cont_f("light", "rgb")}. \code{cont_f} returns
#' a function that accepts a character vector as an argument and returns
#' that value wrapped in a \code{DIV} block with class
#' \dQuote{"diffobj-container light rgb"}. This allows the CSS style sheet to
#' target the \code{Diff} elements with the correct styles.
#'
#' @section Modifying Style Parameters Directly:
#'
#' Often you will want to specify some of the style parameters (e.g.
#' \code{scale} for html styles) while still relying on the default style
#' selection to pick the specific style. You can do so by passing a list to the
#' \code{style} parameter of the \code{\link[=diffPrint]{diff*}} methods.
#' See examples.
#'
#' @section New Classes:
#'
#' You can in theory create entirely new classes that extent \code{Style}. For
#' example you could generate a class that renders the diff in \code{grid}
#' graphics. Note however that we have not tested such extensions and it is
#' possible there is some embedded code that will misbehave with such a new
#' class.
#'
#' @rdname Style
#' @export Style
#' @exportClass Style
#' @param funs a \code{\link{StyleFuns}} object that contains all the functions
#' represented above
#' @param text a \code{\link{StyleText}} object that contains the non-content
#' text used by the diff (e.g. \code{gutter.insert.txt})
#' @param summary a \code{\link{StyleSummary}} object that contains formatting
#' functions and other meta data for rendering summaries
#' @param wrap TRUE or FALSE, whether the text should be hard wrapped to fit in
#' the console
#' @param pad TRUE or FALSE, whether text should be right padded
#' @param pager what type of \code{\link{Pager}} to use
#' @param nchar.fun function to use to count characters; intended mostly for
#' internal use (used only for gutters as of version 0.2.0).
#' @param wrap TRUE or FALSE, whether text should be hard wrapped at
#' \code{disp.width}
#' @param na.sub what character value to substitute for NA elements; NA elements
#' are generated when lining up side by side diffs by adding padding rows; by
#' default the text styles replace these with a blank character string, and
#' the HTML styles leave them as NA for the HTML formatting functions to deal
#' with
#' @param blank sub what character value to replace blanks with; needed in
#' particular for HTML rendering (uses \code{" "}) to prevent lines from
#' collapsing
#' @param disp.width how many columns the text representation of the objects to
#' diff is allowed to take up before it is hard wrapped (assuming \code{wrap}
#' is TRUE). See param \code{disp.width} for \code{\link{diffPrint}}.
#' @param finalizer function that accepts at least two parameters and requires
#' no more than two parameters, will receive as the first parameter the
#' the object to render (either a \code{Diff} or a \code{DiffSummary}
#' object), and the text representation of that object as the second
#' argument. This allows final modifications to the character output so that
#' it is displayed correctly by the pager. For example, \code{StyleHtml}
#' objects use it to generate HTML headers if the \code{Diff} is destined to
#' be displayed in a browser. The object themselves are passed along to
#' provide information about the paging device and other contextual data to
#' the function.
#' @param html.output (\code{StyleHtml} objects only) one of:
#' \itemize{
#' \item \dQuote{page}: Include all HTML/CSS/JS required to create a
#' stand-alone web page with the diff; in this mode the diff string will
#' be re-encoded with \code{\link{enc2utf8}} and the HTML page encoding
#' will be declared as UTF-8.
#' \item \dQuote{diff.w.style}: The CSS and HTML, but without any of the
#' outer tags that would make it a proper HTML page (i.e. no
#' \code{<html>/<head>} tags or the like) and without the JS; note that
#' technically this is illegal HTML since we have \code{<style>} tags
#' floating outside of \code{<head>} tags, but it seems to work in most
#' browsers.
#' \item \dQuote{diff.only}: Like \dQuote{diff.w.style}, but without the CSS
#' \item \dQuote{auto}: Pick one of the above based on \code{Pager}, will
#' chose \dQuote{page} if the pager is of type \code{PagerBrowser} (as in
#' that case the output is destined to be displayed in a browser like
#' device), or \dQuote{diff.only} if it is not.
#' }
#' @param escape.html.entities (\code{StyleHtml} objects only) TRUE (default)
#' or FALSE, whether to escape HTML entities in the input
#' @param scale (\code{StyleHtml} objects only) TRUE (default) or FALSE,
#' whether to scale HTML output to fit to the viewport
#' @param css (\code{StyleHtml} objects only) path to file containing CSS styles
#' to style HTML output with
#' @param js (\code{StyleHtml} objects only) path to file containing Javascript
#' used for scaling output to viewports.
#' @return Style S4 object
#' @examples
#' \dontrun{
#' ## Create a new style based on existing style by changing
#' ## gutter symbols and guide color; see `?StyleFuns` and
#' ## `?StyleText` for a full list of adjustable elements
#' my.style <- StyleAnsi8NeutralYb()
#' my.style ## `show` method gives you a preview of the style
#' my.style@text@gutter.insert <- "+++"
#' my.style@text@gutter.delete <- "---"
#' my.style@funs@text.guide <- crayon::green
#' my.style ## Notice gutters and guide color
#'
#' ## Provide a custom style sheet; here we assume there is a style sheet at
#' ## `HOME/web/mycss.css`
#' my.css <- file.path(path.expand("~"), "web", "mycss.css")
#' diffPrint(1:5, 2:6, style=StyleHtmlLightYb(css=my.css))
#'
#' ## Turn of scaling; notice how we pass a list to `style`
#' ## and we do not need to specify a specific style
#' diffPrint(letters, letters[-5], format="html", style=list(scale=FALSE))
#'
#' ## Alternatively we can do the same by specifying a style, but we must
#' ## give an exact html style instead of relying on preferences to pick
#' ## one for us
#' my.style <- StyleHtmlLightYb(scale=FALSE)
#' diffPrint(letters, letters[-5], style=my.style)
#' }
#' ## Return only the raw HTML without any of the headers
#' as.character(
#' diffPrint(1:5, 2:6, format="html", style=list(html.output="diff.only"))
#' )
Style <- setClass("Style", contains="VIRTUAL",
slots=c(
funs="StyleFuns",
text="StyleText",
summary="StyleSummary",
nchar.fun="ANY",
wrap="logical",
pad="logical",
finalizer="function",
pager="Pager",
na.sub="character",
blank.sub="character",
disp.width="integer"
),
prototype=list(
funs=StyleFuns(),
text=StyleText(),
wrap=TRUE,
pad=TRUE,
pager=PagerOff(),
finalizer=function(x, y) y,
na.sub="",
blank.sub="",
disp.width=0L,
nchar.fun=nchar2 # even raw input can have SGR in it
),
validity=function(object){
# ## no longer true with nchar2 and support sgr parameter
# if(!isTRUE(is.one.arg.fun(object@nchar.fun))) {
# return(paste0(
# "Slot `nchar.fun` should be a function with at least one argument that ",
# "doesn't require more than one argument"
# ) )
# }
if(!is.TF(object@wrap))
return("Slot `wrap` must be TRUE or FALSE")
if(!is.TF(object@pad))
return("Slot `pad` must be TRUE or FALSE")
if(length(object@na.sub) != 1L)
return("Slot `na.sub` must be character(1L)")
if(length(object@blank.sub) != 1L)
return("Slot `na.sub` must be character(1L)")
if(!is.int.1L(object@disp.width) || object@disp.width < 0L)
return("Slot `disp.width` must be integer(1L), positive, and not NA")
fin.args <- formals(object@finalizer)
if(length(fin.args) < 2L)
return(
"Slot `finalizer` must be a function with at least two parameters."
)
if(length(fin.args) > 2L && has_non_def_formals(tail(fin.args, -2L)))
return(
paste0(
"Slot `finalizer` must be a function with no non-default parameters ",
"other than the first two."
) )
}
)
setClass("Light", contains="VIRTUAL")
setClass("Dark", contains="VIRTUAL")
setClass("Neutral", contains="VIRTUAL")
setClass("Raw", contains="VIRTUAL")
setClass("Ansi", contains="VIRTUAL")
setClass("Html", contains="VIRTUAL")
setClass("Rgb", contains="VIRTUAL")
setClass("Yb", contains="VIRTUAL")
#' @export StyleRaw
#' @exportClass StyleRaw
#' @rdname Style
StyleRaw <- setClass(
"StyleRaw", contains=c("Style", "Raw")
)
setMethod(
"initialize", "StyleRaw",
function(.Object, ...) {
.Object@pager <- if(pager_is_less())
PagerSystemLess() else PagerSystem()
callNextMethod(.Object, ...)
})
#' @export StyleAnsi
#' @exportClass StyleAnsi
#' @rdname Style
StyleAnsi <- setClass(
"StyleAnsi", contains=c("StyleRaw", "Ansi"),
prototype=list(
funs=StyleFunsAnsi(),
nchar.fun=nchar2
)
)
#' @export StyleAnsi8NeutralRgb
#' @exportClass StyleAnsi8NeutralRgb
#' @rdname Style
StyleAnsi8NeutralRgb <- setClass(
"StyleAnsi8NeutralRgb", contains=c("StyleAnsi", "Neutral", "Rgb")
)
#' @export StyleAnsi8NeutralYb
#' @exportClass StyleAnsi8NeutralYb
#' @rdname Style
StyleAnsi8NeutralYb <- setClass(
"StyleAnsi8NeutralYb", contains=c("StyleAnsi", "Neutral", "Yb"),
prototype=list(
funs=StyleFunsAnsi(
word.insert=crayon::blue, word.delete=crayon::yellow,
gutter.insert=crayon::blue,
gutter.insert.ctd=crayon::blue,
gutter.delete=crayon::yellow,
gutter.delete.ctd=crayon::yellow
) )
)
#' @export StyleAnsi256LightRgb
#' @exportClass StyleAnsi256LightRgb
#' @rdname Style
StyleAnsi256LightRgb <- setClass(
"StyleAnsi256LightRgb", contains=c("StyleAnsi", "Light", "Rgb"),
prototype=list(
funs=StyleFunsAnsi(
text.insert=crayon::make_style(
rgb(4, 5, 4, maxColorValue=5), bg=TRUE, colors=256
),
text.delete=crayon::make_style(
rgb(5, 4, 4, maxColorValue=5), bg=TRUE, colors=256
),
text.fill=crayon::make_style(
rgb(20, 20, 20, maxColorValue=23), bg=TRUE, grey=TRUE, colors=256
),
word.insert=crayon::make_style(
rgb(2, 4, 2, maxColorValue=5), bg=TRUE, colors=256
),
word.delete=crayon::make_style(
rgb(4, 2, 2, maxColorValue=5), bg=TRUE, colors=256
),
gutter.insert=crayon::make_style(
rgb(0, 3, 0, maxColorValue=5), colors=256
),
gutter.insert.ctd=crayon::make_style(
rgb(0, 3, 0, maxColorValue=5), colors=256
),
gutter.delete=crayon::make_style(
rgb(3, 0, 0, maxColorValue=5), colors=256
),
gutter.delete.ctd=crayon::make_style(
rgb(3, 0, 0, maxColorValue=5), colors=256
),
header=crayon::make_style(
rgb(0, 3, 3, maxColorValue=5), colors=256
)
) ) )
#' @export StyleAnsi256LightYb
#' @exportClass StyleAnsi256LightYb
#' @rdname Style
StyleAnsi256LightYb <- setClass(
"StyleAnsi256LightYb", contains=c("StyleAnsi", "Light", "Yb"),
prototype=list(
funs=StyleFunsAnsi(
text.insert=crayon::make_style(
rgb(3, 3, 5, maxColorValue=5), bg=TRUE, colors=256
),
text.delete=crayon::make_style(
rgb(4, 4, 2, maxColorValue=5), bg=TRUE, colors=256
),
text.fill=crayon::make_style(
rgb(20, 20, 20, maxColorValue=23), bg=TRUE, grey=TRUE, colors=256
),
word.insert=crayon::make_style(
rgb(2, 2, 4, maxColorValue=5), bg=TRUE, colors=256
),
word.delete=crayon::make_style(
rgb(3, 3, 1, maxColorValue=5), bg=TRUE, colors=256
),
gutter.insert=crayon::make_style(
rgb(0, 0, 3, maxColorValue=5), colors=256
),
gutter.insert.ctd=crayon::make_style(
rgb(0, 0, 3, maxColorValue=5), colors=256
),
gutter.delete=crayon::make_style(
rgb(2, 1, 0, maxColorValue=5), colors=256
),
gutter.delete.ctd=crayon::make_style(
rgb(2, 1, 0, maxColorValue=5), colors=256
),
header=crayon::make_style(
rgb(0, 3, 3, maxColorValue=5), colors=256
)
) ) )
#' @export StyleAnsi256DarkRgb
#' @exportClass StyleAnsi256DarkRgb
#' @rdname Style
StyleAnsi256DarkRgb <- setClass(
"StyleAnsi256DarkRgb", contains=c("StyleAnsi", "Dark", "Rgb"),
prototype=list(
funs=StyleFunsAnsi(
text.insert=crayon::make_style(
rgb(0, 1, 0, maxColorValue=5), bg=TRUE, colors=256
),
text.delete=crayon::make_style(
rgb(1, 0, 0, maxColorValue=5), bg=TRUE, colors=256
),
word.insert=crayon::make_style(
rgb(0, 3, 0, maxColorValue=5), bg=TRUE, colors=256
),
word.delete=crayon::make_style(
rgb(3, 0, 0, maxColorValue=5), bg=TRUE, colors=256
),
gutter.insert=crayon::make_style(
rgb(0, 2, 0, maxColorValue=5), colors=256
),
gutter.insert.ctd=crayon::make_style(
rgb(0, 2, 0, maxColorValue=5), colors=256
),
gutter.delete=crayon::make_style(
rgb(2, 0, 0, maxColorValue=5), colors=256
),
gutter.delete.ctd=crayon::make_style(
rgb(2, 0, 0, maxColorValue=5), colors=256
),
gutter.guide=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.guide.ctd=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
line.guide=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.fill=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.fill.ctd=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
text.fill=crayon::make_style(
rgb(2, 2, 2, maxColorValue=23), bg=TRUE, grey=TRUE, colors=256
),
gutter.context.sep=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.context.sep.ctd=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
context.sep=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
meta=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
trim=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
)
) ) )
#' @export StyleAnsi256DarkYb
#' @exportClass StyleAnsi256DarkYb
#' @rdname Style
StyleAnsi256DarkYb <- setClass(
"StyleAnsi256DarkYb", contains=c("StyleAnsi", "Dark", "Yb"),
prototype=list(
funs=StyleFunsAnsi(
text.insert=crayon::make_style(
rgb(0, 0, 2, maxColorValue=5), bg=TRUE, colors=256
),
text.delete=crayon::make_style(
rgb(1, 1, 0, maxColorValue=5), bg=TRUE, colors=256
),
word.insert=crayon::make_style(
rgb(0, 0, 5, maxColorValue=5), bg=TRUE, colors=256
),
word.delete=crayon::make_style(
rgb(3, 2, 0, maxColorValue=5), bg=TRUE, colors=256
),
gutter.insert=crayon::make_style(
rgb(0, 0, 3, maxColorValue=5), colors=256
),
gutter.insert.ctd=crayon::make_style(
rgb(0, 0, 3, maxColorValue=5), colors=256
),
gutter.delete=crayon::make_style(
rgb(1, 1, 0, maxColorValue=5), colors=256
),
gutter.delete.ctd=crayon::make_style(
rgb(1, 1, 0, maxColorValue=5), colors=256
),
header=crayon::make_style(
rgb(0, 3, 3, maxColorValue=5), colors=256
),
gutter.guide=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.guide.ctd=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
line.guide=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.fill=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.fill.ctd=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
text.fill=crayon::make_style(
rgb(2, 2, 2, maxColorValue=23), bg=TRUE, grey=TRUE, colors=256
),
gutter.context.sep=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
gutter.context.sep.ctd=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
context.sep=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
meta=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
),
trim=crayon::make_style(
rgb(13, 13, 13, maxColorValue=23), grey=TRUE, colors=256
)
) ) )
#' Return Location of Default HTML Support Files
#'
#' File location for default CSS and JS files. Note that these files are read
#' and injected into the output HTML rather than referenced to simplify serving.
#'
#' @aliases diffobj_js
#' @name webfiles
#' @rdname webfiles
#' @return path to the default CSS or JS file
#' @examples
#' diffobj_css()
#' diffobj_js()
NULL
#' @export
#' @rdname webfiles
diffobj_css <- function()
file.path(system.file(package="diffobj"), "css", "diffobj.css")
#' @export
#' @rdname webfiles
diffobj_js <- function()
file.path(system.file(package="diffobj"), "script", "diffobj.js")
#' @export StyleHtml
#' @exportClass StyleHtml
#' @rdname Style
StyleHtml <- setClass(
"StyleHtml", contains=c("Style", "Html"),
slots=c(
css="character", html.output="character", escape.html.entities="logical",
js="character", scale="logical"
),
prototype=list(
funs=StyleFuns(
container=cont_f(),
row=div_f("diffobj-row"),
banner.insert=div_f("insert"),
banner.delete=div_f("delete"),
banner=div_f("diffobj-line banner"),
line.insert=div_f("insert"),
line.delete=div_f("delete"),
line.match=div_f("diffobj-match"),
line.guide=div_f("diffobj-guide"),
line.fill=div_f("diffobj-fill"),
line=div_f("diffobj-line"),
text.insert=div_f("insert"),
text.delete=div_f("delete"),
text.match=div_f("diffobj-match"),
text.guide=div_f("diffobj-guide"),
text.fill=div_f("diffobj-fill"),
text=div_f("diffobj-text"),
gutter.insert=div_f("insert"),
gutter.delete=div_f("delete"),
gutter.match=div_f("diffobj-match"),
gutter.guide=div_f("diffobj-guide"),
gutter.fill=div_f("diffobj-fill"),
gutter.pad=div_f("pad"),
gutter.context.sep=div_f(c("context_sep", "ctd")),
gutter.insert.ctd=div_f(c("insert", "ctd")),
gutter.delete.ctd=div_f(c("delete", "ctd")),
gutter.match.ctd=div_f(c("diffobj-match", "ctd")),
gutter.guide.ctd=div_f(c("diffobj-guide", "ctd")),
gutter.fill.ctd=div_f(c("diffobj-fill", "ctd")),
gutter.context.sep.ctd=div_f(c("context_sep", "ctd")),
gutter=div_f("diffobj-gutter"),
context.sep=div_f("context_sep"),
word.insert=span_f(c("diffobj-word", "insert")),
word.delete=span_f(c("diffobj-word", "delete")),
trim=span_f("diffobj-trim"),
header=div_f(c("diffobj-header"))
),
text=StyleText(
gutter.insert=">",
gutter.delete="<",
gutter.match=" ",
line.break="<br />",
pad.col=""
),
summary=StyleSummaryHtml(),
pager=PagerBrowser(),
wrap=FALSE,
pad=FALSE,
nchar.fun=nchar_html, # only used in gutter
escape.html.entities=TRUE,
na.sub=" ",
blank.sub=" ",
disp.width=80L,
html.output="auto",
css="",
js="",
finalizer=finalizeHtml,
scale=TRUE
),
validity=function(object) {
if(!is.chr.1L(object@css))
return("slot `css` must be character(1L)")
if(!is.chr.1L(object@js))
return("slot `js` must be character(1L)")
if(!is.chr.1L(object@html.output))
return("slot `html.output` must be character(1L)")
if(!is.TF(object@escape.html.entities))
return("slot `escape.html.entities` must be TRUE or FALSE.")
if(!is.TF(object@scale))
return("slot `scale` must be TRUE or FALSE.")
if(!identical(object@wrap, FALSE))
return("slot `wrap` must be FALSE for `styleHtml` objects.")
TRUE
}
)
# construct with default values specified via options
setMethod("initialize", "StyleHtml",
function(
.Object, css=getOption("diffobj.html.css"),
js=getOption("diffobj.html.js"),
html.output=getOption("diffobj.html.output", default='auto'),
escape.html.entities=getOption("diffobj.html.escape.html.entities"),
scale=getOption("diffobj.html.scale", default=TRUE),
...
) {
# Had some problems with R 3.1 where it appears that the initialize methods
# are triggered on load, but before `.onLoad` is called, and as such options
# are not available. This is why we have this logic here.
if(is.null(css)) css <- diffobj_css()
if(is.null(js)) js <- diffobj_js()
if(!isTRUE(css.err <- is.one.file.name(css)))
stop("Argument `css` ", css.err)
if(!isTRUE(js.err <- is.one.file.name(js)))
stop("Argument `js` ", js.err)
if(!is.TF(scale))
stop("Argument `scale` must be TRUE or FALSE")
valid.html.output <- c("auto", "page", "diff.only", "diff.w.style")
if(!string_in(html.output, valid.html.output))
stop("Argument `html.output` must be in `", dep(valid.html.output), "`.")
callNextMethod(
.Object, css=css, html.output=html.output, js=js, scale=scale, ...
)
} )
#' @export StyleHtmlLightRgb
#' @exportClass StyleHtmlLightRgb
#' @rdname Style
StyleHtmlLightRgb <- setClass(
"StyleHtmlLightRgb", contains=c("StyleHtml", "Light", "Rgb")
)
setMethod("initialize", "StyleHtmlLightRgb",
function(.Object, ...) {
.Object@funs@container <- cont_f(c("light", "rgb"))
callNextMethod(.Object, ...)
}
)
#' @export StyleHtmlLightYb
#' @exportClass StyleHtmlLightYb
#' @rdname Style
StyleHtmlLightYb <- setClass(
"StyleHtmlLightYb", contains=c("StyleHtml", "Light", "Yb"),
)
setMethod("initialize", "StyleHtmlLightYb",
function(.Object, ...) {
.Object@funs@container <- cont_f(c("light", "yb"))
callNextMethod(.Object, ...)
}
)
# Helper structure for constructing our defaults array
.dfs.dims <- list(
format=c("raw", "ansi8", "ansi256", "html"),
brightness=c("neutral", "light", "dark"),
color.mode=c("rgb", "yb") # add b/w?
)
.dfs.dims.sizes <- vapply(.dfs.dims, length, integer(1L))
.dfs.arr <- array(
vector("list", prod(.dfs.dims.sizes)), dim=.dfs.dims.sizes, dimnames=.dfs.dims
)
#' Class for Tracking Default Styles by Style Type
#'
#' Provides a mechanism for specifying a style based on the style properties
#' along dimensions of format, brightness, and color. This allows a user to
#' request a style that meets a certain description (e.g. a \dQuote{light}
#' scheme in \dQuote{ansi256} format), without having to provide a specific
#' \code{\link{Style}} object.
#'
#' @section An Array of Styles:
#'
#' A \code{PaletteOfStyles} object is an \dQuote{array} containing either
#' \dQuote{classRepresentation} objects that extend \code{StyleHtml} or are
#' instances of objects that inherit from \code{StyleHtml}. The \code{diff*}
#' methods then pick an object/class from this array based on the values of
#' the \code{format}, \code{brightness}, and \code{color.mode} parameters.
#'
#' For the most part the distinction between actual \code{Style} objects vs
#' \dQuote{classRepresentation} ones is academic, except that with the latter
#' you can control the instantiation by providing a parameter list as the
#' \code{style} argument to the \code{diff*} methods. This is not an option with
#' already instantiated objects. See examples.
#'
#' @section Dimensions:
#'
#' There are three general orthogonal dimensions of styles that can be used when
#' rendering diffs: the type of format, the \dQuote{brightness} of the output,
#' and whether the colors used are distinguishable if you assume reds and greens
#' are not distinguishable. Defaults for the intersections each of these
#' dimensions are encoded as a three dimensional list. This list is just an
#' atomic vector of type \dQuote{list} with a length 3 \code{dim} attribute.
#'
#' The array/list dimensions are:
#' \itemize{
#' \item \code{format}: the format type, one of \dQuote{raw},
#' \dQuote{ansi8}, \dQuote{ansi256}, or \dQuote{html}
#' \item \code{brightness}: whether the colors are bright or not, which
#' allows user to chose a scheme that is compatible with their console,
#' one of: \dQuote{light}, \dQuote{dark}, \dQuote{normal}
#' \item \code{color.mode}: \dQuote{rgb} for full color or \dQuote{yb} for
#' dichromats (yb stands for Yellow Blue).
#' }
#'
#' Each of these dimensions can be specified directly via the corresponding
#' parameters to the \code{diff*} methods.
#'
#' @section Methods:
#'
#' \code{PaletteOfStyles} objects have The following methods implemented:
#' \itemize{
#' \item \code{[}, \code{[<-}, \code{[[}
#' \item show
#' \item summary
#' \item dimnames
#' }
#' @section Structural Details:
#'
#' The array/list is stored in the \code{data} slot of
#' \code{PaletteOfStyles} objects. Subsetting methods are provided so you
#' may operate directly on the S4 object as you would on a regular array.
#'
#' The array/list must be fully populated with objects that are or inherit
#' \code{Style}, or are \dQuote{classRepresentation} objects (i.e. those of
#' the type returned by \code{\link{getClassDef}}) that extend \code{Style}.
#' By default the array is populated only with \dQuote{classRepresentation}
#' objects as that allows the list form of the \code{style} parameter to the
#' \code{diff*} methods. If there is a particular combination of coordinates
#' that does not have a corresponding defined style a reasonable substitution
#' must be provided. For example, this package only defines \dQuote{light}
#' HTML styles, so it simply uses that style for all the possible
#' \code{brightness} values.
#'
#' There is no explicit check that the objects in the list comply with the
#' descriptions implied by their coordinates, although the default object
#' provided by the package does comply for the most part. One check that is
#' carried out is that any element that has a \dQuote{html} value in the
#' \code{format} dimension extends \code{StyleHtml}.
#'
#' While the list may only have the three dimensions described, you can add
#' values to the dimensions provided the values described above are the first
#' ones in each of their corresponding dimensions. For example, if you wanted
#' to allow for styles that would render in \code{grid} graphics, you could
#' generate a default list with a \dQuote{"grid"} value appended to the values
#' of the \code{format} dimension.
#'
#' @export PaletteOfStyles
#' @exportClass PaletteOfStyles
#' @examples
#' \dontrun{
#' ## Look at all "ansi256" styles (assumes compatible terminal)
#' PaletteOfStyles()["ansi256",,]
#' }
#' ## Generate the default style object palette, and replace
#' ## the ansi256 / light / rgb style with our modified one
#' ## which for illustrative purposes is the raw style
#' my.pal <- PaletteOfStyles()
#' my.style <- StyleRaw() # See `?Style` for custom styles
#' my.style@funs@word.delete <- function(x) sprintf("--%s--", x)
#' my.pal["ansi256", "light", "rgb"] <- list(my.style) # note `list()`
#' ## Output has no format now for format/color.mode/brightness
#' ## we modified ...
#' ## `pager="off"` for CRAN compliance; you may omit in normal use
#' diffPrint(
#' 1:3, 2:5, format="ansi256", color.mode="rgb", brightness="light",
#' palette.of.styles=my.pal, pager="off", disp.width=80
#' )
#' ## If so desired, set our new style palette as the default
#' ## one; could also pass directly as argument to `diff*` funs
#' \dontrun{
#' options(diffobj.palette=defs)
#' }
PaletteOfStyles <- setClass(
"PaletteOfStyles",
slots=c(data="array"),
validity=function(object) {
dat <- object@data
valid.names <- names(.dfs.dims)
if(!is.list(dat))
return("Slot `data` must be a dimensioned list")
if(
!is.list(dimnames(dat)) ||
!identical(names(dimnames(dat)), valid.names) ||
!all(vapply(dimnames(dat), is.character, logical(1L))) ||
anyNA(unlist(dat))
)
return(
paste0(
"`dimnames` for default styles must be a list with names `",
paste0(deparse(valid.names), collapse=""), "` and contain only ",
"character vectors with no NA values."
) )
if(
!all(
vapply(
valid.names,
function(x) identical(
.dfs.dims[[x]], head(dimnames(dat)[[x]], length(.dfs.dims[[x]]))
),
logical(1L)
) ) )
return("Style dimension names do not contain all required values")
# May be either style objects or Style Class definitions
style.def <- getClassDef("Style", package="diffobj")
are.styles <- vapply(dat, is, logical(1L), "Style")
are.styles.def <- logical(length(are.styles))
are.styles.def[!are.styles] <- vapply(
dat[!are.styles],
function(x) is(x, "classRepresentation") && extends(x, style.def),
logical(1L)
)
if(!all(are.styles | are.styles.def))
return(
paste0(
"Styles may only contain objects that inherit from `Style` or class ",
"definitions that extend `Style`"
) )
if(
!all(
vapply(
dat["html", ,],
function(x)
is(x, "classRepresentation") && extends(x, "StyleHtml") ||
is(x, "StyleHtml"),
logical(1L)
)
)
)
return("Styles classifed as HTML must extend `StyleHtml`")
TRUE
}
)
setMethod("initialize", "PaletteOfStyles",
function(.Object, ...) {
.dfs.arr["raw", , ] <- list(
getClassDef("StyleRaw", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi8", , "rgb"] <- list(
getClassDef("StyleAnsi8NeutralRgb", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi8", , "yb"] <- list(
getClassDef("StyleAnsi8NeutralYb", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi256", "neutral", "rgb"] <- list(
getClassDef("StyleAnsi8NeutralRgb", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi256", "neutral", "yb"] <- list(
getClassDef("StyleAnsi8NeutralYb", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi256", "light", "rgb"] <- list(
getClassDef("StyleAnsi256LightRgb", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi256", "light", "yb"] <- list(
getClassDef("StyleAnsi256LightYb", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi256", "dark", "rgb"] <- list(
getClassDef("StyleAnsi256DarkRgb", package="diffobj", inherits=FALSE)
)
.dfs.arr["ansi256", "dark", "yb"] <- list(
getClassDef("StyleAnsi256DarkYb", package="diffobj", inherits=FALSE)
)
.dfs.arr["html", , "rgb"] <- list(
getClassDef("StyleHtmlLightRgb", package="diffobj", inherits=FALSE)
)
.dfs.arr["html", , "yb"] <- list(
getClassDef("StyleHtmlLightYb", package="diffobj", inherits=FALSE)
)
.Object@data <- .dfs.arr
callNextMethod(.Object, ...)
}
)
#' @rdname Extract_PaletteOfStyles
setReplaceMethod(
"[", signature=c(x="PaletteOfStyles"),
function(x, i, j, ..., value) {
x@data[i, j, ...] <- value
validObject(x)
x
} )
#' @rdname Extract_PaletteOfStyles
setMethod(
"[", signature=c(x="PaletteOfStyles"),
function(x, i, j, ..., drop=FALSE) {
x@data <- x@data[i, j, ..., drop=drop]
x
}
)
#' Extract/Replace a Style Class or Object from PaletteOfStyles
#'
#' @rdname Extract_PaletteOfStyles
#' @seealso \code{\link{diffPrint}} for explanations of \code{format},
#' \code{brightness}, and \code{color.mode}
#' @param x a \code{\link{PaletteOfStyles}} object
#' @param i numeric, or character corresponding to a valid style \code{format}
#' @param j numeric, or character corresponding to a valid style
#' \code{brightness}
#' @param ... pass a numeric or character corresponding to a valid
#' \code{color.mode}
#' @param exact passed on to generic
#' @param drop TRUE or FALSE, whether to drop dimensions, defaults to FALSE,
#' which is different than generic
#' @param value a \emph{list} of \code{\link{Style}} class or
#' \code{\link{Style}} objects
#' @return a \code{\link{Style}} \code{ClassRepresentation} object or
#' \code{\link{Style}} object for \code{[[}, and a list of the same for
#' \code{[}
#' @examples
#' pal <- PaletteOfStyles()
#' pal[["ansi256", "light", "rgb"]]
#' pal["ansi256", "light", ]
#' pal["ansi256", "light", "rgb"] <- list(StyleAnsi8NeutralRgb())
setMethod(
"[[", signature=c(x="PaletteOfStyles"),
function(x, i, j, ..., exact=TRUE) {
x@data[[i, j, ..., exact=exact]]
}
)
#' Retrieve Dimnames for PaletteOfStyles Objects
#'
#' @param x a \code{\link{PaletteOfStyles}} object
#' @return list the dimension names
#' dimnames(PaletteOfStyles())
setMethod("dimnames", "PaletteOfStyles", function(x) dimnames(x@data))
# Matrices used for show methods for styles
.mx1 <- .mx2 <- matrix(1:50, ncol=2)
.mx2[c(6L, 40L)] <- 99L
.mx2 <- .mx2[-7L,]
#' Show Method for Style Objects
#'
#' Display a small sample diff with the Style object styles applied. For
#' ANSI light and dark styles, will also temporarily set the background and
#' foreground colors to ensure they are compatible with the style, even though
#' this is not done in normal output (i.e. if you intend on using a
#' \dQuote{light} style, you should set your terminal background color to be
#' light or expect sub-optimal rendering).
#'
#' @param object a \code{Style} S4 object
#' @return NULL, invisibly
#' @examples
#' show(StyleAnsi256LightYb()) # assumes ANSI colors supported
setMethod("show", "Style",
function(object) {
cat(sprintf("Object of class `%s`:\n\n", class(object)))
d.p <- diffPrint(
.mx1, .mx2, context=1, line.limit=7L,
style=object, pager=PagerOff(),
tar.banner="diffobj:::.mx1", cur.banner="diffobj:::.mx2",
sgr.supported=if(is(object, "Ansi")) TRUE
)
d.txt <- capture.output(show(d.p))
if(is(object, "Ansi")) {
old.opt <- options(crayon.enabled=TRUE)
on.exit(options(old.opt))
pad.width <- max(nchar2(d.txt, sgr.supported=TRUE))
d.txt <- rpad(d.txt, width=pad.width, sgr.supported=TRUE)
bgWhite <- crayon::make_style(rgb(1, 1, 1), bg=TRUE, colors=256)
white <- crayon::make_style(rgb(1, 1, 1), colors=256)
if(is(object, "Light")) {
d.txt <- bgWhite(crayon::black(d.txt))
} else if (is(object, "Dark")) {
d.txt <- crayon::bgBlack(white(d.txt))
}
options(old.opt)
on.exit(NULL)
if(is(object, "Light") || is(object, "Dark")) {
d.txt <- c(
d.txt, "",
strwrap(
paste0(
"Default bg and fg colors forced to appropriate colors for ",
"scheme; this does not happen in actual use."
),
width=pad.width + 20L
) ) } }
cat(d.txt, sep="\n")
invisible(NULL)
} )
#' @rdname show-Style-method
setMethod("show", "StyleHtml",
function(object) {
cat(sprintf("Class `%s` sample output:\n\n", class(object)))
cat("[Object Renders in HTML]\n")
invisible(NULL)
} )
#' Display a PaletteOfStyles
#'
#' @param object a \code{\link{PaletteOfStyles}} object
#' @return NULL, invisibly
setMethod("show", "PaletteOfStyles",
function(object) {
fmt <- dimnames(object)$format
brt <- dimnames(object)$brightness
clr <- dimnames(object)$color.mode
for(f in fmt) {
for(b in brt) {
for(c in clr) {
obj <- object[[f, b, c]]
if(is(obj, "classRepresentation")) obj <- new(obj)
txt <- capture.output(show(obj))
cat(
sprintf("\nformat: %s, brightness: %s, color.mode: %s\n\n", f, b, c)
)
cat(paste0(" ", txt), sep="\n")
} } } } )
#' Display a Summarized Version of a PaletteOfStyles
#'
#' @param object a \code{\link{PaletteOfStyles}} object
#' @param ... unused, for compatibility with generic
#' @return character representation showing classes and/or objects in
#' PaletteOfStyles
#' summary(PaletteOfStyles())
setMethod("summary", "PaletteOfStyles",
function(object, ...)
apply(
object@data,
1:3,
function(x)
if(is(x[[1L]], "classRepresentation"))
paste0("class: ", x[[1L]]@className) else
paste0("object: ", class(x[[1L]]))
)
)
# Helper function to render output for vignette
display_ansi_256_styles <- function() {
styles <- lapply(
list(
StyleAnsi8NeutralYb(), StyleAnsi8NeutralRgb(),
StyleAnsi256DarkYb(), StyleAnsi256DarkRgb(),
StyleAnsi256LightYb(), StyleAnsi256LightRgb()
),
function(x) capture.output(show(x))[3:9]
)
names <- c("Neutral", "Dark", "Light")
cat("\n")
lapply(
1:3,
function(x) {
cat(paste0(" ", names[x]), "\n\n")
cat(paste(" ", styles[[x * 2 - 1]], " ", styles[[x * 2]]), sep="\n")
cat("\n")
}
)
invisible(NULL)
}
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.