1# Copyright (C) 2021 Brodie Gaslam
2#
3# This file is part of "diffobj - Diffs for R Objects"
4#
5# This program is free software: you can redistribute it and/or modify
6# it under the terms of the GNU General Public License as published by
7# the Free Software Foundation, either version 2 of the License, or
8# (at your option) any later version.
9#
10# This program is distributed in the hope that it will be useful,
11# but WITHOUT ANY WARRANTY; without even the implied warranty of
12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13# GNU General Public License for more details.
14#
15# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
16
17#' @include misc.R
18
19NULL
20
21#' Make Functions That Wrap Text in HTML Tags
22#'
23#' Helper functions to generate functions to use as slots for the
24#' \code{StyleHtml@funs} classes.  These are functions that return
25#' \emph{functions}.
26#'
27#' \code{tag_f} and related functions (\code{div_f}, \code{span_f}) produce
28#' functions that are  vectorized and will apply opening and closing tags to
29#' each element of a character vector.  \code{container_f} on the other hand
30#' produces a function will collapse a character vector into length 1, and only
31#' then applies the tags.  Additionally, \code{container_f} already comes with
32#' the \dQuote{diffobj-container} class specified.
33#'
34#' @note inputs are assumed to be valid class names or CSS styles.
35#'
36#' @export
37#' @param tag character(1L) a name of an HTML tag
38#' @param class character the CSS class(es)
39#' @param style named character inline styles, where the name is the CSS
40#'   property and the value the value.
41#' @return a function that accepts a character parameter.  If applied, each
42#'   element in the character vector will be wrapped in the div tags
43#' @aliases div_f, span_f, cont_f
44#' @examples
45#' ## Assuming class 'ex1' has CSS styles defined elsewhere
46#' tag_f("div", "ex1")(LETTERS[1:5])
47#' ## Use convenience function, and add some inline styles
48#' div_f("ex2", c(color="green", `font-family`="arial"))(LETTERS[1:5])
49#' ## Notice how this is a div with pre-specifed class,
50#' ## and only one div is created around the entire data
51#' cont_f()(LETTERS[1:5])
52
53tag_f <- function(tag, class=character(), style=character()) {
54  stopifnot(is.chr.1L(tag), is.character(class), is.character(style))
55  function(x) {
56    if(!is.character(x)) stop("Argument `x` must be character.")
57    if(!length(x)) character(0L) else
58      paste0(
59        "<", tag,
60        if(length(class)) paste0(" class='", paste0(class, collapse=" "), "'"),
61        if(length(style))
62          paste0(
63            " style='",
64            paste(names(style), style, sep=": ", collapse="; "), ";'"
65          ),
66        ">", x, "</", tag, ">"
67      )
68} }
69#' @export
70#' @rdname tag_f
71
72div_f <- function(class=character(), style=character())
73  tag_f("div", class, style)
74
75#' @export
76#' @rdname tag_f
77
78span_f <- function(class=character(), style=character())
79  tag_f("span", class, style)
80
81#' @export
82#' @rdname tag_f
83
84cont_f <- function(class=character()) {
85  stopifnot(is.character(class))
86  function(x) {
87    if(!is.character(x)) stop("Argument `x` must be character.")
88    sprintf(
89      paste0(
90        "<div class='diffobj-container%s'><pre class='diffobj-content'>",
91        "%s</pre></div>"
92      ),
93      if(length(class)) paste0(" ", class, collapse="") else "",
94      paste0(x, collapse="")
95    )
96} }
97#' Count Text Characters in HTML
98#'
99#' Very simple implementation that will fail if there are any \dQuote{>} in the
100#' HTML that are not closing tags, and assumes that HTML entities are all one
101#' character wide.  Also, spaces are counted as one width each because the
102#' HTML output is intended to be displayed inside \code{<PRE>} tags.
103#'
104#' @export
105#' @param x character
106#' @param ... unused for compatibility with internal use
107#' @return integer(length(x)) with number of characters of each element
108#' @examples
109#' nchar_html("<a href='http:www.domain.com'>hello</a>")
110
111nchar_html <- function(x, ...) {
112  stopifnot(is.character(x) && !anyNA(x))
113  tag.less <- gsub("<[^>]*>", "", x)
114  # Thanks ridgerunner for html entity removal regex
115  # http://stackoverflow.com/users/433790/ridgerunner
116  # http://stackoverflow.com/a/8806462/2725969
117  ent.less <-
118    gsub("&(?:[a-z\\d]+|#\\d+|#x[a-f\\d]+);", "X", tag.less, perl=TRUE)
119  nchar(ent.less)
120}
121