R/formatting.R
In msberends/certedata: Tools for Data Analysis at Certe
Defines functions
colourpicker
Documented in
colourpicker
# ==================================================================== #
# TITLE #
# Tools for Data Analysis at Certe #
# #
# AUTHORS #
# Berends MS (m.berends@certe.nl) #
# Meijer BC (b.meijer@certe.nl) #
# Hassing EEA (e.hassing@certe.nl) #
# #
# COPYRIGHT #
# (c) 2019 Certe Medische diagnostiek & advies - https://www.certe.nl #
# #
# LICENCE #
# This R package is free software; you can redistribute it and/or #
# modify it under the terms of the GNU General Public License #
# version 2.0, as published by the Free Software Foundation. #
# This R package 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. #
# ==================================================================== #
#' Kleuren uit de huisstijl van Certe en meer
#'
#' Hiermee kunnen alle Certe-kleuren gebruikt worden, maar daarnaast ook de huisstijl van de RuG, het kleurenblindheid-veilige \code{viridis} en nog 6 andere continue kleurenpaletten. Druk op F1 voor een voorbeeldplaatje van alle beschikbare kleuren.
#' @rdname colourpicker
#' @param x Kleur. Moet een geldige kleur zijn uit \code{\link{colors}} (zoals \code{"black"}, \code{"red"}), een HTML-code (zoals \code{"#ffffaa"}, \code{"#ffa"}), een lege waarde (\code{NA} of \code{NULL}), of: \cr \cr
#' \code{"certe"} \cr Huisstijlkleuren van \href{http://www.certe.nl}{Certe}. Deze kleuren kunnen ook als input gebruikt worden: \code{"certeblauw"}, \code{"certegroen"}, \code{"certeroze"}, \code{"certegeel"}, \code{"certelila"}, \code{"certezachtlila"}, \code{"certeblauw2"}, \code{"certegroen2"}, \code{"certeroze2"}, \code{"certegeel2"}, \code{"certelila2"}, \code{"certezachtlila2"}, \code{"certeblauw3"}, \code{"certegroen3"}, \code{"certeroze3"}, \code{"certegeel3"}, \code{"certelila3"} en \code{"certezachtlila3"}. De rest wordt aangevuld met grijswaarden. Gebruik \code{"certe2"} of \code{"certe3"} om direct de zachtere tinten te gebruiken. \cr \cr
#' \code{"certe_rsi"} \cr De kleuren \code{"certeroze"}, \code{"certegeel"} en \code{"certegroen"}. \cr \cr
#' \code{"certe_rsi2"} \cr De kleuren \code{"certeroze2"}, \code{"certegeel2"} en \code{"certegroen2"}. \cr \cr
#' \code{"izore"} \cr Huisstijlkleuren van \href{http://www.izore.nl}{Izore}. Deze kleuren kunnen ook als input gebruikt worden: \code{"izorerood"}, \code{"izoregrijs"}. \cr \cr
#' \code{"rsi"} \cr De kleuren van het palet \code{"RdYlGn"}; pastelkleuren van rood, geel en groen. \cr \cr
#' \code{"rug"} of \code{"ug"} \cr Huisstijlkleuren van de \href{http://www.rug.nl}{Rijkuniversiteit Groningen}. Deze kleuren kunnen ook als input gebruikt worden: \code{"rugrood"}, \code{"rugblauw"}, \code{"rugpaars"}, \code{"rugdonkerblauw"}, \code{"ruggroen"}, \code{"rugbordeauxrood"}, \code{"ruggrijs"}, \code{"ruggoud"} en \code{"rugzilver"}. De rest wordt aangevuld met grijswaarden. \cr \cr
#' \code{"viridis"} \cr Kleurenblindheid-veilig, zie verderop en \code{\link[viridisLite]{viridis}}. \cr \cr
#' \code{"R"}, \code{"rainbow"} of \code{"regenboog"} \cr Standaardkleuren van R, zie \code{\link{rainbow}} \cr \cr
#' \code{"heat"}, \code{"heatmap"} of \code{"hitte"} \cr Zie \code{\link{heat.colors}} \cr \cr
#' \code{"terrain"} of \code{"terrein"} \cr Zie \code{\link{terrain.colors}} \cr \cr
#' \code{"topo"} of \code{"geo"} \cr Zie \code{\link{topo.colors}} \cr \cr
#' \code{"prev"} of \code{"prevalentie"} \cr \cr
#' \code{"grijs"}, \code{"grijswaarden"}, \code{"greyscale"} of \code{"grayscale"} \cr \cr
#' \code{"colourbrewer"} of \code{"colorbrewer"} \cr Gebaseerd op de 4 meest divergerende kleuren die kleurenblindveilig, printvriendelijk en kopieerveilig zijn volgens \emph{ColorBrewer} (die advies biedt voor cartografie): oranje, gelig, licht- en donkerblauw. Zie \href{http://colorbrewer2.org/#type=diverging&scheme=PuOr&n=4}{deze pagina van ColorBrewer 2.0}. \cr \cr
#' \code{"ggplot"} \cr Kleuren die in de eerste versie van ggplot gebruikt werden als \code{Set1}. \cr \cr
#' \code{"ggplot2"} \cr Kleuren die in ggplot2 gebruikt worden als \code{Set2}. \cr \cr
#' @param length Standaard is \code{1}. Aantal kleuren dat geretourneerd moet worden.
#' @param opacity Standaard is \code{0}. Transparantie, een waarde tussen 0-1.
#' @details
#' \if{html}{
#'
#' \out{<div style="text-align: center">}\figure{palette.png}{options: style="width:925px;max-width:95\%;"}\out{</div>}
#'
#' }
#' \if{latex}{
#'
#' \out{\begin{center}}\figure{palette.png}\out{\end{center}}
#' }
#'
#' About \href{https://CRAN.R-project.org/package=viridis/vignettes/intro-to-viridis.html#introduction}{viridis}:
#'
#' These colour scales are designed to be:
#' \itemize{
#' \item \strong{Colourful}, spanning as wide a palette as possible so as to make differences easy to see,
#' \item \strong{Perceptually uniform}, meaning that values close to each other have similar-appearing colours and values far away from each other have more different-appearing colors, consistently across the range of values,
#' \item \strong{Robust to colourblindness}, so that the above properties hold true for people with common forms of colourblindness, as well as in grey scale printing.
#' }
#' @keywords kleur aantal tint palette
#' @return RGB-kleur(en) in HTML-tekst, zoals \code{"#849A42"} voor \code{x = "certegroen"}.
#' @export
#' @examples
#' colourpicker("certegroen")
#'
#' # spectra uitproberen:
#' tibble(x = c(1:500), y = 1) %>%
#' ggplot(aes(x, y)) +
#' theme(
#' panel.grid.minor.x = element_blank(),
#' panel.grid.major.x = element_blank(),
#' panel.grid.minor.y = element_blank(),
#' panel.grid.major.y = element_blank()
#' ) +
#' geom_col(
#' width = 1,
#' fill = colourpicker("heat", length = 500))
#'
#' \dontrun{
#'
#' ..., col = colourpicker("certeblauw", nrow(tbl)), ...
#' }
colourpicker <- function(x, length = 1, opacity = 0) {
# ondersteuning voor 100% doorzichtige kleur bij NA en NULL
x[is.null(x)] <- '#XXXXXX'
x[is.na(x)] <- '#XXXXXX'
x[x == 'ug'] <- 'rug'
colours.brewers <- c('certe',
'certe2',
'certe_rsi',
'certe_rsi2',
'izore',
'rsi',
'rug',
'viridis',
'r',
'R',
'rainbow',
'regenboog',
'heat',
'heatmap',
'hitte',
'terrain',
'terrein',
'topo',
'geo',
'prev',
'prevalentie',
'colourbrewer',
'colorbrewer',
'grijs',
'grijswaarden',
'greyscale',
'grayscale',
'ggplot',
'ggplot2')
if (x[1] == 'viridis') {
colour.list <- viridis::viridis(length)
} else if (x[1] %in% c('r', 'R', 'rainbow', 'regenboog')) {
colour.list <- rainbow(length)
} else if (x[1] %in% c('heat', 'heatmap', 'hitte')) {
colour.list <- heat.colors(length)
} else if (x[1] %in% c('terrain', 'terrein')) {
colour.list <- terrain.colors(length)
} else if (x[1] %in% c('topo', 'geo')) {
colour.list <- topo.colors(length)
} else if (x[1] %in% c('prev', 'prevalentie')) {
colour.list <- colorRampPalette(c(
rgb(140, 255, 140, maxColorValue = 255), # lichtgroen
rgb(40, 220, 40, maxColorValue = 255), # groen
rgb(220, 110, 20, maxColorValue = 255), # oranje
rgb(170, 0, 0, maxColorValue = 255)) # donkerrood
)(length)
} else if (x[1] %in% c('colourbrewer', 'colorbrewer')) {
# http://colorbrewer2.org/#type=diverging&scheme=PuOr&n=4
colour.list <- colorRampPalette(c(
rgb(230, 97, 1, maxColorValue = 255),
rgb(253, 184, 99, maxColorValue = 255),
rgb(178, 171, 210, maxColorValue = 255),
rgb(94, 60, 153, maxColorValue = 255))
)(length)
} else if (x[1] == 'certe_rsi') {
colour.list <- colorRampPalette(c(
colourpicker("certeroze"),
colourpicker("certegeel"),
colourpicker("certegroen"))
)(length)
} else if (x[1] == 'certe_rsi2') {
colour.list <- colorRampPalette(c(
colourpicker("certeroze2"),
colourpicker("certegeel2"),
colourpicker("certegroen2"))
)(length)
} else if (x[1] == 'rsi') {
# van het palet "RdYlGn"
colour.list <- colorRampPalette(
RColorBrewer::brewer.pal(n = 3, name = "RdYlGn")
)(length)
} else if (x[1] %in% c('grijs', 'grijswaarden', 'greyscale', 'grayscale')) {
colour.list <- gray.colors(length)
} else if (x[1] == 'ggplot') {
# herschreven van https://stackoverflow.com/a/8197703/4575331
colour.list <- grDevices::hcl(h = seq(from = 15, to = 375, length = length + 1),
l = 65,
c = 100)[1:length]
} else if (x[1] == 'ggplot2') {
if (length > 8) {
stop("The `ggplot2` 'Set2' palette only supports up to 8 different colours.")
}
colour.list <- c("#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3",
"#A6D854", "#FFD92F", "#E5C494", "#B3B3B3")
colour.list <- colour.list[1:length]
} else {
colour.list <- c(
certeblauw = rgb(1, 97, 126, maxColorValue = 255),
certegroen = rgb(139, 153, 52, maxColorValue = 255),
certeroze = rgb(224, 72, 131, maxColorValue = 255),
certegeel = rgb(255, 228, 0, maxColorValue = 255),
certelila = rgb(171, 121, 179, maxColorValue = 255),
certezachtlila = rgb(214, 182, 214, maxColorValue = 255),
certeblauw2 = rgb(66, 151, 182, maxColorValue = 255),
certegroen2 = rgb(186, 203, 133, maxColorValue = 255),
certeroze2 = rgb(240, 151, 187, maxColorValue = 255),
certegeel2 = rgb(255, 245, 162, maxColorValue = 255),
certelila2 = rgb(203, 174, 208, maxColorValue = 255),
certezachtlila2 = rgb(230, 210, 230, maxColorValue = 255),
certeblauw3 = rgb(236, 242, 246, maxColorValue = 255),
certegroen3 = rgb(241, 242, 236, maxColorValue = 255),
certeroze3 = rgb(244, 234, 238, maxColorValue = 255),
certegeel3 = rgb(255, 251, 208, maxColorValue = 255),
certelila3 = rgb(230, 210, 230, maxColorValue = 255),
certezachtlila3 = rgb(238, 225, 238, maxColorValue = 255),
izorerood = rgb(199, 66, 49, maxColorValue = 255),
izoregrijs = rgb(205, 205, 205, maxColorValue = 255),
rugrood = rgb(204, 0, 0, maxColorValue = 255),
rugblauw = rgb(0, 156, 239, maxColorValue = 255),
rugpaars = rgb(119, 45, 107, maxColorValue = 255),
rugdonkerblauw = rgb(45, 0, 142, maxColorValue = 255),
ruggroen = rgb(0, 153, 119, maxColorValue = 255),
rugbordeauxrood = rgb(124, 33, 40, maxColorValue = 255),
ruggrijs = rgb(102, 109, 112, maxColorValue = 255),
ruggoud = rgb(132, 112, 64, maxColorValue = 255),
rugzilver = rgb(142, 142, 139, maxColorValue = 255)
)
}
if (x[1] %in% colours.brewers) {
if (x[1] %in% c('certe', 'certe2', 'certe3', 'izore', 'rug')) {
if (x[1] == 'certe2') {
colour.list <- colour.list[7:length(colour.list)]
} else if (x[1] == 'certe3') {
colour.list <- colour.list[13:length(colour.list)]
} else {
colour.list <- colour.list[which(colour.list %>%
names() %>%
grepl(
paste0(
'^',
x[1]),
.))]
}
# RuG helder blauw eruit als het lengte meer dan 3 is
if (length > 3) {
colour.list <- colour.list[which(colour.list %>% names() != 'rugblauw')]
}
if (length > length(colour.list)) {
# vult na alle voorgedefinieerde kleuren aan met grijstinten tussen 70-95% wit
x <- c(colour.list[1:length(colour.list)],
gray.colors(length - length(colour.list), start = 0.7, end = 0.95)) %>%
unname()
} else {
x <- colour.list[1:length] %>% unname()
}
} else {
x <- colour.list
}
} else {
# voor alle rest
for (i in 1:length(x)) {
if (x[i] %like% '^[0-F]{3}$' |
x[i] %like% '^[0-F]{6}$') {
x[i] <- paste0('#', x[i])
}
# ondersteuning voor #ffa -> #ffffaa
if (x[i] %like% '^#[0-F]{3}$') {
xi.bak <- x[i]
x[i] <- '#'
for (h in 2:4) {
x[i] <- paste0(x[i], rep((xi.bak %>% split.every.n(1))[h], 2) %>% concat())
}
}
if (!(x[i] %>% substr(1, 7)) %like% '^#[0-F]{6}$') {
if (x[i] %in% names(colour.list)) {
x[i] <- colour.list[x[i]]
} else if (!x[i] %in% colours() & !x[i] == '#XXXXXX') {
# geen geldige R-kleur
warning('Colour not found: ', x[i], ' - picking random grey between 25-75% black.', call. = FALSE)
# grey25 = rgb(64, 64, 64); grey75 = rgb(191, 191, 191)
col.random <- sample(c(64:191))[1]
x[i] <- rgb(
red = col.random,
green = col.random,
blue = col.random,
maxColorValue = 255
)
} else if (!x[i] == '#XXXXXX') {
rgb.list <- col2rgb(x[i])
x[i] <- rgb(
red = rgb.list[1],
green = rgb.list[2],
blue = rgb.list[3],
maxColorValue = 255
)
}
}
}
x <- x %>% rep(times = length)
}
# bij sommige kleurenspectra wordt FF als alpha toegevoegd; verwijderen
x[which(x %>% nchar() > 7)] <- x %>% substr(1, 7)
# is nu hexadecimaal; alpha erachter plakken
if (!missing(opacity)) {
x <- paste0(x,
((1 - opacity) * 255) %>%
round() %>%
as.hexmode() %>%
toupper() %>%
if_else(nchar(.) == 1,
paste0('0', .),
.))
}
# onsteuning voor 100% doorzichtige kleur bij NA en NULL
x[x == '#XXXXXX'] <- '#FFFFFF00'
x %>% unname()
}
#' @rdname colourpicker
#' @export
colorpicker <- function(x, length = 1, opacity = 0) {
colourpicker(x = x, length = length, opacity = opacity)
}
#' @exportMethod as.data.frame.percent
#' @export
#' @noRd
as.data.frame.percent <- function(x, ...) {
base::as.data.frame.numeric(x, ...)
}
#' Class 'percent'
#'
#' Dit is een nieuwe class voor procentuele weergave van de class \code{double}.
#' @param x Waarde.
#' @param ... Paramters die doorgegeven worden aan \code{\link{as.double}}.
#' @rdname percent
#' @return Nieuwe class \code{percent}
#' @export
as.percent <- function(x, ...) {
p <- x %>% as.double(x, ...)
class(p) <- c('percent', 'double')
p
}
#' @rdname percent
#' @export
is.percent <- function(x) {
identical(class(x), c('percent', 'double'))
}
#' @exportMethod as.character.percent
#' @export
#' @noRd
as.character.percent <- function(x, ...) {
x %>% format2.percent(format.NL = FALSE) %>% as.character.default(...)
}
#' @exportMethod print.percent
#' @export
#' @noRd
print.percent <- function(x, format.NL = FALSE, ...) {
print(paste0("`", format2.percent(x, format.NL = format.NL, round = 2), "`"), quote = FALSE)
}
#' @exportMethod summary.percent
#' @export
#' @noRd
summary.percent <- function(object, ...) {
x <- summary.default(object, ...)
y <- x %>% as.percent() %>% format()
names(y) <- names(x)
y
}
#' Nieuwe formaatweergave
#'
#' Formateer een \code{R} object voor mooie weergave.
#' @param x Waarde(n) die getransformeerd moet(en) worden.
#' @param round Aantal decimalen waarop afgerond moet worden.
#' @param force.decimals Forceren van decimale getallen, zelfs als het laatste decimale getal volgens \code{round} een 0 is.
#' @param format.NL Zie \code{\link{Sys.isdecimalcomma}}. Hiermee worden getallen met een komma als decimaal teken weergegeven.
#' @param non.scientific Met \code{TRUE} wordt een reguliere, niet-wetenschappelijke notatie geforceerd.
#' @param min.length De minimale lengte van de output. Dit overschrijft \code{force.decimals}.
#' @param format Formaat dat gebruikt moet worden. Ondersteunt leesbare formaten zoals \code{"d mmmm yyyy"} d.m.v. \code{\link{date_generic}}, maar ook UNIX zoals \code{"\%e \%B \%Y"}.
#' @exportMethod format2
#' @rdname format2
#' @details Zie voor ondersteunde tekst voor de parameter \code{format} voor datum en tijd: \code{\link{date_generic}}.
#' @export
format2 <- function(x,...) {
UseMethod("format2")
}
#' @exportMethod format2.default
#' @rdname format2
#' @export format2.default
format2.default <- function(x,
format = 'd mmmm yyyy',
percent = FALSE,
round = ifelse(percent, 1, 2),
force.decimals = ifelse(percent, TRUE, FALSE),
format.NL = Sys.isdecimalcomma(),
...) {
if (percent == TRUE) {
format2.percent(x,
round = round,
force.decimals = force.decimals,
format.NL = format.NL,
...)
} else {
if (identical(class(x), "NULL")) {
format(x, ...)
} else if (any(c('list', 'formula', 'expression', 'matrix') %in% class(x))) {
format(x, ...)
} else if (readr::guess_parser(x) == 'date') {
format2.Date(as.Date(x), format = format, ...)
} else if (all(is.double2(x))) {
format2.numeric(x,
round = round,
force.decimals = force.decimals,
format.NL = format.NL, ...)
} else {
format(x, digits = round, ...)
}
}
}
#' @exportMethod format2.percent
#' @rdname format2
#' @export format2.percent
format2.percent <- function(x,
round = 1,
force.decimals = TRUE,
format.NL = Sys.isdecimalcomma(),
...) {
if (length(x) == 0) {
return(character())
}
if (format.NL == TRUE) {
big.mark = "."
decimal.mark = ","
} else {
big.mark = ""
decimal.mark = "."
}
x <-
paste0(formatC(
round(x * 100, round),
big.mark = big.mark,
decimal.mark = decimal.mark,
digits = round,
format = 'f'
),
"%")
x <- gsub('NA%', NA, x, fixed = TRUE)
if (force.decimals == FALSE) {
# alle trailing zeroes verwijderen
x <- gsub(paste0(decimal.mark, '0+%'), '%', x, fixed = FALSE)
# 2,% = 2%
x <- gsub(paste0(decimal.mark, '%'), '%', x, fixed = TRUE)
}
x
}
#' @exportMethod format2.POSIXct
#' @rdname format2
#' @export format2.POSIXct
format2.POSIXct <- function(x, format = 'd mmmm yyyy', ...) {
if (any(class(x) == 'POSIXt')) {
# nu is het tijd, zoals Sys.time(), dat heeft als class: c("POSIXct", "POSIXt")
if (missing(format)) {
format2.POSIXt(x, ...)
} else {
format2.POSIXt(x, format, ...)
}
} else {
format2.Date(x, format, ...)
}
}
#' @exportMethod format2.POSIXlt
#' @rdname format2
#' @export format2.POSIXlt
format2.POSIXlt <- function(x, format = 'd mmmm yyyy', ...) {
format2.Date(x, format, ...)
}
#' @exportMethod format2.POSIXt
#' @rdname format2
#' @export format2.POSIXt
format2.POSIXt <- function(x, format = 'HH:MM:SS', ...) {
format2.Date(x, format, ...)
}
#' @exportMethod format2.hms
#' @rdname format2
#' @export format2.hms
format2.hms <- function(x,
format = 'HH:MM:SS',
round = 2,
force.decimals = FALSE,
format.NL = Sys.isdecimalcomma(),
...) {
if (is.double2(x)) {
format2.numeric(x,
round = round,
force.decimals = force.decimals,
percent = FALSE,
format.NL = format.NL,
...)
} else {
format2.Date(as.POSIXct(x), format = format, ...)
}
}
#' @exportMethod format2.difftime
#' @rdname format2
#' @export format2.difftime
format2.difftime <- function(x,
round = 2,
force.decimals = FALSE,
format.NL = Sys.isdecimalcomma(),
...) {
format2.numeric(x,
round = round,
force.decimals = force.decimals,
percent = FALSE,
format.NL = format.NL,
...)
}
#' @exportMethod format2.Date
#' @rdname format2
#' @export format2.Date
format2.Date <- function(x, format = 'd mmmm yyyy', ...) {
format <- date_generic(format)
# if (all(x %like% '^[0-9]+:[0-9]+')) {
# x <- paste('1970-01-01', x)
# }
if (any(x %>% class() %in% c('hms', 'difftime', 'POSIXlt'))) {
if (all(x %like% '^[0-9]+:[0-9]+')) {
x <- paste('1970-01-01', x)
}
df <- tibble(dat = as.POSIXlt(x), form = format(as.POSIXlt(x), format))
} else {
df <- tibble(dat = as.POSIXct(x), form = format(as.POSIXct(x), format))
}
# Voorloopspatie moet verwijderd worden
df$form <- trimws(df$form, 'left')
df$form <- gsub(' ', ' ', df$form, fixed = TRUE)
# kwartalen vervangen
if (any(grepl('%q', df %>% pull(form), fixed = TRUE))) {
for (i in 1:nrow(df)) {
kwartaal <- as.integer(sprintf("%02i", (as.POSIXlt(df[i, 'dat'] %>% pull())$mon) %/% 3L + 1L))
df[i, 'form'] <- gsub('%q', kwartaal, df[i, 'form'], fixed = TRUE)
}
}
if (format == 'unix') {
df$form %>% as.double()
} else {
df$form
}
}
#' @exportMethod format2.numeric
#' @rdname format2
#' @export format2.numeric
format2.numeric <- function(x,
round = ifelse(percent, 1, 2),
force.decimals = ifelse(percent, TRUE, FALSE),
non.scientific = FALSE,
format.NL = Sys.isdecimalcomma(),
min.length = 0,
percent = FALSE,
...) {
if (percent == TRUE) {
format2.percent(x = x,
round = round,
force.decimals = force.decimals,
format.NL = format.NL)
} else {
label_wetenschappelijk <- function(l) {
# bron: http://stackoverflow.com/a/24241954
# turn in to character string in scientific notation
l <- format(l, scientific = TRUE)
# quote the part before the exponent to keep all the digits
l <- gsub("^(.*)e", "'\\1'e", l)
# verwijder de + bij de exponent
l <- gsub("e+", "e", l, fixed = TRUE)
# afronden op ingestelde aantalen decimalen
#l <- gsub("^(.*)e", paste0('"', substr(l, 1, 2 + round), '"e'), l)
# turn the 'e+' into plotmath format
l <- gsub("e", "%*%10^", l)
# punt vervangen door komma
if (format.NL == TRUE) {
l <- gsub(".", ",", l, fixed = TRUE)
}
# return this as an expression
parse(text = l)
}
if (length(x) == 0) {
return(character())
}
if (format.NL == TRUE) {
big.mark = "."
decimal.mark = ","
} else {
big.mark = ""
decimal.mark = "."
}
if (min.length > 0) {
if (force.decimals == TRUE) {
warning('`force.decimals = TRUE` will be overwritten by `min.length = ', min.length, '`.')
}
# if (!(x %>% identical(x %>% as.integer()))) {
# warning('`force.decimals = TRUE` overwritten by `min.length = ', min.length, '`; transforming to real numbers.')
# }
x <- formatC(x %>% as.integer(),
width = min.length,
flag = "0")
} else {
if (force.decimals == TRUE) {
x <-
formatC(
round(as.double(x), digits = round),
digits = round,
big.mark = big.mark,
decimal.mark = decimal.mark,
format = 'f'
)
} else {
x <-
format(
round(as.double(x), round),
scientific = FALSE,
big.mark = big.mark,
decimal.mark = decimal.mark
)
}
}
x <- gsub('NA', NA, x, fixed = TRUE)
x <- gsub(' NA', NA, x, fixed = TRUE)
x <- trimws(x)
x
}
}
#' @exportMethod format.percent
#' @export
#' @noRd
format.percent <- function(x,
round = 2,
force.decimals = TRUE,
...) {
format2.percent(x, round, force.decimals, format.NL = FALSE, ...)
}
#' Datum-/tijd-formaat van Excel transformeren naar Unix-formaat
#'
#' Retourneert het formaat in Unix-vorm, bijv. \code{"d mmmm yyyy"} -> \code{"\%e \%B \%Y"}.
#' @param format Formaat om te transformeren, zoals \code{"d mmmm yyyy"}. Zie Details.
#' @details
#' De volgende formaten worden ondersteund: \cr
#' \cr \strong{Tijd:}
#' \cr
#' - \code{"H"} (0-23, geen voorloopnul) \cr
#' - \code{"HH"} (00-23, wel voorloopnul) \cr
#' - \code{"MM"} (00-59) \cr
#' - \code{"SS"} (00-59) \cr
#' \cr - Combinaties \cr
#' \code{"H:MM:SS"}: 9:12:01, enz. \cr
#' \code{"HH:MM:SS"}: 09:12:01, enz. \cr
#' \cr \strong{Dagen:}
#' \cr
#' - \code{"d"} (1-31, geen voorloopnul) \cr
#' - \code{"dd"} (01-31, wel voorloopnul) \cr
#' - \code{"ddd"} (ma-zo) \cr
#' - \code{"dddd"} (maandag-zondag) \cr
#' \cr - Combinaties \cr
#' \code{"dddd d mmmm"}: maandag 1 januari, dinsdag 2 januari, enz. \cr
#' \cr \strong{Weken:}
#' \cr
#' - \code{"w"} of \code{"ww"} (01-53) \cr
#' \cr - Combinaties \cr
#' \code{"yyyy-ww"}: 2018-01, 2018-02, enz. \cr
#' \code{"yyyy_iso-ww"}, bijv.: \code{format2("2017-01-01", "yyyy_iso-ww") = 2016-52}. \cr
#'
#' Volgens \href{https://nl.wikipedia.org/wiki/ISO_8601}{ISO 8601} (Nederland); dit weeknummer wijkt af van het Amerikaanse weeknummer. \cr
#' \cr \strong{Maanden:}
#' \cr
#' - \code{"mm"} (01-12) \cr
#' - \code{"mmm"} (jan-dec) \cr
#' - \code{"mmmm"} (januari-december) \cr
#' \cr - Combinaties \cr
#' \code{"mm (mmmm)"}: 01 (januari), 02 (februari), enz. \cr
#' \code{"mm-mmm"}: 01-jan, 02-feb, enz. \cr
#' \cr \strong{Kwartalen:}
#' \cr
#' - \code{"q"} of \code{"k"} (1-4) \cr
#' - \code{"qq"} of \code{"QQ"} (Q1-Q4) \cr
#' - \code{"kk"} of \code{"KK"} (K1-K4) \cr
#' \cr - Combinaties \cr
#' \code{"yyyy-qq"}: 2018-Q1, 2018-Q2, enz. \cr
#' \cr \strong{Jaren:}
#' \cr
#' - \code{"jj"} of \code{"yy"} (00-99) \cr
#' - \code{"jjjj"} of \code{"yyyy"} (1900-2099) \cr
#' - \code{"jj_iso"} of \code{"yy_iso"} (00-99) \cr
#' - \code{"jjjj_iso"} of \code{"yyyy_iso"} (1970-2099) \cr
#'
#' Volgens \href{https://nl.wikipedia.org/wiki/ISO_8601}{ISO 8601} (Nederland, bijv.: \code{format2("2017-01-01", "yyyy_iso") = 2016}). \cr
#' \cr \strong{Overig:}
#' \cr
#' \code{"iso"} datumformaat volgens \href{https://nl.wikipedia.org/wiki/ISO_8601}{ISO 8601}: yyyy-mm-dd \cr
#' \code{"unix"} aantal seconden sinds Epoch (1 jan 1970 0:00:00): een \emph{Unix Timestamp}
#' @keywords format formaat datum date
#' @export
#' @return Tekst
date_generic <- function(format) {
if (!grepl('%', format, fixed = TRUE)) {
# eerst maanden en minuten, daarna is alles hoofdletterONgevoelig
format <- gsub('mmmm', '%B1', format, fixed = TRUE)
format <- gsub('mmm', '%b', format, fixed = TRUE)
format <- gsub('mm', '%m', format, fixed = TRUE)
format <- gsub('MM', '%M1', format, fixed = TRUE)
format <- format %>%
tolower() %>%
gsub('%b1', '%B', ., fixed = TRUE) %>%
gsub('%m1', '%M', ., fixed = TRUE)
# datums
format <- gsub('dddd', '%A', format, fixed = TRUE)
format <- gsub('ddd', '%a', format, fixed = TRUE)
format <- gsub('dd', '%!', format, fixed = TRUE)
format <- gsub('d', '%e', format, fixed = TRUE)
format <- gsub('%!', '%d', format, fixed = TRUE)
format <- gsub('ww', '%V', format, fixed = TRUE)
format <- gsub('w', '%V', format, fixed = TRUE)
format <- gsub('qq', 'Qq', format, fixed = TRUE) # wordt hierna dus 'Q%%q'
format <- gsub('kk', 'Kq', format, fixed = TRUE)
format <- gsub('k', 'q', format, fixed = TRUE)
format <- gsub('q', '%%q', format, fixed = TRUE)
format <- gsub('yyyy_iso', '%G', format, fixed = TRUE)
format <- gsub('jjjj_iso', '%G', format, fixed = TRUE)
format <- gsub('yyyy', '%Y', format, fixed = TRUE)
format <- gsub('jjjj', '%Y', format, fixed = TRUE)
format <- gsub('yy_iso', '%g', format, fixed = TRUE)
format <- gsub('jj_iso', '%g', format, fixed = TRUE)
format <- gsub('yy', '%y', format, fixed = TRUE)
format <- gsub('jj', '%y', format, fixed = TRUE)
# tijd
format <- gsub('hh', '%H', format, fixed = TRUE)
format <- gsub('h', '%k', format, fixed = TRUE)
format <- gsub('ss', '%S', format, fixed = TRUE)
# Seconds since the Epoch, 1970-01-01 00:00:00
format <- gsub('unix', '%s', format, fixed = TRUE)
# Equivalent to %Y-%m-%d (the ISO 8601 date format)
format <- gsub('iso', '%F', format, fixed = TRUE)
}
format
}
#' Unmelt
#'
#' Doet het tegenovergestelde van \code{\link{melt}}.
#' @param x Tabel
#' @param id Standaard is de eerste kolom. De kolomnaam die blijft staan
#' @param variabele Standaard is de tweede kolom. De kolom waarvan de unieke waarden nieuwe kolommen worden
#' @export
unmelt <- function(x, id = colnames(x)[1], variables = colnames(x)[2]) {
x <- x %>% reshape2::dcast(.[, id] ~ .[, variables])
colnames(x)[1] <- id
x
}
#' Datum uit klinische gegevens bepalen
#'
#' Bepaalt met reguliere expressie de waarde uit klinische gegevens en retourneert geldige datums.
#' @param x Tekst, zoals klinische gegevens.
#' @param type Standaard is de eerste ziektedag.
clinical_date <- function(x, type = "Eerste ziektedag") {
regex <- paste0(".*", gsub(" ", ".?", type), "[: ]+([0-9]{1,2}[ ./-]([0-9]{1,2}|[a-z ]+)[ ./-][0-9]{1,4}).*")
dates <- gsub(regex, "\\1", x, ignore.case = TRUE)
lubridate::dmy(dates)
}
#' Data completeren met extra rijen
#'
#' Data opvullen met missende rijen. Standaard worden rijen aangevuld tussen de min en max van \code{variabele}.
#' @param data \code{data.frame} waarin rijen missen.
#' @param variable Variabele die numerieke waarden bevat en op basis waarvan de tabel aangevuld moet worden.
#' @param newvalue Standaard is \code{0}. Waarde die ingevuld moet worden in de kolommen.
# @param columns_to_expand Standaard is alle kolommen, behalve \code{variable}. Kolommen die aangevuld moeten worden met de waarde \code{newvalue}.
#' @param start_with_1 Standaard is \code{FALSE}. Waarde \code{1} als minimum voor \code{variabele} gebruiken, waardoor het hele bereik ingevuld wordt.
#' @export
#' @examples
#' a <- data.frame(week = c(3, 5, 6),
#' x = c(14, 23, 16),
#' y = c(34, 31, 28))
#' a
#' # week x y
#' # 1 3 14 34
#' # 2 5 23 31
#' # 3 6 16 28
#'
#' a %>% complete_rows(week)
#' # week x y
#' # 1 3 14 34
#' # 2 4 0 0
#' # 3 5 23 31
#' # 4 6 16 28
#'
#' a %>% complete_rows(week, start_with_1 = TRUE)
#' # week x y
#' # 1 1 0 0
#' # 2 2 0 0
#' # 3 3 14 34
#' # 4 4 0 0
#' # 5 5 23 31
#' # 6 6 16 28
#'
#' a %>% complete_rows(week, NA, start_with_1 = TRUE)
#' # week x y
#' # 1 1 NA NA
#' # 2 2 NA NA
#' # 3 3 14 34
#' # 4 4 NA NA
#' # 5 5 23 31
#' # 6 6 16 28
complete_rows <- function(data, variable, newvalue = 0, start_with_1 = FALSE) {
variable <- deparse(substitute(variable))
if (!is.numeric(data %>% pull(variable))) {
stop('`variabele` must be a numeric value')
}
var_vector <- data %>% pull(variable)
if (start_with_1 == TRUE) {
var_min <- 1
} else {
var_min <- var_vector %>% min()
}
var_max <- var_vector %>% max()
var_missing <- (seq(from = var_min, to = var_max) %in% var_vector) == FALSE
var_new <- seq(from = var_min, to = var_max)[var_missing]
#if (is.null(columns_to_expand)) {
columns_to_expand <- colnames(data)[colnames(data) != variable]
#}
if (rownames(data) %>% as.double2() %>%
identical(c(1:nrow(data)) %>% as.double2())) {
reset_rownames <- TRUE
} else {
reset_rownames <- FALSE
}
for (i in 1:length(var_new)) {
data_line <- data[1,]
data_line[,columns_to_expand] <- newvalue
data_line[,variable] <- var_new[i]
data <- data %>% rbind(data_line)
}
data <- data[order(data %>% pull(variable)), ]
if (reset_rownames == TRUE) {
rownames(data) <- 1:nrow(data)
}
data
}
#' @rdname double
#' @inherit base::double
#' @description Dit werkt hetzelfde als \code{\link{is.double}} en \code{\link{as.double}}, maar toetst en transformeert respectievelijk door eerst komma's als punt te lezen. De functie \code{is.double2} toetst door middel van reguliere expressies, dus wordt ook \code{TRUE} bij bijvoorbeeld \code{"3306"}.
#' @param dec Standaard is \code{c(".", ",")}. Tekens die als decimaal teken gelezen moeten worden.
#' @param na.rm Standaard is \code{TRUE}. lege waarden negeren.
#' @export is.double2
is.double2 <- function(x, dec = c(".", ","), na.rm = TRUE) {
if (na.rm == TRUE) {
x <- x[!is.na(x)]
} else if (length(x[is.na(x)]) > 0) {
return(NA)
}
x %like% paste0('^[0-9]+[', concat(dec), '][0-9]+$') | x %like% '^[0-9]+$'
}
#' @rdname double
#' @export as.double2
as.double2 <- function(x) {
x %>% gsub(",", ".", .) %>% as.double()
}
#' Splitsen in vaste breedte
#'
#' Hiermee kan een tekst of getal gesplitst worden op elk aangegeven aantal tekens.
#' @param x Tekst of getal
#' @param n De input \code{x} splitsen op elke \code{n} tekens.
#' @keywords split
#' @export split.every.n
#' @examples
#' 256 %>% split.every.n(1) # c(2, 5, 6)
#' 256 %>% split.every.n(2) # c(25, 6)
#' "Certe" %>% split.every.n(1) # c("C", "e", "r", "t", "e")
#' "Certe" %>% split.every.n(4) # c("Cert", "e")
split.every.n <- function(x, n) {
if (length(x) != 1L) {
stop('Only input with length of 1 allowed.')
}
if (is.na(x) | x == "") {
return("")
} else {
output.class <- class(x)
if (n == 1) {
as(strsplit(x %>% as.character(), "")[[1]], output.class)
} else {
substring(x,
seq(from = 1, to = nchar(x), by = n),
seq(from = n, to = nchar(x) + n - 1, by = n)) %>%
as(output.class)
}
}
}
#' Samenvoegen van vector
#'
#' Samenvoegen van items in een vector. Dit is gelijk aan \code{paste(..., sep = "", collapse = "")}.
#' @param x Een vector met tekst.
#' @param sep Standaard is \code{""}. Tekst om \code{x} op te splitsen.
#' @export
concat <- function(x, sep = '') {
paste(x, collapse = sep, sep = "")
}
#' Transformeren naar Zoals een zin.
#'
#' Dit transformeert de hoofdletters van een tekst naar de vorm \strong{"Zoals een zin."} of, wanneer \code{every.word = TRUE} wordt gebruikt, \strong{"Zoals Een Zin."}.
#' @param text De tekst die getransformeerd moet worden
#' @param every.word Standaard is \code{FALSE}. Ieder woord met een hoofdletter laten beginnen.
#' @param intelligent Standaard is \code{FALSE}. Woorden van maximaal 4 tekens met maximaal 1 klinker niet transformeren (zoals \code{"MCL"} en \code{"UMCG"}), en 1-letterwoorden niet capitaliseren.
#' @param only.first.char Standaard is tegenovergestelde van \code{every.word}. Hoofdlettergebruik behouden van alles behalve eerste letter.
#' @keywords case tolower toupper toproper proper hoofdletters hoofdletter
#' @return Tekst
#' @export
#' @examples
#' tolower("TJONGERSCHANS") # wordt "tjongerschans"
#' toupper("Tjongerschans") # wordt "TJONGERSCHANS"
#' toproper("TJONGERSCHANS") # wordt "Tjongerschans"
#'
#' toproper(c("TJONGERSCHANS", "ANTONIUS", "MCL", "UMCG"))
#' # wordt c("Tjongerschans", "Antonius", "Mcl", "Umcg")
#'
#' toproper(c("TJONGERSCHANS", "ANTONIUS", "MCL", "UMCG"), intelligent = TRUE)
#' # wordt c("Tjongerschans", "Antonius", "MCL", "UMCG")
toproper <- function(text, every.word = FALSE, intelligent = FALSE, only.first.char = !every.word) {
text <- as.character(text)
for (i in 1:length(text)) {
if (is.na(text[i])
| (intelligent == TRUE & nchar(text[i]) == 1)
| (intelligent == TRUE &
nchar(text[i]) < 5 &
nchar(text[i]) - nchar(gsub('[aeiyouAEIYOU]', '', text[i])) <= 1)) {
# waarde NA, of 1-letterwoord, of een afkorting zoals MCL en UMCG --> niet transformeren
} else if (every.word == FALSE) {
if (only.first.char == TRUE) {
text[i] <- paste0(text[i] %>% substr(1, 1) %>% toupper(),
text[i] %>% substr(2, nchar(text[i])))
} else {
text[i] <- paste0(text[i] %>% substr(1, 1) %>% toupper(),
text[i] %>% substr(2, nchar(text[i])) %>% tolower())
}
} else {
lijst <- text[i] %>% strsplit(' ', fixed = TRUE) %>% unlist()
for (j in 1:length(lijst)) {
if (only.first.char == TRUE) {
lijst[j] <- paste0(lijst[j] %>% substr(1, 1) %>% toupper(),
lijst[j] %>% substr(2, nchar(lijst[j])))
} else {
lijst[j] <- paste0(lijst[j] %>% substr(1, 1) %>% toupper(),
lijst[j] %>% substr(2, nchar(lijst[j])) %>% tolower())
}
}
text[i] <- concat(lijst, ' ')
}
}
text
}
#' Verwijderen van titel en voorletters van naam
#'
#' Dit transformeert een naam als \code{"Dhr AA van der Molen"} naar \code{"V/d Molen"} en een naam als \code{"Prof dr AB Jansen"} naar \code{"Jansen"}. Verwijdert alle academische titels voor de naam (Prof, Dr, Ir, enz) en achter de naam (Ph.D., MD, enz.) en ook Nederlandse voor- en achtervoegsels zoals Mw, Dhr en Jr of Sr.
#' @param name Naam van persoon
#' @keywords name
#' @return Tekst
#' @export
#' @examples
#' \dontrun{
#'
#' tbl$artsnaam <- strip_name(tbl$artsnaam)
#' }
strip_name <- function(name) {
nieuw <- name
# punt en komma eruit
nieuw <- gsub('.', '', nieuw, fixed = TRUE)
nieuw <- gsub(',', '', nieuw, fixed = TRUE)
# dubbele spaties naar 1 spatie
nieuw <- gsub(' ', ' ', nieuw, fixed = TRUE)
# titulatuur verwijderen
nieuw <- sub('^[Pp]rof ', '', nieuw)
nieuw <- sub('^[Dd]rs ', '', nieuw)
nieuw <- sub('^[Dd]r ', '', nieuw)
nieuw <- sub('^[Dd]r ', '', nieuw)
nieuw <- sub('^[Mm]ed ', '', nieuw)
nieuw <- sub('^[Ii]r ', '', nieuw)
nieuw <- sub('^[Mm]r ', '', nieuw)
nieuw <- sub('^[Ii]ng ', '', nieuw)
nieuw <- sub('^[Mm]w ', '', nieuw)
nieuw <- sub('^[Dd]hr ', '', nieuw)
nieuw <- sub('^[Dd]hm ', '', nieuw)
nieuw <- sub('^[Dd]hrn ', '', nieuw)
nieuw <- sub(' [Jj][Rr]$', '', nieuw)
nieuw <- sub(' [Ss][Rr]$', '', nieuw)
nieuw <- sub(' [Pp][Hh][Dd]$', '', nieuw)
nieuw <- sub(' [Mm][Dd]$', '', nieuw)
nieuw <- sub(' [Jj][Dd]$', '', nieuw)
nieuw <- sub(' [Pp][Hh][Dd]$', '', nieuw)
# voorletters verwijderen
nieuw <- sub('^[A-Z]+ ', '', nieuw)
# nieuwe eerste hoofdletter
nieuw <- paste0(toupper(substr(nieuw, 1, 1)), substr(nieuw, 2, nchar(nieuw)))
# sommige artsen staan verschillend in het systeem; plat slaan
nieuw <- sub('^Vd ', 'V/d ', nieuw)
nieuw <- sub('^Van der ', 'V/d ', nieuw)
nieuw <- sub('^Van den ', 'V/d ', nieuw)
nieuw <- sub('^Van de ', 'V/d ', nieuw)
nieuw
}
#' Bytes weergeven in kB/MB/GB
#'
#' De bestandsgrootte (als double) weergeven als kB/MB/GB.
#' @param bytes Grootte als getal
#' @param decimals Aantal tekens achter de komma.
#' @export
#' @examples
#' size_humanreadable(123456) # 121 kB
#' size_humanreadable(12345678) # 11.8 MB
size_humanreadable <- function(bytes, decimals = 1) {
bytes <- bytes %>% as.double()
# Adapted from:
# http://jeffreysambells.com/2012/10/25/human-readable-filesize-php
size <- c('B','kB','MB','GB','TB','PB','EB','ZB','YB')
factor <- floor((nchar(bytes) - 1) / 3)
# added slight improvement; no decimals for B and kB:
decimals <- rep(decimals, length(bytes))
decimals[size[factor + 1] %in% c('B', 'kB')] <- 0
out <- paste(sprintf(paste0("%.", decimals, "f"), bytes / (1024 ^ factor)), size[factor + 1])
if (Sys.isdecimalcomma()) {
out <- gsub('.', ',', out, fixed = TRUE)
}
out
}
#' Certe-thema voor \code{ggplot}-grafieken
#'
#' Hiermee kan aan een \code{ggplot}-model het Certe-thema meegegeven worden.
#' @param subtitle.colour Standaard is \code{colourpicker("certeblauw")}. Kleur van de ondertitel. Zie \code{\link{colourpicker}}.
#' @param x.lbl.angle Standaard is \code{0}. De hoek in graden waaronder de labels van de x-as weergegeven worden. Gebruik voor verticale weergave een hoek van \code{90} (richting onder naar boven) of \code{270} (richting boven naar onder).
#' @param x.lbl.align Standaard is \code{0.5}, waardoor er centraal uitgelijnd wordt. Andere geldige opties zijn \code{"links"}, \code{"midden"} en \code{"rechts"}.
#' @param horizontal Standaard is \code{FALSE}. Voor horizontale orientatie van kolommen of boxplots. Met \code{TRUE} worden de lijnen van de y-as vervangen door lijnen op de x-as.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt wordt voor tekst in de grafiek.
#' @param legend.position Standaard is \code{"top"}. Geldige opties zijn \code{"none"} (\code{"geen"}), \code{"left"} (\code{"links"}), \code{"right"} (\code{"rechts"}), \code{"top"} (\code{"boven"}), \code{"bottom"} (\code{"onder"}), of een vector met 2 cijfers: bijv. \code{legend.position = c(0, 0)} voor linksonder of \code{legend.position = c(1, 1)} voor rechtsboven.
#' @param text.factor Standaard is \code{1}. Factor van de grootte van alle tekst.
#' @param x.category.fill Standaard is \code{"certeblauw3"}. Kleur die doorgegeven wordt aan \code{\link{colourpicker}}.
#' @param x.category.bold Standaard is \code{TRUE}. Tekst van \code{x.category} vetgedrukt weergeven.
#' @param x.category.size Standaard is \code{10} pt. Grootte van de 'titel' bij elke grafiek.
#' @param x.category.margin Standaard is 3. Marge van de 'titel' bij elke grafiek.
#' @param has_subtitle Standaard is \code{FALSE}. De marges worden aangepast o.b.v. aanwezigheid van een ondertitel.
#' @details
#' \if{html}{Zonder \code{theme_certe()}:
#'
#' \out{<div style="text-align: center">}\figure{ggplot.png}{options: style="width:600px;max-width:95\%;"}\out{</div>}
#'
#' }
#' \if{latex}{Zonder theme_certe():
#'
#' \out{\begin{center}}\figure{ggplot.png}\out{\end{center}}
#' }
#' \if{html}{Met \code{theme_certe()}:
#'
#' \out{<div style="text-align: center">}\figure{singlecolumn.png}{options: style="width:600px;max-width:95\%;"}\out{</div>}
#' \out{<div style="text-align: center">}\figure{doublecolumn.png}{options: style="width:600px;max-width:95\%;"}\out{</div>}
#'
#' }
#' \if{latex}{Met theme_certe():
#'
#' \out{\begin{center}}\figure{singlecolumn.png}\out{\end{center}}
#' \out{\begin{center}}\figure{doublecolumn.png}\out{\end{center}}
#' }
#' @keywords grafiek chart ggplot subtitle.colour x.lbl.angle x.lbl.align horizontal font.family legend.position
#' @return Thema
#' @export
#' @examples
#' \dontrun{
#'
#' ggplot(tbl, aes(x = col1, y = col2)) + theme_certe()
#' }
theme_certe <- function(subtitle.colour = colourpicker("certeblauw"),
x.lbl.angle = 0,
x.lbl.align = 0.5,
horizontal = FALSE,
font.family = 'Calibri',
legend.position = 'top',
text.factor = 1,
x.category.fill = colourpicker(NA),
x.category.bold = TRUE,
x.category.size = 10,
x.category.margin = 4,
has_subtitle = FALSE) {
if (length(legend.position) == 1) {
legend.position <- tolower(legend.position)
if (is.na(legend.position)) {
legend.position <- 'none'
}
legend.position <- sub('geen', 'none', legend.position)
legend.position <- sub('^(t|boven)$', 'top', legend.position)
legend.position <- sub('^(r|rechts)$', 'right', legend.position)
legend.position <- sub('^(b|o|onder)$', 'bottom', legend.position)
legend.position <- sub('^(l|links)$', 'left', legend.position)
}
t <- theme_bw(base_size = 11 * text.factor,
base_family = font.family) %+replace%
theme(
axis.text.x = element_text(angle = x.lbl.angle, hjust = x.lbl.align, margin = margin(3, 0, 0, 0)),
axis.title.x = element_text(margin = margin(14, 0, 0, 0)),
axis.title.y = element_text(margin = margin(0, 14, 0, 0), angle = 90),
axis.ticks.y = element_blank(),
axis.ticks.x = element_line(size = 0.75, colour = 'grey75'),
axis.ticks.length = unit(2, "pt"),
legend.background = element_blank(),
legend.key = element_blank(),
legend.key.size = unit(11 * text.factor, 'pt'), # blokjes en lijnen links van tekst in legenda
legend.text = element_text(size = unit(9 * text.factor, 'pt'), # tekst zelf
margin = margin(l = 1, r = 6, unit = "pt")), # ruimte links en rechts van tekst
legend.position = legend.position,
legend.title = element_text(face = 'bold', size = unit(10 * text.factor, 'pt')),
panel.background = element_blank(),
panel.border = element_blank(),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_line(size = 0.375, colour = 'grey75'),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_line(size = 0.25, colour = 'grey85'),
axis.line = element_line(size = 0.375, colour = 'grey75'),
axis.line.y = element_blank(),
plot.margin = unit(c(5, # top
ifelse(horizontal == TRUE, 25, 5), # right
5, # bottom
5), # left
units = "pt"),
plot.background = element_blank(),
plot.subtitle = element_text(size = unit(11 * text.factor, 'pt'),
margin = margin(0, 0, ifelse(has_subtitle == TRUE, 15, 7), 0),
hjust = 0.5,
colour = subtitle.colour),
plot.title = element_text(size = unit(13 * text.factor, 'pt'),
margin = margin(0, 0, ifelse(has_subtitle == TRUE, 7, 15), 0),
hjust = 0.5,
colour = 'black'),
plot.caption = element_text(colour = 'grey50',
size = unit(10 * text.factor, 'pt'),
hjust = 1),
plot.tag = element_text(size = unit(14 * text.factor, 'pt'),
margin = margin(0, 0, 0, 0),
hjust = 0,
colour = 'black',
face = "bold"),
# voor x.category (facet_wrap):
strip.background = element_rect(fill = x.category.fill, colour = '#FFFFFF00'),
strip.text = element_text(face = if_else(x.category.bold, 'bold', 'plain'),
size = unit(x.category.size * text.factor, 'pt'),
margin = margin(t = x.category.margin, b = x.category.margin)),
strip.switch.pad.wrap = unit(10 * text.factor, "pt"),
strip.placement = 'outside',
complete = TRUE)
if (x.lbl.angle < 90 & x.lbl.angle > 10) {
t <- t +
theme(axis.text.x = element_text(margin = margin(-5, 0, 0, 0)))
}
if (horizontal == TRUE) {
t <- t %+replace%
theme(panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
panel.grid.major.x = element_line(size = 0.375, colour = 'grey75'),
panel.grid.minor.x = element_line(size = 0.25, colour = 'grey85'),
axis.ticks.x = element_blank(),
axis.ticks.y = element_line(size = 0.75, colour = 'grey75'),
# tekst op y-as (wat x-as was) rechts align en minder ruimte geven
axis.text.y = element_text(hjust = 1.0, vjust = 0.3, margin = margin(0, 3, 0, 0)),
axis.text.x = element_text(margin = margin(0, 0, 0, 0)),
axis.line.y = element_line(size = 0.375, colour = 'grey75'),
axis.line.x = element_blank())
}
t
}
#' Tijden transformeren naar UTC
#'
#' Transformeert all tijden die voorkomen in \code{x} naar UTC.
#' @param x Een vector of \code{data.frame} die kolommen bevat met tijden.
#' @export
as.UTC <- function(x) {
if (is.null(dim(x)) & "POSIXct" %in% class(x)) {
attr(x, "tzone") <- "UTC"
} else if ("POSIXct" %in% unlist(lapply(x, class))) {
for (i in 1:ncol(x)) {
x_vector <- x %>% pull(i)
if ("POSIXct" %in% class(x_vector)) {
attr(x_vector, "tzone") <- "UTC"
x[, i] <- x_vector
}
}
}
x
}
#' Class van elke kolom schatten
#'
#' Transformeert een \code{data.frame} door de class van elke kolom te schatten met \code{\link[readr]{parse_guess}} en forceert daarbij UTF-8-encoding voor ondersteuning van speciale tekens zoals klinkers met accenten. Wanneer een kolom de class \code{factor} of \code{character} bezit, wordt het Unicode-teken 00EB (ASCII escape character) vervangen door een spatie, worden kolommen die uitsluitend de waarden \code{c(NA, "", "S", "I", "R")} bevatten getransformeerd met \code{\link{as.rsi}}, en worden kolommen met kolomnamen die eindigen op \code{_mic} getransformeerd met \code{\link{as.mic}}.
#' @param tbl Tabel.
#' @param datenames Standaard is \code{"en"}. Taal van de datenames (zoals weekdagen en maanden).
#' @param dateformat Standaard is \code{"\%Y-\%m-\%d"}. Accepteert ook Excel-formaten, zoals \code{"dd-mm-yy"} en \code{"dd-mm-jjjj"}.
#' @param timeformat Standaard is \code{"\%H:\%M"}. Accepteert ook Excel-formaten, zoals \code{"HH:MM:SS"}.
#' @param decimal.mark Standaard is \code{"."}. Scheidingsteken voor decimale getallen.
#' @param big.mark Standaard is \code{""}. Groepsteken voor getallen, zoals 1.000.000.
#' @param timezone Standaard is \code{"UTC"}. Forceren van de weergave van tijd door de tijdzone aan te passen. Zomertijd is gelijk aan CEST (Central European Summer Time) en loopt 2 uur voor op UTC, wintertijd is gelijk aan CET (Central European Time) en loopt 1 uur voor op UTC.
#' @param na Standaard is \code{c("", "NULL", "NA", "<NA>")}. Waarden die vertaald moeten worden als \code{NA}.
#' @return Met behoud van oorspronkelijke class: \code{data.frame} (forceert geen \code{\link[tibble]{tibble}})
#' @export
tbl_guess_columns <- function(tbl,
datenames = 'en',
dateformat = '%Y-%m-%d',
timeformat = '%H:%M',
decimal.mark = '.',
big.mark = '',
timezone = 'UTC',
na = c("", "NULL", "NA", "<NA>")) {
dateformat <- date_generic(dateformat)
timeformat <- date_generic(timeformat)
# kolomtypen instellen met readr
for (i in 1:ncol(tbl)) {
if (!all(tbl %>% pull(i) %>% class() %in% c('list', 'matrix')) &
# geen Feces of Tips
!all(tbl %>% pull(i) %>% unique() %in% c('T', 'F'))) {
tbl[, i] <- readr::parse_guess(x = tbl %>% pull(i) %>% as.character(),
na = na,
locale = readr::locale(date_names = datenames,
date_format = dateformat,
time_format = timeformat,
decimal_mark = decimal.mark,
grouping_mark = big.mark,
encoding = "UTF-8",
tz = timezone,
asciify = FALSE))
}
if (timezone == "UTC") {
tbl <- as.UTC(tbl)
}
if (any(tbl %>% pull(i) %>% class() %in% c('factor', 'character'))) {
# voor snellere vergelijkingen:
distinct_val <- tbl %>% pull(i) %>% unique() %>% sort()
# ASCII escape character verwijderen: https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character
tbl[, i] <- tbl %>% pull(i) %>% tryCatch(gsub('\033', ' ', ., fixed = TRUE),
error = function(e) {
warning(e$message)
return(.)})
# zoeken naar RSI, mag niet allemaal "" zijn en moeten geldige AB-interpretaties zijn
if (!all(distinct_val[!is.na(distinct_val)] == '')
& all(distinct_val[!is.na(distinct_val)] %in% c('', 'I', 'I;I', 'R', 'R;R', 'S', 'S;S'))) {
tbl[, i] <- tbl %>% pull(i) %>% as.rsi()
}
}
# omzetten naar mic class
if (colnames(tbl)[i] %like% '_mic$') {
tbl[, i] <- tbl %>% pull(i) %>% as.mic()
}
# bacteriecode (EDIT: nu niet meer nodig, wordt apart `mo` toegevoegd in database.R)
# if (colnames(tbl)[i] %in% c('bactid', 'bacteriecode')) {
# suppressWarnings(tbl[, i] <- tbl %>% pull(i) %>% as.mo())
# }
}
tbl
}
#' Binaire kolommen transformeren naar logical
#'
#' Hiermee worden kolommen die uitsluitend waarden 0 en 1 bevatten, omgezet naar de class \code{logical}.
#' @param tbl Tabel waarvan kolommen getransformeerd moeten worden.
#' @export
tbl_binary2logical <- function(tbl) {
for (i in 1:ncol(tbl)) {
# moet 0 en 1 bevatten en mag niet alleen maar NA zijn, en geen factor
if ('0' %in% (tbl %>% pull(i))
& '1' %in% (tbl %>% pull(i))
& all(tbl %>% pull(i) %in% c('0', '1', NA))
& !all(is.na(tbl %>% pull(i)))
& !'factor' %in% (tbl %>% pull(i) %>% class())) {
suppressWarnings(
tbl[, i] <- tbl %>% pull(i) %>% as.double() %>% as.logical()
)
}
}
tbl
}
#' Tabel printen in Markdown, LaTeX of HTML
#'
#' Drukt een tabel af (forceert \code{\link{print}}) in Markdown, LaTeX of HTML m.b.v. \code{\link[knitr]{kable}}, met standaard vette kolomnamen en naar Nederlands getransformeerde formaten voor datums, getallen en percentages.
#' @param tbl Een \code{data.frame} met gegevens.
#' @param row.names Standaard is \code{FALSE}. Weer te geven rijnamen.
#' @param column.names Standaard is \code{colnames(tabel)}. Weer te geven kolomnamen.
#' @param align Standaard is \code{NULL}, waardoor kolommen met getallen rechts worden uitgelijnd en andere kolommen links worden uitgelijnd.
#' @param padding Standaard is \code{2}. Extra ruimte in de cellen.
#' @param caption Standaard is \code{""}. Bijschrift bij de tabel.
#' @param na Standaard is \code{""}. Tekst voor ontbrekende waarden.
#' @param format.tbl Standaard is \code{"markdown"}. Geldige opties zijn \code{"latex"}, \code{"html"}, \code{"markdown"}, \code{"pandoc"} en \code{"rst"}.
#' @param format.dates Standaard is \code{"dd-mm-yyyy"}. Zie \code{\link{format2}}.
#' @param format.NL Standaard is \code{Sys.isdecimalcomma()}, zie \code{\link{Sys.isdecimalcomma}}. Hiermee worden getallen met een komma als decimaal teken weergegeven.
#' @param columns.percent Standaard is \code{NA}. De kolomindices weergeven als percentage met \code{\link{format2}}. Voorbeeld: \code{columns.percent = c(2, 3)}. Makkelijk is om deze kolommen vooraf te transformeren met \code{\link{as.percent}}, zo blijven de bronwaarden namelijk gelijk.
#' @param columns.bold Standaard is \code{TRUE}. Kolomnamen vet weergeven.
#' @param round.numbers Standaard is \code{2}. Aantal decimalen om op af te ronden bij getallen.
#' @param round.percent Standaard is \code{1}. Aantal decimalen om op af te ronden wanneer \code{columns.percent} gebruikt wordt.
#' @param newlines.leading Standaard is \code{2}. Aantal witregels om te printen \strong{voor} de tabel.
#' @param newlines.trailing Standaard is \code{2}. Aantal witregels om te printen \strong{na} de tabel.
#' @details Wanneer in een R Markdown-rapport een tabel met deze functie voorafgegaan wordt door een ander object (zoals een grafiek), printen de kolomkoppen alleen goed wanneer \code{newlines.leading} >= 2, of door handmatig gebruik van \code{cat("\\n\\n")} alvorens de tabel te printen.
#' @keywords tabel knitr kable
#' @seealso \code{\link[knitr]{kable}}
#' @return Tekst
#' @export
tbl_markdown <- function(tbl,
row.names = FALSE,
column.names = colnames(tbl),
align = NULL,
padding = 2,
caption = '',
na = '',
format.tbl = 'markdown',
format.dates = 'dd-mm-yyyy',
format.NL = Sys.isdecimalcomma(),
columns.percent = NA,
columns.bold = TRUE,
round.numbers = 2,
round.percent = 1,
newlines.leading = 2,
newlines.trailing = 2) {
tbl <- as.data.frame(tbl)
tblnaam <- deparse(substitute(tbl))
if (caption == '') {
caption <- NULL
}
if (columns.bold == TRUE) {
column.names <- paste0('**', column.names, '**')
}
if (is.null(ncol(tbl))) {
kolommenaantal <- 1
} else {
kolommenaantal <- ncol(tbl)
}
for (i in 1:kolommenaantal) {
if (class(tbl[1, i])[1] %in% c('Date', 'POSIXct', 'POSIXlt')) {
tbl[, i] <- tbl %>% pull(i) %>% format2(format = format.dates)
}
if (class(tbl[1, i])[1] %in% c('double', 'integer', 'numeric', 'single') &
!i %in% columns.percent) {
tbl[, i] <- tbl %>% pull(i) %>% format2(round = round.numbers, format.NL = format.NL)
}
if (i %in% columns.percent) {
tbl[, i] <- tbl %>% pull(i) %>% as.percent() %>% format2(round = round.percent, format.NL = format.NL)
}
}
opt.old <- options()$knitr.kable.NA
options(knitr.kable.NA = na)
cat(rep('\n', newlines.leading) %>% concat())
print(
knitr::kable(
tbl,
table.attr = paste0('id="', tblnaam, '"'),
col.names = column.names,
row.names = row.names,
align = align,
format = format.tbl,
padding = padding,
caption = caption
)
)
cat(rep('\n', newlines.trailing) %>% concat())
options(knitr.kable.NA = opt.old)
}
#' Verwijderen van privacygevoelige kolommen
#'
#' Verwijdert de volgende kolommen uit een dataframe: \code{geslachtsnaam}, \code{naam}, \code{achternaam}, \code{geboortedatum}, \code{postcode}, \code{plaats}, \code{woonplaats}, \code{provincie}, en \code{"lastname"}, \code{"name"}, \code{"dob"}, \code{"birthdate"} en \code{"city"}.
#' @param tbl Dataframe met gegevens.
#' @keywords anonymise anoniem
#' @export
#' @return data.frame
#' @examples
#' \dontrun{
#' tbl <- tbl_anonymise(tbl)
#' }
tbl_anonymise <- function(tbl) {
verwijderen <- c(
"geslachtsnaam",
"naam",
"achternaam",
"geboortedatum",
"postcode",
"plaats",
"woonplaats",
"provincie",
"lastname",
"name",
"dob",
"birthdate",
"city"
)
tbl[, !(tolower(colnames(tbl)) %in% verwijderen)]
}
#' Kleurnaam van RGB-code of HTML-code
#'
#' Print een kleurnaam van een RGB-code of HTML-code.
#' @rdname colour.name
#' @param htmlcode Een tekst zoals \code{"#FFFFFF"}, of een formule die dit retourneert, zoals \code{rgb(1, 1, 1)}.
#' @keywords kleur
#' @return Tekst
#' @export
colour.name <- function(htmlcode) {
kleurtabel <- structure(list(
rgb = c("#000000", "#FF0000", "#00FF00", "#0000FF",
"#FF00FF", "#FFFF00", "#00FFFF", "#FFFFFF", "#C0C0C0", "#800000",
"#008000", "#000080", "#800080", "#808000", "#008080", "#808080",
"#CD5C5C", "#F08080", "#FA8072", "#E9967A", "#FF4500", "#FF0000",
"#DC143C", "#B22222", "#8B0000", "#FFC0CB", "#FFB6C1", "#DB7093",
"#FF69B4", "#FF1493", "#C71585", "#FFFFE0", "#FFFACD", "#FAFAD2",
"#FFEFD5", "#FFE4B5", "#FFDAB9", "#EEE8AA", "#F0E68C", "#FFFF00",
"#FFD700", "#BDB76B", "#E0FFFF", "#AFEEEE", "#00FFFF", "#7FFFD4",
"#40E0D0", "#48D1CC", "#00CED1", "#B0E0E6", "#B0C4DE", "#ADD8E6",
"#87CEEB", "#87CEFA", "#00BFFF", "#6495ED", "#4682B4", "#5F9EA0",
"#7B68EE", "#1E90FF", "#4169E1", "#0000FF", "#0000CD", "#00008B",
"#000080", "#191970", "#FFA07A", "#FFA500", "#FF8C00", "#FF7F50",
"#FF6347", "#FF4500", "#ADFF2F", "#7FFF00", "#7CFC00", "#00FF00",
"#98FB98", "#90EE90", "#00FA9A", "#00FF7F", "#9ACD32", "#32CD32",
"#3CB371", "#2E8B57", "#228B22", "#008000", "#6B8E23", "#808000",
"#556B2F", "#006400", "#7FFFD4", "#66CDAA", "#8FBC8F", "#20B2AA",
"#008B8B", "#008080", "#E6E6FA", "#D8BFD8", "#DDA0DD", "#EE82EE",
"#FF00FF", "#DA70D6", "#BA55D3", "#9370DB", "#6A5ACD", "#8A2BE2",
"#9400D3", "#9932CC", "#663399", "#8B008B", "#800080", "#483D8B",
"#4B0082", "#FFF8DC", "#FFEBCD", "#FFE4C4", "#FFDEAD", "#F5DEB3",
"#DEB887", "#D2B48C", "#BC8F8F", "#F4A460", "#DAA520", "#B8860B",
"#CD853F", "#D2691E", "#8B4513", "#A0522D", "#A52A2A", "#800000",
"#FFFFFF", "#FFFAFA", "#F0FFF0", "#F5FFFA", "#F0FFFF", "#F0F8FF",
"#F8F8FF", "#F5F5F5", "#FFF5EE", "#F5F5DC", "#FDF5E6", "#FFFAF0",
"#FFFFF0", "#FAEBD7", "#FAF0E6", "#FFF0F5", "#FFE4E1", "#DCDCDC",
"#D3D3D3", "#C0C0C0", "#A9A9A9", "#808080", "#696969", "#778899",
"#708090", "#2F4F4F", "#000000"),
r = c(0L, 255L, 0L, 0L, 255L,
255L, 0L, 255L, 192L, 128L, 0L, 0L, 128L, 128L, 0L, 128L, 205L,
240L, 250L, 233L, 255L, 255L, 220L, 178L, 139L, 255L, 255L, 219L,
255L, 255L, 199L, 255L, 255L, 250L, 255L, 255L, 255L, 238L, 240L,
255L, 255L, 189L, 224L, 175L, 0L, 127L, 64L, 72L, 0L, 176L, 176L,
173L, 135L, 135L, 0L, 100L, 70L, 95L, 123L, 30L, 65L, 0L, 0L,
0L, 0L, 25L, 255L, 255L, 255L, 255L, 255L, 255L, 173L, 127L,
124L, 0L, 152L, 144L, 0L, 0L, 154L, 50L, 60L, 46L, 34L, 0L, 107L,
128L, 85L, 0L, 127L, 102L, 143L, 32L, 0L, 0L, 230L, 216L, 221L,
238L, 255L, 218L, 186L, 147L, 106L, 138L, 148L, 153L, 102L, 139L,
128L, 72L, 75L, 255L, 255L, 255L, 255L, 245L, 222L, 210L, 188L,
244L, 218L, 184L, 205L, 210L, 139L, 160L, 165L, 128L, 255L, 255L,
240L, 245L, 240L, 240L, 248L, 245L, 255L, 245L, 253L, 255L, 255L,
250L, 250L, 255L, 255L, 220L, 211L, 192L, 169L, 128L, 105L, 119L,
112L, 47L, 0L),
g = c(0L, 0L, 255L, 0L, 0L, 255L, 255L, 255L,
192L, 0L, 128L, 0L, 0L, 128L, 128L, 128L, 92L, 128L, 128L, 150L,
69L, 0L, 20L, 34L, 0L, 192L, 182L, 112L, 105L, 20L, 21L, 255L,
250L, 250L, 239L, 228L, 218L, 232L, 230L, 255L, 215L, 183L, 255L,
238L, 255L, 255L, 224L, 209L, 206L, 224L, 196L, 216L, 206L, 206L,
191L, 149L, 130L, 158L, 104L, 144L, 105L, 0L, 0L, 0L, 0L, 25L,
160L, 165L, 140L, 127L, 99L, 69L, 255L, 255L, 252L, 255L, 251L,
238L, 250L, 255L, 205L, 205L, 179L, 139L, 139L, 128L, 142L, 128L,
107L, 100L, 255L, 205L, 188L, 178L, 139L, 128L, 230L, 191L, 160L,
130L, 0L, 112L, 85L, 112L, 90L, 43L, 0L, 50L, 51L, 0L, 0L, 61L,
0L, 248L, 235L, 228L, 222L, 222L, 184L, 180L, 143L, 164L, 165L,
134L, 133L, 105L, 69L, 82L, 42L, 0L, 255L, 250L, 255L, 255L,
255L, 248L, 248L, 245L, 245L, 245L, 245L, 250L, 255L, 235L, 240L,
240L, 228L, 220L, 211L, 192L, 169L, 128L, 105L, 136L, 128L, 79L,
0L),
b = c(0L, 0L, 0L, 255L, 255L, 0L, 255L, 255L, 192L, 0L,
0L, 128L, 128L, 0L, 128L, 128L, 92L, 128L, 114L, 122L, 0L, 0L,
60L, 34L, 0L, 203L, 193L, 147L, 180L, 147L, 133L, 224L, 205L,
210L, 213L, 181L, 185L, 170L, 140L, 0L, 0L, 107L, 255L, 238L,
255L, 212L, 208L, 204L, 209L, 230L, 222L, 230L, 235L, 250L, 255L,
237L, 180L, 160L, 238L, 255L, 225L, 255L, 205L, 139L, 128L, 112L,
122L, 0L, 0L, 80L, 71L, 0L, 47L, 0L, 0L, 0L, 152L, 144L, 154L,
127L, 50L, 50L, 113L, 87L, 34L, 0L, 35L, 0L, 47L, 0L, 212L, 170L,
143L, 170L, 139L, 128L, 250L, 216L, 221L, 238L, 255L, 214L, 211L,
219L, 205L, 226L, 211L, 204L, 153L, 139L, 128L, 139L, 130L, 220L,
205L, 196L, 173L, 179L, 135L, 140L, 143L, 96L, 32L, 11L, 63L,
30L, 19L, 45L, 42L, 0L, 255L, 250L, 240L, 250L, 255L, 255L, 255L,
245L, 238L, 220L, 230L, 240L, 240L, 215L, 230L, 245L, 225L, 220L,
211L, 192L, 169L, 128L, 105L, 153L, 144L, 79L, 0L),
colour.name = c("zwart", "rood", "groen",
"blauw", "magenta", "geel", "cyaan", "wit", "zilver", "kastanjebruin",
"groen", "marine", "purper", "olijfgroen", "groenblauw", "grijs",
"indisch rood", "lichtkoraal", "zalm", "donkerzalm", "oranjerood",
"rood", "rood", "rood", "donkerrood", "roze",
"lichtroze", "bleekvioletrood", "acaciaroze", "dieproze", "midvioletrood",
"lichtgeel", "lichtgeel", "lichtgoudgeel", "lichtperzik",
"perzik", "perzik", "bleekgoud", "geelbruin", "geel", "goud",
"donkergeelbruin", "lichtcyaan", "lichtturkoois", "cyaan", "aquamarijn",
"turkoois", "midturkoois", "donkerturkoois", "poederblauw",
"staalblauw", "lichtblauw", "hemelsblauw", "lichthemelsblauw",
"diephemelsblauw", "korenbloemblauw", "donkerstaalblauw", "kadetblauw",
"midgrijsblauw", "helderblauw", "koningsblauw", "blauw", "midblauw",
"donkerblauw", "marine", "midnachtsblauw", "lichtzalm", "oranje",
"donkeroranje", "koraal", "tomaat", "oranjerood", "groengeel",
"groengeel", "grasgroen", "limoen", "bleekgroen", "lichtgroen",
"midlentegroen", "lentegroen", "geelgroen", "limoengroen", "midzeegroen",
"zeegroen", "bosgroen", "groen", "olijf", "olijfgroen", "donkerolijfgroen",
"donkergroen", "aquamarijn", "midaquamarine", "donkerzeegroen",
"lichtzeegroen", "donkercyaan", "groenblauw", "lavendel", "lavendel",
"pruim", "violet", "magenta", "orchidee", "midorchidee",
"midpaars", "leiblauw", "blauwviolet", "donkerviolet", "donkerorchidee",
"blauwpaars", "donkermagenta", "purper", "donkerleiblauw",
"indigo", "witroze", "witroze", "witroze", "navajowit",
"tarwe", "bruinroze", "bruinroze", "paarsbrown", "zandbruin", "goud",
"donkergoud", "peru", "chocoladebruin", "bruin", "bruin",
"bruin", "kastanjebruin", "wit", "sneeuwwit", "witgrijs", "mint",
"helderblauw", "witblauw", "wit", "rookwit", "schelp",
"beige", "kant", "fluweelwit", "ivoor", "antiekwit", "linnen",
"witroze", "witroze", "grijswit", "lichtgrijs", "zilver",
"donkergrijs", "grijs", "grijs", "lichtleigrijs", "leigrijs",
"donkerleigrijs", "zwart")),
class = c("tbl_df", "tbl", "data.frame"),
row.names = c(NA, -157L),
.Names = c("rgb", "r", "g", "b", "kleurnaam"))
dichtste <- function(getal, precisie) {
lijst <- seq(0, 255, by = precisie)
getal.nieuw <- getal
for (n in 1:length(getal)) {
getal.nieuw[n] <- lijst[which.min(abs(lijst - getal[n]))]
}
getal.nieuw
}
for (k in 1:length(htmlcode)) {
if (htmlcode[k] == colourpicker('certeblauw')) {
htmlcode[k] <- 'certeblauw'
next
}
if (htmlcode[k] == colourpicker('certegroen')) {
htmlcode[k] <- 'certegroen'
next
}
if (htmlcode[k] == colourpicker('certeroze')) {
htmlcode[k] <- 'certeroze'
next
}
if (htmlcode[k] == colourpicker('certegeel')) {
htmlcode[k] <- 'certegeel'
next
}
if (htmlcode[k] == colourpicker('certelila')) {
htmlcode[k] <- 'certelila'
next
}
if (htmlcode[k] == colourpicker('certezachtlila')) {
htmlcode[k] <- 'certezachtlila'
next
}
kleuren <- col2rgb(htmlcode[k])
zoek.rood <- kleuren[1]
zoek.groen <- kleuren[2]
zoek.blauw <- kleuren[3]
for (i in seq(10, 100, by = 10)) {
html.rood <- dichtste(zoek.rood, i)
html.groen <- dichtste(zoek.groen, i)
html.blauw <- dichtste(zoek.blauw, i)
kleurtabel$rood <- dichtste(kleurtabel$r, i)
kleurtabel$groen <- dichtste(kleurtabel$g, i)
kleurtabel$blauw <- dichtste(kleurtabel$b, i)
resultaat <- kleurtabel %>% filter(rood == html.rood,
groen == html.groen,
blauw == html.blauw)
if (nrow(resultaat) > 0) {
htmlcode[k] <- resultaat$kleurnaam[length(resultaat$kleurnaam)]
break
}
}
if (!grepl('#', htmlcode[k], fixed = TRUE)) {
next
}
htmlcode[k] <- ''
if (zoek.rood > zoek.groen & zoek.rood > zoek.blauw) {
htmlcode[k] <- 'roodachtig'
}
if (zoek.groen > zoek.rood & zoek.groen > zoek.blauw) {
htmlcode[k] <- 'groenachtig'
}
if (zoek.blauw > zoek.rood & zoek.blauw > zoek.groen) {
htmlcode[k] <- 'blauwachtig'
}
}
htmlcode
}
#' @rdname colour.name
#' @export
color.name <- function(htmlcode) {
colour.name(htmlcode = htmlcode)
}
#' Draaien van tabel (pivoteren)
#'
#' Hiermee wordt een tabel gepivoteerd, d.w.z. een kwartslag gedraaid.
#' @param tbl Tabel die gepivoteerd moet worden
#' @param col.prefix Standaard is \code{"Kolom"}. Prefix van de nieuwe kolomnamen: Kolom1, Kolom2, enz.
#' @param firstcol.as.header Standaard is \code{FALSE}. De eerste kolom als kolomkoppen gebruiken. Met \code{TRUE} wordt eerst een kolom toegevoegd en wordt daarna pas gepivoteerd, zodat deze nieuwe kolom als kolomkoppen gebruikt wordt.
#' @export
#' @examples
#' \dontrun{
#' tbl %>%
#' group_by(ziekenhuis) %>%
#' summarise(amox = rsi(amox),
#' cipr = rsi(cipr)) %>%
#' pivot()
#' }
pivot <- function(tbl, col.prefix = 'Kolom', firstcol.as.header = FALSE) {
col.list <- paste0('Kolom', 1:nrow(tbl))
tbl <- tbl %>% as.data.frame()
if (firstcol.as.header == FALSE) {
tbl <- tbl %>% tibble::add_column(col.list, .before = 1)
} else if (n_distinct(tbl[, 1] < nrow(tbl))) {
stop('All values in first column must be unique to use it as header.')
}
tbl.pivot <- data.frame(col1.name = colnames(tbl)[2:ncol(tbl)])
colnames(tbl.pivot)[1] <- paste0(col.prefix, 0) # col.list[1]
# kolommen toevoegen
for (i in 1:nrow(tbl)) {
tbl.pivot <- tibble::add_column(tbl.pivot,
nieuwecol = tbl[i, 2:ncol(tbl)] %>% as.character())
colnames(tbl.pivot)[i + 1] <- tbl[i, 1] %>% as.character()
}
# kolomtypen gokken met readr
for (i in 1:ncol(tbl.pivot)) {
tbl.pivot[, i] <- readr::parse_guess(tbl.pivot[, i])
}
tbl.pivot %>% tibble::as.tibble()
}
#' Getallen octaal of hexadecimaal weergeven
#'
#' @param x Waarde(n).
#' @param from.base Standaard is \code{10} (decimaal). Grondtal van berekeningen; 8, 10 of 16.
#' @param to.base Grondtal van berekeningen; 8, 10 of 16.
#' @export
as.basenumber <- function(x, from.base = 10, to.base) {
if (from.base != 10) {
if (from.base == 8) {
class(x) <- 'octmode'
} else if (from.base == 16) {
class(x) <- 'hexmode'
} else {
stop('Invalid `from.base` - must be 8, 10 or 16.')
}
x <- x %>% as.integer()
}
if (to.base == 10) {
return(x)
} else if (to.base == 8) {
return(x %>% as.octmode())
} else if (to.base == 16) {
return(x %>% as.hexmode())
} else {
stop('Invalid `to.base` - must be 8, 10 or 16.')
}
}
#' Splits tekst en selecteer element
#' @inheritParams base::strsplit
#' @param element The nth element that should be returned.
#' @seealso \code{\link[base]{strsplit}}
#' @export strsplit.select
#' @examples
#' \dontrun{
#' tbl %>%
#' mutate(genus = strsplit.select(microorganisme, 1),
#' species = strsplit.select(microorganisme, 2))
#' }
strsplit.select <- function(x, element, split = " ", fixed = FALSE, perl = FALSE, useBytes = FALSE) {
sapply(strsplit(x,
split,
fixed = fixed,
perl = perl,
useBytes = useBytes
),
"[",
element)
}
classCaption <- function(obj, title_and_lvls = TRUE, sep = '->') {
classes <- obj %>% class()
c <- paste0(classes %>% rev() %>% concat(sep))
c <- gsub(paste0('factor', sep, 'ordered'), 'ord.factor', c)
if (title_and_lvls == TRUE) {
if (!is.null(levels(obj))) {
c <- paste0(c, ', with ', length(levels(obj)), ' levels')
}
if ('mic' %in% classes) {
c <- paste0('MIC values (', c, ')')
} else if ('rsi' %in% classes) {
c <- paste0('AB interpretations (', c, ')')
} else if ('tbl_df' %in% classes) {
if ('grouped_df' %in% classes) {
c <- paste0('grouped tibble (', c, ')')
} else {
c <- paste0('tibble (', c, ')')
}
} else if ('data.table' %in% classes) {
c <- paste0('DT (', c, ')')
} else if ('ggplot' %in% classes) {
if ('certedata_plot2' %in% classes) {
c <- paste0('certedata plot (', c, ')')
} else {
c <- paste0('ggplot2 plot (', c, ')')
}
} else if ('ggproto' %in% classes) {
c <- paste0('ggplot2 environment (', c, ')')
}
}
c
}
msberends/certedata documentation built on Nov. 26, 2019, 5:19 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions colourpicker
Documented in colourpicker
# ==================================================================== #
# TITLE #
# Tools for Data Analysis at Certe #
# #
# AUTHORS #
# Berends MS (m.berends@certe.nl) #
# Meijer BC (b.meijer@certe.nl) #
# Hassing EEA (e.hassing@certe.nl) #
# #
# COPYRIGHT #
# (c) 2019 Certe Medische diagnostiek & advies - https://www.certe.nl #
# #
# LICENCE #
# This R package is free software; you can redistribute it and/or #
# modify it under the terms of the GNU General Public License #
# version 2.0, as published by the Free Software Foundation. #
# This R package 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. #
# ==================================================================== #
#' Kleuren uit de huisstijl van Certe en meer
#'
#' Hiermee kunnen alle Certe-kleuren gebruikt worden, maar daarnaast ook de huisstijl van de RuG, het kleurenblindheid-veilige \code{viridis} en nog 6 andere continue kleurenpaletten. Druk op F1 voor een voorbeeldplaatje van alle beschikbare kleuren.
#' @rdname colourpicker
#' @param x Kleur. Moet een geldige kleur zijn uit \code{\link{colors}} (zoals \code{"black"}, \code{"red"}), een HTML-code (zoals \code{"#ffffaa"}, \code{"#ffa"}), een lege waarde (\code{NA} of \code{NULL}), of: \cr \cr
#' \code{"certe"} \cr Huisstijlkleuren van \href{http://www.certe.nl}{Certe}. Deze kleuren kunnen ook als input gebruikt worden: \code{"certeblauw"}, \code{"certegroen"}, \code{"certeroze"}, \code{"certegeel"}, \code{"certelila"}, \code{"certezachtlila"}, \code{"certeblauw2"}, \code{"certegroen2"}, \code{"certeroze2"}, \code{"certegeel2"}, \code{"certelila2"}, \code{"certezachtlila2"}, \code{"certeblauw3"}, \code{"certegroen3"}, \code{"certeroze3"}, \code{"certegeel3"}, \code{"certelila3"} en \code{"certezachtlila3"}. De rest wordt aangevuld met grijswaarden. Gebruik \code{"certe2"} of \code{"certe3"} om direct de zachtere tinten te gebruiken. \cr \cr
#' \code{"certe_rsi"} \cr De kleuren \code{"certeroze"}, \code{"certegeel"} en \code{"certegroen"}. \cr \cr
#' \code{"certe_rsi2"} \cr De kleuren \code{"certeroze2"}, \code{"certegeel2"} en \code{"certegroen2"}. \cr \cr
#' \code{"izore"} \cr Huisstijlkleuren van \href{http://www.izore.nl}{Izore}. Deze kleuren kunnen ook als input gebruikt worden: \code{"izorerood"}, \code{"izoregrijs"}. \cr \cr
#' \code{"rsi"} \cr De kleuren van het palet \code{"RdYlGn"}; pastelkleuren van rood, geel en groen. \cr \cr
#' \code{"rug"} of \code{"ug"} \cr Huisstijlkleuren van de \href{http://www.rug.nl}{Rijkuniversiteit Groningen}. Deze kleuren kunnen ook als input gebruikt worden: \code{"rugrood"}, \code{"rugblauw"}, \code{"rugpaars"}, \code{"rugdonkerblauw"}, \code{"ruggroen"}, \code{"rugbordeauxrood"}, \code{"ruggrijs"}, \code{"ruggoud"} en \code{"rugzilver"}. De rest wordt aangevuld met grijswaarden. \cr \cr
#' \code{"viridis"} \cr Kleurenblindheid-veilig, zie verderop en \code{\link[viridisLite]{viridis}}. \cr \cr
#' \code{"R"}, \code{"rainbow"} of \code{"regenboog"} \cr Standaardkleuren van R, zie \code{\link{rainbow}} \cr \cr
#' \code{"heat"}, \code{"heatmap"} of \code{"hitte"} \cr Zie \code{\link{heat.colors}} \cr \cr
#' \code{"terrain"} of \code{"terrein"} \cr Zie \code{\link{terrain.colors}} \cr \cr
#' \code{"topo"} of \code{"geo"} \cr Zie \code{\link{topo.colors}} \cr \cr
#' \code{"prev"} of \code{"prevalentie"} \cr \cr
#' \code{"grijs"}, \code{"grijswaarden"}, \code{"greyscale"} of \code{"grayscale"} \cr \cr
#' \code{"colourbrewer"} of \code{"colorbrewer"} \cr Gebaseerd op de 4 meest divergerende kleuren die kleurenblindveilig, printvriendelijk en kopieerveilig zijn volgens \emph{ColorBrewer} (die advies biedt voor cartografie): oranje, gelig, licht- en donkerblauw. Zie \href{http://colorbrewer2.org/#type=diverging&scheme=PuOr&n=4}{deze pagina van ColorBrewer 2.0}. \cr \cr
#' \code{"ggplot"} \cr Kleuren die in de eerste versie van ggplot gebruikt werden als \code{Set1}. \cr \cr
#' \code{"ggplot2"} \cr Kleuren die in ggplot2 gebruikt worden als \code{Set2}. \cr \cr
#' @param length Standaard is \code{1}. Aantal kleuren dat geretourneerd moet worden.
#' @param opacity Standaard is \code{0}. Transparantie, een waarde tussen 0-1.
#' @details
#' \if{html}{
#'
#' \out{<div style="text-align: center">}\figure{palette.png}{options: style="width:925px;max-width:95\%;"}\out{</div>}
#'
#' }
#' \if{latex}{
#'
#' \out{\begin{center}}\figure{palette.png}\out{\end{center}}
#' }
#'
#' About \href{https://CRAN.R-project.org/package=viridis/vignettes/intro-to-viridis.html#introduction}{viridis}:
#'
#' These colour scales are designed to be:
#' \itemize{
#' \item \strong{Colourful}, spanning as wide a palette as possible so as to make differences easy to see,
#' \item \strong{Perceptually uniform}, meaning that values close to each other have similar-appearing colours and values far away from each other have more different-appearing colors, consistently across the range of values,
#' \item \strong{Robust to colourblindness}, so that the above properties hold true for people with common forms of colourblindness, as well as in grey scale printing.
#' }
#' @keywords kleur aantal tint palette
#' @return RGB-kleur(en) in HTML-tekst, zoals \code{"#849A42"} voor \code{x = "certegroen"}.
#' @export
#' @examples
#' colourpicker("certegroen")
#'
#' # spectra uitproberen:
#' tibble(x = c(1:500), y = 1) %>%
#' ggplot(aes(x, y)) +
#' theme(
#' panel.grid.minor.x = element_blank(),
#' panel.grid.major.x = element_blank(),
#' panel.grid.minor.y = element_blank(),
#' panel.grid.major.y = element_blank()
#' ) +
#' geom_col(
#' width = 1,
#' fill = colourpicker("heat", length = 500))
#'
#' \dontrun{
#'
#' ..., col = colourpicker("certeblauw", nrow(tbl)), ...
#' }
colourpicker <- function(x, length = 1, opacity = 0) {
# ondersteuning voor 100% doorzichtige kleur bij NA en NULL
x[is.null(x)] <- '#XXXXXX'
x[is.na(x)] <- '#XXXXXX'
x[x == 'ug'] <- 'rug'
colours.brewers <- c('certe',
'certe2',
'certe_rsi',
'certe_rsi2',
'izore',
'rsi',
'rug',
'viridis',
'r',
'R',
'rainbow',
'regenboog',
'heat',
'heatmap',
'hitte',
'terrain',
'terrein',
'topo',
'geo',
'prev',
'prevalentie',
'colourbrewer',
'colorbrewer',
'grijs',
'grijswaarden',
'greyscale',
'grayscale',
'ggplot',
'ggplot2')
if (x[1] == 'viridis') {
colour.list <- viridis::viridis(length)
} else if (x[1] %in% c('r', 'R', 'rainbow', 'regenboog')) {
colour.list <- rainbow(length)
} else if (x[1] %in% c('heat', 'heatmap', 'hitte')) {
colour.list <- heat.colors(length)
} else if (x[1] %in% c('terrain', 'terrein')) {
colour.list <- terrain.colors(length)
} else if (x[1] %in% c('topo', 'geo')) {
colour.list <- topo.colors(length)
} else if (x[1] %in% c('prev', 'prevalentie')) {
colour.list <- colorRampPalette(c(
rgb(140, 255, 140, maxColorValue = 255), # lichtgroen
rgb(40, 220, 40, maxColorValue = 255), # groen
rgb(220, 110, 20, maxColorValue = 255), # oranje
rgb(170, 0, 0, maxColorValue = 255)) # donkerrood
)(length)
} else if (x[1] %in% c('colourbrewer', 'colorbrewer')) {
# http://colorbrewer2.org/#type=diverging&scheme=PuOr&n=4
colour.list <- colorRampPalette(c(
rgb(230, 97, 1, maxColorValue = 255),
rgb(253, 184, 99, maxColorValue = 255),
rgb(178, 171, 210, maxColorValue = 255),
rgb(94, 60, 153, maxColorValue = 255))
)(length)
} else if (x[1] == 'certe_rsi') {
colour.list <- colorRampPalette(c(
colourpicker("certeroze"),
colourpicker("certegeel"),
colourpicker("certegroen"))
)(length)
} else if (x[1] == 'certe_rsi2') {
colour.list <- colorRampPalette(c(
colourpicker("certeroze2"),
colourpicker("certegeel2"),
colourpicker("certegroen2"))
)(length)
} else if (x[1] == 'rsi') {
# van het palet "RdYlGn"
colour.list <- colorRampPalette(
RColorBrewer::brewer.pal(n = 3, name = "RdYlGn")
)(length)
} else if (x[1] %in% c('grijs', 'grijswaarden', 'greyscale', 'grayscale')) {
colour.list <- gray.colors(length)
} else if (x[1] == 'ggplot') {
# herschreven van https://stackoverflow.com/a/8197703/4575331
colour.list <- grDevices::hcl(h = seq(from = 15, to = 375, length = length + 1),
l = 65,
c = 100)[1:length]
} else if (x[1] == 'ggplot2') {
if (length > 8) {
stop("The `ggplot2` 'Set2' palette only supports up to 8 different colours.")
}
colour.list <- c("#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3",
"#A6D854", "#FFD92F", "#E5C494", "#B3B3B3")
colour.list <- colour.list[1:length]
} else {
colour.list <- c(
certeblauw = rgb(1, 97, 126, maxColorValue = 255),
certegroen = rgb(139, 153, 52, maxColorValue = 255),
certeroze = rgb(224, 72, 131, maxColorValue = 255),
certegeel = rgb(255, 228, 0, maxColorValue = 255),
certelila = rgb(171, 121, 179, maxColorValue = 255),
certezachtlila = rgb(214, 182, 214, maxColorValue = 255),
certeblauw2 = rgb(66, 151, 182, maxColorValue = 255),
certegroen2 = rgb(186, 203, 133, maxColorValue = 255),
certeroze2 = rgb(240, 151, 187, maxColorValue = 255),
certegeel2 = rgb(255, 245, 162, maxColorValue = 255),
certelila2 = rgb(203, 174, 208, maxColorValue = 255),
certezachtlila2 = rgb(230, 210, 230, maxColorValue = 255),
certeblauw3 = rgb(236, 242, 246, maxColorValue = 255),
certegroen3 = rgb(241, 242, 236, maxColorValue = 255),
certeroze3 = rgb(244, 234, 238, maxColorValue = 255),
certegeel3 = rgb(255, 251, 208, maxColorValue = 255),
certelila3 = rgb(230, 210, 230, maxColorValue = 255),
certezachtlila3 = rgb(238, 225, 238, maxColorValue = 255),
izorerood = rgb(199, 66, 49, maxColorValue = 255),
izoregrijs = rgb(205, 205, 205, maxColorValue = 255),
rugrood = rgb(204, 0, 0, maxColorValue = 255),
rugblauw = rgb(0, 156, 239, maxColorValue = 255),
rugpaars = rgb(119, 45, 107, maxColorValue = 255),
rugdonkerblauw = rgb(45, 0, 142, maxColorValue = 255),
ruggroen = rgb(0, 153, 119, maxColorValue = 255),
rugbordeauxrood = rgb(124, 33, 40, maxColorValue = 255),
ruggrijs = rgb(102, 109, 112, maxColorValue = 255),
ruggoud = rgb(132, 112, 64, maxColorValue = 255),
rugzilver = rgb(142, 142, 139, maxColorValue = 255)
)
}
if (x[1] %in% colours.brewers) {
if (x[1] %in% c('certe', 'certe2', 'certe3', 'izore', 'rug')) {
if (x[1] == 'certe2') {
colour.list <- colour.list[7:length(colour.list)]
} else if (x[1] == 'certe3') {
colour.list <- colour.list[13:length(colour.list)]
} else {
colour.list <- colour.list[which(colour.list %>%
names() %>%
grepl(
paste0(
'^',
x[1]),
.))]
}
# RuG helder blauw eruit als het lengte meer dan 3 is
if (length > 3) {
colour.list <- colour.list[which(colour.list %>% names() != 'rugblauw')]
}
if (length > length(colour.list)) {
# vult na alle voorgedefinieerde kleuren aan met grijstinten tussen 70-95% wit
x <- c(colour.list[1:length(colour.list)],
gray.colors(length - length(colour.list), start = 0.7, end = 0.95)) %>%
unname()
} else {
x <- colour.list[1:length] %>% unname()
}
} else {
x <- colour.list
}
} else {
# voor alle rest
for (i in 1:length(x)) {
if (x[i] %like% '^[0-F]{3}$' |
x[i] %like% '^[0-F]{6}$') {
x[i] <- paste0('#', x[i])
}
# ondersteuning voor #ffa -> #ffffaa
if (x[i] %like% '^#[0-F]{3}$') {
xi.bak <- x[i]
x[i] <- '#'
for (h in 2:4) {
x[i] <- paste0(x[i], rep((xi.bak %>% split.every.n(1))[h], 2) %>% concat())
}
}
if (!(x[i] %>% substr(1, 7)) %like% '^#[0-F]{6}$') {
if (x[i] %in% names(colour.list)) {
x[i] <- colour.list[x[i]]
} else if (!x[i] %in% colours() & !x[i] == '#XXXXXX') {
# geen geldige R-kleur
warning('Colour not found: ', x[i], ' - picking random grey between 25-75% black.', call. = FALSE)
# grey25 = rgb(64, 64, 64); grey75 = rgb(191, 191, 191)
col.random <- sample(c(64:191))[1]
x[i] <- rgb(
red = col.random,
green = col.random,
blue = col.random,
maxColorValue = 255
)
} else if (!x[i] == '#XXXXXX') {
rgb.list <- col2rgb(x[i])
x[i] <- rgb(
red = rgb.list[1],
green = rgb.list[2],
blue = rgb.list[3],
maxColorValue = 255
)
}
}
}
x <- x %>% rep(times = length)
}
# bij sommige kleurenspectra wordt FF als alpha toegevoegd; verwijderen
x[which(x %>% nchar() > 7)] <- x %>% substr(1, 7)
# is nu hexadecimaal; alpha erachter plakken
if (!missing(opacity)) {
x <- paste0(x,
((1 - opacity) * 255) %>%
round() %>%
as.hexmode() %>%
toupper() %>%
if_else(nchar(.) == 1,
paste0('0', .),
.))
}
# onsteuning voor 100% doorzichtige kleur bij NA en NULL
x[x == '#XXXXXX'] <- '#FFFFFF00'
x %>% unname()
}
#' @rdname colourpicker
#' @export
colorpicker <- function(x, length = 1, opacity = 0) {
colourpicker(x = x, length = length, opacity = opacity)
}
#' @exportMethod as.data.frame.percent
#' @export
#' @noRd
as.data.frame.percent <- function(x, ...) {
base::as.data.frame.numeric(x, ...)
}
#' Class 'percent'
#'
#' Dit is een nieuwe class voor procentuele weergave van de class \code{double}.
#' @param x Waarde.
#' @param ... Paramters die doorgegeven worden aan \code{\link{as.double}}.
#' @rdname percent
#' @return Nieuwe class \code{percent}
#' @export
as.percent <- function(x, ...) {
p <- x %>% as.double(x, ...)
class(p) <- c('percent', 'double')
p
}
#' @rdname percent
#' @export
is.percent <- function(x) {
identical(class(x), c('percent', 'double'))
}
#' @exportMethod as.character.percent
#' @export
#' @noRd
as.character.percent <- function(x, ...) {
x %>% format2.percent(format.NL = FALSE) %>% as.character.default(...)
}
#' @exportMethod print.percent
#' @export
#' @noRd
print.percent <- function(x, format.NL = FALSE, ...) {
print(paste0("`", format2.percent(x, format.NL = format.NL, round = 2), "`"), quote = FALSE)
}
#' @exportMethod summary.percent
#' @export
#' @noRd
summary.percent <- function(object, ...) {
x <- summary.default(object, ...)
y <- x %>% as.percent() %>% format()
names(y) <- names(x)
y
}
#' Nieuwe formaatweergave
#'
#' Formateer een \code{R} object voor mooie weergave.
#' @param x Waarde(n) die getransformeerd moet(en) worden.
#' @param round Aantal decimalen waarop afgerond moet worden.
#' @param force.decimals Forceren van decimale getallen, zelfs als het laatste decimale getal volgens \code{round} een 0 is.
#' @param format.NL Zie \code{\link{Sys.isdecimalcomma}}. Hiermee worden getallen met een komma als decimaal teken weergegeven.
#' @param non.scientific Met \code{TRUE} wordt een reguliere, niet-wetenschappelijke notatie geforceerd.
#' @param min.length De minimale lengte van de output. Dit overschrijft \code{force.decimals}.
#' @param format Formaat dat gebruikt moet worden. Ondersteunt leesbare formaten zoals \code{"d mmmm yyyy"} d.m.v. \code{\link{date_generic}}, maar ook UNIX zoals \code{"\%e \%B \%Y"}.
#' @exportMethod format2
#' @rdname format2
#' @details Zie voor ondersteunde tekst voor de parameter \code{format} voor datum en tijd: \code{\link{date_generic}}.
#' @export
format2 <- function(x,...) {
UseMethod("format2")
}
#' @exportMethod format2.default
#' @rdname format2
#' @export format2.default
format2.default <- function(x,
format = 'd mmmm yyyy',
percent = FALSE,
round = ifelse(percent, 1, 2),
force.decimals = ifelse(percent, TRUE, FALSE),
format.NL = Sys.isdecimalcomma(),
...) {
if (percent == TRUE) {
format2.percent(x,
round = round,
force.decimals = force.decimals,
format.NL = format.NL,
...)
} else {
if (identical(class(x), "NULL")) {
format(x, ...)
} else if (any(c('list', 'formula', 'expression', 'matrix') %in% class(x))) {
format(x, ...)
} else if (readr::guess_parser(x) == 'date') {
format2.Date(as.Date(x), format = format, ...)
} else if (all(is.double2(x))) {
format2.numeric(x,
round = round,
force.decimals = force.decimals,
format.NL = format.NL, ...)
} else {
format(x, digits = round, ...)
}
}
}
#' @exportMethod format2.percent
#' @rdname format2
#' @export format2.percent
format2.percent <- function(x,
round = 1,
force.decimals = TRUE,
format.NL = Sys.isdecimalcomma(),
...) {
if (length(x) == 0) {
return(character())
}
if (format.NL == TRUE) {
big.mark = "."
decimal.mark = ","
} else {
big.mark = ""
decimal.mark = "."
}
x <-
paste0(formatC(
round(x * 100, round),
big.mark = big.mark,
decimal.mark = decimal.mark,
digits = round,
format = 'f'
),
"%")
x <- gsub('NA%', NA, x, fixed = TRUE)
if (force.decimals == FALSE) {
# alle trailing zeroes verwijderen
x <- gsub(paste0(decimal.mark, '0+%'), '%', x, fixed = FALSE)
# 2,% = 2%
x <- gsub(paste0(decimal.mark, '%'), '%', x, fixed = TRUE)
}
x
}
#' @exportMethod format2.POSIXct
#' @rdname format2
#' @export format2.POSIXct
format2.POSIXct <- function(x, format = 'd mmmm yyyy', ...) {
if (any(class(x) == 'POSIXt')) {
# nu is het tijd, zoals Sys.time(), dat heeft als class: c("POSIXct", "POSIXt")
if (missing(format)) {
format2.POSIXt(x, ...)
} else {
format2.POSIXt(x, format, ...)
}
} else {
format2.Date(x, format, ...)
}
}
#' @exportMethod format2.POSIXlt
#' @rdname format2
#' @export format2.POSIXlt
format2.POSIXlt <- function(x, format = 'd mmmm yyyy', ...) {
format2.Date(x, format, ...)
}
#' @exportMethod format2.POSIXt
#' @rdname format2
#' @export format2.POSIXt
format2.POSIXt <- function(x, format = 'HH:MM:SS', ...) {
format2.Date(x, format, ...)
}
#' @exportMethod format2.hms
#' @rdname format2
#' @export format2.hms
format2.hms <- function(x,
format = 'HH:MM:SS',
round = 2,
force.decimals = FALSE,
format.NL = Sys.isdecimalcomma(),
...) {
if (is.double2(x)) {
format2.numeric(x,
round = round,
force.decimals = force.decimals,
percent = FALSE,
format.NL = format.NL,
...)
} else {
format2.Date(as.POSIXct(x), format = format, ...)
}
}
#' @exportMethod format2.difftime
#' @rdname format2
#' @export format2.difftime
format2.difftime <- function(x,
round = 2,
force.decimals = FALSE,
format.NL = Sys.isdecimalcomma(),
...) {
format2.numeric(x,
round = round,
force.decimals = force.decimals,
percent = FALSE,
format.NL = format.NL,
...)
}
#' @exportMethod format2.Date
#' @rdname format2
#' @export format2.Date
format2.Date <- function(x, format = 'd mmmm yyyy', ...) {
format <- date_generic(format)
# if (all(x %like% '^[0-9]+:[0-9]+')) {
# x <- paste('1970-01-01', x)
# }
if (any(x %>% class() %in% c('hms', 'difftime', 'POSIXlt'))) {
if (all(x %like% '^[0-9]+:[0-9]+')) {
x <- paste('1970-01-01', x)
}
df <- tibble(dat = as.POSIXlt(x), form = format(as.POSIXlt(x), format))
} else {
df <- tibble(dat = as.POSIXct(x), form = format(as.POSIXct(x), format))
}
# Voorloopspatie moet verwijderd worden
df$form <- trimws(df$form, 'left')
df$form <- gsub(' ', ' ', df$form, fixed = TRUE)
# kwartalen vervangen
if (any(grepl('%q', df %>% pull(form), fixed = TRUE))) {
for (i in 1:nrow(df)) {
kwartaal <- as.integer(sprintf("%02i", (as.POSIXlt(df[i, 'dat'] %>% pull())$mon) %/% 3L + 1L))
df[i, 'form'] <- gsub('%q', kwartaal, df[i, 'form'], fixed = TRUE)
}
}
if (format == 'unix') {
df$form %>% as.double()
} else {
df$form
}
}
#' @exportMethod format2.numeric
#' @rdname format2
#' @export format2.numeric
format2.numeric <- function(x,
round = ifelse(percent, 1, 2),
force.decimals = ifelse(percent, TRUE, FALSE),
non.scientific = FALSE,
format.NL = Sys.isdecimalcomma(),
min.length = 0,
percent = FALSE,
...) {
if (percent == TRUE) {
format2.percent(x = x,
round = round,
force.decimals = force.decimals,
format.NL = format.NL)
} else {
label_wetenschappelijk <- function(l) {
# bron: http://stackoverflow.com/a/24241954
# turn in to character string in scientific notation
l <- format(l, scientific = TRUE)
# quote the part before the exponent to keep all the digits
l <- gsub("^(.*)e", "'\\1'e", l)
# verwijder de + bij de exponent
l <- gsub("e+", "e", l, fixed = TRUE)
# afronden op ingestelde aantalen decimalen
#l <- gsub("^(.*)e", paste0('"', substr(l, 1, 2 + round), '"e'), l)
# turn the 'e+' into plotmath format
l <- gsub("e", "%*%10^", l)
# punt vervangen door komma
if (format.NL == TRUE) {
l <- gsub(".", ",", l, fixed = TRUE)
}
# return this as an expression
parse(text = l)
}
if (length(x) == 0) {
return(character())
}
if (format.NL == TRUE) {
big.mark = "."
decimal.mark = ","
} else {
big.mark = ""
decimal.mark = "."
}
if (min.length > 0) {
if (force.decimals == TRUE) {
warning('`force.decimals = TRUE` will be overwritten by `min.length = ', min.length, '`.')
}
# if (!(x %>% identical(x %>% as.integer()))) {
# warning('`force.decimals = TRUE` overwritten by `min.length = ', min.length, '`; transforming to real numbers.')
# }
x <- formatC(x %>% as.integer(),
width = min.length,
flag = "0")
} else {
if (force.decimals == TRUE) {
x <-
formatC(
round(as.double(x), digits = round),
digits = round,
big.mark = big.mark,
decimal.mark = decimal.mark,
format = 'f'
)
} else {
x <-
format(
round(as.double(x), round),
scientific = FALSE,
big.mark = big.mark,
decimal.mark = decimal.mark
)
}
}
x <- gsub('NA', NA, x, fixed = TRUE)
x <- gsub(' NA', NA, x, fixed = TRUE)
x <- trimws(x)
x
}
}
#' @exportMethod format.percent
#' @export
#' @noRd
format.percent <- function(x,
round = 2,
force.decimals = TRUE,
...) {
format2.percent(x, round, force.decimals, format.NL = FALSE, ...)
}
#' Datum-/tijd-formaat van Excel transformeren naar Unix-formaat
#'
#' Retourneert het formaat in Unix-vorm, bijv. \code{"d mmmm yyyy"} -> \code{"\%e \%B \%Y"}.
#' @param format Formaat om te transformeren, zoals \code{"d mmmm yyyy"}. Zie Details.
#' @details
#' De volgende formaten worden ondersteund: \cr
#' \cr \strong{Tijd:}
#' \cr
#' - \code{"H"} (0-23, geen voorloopnul) \cr
#' - \code{"HH"} (00-23, wel voorloopnul) \cr
#' - \code{"MM"} (00-59) \cr
#' - \code{"SS"} (00-59) \cr
#' \cr - Combinaties \cr
#' \code{"H:MM:SS"}: 9:12:01, enz. \cr
#' \code{"HH:MM:SS"}: 09:12:01, enz. \cr
#' \cr \strong{Dagen:}
#' \cr
#' - \code{"d"} (1-31, geen voorloopnul) \cr
#' - \code{"dd"} (01-31, wel voorloopnul) \cr
#' - \code{"ddd"} (ma-zo) \cr
#' - \code{"dddd"} (maandag-zondag) \cr
#' \cr - Combinaties \cr
#' \code{"dddd d mmmm"}: maandag 1 januari, dinsdag 2 januari, enz. \cr
#' \cr \strong{Weken:}
#' \cr
#' - \code{"w"} of \code{"ww"} (01-53) \cr
#' \cr - Combinaties \cr
#' \code{"yyyy-ww"}: 2018-01, 2018-02, enz. \cr
#' \code{"yyyy_iso-ww"}, bijv.: \code{format2("2017-01-01", "yyyy_iso-ww") = 2016-52}. \cr
#'
#' Volgens \href{https://nl.wikipedia.org/wiki/ISO_8601}{ISO 8601} (Nederland); dit weeknummer wijkt af van het Amerikaanse weeknummer. \cr
#' \cr \strong{Maanden:}
#' \cr
#' - \code{"mm"} (01-12) \cr
#' - \code{"mmm"} (jan-dec) \cr
#' - \code{"mmmm"} (januari-december) \cr
#' \cr - Combinaties \cr
#' \code{"mm (mmmm)"}: 01 (januari), 02 (februari), enz. \cr
#' \code{"mm-mmm"}: 01-jan, 02-feb, enz. \cr
#' \cr \strong{Kwartalen:}
#' \cr
#' - \code{"q"} of \code{"k"} (1-4) \cr
#' - \code{"qq"} of \code{"QQ"} (Q1-Q4) \cr
#' - \code{"kk"} of \code{"KK"} (K1-K4) \cr
#' \cr - Combinaties \cr
#' \code{"yyyy-qq"}: 2018-Q1, 2018-Q2, enz. \cr
#' \cr \strong{Jaren:}
#' \cr
#' - \code{"jj"} of \code{"yy"} (00-99) \cr
#' - \code{"jjjj"} of \code{"yyyy"} (1900-2099) \cr
#' - \code{"jj_iso"} of \code{"yy_iso"} (00-99) \cr
#' - \code{"jjjj_iso"} of \code{"yyyy_iso"} (1970-2099) \cr
#'
#' Volgens \href{https://nl.wikipedia.org/wiki/ISO_8601}{ISO 8601} (Nederland, bijv.: \code{format2("2017-01-01", "yyyy_iso") = 2016}). \cr
#' \cr \strong{Overig:}
#' \cr
#' \code{"iso"} datumformaat volgens \href{https://nl.wikipedia.org/wiki/ISO_8601}{ISO 8601}: yyyy-mm-dd \cr
#' \code{"unix"} aantal seconden sinds Epoch (1 jan 1970 0:00:00): een \emph{Unix Timestamp}
#' @keywords format formaat datum date
#' @export
#' @return Tekst
date_generic <- function(format) {
if (!grepl('%', format, fixed = TRUE)) {
# eerst maanden en minuten, daarna is alles hoofdletterONgevoelig
format <- gsub('mmmm', '%B1', format, fixed = TRUE)
format <- gsub('mmm', '%b', format, fixed = TRUE)
format <- gsub('mm', '%m', format, fixed = TRUE)
format <- gsub('MM', '%M1', format, fixed = TRUE)
format <- format %>%
tolower() %>%
gsub('%b1', '%B', ., fixed = TRUE) %>%
gsub('%m1', '%M', ., fixed = TRUE)
# datums
format <- gsub('dddd', '%A', format, fixed = TRUE)
format <- gsub('ddd', '%a', format, fixed = TRUE)
format <- gsub('dd', '%!', format, fixed = TRUE)
format <- gsub('d', '%e', format, fixed = TRUE)
format <- gsub('%!', '%d', format, fixed = TRUE)
format <- gsub('ww', '%V', format, fixed = TRUE)
format <- gsub('w', '%V', format, fixed = TRUE)
format <- gsub('qq', 'Qq', format, fixed = TRUE) # wordt hierna dus 'Q%%q'
format <- gsub('kk', 'Kq', format, fixed = TRUE)
format <- gsub('k', 'q', format, fixed = TRUE)
format <- gsub('q', '%%q', format, fixed = TRUE)
format <- gsub('yyyy_iso', '%G', format, fixed = TRUE)
format <- gsub('jjjj_iso', '%G', format, fixed = TRUE)
format <- gsub('yyyy', '%Y', format, fixed = TRUE)
format <- gsub('jjjj', '%Y', format, fixed = TRUE)
format <- gsub('yy_iso', '%g', format, fixed = TRUE)
format <- gsub('jj_iso', '%g', format, fixed = TRUE)
format <- gsub('yy', '%y', format, fixed = TRUE)
format <- gsub('jj', '%y', format, fixed = TRUE)
# tijd
format <- gsub('hh', '%H', format, fixed = TRUE)
format <- gsub('h', '%k', format, fixed = TRUE)
format <- gsub('ss', '%S', format, fixed = TRUE)
# Seconds since the Epoch, 1970-01-01 00:00:00
format <- gsub('unix', '%s', format, fixed = TRUE)
# Equivalent to %Y-%m-%d (the ISO 8601 date format)
format <- gsub('iso', '%F', format, fixed = TRUE)
}
format
}
#' Unmelt
#'
#' Doet het tegenovergestelde van \code{\link{melt}}.
#' @param x Tabel
#' @param id Standaard is de eerste kolom. De kolomnaam die blijft staan
#' @param variabele Standaard is de tweede kolom. De kolom waarvan de unieke waarden nieuwe kolommen worden
#' @export
unmelt <- function(x, id = colnames(x)[1], variables = colnames(x)[2]) {
x <- x %>% reshape2::dcast(.[, id] ~ .[, variables])
colnames(x)[1] <- id
x
}
#' Datum uit klinische gegevens bepalen
#'
#' Bepaalt met reguliere expressie de waarde uit klinische gegevens en retourneert geldige datums.
#' @param x Tekst, zoals klinische gegevens.
#' @param type Standaard is de eerste ziektedag.
clinical_date <- function(x, type = "Eerste ziektedag") {
regex <- paste0(".*", gsub(" ", ".?", type), "[: ]+([0-9]{1,2}[ ./-]([0-9]{1,2}|[a-z ]+)[ ./-][0-9]{1,4}).*")
dates <- gsub(regex, "\\1", x, ignore.case = TRUE)
lubridate::dmy(dates)
}
#' Data completeren met extra rijen
#'
#' Data opvullen met missende rijen. Standaard worden rijen aangevuld tussen de min en max van \code{variabele}.
#' @param data \code{data.frame} waarin rijen missen.
#' @param variable Variabele die numerieke waarden bevat en op basis waarvan de tabel aangevuld moet worden.
#' @param newvalue Standaard is \code{0}. Waarde die ingevuld moet worden in de kolommen.
# @param columns_to_expand Standaard is alle kolommen, behalve \code{variable}. Kolommen die aangevuld moeten worden met de waarde \code{newvalue}.
#' @param start_with_1 Standaard is \code{FALSE}. Waarde \code{1} als minimum voor \code{variabele} gebruiken, waardoor het hele bereik ingevuld wordt.
#' @export
#' @examples
#' a <- data.frame(week = c(3, 5, 6),
#' x = c(14, 23, 16),
#' y = c(34, 31, 28))
#' a
#' # week x y
#' # 1 3 14 34
#' # 2 5 23 31
#' # 3 6 16 28
#'
#' a %>% complete_rows(week)
#' # week x y
#' # 1 3 14 34
#' # 2 4 0 0
#' # 3 5 23 31
#' # 4 6 16 28
#'
#' a %>% complete_rows(week, start_with_1 = TRUE)
#' # week x y
#' # 1 1 0 0
#' # 2 2 0 0
#' # 3 3 14 34
#' # 4 4 0 0
#' # 5 5 23 31
#' # 6 6 16 28
#'
#' a %>% complete_rows(week, NA, start_with_1 = TRUE)
#' # week x y
#' # 1 1 NA NA
#' # 2 2 NA NA
#' # 3 3 14 34
#' # 4 4 NA NA
#' # 5 5 23 31
#' # 6 6 16 28
complete_rows <- function(data, variable, newvalue = 0, start_with_1 = FALSE) {
variable <- deparse(substitute(variable))
if (!is.numeric(data %>% pull(variable))) {
stop('`variabele` must be a numeric value')
}
var_vector <- data %>% pull(variable)
if (start_with_1 == TRUE) {
var_min <- 1
} else {
var_min <- var_vector %>% min()
}
var_max <- var_vector %>% max()
var_missing <- (seq(from = var_min, to = var_max) %in% var_vector) == FALSE
var_new <- seq(from = var_min, to = var_max)[var_missing]
#if (is.null(columns_to_expand)) {
columns_to_expand <- colnames(data)[colnames(data) != variable]
#}
if (rownames(data) %>% as.double2() %>%
identical(c(1:nrow(data)) %>% as.double2())) {
reset_rownames <- TRUE
} else {
reset_rownames <- FALSE
}
for (i in 1:length(var_new)) {
data_line <- data[1,]
data_line[,columns_to_expand] <- newvalue
data_line[,variable] <- var_new[i]
data <- data %>% rbind(data_line)
}
data <- data[order(data %>% pull(variable)), ]
if (reset_rownames == TRUE) {
rownames(data) <- 1:nrow(data)
}
data
}
#' @rdname double
#' @inherit base::double
#' @description Dit werkt hetzelfde als \code{\link{is.double}} en \code{\link{as.double}}, maar toetst en transformeert respectievelijk door eerst komma's als punt te lezen. De functie \code{is.double2} toetst door middel van reguliere expressies, dus wordt ook \code{TRUE} bij bijvoorbeeld \code{"3306"}.
#' @param dec Standaard is \code{c(".", ",")}. Tekens die als decimaal teken gelezen moeten worden.
#' @param na.rm Standaard is \code{TRUE}. lege waarden negeren.
#' @export is.double2
is.double2 <- function(x, dec = c(".", ","), na.rm = TRUE) {
if (na.rm == TRUE) {
x <- x[!is.na(x)]
} else if (length(x[is.na(x)]) > 0) {
return(NA)
}
x %like% paste0('^[0-9]+[', concat(dec), '][0-9]+$') | x %like% '^[0-9]+$'
}
#' @rdname double
#' @export as.double2
as.double2 <- function(x) {
x %>% gsub(",", ".", .) %>% as.double()
}
#' Splitsen in vaste breedte
#'
#' Hiermee kan een tekst of getal gesplitst worden op elk aangegeven aantal tekens.
#' @param x Tekst of getal
#' @param n De input \code{x} splitsen op elke \code{n} tekens.
#' @keywords split
#' @export split.every.n
#' @examples
#' 256 %>% split.every.n(1) # c(2, 5, 6)
#' 256 %>% split.every.n(2) # c(25, 6)
#' "Certe" %>% split.every.n(1) # c("C", "e", "r", "t", "e")
#' "Certe" %>% split.every.n(4) # c("Cert", "e")
split.every.n <- function(x, n) {
if (length(x) != 1L) {
stop('Only input with length of 1 allowed.')
}
if (is.na(x) | x == "") {
return("")
} else {
output.class <- class(x)
if (n == 1) {
as(strsplit(x %>% as.character(), "")[[1]], output.class)
} else {
substring(x,
seq(from = 1, to = nchar(x), by = n),
seq(from = n, to = nchar(x) + n - 1, by = n)) %>%
as(output.class)
}
}
}
#' Samenvoegen van vector
#'
#' Samenvoegen van items in een vector. Dit is gelijk aan \code{paste(..., sep = "", collapse = "")}.
#' @param x Een vector met tekst.
#' @param sep Standaard is \code{""}. Tekst om \code{x} op te splitsen.
#' @export
concat <- function(x, sep = '') {
paste(x, collapse = sep, sep = "")
}
#' Transformeren naar Zoals een zin.
#'
#' Dit transformeert de hoofdletters van een tekst naar de vorm \strong{"Zoals een zin."} of, wanneer \code{every.word = TRUE} wordt gebruikt, \strong{"Zoals Een Zin."}.
#' @param text De tekst die getransformeerd moet worden
#' @param every.word Standaard is \code{FALSE}. Ieder woord met een hoofdletter laten beginnen.
#' @param intelligent Standaard is \code{FALSE}. Woorden van maximaal 4 tekens met maximaal 1 klinker niet transformeren (zoals \code{"MCL"} en \code{"UMCG"}), en 1-letterwoorden niet capitaliseren.
#' @param only.first.char Standaard is tegenovergestelde van \code{every.word}. Hoofdlettergebruik behouden van alles behalve eerste letter.
#' @keywords case tolower toupper toproper proper hoofdletters hoofdletter
#' @return Tekst
#' @export
#' @examples
#' tolower("TJONGERSCHANS") # wordt "tjongerschans"
#' toupper("Tjongerschans") # wordt "TJONGERSCHANS"
#' toproper("TJONGERSCHANS") # wordt "Tjongerschans"
#'
#' toproper(c("TJONGERSCHANS", "ANTONIUS", "MCL", "UMCG"))
#' # wordt c("Tjongerschans", "Antonius", "Mcl", "Umcg")
#'
#' toproper(c("TJONGERSCHANS", "ANTONIUS", "MCL", "UMCG"), intelligent = TRUE)
#' # wordt c("Tjongerschans", "Antonius", "MCL", "UMCG")
toproper <- function(text, every.word = FALSE, intelligent = FALSE, only.first.char = !every.word) {
text <- as.character(text)
for (i in 1:length(text)) {
if (is.na(text[i])
| (intelligent == TRUE & nchar(text[i]) == 1)
| (intelligent == TRUE &
nchar(text[i]) < 5 &
nchar(text[i]) - nchar(gsub('[aeiyouAEIYOU]', '', text[i])) <= 1)) {
# waarde NA, of 1-letterwoord, of een afkorting zoals MCL en UMCG --> niet transformeren
} else if (every.word == FALSE) {
if (only.first.char == TRUE) {
text[i] <- paste0(text[i] %>% substr(1, 1) %>% toupper(),
text[i] %>% substr(2, nchar(text[i])))
} else {
text[i] <- paste0(text[i] %>% substr(1, 1) %>% toupper(),
text[i] %>% substr(2, nchar(text[i])) %>% tolower())
}
} else {
lijst <- text[i] %>% strsplit(' ', fixed = TRUE) %>% unlist()
for (j in 1:length(lijst)) {
if (only.first.char == TRUE) {
lijst[j] <- paste0(lijst[j] %>% substr(1, 1) %>% toupper(),
lijst[j] %>% substr(2, nchar(lijst[j])))
} else {
lijst[j] <- paste0(lijst[j] %>% substr(1, 1) %>% toupper(),
lijst[j] %>% substr(2, nchar(lijst[j])) %>% tolower())
}
}
text[i] <- concat(lijst, ' ')
}
}
text
}
#' Verwijderen van titel en voorletters van naam
#'
#' Dit transformeert een naam als \code{"Dhr AA van der Molen"} naar \code{"V/d Molen"} en een naam als \code{"Prof dr AB Jansen"} naar \code{"Jansen"}. Verwijdert alle academische titels voor de naam (Prof, Dr, Ir, enz) en achter de naam (Ph.D., MD, enz.) en ook Nederlandse voor- en achtervoegsels zoals Mw, Dhr en Jr of Sr.
#' @param name Naam van persoon
#' @keywords name
#' @return Tekst
#' @export
#' @examples
#' \dontrun{
#'
#' tbl$artsnaam <- strip_name(tbl$artsnaam)
#' }
strip_name <- function(name) {
nieuw <- name
# punt en komma eruit
nieuw <- gsub('.', '', nieuw, fixed = TRUE)
nieuw <- gsub(',', '', nieuw, fixed = TRUE)
# dubbele spaties naar 1 spatie
nieuw <- gsub(' ', ' ', nieuw, fixed = TRUE)
# titulatuur verwijderen
nieuw <- sub('^[Pp]rof ', '', nieuw)
nieuw <- sub('^[Dd]rs ', '', nieuw)
nieuw <- sub('^[Dd]r ', '', nieuw)
nieuw <- sub('^[Dd]r ', '', nieuw)
nieuw <- sub('^[Mm]ed ', '', nieuw)
nieuw <- sub('^[Ii]r ', '', nieuw)
nieuw <- sub('^[Mm]r ', '', nieuw)
nieuw <- sub('^[Ii]ng ', '', nieuw)
nieuw <- sub('^[Mm]w ', '', nieuw)
nieuw <- sub('^[Dd]hr ', '', nieuw)
nieuw <- sub('^[Dd]hm ', '', nieuw)
nieuw <- sub('^[Dd]hrn ', '', nieuw)
nieuw <- sub(' [Jj][Rr]$', '', nieuw)
nieuw <- sub(' [Ss][Rr]$', '', nieuw)
nieuw <- sub(' [Pp][Hh][Dd]$', '', nieuw)
nieuw <- sub(' [Mm][Dd]$', '', nieuw)
nieuw <- sub(' [Jj][Dd]$', '', nieuw)
nieuw <- sub(' [Pp][Hh][Dd]$', '', nieuw)
# voorletters verwijderen
nieuw <- sub('^[A-Z]+ ', '', nieuw)
# nieuwe eerste hoofdletter
nieuw <- paste0(toupper(substr(nieuw, 1, 1)), substr(nieuw, 2, nchar(nieuw)))
# sommige artsen staan verschillend in het systeem; plat slaan
nieuw <- sub('^Vd ', 'V/d ', nieuw)
nieuw <- sub('^Van der ', 'V/d ', nieuw)
nieuw <- sub('^Van den ', 'V/d ', nieuw)
nieuw <- sub('^Van de ', 'V/d ', nieuw)
nieuw
}
#' Bytes weergeven in kB/MB/GB
#'
#' De bestandsgrootte (als double) weergeven als kB/MB/GB.
#' @param bytes Grootte als getal
#' @param decimals Aantal tekens achter de komma.
#' @export
#' @examples
#' size_humanreadable(123456) # 121 kB
#' size_humanreadable(12345678) # 11.8 MB
size_humanreadable <- function(bytes, decimals = 1) {
bytes <- bytes %>% as.double()
# Adapted from:
# http://jeffreysambells.com/2012/10/25/human-readable-filesize-php
size <- c('B','kB','MB','GB','TB','PB','EB','ZB','YB')
factor <- floor((nchar(bytes) - 1) / 3)
# added slight improvement; no decimals for B and kB:
decimals <- rep(decimals, length(bytes))
decimals[size[factor + 1] %in% c('B', 'kB')] <- 0
out <- paste(sprintf(paste0("%.", decimals, "f"), bytes / (1024 ^ factor)), size[factor + 1])
if (Sys.isdecimalcomma()) {
out <- gsub('.', ',', out, fixed = TRUE)
}
out
}
#' Certe-thema voor \code{ggplot}-grafieken
#'
#' Hiermee kan aan een \code{ggplot}-model het Certe-thema meegegeven worden.
#' @param subtitle.colour Standaard is \code{colourpicker("certeblauw")}. Kleur van de ondertitel. Zie \code{\link{colourpicker}}.
#' @param x.lbl.angle Standaard is \code{0}. De hoek in graden waaronder de labels van de x-as weergegeven worden. Gebruik voor verticale weergave een hoek van \code{90} (richting onder naar boven) of \code{270} (richting boven naar onder).
#' @param x.lbl.align Standaard is \code{0.5}, waardoor er centraal uitgelijnd wordt. Andere geldige opties zijn \code{"links"}, \code{"midden"} en \code{"rechts"}.
#' @param horizontal Standaard is \code{FALSE}. Voor horizontale orientatie van kolommen of boxplots. Met \code{TRUE} worden de lijnen van de y-as vervangen door lijnen op de x-as.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt wordt voor tekst in de grafiek.
#' @param legend.position Standaard is \code{"top"}. Geldige opties zijn \code{"none"} (\code{"geen"}), \code{"left"} (\code{"links"}), \code{"right"} (\code{"rechts"}), \code{"top"} (\code{"boven"}), \code{"bottom"} (\code{"onder"}), of een vector met 2 cijfers: bijv. \code{legend.position = c(0, 0)} voor linksonder of \code{legend.position = c(1, 1)} voor rechtsboven.
#' @param text.factor Standaard is \code{1}. Factor van de grootte van alle tekst.
#' @param x.category.fill Standaard is \code{"certeblauw3"}. Kleur die doorgegeven wordt aan \code{\link{colourpicker}}.
#' @param x.category.bold Standaard is \code{TRUE}. Tekst van \code{x.category} vetgedrukt weergeven.
#' @param x.category.size Standaard is \code{10} pt. Grootte van de 'titel' bij elke grafiek.
#' @param x.category.margin Standaard is 3. Marge van de 'titel' bij elke grafiek.
#' @param has_subtitle Standaard is \code{FALSE}. De marges worden aangepast o.b.v. aanwezigheid van een ondertitel.
#' @details
#' \if{html}{Zonder \code{theme_certe()}:
#'
#' \out{<div style="text-align: center">}\figure{ggplot.png}{options: style="width:600px;max-width:95\%;"}\out{</div>}
#'
#' }
#' \if{latex}{Zonder theme_certe():
#'
#' \out{\begin{center}}\figure{ggplot.png}\out{\end{center}}
#' }
#' \if{html}{Met \code{theme_certe()}:
#'
#' \out{<div style="text-align: center">}\figure{singlecolumn.png}{options: style="width:600px;max-width:95\%;"}\out{</div>}
#' \out{<div style="text-align: center">}\figure{doublecolumn.png}{options: style="width:600px;max-width:95\%;"}\out{</div>}
#'
#' }
#' \if{latex}{Met theme_certe():
#'
#' \out{\begin{center}}\figure{singlecolumn.png}\out{\end{center}}
#' \out{\begin{center}}\figure{doublecolumn.png}\out{\end{center}}
#' }
#' @keywords grafiek chart ggplot subtitle.colour x.lbl.angle x.lbl.align horizontal font.family legend.position
#' @return Thema
#' @export
#' @examples
#' \dontrun{
#'
#' ggplot(tbl, aes(x = col1, y = col2)) + theme_certe()
#' }
theme_certe <- function(subtitle.colour = colourpicker("certeblauw"),
x.lbl.angle = 0,
x.lbl.align = 0.5,
horizontal = FALSE,
font.family = 'Calibri',
legend.position = 'top',
text.factor = 1,
x.category.fill = colourpicker(NA),
x.category.bold = TRUE,
x.category.size = 10,
x.category.margin = 4,
has_subtitle = FALSE) {
if (length(legend.position) == 1) {
legend.position <- tolower(legend.position)
if (is.na(legend.position)) {
legend.position <- 'none'
}
legend.position <- sub('geen', 'none', legend.position)
legend.position <- sub('^(t|boven)$', 'top', legend.position)
legend.position <- sub('^(r|rechts)$', 'right', legend.position)
legend.position <- sub('^(b|o|onder)$', 'bottom', legend.position)
legend.position <- sub('^(l|links)$', 'left', legend.position)
}
t <- theme_bw(base_size = 11 * text.factor,
base_family = font.family) %+replace%
theme(
axis.text.x = element_text(angle = x.lbl.angle, hjust = x.lbl.align, margin = margin(3, 0, 0, 0)),
axis.title.x = element_text(margin = margin(14, 0, 0, 0)),
axis.title.y = element_text(margin = margin(0, 14, 0, 0), angle = 90),
axis.ticks.y = element_blank(),
axis.ticks.x = element_line(size = 0.75, colour = 'grey75'),
axis.ticks.length = unit(2, "pt"),
legend.background = element_blank(),
legend.key = element_blank(),
legend.key.size = unit(11 * text.factor, 'pt'), # blokjes en lijnen links van tekst in legenda
legend.text = element_text(size = unit(9 * text.factor, 'pt'), # tekst zelf
margin = margin(l = 1, r = 6, unit = "pt")), # ruimte links en rechts van tekst
legend.position = legend.position,
legend.title = element_text(face = 'bold', size = unit(10 * text.factor, 'pt')),
panel.background = element_blank(),
panel.border = element_blank(),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_line(size = 0.375, colour = 'grey75'),
panel.grid.minor.x = element_blank(),
panel.grid.minor.y = element_line(size = 0.25, colour = 'grey85'),
axis.line = element_line(size = 0.375, colour = 'grey75'),
axis.line.y = element_blank(),
plot.margin = unit(c(5, # top
ifelse(horizontal == TRUE, 25, 5), # right
5, # bottom
5), # left
units = "pt"),
plot.background = element_blank(),
plot.subtitle = element_text(size = unit(11 * text.factor, 'pt'),
margin = margin(0, 0, ifelse(has_subtitle == TRUE, 15, 7), 0),
hjust = 0.5,
colour = subtitle.colour),
plot.title = element_text(size = unit(13 * text.factor, 'pt'),
margin = margin(0, 0, ifelse(has_subtitle == TRUE, 7, 15), 0),
hjust = 0.5,
colour = 'black'),
plot.caption = element_text(colour = 'grey50',
size = unit(10 * text.factor, 'pt'),
hjust = 1),
plot.tag = element_text(size = unit(14 * text.factor, 'pt'),
margin = margin(0, 0, 0, 0),
hjust = 0,
colour = 'black',
face = "bold"),
# voor x.category (facet_wrap):
strip.background = element_rect(fill = x.category.fill, colour = '#FFFFFF00'),
strip.text = element_text(face = if_else(x.category.bold, 'bold', 'plain'),
size = unit(x.category.size * text.factor, 'pt'),
margin = margin(t = x.category.margin, b = x.category.margin)),
strip.switch.pad.wrap = unit(10 * text.factor, "pt"),
strip.placement = 'outside',
complete = TRUE)
if (x.lbl.angle < 90 & x.lbl.angle > 10) {
t <- t +
theme(axis.text.x = element_text(margin = margin(-5, 0, 0, 0)))
}
if (horizontal == TRUE) {
t <- t %+replace%
theme(panel.grid.major.y = element_blank(),
panel.grid.minor.y = element_blank(),
panel.grid.major.x = element_line(size = 0.375, colour = 'grey75'),
panel.grid.minor.x = element_line(size = 0.25, colour = 'grey85'),
axis.ticks.x = element_blank(),
axis.ticks.y = element_line(size = 0.75, colour = 'grey75'),
# tekst op y-as (wat x-as was) rechts align en minder ruimte geven
axis.text.y = element_text(hjust = 1.0, vjust = 0.3, margin = margin(0, 3, 0, 0)),
axis.text.x = element_text(margin = margin(0, 0, 0, 0)),
axis.line.y = element_line(size = 0.375, colour = 'grey75'),
axis.line.x = element_blank())
}
t
}
#' Tijden transformeren naar UTC
#'
#' Transformeert all tijden die voorkomen in \code{x} naar UTC.
#' @param x Een vector of \code{data.frame} die kolommen bevat met tijden.
#' @export
as.UTC <- function(x) {
if (is.null(dim(x)) & "POSIXct" %in% class(x)) {
attr(x, "tzone") <- "UTC"
} else if ("POSIXct" %in% unlist(lapply(x, class))) {
for (i in 1:ncol(x)) {
x_vector <- x %>% pull(i)
if ("POSIXct" %in% class(x_vector)) {
attr(x_vector, "tzone") <- "UTC"
x[, i] <- x_vector
}
}
}
x
}
#' Class van elke kolom schatten
#'
#' Transformeert een \code{data.frame} door de class van elke kolom te schatten met \code{\link[readr]{parse_guess}} en forceert daarbij UTF-8-encoding voor ondersteuning van speciale tekens zoals klinkers met accenten. Wanneer een kolom de class \code{factor} of \code{character} bezit, wordt het Unicode-teken 00EB (ASCII escape character) vervangen door een spatie, worden kolommen die uitsluitend de waarden \code{c(NA, "", "S", "I", "R")} bevatten getransformeerd met \code{\link{as.rsi}}, en worden kolommen met kolomnamen die eindigen op \code{_mic} getransformeerd met \code{\link{as.mic}}.
#' @param tbl Tabel.
#' @param datenames Standaard is \code{"en"}. Taal van de datenames (zoals weekdagen en maanden).
#' @param dateformat Standaard is \code{"\%Y-\%m-\%d"}. Accepteert ook Excel-formaten, zoals \code{"dd-mm-yy"} en \code{"dd-mm-jjjj"}.
#' @param timeformat Standaard is \code{"\%H:\%M"}. Accepteert ook Excel-formaten, zoals \code{"HH:MM:SS"}.
#' @param decimal.mark Standaard is \code{"."}. Scheidingsteken voor decimale getallen.
#' @param big.mark Standaard is \code{""}. Groepsteken voor getallen, zoals 1.000.000.
#' @param timezone Standaard is \code{"UTC"}. Forceren van de weergave van tijd door de tijdzone aan te passen. Zomertijd is gelijk aan CEST (Central European Summer Time) en loopt 2 uur voor op UTC, wintertijd is gelijk aan CET (Central European Time) en loopt 1 uur voor op UTC.
#' @param na Standaard is \code{c("", "NULL", "NA", "<NA>")}. Waarden die vertaald moeten worden als \code{NA}.
#' @return Met behoud van oorspronkelijke class: \code{data.frame} (forceert geen \code{\link[tibble]{tibble}})
#' @export
tbl_guess_columns <- function(tbl,
datenames = 'en',
dateformat = '%Y-%m-%d',
timeformat = '%H:%M',
decimal.mark = '.',
big.mark = '',
timezone = 'UTC',
na = c("", "NULL", "NA", "<NA>")) {
dateformat <- date_generic(dateformat)
timeformat <- date_generic(timeformat)
# kolomtypen instellen met readr
for (i in 1:ncol(tbl)) {
if (!all(tbl %>% pull(i) %>% class() %in% c('list', 'matrix')) &
# geen Feces of Tips
!all(tbl %>% pull(i) %>% unique() %in% c('T', 'F'))) {
tbl[, i] <- readr::parse_guess(x = tbl %>% pull(i) %>% as.character(),
na = na,
locale = readr::locale(date_names = datenames,
date_format = dateformat,
time_format = timeformat,
decimal_mark = decimal.mark,
grouping_mark = big.mark,
encoding = "UTF-8",
tz = timezone,
asciify = FALSE))
}
if (timezone == "UTC") {
tbl <- as.UTC(tbl)
}
if (any(tbl %>% pull(i) %>% class() %in% c('factor', 'character'))) {
# voor snellere vergelijkingen:
distinct_val <- tbl %>% pull(i) %>% unique() %>% sort()
# ASCII escape character verwijderen: https://en.wikipedia.org/wiki/Escape_character#ASCII_escape_character
tbl[, i] <- tbl %>% pull(i) %>% tryCatch(gsub('\033', ' ', ., fixed = TRUE),
error = function(e) {
warning(e$message)
return(.)})
# zoeken naar RSI, mag niet allemaal "" zijn en moeten geldige AB-interpretaties zijn
if (!all(distinct_val[!is.na(distinct_val)] == '')
& all(distinct_val[!is.na(distinct_val)] %in% c('', 'I', 'I;I', 'R', 'R;R', 'S', 'S;S'))) {
tbl[, i] <- tbl %>% pull(i) %>% as.rsi()
}
}
# omzetten naar mic class
if (colnames(tbl)[i] %like% '_mic$') {
tbl[, i] <- tbl %>% pull(i) %>% as.mic()
}
# bacteriecode (EDIT: nu niet meer nodig, wordt apart `mo` toegevoegd in database.R)
# if (colnames(tbl)[i] %in% c('bactid', 'bacteriecode')) {
# suppressWarnings(tbl[, i] <- tbl %>% pull(i) %>% as.mo())
# }
}
tbl
}
#' Binaire kolommen transformeren naar logical
#'
#' Hiermee worden kolommen die uitsluitend waarden 0 en 1 bevatten, omgezet naar de class \code{logical}.
#' @param tbl Tabel waarvan kolommen getransformeerd moeten worden.
#' @export
tbl_binary2logical <- function(tbl) {
for (i in 1:ncol(tbl)) {
# moet 0 en 1 bevatten en mag niet alleen maar NA zijn, en geen factor
if ('0' %in% (tbl %>% pull(i))
& '1' %in% (tbl %>% pull(i))
& all(tbl %>% pull(i) %in% c('0', '1', NA))
& !all(is.na(tbl %>% pull(i)))
& !'factor' %in% (tbl %>% pull(i) %>% class())) {
suppressWarnings(
tbl[, i] <- tbl %>% pull(i) %>% as.double() %>% as.logical()
)
}
}
tbl
}
#' Tabel printen in Markdown, LaTeX of HTML
#'
#' Drukt een tabel af (forceert \code{\link{print}}) in Markdown, LaTeX of HTML m.b.v. \code{\link[knitr]{kable}}, met standaard vette kolomnamen en naar Nederlands getransformeerde formaten voor datums, getallen en percentages.
#' @param tbl Een \code{data.frame} met gegevens.
#' @param row.names Standaard is \code{FALSE}. Weer te geven rijnamen.
#' @param column.names Standaard is \code{colnames(tabel)}. Weer te geven kolomnamen.
#' @param align Standaard is \code{NULL}, waardoor kolommen met getallen rechts worden uitgelijnd en andere kolommen links worden uitgelijnd.
#' @param padding Standaard is \code{2}. Extra ruimte in de cellen.
#' @param caption Standaard is \code{""}. Bijschrift bij de tabel.
#' @param na Standaard is \code{""}. Tekst voor ontbrekende waarden.
#' @param format.tbl Standaard is \code{"markdown"}. Geldige opties zijn \code{"latex"}, \code{"html"}, \code{"markdown"}, \code{"pandoc"} en \code{"rst"}.
#' @param format.dates Standaard is \code{"dd-mm-yyyy"}. Zie \code{\link{format2}}.
#' @param format.NL Standaard is \code{Sys.isdecimalcomma()}, zie \code{\link{Sys.isdecimalcomma}}. Hiermee worden getallen met een komma als decimaal teken weergegeven.
#' @param columns.percent Standaard is \code{NA}. De kolomindices weergeven als percentage met \code{\link{format2}}. Voorbeeld: \code{columns.percent = c(2, 3)}. Makkelijk is om deze kolommen vooraf te transformeren met \code{\link{as.percent}}, zo blijven de bronwaarden namelijk gelijk.
#' @param columns.bold Standaard is \code{TRUE}. Kolomnamen vet weergeven.
#' @param round.numbers Standaard is \code{2}. Aantal decimalen om op af te ronden bij getallen.
#' @param round.percent Standaard is \code{1}. Aantal decimalen om op af te ronden wanneer \code{columns.percent} gebruikt wordt.
#' @param newlines.leading Standaard is \code{2}. Aantal witregels om te printen \strong{voor} de tabel.
#' @param newlines.trailing Standaard is \code{2}. Aantal witregels om te printen \strong{na} de tabel.
#' @details Wanneer in een R Markdown-rapport een tabel met deze functie voorafgegaan wordt door een ander object (zoals een grafiek), printen de kolomkoppen alleen goed wanneer \code{newlines.leading} >= 2, of door handmatig gebruik van \code{cat("\\n\\n")} alvorens de tabel te printen.
#' @keywords tabel knitr kable
#' @seealso \code{\link[knitr]{kable}}
#' @return Tekst
#' @export
tbl_markdown <- function(tbl,
row.names = FALSE,
column.names = colnames(tbl),
align = NULL,
padding = 2,
caption = '',
na = '',
format.tbl = 'markdown',
format.dates = 'dd-mm-yyyy',
format.NL = Sys.isdecimalcomma(),
columns.percent = NA,
columns.bold = TRUE,
round.numbers = 2,
round.percent = 1,
newlines.leading = 2,
newlines.trailing = 2) {
tbl <- as.data.frame(tbl)
tblnaam <- deparse(substitute(tbl))
if (caption == '') {
caption <- NULL
}
if (columns.bold == TRUE) {
column.names <- paste0('**', column.names, '**')
}
if (is.null(ncol(tbl))) {
kolommenaantal <- 1
} else {
kolommenaantal <- ncol(tbl)
}
for (i in 1:kolommenaantal) {
if (class(tbl[1, i])[1] %in% c('Date', 'POSIXct', 'POSIXlt')) {
tbl[, i] <- tbl %>% pull(i) %>% format2(format = format.dates)
}
if (class(tbl[1, i])[1] %in% c('double', 'integer', 'numeric', 'single') &
!i %in% columns.percent) {
tbl[, i] <- tbl %>% pull(i) %>% format2(round = round.numbers, format.NL = format.NL)
}
if (i %in% columns.percent) {
tbl[, i] <- tbl %>% pull(i) %>% as.percent() %>% format2(round = round.percent, format.NL = format.NL)
}
}
opt.old <- options()$knitr.kable.NA
options(knitr.kable.NA = na)
cat(rep('\n', newlines.leading) %>% concat())
print(
knitr::kable(
tbl,
table.attr = paste0('id="', tblnaam, '"'),
col.names = column.names,
row.names = row.names,
align = align,
format = format.tbl,
padding = padding,
caption = caption
)
)
cat(rep('\n', newlines.trailing) %>% concat())
options(knitr.kable.NA = opt.old)
}
#' Verwijderen van privacygevoelige kolommen
#'
#' Verwijdert de volgende kolommen uit een dataframe: \code{geslachtsnaam}, \code{naam}, \code{achternaam}, \code{geboortedatum}, \code{postcode}, \code{plaats}, \code{woonplaats}, \code{provincie}, en \code{"lastname"}, \code{"name"}, \code{"dob"}, \code{"birthdate"} en \code{"city"}.
#' @param tbl Dataframe met gegevens.
#' @keywords anonymise anoniem
#' @export
#' @return data.frame
#' @examples
#' \dontrun{
#' tbl <- tbl_anonymise(tbl)
#' }
tbl_anonymise <- function(tbl) {
verwijderen <- c(
"geslachtsnaam",
"naam",
"achternaam",
"geboortedatum",
"postcode",
"plaats",
"woonplaats",
"provincie",
"lastname",
"name",
"dob",
"birthdate",
"city"
)
tbl[, !(tolower(colnames(tbl)) %in% verwijderen)]
}
#' Kleurnaam van RGB-code of HTML-code
#'
#' Print een kleurnaam van een RGB-code of HTML-code.
#' @rdname colour.name
#' @param htmlcode Een tekst zoals \code{"#FFFFFF"}, of een formule die dit retourneert, zoals \code{rgb(1, 1, 1)}.
#' @keywords kleur
#' @return Tekst
#' @export
colour.name <- function(htmlcode) {
kleurtabel <- structure(list(
rgb = c("#000000", "#FF0000", "#00FF00", "#0000FF",
"#FF00FF", "#FFFF00", "#00FFFF", "#FFFFFF", "#C0C0C0", "#800000",
"#008000", "#000080", "#800080", "#808000", "#008080", "#808080",
"#CD5C5C", "#F08080", "#FA8072", "#E9967A", "#FF4500", "#FF0000",
"#DC143C", "#B22222", "#8B0000", "#FFC0CB", "#FFB6C1", "#DB7093",
"#FF69B4", "#FF1493", "#C71585", "#FFFFE0", "#FFFACD", "#FAFAD2",
"#FFEFD5", "#FFE4B5", "#FFDAB9", "#EEE8AA", "#F0E68C", "#FFFF00",
"#FFD700", "#BDB76B", "#E0FFFF", "#AFEEEE", "#00FFFF", "#7FFFD4",
"#40E0D0", "#48D1CC", "#00CED1", "#B0E0E6", "#B0C4DE", "#ADD8E6",
"#87CEEB", "#87CEFA", "#00BFFF", "#6495ED", "#4682B4", "#5F9EA0",
"#7B68EE", "#1E90FF", "#4169E1", "#0000FF", "#0000CD", "#00008B",
"#000080", "#191970", "#FFA07A", "#FFA500", "#FF8C00", "#FF7F50",
"#FF6347", "#FF4500", "#ADFF2F", "#7FFF00", "#7CFC00", "#00FF00",
"#98FB98", "#90EE90", "#00FA9A", "#00FF7F", "#9ACD32", "#32CD32",
"#3CB371", "#2E8B57", "#228B22", "#008000", "#6B8E23", "#808000",
"#556B2F", "#006400", "#7FFFD4", "#66CDAA", "#8FBC8F", "#20B2AA",
"#008B8B", "#008080", "#E6E6FA", "#D8BFD8", "#DDA0DD", "#EE82EE",
"#FF00FF", "#DA70D6", "#BA55D3", "#9370DB", "#6A5ACD", "#8A2BE2",
"#9400D3", "#9932CC", "#663399", "#8B008B", "#800080", "#483D8B",
"#4B0082", "#FFF8DC", "#FFEBCD", "#FFE4C4", "#FFDEAD", "#F5DEB3",
"#DEB887", "#D2B48C", "#BC8F8F", "#F4A460", "#DAA520", "#B8860B",
"#CD853F", "#D2691E", "#8B4513", "#A0522D", "#A52A2A", "#800000",
"#FFFFFF", "#FFFAFA", "#F0FFF0", "#F5FFFA", "#F0FFFF", "#F0F8FF",
"#F8F8FF", "#F5F5F5", "#FFF5EE", "#F5F5DC", "#FDF5E6", "#FFFAF0",
"#FFFFF0", "#FAEBD7", "#FAF0E6", "#FFF0F5", "#FFE4E1", "#DCDCDC",
"#D3D3D3", "#C0C0C0", "#A9A9A9", "#808080", "#696969", "#778899",
"#708090", "#2F4F4F", "#000000"),
r = c(0L, 255L, 0L, 0L, 255L,
255L, 0L, 255L, 192L, 128L, 0L, 0L, 128L, 128L, 0L, 128L, 205L,
240L, 250L, 233L, 255L, 255L, 220L, 178L, 139L, 255L, 255L, 219L,
255L, 255L, 199L, 255L, 255L, 250L, 255L, 255L, 255L, 238L, 240L,
255L, 255L, 189L, 224L, 175L, 0L, 127L, 64L, 72L, 0L, 176L, 176L,
173L, 135L, 135L, 0L, 100L, 70L, 95L, 123L, 30L, 65L, 0L, 0L,
0L, 0L, 25L, 255L, 255L, 255L, 255L, 255L, 255L, 173L, 127L,
124L, 0L, 152L, 144L, 0L, 0L, 154L, 50L, 60L, 46L, 34L, 0L, 107L,
128L, 85L, 0L, 127L, 102L, 143L, 32L, 0L, 0L, 230L, 216L, 221L,
238L, 255L, 218L, 186L, 147L, 106L, 138L, 148L, 153L, 102L, 139L,
128L, 72L, 75L, 255L, 255L, 255L, 255L, 245L, 222L, 210L, 188L,
244L, 218L, 184L, 205L, 210L, 139L, 160L, 165L, 128L, 255L, 255L,
240L, 245L, 240L, 240L, 248L, 245L, 255L, 245L, 253L, 255L, 255L,
250L, 250L, 255L, 255L, 220L, 211L, 192L, 169L, 128L, 105L, 119L,
112L, 47L, 0L),
g = c(0L, 0L, 255L, 0L, 0L, 255L, 255L, 255L,
192L, 0L, 128L, 0L, 0L, 128L, 128L, 128L, 92L, 128L, 128L, 150L,
69L, 0L, 20L, 34L, 0L, 192L, 182L, 112L, 105L, 20L, 21L, 255L,
250L, 250L, 239L, 228L, 218L, 232L, 230L, 255L, 215L, 183L, 255L,
238L, 255L, 255L, 224L, 209L, 206L, 224L, 196L, 216L, 206L, 206L,
191L, 149L, 130L, 158L, 104L, 144L, 105L, 0L, 0L, 0L, 0L, 25L,
160L, 165L, 140L, 127L, 99L, 69L, 255L, 255L, 252L, 255L, 251L,
238L, 250L, 255L, 205L, 205L, 179L, 139L, 139L, 128L, 142L, 128L,
107L, 100L, 255L, 205L, 188L, 178L, 139L, 128L, 230L, 191L, 160L,
130L, 0L, 112L, 85L, 112L, 90L, 43L, 0L, 50L, 51L, 0L, 0L, 61L,
0L, 248L, 235L, 228L, 222L, 222L, 184L, 180L, 143L, 164L, 165L,
134L, 133L, 105L, 69L, 82L, 42L, 0L, 255L, 250L, 255L, 255L,
255L, 248L, 248L, 245L, 245L, 245L, 245L, 250L, 255L, 235L, 240L,
240L, 228L, 220L, 211L, 192L, 169L, 128L, 105L, 136L, 128L, 79L,
0L),
b = c(0L, 0L, 0L, 255L, 255L, 0L, 255L, 255L, 192L, 0L,
0L, 128L, 128L, 0L, 128L, 128L, 92L, 128L, 114L, 122L, 0L, 0L,
60L, 34L, 0L, 203L, 193L, 147L, 180L, 147L, 133L, 224L, 205L,
210L, 213L, 181L, 185L, 170L, 140L, 0L, 0L, 107L, 255L, 238L,
255L, 212L, 208L, 204L, 209L, 230L, 222L, 230L, 235L, 250L, 255L,
237L, 180L, 160L, 238L, 255L, 225L, 255L, 205L, 139L, 128L, 112L,
122L, 0L, 0L, 80L, 71L, 0L, 47L, 0L, 0L, 0L, 152L, 144L, 154L,
127L, 50L, 50L, 113L, 87L, 34L, 0L, 35L, 0L, 47L, 0L, 212L, 170L,
143L, 170L, 139L, 128L, 250L, 216L, 221L, 238L, 255L, 214L, 211L,
219L, 205L, 226L, 211L, 204L, 153L, 139L, 128L, 139L, 130L, 220L,
205L, 196L, 173L, 179L, 135L, 140L, 143L, 96L, 32L, 11L, 63L,
30L, 19L, 45L, 42L, 0L, 255L, 250L, 240L, 250L, 255L, 255L, 255L,
245L, 238L, 220L, 230L, 240L, 240L, 215L, 230L, 245L, 225L, 220L,
211L, 192L, 169L, 128L, 105L, 153L, 144L, 79L, 0L),
colour.name = c("zwart", "rood", "groen",
"blauw", "magenta", "geel", "cyaan", "wit", "zilver", "kastanjebruin",
"groen", "marine", "purper", "olijfgroen", "groenblauw", "grijs",
"indisch rood", "lichtkoraal", "zalm", "donkerzalm", "oranjerood",
"rood", "rood", "rood", "donkerrood", "roze",
"lichtroze", "bleekvioletrood", "acaciaroze", "dieproze", "midvioletrood",
"lichtgeel", "lichtgeel", "lichtgoudgeel", "lichtperzik",
"perzik", "perzik", "bleekgoud", "geelbruin", "geel", "goud",
"donkergeelbruin", "lichtcyaan", "lichtturkoois", "cyaan", "aquamarijn",
"turkoois", "midturkoois", "donkerturkoois", "poederblauw",
"staalblauw", "lichtblauw", "hemelsblauw", "lichthemelsblauw",
"diephemelsblauw", "korenbloemblauw", "donkerstaalblauw", "kadetblauw",
"midgrijsblauw", "helderblauw", "koningsblauw", "blauw", "midblauw",
"donkerblauw", "marine", "midnachtsblauw", "lichtzalm", "oranje",
"donkeroranje", "koraal", "tomaat", "oranjerood", "groengeel",
"groengeel", "grasgroen", "limoen", "bleekgroen", "lichtgroen",
"midlentegroen", "lentegroen", "geelgroen", "limoengroen", "midzeegroen",
"zeegroen", "bosgroen", "groen", "olijf", "olijfgroen", "donkerolijfgroen",
"donkergroen", "aquamarijn", "midaquamarine", "donkerzeegroen",
"lichtzeegroen", "donkercyaan", "groenblauw", "lavendel", "lavendel",
"pruim", "violet", "magenta", "orchidee", "midorchidee",
"midpaars", "leiblauw", "blauwviolet", "donkerviolet", "donkerorchidee",
"blauwpaars", "donkermagenta", "purper", "donkerleiblauw",
"indigo", "witroze", "witroze", "witroze", "navajowit",
"tarwe", "bruinroze", "bruinroze", "paarsbrown", "zandbruin", "goud",
"donkergoud", "peru", "chocoladebruin", "bruin", "bruin",
"bruin", "kastanjebruin", "wit", "sneeuwwit", "witgrijs", "mint",
"helderblauw", "witblauw", "wit", "rookwit", "schelp",
"beige", "kant", "fluweelwit", "ivoor", "antiekwit", "linnen",
"witroze", "witroze", "grijswit", "lichtgrijs", "zilver",
"donkergrijs", "grijs", "grijs", "lichtleigrijs", "leigrijs",
"donkerleigrijs", "zwart")),
class = c("tbl_df", "tbl", "data.frame"),
row.names = c(NA, -157L),
.Names = c("rgb", "r", "g", "b", "kleurnaam"))
dichtste <- function(getal, precisie) {
lijst <- seq(0, 255, by = precisie)
getal.nieuw <- getal
for (n in 1:length(getal)) {
getal.nieuw[n] <- lijst[which.min(abs(lijst - getal[n]))]
}
getal.nieuw
}
for (k in 1:length(htmlcode)) {
if (htmlcode[k] == colourpicker('certeblauw')) {
htmlcode[k] <- 'certeblauw'
next
}
if (htmlcode[k] == colourpicker('certegroen')) {
htmlcode[k] <- 'certegroen'
next
}
if (htmlcode[k] == colourpicker('certeroze')) {
htmlcode[k] <- 'certeroze'
next
}
if (htmlcode[k] == colourpicker('certegeel')) {
htmlcode[k] <- 'certegeel'
next
}
if (htmlcode[k] == colourpicker('certelila')) {
htmlcode[k] <- 'certelila'
next
}
if (htmlcode[k] == colourpicker('certezachtlila')) {
htmlcode[k] <- 'certezachtlila'
next
}
kleuren <- col2rgb(htmlcode[k])
zoek.rood <- kleuren[1]
zoek.groen <- kleuren[2]
zoek.blauw <- kleuren[3]
for (i in seq(10, 100, by = 10)) {
html.rood <- dichtste(zoek.rood, i)
html.groen <- dichtste(zoek.groen, i)
html.blauw <- dichtste(zoek.blauw, i)
kleurtabel$rood <- dichtste(kleurtabel$r, i)
kleurtabel$groen <- dichtste(kleurtabel$g, i)
kleurtabel$blauw <- dichtste(kleurtabel$b, i)
resultaat <- kleurtabel %>% filter(rood == html.rood,
groen == html.groen,
blauw == html.blauw)
if (nrow(resultaat) > 0) {
htmlcode[k] <- resultaat$kleurnaam[length(resultaat$kleurnaam)]
break
}
}
if (!grepl('#', htmlcode[k], fixed = TRUE)) {
next
}
htmlcode[k] <- ''
if (zoek.rood > zoek.groen & zoek.rood > zoek.blauw) {
htmlcode[k] <- 'roodachtig'
}
if (zoek.groen > zoek.rood & zoek.groen > zoek.blauw) {
htmlcode[k] <- 'groenachtig'
}
if (zoek.blauw > zoek.rood & zoek.blauw > zoek.groen) {
htmlcode[k] <- 'blauwachtig'
}
}
htmlcode
}
#' @rdname colour.name
#' @export
color.name <- function(htmlcode) {
colour.name(htmlcode = htmlcode)
}
#' Draaien van tabel (pivoteren)
#'
#' Hiermee wordt een tabel gepivoteerd, d.w.z. een kwartslag gedraaid.
#' @param tbl Tabel die gepivoteerd moet worden
#' @param col.prefix Standaard is \code{"Kolom"}. Prefix van de nieuwe kolomnamen: Kolom1, Kolom2, enz.
#' @param firstcol.as.header Standaard is \code{FALSE}. De eerste kolom als kolomkoppen gebruiken. Met \code{TRUE} wordt eerst een kolom toegevoegd en wordt daarna pas gepivoteerd, zodat deze nieuwe kolom als kolomkoppen gebruikt wordt.
#' @export
#' @examples
#' \dontrun{
#' tbl %>%
#' group_by(ziekenhuis) %>%
#' summarise(amox = rsi(amox),
#' cipr = rsi(cipr)) %>%
#' pivot()
#' }
pivot <- function(tbl, col.prefix = 'Kolom', firstcol.as.header = FALSE) {
col.list <- paste0('Kolom', 1:nrow(tbl))
tbl <- tbl %>% as.data.frame()
if (firstcol.as.header == FALSE) {
tbl <- tbl %>% tibble::add_column(col.list, .before = 1)
} else if (n_distinct(tbl[, 1] < nrow(tbl))) {
stop('All values in first column must be unique to use it as header.')
}
tbl.pivot <- data.frame(col1.name = colnames(tbl)[2:ncol(tbl)])
colnames(tbl.pivot)[1] <- paste0(col.prefix, 0) # col.list[1]
# kolommen toevoegen
for (i in 1:nrow(tbl)) {
tbl.pivot <- tibble::add_column(tbl.pivot,
nieuwecol = tbl[i, 2:ncol(tbl)] %>% as.character())
colnames(tbl.pivot)[i + 1] <- tbl[i, 1] %>% as.character()
}
# kolomtypen gokken met readr
for (i in 1:ncol(tbl.pivot)) {
tbl.pivot[, i] <- readr::parse_guess(tbl.pivot[, i])
}
tbl.pivot %>% tibble::as.tibble()
}
#' Getallen octaal of hexadecimaal weergeven
#'
#' @param x Waarde(n).
#' @param from.base Standaard is \code{10} (decimaal). Grondtal van berekeningen; 8, 10 of 16.
#' @param to.base Grondtal van berekeningen; 8, 10 of 16.
#' @export
as.basenumber <- function(x, from.base = 10, to.base) {
if (from.base != 10) {
if (from.base == 8) {
class(x) <- 'octmode'
} else if (from.base == 16) {
class(x) <- 'hexmode'
} else {
stop('Invalid `from.base` - must be 8, 10 or 16.')
}
x <- x %>% as.integer()
}
if (to.base == 10) {
return(x)
} else if (to.base == 8) {
return(x %>% as.octmode())
} else if (to.base == 16) {
return(x %>% as.hexmode())
} else {
stop('Invalid `to.base` - must be 8, 10 or 16.')
}
}
#' Splits tekst en selecteer element
#' @inheritParams base::strsplit
#' @param element The nth element that should be returned.
#' @seealso \code{\link[base]{strsplit}}
#' @export strsplit.select
#' @examples
#' \dontrun{
#' tbl %>%
#' mutate(genus = strsplit.select(microorganisme, 1),
#' species = strsplit.select(microorganisme, 2))
#' }
strsplit.select <- function(x, element, split = " ", fixed = FALSE, perl = FALSE, useBytes = FALSE) {
sapply(strsplit(x,
split,
fixed = fixed,
perl = perl,
useBytes = useBytes
),
"[",
element)
}
classCaption <- function(obj, title_and_lvls = TRUE, sep = '->') {
classes <- obj %>% class()
c <- paste0(classes %>% rev() %>% concat(sep))
c <- gsub(paste0('factor', sep, 'ordered'), 'ord.factor', c)
if (title_and_lvls == TRUE) {
if (!is.null(levels(obj))) {
c <- paste0(c, ', with ', length(levels(obj)), ' levels')
}
if ('mic' %in% classes) {
c <- paste0('MIC values (', c, ')')
} else if ('rsi' %in% classes) {
c <- paste0('AB interpretations (', c, ')')
} else if ('tbl_df' %in% classes) {
if ('grouped_df' %in% classes) {
c <- paste0('grouped tibble (', c, ')')
} else {
c <- paste0('tibble (', c, ')')
}
} else if ('data.table' %in% classes) {
c <- paste0('DT (', c, ')')
} else if ('ggplot' %in% classes) {
if ('certedata_plot2' %in% classes) {
c <- paste0('certedata plot (', c, ')')
} else {
c <- paste0('ggplot2 plot (', c, ')')
}
} else if ('ggproto' %in% classes) {
c <- paste0('ggplot2 environment (', c, ')')
}
}
c
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.