#' Cleans up a CSS attribute value.
#'
#' \code{cleanCssValue} is a utility function that performs some basic cleanup
#' on CSS attribute values. Leading and trailing whitespace is removed. The
#' CSS values "initial" and "inherit" are blocked. The function is vectorised
#' so can be used with arrays.
#'
#' @param cssValue The value to cleanup.
#' @return The cleaned value.
cleanCssValue <- function(cssValue) {
if(is.null(cssValue)) return(NULL)
value <- trimws(cssValue)
value <- ifelse(endsWith(value, ";"), substr(value, 1, nchar(value)-1), value)
value <- value[tolower(value) != "initial"]
value <- value[tolower(value) != "inherit"]
return(value)
}
#' Find the first value in an array that is larger than the specified value.
#'
#' \code{getNextPosition} is a utility function that helps when parsing strings
#' that contain delimiters.
#'
#' @param positions An ordered numeric vector.
#' @param afterPosition The value to start searching after.
#' @return The first value in the array larger than afterPosition.
getNextPosition <- function(positions, afterPosition) {
laterPositions <- positions[positions > afterPosition]
if(length(laterPositions)==0) return(NULL)
else return(laterPositions[1])
}
#' Split a CSS attribute value into a vector/array.
#'
#' \code{parseCssString} is a utility function that splits a string into a
#' vector/array. The function pays attention to text qualifiers (single and
#' double quotes) so won't split if the delimiter occurs inside a value.
#'
#' @param text The text to split.
#' @param separator The field separator, default comma.
#' @param removeEmptyString TRUE to not return empty string / whitespace values.
#' @return An R vector containing the values from text split up.
parseCssString <- function(text, separator=",", removeEmptyString=TRUE) {
cText <- trimws(text)
if(endsWith(cText, ";")) cText <- substr(cText, 1, nchar(cText)-1)
i <- 1
iEnd <- nchar(cText)
quote1 <- gregexpr("'", cText, fixed=TRUE)[[1]]
quote2 <- gregexpr("\"", cText, fixed=TRUE)[[1]]
sep <- gregexpr(separator, cText, fixed=TRUE)[[1]]
ws <- c(" ", "\t", "\r", "\n")
results <- list()
while (i <= iEnd) {
chr <- substr(cText, i, i)
# message(chr)
# skip past whitespace
if(chr %in% ws) {
i <- i + 1
next
}
else if(chr==separator) { # comma - zero length string
results[[length(results)+1]] <- ""
i <- i + 1
}
else if(chr=="\"") { # double quotes
# next double quotes
j <- getNextPosition(quote2, i)
# message(paste0("jd=", j))
if(is.null(j)||(j<=0)) {
# malformed, just take the rest of the string and break out of the loop
results[[length(results)+1]] <- trimws(substr(cText, i+1, iEnd))
break
}
else {
results[[length(results)+1]] <- trimws(substr(cText, i+1, j-1))
k <- getNextPosition(sep, j)
if(is.null(k)||(k<=0)) break
i <- k + 1
}
}
else if(chr=="'") { # single quote
# next single quote
j <- getNextPosition(quote1, i)
# message(paste0("js=", j))
if(is.null(j)||(j<=0)) {
# malformed, just take the rest of the string and break out of the loop
results[[length(results)+1]] <- trimws(substr(cText, i+1, iEnd))
break
}
else {
results[[length(results)+1]] <- trimws(substr(cText, i+1, j-1))
k <- getNextPosition(sep, j)
if(is.null(k)||(k<=0)) break
i <- k + 1
}
}
else {
# find next comma
j <- getNextPosition(sep, i)
# message(paste0("jc=", j))
if(is.null(j)||(j<=0)) {
# malformed, just take the rest of the string and break out of the loop
results[[length(results)+1]] <- trimws(substr(cText, i, iEnd))
break
}
else {
results[[length(results)+1]] <- trimws(substr(cText, i, j-1))
i <- j + 1
}
}
}
results <- unlist(results)
if(removeEmptyString) results <- results[nchar(results)>0]
return(results)
}
#' Convert a CSS size value into points.
#'
#' \code{parseCssSizeToPt} will take a CSS style and convert it to points.
#' Supported input size units are in, cm, mm, pt, pc, px, em, %. The following
#' are converted exactly: in, cm, mm, pt, pc: using 1in = 2.54cm = 25.4mm =
#' 72pt = 6pc. The following are converted approximately: px, em, %: using
#' approx 1em=16px=12pt and 100%=1em, so approx 25.4mm = 96px
#'
#' @param size A size specified in common CSS units.
#' @return The size converted to points.
parseCssSizeToPt <- function(size) {
# able to convert in, cm, mm, pt, pc, px, em, %
# convert exactly: in, cm, mm, pt, pc: using 1in = 2.54cm = 25.4mm = 72pt = 6pc
# convert approximately: px, em, %: using approx 1em=16px=12pt and 100%=1em, so approx 25.4mm = 96px
# references:
# https://www.w3.org/Style/Examples/007/units.en.html
cSize <- tolower(cleanCssValue(size))
if(!isTextValue(cSize)) return(NULL)
# convert named sizes, percentages, em and px
percent <- NULL
if(cSize=="xx-small") percent <- 50
else if(cSize=="x-small") percent <- 60
else if(cSize=="small") percent <- 80
else if(cSize=="medium") percent <- 100
else if(cSize=="large") percent <- 110
else if(cSize=="x-large") percent <- 150
else if(cSize=="xx-large") percent <- 200
else if(endsWith(cSize, "%")&&(nchar(cSize) > 1)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-1))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) percent <- testValue
}
else if(endsWith(cSize, "em")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) percent <- 100 * testValue
}
else if(endsWith(cSize, "px")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) percent <- testValue * 100 / 16
}
if(!is.null(percent)) {
pt <- round(percent * 12 / 50) / 2 # round to nearest 0.5 pt
pt <- min(max(pt, 4), 72)
return(pt)
}
# convert in, cm, mm
mm <- NULL
if(endsWith(cSize, "in")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) mm <- 25.4 * testValue
}
if(endsWith(cSize, "cm")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) mm <- 10 * testValue
}
if(endsWith(cSize, "mm")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) mm <- testValue
}
if(!is.null(mm)) {
pt <- round(mm * 144 / 25.4) / 2 # round to nearest 0.5 pt
pt <- min(max(pt, 4), 72)
return(pt)
}
# convert pt
if(endsWith(cSize, "pt")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) {
pt <- testValue
pt <- min(max(pt, 4), 72)
return(pt)
}
}
# convert pc
if(endsWith(cSize, "pc")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) {
pt <- 12 * testValue
pt <- min(max(pt, 4), 72)
return(pt)
}
}
# unknown units
return(NULL)
}
#' Convert a CSS size value into pixels
#'
#' \code{parseCssSizeToPx} will take a CSS style and convert it to pixels
#' Supported input size units are in, cm, mm, pt, pc, px, em, %. The following
#' are converted exactly: in, cm, mm, pt, pc: using 1in = 2.54cm = 25.4mm =
#' 72pt = 6pc. The following are converted approximately: px, em, %: using
#' approx 1em=16px=12pt and 100%=1em, so approx 25.4mm = 96px
#'
#' @param size A size specified in common CSS units.
#' @return The size converted to pixels.
parseCssSizeToPx <- function(size) {
# able to convert in, cm, mm, pt, pc, px, em, %
# convert exactly: in, cm, mm, pt, pc: using 1in = 2.54cm = 25.4mm = 72pt = 6pc
# convert approximately: px, em, %: using approx 1em=16px=12pt and 100%=1em, so approx 25.4mm = 96px
# references:
# https://www.w3.org/Style/Examples/007/units.en.html
cSize <- tolower(cleanCssValue(size))
if(!isTextValue(cSize)) return(NULL)
# convert named sizes, percentages, em
percent <- NULL
if(cSize=="xx-small") percent <- 50
else if(cSize=="x-small") percent <- 60
else if(cSize=="small") percent <- 80
else if(cSize=="medium") percent <- 100
else if(cSize=="large") percent <- 110
else if(cSize=="x-large") percent <- 150
else if(cSize=="xx-large") percent <- 200
else if(endsWith(cSize, "%")&&(nchar(cSize) > 1)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-1))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) percent <- testValue
}
else if(endsWith(cSize, "em")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) percent <- 100 * testValue
}
if(!is.null(percent)) {
px <- round(percent * 16 / 10) / 10 # round to nearest 0.1px
px <- min(max(px, 0), 768)
return(px)
}
# convert in, cm, mm
mm <- NULL
if(endsWith(cSize, "in")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) mm <- 25.4 * testValue
}
if(endsWith(cSize, "cm")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) mm <- 10 * testValue
}
if(endsWith(cSize, "mm")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) mm <- testValue
}
if(!is.null(mm)) {
px <- round(mm * 960 / 25.4) / 10 # round to nearest 0.1 px
px <- min(max(px, 0), 768)
return(px)
}
# convert pt
if(endsWith(cSize, "pt")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) {
px <- 4 * testValue / 3
px <- min(max(px, 0), 768)
return(px)
}
}
# convert pc
if(endsWith(cSize, "pc")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) {
px <- 4 * 12 * testValue / 3
px <- min(max(px, 0), 768)
return(px)
}
}
# convert px
if(endsWith(cSize, "px")&&(nchar(cSize) > 2)) {
testValue <- trimws(substr(cSize, 1, nchar(cSize)-2))
testValue <- suppressWarnings(as.numeric(testValue))
if(!is.na(testValue)) {
px <- testValue
px <- min(max(px, 0), 768)
return(px)
}
}
# unknown units
return(NULL)
}
#' Convert a number of pixels to points
#'
#' \code{PxToPt} converts pixels to points.
#' 1inch = 72pt = 96px according to W3C.
#' Ref: https://www.w3.org/TR/css3-values/#absolute-lengths
#'
#' @param px The number of pixels convert.
#' @return The corresponding number of points.
PxToPt <- function(px) {
if(is.null(px)) {
return(NULL)
}
pt <- round(px * 72 / 96)
return(pt)
}
#' Convert a CSS colour into a hex based colour code.
#'
#' \code{parseColor} converts a colour value specified in CSS to a hex based
#' colour code. Example supported input values/formats/named colours are:
#' #0080FF, rgb(0, 128, 255), rgba(0, 128, 255, 0.5) and red, green, etc.
#'
#' @param color The colour to convert.
#' @return The colour as a hex code, e.g. #FF00A0.
parseColor <- function(color) { # returns a colour in the form #[0-9A-F]
cColor <- cleanCssValue(color)
if(!isTextValue(cColor)) return(NULL)
# colour already in hex format?
check <- grep("#[0-9A-F]{6}", toupper(cColor))
if((length(check)>0)&&(check==TRUE)) return(toupper(cColor))
# to lower after above check
cColor <- tolower(cColor)
# RGB color?
if(startsWith(cColor, "rgb(") && endsWith(cColor, ")") && (nchar(cColor) > 5)) {
s <- substr(cColor, 5, nchar(cColor)-1)
clrs <- trimws(unlist(strsplit(s, ",")))
if(length(clrs)==3) {
clrRed <- suppressWarnings(min(max(as.numeric(clrs[1]), 0), 255))
clrGreen <- suppressWarnings(min(max(as.numeric(clrs[2]), 0), 255))
clrBlue <- suppressWarnings(min(max(as.numeric(clrs[3]), 0), 255))
if((!is.na(clrRed))&&(!is.na(clrGreen))&&(!is.na(clrBlue))) {
return(paste0("#",
as.character.hexmode(clrRed, width=2, upper.case=TRUE),
as.character.hexmode(clrGreen, width=2, upper.case=TRUE),
as.character.hexmode(clrBlue, width=2, upper.case=TRUE)))
}
}
}
# RGBA color?
if(startsWith(cColor, "rgba(") && endsWith(cColor, ")") && (nchar(cColor) > 6)) {
s <- substr(cColor, 6, nchar(cColor)-1)
clrs <- trimws(unlist(strsplit(s, ",")))
if(length(clrs)>=3) {
clrRed <- suppressWarnings(min(max(as.numeric(clrs[1]), 0), 255))
clrGreen <- suppressWarnings(min(max(as.numeric(clrs[2]), 0), 255))
clrBlue <- suppressWarnings(min(max(as.numeric(clrs[3]), 0), 255))
if((!is.na(clrRed))&&(!is.na(clrGreen))&&(!is.na(clrBlue))) {
return(paste0("#",
as.character.hexmode(clrRed, width=2, upper.case=TRUE),
as.character.hexmode(clrGreen, width=2, upper.case=TRUE),
as.character.hexmode(clrBlue, width=2, upper.case=TRUE)))
}
}
}
# named colours
if(cColor=="aliceblue") return("#F0F8FF")
else if(cColor=="antiquewhite") return("#FAEBD7")
else if(cColor=="aqua") return("#00FFFF")
else if(cColor=="aquamarine") return("#7FFFD4")
else if(cColor=="azure") return("#F0FFFF")
else if(cColor=="beige") return("#F5F5DC")
else if(cColor=="bisque") return("#FFE4C4")
else if(cColor=="black") return("#000000")
else if(cColor=="blanchedalmond") return("#FFEBCD")
else if(cColor=="blue") return("#0000FF")
else if(cColor=="blueviolet") return("#8A2BE2")
else if(cColor=="brown") return("#A52A2A")
else if(cColor=="burlywood") return("#DEB887")
else if(cColor=="cadetblue") return("#5F9EA0")
else if(cColor=="chartreuse") return("#7FFF00")
else if(cColor=="chocolate") return("#D2691E")
else if(cColor=="coral") return("#FF7F50")
else if(cColor=="cornflowerblue") return("#6495ED")
else if(cColor=="cornsilk") return("#FFF8DC")
else if(cColor=="crimson") return("#DC143C")
else if(cColor=="cyan") return("#00FFFF")
else if(cColor=="darkblue") return("#00008B")
else if(cColor=="darkcyan") return("#008B8B")
else if(cColor=="darkgoldenrod") return("#B8860B")
else if(cColor=="darkgray") return("#A9A9A9")
else if(cColor=="darkgrey") return("#A9A9A9")
else if(cColor=="darkgreen") return("#006400")
else if(cColor=="darkkhaki") return("#BDB76B")
else if(cColor=="darkmagenta") return("#8B008B")
else if(cColor=="darkolivegreen") return("#556B2F")
else if(cColor=="darkorange") return("#FF8C00")
else if(cColor=="darkorchid") return("#9932CC")
else if(cColor=="darkred") return("#8B0000")
else if(cColor=="darksalmon") return("#E9967A")
else if(cColor=="darkseagreen") return("#8FBC8F")
else if(cColor=="darkslateblue") return("#483D8B")
else if(cColor=="darkslategray") return("#2F4F4F")
else if(cColor=="darkslategrey") return("#2F4F4F")
else if(cColor=="darkturquoise") return("#00CED1")
else if(cColor=="darkviolet") return("#9400D3")
else if(cColor=="deeppink") return("#FF1493")
else if(cColor=="deepskyblue") return("#00BFFF")
else if(cColor=="dimgray") return("#696969")
else if(cColor=="dimgrey") return("#696969")
else if(cColor=="dodgerblue") return("#1E90FF")
else if(cColor=="firebrick") return("#B22222")
else if(cColor=="floralwhite") return("#FFFAF0")
else if(cColor=="forestgreen") return("#228B22")
else if(cColor=="fuchsia") return("#FF00FF")
else if(cColor=="gainsboro") return("#DCDCDC")
else if(cColor=="ghostwhite") return("#F8F8FF")
else if(cColor=="gold") return("#FFD700")
else if(cColor=="goldenrod") return("#DAA520")
else if(cColor=="gray") return("#808080")
else if(cColor=="grey") return("#808080")
else if(cColor=="green") return("#008000")
else if(cColor=="greenyellow") return("#ADFF2F")
else if(cColor=="honeydew") return("#F0FFF0")
else if(cColor=="hotpink") return("#FF69B4")
else if(cColor=="indianred") return("#CD5C5C")
else if(cColor=="indigo") return("#4B0082")
else if(cColor=="ivory") return("#FFFFF0")
else if(cColor=="khaki") return("#F0E68C")
else if(cColor=="lavender") return("#E6E6FA")
else if(cColor=="lavenderblush") return("#FFF0F5")
else if(cColor=="lawngreen") return("#7CFC00")
else if(cColor=="lemonchiffon") return("#FFFACD")
else if(cColor=="lightblue") return("#ADD8E6")
else if(cColor=="lightcoral") return("#F08080")
else if(cColor=="lightcyan") return("#E0FFFF")
else if(cColor=="lightgoldenrodyellow") return("#FAFAD2")
else if(cColor=="lightgray") return("#D3D3D3")
else if(cColor=="lightgrey") return("#D3D3D3")
else if(cColor=="lightgreen") return("#90EE90")
else if(cColor=="lightpink") return("#FFB6C1")
else if(cColor=="lightsalmon") return("#FFA07A")
else if(cColor=="lightseagreen") return("#20B2AA")
else if(cColor=="lightskyblue") return("#87CEFA")
else if(cColor=="lightslategray") return("#778899")
else if(cColor=="lightslategrey") return("#778899")
else if(cColor=="lightsteelblue") return("#B0C4DE")
else if(cColor=="lightyellow") return("#FFFFE0")
else if(cColor=="lime") return("#00FF00")
else if(cColor=="limegreen") return("#32CD32")
else if(cColor=="linen") return("#FAF0E6")
else if(cColor=="magenta") return("#FF00FF")
else if(cColor=="maroon") return("#800000")
else if(cColor=="mediumaquamarine") return("#66CDAA")
else if(cColor=="mediumblue") return("#0000CD")
else if(cColor=="mediumorchid") return("#BA55D3")
else if(cColor=="mediumpurple") return("#9370DB")
else if(cColor=="mediumseagreen") return("#3CB371")
else if(cColor=="mediumslateblue") return("#7B68EE")
else if(cColor=="mediumspringgreen") return("#00FA9A")
else if(cColor=="mediumturquoise") return("#48D1CC")
else if(cColor=="mediumvioletred") return("#C71585")
else if(cColor=="midnightblue") return("#191970")
else if(cColor=="mintcream") return("#F5FFFA")
else if(cColor=="mistyrose") return("#FFE4E1")
else if(cColor=="moccasin") return("#FFE4B5")
else if(cColor=="navajowhite") return("#FFDEAD")
else if(cColor=="navy") return("#000080")
else if(cColor=="oldlace") return("#FDF5E6")
else if(cColor=="olive") return("#808000")
else if(cColor=="olivedrab") return("#6B8E23")
else if(cColor=="orange") return("#FFA500")
else if(cColor=="orangered") return("#FF4500")
else if(cColor=="orchid") return("#DA70D6")
else if(cColor=="palegoldenrod") return("#EEE8AA")
else if(cColor=="palegreen") return("#98FB98")
else if(cColor=="paleturquoise") return("#AFEEEE")
else if(cColor=="palevioletred") return("#DB7093")
else if(cColor=="papayawhip") return("#FFEFD5")
else if(cColor=="peachpuff") return("#FFDAB9")
else if(cColor=="peru") return("#CD853F")
else if(cColor=="pink") return("#FFC0CB")
else if(cColor=="plum") return("#DDA0DD")
else if(cColor=="powderblue") return("#B0E0E6")
else if(cColor=="purple") return("#800080")
else if(cColor=="rebeccapurple") return("#663399")
else if(cColor=="red") return("#FF0000")
else if(cColor=="rosybrown") return("#BC8F8F")
else if(cColor=="royalblue") return("#4169E1")
else if(cColor=="saddlebrown") return("#8B4513")
else if(cColor=="salmon") return("#FA8072")
else if(cColor=="sandybrown") return("#F4A460")
else if(cColor=="seagreen") return("#2E8B57")
else if(cColor=="seashell") return("#FFF5EE")
else if(cColor=="sienna") return("#A0522D")
else if(cColor=="silver") return("#C0C0C0")
else if(cColor=="skyblue") return("#87CEEB")
else if(cColor=="slateblue") return("#6A5ACD")
else if(cColor=="slategray") return("#708090")
else if(cColor=="slategrey") return("#708090")
else if(cColor=="snow") return("#FFFAFA")
else if(cColor=="springgreen") return("#00FF7F")
else if(cColor=="steelblue") return("#4682B4")
else if(cColor=="tan") return("#D2B48C")
else if(cColor=="teal") return("#008080")
else if(cColor=="thistle") return("#D8BFD8")
else if(cColor=="tomato") return("#FF6347")
else if(cColor=="turquoise") return("#40E0D0")
else if(cColor=="violet") return("#EE82EE")
else if(cColor=="wheat") return("#F5DEB3")
else if(cColor=="white") return("#FFFFFF")
else if(cColor=="whitesmoke") return("#F5F5F5")
else if(cColor=="yellow") return("#FFFF00")
else if(cColor=="yellowgreen") return("#9ACD32")
else return(NULL)
}
#' Parse a CSS border value.
#'
#' \code{parseCssBorder} parses the CSS combined border declarations (i.e.
#' border, border-left, border-right, border-top, border-bottom) and returns a
#' list containing the width, style and color as separate elements.
#'
#' @param text The border declaration to parse.
#' @return A list containing three elements: width, style and color.
parseCssBorder <- function(text) {
# parses a combined border declaration,
# e.g. 1: border: thin solid #FF00BB
# e.g. 2: border-left: thin solid red
# e.g. 3: border-left: 2px solid rgb(0, 255, 0)
# does not currently support specifying different values for different sides,
# e.g. (not supported): border: thin thick solid thin red blue
cText <- trimws(text)
if(!isTextValue(cText)) return(NULL)
if(endsWith(cText, ";")) cText <- substr(cText, 1, nchar(cText)-1)
i <- 1
iEnd <- nchar(cText)
space <- gregexpr("[ \t\r\n]", cText)[[1]]
closeBracket <- gregexpr(")", cText, fixed=TRUE)[[1]]
ws <- c(" ", "\t", "\r", "\n")
parts <- list()
while (i <= iEnd) {
chr <- substr(cText, i, i)
# message(chr)
# skip past whitespace
if(chr %in% ws) {
i <- i + 1
next
}
else {
# find next space
j <- getNextPosition(space, i)
# message(paste0("sp=", j))
if(is.null(j)||(j<=0)) {
# malformed, just take the rest of the string and break out of the loop
parts[[length(parts)+1]] <- trimws(substr(cText, i, iEnd))
break
}
else {
word <- trimws(substr(cText, i, j-1))
if(startsWith(tolower(word), "rgb(")) {
k <- getNextPosition(closeBracket, i)
word <- trimws(substr(cText, i, k))
parts[[length(parts)+1]] <- word
i <- k + 1
}
else if(startsWith(tolower(word), "rgba(")) {
k <- getNextPosition(closeBracket, i)
word <- trimws(substr(cText, i, k))
parts[[length(parts)+1]] <- word
i <- k + 1
}
else {
parts[[length(parts)+1]] <- word
i <- j + 1
}
}
}
}
parts <- unlist(parts)
parts <- parts[nchar(parts)>0]
# get width, style and color
borderWidth <- NULL
borderStyle <- NULL
borderColor <- NULL
allowedWidths <- c("thin", "medium", "thick")
allowedStyles <- c("none", "hidden", "dotted", "dashed", "solid", "double", "groove", "ridge", "inset", "outset")
for(i in 1:length(parts)) {
# examine each part
part <- tolower(cleanCssValue(parts[i]))
if(!isTextValue(part)) next
# width?
if(is.null(borderWidth)) {
if(part %in% allowedWidths) borderWidth <- part
else {
numericalWidth <- parseCssSizeToPx(part)
if(!is.null(numericalWidth)) borderWidth <- numericalWidth
}
}
# style
if(is.null(borderStyle)) {
if(part %in% allowedStyles) borderStyle <- part
}
# color
if(is.null(borderColor)) {
color <- parseColor(part)
if(!is.null(color)) borderColor <- color
}
}
if(!isTextValue(borderStyle)) return(NULL)
if(is.null(borderWidth)&&is.null(borderStyle)&&is.null(borderColor)) return(NULL)
result <- list(width=borderWidth, style=borderStyle, color=borderColor)
return(result)
}
#' Convert CSS border values to those used by the openxlsx package.
#'
#' \code{getXlBorderStyleFromCssBorder} takes border parameters expressed as a
#' list (containing elements: width and style) and returns a border style that
#' is compatible with the openxlsx package.
#'
#' @param border A list containing elements width and style.
#' @return An openxlsx border style.
getXlBorderStyleFromCssBorder <- function(border) {
# border is a return value from the parseCssBorder() function
if(!isTextValue(border)) return(NULL)
cssBorderStyle <- border[["style"]]
cssBorderWidth <- border[["width"]]
if(!isTextValue(cssBorderStyle)) return(NULL)
if(!isTextValue(cssBorderWidth)) cssBorderWidth <- "thin"
if(cssBorderStyle %in% c("none", "hidden", "initial", "inherit")) return(NULL)
if(cssBorderStyle %in% c("groove", "ridge", "inset", "outset")) cssBorderStyle <- "solid"
if(cssBorderStyle=="solid") {
if(cssBorderWidth=="thin") return("thin")
else if(cssBorderWidth=="medium") return("medium")
else if(cssBorderWidth=="thick") return("thick")
else {
numericalWidth <- suppressWarnings(as.numeric(cssBorderWidth))
if(is.na(numericalWidth)) return("thin")
else if(numericalWidth < 1) return("hair")
else if(numericalWidth < 1.5) return("thin")
else if(numericalWidth < 2.5) return("medium")
else return("thick")
}
}
else if(cssBorderStyle=="dotted") {
if(cssBorderWidth=="thin") return("dotted")
else if(cssBorderWidth=="medium") return("mediumDashDot")
else if(cssBorderWidth=="thick") return("mediumDashDot")
else {
numericalWidth <- suppressWarnings(as.numeric(cssBorderWidth))
if(is.na(numericalWidth)) return("dotted")
else if(numericalWidth < 1) return("dotted")
else if(numericalWidth < 1.5) return("mediumDashDot")
else if(numericalWidth < 2.5) return("mediumDashDot")
else return("mediumDashDot")
}
}
else if(cssBorderStyle=="dashed") {
if(cssBorderWidth=="thin") return("dashed")
else if(cssBorderWidth=="medium") return("mediumDashed")
else if(cssBorderWidth=="thick") return("mediumDashed")
else {
numericalWidth <- suppressWarnings(as.numeric(cssBorderWidth))
if(is.na(numericalWidth)) return("dashed")
else if(numericalWidth < 1) return("dashed")
else if(numericalWidth < 1.5) return("mediumDashed")
else if(numericalWidth < 2.5) return("mediumDashed")
else return("mediumDashed")
}
}
else if(cssBorderStyle=="double") {
if(cssBorderWidth=="thin") return("thin")
else if(cssBorderWidth=="medium") return("double")
else if(cssBorderWidth=="thick") return("double")
else {
numericalWidth <- suppressWarnings(as.numeric(cssBorderWidth))
if(is.na(numericalWidth)) return("thin")
else if(numericalWidth < 1) return("thin")
else if(numericalWidth < 1.5) return("double")
else if(numericalWidth < 2.5) return("double")
else return("double")
}
}
return(NULL)
}
#' Convert CSS border style values to those used by the openxlsx package.
#'
#' \code{getXlBorderFromCssBorder} parses the CSS combined border declarations
#' (i.e. border, border-left, border-right, border-top, border-bottom) and
#' returns a list containing an openxlsx border style and color as separate
#' elements.
#'
#' @param text The border declaration to parse.
#' @return A list containing two elements: style and color.
getXlBorderFromCssBorder <- function(text) {
cssBorder <- parseCssBorder(text)
if(is.null(cssBorder)) return(NULL)
xlBorderStyle <- getXlBorderStyleFromCssBorder(cssBorder)
if(is.null(xlBorderStyle)&&is.null(cssBorder[["color"]])) return(NULL)
return(list(style=xlBorderStyle, color=cssBorder[["color"]]))
}
#' Parse an xl-border value.
#'
#' \code{parseXlBorder} parses the combined xl border declarations (i.e.
#' xl-border, xl-border-left, xl-border-right, xl-border-top, xl-border-bottom)
#' and returns a list containing style and color as separate elements.
#'
#' @param text The border declaration to parse.
#' @return A list containing two elements: style and color.
parseXlBorder <- function(text) {
# parses a combined border declaration,
# e.g. 1: xl-border: thin #FF00BB
# e.g. 2: xl-border-left: thin red
# e.g. 3: xl-border-left: dashed rgb(0, 255, 0)
# does not currently support specifying different values for different sides,
# e.g. (not supported): xl-border: thin thick red blue
cText <- trimws(text)
if(!isTextValue(cText)) return(NULL)
if(endsWith(cText, ";")) cText <- substr(cText, 1, nchar(cText)-1)
i <- 1
iEnd <- nchar(cText)
space <- gregexpr("[ \t\r\n]", cText)[[1]]
closeBracket <- gregexpr(")", cText, fixed=TRUE)[[1]]
ws <- c(" ", "\t", "\r", "\n")
parts <- list()
while (i <= iEnd) {
chr <- substr(cText, i, i)
# message(chr)
# skip past whitespace
if(chr %in% ws) {
i <- i + 1
next
}
else {
# find next space
j <- getNextPosition(space, i)
# message(paste0("sp=", j))
if(is.null(j)||(j<=0)) {
# malformed, just take the rest of the string and break out of the loop
parts[[length(parts)+1]] <- trimws(substr(cText, i, iEnd))
break
}
else {
word <- trimws(substr(cText, i, j-1))
if(startsWith(tolower(word), "rgb(")) {
k <- getNextPosition(closeBracket, i)
word <- trimws(substr(cText, i, k))
parts[[length(parts)+1]] <- word
i <- k + 1
}
else if(startsWith(tolower(word), "rgba(")) {
k <- getNextPosition(closeBracket, i)
word <- trimws(substr(cText, i, k))
parts[[length(parts)+1]] <- word
i <- k + 1
}
else {
parts[[length(parts)+1]] <- word
i <- j + 1
}
}
}
}
parts <- unlist(parts)
parts <- parts[nchar(parts)>0]
# get width, style and color
borderStyle <- NULL
borderColor <- NULL
allowedStyles <- c("none", "thin", "medium", "dashed", "dotted", "thick", "double", "hair", "mediumDashed", "dashDot", "mediumDashDot", "dashDotDot", "mediumDashDotDot", "slantDashDot")
for(i in 1:length(parts)) {
# examine each part
part <- tolower(cleanCssValue(parts[i]))
# style
if(is.null(borderStyle)) {
if(part %in% allowedStyles) borderStyle <- part
}
# color
if(is.null(borderColor)) {
color <- parseColor(part)
if(!is.null(color)) borderColor <- color
}
}
if(is.null(borderStyle)&&is.null(borderColor)) return(NULL)
result <- list(style=borderStyle, color=borderColor)
return(result)
}
#' Convert CSS border style values to those used by the flextable package.
#'
#' \code{getFtBorderStyleFromCssBorder} takes border parameters expressed as a
#' list (must contain an element named style) and returns a border style that
#' is compatible with the flextable package.
#'
#' @param border A list containing an element named style.
#' @return A flextable border style.
getFtBorderStyleFromCssBorder <- function(border) {
# border is a return value from the parseCssBorder() function
if(!isTextValue(border)) return(NULL)
cssBorderStyle <- border[["style"]]
if(!isTextValue(cssBorderStyle)) return(NULL)
if(cssBorderStyle %in% c("none", "hidden", "initial", "inherit")) return(NULL)
if(cssBorderStyle %in% c("groove", "ridge", "inset", "outset")) cssBorderStyle <- "solid"
if(cssBorderStyle=="solid") return("solid")
else if(cssBorderStyle=="dotted") return("dotted")
else if(cssBorderStyle=="dashed") return("dashed")
else if(cssBorderStyle=="double") return("solid")
return(NULL)
}
#' Convert CSS border width to those used by the flextable package.
#'
#' \code{getFtBorderStyleFromCssBorder} takes border parameters expressed as a
#' list (must contain an element named style) and returns a border style that
#' is compatible with the flextable package.
#'
#' @param border A list containing an element named style.
#' @return A flextable border style.
getFtBorderWidthFromCssBorder <- function(border) {
# border is a return value from the parseCssBorder() function
if(!isTextValue(border)) return(NULL)
cssBorderWidth <- border[["width"]]
if(cssBorderWidth %in% c("none", "hidden", "initial", "inherit")) return(NULL)
if(cssBorderWidth=="thin") return(2)
else if(cssBorderWidth=="medium") return(4)
else if(cssBorderWidth=="thick") return(6)
else if(isNumericValue(cssBorderWidth)) return(cssBorderWidth)
}
#' Convert CSS border values to those used by the flextable package.
#'
#' \code{getXlBorderFromCssBorder} parses the CSS combined border declarations
#' (i.e. border, border-left, border-right, border-top, border-bottom) and
#' returns a list containing an openxlsx border style and color as separate
#' elements.
#'
#' @param text The border declaration to parse.
#' @return A list containing two elements: width, style and color.
getFtBorderFromCssBorder <- function(text) {
cssBorder <- parseCssBorder(text)
if(is.null(cssBorder)) return(NULL)
ftBorderStyle <- getFtBorderStyleFromCssBorder(cssBorder)
ftBorderWidth <- getFtBorderWidthFromCssBorder(cssBorder)
if(is.null(ftBorderStyle)&&is.null(cssBorder[["color"]])&&is.null(ftBorderWidth)) return(NULL)
return(list(style=ftBorderStyle, color=cssBorder[["color"]], width=ftBorderWidth))
}
#' Parse an ft-border value.
#'
#' \code{parseFtBorder} parses the combined ft border declarations (i.e.
#' ft-border, ft-border-left, ft-border-right, ft-border-top, ft-border-bottom)
#' and returns a list containing width, style and color as separate elements.
#'
#' @param text The border declaration to parse.
#' @return A list containing two elements: width, style and color.
parseFtBorder <- function(text) {
# parses a combined border declaration,
# e.g. 1: ft-border: thin solid #FF00BB
# e.g. 2: ft-border-left: thin dotted red
# e.g. 3: ft-border-left: medium dashed rgb(0, 255, 0)
# does not currently support specifying different values for different sides,
# e.g. (not supported): ft-border: thin thick red blue
cText <- trimws(text)
if(!isTextValue(cText)) return(NULL)
if(endsWith(cText, ";")) cText <- substr(cText, 1, nchar(cText)-1)
i <- 1
iEnd <- nchar(cText)
space <- gregexpr("[ \t\r\n]", cText)[[1]]
closeBracket <- gregexpr(")", cText, fixed=TRUE)[[1]]
ws <- c(" ", "\t", "\r", "\n")
parts <- list()
while (i <= iEnd) {
chr <- substr(cText, i, i)
# message(chr)
# skip past whitespace
if(chr %in% ws) {
i <- i + 1
next
}
else {
# find next space
j <- getNextPosition(space, i)
# message(paste0("sp=", j))
if(is.null(j)||(j<=0)) {
# malformed, just take the rest of the string and break out of the loop
parts[[length(parts)+1]] <- trimws(substr(cText, i, iEnd))
break
}
else {
word <- trimws(substr(cText, i, j-1))
if(startsWith(tolower(word), "rgb(")) {
k <- getNextPosition(closeBracket, i)
word <- trimws(substr(cText, i, k))
parts[[length(parts)+1]] <- word
i <- k + 1
}
else if(startsWith(tolower(word), "rgba(")) {
k <- getNextPosition(closeBracket, i)
word <- trimws(substr(cText, i, k))
parts[[length(parts)+1]] <- word
i <- k + 1
}
else {
parts[[length(parts)+1]] <- word
i <- j + 1
}
}
}
}
parts <- unlist(parts)
parts <- parts[nchar(parts)>0]
# get width, style and color
borderWidth <- NULL
borderStyle <- NULL
borderColor <- NULL
allowedStyles <- c("none", "solid", "dotted", "dashed")
for(i in 1:length(parts)) {
# examine each part
part <- tolower(cleanCssValue(parts[i]))
# width?
if(is.null(borderWidth)) {
numericalWidth <- suppressWarnings(as.numeric(part))
if(!is.null(numericalWidth)) borderWidth <- numericalWidth
}
# style
if(is.null(borderStyle)) {
if(part %in% allowedStyles) borderStyle <- part
}
# color
if(is.null(borderColor)) {
color <- parseColor(part)
if(!is.null(color)) borderColor <- color
}
}
if(is.null(borderWidth)&&is.null(borderStyle)&&is.null(borderColor)) return(NULL)
result <- list(width=borderWidth, style=borderStyle, color=borderColor)
return(result)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.