R/plot2.R
In msberends/certedata: Tools for Data Analysis at Certe
Defines functions
plot2
Documented in
plot2
# ==================================================================== #
# 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. #
# ==================================================================== #
#' Grafiek van tabel of reeks
#'
#' Grafiek van tabel of reeks met Certe-kleuren. De data wordt automatsch geinterpreteerd en zonodig getransformeerd voordat de grafiek getekend wordt. \cr
#' Voor \code{x}, \code{y}, \code{x.category}, \code{y.category} en \code{datalabels} wordt \code{\link[rlang]{quasiquotation}} ondersteund. \cr
#' Geldige types (\code{type}) zijn \code{"bar"}, \code{"barpercent"}, \code{"boxplot"}, \code{"column"}, \code{"density"}, \code{"frequency"}, \code{"histogram"}, \code{"line"}, \code{"lollipop"}, \code{"point"}, \code{"rsi"} en \code{"mic"}. \cr \cr De \code{plot2.*}-functies zijn hier wrappers van.
#' @rdname plot2
#' @name plot2
#' @aliases plot2 plot2.bar plot2.barpercent plot2.boxplot plot2.column plot2.line plot2.point plot2.mic plot2.rsi plot2.density plot2.frequency plot2.histogram
#' @param data \code{data.frame} met gegevens.
#' @param x Standaard is eerste kolom van \code{data}. Naam van kolom (als tekst) met gegevens voor de x-as. Wanneer in deze kolom waarden meerdere keren voorkomen, worden daarvan de waarden van \code{y} bij elkaar opgeteld.
#' @param y Standaard is tweede of derde kolom van \code{data}. Naam van kolom (als tekst) met gegevens voor de y-as. Het is ook mogelijk om hier namen aan te geven, om de tekst in de legenda aan te passen; zie voorbeelden. Niet-numerieke waarden worden getransformeerd met \code{\link{as.double}}.
#' @param y.category Standaard is tweede kolom van \code{data}. Naam van kolom (als tekst) met gegevens voor de y-as.
#' @param x.category Standaard is \code{NA}. Splitsen in verschillende plots door middel van \code{\link[ggplot2]{facet_wrap}(scales = "free")}. Zie aldaar voor meer parameters.
#' @param type Standaard is \code{"column"}, in tegenstelling tot de standaard \code{type = "p"} van \code{\link{plot}}. Geldige opties zijn \code{"bar"} (\code{"b"}), \code{"barpercent"}, \code{"boxplot"} (\code{"box"}), \code{"column"} (\code{"c"}, \code{"col"}), \code{"density"} (\code{"d"}, \code{"dens"}), \code{"frequency"} (\code{"f"}, \code{"freq"}), \code{"histogram"} (\code{"h"}, \code{"hist"}), \code{"line"} (\code{"l"}), \code{"lollipop"}, \code{"point"} (\code{"p"}), \code{"rsi"} en \code{"mic"}.
#' @param x.title,y.title Standaard is de kolomnaam van \code{x} of \code{y}. Beschrijving van de x- en y-as. Laat deze ongedefinieerd om de kolomtitels van de data te gebruiken. Tekst tussen *enkele sterren* of _underscores_ wordt cursief gemaakt, tekst tussen **dubbele sterren** wordt vet gemaakt.
#' @param fun Standaard is \code{\link{portion_df}}. Functie die gebruikt wordt om data te transformeren voor \code{plot2.rsi}. Geldige opties zijn \code{\link{portion_df}} en \code{\link{count_df}}.
#' @param translate_ab Standaard is \code{"trivial_nl"}, zie \code{\link{portion_df}}.
#' @param minimum Standaard is \code{30}, zie \code{\link{portion_df}}.
#' @param title Standaard is \code{NA}, waarmee de asnamen van y en x weergegeven worden als "y per x". Titel van de grafiek. Tekst tussen *enkele sterren* of _underscores_ wordt cursief gemaakt, tekst tussen **dubbele sterren** wordt vet gemaakt. De teksten \code{n()} en \code{n_distinct(kolomnaam)} worden vertaald.
#' @param subtitle Standaard is leeg. Ondertitel van de grafiek. Tekst tussen *enkele sterren* of _underscores_ wordt cursief gemaakt, tekst tussen **dubbele sterren** wordt vet gemaakt. De teksten \code{n()} en \code{n_distinct(kolomnaam)} worden vertaald.
#' @param caption Standaard is leeg. Bijschrift van de grafiek. Gebruik \code{caption = ID()} om een \code{\link{ID}} te maken van standaard 6 tekens.
#' @param tag Standaard is leeg. Bovenschrift van de grafiek. Dit komt links bovenin de grafiek, is vetgedrukt en groter dan de titel.
#' @param title_maxlength Standaard is \code{60}. Maximale aantal tekens op een regel.
#' @param subtitle_maxlength Standaard is \code{60}. Maximale aantal tekens op een regel.
#' @param na.replace Standaard is \code{"(onbekend)"}. De tekst die geplaatst wordt in plaats van \code{NA} in de variabelen \code{x}, \code{x.category} en \code{y.category}. In geval van \code{plot2.calendar} is dit de kleur die gegeven wordt aan dagen met missende informatie.
#' @param na.rm Standaard is \code{FALSE}. Verwijderen van alle \code{NA}'s in de variabelen \code{x}, \code{y}, \code{x.category} en \code{y.category}.
#' @param x.category.fill Standaard is \code{NA}; doorzichtig. Kleur die doorgegeven wordt aan \code{\link{colourpicker}}.
#' @param x.category.position Standaard is \code{"top"}. Geldige opties zijn \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}.
#' @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.repeat.lbls.x Standaard is \code{TRUE}. Herhalen van de x-aslabels bij elke deelgrafiex.
#' @param x.category.repeat.lbls.y Standaard is \code{TRUE}. Herhalen van de y-aslabels bij elke deelgrafiek.
#' @param x.category.drop Standaard is \code{FALSE}. Verwijderen van factor levels die niet voorkomen in de data.
#' @param x.category.nrow Standaard is leeg, waardoor het automatisch wordt bepaald door \code{link[ggplot2]{facet_wrap}}. Aantal rijen met grafieken.
#' @param x.category.margin Standaard is 3.5. Marge van de tekst van \code{x.category}.
#' @param x.category.relative Standaard is \code{FALSE}. Hiermee wordt de breedte van grafieken afgestemd op de beschikbare waarden van de x-as.
#' @param x.date_breaks Standaard is \code{"1 month"}. Datumafstand op x-as, zoals \code{"2 weeks"} of \code{"10 years"}.
#' @param x.date_labels Standaard is \code{"mmm"}. Datumlabels op x-as. Wordt geëvalueerd met \code{\link{date_generic}}, dus ondersteunt ook \code{"d mmmm yyyy"}.
#' @param y.category.focus Standaard is leeg. Een waarde die voorkomt in \code{data$y.category} om te benadrukken. De andere waarden in \code{data$y.category} worden grijs gemaakt, en de benadrukte kleur is het eerste element van \code{colours}.
#' @param colours Standaard is \code{"certe"}. De standaard optie kan ook ingesteld worden met \code{options(plot2.colours = "gekozen_kleuren")}. Een tekst of vector van tekst die doorgegeven wordt aan \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{NA}, waardoor het uitlijnen berekend wordt op basis van \code{x.lbl.angle}. Andere geldige opties zijn \code{"left"}, \code{"center"} en \code{"right"}. Deze kunnen afgekort worden.
#' @param x.lbl.italic Standaard is \code{FALSE}. De categorieën van de x-as cursief maken. Dit is nodig bij namen van micro-organismen.
#' @param x.position Standaard is \code{"bottom"}. Geldige opties zijn \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}. Verplaatst de astitel en de astekst.
#' @param x.max Standaard is \code{10} bij \code{plot2.barpercent} en \code{NA} bij de rest. Maximaal aantal verschillende waarden op de x-as.
#' @param x.max.txt Standaard is \code{"(rest, x \%n)"}. Tekst die weergegeven wordt bij waarden op de x-as die buiten \code{x.max} vallen. Gebruik \code{"\%n"} om het aantal overige categorieën weer te geven.
#' @param x.remove Standaard is \code{FALSE}. De eenheden van x-as verwijderen. Om de \emph{tekst} (label) van de x-as te verwijderen, gebruik \code{x.title = ""}.
#' @param y.remove Standaard is \code{FALSE}. De eenheden van y-as verwijderen. Om de \emph{tekst} (label) van de y-as te verwijderen, gebruik \code{y.title = ""}.
#' @param y.24h Standaard is \code{FALSE}. De primaire lijnen van de y-as per 24 uur weergeven.
#' @param y.age Standaard is \code{FALSE}. De primaire lijnen van de y-as per leeftijdsgroep weergeven (zie \code{\link{age.group}}).
#' @param y.percent Standaard is \code{FALSE}. Toont de y-as als percentage.
#' @param y.percent.break Standaard is \code{10}. Labels worden geplaatst op elke \code{y.percent.break} procent.
#' @param y.scale Standaard is automatisch. Hiermee kan de schaal van de y-as aangepast worden, met bijvoorbeeld \code{y.scale = c(0, 25)}. Standaard wordt in tegenstelling tot \code{ggplot} wordt altijd \code{y = 0} weergegeven. De hoogste waarde op de y-as is standaard 1,25x de hoogst voorkomende y-waarde en de laagste waarde op de y-as is standaard 0 (of 1,25x de laagst voorkomende y-waarde wanneer dit lager is dan 0).
#' @param y.position Standaard is \code{"left"}, behalve bij \code{type = "barpercent"}. Geldige opties zijn \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}. Verplaatst de astitel en de astekst.
#' @param sort.x,sort.y.category,sort.x.category Standaard is \code{TRUE}. Sorteren van de \code{x} en/of \code{y.category} en/of \code{x.category} door deze te transformeren naar een geordende \code{\link{factor}}. Geldige waarden zijn: \cr
#' - \code{TRUE}, bij factors op levels sorteren, anders zoals \code{"asc"} sorteren. \cr
#' - \code{FALSE}, zoals volgorde in de data voortkomt sorteren. \cr
#' - \code{NULL}, helemaal niet sorteren/transformeren \cr
#' - \code{"asc"} of \code{"alpha"}, oplopend alfabetisch sorteren; \emph{ascending}. \cr
#' - \code{"desc"}, aflopend alfabetisch sorteren; \emph{descending}. \cr
#' - \code{"order"}, zoals \code{FALSE} sorteren. \cr
#' - \code{"freq"}, aflopend volgens de frequentie (\code{summarise_function}) van \code{y} sorteren (hoogste waarde eerst). \cr
#' - \code{"freq-asc"}, oplopend zoals \code{"freq"} sorteren (laagste waarde eerst). \cr
#' @param datalabels Standaard is \code{TRUE}, wat de waarden weergeeft van \code{y}. Geeft datalabels weer bij de kolommen, lijnen of punten. Dit kan een kolomnaam van \code{data} zijn, of een lijst met waarden. Gebruik \code{datalabels = FALSE} of \code{datalabels = NA} om geen datalabels weer te geven.
#' @param datalabels.round Standaard is \code{if_else(y.percent == FALSE, 2, 1)}. Aantal decimalen waarop \code{datalabels} afgerond wordt, wanneer dit (decimale) getallen zijn.
#' @param datalabels.fill Standaard is \code{'white'}. De achtergrondkleur van de labels die doorgegeven wordt aan \code{\link{colourpicker}}. Gebruik \code{datalabels.fill = NA} om geen achtergrond weer te geven.
#' @param summarise_function Standaard is \code{sum}. De functie die gebruikt wordt voor \code{link{summarise}} om de waarden van \code{y} te berekenen wanneer waarden van \code{x} vaker voorkomen. Kan ook uit een ander pakket komen: \code{plot2(summarise_function = base::mean)}.
#' @param stacked Standaard is \code{FALSE}. Met \code{FALSE} worden de kolommen naast elkaar geplaatst, in plaats van op elkaar.
#' @param stackedpercent Standaard is \code{FALSE}. Hiermee kan een 100\% gestapelde grafiek gemaakt worden.
#' @param horizontal Standaard is \code{FALSE}. Horizontale orientatie van de kolommen. Met \code{TRUE} worden er horizontale balken weergegeven.
#' @param reverse Standaard is \code{horizontal}, waardoor de waarde van \code{horizontal} overgenomen wordt. Hiermee worden gestapelde balken omgekeerd. Dit is soms nodig om de legenda synchroon te houden met de kleuren van de balken. Kan ook \code{TRUE} of \code{FALSE} zijn.
#' @param smooth Standaard is \code{FALSE}. Lijnen vloeiend weergeven.
#' @param size Standaard is \code{if_else(type == "line", 0.75, 2)}. Dikte van de lijnen in geval van een lijngrafiek en punten in geval van een puntgrafiek.
#' @param bins Standaard is \code{20} of, wanneer dit lager is, het unieke aantal waarden gedeeld door 3. Bij een histogram het aantal 'bins'.
#' @param width Standaard is automatisch. De breedte van kolommen en dergelijke.
#' @param show.mean Standaard is \code{FALSE}. Bij boxplots de gemiddelde lijn ook weergeven.
#' @param break.S Standaard is \code{NA}. De hoogste MIC die geïnterpreteerd wordt als S.
#' @param break.R Standaard is \code{break.S}. De laagste MIC die geïnterpreteerd wordt als R.
#' @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 legend.title Standaard is \code{""}. Titel van de legenda.
#' @param print Standaard is \code{FALSE}. Hiermee wordt de grafiek direct met \code{print} weergegeven. Met \code{FALSE} kan de output gebruikt worden om door te geven aan een variabele.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt moet worden voor tekst in de grafiek. Om alle lettertypen te kunnen gebruiken die momenteel in Windows geïnstalleerd zijn, moet de functie \code{\link{install.fonts}} eerst eenmalig gebruikt worden.
#' @param text.factor Standaard is \code{1}. Factor van de grootte van alle tekst.
#' @param format.NL Standaard is \code{Sys.isdecimalcomma()}, zie \code{\link{Sys.isdecimalcomma}}. Getallen Nederlands weergeven, met een komma als decimaal scheidingsteken.
#' @param ... Parameters voor oudere versies, die intern vertaald worden.
#' @param misses.data,misses.x,misses.y,misses.y.category,certe_theme Wordt alleen intern gebruikt.
#' @export
#' @keywords grafiek chart plot data x y y.category type x.title,y.title title subtitle colour.list x.lbl.angle x.lbl.align x.remove y.remove y.24h y.age y.percent y.scale datalabels datalabels.round stacked stackedpercent horizontal smooth size bins legend.position print font.family format.NL
#' @return Een \code{ggplot}-model.
#' @seealso \code{\link{plot2.save}} om een grafiek direct op te slaan. \cr
#' \code{\link{plot2.map_old}} om een prevalentiegrafiek met Google Maps te maken. \cr
#' \code{\link{plot2.map}} om een GIS-data te gebruiken voor ruimtelijke analyse. \cr
#' \code{\link{plot2.pie}} om een taartgrafiek te maken.
#'
#' @examples
#' \dontrun{
#' plot2.column(mmb.orders, 'jaar', 'aantal orders')
#'
#'
#' # Direct vanuit dplyr:
#'
#' df %>%
#' group_by(jaar, specialisme) %>%
#' summarise(aantal = n()) %>%
#' plot2(type = "column")
#'
#' # Legenda gedefinieerde namen geven:
#' df %>%
#' filter(...) %>%
#' group_by(...) %>%
#' summarise(aantal = n()
#' monsters = n_distinct(ordernr)) %>%
#' plot2(y = c('Aantal orders' = 'aantal',
#' 'Aantal monsters' = 'monsters'),
#' title = 'Aanvragen in 2018',
#' type = 'c')
#'
#' # Gevoeligheidsanalyse, maakt gebruik van AMR::portion_df
#' # kolommen `interpretatie`, `ab` en `waarde` worden hierdoor standaard gemaakt.
#' septic_patients %>%
#' select(hospital_id, amox, fosf, nitr, cipr) %>%
#' plot2.rsi(x = hospital_id, x.category = ab)
#' }
plot2 <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
type = 'column',
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.remove = FALSE,
x.position = 'bottom',
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
horizontal = FALSE,
reverse = horizontal,
smooth = FALSE,
size = if_else(type == 'line', 0.75, 2),
bins = NULL,
width = NULL,
show.mean = FALSE,
break.S = NA,
break.R = break.S,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
misses.data = FALSE,
misses.x = FALSE,
misses.y = FALSE,
misses.y.category = FALSE,
misses.datalabels = FALSE,
certe_theme = TRUE,
x.lbl = NA,
...) {
if (NROW(data) == 0) {
warning("No observations to plot.")
return(invisible())
}
# backward compatibility en typfouten ----
via_wrapper <- FALSE
dots <- list(...) %>% unlist()
if (length(dots) != 0) {
dots.names <- dots %>% names()
if ('via_wrapper' %in% dots.names) {
via_wrapper <- dots[which(dots.names == 'via_wrapper')]
}
if ('summarise_function_text' %in% dots.names) {
summarise_function_text <- dots[which(dots.names == 'summarise_function_text')]
}
if ('legend.location' %in% dots.names) {
legend.position <- dots[which(dots.names == 'legend.location')]
}
if ('colour.list' %in% dots.names) {
colours <- dots[which(dots.names == 'colour.list')]
}
if ('colors' %in% dots.names) {
colours <- dots[which(dots.names == 'colors')]
}
if ('color' %in% dots.names) {
colours <- dots[which(dots.names == 'color')]
}
if ('titel' %in% dots.names) {
title <- dots[which(dots.names == 'titel')]
}
if ('subtitel' %in% dots.names) {
subtitle <- dots[which(dots.names == 'subtitel')]
}
if ('xas.lbl' %in% dots.names) {
x.title <- dots[which(dots.names == 'xas.lbl')]
}
if ('xas.lbl.hoek' %in% dots.names) {
x.lbl.angle <- dots[which(dots.names == 'xas.lbl.hoek')]
}
if ('yas.lbl' %in% dots.names) {
y.title <- dots[which(dots.names == 'yas.lbl')]
}
if ('y.lbl' %in% dots.names) {
y.title <- dots[which(dots.names == 'y.lbl')]
}
if ('yas.categorie' %in% dots.names) {
y.category <- dots[which(dots.names == 'yas.categorie')]
}
if ('x.sort' %in% dots.names) {
sort.x <- dots[which(dots.names == 'x.sort')]
}
if ('y.category.sort' %in% dots.names) {
sort.y.category <- dots[which(dots.names == 'y.category.sort')]
}
if ('x.category.sort' %in% dots.names) {
sort.x.category <- dots[which(dots.names == 'x.category.sort')]
}
if ('x.category.repeat.lbls' %in% dots.names) {
x.category.repeat.lbls.y <- dots[which(dots.names == 'x.category.repeat.lbls')]
}
if ('nrow' %in% dots.names) {
x.category.nrow <- dots[which(dots.names == 'nrow')]
}
if ('legend.lbl' %in% dots.names) {
legend.title <- dots[which(dots.names == 'legend.lbl')]
}
if ('sort.column' %in% dots.names) {
stop('`sort.column` is no longer valid, use `sort.x` or `sort.y.category` instead.')
}
if ('sort.desc' %in% dots.names) {
stop('`sort.desc` is no longer valid, use `sort.x` or `sort.y.category` instead.')
}
}
if (!is.na(x.lbl)) {
x.title <- x.lbl
}
x.date_labels <- date_generic(x.date_labels)
if (certe_theme == FALSE) {
if (colours == "certe") {
colours <- "ggplot"
}
if (missing(datalabels) | misses.datalabels == TRUE) {
datalabels <- FALSE
}
}
if (via_wrapper == FALSE) {
# quasiquotation
if (!missing(x) & !misses.x) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y) & !misses.y) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category) & !misses.y.category) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
y.category.focus <- quasiquotate(deparse(substitute(y.category.focus)), y.category.focus)
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
}
# onmogelijke keuzen blokkeren ----
if ("sf" %in% class(data)) {
stop('Use `plot2.map` for spatial analysis.')
}
if (type == "rsi" & !all(c("interpretatie", "ab", "waarde") %in% colnames(data))) {
stop("Use plot2.rsi for resistance analysis.")
}
if (sum(y.percent, y.24h, y.age) > 1) {
stop('`y.percent`, `y.24h` and/or `y.age` cannot be used together.')
}
if (!(x.lbl.angle %in% c(0:360))) {
stop('No valid angle for the x-axis, must be 0-360.')
}
if (length(x) > 1 & (stacked == TRUE | stackedpercent == TRUE)) {
stop('`stacked` and `stackedpercent` cannot be used when there is more than 1 x-axis.')
}
if (any(colnames(data) %like% '[()<>{}\\/]')) {
warning('Possibly invalid variable name(s) which may lead to missing values.')
}
if (any(colours %>% class != 'character')) {
stop('`colours` must be a character or a character vector.')
}
if (text.factor < 0.1 | text.factor > 10) {
stop('`text.factor` must be a number between 0.1 and 10.')
}
if (!is.na(x.category)) {
if (!x.category %in% colnames(data)) {
stop('This variable does not exist: ', x.category)
}
}
allowed_sorting <- c(TRUE, FALSE, NULL, 'asc', 'desc', 'freq', 'freq-asc', 'freq-desc',
'infreq', 'infreq-asc', 'infreq-desc', 'inorder', 'order')
if (length(sort.x) > 1
| !all(sort.x %in% allowed_sorting)) {
stop('Invalid value for `sort.x`: ', sort.x %>% concat(', '))
}
if (length(sort.y.category) > 1
| !all(sort.y.category %in% allowed_sorting)) {
stop('Invalid value for `sort.y.category`: ', sort.y.category %>% concat(', '))
}
if (length(sort.x.category) > 1
| !all(sort.x.category %in% allowed_sorting)) {
stop('Invalid value for `sort.x.category`: ', sort.x.category %>% concat(', '))
}
type.input <- type
if (type %in% c('c', 'col', 'rsi', 'mic')) {
type <- 'column'
horizontal <- FALSE
}
if (type %in% c('b', 'lollipop')) {
type = 'bar'
}
if (type == 'box') {
type = 'boxplot'
}
if (type == 'l') {
type <- 'line'
}
if (type == 'm') {
type <- 'map'
}
if (type == 'p') {
type <- 'point'
}
if (type %in% c('h', 'hist', 'histogram', 'f', 'freq', 'freqency')) {
type <- 'frequency' # wordt later "histogram"
}
if (type %in% c('d', 'dens')) {
type <- 'density' # wordt later "histogram"
}
if (!type %in% c('area', 'column', 'bar', 'barpercent', 'line', 'path', 'point', 'frequency', 'density', 'boxplot', 'map')) {
stop('`plot2` does not recognise type "', type.input, '".')
}
if (type == 'boxplot' & !missing(y.category) & !is.na(y.category)) {
stop('Type "', type.input, '" is incompatible with `y.category`. Use `x` to split groups.')
}
if (horizontal == TRUE & type %in% c('density', 'frequency', 'mic')) {
# hier ook boxplot bij??
stop('Horizontal view is incompatible with type ', type, '.')
}
if (type == 'bar') {
type <- 'column'
horizontal <- TRUE
}
if (type == 'barpercent') {
horizontal <- TRUE
y.percent <- TRUE
y.category <- NA
y.position <- 'right'
}
# alle data transformeren, schatten hoe grafiek moet worden o.b.v. input ----
x.remove.bak <- x.remove
variabelen <- plot2.variables(data,
x,
y,
y.category,
x.category,
type,
(missing(data) | misses.data),
(missing(x) | misses.x),
(missing(y) | misses.y),
(missing(y.category) | misses.y.category),
sort.x,
sort.y.category,
sort.x.category,
horizontal,
datalabels,
x.max,
x.max.txt,
summarise_function,
summarise_function_text,
na.replace,
na.rm)
data <- variabelen$data
grafiek <- variabelen$grafiek
x <- variabelen$x
y <- variabelen$y
y.category <- variabelen$y.category
x.remove <- variabelen$x.remove
meerdere_series <- variabelen$meerdere_series
datalabels.show <- variabelen$datalabels.show
datalabels <- variabelen$datalabels
if (!is.null(y.category.focus)) {
if (!y.category.focus %in% (data %>% pull(y.category))) {
stop("value '", y.category.focus, "' for `y.category.focus` not found in data$", y.category, ".", call. = FALSE)
}
}
###
# print(data)
# print(grafiek$data)
# if (type.input == 'rsi') {
# data <- data %>% filter_at(vars(x), any_vars(!is.na(.)))
# grafiek$data <- data
# datalabels <- datalabels[1:3]
# }
if (is.na(x.lbl.align)) {
# berekenen wat beter is qua uitlijning
if (x.lbl.angle %in% c(0:10, 171:190, 351:360)) {
xas.align <- 0.5 # midden
}
if (x.lbl.angle %in% c(191:350)) {
xas.align <- 0 # links
}
if (x.lbl.angle %in% c(11:170)) {
xas.align <- 1 # rechts
}
} else {
# als uitlijnen ingesteld is, dan zo hanteren
if (x.lbl.align %in% c('l', 'left')) {
xas.align <- 0
} else if (x.lbl.align %in% c('c', 'center')) {
xas.align <- 0.5
} else if (x.lbl.align %in% c('r', 'right')) {
xas.align <- 1
} else {
stop('No valid value for `x.lbl.align`, must be "left", "center", or "right".')
}
}
y.percent.break <- y.percent.break / 100
histdata <- NULL
if (meerdere_series == FALSE) {
# Enkele serie ------------------------------------------------------------
if (stackedpercent == TRUE | stacked == TRUE) {
warning("`stackedpercent` and `stacked` will be ignored in plots with only one category.", call. = FALSE)
}
if (length(colours) == data %>% pull(x) %>% n_distinct()) {
colour.list <- colours %>% colourpicker()
colour.list.fill <- colours %>% colourpicker(length = 1, opacity = 0.9)
} else {
colour.list <- colourpicker(colours[1], length = 1)
colour.list.fill <- colourpicker(colours[1], length = 1, opacity = 0.9)
}
colour.list.bak <- colour.list
# kleuren van MIC's
if (type.input == 'mic') {
if (AMR::is.mic(data$level) & (!is.na(break.S) | !is.na(break.R))) {
data_mic <- data %>% mutate(breaks = as.double(level),
col = 'certeroze')
if (!is.na(break.R)) {
# alles lager dan break.R geel maken
data_mic <- data_mic %>%
mutate(col = if_else(breaks < break.R, 'certegeel', col))
if (is.na(break.S)) {
break.S <- break.R / 2 # 1 stap lager dan R
}
}
if (!is.na(break.S)) {
# alles vanaf break.S groen maken
data_mic <- data_mic %>%
mutate(col = if_else(breaks <= break.S, 'certegroen', col))
}
colour.list = colourpicker(data_mic$col)
}
}
if (type == 'point') {
grafiek <- grafiek +
geom_point(colour = colour.list,
size = size,
na.rm = TRUE)
datalabels.show <- FALSE
} else if (type == 'line') {
if (smooth == TRUE) {
grafiek <- grafiek +
geom_smooth(
aes_string(x = x,
y = y,
group = 1),
stat = "smooth",
method = 'lm',
span = 0.1,
se = FALSE,
colour = colour.list,
size = size,
na.rm = TRUE)
} else {
grafiek <- grafiek +
geom_line(
aes_string(x = x,
y = y,
group = 1),
colour = colour.list,
lineend = 'round',
size = size,
na.rm = TRUE)
}
datalabels.show <- FALSE
x.remove <- FALSE
} else if (type == 'path') {
if (smooth == TRUE) {
grafiek <- grafiek + geom_smooth(
aes_string(x = x,
y = y,
group = 1),
stat = "smooth",
method = 'lm',
span = 0.1,
se = FALSE,
colour = colour.list,
size = size,
na.rm = TRUE)
} else {
grafiek <- grafiek +
geom_path(
aes_string(x = x,
y = y,
group = 1),
colour = colour.list,
lineend = 'round',
size = size,
na.rm = TRUE)
}
datalabels.show <- FALSE
x.remove <- FALSE
} else if (type == 'area') {
grafiek <- ggplot(data) +
geom_area(aes_string(x = x,
y = y),
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels.show <- FALSE
} else if (type.input == "lollipop") {
grafiek <- grafiek +
geom_segment(
aes_string(xend = x, y = 0, yend = y),
colour = colour.list,
size = size / 4,
na.rm = TRUE) +
geom_point(
size = size,
color = colour.list[1],
na.rm = TRUE)
datalabels <- FALSE
datalabels.show <- FALSE
} else if (type %in% c('barpercent', 'column')) {
grafiek <- grafiek + geom_col(
colour = colour.list,
fill = colour.list,
width = ifelse(!is.null(width), width, 0.5),
na.rm = TRUE)
} else if (type %in% c('density', 'frequency')) {
histdata <- data %>% pull(y)
# NA's eruit, geeft anders warning: Removed 7 rows containing non-finite values (stat_density).
histdata <- histdata[!is.na(histdata)]
if (type == 'density') {
grafiek <- grafiek +
geom_density(inherit.aes = FALSE,
data = tibble(x = histdata),
mapping = aes(x = x),
colour = colour.list[1],
fill = paste0(colour.list[1], '15'),
na.rm = TRUE) # alpha toevoegen (00-AA)
} else if (type == 'frequency') {
if (is.null(bins)) {
bins <- min(20, n_distinct(histdata) / 3)
# minimaal aantal waarnemingen wanneer onder de 20 én onder n/3:
#bins <- max(min(20, n_distinct(histdata) / 3), n_distinct(histdata))
}
grafiek <- grafiek +
geom_histogram(inherit.aes = FALSE,
data = tibble(x = histdata),
mapping = aes(x = x),
colour = colour.list[1],
fill = paste0(colour.list[1], '15'), # alpha toevoegen (00-AA)
bins = bins,
na.rm = TRUE)
}
type <- 'histogram'
datalabels <- FALSE
datalabels.show <- FALSE
x.remove <- FALSE
# y-as
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.percent,
# breaks = seq(from = min(grafiek$data[, y]), to = max(grafiek$data[, y]), by = y.percent.break),
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.percent.EN,
# breaks = seq(from = min(grafiek$data[, y]), to = max(grafiek$data[, y]), by = y.percent.break),
position = y.position)
}
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.number.EN,
position = y.position)
}
}
} else if (type == 'boxplot') {
# alle waarden van x zijn uniek, dan geen categorieen van x gebruiken
data[, x] <- ''
grafiek <- ggplot(data, aes_string(x = x, y = y)) +
# whiskerlijn boven en onder:
stat_boxplot(geom = 'errorbar',
coef = 1.5, # 1.5 * IQR
colour = colour.list[1],
width = ifelse(!is.null(width), width, 0.5) * 0.66,
lwd = (size * 0.75) / 2.5) +
# boxplot met uitbijters:
geom_boxplot(
colour = colour.list[1],
fill = if_else(colours == 'certe', colourpicker('certeblauw3'), colour.list.fill[1]),
outlier.size = 1.5,
width = ifelse(!is.null(width), width, 0.5),
lwd = (size * 0.75) / 2.5, # line width, van hele vlak
fatten = 1.5, # factor om mediaan dikker te maken t.o.v. lwd
na.rm = TRUE)
x.remove <- TRUE
if (is.na(x.title)) {
x.title <- ''
}
}
if (length(y.scale) == 1 & type != 'histogram') {
# want length(NA) = 1
if (!is.na(y.scale)) {
stop('The scale for the y-axis cannot be a single value.')
} else {
# if (!is.numeric(data %>% pull(x))) {
# grafiek <- grafiek + scale_x_discrete(position = x.position,
# breaks = waiver())
# } else {
# grafiek <- grafiek + scale_x_continuous(position = x.position,
# breaks = waiver())
# }
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
labels = plot2.format.percent,
breaks = seq(from = min(0, 1.25 * min(data %>% pull(y))),
to = 1.25 * max(data %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
breaks = seq(from = min(0, 1.25 * min(data %>% pull(y))),
to = 1.25 * max(data %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
labels = plot2.format.percent.EN,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
labels = plot2.format.number.EN,
position = y.position)
}
}
}
}
} else if (type != 'histogram') {
# if (!is.numeric(data %>% pull(x))) {
# grafiek <- grafiek + scale_x_discrete(position = x.position,
# breaks = waiver())
# } else {
# grafiek <- grafiek + scale_x_continuous(position = x.position,
# breaks = waiver())
# }
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent.EN,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.number.EN,
position = y.position)
}
}
}
}
} else {
# Meerdere series ---------------------------------------------------------
# kleuren
colour.list <- colourpicker(colours,
length = data %>% pull(y.category) %>% n_distinct())
colour.list.fill <- colourpicker(colours,
length = data %>% pull(y.category) %>% n_distinct(),
opacity = 0.9)
colour.list.bak <- colour.list
if (!is.null(y.category.focus)) {
# put focussed on top by reordering the factor: focussed one must come last
seq.old <- c(1:length(levels(data %>% pull(y.category))))
seq.new <- seq.old[levels(data %>% pull(y.category)) != y.category.focus]
seq.new <- c(seq.new, seq.old[!seq.old %in% seq.new])
data[, y.category] <- forcats::lvls_reorder(data %>% pull(y.category), seq.new)
# set focus colour to first of colour.list
colour.list[levels(data %>% pull(y.category)) == y.category.focus] <- colour.list[1]
colour.list.fill[levels(data %>% pull(y.category)) == y.category.focus] <- colour.list[1]
# set grey to all others
colour.list[levels(data %>% pull(y.category)) != y.category.focus] <- "lightgrey"
colour.list.fill[levels(data %>% pull(y.category)) != y.category.focus] <- "lightgrey"
}
if (length(x) > 1) {
# colour.list <- rep(colour.certe(length = 1, palette = palette), length(x))
# colour.list.fill <- rep(colour.certe(length = 1, palette = palette, tint = 0.9), length(x))
colour.list <- colourpicker(colours[1], length = length(x))
colour.list.fill <- colourpicker(colours[1], length = length(x), opacity = 0.9)
}
# colour.list2 bevat zoveel waarden als nrow(data).
for (k in 1:length(colour.list)) {
if (k == 1) {
colour.list2 <- rep(colour.list[k], nrow(data) / length(colour.list))
} else {
colour.list2 <- c(colour.list2, rep(colour.list[k], nrow(data) / length(colour.list)))
}
}
if (type == 'point') {
grafiek <- ggplot(data) +
geom_point(aes_string(x = x, y = y, colour = y.category),
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels.show <- FALSE
} else if (type == 'line') {
if (smooth == TRUE) {
poly.min <- min(8, data %>% pull(x) %>% n_distinct() - 1)
grafiek <- ggplot(data) +
stat_smooth(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
se = FALSE,
method = 'lm',
size = size,
formula = y ~ poly(x, poly.min)) +
scale_colour_manual(values = colour.list)
} else {
grafiek <- ggplot(data) +
geom_line(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
lineend = 'round',
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
}
datalabels.show <- FALSE
} else if (type == 'path') {
if (smooth == TRUE) {
poly.min <- min(8, data %>% pull(x) %>% n_distinct() - 1)
grafiek <- ggplot(data) +
stat_smooth(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
se = FALSE,
method = 'lm',
size = size,
formula = y ~ poly(x, poly.min)) +
scale_colour_manual(values = colour.list)
} else {
grafiek <- ggplot(data) +
geom_line(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
lineend = 'round',
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
}
datalabels.show <- FALSE
} else if (type == 'area') {
grafiek <- ggplot(data) +
geom_area(aes_string(x = x,
y = y,
colour = y.category,
fill = y.category,
group = y.category),
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels.show <- FALSE
} else if (type.input == "lollipop") {
grafiek <- grafiek +
geom_segment(
aes_string(xend = x, y = 0, yend = y),
colour = colour.list[1],
size = size / 4,
na.rm = TRUE) +
geom_point(
aes_string(colour = y.category),
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels <- FALSE
datalabels.show <- FALSE
} else if (type == 'column') {
breedte.a <- 0.5
breedte.b <- 0.5
breedte.c <- breedte.b * 1.05
if (length(x) > 1) {
breedte.a <- 0.95
breedte.b <- 0.95
breedte.c <- 0.95
}
if (stackedpercent == TRUE) {
if (!missing(stacked) & stacked == FALSE) {
# warning("'stacked = FALSE' will be ignored because stackedpercent = TRUE.")
}
grafiek <- grafiek + geom_bar(width = ifelse(!is.null(width), width, breedte.a),
stat = 'identity',
position = position_fill(reverse = reverse),
na.rm = TRUE)
# +
# # hoeft geen plot2.format.percent.EN van
# scale_y_continuous(labels = plot2.format.percent,
# breaks = seq(from = 0, to = 1, by = y.percent.break),
# minor_breaks = NULL,
# position = y.position)
} else {
if (stacked == TRUE) {
grafiek <- grafiek + geom_bar(width = ifelse(!is.null(width), width, breedte.a),
stat = 'identity',
position = position_stack(reverse = reverse),
na.rm = TRUE)
} else {
grafiek <- grafiek + geom_bar(width = ifelse(!is.null(width), width, breedte.b),
stat = 'identity',
# kleine witte ruimte tussen kolommen:
position = position_dodge2(width = ifelse(!is.null(width), width * 1.05, breedte.c), preserve = "single"),
na.rm = TRUE)
}
}
} else if (type == 'boxplot') {
if (data %>% pull(y.category) %>% is.na() %>% all()) {
data[, y.category] <- ''
x.remove <- TRUE
x.title <- ''
}
grafiek <- ggplot(data, aes_string(x = x, y = y)) +
# whiskerlijn boven en onder:
stat_boxplot(geom = 'errorbar',
coef = 1.5, # 1.5 * IQR
colour = colour.list[1],
width = ifelse(!is.null(width), width, 0.5) * 0.66,
lwd = (size * 0.75) / 2.5) +
# boxplot met uitbijters:
geom_boxplot(
colour = colour.list[1],
fill = if_else(colours == 'certe', colourpicker('certeblauw3'), colour.list.fill[1]),
outlier.size = 1.5,
width = ifelse(!is.null(width), width, 0.5),
lwd = (size * 0.75) / 2.5, # line width, van hele vlak
fatten = 1.5, # factor om mediaan dikker te maken t.o.v. lwd
na.rm = TRUE)
}
if (length(y.scale) == 1) {
# want length(NA) = 1
if (!is.na(y.scale)) {
stop('The scale for the y-axis cannot be a single value.')
} else if (stackedpercent == FALSE) {
max_vars <- c(x, x.category)
max_vars <- max_vars[!is.na(max_vars)]
if (stacked == TRUE) {
# sum per groep om maximale y op as te bepalen
suppressWarnings(
maxdata <- data %>%
as.data.frame() %>%
as.tibble() %>%
mutate_if(is.factor, as.character) %>%
group_by_at(vars(max_vars)) %>%
summarise_at(vars(y), sum, na.rm = TRUE)
)
} else {
# max per groep om maximale y op as te bepalen
suppressWarnings(
maxdata <- data %>%
as.data.frame() %>%
as.tibble() %>%
mutate_if(is.factor, as.character) %>%
group_by_at(vars(max_vars)) %>%
summarise_at(vars(y), max, na.rm = TRUE)
)
}
maxdata[, y] <- maxdata %>% pull(y) %>% gsub(Inf, 0, .)
maxdata[, y] <- maxdata %>% pull(y) %>% as.double() # soms nodig, omdat er anders een tibble ontstaat met <chr>
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = plot2.format.percent,
breaks = seq(from = min(0, 1.25 * min(maxdata %>% pull(y))),
to = 1.25 * max(maxdata %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = plot2.format.percent.EN,
breaks = seq(from = min(0, 1.25 * min(maxdata %>% pull(y))),
to = 1.25 * max(maxdata %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = plot2.format.number.EN,
position = y.position)
}
}
}
} else {
# stackedpercent = TRUE, y.percent = FALSE (gewone data op een 100% gestapelde grafiek)
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.percent,
breaks = seq(from = 0, to = 1, by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent.EN,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.number.EN,
position = y.position)
}
}
}
}
# if (!is.numeric(data %>% pull(x))) {
# grafiek <- grafiek + scale_x_discrete(position = x.position,
# breaks = waiver())
# } else {
# grafiek <- grafiek + scale_x_continuous(position = x.position,
# breaks = waiver())
# }
if (length(x) > 1) {
grafiek <- grafiek +
facet_grid(~pull(data, x[2]), space = "free_x", switch = 'y')
if (y.category %in% x) {
legend.position <- 'none'
}
}
# kleuren
grafiek <- grafiek + scale_fill_manual(values = colour.list)
}
# X-as --------------------------------------------------------------------
if (is.null(histdata)) {
x_classes <- data %>% pull(x) %>% class()
} else {
x_classes <- histdata %>% class()
}
if ("Date" %in% x_classes) {
grafiek <- grafiek + scale_x_date(position = x.position,
date_breaks = x.date_breaks,
date_labels = x.date_labels)
} else if (any(c('POSIXct', 'POSIXlt') %in% x_classes)) {
grafiek <- grafiek + scale_x_datetime(position = x.position,
date_breaks = x.date_breaks,
date_labels = x.date_labels)
} else {
if (!is.numeric(data %>% pull(x))) {
grafiek <- grafiek + scale_x_discrete(position = x.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_x_continuous(labels = format2,
position = x.position)
} else {
grafiek <- grafiek + scale_x_continuous(labels = plot2.format.number.EN,
position = x.position)
}
}
}
# Rest --------------------------------------------------------------------
if (datalabels.show == TRUE) {
if (all(datalabels %>% is.double2())) {
datalabels <- datalabels %>% as.double()
}
if (type != 'boxplot') {
if (is.double(datalabels)) {
if (y.percent == TRUE) {
if (type == 'barpercent') {
datalabels <- paste0(datalabels %>%
format2(datalabels.round, format.NL = format.NL),
' (',
data %>%
pull(y) %>%
as.percent() %>%
format2(round = datalabels.round, format.NL = format.NL),
')')
} else {
datalabels <- datalabels %>% as.percent() %>% format2(round = datalabels.round, format.NL = format.NL)
}
} else {
datalabels <- datalabels %>% format2(datalabels.round, format.NL = format.NL)
}
}
# waarden als tekst en 0 vervangen door ""
datalabels <- datalabels %>% as.character() %>% gsub('^0[.,0]*$', '', .)
grafiek <- plot2.datalabels(grafiek,
data,
x,
y,
datalabels,
datalabels.fill,
y.category,
stacked,
stackedpercent,
horizontal,
reverse,
font.family,
text.factor,
width)
} else if (type == 'boxplot') {
# if (horizontal == TRUE) {
# v <- 0.5
# h <- 1.75
# } else {
# v <- 1.75
# h <- 0.5
# }
#
# if (meerdere_series == TRUE) {
# data.boxplotlbl <- data %>%
# mutate(x = data %>% pull(y.category))
# } else {
# data.boxplotlbl <- data
# }
#
# data.boxplotlbl <- data.boxplotlbl %>%
# group_by(x = eval(x)) %>%
# summarise(n = paste('n =', format2(n())))
#
# grafiek <- grafiek +
# geom_text(
# data = data.boxplotlbl,
# aes(x = x,
# y = 0,
# label = n),
# inherit.aes = FALSE,
# size = 3 * text.factor,
# colour = colour.list[1],
# vjust = v, # iets onder y = 0
# hjust = h, # of iets links van y = 0 bij horizontal == TRUE
# fontface = 'italic',
# na.rm = TRUE)
}
}
if (show.mean == TRUE) {
# voor boxplots
x.initlijst <- integer(0)
if (meerdere_series == TRUE) {
x.aantallen <- data %>%
mutate(x = data %>% pull(y.category))
} else {
x.aantallen <- data
}
x.aantallen <- x.aantallen %>%
group_by(x = eval(x)) %>%
summarise(n())
#for (i in 1:n_distinct(data[, x])) {
for (i in 1:nrow(x.aantallen)) {
# aantallen toevoegen
x.initlijst <- c(x.initlijst, rep(i, x.aantallen[i, 2]))
}
if (meerdere_series == TRUE) {
data.boxplotmean <- data %>%
mutate(x = data %>% pull(y.category))
} else {
data.boxplotmean <- data
}
data.boxplotmean <- data.boxplotmean %>%
mutate(y = data.boxplotmean[, y]) %>%
group_by(x = eval(x)) %>%
mutate(gem.y = mean(y)) %>%
arrange(x) %>%
as.data.frame()
data.boxplotmean <- data.boxplotmean %>%
mutate(x.init = x.initlijst) %>%
mutate(x.voor = x.init - (0.75 / 2),
x.na = x.init + (0.75 / 2))
colour.list.mean <- colourpicker(colours, length = 3)[3]
if (colour.list.mean == colour.list[1]) {
colour.list.mean <- colourpicker('certeroze')
}
if (colours %like% '^rug') {
colour.list.mean <- colourpicker('black')
}
grafiek <- grafiek +
geom_segment(data = data.boxplotmean,
aes_string(
y = 'gem.y',
yend = 'gem.y',
x = 'x.voor',
xend = 'x.na'),
colour = colour.list.mean,
size = 0.5,
linetype = 5,
na.rm = TRUE)
}
if (meerdere_series == TRUE) {
if (data %>% pull(y.category) %>% n_distinct() == 1) {
# geen legenda wanneer er maar 1 item in staat
legend.position <- 'none'
y <- unique(data %>% pull(y.category))
}
}
t <- function(x) {
lang <- Sys.getlocale("LC_CTYPE")
if (x == 'en') {
if (lang %like% 'English') {
x <- 'and'
} else if (lang %like% 'German') {
x <- 'und'
# } else if (!lang %like% 'Dutch') {
# x <- '/'
}
}
if (x == 'per') {
if (lang %like% 'English') {
x <- 'per'
} else if (lang %like% 'German') {
x <- 'pro'
# } else if (!lang %like% 'Dutch') {
# x <- '/'
}
}
x
}
word_wrapper <- function(x, width, markdown = FALSE) {
paste(strwrap(x = x, width = width), collapse = ifelse(markdown, "<br>", "\n"))
}
x <- gsub("^n$", ifelse(stackedpercent == TRUE, "aandeel", "aantal"), x)
y <- gsub("^n$", ifelse(stackedpercent == TRUE, "aandeel", "aantal"), y)
if (!is.expression(title) && is.na(title) & type.input != 'barpercent') {
if (!is.na(x.category)) {
title <- toproper(paste(y, t('per'), x.category, t('en'), x), every = FALSE)
} else if (!is.na(y.category)) {
title <- toproper(paste(y, t('per'), x, t('en'), y.category), every = FALSE)
} else {
title <- toproper(paste(y, t('per'), x), every = FALSE)
}
} else if (!is.expression(title) && is.na(title) & type.input == 'barpercent') {
title <- ''
}
if (is.expression(title)) {
grafiek <- grafiek + labs(title = title)
} else if (title != '') {
if (grepl('n()', title, fixed = TRUE)) {
title <- gsub('n()', data %>% ungroup() %>% nrow() %>% format2(format.NL = format.NL), title, fixed = TRUE)
}
if (grepl('n_distinct[(].+[)]', title)) {
kolom <- regmatches(title, regexpr('[(].+[)]', title, perl = TRUE))
kolom <- substr(kolom, 2, nchar(kolom) - 1)
title <- gsub('n_distinct[(].+[)]', data %>% pull(kolom) %>% n_distinct() %>% format2(format.NL = format.NL), title)
}
if (title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
title <- markdown_bolditalic(title)
} else {
title <- word_wrapper(title, title_maxlength)
}
grafiek <- grafiek + labs(title = title)
}
if (is.expression(subtitle)) {
grafiek <- grafiek + labs(subtitle = subtitle)
} else if (subtitle != '') {
if (grepl('n()', subtitle, fixed = TRUE)) {
subtitle <- gsub('n()', data %>% ungroup() %>% nrow() %>% format2(format.NL = format.NL), subtitle, fixed = TRUE)
}
if (grepl('n_distinct[(].+[)]', subtitle)) {
kolom <- regmatches(subtitle, regexpr('[(].+[)]', subtitle, perl = TRUE))
kolom <- substr(kolom, 2, nchar(kolom) - 1)
subtitle <- gsub('n_distinct[(].+[)]', data %>% pull(kolom) %>% n_distinct() %>% format2(format.NL = format.NL), subtitle)
}
if (subtitle %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
subtitle <- markdown_bolditalic(subtitle)
} else {
subtitle <- word_wrapper(subtitle, subtitle_maxlength)
}
grafiek <- grafiek + labs(subtitle = subtitle)
}
if (is.expression(caption)) {
grafiek <- grafiek + labs(caption = caption)
} else if (caption != '') {
if (caption %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
caption <- markdown_bolditalic(caption)
}
grafiek <- grafiek + labs(caption = caption)
}
if (is.expression(tag)) {
grafiek <- grafiek + labs(tag = tag)
} else if (tag != '') {
if (tag %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
tag <- markdown_bolditalic(tag)
}
grafiek <- grafiek + labs(tag = tag)
}
# thema toepassen
if (certe_theme == TRUE) {
grafiek <- grafiek +
theme_certe(subtitle.colour = ifelse(type.input == 'mic',
colourpicker('certeblauw'),
colour.list.bak[1]),
x.lbl.angle = x.lbl.angle,
x.lbl.align = xas.align,
horizontal = horizontal,
font.family = font.family,
legend.position = legend.position,
text.factor = text.factor,
x.category.fill = colourpicker(x.category.fill),
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.margin = x.category.margin,
has_subtitle = !subtitle %in% c("", NA))
}
if (type == 'histogram') {
grafiek <- grafiek +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank())
}
# legenda - moet na certe theme, anders wordt theme(legend.title) opnieuw gedefinieerd
if (is.expression(legend.title)) {
grafiek <- grafiek + labs(colour = legend.title, fill = legend.title)
} else if (legend.title != '') {
if (legend.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
legend.title <- markdown_bolditalic(legend.title)
}
grafiek <- grafiek + labs(colour = legend.title, fill = legend.title)
} else {
grafiek <- grafiek + theme(legend.title = element_blank())
}
#
# X en Y assen
#
if (x.remove.bak == TRUE) {
# overrulen
x.remove <- TRUE
}
if (is.na(x.title)) {
if (!is.na(x.category)) {
grafiek <- grafiek + labs(x = toproper(paste(x.category, t('en'), x)))
} else {
grafiek <- grafiek + labs(x = toproper(x, intelligent = TRUE))
}
} else {
if (x.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
x.title <- markdown_bolditalic(x.title)
}
grafiek <- grafiek + labs(x = x.title)
}
if (x.remove == TRUE) {
grafiek <- grafiek +
theme(
axis.text.x = element_blank()
)
}
if (x.lbl.italic == TRUE) {
if (horizontal == FALSE) {
grafiek <- grafiek + theme(axis.text.x = element_text(face = 'italic'))
} else {
grafiek <- grafiek + theme(axis.text.y = element_text(face = 'italic'))
}
}
if (is.na(y.title)) {
grafiek <- grafiek + labs(y = toproper(y, intelligent = TRUE))
#} else if (y.title != '') {
} else {
if (y.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
y.title <- markdown_bolditalic(y.title)
}
grafiek <- grafiek + labs(y = y.title)
}
if (y.remove == TRUE) {
grafiek <- grafiek +
theme(
axis.text.y = element_blank()
)
}
# als schaal van y-as tot max 100% loopt dan secundaire lijnen verwijderen
# if (y.percent == TRUE & length(y.scale) > 1) {
# if (max(y.scale) == 1) {
# grafiek <- grafiek +
# theme(panel.grid.minor.y = element_blank())
# }
# }
if (!is.na(x.category)) {
scales <- 'fixed'
if (x.category.repeat.lbls.x == TRUE & x.category.repeat.lbls.y == TRUE) {
scales <- 'free'
} else if (x.category.repeat.lbls.y == TRUE) {
scales <- 'free_y'
if (horizontal == TRUE) {
scales <- 'free_x'
}
} else if (x.category.repeat.lbls.x == TRUE) {
scales <- 'free_x'
if (horizontal == TRUE) {
scales <- 'free_y'
}
}
if (is.na(x.category.nrow)) {
x.category.nrow <- NULL
}
if (any(data %>% pull(x.category) %>% is.na())) {
# drop is droppen van factors levels. Als dit FALSE is en de kolom bevat NA, geeft het een fout:
# Error in scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales)
x.category.drop <- TRUE
}
if (x.category.relative == TRUE) {
switch <- "x"
if (horizontal == TRUE) {
switch <- "y"
}
grafiek$data <- grafiek$data %>%
ungroup() %>%
mutate("x.category" = grafiek$data %>% pull(x.category))
grafiek <- grafiek +
facet_grid(cols = vars(x.category),
space = scales,
drop = x.category.drop,
scales = scales,
switch = switch)
} else {
grafiek <- grafiek +
facet_wrap(x.category,
scales = scales,
strip.position = x.category.position,
drop = x.category.drop,
nrow = x.category.nrow)
}
}
if (horizontal == TRUE) {
grafiek <- grafiek + coord_flip()
}
if (print == TRUE) {
print(grafiek)
} else {
# Class toevoegen
class(grafiek) <- c('certedata_plot2', class(grafiek))
grafiek
}
}
#' @rdname plot2
#' @export
plot2.column <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
reverse = FALSE, # omdat bij bar horizontal = FALSE
width = NULL,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = FALSE,
reverse = reverse,
width = width,
type = 'column',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.area <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
#stacked = TRUE,
#stackedpercent = FALSE,
reverse = FALSE, # omdat bij bar horizontal = FALSE
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
#stacked = stacked,
#stackedpercent = stackedpercent,
stacked = TRUE,
stackedpercent = FALSE,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = FALSE,
reverse = reverse,
type = 'area',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.bar <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
reverse = TRUE, # want bij bar horizontal = TRUE
width = NULL,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
if (!missing(datalabels)) {
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
}
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = TRUE,
reverse = reverse,
width = width,
type = 'column',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.barpercent <- function(data = NA,
x = NA,
y = NA,
x.title = NA,
y.title = '',
x.category = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = 10,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.scale = NA,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = 1,
datalabels.fill = 'white',
width = NULL,
summarise_function = sum,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.percent = TRUE,
y.scale = y.scale,
y.position = 'right',
y.remove = y.remove,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
width = width,
summarise_function = summarise_function,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
sort.x = 'freq-desc',
horizontal = TRUE,
type = 'barpercent',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.lollipop <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
size = 2,
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
reverse = TRUE, # want bij bar horizontal = TRUE
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = NA,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
size = size,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = TRUE,
reverse = reverse,
type = 'lollipop',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.line <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
smooth = FALSE,
size = 0.75,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
smooth = smooth,
size = size,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'line',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.path <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
smooth = FALSE,
size = 0.75,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
smooth = smooth,
size = size,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'path',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.point <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
size = 2,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
size = size,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'point',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.mic <- function(data = NA,
y = NA,
x = NA,
x.title = 'MIC-waarde',
y.title = 'Aantal',
title = 'Overzicht MIC-waarden',
subtitle = NA,
break.S = NA,
break.R = break.S,
...) {
if (is.na(subtitle)) {
subtitle <- deparse(substitute(data))
subtitle <- gsub('_mic$', '', subtitle)
if (subtitle %in% AMR::antibiotics$molis) {
subtitle <- abname_molis(subtitle)
}
}
plot2(data = data,
y = y,
x = x,
type = 'mic',
y.title = y.title,
x.title = x.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
break.S = break.S,
break.R = break.R,
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
...)
}
#' @rdname plot2
#' @export
plot2.rsi <- function(data = NA,
x = NA,
y.category = "interpretatie",
x.category = NA,
x.title = NA,
y.title = NA,
fun = portion_df,
translate_ab = "trivial_nl",
minimum = 30,
title = "Gevoeligheidsanalyse",
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = 1,
x.category.margin = 3.5,
x.category.relative = FALSE,
colours = "certe_rsi",
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = 1,
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = TRUE,
reverse = FALSE, # omdat bij bar horizontal = FALSE
legend.position = 'right',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# if (is.na(subtitle)) {
# subtitle <- deparse(substitute(data))
# subtitle <- gsub('_mic$', '', subtitle)
# if (subtitle %in% AMR::antibiotics$molis) {
# subtitle <- abname_molis(subtitle)
# }
# }
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
# if (!missing(y)) {
# y <- quasiquotate(deparse(substitute(y)), y)
# }
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
fun_name <- deparse(substitute(fun))
if (!fun_name %in% c("portion_df", "count_df")) {
stop("`fun` must be portion_df or count_df")
}
if (fun_name == "portion_df") {
if (missing(y.percent)) {
y.percent <- TRUE
}
if (missing(y.scale)) {
y.scale <- c(0, 1)
}
}
if (!missing(data)) {
if (!missing(x) & x != "ab") {
data <- data %>% group_by_at(x)
}
if (!is.na(x.category)) {
if (!x.category %in% c("ab", "antibiotica", "Antibiotic")) {
data <- data %>% group_by_at(x.category)
}
}
data <- fun(data, translate_ab = translate_ab, minimum = minimum)
colnames(data) <- gsub("^Interpretation$", "interpretatie",
colnames(data))
colnames(data) <- gsub("^Antibiotic$", "ab", colnames(data))
colnames(data) <- gsub("^(Percentage|Count|Value)$", "waarde",
colnames(data))
if (missing(x)) {
x <- "ab"
}
y <- "waarde"
}
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.position = x.position,
x.remove = x.remove,
x.max = x.max,
x.max.txt = x.max.txt,
y.remove = y.remove,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
reverse = reverse,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
via_wrapper = TRUE,
misses.data = missing(data),
misses.x = FALSE,
misses.y = FALSE,
...)
}
#' @rdname plot2
#' @export
plot2.boxplot <- function(data = NA,
x = NA,
y = NA,
x.title = NA,
y.title = NA,
x.category = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
datalabels = TRUE,
horizontal = FALSE,
show.mean = FALSE,
legend.position = 'top',
legend.title = '',
print = FALSE,
size = 2,
width = NULL,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.remove = y.remove,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
datalabels = datalabels,
horizontal = horizontal,
show.mean = show.mean,
legend.position = legend.position,
legend.title = legend.title,
print = print,
size = size,
width = width,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'boxplot',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' GIS-data plotten
#'
#' Hiermee kan GIS-data van \code{\link{get_map}} geplot worden.
#' @param y Naam van de antibioticumkolom.
#' @param y.scale Standaard is tussen 0 en 50\%. De schaal van y; in feite de schaal van de legenda.
#' @param colours Standaard is wit en Certe-roze. Twee kleuren voor het kleurenpalet van de grafiek; de overgang hiertussen wordt automatisch berekend. Zie \code{\link{colourpicker}}.
#' @param legend.title Standaard is \code{"\%IR"}. Titel van de legenda.
#' @inheritParams plot2
#' @export
plot2.map <- function(data,
y,
y.scale = c(0, 0.5),
title = '',
subtitle = '',
caption = '',
tag = '',
colours = c("white", colourpicker("certeroze")),
legend.title = "%IR",
legend.position = "right",
print = FALSE,
font.family = 'Calibri',
text.factor = 1) {
if (!"sf" %in% class(data)) {
stop("`data` must be a simple feature collection (class 'sf')", call. = FALSE)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!y %in% colnames(data)) {
stop('column `', y, '` does not exist in simple feature collection', call. = FALSE)
}
if (all(is.na(data %>% pull(y)))) {
stop('All values of `', y, '` are NA - the map would be blank.', call. = FALSE)
}
library(sf)
limit <- y.scale
if (max(y.scale) >= 1) {
y.scale <- seq(min(y.scale), 1, 0.25)
y.scale.lbl <- paste0(y.scale, "%")
} else {
y.scale <- seq(min(y.scale), max(y.scale), 0.1)
y.scale.lbl <- c(paste0(y.scale[1:length(y.scale) - 1] * 100, "%"),
paste0(">=", y.scale[length(y.scale)] * 100, "%"))
}
grafiek <- ggplot(data) +
geom_sf(aes_string(fill = y,
colour = y),
na.rm = TRUE) +
theme_certe(legend.position = legend.position,
font.family = font.family,
text.factor = text.factor) +
theme(axis.title = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major = element_line(colour = "white"),
axis.text = element_blank()) +
scale_fill_gradient(low = colours[1],
high = colours[2],
na.value = "gray90",
limit = limit,
breaks = y.scale,
labels = y.scale.lbl) +
scale_colour_gradient(low = colours[1],
high = colours[2],
na.value = "gray90",
limit = limit,
breaks = y.scale,
labels = y.scale.lbl)
if (title != '') {
if (title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
title <- markdown_bolditalic(title)
}
grafiek <- grafiek + labs(title = title)
}
if (subtitle != '') {
if (subtitle %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
subtitle <- markdown_bolditalic(subtitle)
}
grafiek <- grafiek + labs(subtitle = subtitle)
}
if (caption != '') {
grafiek <- grafiek + labs(caption = caption)
}
if (tag != '') {
grafiek <- grafiek + labs(tag = tag)
}
# legenda
if (legend.title != '') {
if (legend.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
legend.title <- markdown_bolditalic(legend.title)
}
grafiek <- grafiek + labs(colour = legend.title, fill = legend.title)
} else {
grafiek <- grafiek + theme(legend.title = element_blank())
}
if (print == TRUE) {
print(grafiek)
} else {
# Class toevoegen
class(grafiek) <- c('certedata_plot2', class(grafiek))
grafiek
}
}
#' @rdname plot2
#' @export
plot2.density <- function(y, x.title = 'Waarde', y.title = 'Dichtheid', y.percent = TRUE, ...) {
# quasiquotation
y <- quasiquotate(deparse(substitute(y)), y)
plot2(y = y,
type = 'density',
x.title = x.title,
y.title = y.title,
y.percent = y.percent,
...,
via_wrapper = TRUE)
}
#' @rdname plot2
#' @export
plot2.frequency <- function(y, x.title = '', y.title = 'Aantal', bins = NULL, ...) {
# quasiquotation
y <- quasiquotate(deparse(substitute(y)), y)
plot2(y = y,
type = 'frequency',
x.title = x.title,
y.title = y.title,
bins = bins,
...,
via_wrapper = TRUE)
}
#' @rdname plot2
#' @export
plot2.histogram <- function(y, x.title = '', y.title = 'Aantal', bins = NULL, ...) {
# quasiquotation
y <- quasiquotate(deparse(substitute(y)), y)
plot2(y = y,
type = 'frequency',
x.title = x.title,
y.title = y.title,
bins = bins,
...,
via_wrapper = TRUE)
}
#' @rdname plot2
#' @export
plot2.calendar <- function(data = NULL,
x = NULL,
y = NULL,
title = NULL,
subtitle = NULL,
x.title = "Week in de maand",
y.title = "Weekdag",
caption = '',
tag = '',
na.replace = "grey98",
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = FALSE,
x.category.repeat.lbls.y = FALSE,
x.category.margin = 3.5,
legend.position = "right",
legend.title = "",
colours = c("grey85", "certeblauw"),
certe_theme = TRUE,
font.family = "Calibri",
text.factor = 1,
print = TRUE,
...) {
if (NROW(data) == 0) {
warning("No observations to plot.")
return(invisible())
}
if (length(colours) != 2) {
stop("`colours` must be of length 2 for a calendar plot")
}
if (missing(data)) {
# no data
if (missing(x)) {
stop("`x` must be dates")
}
if (!"Date" %in% class(x) & !"POSIXct" %in% class(x)) {
stop("`x` must be dates")
}
if (missing(y)) {
data <- tibble(datum = x, aantal = 1) %>%
group_by(datum) %>%
summarise(aantal = sum(aantal))
x <- "datum"
y <- "aantal"
} else {
# x en y missen niet
if (!is.numeric(y)) {
stop("`y` must be numeric")
}
data <- tibble(datum = x, aantal = y)
x <- "datum"
y <- "aantal"
}
} else {
# data mist niet
if (!is.data.frame(data)) {
stop("`data` must be a data.frame")
}
if (is.null(x)) {
# zoeken naar datum kolom
for (i in 1:ncol(data)) {
if ("Date" %in% class(data %>% pull(i)) | "POSIXct" %in% class(data %>% pull(i))) {
x <- colnames(data)[i]
message("Using column `", x, "` for dates")
break
}
}
}
if (is.null(x)) {
stop("no date columns found")
} else if (is.null(y)) {
data <- data %>%
group_by_at(x) %>%
summarise(aantal = n())
y <- "aantal"
colnames(data)[1] <- "datum"
}
# if (!"Date" %in% class(x) & !"POSIXct" %in% class(x)) {
# stop("`x` must be dates")
# }
}
# missende datums aanvullen met NAs
eom <- function(date) {
# date character string containing POSIXct date
date.lt <- as.POSIXlt(date) # add a month, then subtract a day:
mon <- date.lt$mon + 2
year <- date.lt$year
year <- year + as.integer(mon==13) # if month was December add a year
mon[mon==13] <- 1
iso = ISOdate(1900+year, mon, 1, hour=0) #, tz = attr(date,"tz"))
result = as.POSIXct(iso) - 86400 # subtract one day
result + (as.POSIXlt(iso)$isdst - as.POSIXlt(result)$isdst)*3600
}
x_dates <- seq(as.Date(paste0(year(min(data$datum)), "-", month(min(data$datum), label = FALSE), "-01")),
as.Date(eom(max(data$datum))),
by = 1)
x_dates <- x_dates[!x_dates %in% data$datum]
x_dates <- tibble(datum = x_dates, aantal = NA_integer_)
data <- bind_rows(data, x_dates) %>%
arrange(datum) %>%
mutate(jaar = format2(datum, "yyyy"),
maand = factor(format2(datum, "mmmm"),
levels = format2(as.Date(paste0("2018-", 1:12, "-01")), "mmmm"),
ordered = TRUE),
weekinmaand = stringi::stri_datetime_fields(datum)$WeekOfMonth,
weekdag = factor(format2(datum, "ddd"),
# 1 januari 2018 was maandag
levels = rev(format2(as.Date(paste0("2018-01-0", 1:7)), "ddd")),
ordered = TRUE))
p <- ggplot(data) +
geom_tile(mapping = aes_string(x = "weekinmaand",
y = "weekdag",
fill = "aantal"),
colour = "grey80",
na.rm = TRUE) +
scale_x_continuous(breaks = 0:5,
labels = c("", 1:4, "")) +
scale_fill_gradient(low = colourpicker(colours[1]),
high = colourpicker(colours[2]),
na.value = na.replace,
guide = "colourbar")
if (certe_theme == TRUE) {
p <- p +
theme_certe(subtitle.colour = colourpicker(colours[2]),
font.family = font.family,
legend.position = legend.position,
text.factor = text.factor,
x.category.fill = colourpicker(x.category.fill),
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.margin = x.category.margin,
has_subtitle = !subtitle %in% c("", NA)) +
theme(panel.grid.major = element_blank(),
axis.ticks = element_blank())
}
scales <- 'fixed'
if (x.category.repeat.lbls.x == TRUE & x.category.repeat.lbls.y == TRUE) {
scales <- 'free'
} else if (x.category.repeat.lbls.y == TRUE) {
scales <- 'free_y'
} else if (x.category.repeat.lbls.x == TRUE) {
scales <- 'free_x'
}
if (data %>% pull("jaar") %>% n_distinct() > 1) {
p <- p + facet_wrap(facets = c("jaar", "maand"),
scales = scales,
strip.position = x.category.position)
} else {
p <- p + facet_wrap(facets = "maand",
scales = scales,
strip.position = x.category.position)
}
p <- p +
labs(x = x.title,
y = y.title,
title = title,
subtitle = subtitle,
fill = legend.title,
caption = caption,
tag = tag)
if (print == TRUE) {
print(p)
} else {
p
}
}
#' Extra element toevoegen aan grafiek
#'
#' Dit maakt een extra element in een grafiek.
#' @param plot Een \code{ggplot}-model waaraan de lijn toegevoegd moet worden.
#' @param type Type element dat toegevoegd moet worden. Voor een lijst van mogelijkheden: \code{\link{plot2.elements}}.
#' @param move Standaard is \code{0}. Nieuwe type verplaatsen m.b.v. \code{\link{plot2.movelayer}}.
#' @param size Standaard is \code{0.75} bij lijnen en anders \code{2}. Dikte van de lijnen in geval van een lijngrafiek en punten in geval van een puntgrafiek.
#' @param linetype Standaard is \code{1}. Het type lijn. Uit \code{\link{linetype}}: \code{0 = blank, 1 = solid, 2 = dashed, 3 = dotted, 4 = dotdash, 5 = longdash, 6 = twodash}.
#' @param colour Standaard is \code{"certeroze"}. Kleur van het type. Ondersteunt \code{\link{colourpicker}}.
#' @param ... Parameters die doorgegeven worden aan het type, zoals \code{colour}, \code{fill} en \code{size}, maar ook \code{inherit.aes} en \code{mapping}. Ondersteunt \code{\link{colourpicker}}. Variabelen uit de data van \code{plot} worden automatisch vertaald, zie Examples.
#' @keywords plot2 chart plot lijn
#' @seealso \code{\link{plot2}}
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' # Variabelen uit plot$data worden vertaald, zoals hier uit `rr_ewma`:
#' plot2(y = (runif(52) * 100) + 300, type = "line") %>%
#' plot2.add("line", y = rr_ewma(y, lambda = 0.75))
#'
#'
#' # hier met gefingeerde weekaantallen
#' tibble(week = 1:52,
#' meetpuntjes = (runif(52) * 100) + 30) %>%
#' plot2(type = "point",
#' size = 2,
#' colour = "gray") %>%
#' plot2.add("line",
#' colour = "gray",
#' size = 0.5) %>%
#' # rrEWMA
#' plot2.add("line",
#' y = rr_ewma(meetpuntjes,
#' lambda = 0.9)) %>%
#' # 90e percentiel
#' plot2.add("line",
#' y = quantile(meetpuntjes,
#' 0.9,
#' info = FALSE),
#' linetype = 2,
#' colour = "certeblauw") %>%
#' # en een leesbaardere x-as: elke 4 weken en beginnen bij 1
#' plot2.axis("x",
#' breaks = c(1, seq(from = 0, to = 52, by = 4)))
plot2.add <- function(plot,
type,
move = 0,
size = if_else(type %like% 'line$', 0.75, 2),
linetype = 1,
colour = "certeroze",
...) {
if (missing(type)) {
type <- ""
}
if (!is.character(type)) {
stop("`type` must be a character vector.", call. = FALSE)
}
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
# geen enkel type eindigt op -s, dus die verwijderen voor
# als bijv. "points" of "lines" gebruikt wordt
type <- gsub('s$', '', type)
# als type = "geom_line" gebruikt wordt, moet dat ook kunnen
type <- gsub('^geom_', '', type)
type_valid <- plot2.elements()
if (!all(type %in% type_valid)) {
stop('`type` must all be one of: ', type_valid %>% concat(", "), call. = FALSE)
}
# dots vertalen
geom <- type
argnames <- names(as.list(match.call(expand.dots = FALSE)[-1]))
arguments <- as.list(match.call()[-1])
if (!'size' %in% argnames) {
argnames <- c(argnames, 'size')
arguments$size <- size
}
if (!'linetype' %in% argnames) {
argnames <- c(argnames, 'linetype')
arguments$linetype <- linetype
}
if (!'colour' %in% argnames) {
argnames <- c(argnames, 'colour')
arguments$colour <- colour
}
# group = 1 toevoegen als een lijn toegevoegd moet worden
# https://stackoverflow.com/a/16350805/4575331
if (any(type %in% c('line', 'path', 'step'))) {
if (!"group" %in% as.character(plot$mapping)) {
argnames <- c(argnames, 'group')
arguments$group <- 1
}
}
arguments <- arguments[!names(arguments) %in% c('plot', 'geom', 'type', 'move')]
if (type %in% c('blank', 'count', 'area', 'dotplot', 'hex', 'jitter', 'label', 'point', 'qq', 'qqline', 'text')) {
arguments <- arguments[names(arguments) != 'linetype']
}
# kleuren uit colourpicker ondersteunen
if ('fill' %in% names(arguments)) {
arguments[['fill']] <- colourpicker(eval(arguments[['fill']]))
}
if ('color' %in% names(arguments)) {
arguments[['color']] <- colourpicker(eval(arguments[['color']]))
}
if ('colour' %in% names(arguments)) {
arguments[['colour']] <- colourpicker(eval(arguments[['colour']]))
}
if ('.' %in% names(arguments)) {
arguments[['.']] <- eval(plot)
}
if (length(arguments) > 0) {
for (i in 1:length(arguments)) {
if (concat(as.character(arguments[[i]]), "") %in% colnames(plot$data)) {
# als parameter in plot$data voorkomt, direct oplossen
arg_text <- paste0('plot$data$', arguments[[i]])
arguments[[i]] <- unlist(list(eval(parse(text = arg_text))))
} else if (class(arguments[[i]]) == "call") {
# variabelen uit plot$data evalueren
params <- arguments[[i]] %>% as.character()
# 1e argument is functienaam, dus vanaf 2e controleren
for (j in 2:length(params)) {
if (params[j] %in% colnames(plot$data)) {
params[j] <- paste0('plot$data$', params[j])
}
}
names(params) <- names(arguments[[i]])
params_call <- params %>% as.list()
for (j in 2:length(params_call)) {
if (is.double2(params_call[j])) {
params_call[j] <- params_call[j] %>% as.double()
}
# hier evalueren
params_call[j] <- list(eval(parse(text = params_call[j])))
}
# eerste parameter als name; anders werkt `as.call` niet
params_call[[1]] <- as.name(params[1])
arguments[[i]] <- as.call(params_call)
}
}
}
# type toevoegen aan plot
for (g in geom) {
plot <- plot + do.call(paste0("geom_", g), arguments)
if (move != 0) {
plot <- plot %>% plot2.movelayer(move = move, info = FALSE)
}
}
plot
}
#' Aanpassen van \code{plot2}-assen
#'
#' Hierbij kunnen de x- en y-as van een \code{ggplot}-model aangepast worden.
#' @param plot Een \code{ggplot}-model waarvan de as(sen) aangepast moet(en) worden.
#' @param axis As die aangepast moet worden: \code{"x"}, \code{"y"}, \code{"xy"} of \code{c("x", "y")}.
#' @param breaks,date_breaks,minor_breaks,date_minor_breaks,labels,date_labels,limits,position,log Zie \code{\link{scale_x_continuous}}, \code{\link{scale_x_discrete}} en \code{\link{scale_x_date}} voor alle mogelijkheden.
#' @param trans Transformaties die gedaan kunnen worden aan een continuous schaal, zoals \code{"asn"}, \code{"atanh"}, \code{"boxcox"}, \code{"exp"}, \code{"identity"}, \code{"log"}, \code{"log10"}, \code{"log1p"}, \code{"log2"}, \code{"logit"}, \code{"probability"}, \code{"probit"}, \code{"reciprocal"}, \code{"reverse"} en \code{"sqrt"}.
#' @export
plot2.axis <- function(plot,
axis,
breaks = waiver(),
date_breaks = waiver(),
minor_breaks = waiver(),
date_minor_breaks = waiver(),
labels = waiver(),
date_labels = waiver(),
limits = NULL,
position = if_else(axis == "x", "bottom", "left"),
log = FALSE,
trans = NULL) {
if (!axis %like% "^[xy]{1,2}$") {
stop("`axis` must be x, y or both.", call. = FALSE)
}
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
axis <- axis %>% concat()
x_type <- class(plot$scales$scales[[1]])[1]
if (!axis %like% "x") {
x_type <- ""
}
y_type <- class(plot$scales$scales[[2]])[1]
if (!axis %like% "y") {
y_type <- ""
}
sup <- base::suppressMessages
if (is.null(trans)) {
trans <- "identity"
}
if (log == TRUE) {
trans <- "log2"
}
# x-as
if (x_type %like% 'continuous') {
sup(plot <- plot +
scale_x_continuous(breaks = breaks,
minor_breaks = minor_breaks,
labels = labels,
limits = limits,
position = position,
trans = trans))
} else if (x_type %like% 'discrete') {
sup(plot <- plot +
scale_x_discrete(breaks = breaks,
labels = labels,
limits = limits,
position = position))
} else if (x_type %like% 'datetime') {
sup(plot <- plot +
scale_x_datetime(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (x_type %like% 'date') {
sup(plot <- plot +
scale_x_date(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (x_type %like% 'time') {
sup(plot <- plot +
scale_x_time(breaks = breaks,
#date_breaks = date_breaks,
minor_breaks = minor_breaks,
#date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
}
# y-as
if (y_type %like% 'continuous') {
sup(plot <- plot +
scale_y_continuous(breaks = breaks,
minor_breaks = minor_breaks,
labels = labels,
limits = limits,
position = position,
trans = trans))
} else if (y_type %like% 'discrete') {
sup(plot <- plot +
scale_y_discrete(breaks = breaks,
labels = labels,
limits = limits,
position = position))
} else if (y_type %like% 'datetime') {
sup(plot <- plot +
scale_y_datetime(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (y_type %like% 'date') {
sup(plot <- plot +
scale_y_date(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (y_type %like% 'time') {
sup(plot <- plot +
scale_y_time(breaks = breaks,
#date_breaks = date_breaks,
minor_breaks = minor_breaks,
#date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
}
plot
}
#' Lijst met elementen
#'
#' Lijst met mogelijke elementen die toegevoegd kunnen worden aan een plot2, door middel van \code{\link{plot2.add}}.
#' @export
plot2.elements <- function() {
ls(pattern = '^geom_', env = as.environment('package:ggplot2')) %>% gsub('^geom_', '', .)
}
#' Foutbalken toevoegen aan grafiek
#'
#' Dit voegt foutbalken in op de aangegeven plaatsen.
#' @param plot De grafiek waaraan de lijn toegevoegd moet worden.
#' @param ymin,ymax,x Kolomnaam in \code{plot$data}. Waarden met \code{NA} worden genegeerd.
#' @param size Standaard is \code{1}. Dikte van de lijnen in millimeters. Zie \code{\link{size}}.
#' @param linetype Standaard is \code{2}. Het type lijn. Uit \code{\link{linetype}}: \code{0 = blank, 1 = solid, 2 = dashed, 3 = dotted, 4 = dotdash, 5 = longdash, 6 = twodash}.
#' @param width Standaard is \code{0.33}. Breedte van de lijnen.
#' @param colour Standaard is \code{colourpicker("black")}. Kleur van de lijnen. Zie ook \code{\link{colourpicker}}.
#' @param type Standaard is \code{"errorbar"}. Geldige opties zijn \code{"errorbar"} en \code{"ribbon"}.
#' @keywords plot2 chart plot lijn
#' @seealso \code{\link{plot2}}
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' \donttest{
#' plot2(...) %>%
#' plot2.errorbar(ymin = "se_min",
#' ymax = "se_max")
#' }
plot2.errorbar <- function(plot,
ymin,
ymax,
x = colnames(plot$data)[1],
size = 1,
linetype = 1,
width = 0.33,
colour = colourpicker('black', opacity = 0.5),
type = 'errorbar') {
if (type == 'errorbar') {
plot + geom_errorbar(
aes_string(ymin = ymin,
ymax = ymax),
width = width,
linetype = linetype,
size = size,
colour = colour)
} else if (type == 'ribbon') {
# x-as continuous maken
plot$data[, x] <- plot$data %>% pull(x) %>% as.character() %>% as.integer()
plot +
scale_x_continuous(breaks = plot$data %>% pull(x)) +
geom_ribbon(
aes_string(ymin = ymin,
ymax = ymax),
fill = colourpicker(colour, opacity = 0.75))
}
}
#' Tekst toevoegen aan grafiek
#'
#' Dit voegt een annotatie toe aan een grafiek. De tekst wordt links uitgelijnd. BELANGRIJK: hiervoor moet een andere grafiekfunctie gebruikt worden met \code{print = FALSE}.
#' @param plot De grafiek waaraan de tekst toegevoegd moet worden
#' @param text De tekst die geplot moet worden.
#' @param y Plaats op de y-as.
#' @param x Standaard is \code{"0.5"}. Plaats op de x-as.
#' @param colour Standaard is \code{colourpicker("certeroze")}. Kleur van de tekst. Zie ook \code{\link{colourpicker}}.
# @param fill Standaard is \code{NA}. Kleur van de achtergrond. Zie ook \code{\link{colourpicker}}.
#' @param size Standaard is \code{"4"}. Grootte van de tekst.
#' @param bold Standaard is \code{FALSE}. Tekst vetgedrukt maken.
#' @param formula Standaard is \code{FALSE}. Wanneer de tekst een formule is (zoals \code{text = "R^2 =="}), moet \code{parse = TRUE} gebruikt worden.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt moet worden voor tekst in de grafiek.
#' @param ... Andere parameters die doorgegeven worden aan \code{\link[ggplot2]{layer}}.
#' @keywords grafiek chart plot lijn
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' \dontrun{
#' plot2.text('90e pct', 275)
#' }
plot2.text <- function(plot,
text,
y,
x = 0.5,
colour = "certeroze",
#fill = NA,
size = 4,
bold = FALSE,
formula = FALSE,
font.family = 'Calibri',
...) {
colour <- colour %>% colourpicker()
#fill <- fill %>% colourpicker()
bold.int <- bold + 1 # FALSE + 1 = 1 en TRUE + 1 = 2
plot <- plot +
annotate("text",
x = x,
y = y,
size = size,
colour = colour,
# fill = fill,
label = text,
hjust = 0, # links centreren
family = font.family,
fontface = bold.int,
parse = formula,
...)
plot
}
#' Verplaatsen van een laag van een ggplot-model
#'
#' Hiermee kan een laag binnen een ggplot (plot2) verplaatst worden, zodat ook na het maken van een plot toch de volgorde van de lagen veranderd kan worden.
#' @param plot De grafiek waaraan de lijn toegevoegd moet worden.
#' @param layer Standaard is de laatste laag. De index van de laag die verplaatst moet worden.
#' @param move Een positief of negatief getal die aangeeft hoeveel posities de laag \code{layer} verplaatst moet worden.
#' @param info Standaard is \code{TRUE}. Printen van de oude en nieuwe laagindeling.
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' \dontrun{
#' plot2(..) %>%
#' plot2.errorbar(..) %>%
#' plot2.movelayer(move = -2)
#' }
plot2.movelayer <- function(plot, layer = length(plot$layers), move, info = TRUE) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
layers <- plot$layers
layer_old <- layer
layer_new <- layer + move
if (!layer_old %in% c(1:length(layers))) {
stop('This plot contains only ', length(layers), ' layers. Layer ',
layer_old, ' does not exist.', call. = FALSE)
}
if (!layer_new %in% c(1:length(layers))) {
stop('This plot contains only ', length(layers), ' layers; layer ',
layer_old, ' cannot be moved to position ', layer_new, '.', call. = FALSE)
}
# functie voor weergeven van lagen
layeroverview <- function(layers) {
for (i in 1:length(layers)) {
aes_params <- layers[[i]]$aes_params
for (p in 1:length(aes_params)) {
if (aes_params[p][[1]] %like% '#[0-f]{6,8}') {
aes_params[p][[1]] <- aes_params[p][[1]] %>% gsub('#[0-f]{6}', colour.name(.), .)
} else if (aes_params[p][[1]] %in% colors()) {
aes_params[p][[1]] <- paste0(
col2rgb(aes_params[p][[1]])) %>%
as.integer() %>%
as.hexmode() %>%
concat() %>%
paste0('#', .) %>%
colour.name()
}
}
aes_params <- paste(names(aes_params), aes_params, collapse = ', ', sep = ': ')
geom <- layers[[i]]$geom
geom_firstclass <- (geom %>% class())[1] %>%
gsub('Geom', 'Geom_', ., fixed = TRUE) %>%
tolower()
cat('[', i, '] ', geom_firstclass, ' (', aes_params, ')\n', sep = '')
}
}
if (info == TRUE) {
cat('Old layer order:\n')
plot2.listlayers(plot)
}
# nieuwe volgorde; layer_old wordt layer_new en de rest doorschuiven
layers_backup <- layers
layers[[layer_new]] <- layers[[layer_old]]
for (i in (layer_new + 1):length(layers)) {
layers[[i]] <- layers_backup[[i - 1]]
}
plot$layers <- layers
if (info == TRUE) {
cat('\nNew layer order:\n')
plot2.listlayers(plot)
}
plot
}
#' Weergeven van alle lagen van een ggplot-model
#'
#' Hiermee wordt een overzicht gegeven van alle lagen van een \code{ggplot}-model (of \code{plot2}).
#' @param plot Een \code{ggplot}-model.
#' @param as.data.frame Standaard is \code{FALSE}. Overzicht printen als \code{data.frame}.
#' @return Tekst
#' @export
#' @examples
#' \dontrun{
#' plot2(..) %>%
#' plot2.listlayers()
#' }
plot2.listlayers <- function(plot, as.data.frame = FALSE) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
layers <- plot$layers
df <- tibble(i = integer(0), type = character(0), params = character(0))
for (i in 1:length(layers)) {
aes_params <- layers[[i]]$aes_params
if (aes_params %>% length() > 0) {
for (p in 1:length(aes_params)) {
if (aes_params[p][[1]] %like% '#[0-f]{6,8}') {
aes_params[p][[1]] <- aes_params[p][[1]] %>% gsub('#[0-f]{6}', colour.name(.), .)
} else if (aes_params[p][[1]] %in% colors()) {
aes_params[p][[1]] <- paste0(
col2rgb(aes_params[p][[1]])) %>%
as.integer() %>%
as.hexmode() %>%
concat() %>%
paste0('#', .) %>%
colour.name()
}
}
}
aes_params <- paste(names(aes_params), aes_params, collapse = ', ', sep = ': ')
geom <- layers[[i]]$geom
geom_firstclass <- (geom %>% class())[1] %>%
gsub('Geom', 'Geom_', ., fixed = TRUE) %>%
tolower()
if (as.data.frame) {
df <- df %>% rbind(tibble(i = i, type = geom_firstclass, params = aes_params))
} else {
cat('[', i, '] ', geom_firstclass, ' (', aes_params, ')\n', sep = '')
}
}
if (as.data.frame) {
df
}
}
#' Prevalentiegrafiek van tabel
#'
#' Dit plot adressen op een Google Maps kaart met prevalentiekleuren.
#'
#' @param tbl De tabel met gegevens die geplot moet worden. \strong{De tabel moet de kolommen \code{lat} en \code{lng} bevatten.}
#' @param coord.round Standaard is \code{2}. Afronden van coordinaten. Met minder decimalen krijgen coordinaten betrekking op een groter gebied. Punten met dezelfde coordinaten worden opgeteld.
#' @param dot.size Standaard is \code{10}. Grootte van de stippen.
#' @param dot.alpha Standaard is \code{0.75}. De zichtbaarheid van de stippen, een waarden tussen 0 en 1.
#' @param text.show Standaard is \code{TRUE}. Met \code{FALSE} worden alleen stippen weergegeven.
#' @param text.size Standaard is \code{4}. Grootte van de tekst in de stippen.
#' @param text.colour Standaard is \code{"white"}. Kleur van de tekst in de stippen.
#' @param print Standaard is \code{FALSE}. Hiermee wordt de grafiek direct met \code{print} weergegeven. Met \code{FALSE} kan de output gebruikt worden om door te geven aan een variabele.
#' @param colours Standaard is \code{"prev"}. Zie \code{\link{colourpicker}}.
#' @keywords grafiek chart plot adres
#' @return Een \code{ggmap}-model.
#' @seealso \code{\link{tbl_address}} \code{\link{gps_from_address}}
#' @export
#' @examples
#' \dontrun{
#' plot2.map_old(tbl = tbl_address("Van Swietenlaan 2, Groningen"))
#' }
plot2.map_old <- function(tbl,
coord.round = 2,
dot.size = 10,
dot.alpha = 0.75,
text.show = TRUE,
text.size = 4,
text.colour = 'white',
print = FALSE,
colours = 'prev') {
# coordinaten afronden
tbl$lat.round <- round(tbl$lat, coord.round)
tbl$lng.round <- round(tbl$lng, coord.round)
df <- tbl %>%
mutate(gps = paste(lat.round, lng.round)) %>%
group_by(gps, lat.round, lng.round) %>%
summarise(n = n()) %>%
# zodat hogere aantallen als laatst geplot worden (donkerrood bovenop rood):
arrange(n) %>%
ungroup()
prevkleuren <- colourpicker(colours, length = max(max(df$n), 10))
df$kleur <- prevkleuren[df$n]
suppressMessages(
kaart <-
ggmap::get_map(
location = c(lng = mean(df$lng.round), lat = mean(df$lat.round)),
zoom = 9,
maptype = "roadmap",
scale = 2,
source = 'google',
language = "nl-NL",
api_key = maps_api_key()
)
)
grafiek <- ggmap::ggmap(kaart) +
theme(axis.line = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.margin = unit(c(0, 0, -1, -1), 'lines')) +
xlab('') +
ylab('') +
geom_point(
data = df,
aes(x = lng.round, y = lat.round),
colour = df$kleur,
fill = df$kleur,
size = dot.size,
alpha = dot.alpha,
shape = 21
)
if (text.show == TRUE) {
grafiek <- grafiek +
geom_text(
data = df,
aes(x = lng.round, y = lat.round, label = n),
colour = text.colour,
size = text.size,
vjust = 0.5,
hjust = 0.5
)
}
if (print == TRUE) {
print(grafiek)
} else {
grafiek
}
}
#' Taartgrafiek van tabel
#'
#' Dit maakt een taartgrafiek met Certe-kleuren.
#' @param data Tabel met gegevens.
#' @param x Standaard is de eerste kolom van \code{data}. Tekstlabels voor elke taartpunt.
#' @param y Standaard is de tweede kolom van \code{data}. Gegevens voor de taartpunten.
#' @param title Standaard is leeg. Titel van de grafiek.
#' @param show.percent Standaard is \code{TRUE}. Onder de labels het percentage weergeven.
#' @param show.count Standaard is \code{FALSE}. Onder de labels het aantal weergeven.
#' @param show.labels Standaard is \code{TRUE}. Met \code{FALSE} worden helemaal geen labels weergegeven.
#' @param sort.size Standaard is \code{TRUE}. De taartpunten sorteren van groot naar klein.
#' @param round Standaard is \code{2}. Aantal decimalen waarop de grootte van \code{n} afgerond moet worden.
#' @param restgroup.threshold Standaard is \code{90}. Het percentage dat gedefinieerd moet zijn voordat de rest onder de restgroep gevat wordt (mits er meer dan 1 waarde over is). De restgroepgrootte is dus tussen de 0 en (100 - \code{restgroup.threshold}) procent. Gebruik een waarde van \code{NA} of \code{100} om geen restgroep te maken. Waarden tussen 0 en 1 worden ook ondersteund.
#' @param restgroup.info Standaard is \code{TRUE}. Printen van de waarnemingen die in de restgroep vallen naar de console.
#' @param clockwise Standaard is \code{TRUE}. Gegevens met de klok mee weergeven.
#' @param colours Standaard is \code{"certe"}. Zie \code{\link{colourpicker}}.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt moet worden voor tekst in de grafiek.
#' @keywords grafiek chart plot pie
#' @return Grafiek
#' @export
#' @examples
#' \dontrun{
#' plot2.pie(mmb$aanvragen, mmb$artsnaam, 'Overzicht')
#' }
plot2.pie <- function(data,
x = NA,
y = NA,
title = NA,
show.percent = TRUE,
show.count = FALSE,
show.labels = TRUE,
sort.size = TRUE,
round = 2,
restgroup.threshold = 90,
restgroup.info = TRUE,
clockwise = TRUE,
colours = getOption("plot2.colours", "certe"),
font.family = 'Calibri',
prefix.count = 'n = ') {
.Deprecated(msg = '`plot2.pie` is deprecated. Use `plot2.barpercent` instead.',
old = 'plot2.pie',
new = 'plot2.barpercent')
data <- as.data.frame(data)
if (is.na(x)) {
labels <- data[, 1]
} else {
labels <- data[, x]
}
if (is.na(y)) {
if (length(data) == 1) {
waarden <- data[, 1]
} else {
waarden <- data %>% pull(2)
}
} else {
waarden <- data[, y]
}
if (min(waarden) < 0) {
waarden <- abs(waarden)
warning('All values have been made positive.\n\n')
}
if (sum(waarden) == 0) {
stop('No values for this plot.')
}
if (is.na(title)) {
par(mar = c(0, 0, 0, 0), family = font.family)
} else {
par(mar = c(0, 0, 2, 0), family = font.family)
}
if (sort.size == TRUE) {
if (is.null(labels)) {
waarden <- sort(waarden, decreasing = TRUE)
} else {
temp <- data.frame(waarden, labels)
temp <- temp %>% arrange(desc(waarden))
waarden <- temp$waarden
labels <- temp$labels
}
}
labels <- as.character(labels)
aandeel <- waarden / sum(waarden)
if (!is.na(restgroup.threshold) & restgroup.threshold < 100) {
if (restgroup.threshold < 1) {
restgroup.threshold <- restgroup.threshold * 100
}
totaal <- 0
for (i in 1:length(waarden)) {
totaal <- totaal + waarden[i]
totaal.perc <- totaal / sum(waarden) * 100
waarden.resterend.perc <- (100 - totaal.perc) / 100
waarden.resterend.aantal <- length(waarden) - i
waarden.resterend.som <- sum(waarden[i + 1:length(waarden)])
if (totaal.perc >= restgroup.threshold & waarden.resterend.aantal > 1) {
if (restgroup.info == TRUE) {
cat('These observation are within the rest group:\n\n')
print(data.frame(
label = labels[i + 1:length(labels)][1:waarden.resterend.aantal],
waarde = format2(waarden[i + 1:length(waarden)][1:waarden.resterend.aantal], round),
aandeel = (aandeel[i + 1:length(aandeel)][1:waarden.resterend.aantal]) %>% as.percent() %>% format2()
))
}
waarden <- c(waarden[1:i], waarden.resterend.som)
labels <- c(labels[1:i], paste0('Rest (x', waarden.resterend.aantal, ')'))
aandeel <- waarden / sum(waarden)
break
}
}
}
if (show.percent == TRUE & show.count == TRUE) {
lbl <- paste0(prefix.count, format2(waarden, round), ' (', aandeel %>% as.percent() %>% format2(), ')')
} else if (show.percent == TRUE & show.count == FALSE) {
lbl <- aandeel %>% as.percent() %>% format2()
} else if (show.percent == FALSE & show.count == TRUE) {
lbl <- paste0(prefix.count, format2(waarden, round))
} else {
lbl <- ''
}
if (!is.null(labels) & !(length(labels) == 1)) {
lbl <- paste0(labels, '\n', lbl)
} else {
lbl <- labels
}
if (show.labels == FALSE) {
lbl <- NA
}
pie(
x = waarden,
labels = lbl,
clockwise = clockwise,
col = colourpicker(colours, length = length(waarden)),
border = colourpicker(colours, length = length(waarden)),
cex = 0.8,
cex.main = 1.1,
font.main = 1,
radius = 0.9,
main = title
)
}
#' @rdname qc
#' @export
plot2.qcc <- function(x, ..., plot.print = FALSE) {
qc.test(x, ..., text.show = FALSE, plot.show = TRUE, plot.print = plot.print)
}
#' Titel ophalen van grafiek
#'
#' @param plot Grafiek
#' @param validfilename Standaard is \code{TRUE}. Verandert de te retourneren tekst zodanig, dat dit een geldige bestandsnaam is.
#' @param append_ID Standaard is \code{TRUE}. Alleen als de caption van de grafiek een alfanumerieke tekst is (bijv. gemaakt met \code{\link{ID}}), wordt deze achter de output geplaatst.
#' @export
getplottitle <- function(plot, validfilename = TRUE, append_ID = TRUE) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
title <- plot$labels$title
if (is.null(title)) {
title <- 'plot'
} else {
title <- title %>%
as.character() %>%
gsub("\"", "***", .) %>%
strsplit("***", fixed = TRUE) %>%
unlist()
title <- title[which(title != ''
& title != 'paste('
& title != ', italic('
& title != ')'
& title != '), ')]
title <- title %>%
concat() %>%
trimws()
if (validfilename == TRUE) {
title <- title %>%
gsub("[?|<>|:/\\*]", "", .)
}
}
# caption toevoegen als dit een ID is
caption <- plot$labels$caption
if (!is.null(caption)) {
if (caption %like% '^[0-9a-f]+$') {
title <- paste0(title, " (", caption, ")")
}
}
title
}
#' Grafiek opslaan op schijf
#'
#' Hiermee wordt een plot2-grafiek opgeslagen op de schijf in de huidige werkmap. Het bestandstype wordt bepaald op basis van de extensie die gegeven wordt aan \code{filename}.
#' @details De maplocatie van de plot2-grafiek die met deze functie opgeslagen wordt, wordt vastgelegd in de functie \code{options} met de variabele \code{plot2.lastsave}. Zie \code{\link{plot2.opendir}} voor meer informatie.
#' @rdname plot2.save
#' @param plot Grafiek die opgeslagen moet worden.
#' @param width Standaard is \code{800}. Breedte van de grafiek in pixels.
#' @param height Standaard is \code{500}. Hoogte van de grafiek in pixels.
#' @param size Standaard is \code{NA}. Kan gebruikt worden \strong{in plaats van \code{width} en \code{height}} om de grootte aan te geven. Dit kan een waarde zijn als:
#'
#' - \code{"1200 * 800"}, voor een resolutie;
#'
#' - \code{"Office"}, \code{"vector"}, \code{"PowerPoint"} of \code{"Word"} voor een vectorafbeelding zonder kwaliteitsverlies (hierbij wordt altijd het .emf-bestandstype gebruikt);
#'
#' - in geval van PDF: \code{"A0"} t/m \code{"A6"};
#'
#' - een schermresolutie (niet-hoofdlettergevoelig): \code{"SVGA"}, \code{"XGA"}, \code{"WXGA"}, \code{"SXGA"}, \code{"HD"}, \code{"WXGA"}, \code{"WSXGA"}, \code{"FHD"}, \code{"FullHD"}, \code{"WUXGA"}, \code{"WQHD"}, \code{"UltraHD"} of \code{"4K"}.
#' @param portrait Standaard is \code{FALSE}. Bij PDF de pagina staand (\emph{portrait}) weergeven, wordt anders liggend (\emph{landscape}).
#' @param text.factor Standaard is \code{1}. Een factor tussen \code{0.5} en \code{2} die voor tekst in de grafiek gebruikt wordt. Op basis hiervan wordt intern het aantal dots per inch (DPI) en afbeeldingsgrootte in inch berekend:
#'
#' \code{breedte (inch) = width / (text.factor * 100)}, en
#'
#' \code{hoogte (inch) = height / (text.factor * 100)}
#' @param filename Standaard is de titel van \code{plot} of (wanneer deze niet beschikbaar is) de datum en tijd op deze manier: \code{"YYYYMMDD-hhmmss"}. Daarna wordt de extensie \code{.png} toegevoegd. Wordt opgeslagen in de huidige werkmap, tenzij \code{selectdir = TRUE}. De bestandsnaam kan eindigen op \code{"png"}, \code{"bmp"}, \code{"jpeg"}, \code{"tiff"}, \code{"pdf"}, \code{"svg"}, \code{"eps"}, \code{"ps"}, \code{"tex"}, \code{"wmf"} of \code{"emf"}.
#' @param selectdir Standaard is \code{FALSE}. Een popup weergeven zodat de map geselecteerd kan worden.
#' @param returnplot Standaard is \code{TRUE}. De plot niet alleen opslaan, maar ook printen.
#' @export
#' @seealso \code{\link{plot2.opendir}} om de map te openen waarin de afbeelding geplaatst is en \code{\link{ggsave}} voor de functie die intern gebruikt wordt.
#' @examples
#' \dontrun{
#' tbl %>%
#' filter(...) %>%
#' group_by(...) %>%
#' summarise(...) %>%
#' plot2() %>%
#' plot2.save(1200, 800)
#'
#' tbl %>%
#' plot2() %>%
#' plot2.save(size = "1200 * 800")
#'
#' tbl %>%
#' plot2() %>%
#' plot2.save(size = "FullHD", text.factor = 1.25)
#'
#' tbl %>%
#' plot2() %>%
#' plot2.save(size = "PowerPoint", filename = "Test") # will output `Test.emf`
#' }
plot2.save <- function(plot,
width = 800,
height = 500,
size = NA,
portrait = FALSE,
text.factor = 1,
title = if_else(is.na(getplottitle(plot)),
format(Sys.time(), format = '%Y%m%d-%H%M%S'),
getplottitle(plot)),
file_format = "png",
filename = paste0(title, ".", file_format),
selectdir = FALSE,
returnplot = TRUE) {
filename.deparse <- paste(deparse(substitute(filename)), collapse = "")
if (text.factor < 0.1 | text.factor > 10) {
stop('`text.factor` must be a number between 0.1 and 10.')
}
strip.extension <- function(filename) {
sapply(strsplit(basename(filename), "\\."), function(x)
paste(x[1:(length(x) - 1)], collapse = "."))
}
get.extension <- function(filename) {
gsub(filename %>% strip.extension(), '', filename) %>%
tolower() %>%
gsub('.', '', ., fixed = TRUE)
}
# standaard A4 voor pdf
if (is.na(size) & get.extension(filename) == 'pdf') {
size <- 'A4'
}
if (!is.na(size)) {
# zoals size = '1200 * 800' en '1200*800'
if (grepl(' * ', size, fixed = TRUE)) {
width <- (strsplit(size, " * ", fixed = TRUE) %>% unlist())[1] %>% as.integer()
height <- (strsplit(size, " * ", fixed = TRUE) %>% unlist())[2] %>% as.integer()
} else if (size %>% tolower() %in% tolower(c('Office', 'vector', 'PowerPoint', 'Word'))) {
# extensie verwijderen
filename <- filename %>% strip.extension()
filename <- paste0(filename, '.emf')
text.factor <- 1.75
width <- 1200
height <- 900
dpi <- 300
} else if (size %>% tolower() == "SVGA" %>% tolower()) {
width <- 800
height <- 600
} else if (size %>% tolower() == "XGA" %>% tolower()) {
width <- 1024
height <- 768
} else if (size %>% tolower() == "WXGA" %>% tolower()) {
width <- 1280
height <- 720
} else if (size %>% tolower() == "SXGA" %>% tolower()) {
width <- 1280
height <- 1024
} else if (size %>% tolower() == "HD" %>% tolower()) {
width <- 1366
height <- 768
} else if (size %>% tolower() == "WXGA" %>% tolower()) {
width <- 1440
height <- 900
} else if (size %>% tolower() == "WSXGA" %>% tolower()) {
width <- 1680
height <- 1050
} else if (size %>% tolower() == "FHD" %>% tolower()) {
width <- 1920
height <- 1080
} else if (size %>% tolower() == "FullHD" %>% tolower()) {
width <- 1920
height <- 1080
} else if (size %>% tolower() == "WUXGA" %>% tolower()) {
width <- 1920
height <- 1200
} else if (size %>% tolower() == "WQHD" %>% tolower()) {
width <- 2560
height <- 1440
} else if (size %>% tolower() == "UltraHD" %>% tolower()) {
width <- 3840
height <- 2160
} else if (size %>% tolower() == "4K" %>% tolower()) {
width <- 3840
height <- 2160
# PDF
} else if (get.extension(filename) == "pdf" | file_format == "pdf") {
a0_height <- sqrt(sqrt(2)) * 1000 # x1000 voor millimeters.
a1_height <- a0_height / sqrt(2)
a2_height <- a1_height / sqrt(2)
a3_height <- a2_height / sqrt(2)
a4_height <- a3_height / sqrt(2)
a5_height <- a4_height / sqrt(2)
a6_height <- a5_height / sqrt(2)
if (size %>% tolower() == "a0" %>% tolower()) {
height <- a0_height
width <- a0_height / sqrt(2)
} else if (size %>% tolower() == "a1" %>% tolower()) {
height <- a1_height
width <- a1_height / sqrt(2)
} else if (size %>% tolower() == "a2" %>% tolower()) {
height <- a2_height
width <- a2_height / sqrt(2)
} else if (size %>% tolower() == "a3" %>% tolower()) {
height <- a3_height
width <- a3_height / sqrt(2)
} else if (size %>% tolower() == "a4" %>% tolower()) {
height <- a4_height
width <- a4_height / sqrt(2)
} else if (size %>% tolower() == "a5" %>% tolower()) {
height <- a5_height
width <- a5_height / sqrt(2)
} else if (size %>% tolower() == "a6" %>% tolower()) {
height <- a6_height
width <- a6_height / sqrt(2)
} else {
warning('No valid value for size; A4 will be used.')
height <- a4_height
width <- a4_height / sqrt(2)
}
if (portrait == FALSE) {
height.bak <- height
height <- width
width <- height.bak
}
} else {
warning('No valid value for size; (default) values for width and height will be used.')
size <- NA
}
}
# if (!is.na(size) & (!missing(width) | !missing(height))) {
# warning('Width and height will be ignored, because size is set')
# }
if (selectdir == TRUE) {
map <- choose.dir(getwd(), "Select a folder:")
if (is.na(map)) {
stop('No folder selected to save to.')
}
map <- paste0(map, '/')
} else {
map <- ''
}
if (get.extension(filename) == '') {
filename <- paste0(filename, '.png')
}
filename.only <- filename
filename <- paste0(map, filename)
if (get.extension(filename) != 'pdf') {
dpi <- text.factor * 100
} else {
dpi <- 1
if (text.factor != 1) {
warning('`text.factor` has no use in PDF export.')
}
}
width.calc <- width / dpi
height.calc <- height / dpi
if (filename %like% '(.pdf)$') {
suppressWarnings(
ggsave(filename = filename,
device = cairo_pdf,
width = width.calc,
height = height.calc,
units = 'mm',
plot = plot)
)
} else {
suppressWarnings(
ggsave(filename = filename,
dpi = dpi,
width = width.calc,
height = height.calc,
units = 'in',
plot = plot)
)
}
filesize <- paste(round(file.size(filename) / 1024), 'kB')
if (!filename.only %like% '(.emf|.wmf|.pdf|.svg|.ps|.tex)$') {
filesize <- paste0(width, 'x', height, 'px, ', filesize)
} else {
if (get.extension(filename) == 'pdf') {
filesize <- paste0(toupper(size), ' format, ', filesize)
#cat('Exporting to a PDF document in', toupper(size), 'format...\n')
} else {
cat('Some vector types can be ungrouped (e.g. in PowerPoint or Word) and edited if needed.\n')
}
}
if (file.exists(filename)) {
if (map == "") {
last.save <- paste0(getwd(), '/', filename)
} else {
last.save <- filename
}
options(plot2.lastsave = last.save)
cat(paste0(
'[',
format2(Sys.time()),
'] Plot saved as `',
normalizePath(filename),
'` (', filesize, ')',
'.\n'
))
# altijd anderhalve seconde wachten zodat plots elkaar niet overschrijven met standaard filename
if (title %like% '(format|Sys.time)') {
Sys.sleep(1.5)
}
if (returnplot == TRUE) {
print(plot)
}
} else {
if (returnplot == TRUE) {
print(plot)
}
stop("Error while saving '", filename, "'")
}
# if (interactive()) {
# # focus naar Console:
# rstudioapi::sendToConsole("", FALSE)
# openplot <- readline("Would you like to open this folder now? [y/N] ")
# if (openplot %>% substr(1, 1) %>% tolower() %in% c('n', '')) {
# cat('Run plot2.opendir() to open this folder any moment in the future.\n')
# } else {
# plot2.opendir()
# }
# }
}
#' Interactieve grafiek maken
#'
#' Dit maakt van een plot2-model een interactief \code{plotly}-model.
#' @param plot Een \code{ggplot}-model.
#' @param ... Parameters die doorgegeven worden aan \code{\link[plotly]{ggplotly}}.
#' @export
plot2.interactive <- function(plot, ...) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
suppressMessages(
suppressWarnings(
plotly::ggplotly(p = plot, tooltip = c("x", "y"), ...)
)
)
}
#' Map openen van laatste \code{plot2.save()}.
#'
#' De locatie van de laatste plot2-grafiek openen in een nieuw scherm van Windows Verkenner.
#' @details De locatie van de laatste plot2-grafiek wordt opgeslagen met de functie \code{\link{options}}, onder variabele \code{plot2.lastsave}. Daarom kan de locatie opgehaald worden met de functie \code{getOption("plot2.lastsave")} of \code{options()$plot2.lastsave}.
#' @seealso \code{\link{plot2.save}}
#' @export
plot2.opendir <- function() {
filename <- getOption("plot2.lastsave")
if (is.null(filename)) {
stop("No last saved plot found.")
}
suppressWarnings(shell(
paste0('explorer /select, "', gsub('/', '\\', filename, fixed = TRUE), '"')
))
}
plot2.format.number.EN <- function(x) {
x %>% format2(format.NL = FALSE)
}
plot2.format.percent <- function(x) {
x %>% as.percent() %>% format2(round = 1, force.decimals = FALSE)
}
plot2.format.percent.EN <- function(x) {
x %>% as.percent() %>% format2(round = 1, force.decimals = FALSE, format.NL = FALSE)
}
plot2.datalabels <- function(grafiek,
data,
x,
y,
datalabels,
datalabels.fill,
y.category,
stacked,
stackedpercent,
horizontal,
reverse,
font.family,
text.factor,
width) {
width <- ifelse(!is.null(width), width, 0.5)
if (stacked == FALSE & stackedpercent == FALSE) {
kleur.label <- colourpicker(datalabels.fill)
kleur.tekst <- 'gray25'
} else {
kleur.label <- colourpicker(datalabels.fill, opacity = 0.75) # 75% doorzichtig
kleur.tekst <- 'black'
}
if (any(grepl('%*%', datalabels, fixed = TRUE) == TRUE)) {
datalabels <- as.expression(datalabels)
als.formule <- TRUE
} else {
als.formule <- FALSE
}
# datalabels toevoegen aan grafiekdata
grafiek$data <- grafiek$data %>% tibble::add_column(lbls.nieuw = datalabels)
grafiek$data$lbls.nieuw <- grafiek$data$lbls.nieuw %>% as.character()
h.label <- 0.5
h.tekst <- 0.5
v.label <- -0.1
v.tekst <- -0.75
if (horizontal == TRUE) {
v.label <- 0.5
v.tekst <- 0.5
h.label <- -0.1
h.tekst <- -0.25
}
textsize.txt <- text.factor * 3.0
textsize.lbl <- (text.factor * 1.25) + textsize.txt
if (text.factor == 1) {
textsize.lbl <- textsize.txt * 0.75
}
if (!is.na(y.category)) {
if (stackedpercent == TRUE) {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_fill(reverse = reverse, vjust = 0.5),
vjust = 0.5,
hjust = 0.5,
size = textsize.lbl,
fill = kleur.label,
colour = NA,
family = font.family
) +
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_fill(reverse = reverse, vjust = 0.5),
vjust = 0.5,
hjust = 0.5,
size = textsize.txt,
colour = kleur.tekst,
family = font.family)
} else if (stacked == TRUE) {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_stack(reverse = reverse, vjust = 0.5),
size = textsize.lbl,
fill = kleur.label,
colour = NA,
family = font.family,
na.rm = TRUE
) +
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_stack(reverse = reverse, vjust = 0.5),
size = textsize.txt,
colour = kleur.tekst,
family = font.family,
na.rm = TRUE)
} else {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_dodge2(width = width, preserve = "single"),
size = textsize.lbl,
colour = NA,
fill = kleur.label,
label.padding = unit(0.25, 'lines'),
label.r = unit(0, 'lines'),
vjust = v.label,
hjust = h.label,
family = font.family,
na.rm = TRUE) +
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_dodge2(width = width, preserve = "single"),
vjust = v.tekst,
hjust = h.tekst,
size = textsize.txt,
colour = kleur.tekst,
family = font.family,
na.rm = TRUE)
}
} else {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
size = textsize.lbl,
colour = NA,
fill = kleur.label,
label.padding = unit(0.25, 'lines'),
label.r = unit(0, 'lines'),
vjust = v.label,
hjust = h.label,
family = font.family,
na.rm = TRUE) +
# tekst zelf:
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
size = textsize.txt,
colour = kleur.tekst,
vjust = v.tekst,
hjust = h.tekst,
family = font.family,
na.rm = TRUE)
}
if (stacked == FALSE & stackedpercent == FALSE) {
# laag label helemaal naar onderen verplaatsen, dat is de een na laatste;
# daardoor valt het label (kleur achtergrond) nooit over een bar heen
alle_lagen <- c(1:length(lbls$layers))
label_laag <- length(alle_lagen) - 1
rest_lagen <- alle_lagen[-label_laag]
lbls$layers <- lbls$layers[c(label_laag, rest_lagen)]
}
lbls
}
markdown_bolditalic <- function(text) {
if (text %like% '[*]{2}.+[*]{2}') {
# bold
locations <- unlist(gregexpr(pattern = '[*]{2}',
text))
locations <- locations[1:2]
text.left <- substr(text,
1,
min(locations) - 1)
text.middle <- substr(text,
min(locations) + 2,
max(locations) - 1)
text.right <- substr(text,
max(locations) + 2,
nchar(text))
text.new <- substitute(
expression(paste(
text.left, bold(text.middle), text.right
)),
list(
text.left = text.left,
text.middle = text.middle,
text.right = text.right
)
)
text.new %>% eval()
} else if (text %like% '(_.*_|\\*.*\\*)') {
# italic
if (text %like% '(_.*_)') {
locations <- unlist(gregexpr(pattern = '[_]',
text))
} else {
locations <- unlist(gregexpr(pattern = '[*]',
text))
}
locations <- locations[1:2]
text.left <- substr(text,
1,
min(locations) - 1)
text.middle <- substr(text,
min(locations) + 1,
max(locations) - 1)
text.right <- substr(text,
max(locations) + 1,
nchar(text))
text.new <- substitute(
expression(paste(
text.left, italic(text.middle), text.right
)),
list(
text.left = text.left,
text.middle = text.middle,
text.right = text.right
)
)
text.new %>% eval()
} else {
text
}
}
plot2.variables <- function(data,
x,
y,
y.category,
x.category,
type,
misses.data,
misses.x,
misses.y,
misses.y.category,
sort.x,
sort.y.category,
sort.x.category,
horizontal,
datalabels,
x.max,
x.max.txt,
summarise_function,
summarise_function_text,
na.replace,
na.rm) {
x.remove <- FALSE
# print(misses.x)
# if (type == 'boxplot') {
# if (!misses.x ) {
# y.category = x
# }
# }
if (misses.data == FALSE & is.data.frame(data)) {
# altijd groepen verwijderen voor plotten
data <- ungroup(data)
}
if (misses.y == FALSE & all(y %in% c(NA, NaN))) {
stop("Invalid values for y (all are NA or NaN)", call. = FALSE)
}
# als geen data opgegeven is, deze maken
if (misses.data == TRUE) {
if (misses.y == TRUE & misses.x == FALSE) {
data <- tibble(x = x) %>%
group_by(x) %>%
summarise(y = n())
x = 'x'
y = 'y'
datalabels <- FALSE
} else if (misses.y == FALSE & misses.x == TRUE) {
# alleen y opgegeven
if (is.na(datalabels)) {
datalabels <- 'y'
}
if (any(class(y) == 'factor')) {
class.bak <- class(data)
data <- tibble(level = y, count = 1) %>%
group_by(level) %>%
summarise(count = sum(count)) %>%
droplevels()
class(data$level) <- class.bak
x <- 'level'
y <- 'count'
} else {
data <- tibble(x = c(1:length(y)), y = y)
x <- 'x'
y <- 'y'
x.remove <- TRUE
}
} else if (misses.y == FALSE & misses.x == FALSE) {
# x en y opgegeven
if (length(x) == length(y) |
(length(x) != 1 | length(y) != 1)) {
data <- tibble(x = x, y = y)
x <- 'x'
y <- 'y'
} else {
stop('`x` and `y` must have the same length when both are defined manually.')
}
}
if (misses.y.category == FALSE) {
data <- data %>% tibble::add_column(y.category)
}
} else if (misses.x == TRUE & misses.y == TRUE & !is.data.frame(data)) {
# x en y missen, en data is een reeks getallen; dit wordt y
if (is.na(datalabels)) {
datalabels <- data
}
if (any(class(data) == 'factor')) {
class.bak <- class(data)
data <- tibble(level = data, count = 1) %>%
group_by(level) %>%
summarise(count = sum(count)) %>%
droplevels()
class(data$level) <- class.bak
x <- 'level'
y <- 'count'
} else {
data <- tibble(x = c(1:length(data)), y = data)
x <- 'x'
y <- 'y'
x.remove <- TRUE
}
} else {
# data mist niet, maar x en/of y mist
# dit komt door `df %>% plot2()` en komt dus veel voor
if (misses.y == TRUE) {
if (is.numeric(data %>% pull(2))) {
y <- colnames(data)[2]
} else {
if (misses.y.category == TRUE
& data %>% pull(2) %>% n_distinct() > 1) {
y.category <- colnames(data)[2]
}
y <- colnames(data)[3]
}
}
if (misses.x == TRUE) {
x <- colnames(data)[1]
}
}
if (identical(y, x) | identical(y, y.category) | identical(y, x.category)) {
# y is automatisch bepaald, maar is gelijk aan een ander
# op zoek naar eerste beste numerieke kolom, anders fout
y <- NA
for (i in 1:ncol(data)) {
if (is.numeric(data %>% pull(i))
& !(identical(colnames(data)[i], x)
& !identical(colnames(data)[i], y.category)
& !identical(colnames(data)[i], x.category))) {
y <- colnames(data)[i]
break
}
}
if (is.na(y)) {
stop('`y` cannot be determined.')
}
}
if (misses.x == FALSE & length(x) == 1) {
if (is.na(x)) {
x.remove <- TRUE
datalabels <- FALSE
}
}
if (type == 'boxplot') {
if (!misses.x) {
y.category <- x
} else if (!is.na(y.category) & x == "") {
# geen x opgegeven, maar y.category is wel beredeneerd
x <- y.category
}
}
if (type == 'barpercent') {
y.category <- NA
}
if (identical(x.category, y.category)) {
y.category <- NA
}
# Alle NA's verwijderen of vervangen
if (na.rm == TRUE) {
if (!is.na(x)) {
data <- data %>% filter_at(x, all_vars(!is.na(.)))
}
if (!is.na(y)) {
data <- data %>% filter_at(y, all_vars(!is.na(.)))
}
if (!is.na(x.category)) {
data <- data %>% filter_at(x.category, all_vars(!is.na(.)))
}
if (!is.na(y.category)) {
data <- data %>% filter_at(y.category, all_vars(!is.na(.)))
}
} else if (!is.na(na.replace)) {
# waar in kolom x, x.category of y.category NA voorkomt, vervangen door na.replace:
if (!is.na(x)) {
if (data %>% pull(x) %>% is.na() %>% sum(na.rm = TRUE) > 0) {
if (is.factor(data %>% pull(x))) {
data[, x] <- factor(x = data %>% pull(x),
levels = c(data %>% pull(x) %>% levels(), na.replace) %>% unique())
data[data %>% pull(x) %>% is.na(), x] <- na.replace
}
}
}
if (!is.na(x.category)) {
if (data %>% pull(x.category) %>% is.na() %>% sum(na.rm = TRUE) > 0) {
if (is.factor(data %>% pull(x.category))) {
data[, x.category] <- factor(x = data %>% pull(x.category),
levels = c(data %>% pull(x.category) %>% levels(), na.replace) %>% unique())
data[data %>% pull(x.category) %>% is.na(), x.category] <- na.replace
}
}
}
if (!is.na(y.category)) {
if (data %>% pull(y.category) %>% is.na() %>% sum(na.rm = TRUE) > 0) {
if (is.factor(data %>% pull(y.category))) {
data[, y.category] <- factor(x = data %>% pull(y.category),
levels = c(data %>% pull(y.category) %>% levels(), na.replace) %>% unique())
data[data %>% pull(y.category) %>% is.na(), y.category] <- na.replace
}
}
}
}
# controleren of kolommen wel bestaan
for (i in 1:length(x)) {
if (!is.na(x[i])) {
if (!x[i] %in% colnames(data)) {
stop('This variable does not exist: ', x[i], '.', call. = FALSE)
}
}
}
for (i in 1:length(y)) {
if (!is.na(y[i])) {
if (!y[i] %in% colnames(data)) {
stop('This variable does not exist: ', y[i], '.', call. = FALSE)
}
}
}
if (is.na(y.category) & length(y) == 1) {
meerdere_series <- FALSE
} else {
meerdere_series <- TRUE
}
# print(x)
# print(y)
# print(y.category)
# print(x.category)
# gaat anders problemen geven als `x` of `y` ook in de data voorkomt
col_x_ <- x
col_y_ <- y
# geen difftime voor y-as
for (i in 1:length(col_y_)) {
if (!is.numeric(data %>% pull(col_y_[i]))) {
class_y <- data %>% pull(col_y_[i]) %>% class()
if ("difftime" %in% class_y) {
values_type <- attributes(data %>% pull(col_y_[i]))$units
} else {
values_type <- "values"
}
warning("Column '", col_y_[i], "' (input for y) is of class '", rev(class_y)[1],
"'. These ", values_type, " are transformed to class 'double'.", call. = FALSE)
data[, col_y_[i]] <- data %>% pull(col_y_[i]) %>% as.double()
}
}
if (type == 'barpercent') {
if (meerdere_series == TRUE) {
stop('Type `barpercent` does not allow more than one category.', call. = FALSE)
}
data$y.bak <- data %>% pull(col_y_)
data[, col_y_] <- (data %>% pull(col_y_)) / sum(data %>% pull(col_y_))
}
if (!(type == 'boxplot' & meerdere_series == TRUE)
& is.na(x.category)
& !is.na(col_x_)
& ((is.na(y.category) & length(col_y_) == 1)
| identical(col_x_, y.category))) {
if (data %>% pull(col_x_) %>% n_distinct() < nrow(data)) {
# elke x komt vaker voorkomen dan 1x
if (type == 'barpercent') {
data <- data %>%
group_by_at(col_x_) %>%
summarise_at(vars(col_y_, y.bak), summarise_function)
} else {
data <- data %>%
group_by_at(col_x_) %>%
summarise_at(col_y_, summarise_function)
}
# if (!summarise_function_text %like% '[::]') {
# # locatie van de functie ophalen
# fn_location <- getAnywhere(summarise_function_text)[['where']][1] %>%
# gsub('package:', '', ., fixed = TRUE)
# summarise_function_text <- paste0(fn_location, '::', summarise_function_text)
# }
message('Using ', summarise_function_text, ' for `', col_y_,
'` (y), since `', col_x_ , '` (x) contains duplicate values (change this with `summarise_function`).')
}
}
if (!is.na(y.category) & length(col_y_) > 1) {
stop("`y.category` cannot be used while y has length > 1.")
} else if (meerdere_series == FALSE) {
# ################### #
# grafiek met 1 serie #
# ################### #
if (!col_y_ %in% colnames(data)) {
stop('This variable does not exist: ', col_y_, '.')
}
if (!is.na(col_x_)) { #is.na nodig voor boxplots wanneer plot2(x = NA) gebruikt wordt
grafiek <- ggplot(data, aes_string(x = col_x_, y = col_y_))
} else {
grafiek <- ggplot(data, aes_string(y = col_y_))
}
} else if (meerdere_series == TRUE) {
# #################### #
# grafiek met >1 serie #
# #################### #
if (is.na(y.category) & length(col_y_) > 1) {
# met categorieën, eerst gather nodig
exlude_vars <- character(0)
if (!is.na(x)) {
exlude_vars <- c(x, exlude_vars)
}
if (!is.na(x.category)) {
exlude_vars <- c(x.category, exlude_vars)
}
if (length(exlude_vars) > 0) {
data <- tidyr::gather(data, key = "y.category", value = "y", -exlude_vars)
} else {
data <- tidyr::gather(data, key = "y.category", value = "y")
}
lijst <- y
data <- data %>% filter(y.category %in% lijst)
if (nrow(data) == 0) {
stop('These variables do not exist: ', toString(lijst), '.')
}
if (data %>% pull('y.category') %>% n_distinct() < length(lijst)) {
warning('These variables do not exist: ',
toString(setdiff(lijst, unique(data %>% pull('y.category')))),
'.')
}
# ondersteuning voor legenda: y = c('Aantal orders' = 'aantal', 'Aantal monsters' = 'monsters')
if (!is.null(names(y))) {
for (i in 1:length(y)) {
if (names(y)[i] != '') {
data[, 'y.category'] <- gsub(paste0('^', (y)[i], '$'), names(y)[i], data %>% pull('y.category'))
}
}
}
col_y_ <- 'y'
y.category <- 'y.category'
}
if (length(y.category) > 1) {
# is data opgegeven
data$y.category <- y.category
y.category <- 'y.category'
}
grafiek <- ggplot(data, aes_string(x = col_x_, y = col_y_, fill = y.category, group = y.category))
}
if ('y' %in% colnames(grafiek$data)) {
if (class(grafiek$data$y) == 'character') {
grafiek$data$y <- grafiek$data$y %>% as.double()
}
}
if ('y.category' %in% colnames(grafiek$data)) {
if (class(grafiek$data$y.category) != 'character') {
grafiek$data$y.category <- grafiek$data$y.category %>% as.character()
}
}
if (!is.na(x.max)) {
if (data %>% pull(col_x_) %>% n_distinct() > x.max) {
# groeperen op x en alles > x.max de naam x.max.txt geven
data[, col_x_] <- data %>% pull(col_x_) %>% as.character() # krijgt namelijk x.max.txt erbij; dat is een tekst
desc_x <- data %>%
group_by_at(col_x_) %>%
summarise_at(vars(col_y_), funs(n = sum), na.rm = TRUE) %>%
arrange(desc(n)) %>%
pull(col_x_)
x.max.txt <- gsub('%n', length(desc_x) - x.max, x.max.txt, fixed = TRUE)
desc_x <- desc_x[1:x.max]
data[which(!(data %>% pull(col_x_)) %in% desc_x), col_x_] <- x.max.txt
if (meerdere_series == FALSE) {
if (!'sortering' %in% colnames(data)) {
data <- data %>% mutate(sortering = data %>% pull(col_y_))
}
if (!'y.bak' %in% colnames(data)) {
data <- data %>% mutate(y.bak = data %>% pull(col_y_))
}
data[which(data %>% pull(col_x_) == x.max.txt), 'sortering'] <- 0 # laagste sortering
data <- data %>%
group_by_at(col_x_) %>%
summarise_at(vars(col_y_, y.bak, sortering), sum, na.rm = TRUE) %>%
arrange(sortering)
data[, col_x_] <- factor(x = data %>% pull(col_x_),
levels = data %>% pull(col_x_))
}
grafiek$data <- data
}
}
# datalabels
if (length(datalabels) == 1) {
if (is.na(datalabels)) {
datalabels.show <- FALSE
} else {
if (datalabels == FALSE | datalabels == '') {
datalabels.show <- FALSE
} else if (datalabels == TRUE) {
datalabels.show <- TRUE
if (type == 'barpercent') {
datalabels <- data %>% pull(y.bak) # wordt in plot2() opgemaakt
} else if (length(col_y_) == 1) {
datalabels <- data %>% pull(col_y_)
} else {
datalabels <- data %>% pull(y)
}
} else if (datalabels != '') {
datalabels.show <- TRUE
if (class(datalabels) == 'character' & datalabels %in% colnames(data)) {
# plot2(..., datalabels = col_x) mogelijk maken, wanneer 'col_x' in data voorkomt
datalabels <- data %>% pull(datalabels)
}
}
}
} else {
if (meerdere_series == TRUE & sort(datalabels) %>% identical(sort(unique(grafiek$data$y.category)))) {
datalabels <- data %>% pull(col_y_)
}
datalabels.show <- TRUE
}
if (type == "rsi") {
datalabels.show <- FALSE
}
# sorteren van x
if (!is.na(x)) {
if (!is.null(sort.x)) { # sort.x = NULL niet sorteren
if (x != '') {
if (data %>% pull(col_x_) %>% is.numeric()) {
values <- data %>% pull(col_x_) %>% as.double()
} else {
values <- data %>% pull(col_x_) %>% as.character()
}
if (any(data %>% pull(col_x_) %>% class() %in% c("Date", "POSIXct", "POSIXlt"))) {
# melding bij datums op x-as, die worden een factor wanneer sort.x != "asis"
warning('x axis contains dates, that will be transformed to factors since sort.x = ', toString(sort.x), '. Use sort.x = NULL to prevent this.', call. = FALSE)
}
if (sort.x == TRUE) {
if ('factor' %in% (data %>% pull(col_x_) %>% class())) {
sort.x <- "" # helemaal niet sorteren
} else {
sort.x <- 'asc'
}
}
if (sort.x %like% 'freq$') {
sort.x <- paste0(sort.x, '-desc')
}
if (horizontal == TRUE) {
# asc en desc omdraaien
sort.x <- gsub('asc', 'asc2', sort.x)
sort.x <- gsub('desc', 'asc', sort.x)
sort.x <- gsub('asc2', 'desc', sort.x)
}
if (sort.x %in% c('alpha', 'asc')) {
data[, col_x_] <- base::factor(values,
levels = values %>%
unique() %>%
sort())
} else if (sort.x == 'desc') {
data[, col_x_] <- base::factor(values,
levels = values %>%
unique() %>%
sort() %>%
rev())
} else if (sort.x %in% c('inorder', 'order', FALSE)) {
data[, col_x_] <- forcats::fct_inorder(values %>% as.character())
} else if (sort.x %in% c('infreq-desc', 'freq-desc')) {
data[, col_x_] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = TRUE)
} else if (sort.x %in% c('infreq-asc', 'freq-asc')) {
data[, col_x_] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = FALSE)
} else if (sort.x == "asis") {
# helemaal niet transformeren
}
if (!is.na(x.max) & sort.x != "asis") {
# tekst '(rest x n)' als laatste level
if (horizontal == TRUE & type != 'barpercent') {
x.max.after = Inf
} else {
x.max.after = 0L
}
suppressWarnings(
data[, col_x_] <- forcats::fct_relevel(data %>% pull(col_x_), x.max.txt, after = x.max.after)
)
}
grafiek$data[, col_x_] <- data %>% pull(col_x_)
}
}
}
# sorteren van y.category
if (!is.na(y.category)) {
if (!is.null(sort.y.category)) { # sort.y.category = NULL niet sorteren
if (y.category != '') {
if (data %>% pull(y.category) %>% is.numeric()) {
values <- data %>% pull(y.category) %>% as.double()
} else {
values <- data %>% pull(y.category) %>% as.character()
}
if (sort.y.category == TRUE) {
if ('factor' %in% (data %>% pull(y.category) %>% class())) {
sort.y.category <- "" # helemaal niet sorteren
} else {
sort.y.category <- 'asc'
}
}
if (sort.y.category %like% 'freq$') {
sort.y.category <- paste0(sort.y.category, '-desc')
}
if (horizontal == TRUE) {
# asc en desc omdraaien
sort.y.category <- gsub('asc', 'asc2', sort.y.category)
sort.y.category <- gsub('desc', 'asc', sort.y.category)
sort.y.category <- gsub('asc2', 'desc', sort.y.category)
}
if (sort.y.category %in% c('alpha', 'asc')) {
data[, y.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort())
} else if (sort.y.category == 'desc') {
data[, y.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort() %>%
rev())
} else if (sort.y.category %in% c('inorder', 'order', FALSE)) {
data[, y.category] <- forcats::fct_inorder(values %>% as.character())
} else if (sort.y.category %in% c('infreq-desc', 'freq-desc')) {
data[, y.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = TRUE)
} else if (sort.y.category %in% c('infreq-asc', 'freq-asc')) {
data[, y.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = FALSE)
}
grafiek$data[, y.category] <- data %>% pull(y.category)
}
}
}
# sorteren van x.category
if (!is.na(x.category)) {
if (!is.null(sort.x.category)) { # sort.x.category = NULL niet sorteren
if (x.category != '') {
if (data %>% pull(x.category) %>% is.numeric()) {
values <- data %>% pull(x.category) %>% as.double()
} else {
values <- data %>% pull(x.category) %>% as.character()
}
if (sort.x.category == TRUE) {
if ('factor' %in% (data %>% pull(x.category) %>% class())) {
sort.x.category <- "" # helemaal niet sorteren
} else {
sort.x.category <- 'asc'
}
}
if (sort.x.category %like% 'freq$') {
sort.x.category <- paste0(sort.x.category, '-desc')
}
if (horizontal == TRUE) {
# asc en desc omdraaien
sort.x.category <- gsub('asc', 'asc2', sort.x.category)
sort.x.category <- gsub('desc', 'asc', sort.x.category)
sort.x.category <- gsub('asc2', 'desc', sort.x.category)
}
if (sort.x.category %in% c('alpha', 'asc')) {
data[, x.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort())
} else if (sort.x.category == 'desc') {
data[, x.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort() %>%
rev())
} else if (sort.x.category %in% c('inorder', 'order', FALSE)) {
data[, x.category] <- forcats::fct_inorder(values %>% as.character())
} else if (sort.x.category %in% c('infreq-desc', 'freq-desc')) {
data[, x.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = TRUE)
} else if (sort.x.category %in% c('infreq-asc', 'freq-asc')) {
data[, x.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = FALSE)
}
grafiek$data[, x.category] <- data %>% pull(x.category)
}
}
}
return(
list(
data = data,
grafiek = grafiek,
x = col_x_,
y = col_y_,
y.category = y.category,
x.remove = x.remove,
meerdere_series = meerdere_series,
datalabels.show = datalabels.show,
datalabels = datalabels
)
)
}
quasiquotate <- function(deparsed, parsed) {
# bij tekst: eerste en laatste " verwijderen
if (any(deparsed %like% '^".+"$' | deparsed %like% "^'.+'$")) {
deparsed <- deparsed %>% substr(2, nchar(.) - 1)
}
# als deparsed in de kolomnamen van parsed voorkomt, moet de voorkeur naar de kolomnaam gaan (deparsed),
# anders werkt dit niet: aantal$aantal bestaat, en je runt `aantal %>% plot2(y = aantal)`
deparsed_in_cols <- tryCatch(deparsed %in% colnames(parsed),
error = function(e) FALSE)
# toepassen als nodig
if (any(!deparsed %like% '[[$:()]'
& !deparsed %in% c('""', "''", "", # lege tekst
".", ".data", # dplyr referenties
"TRUE", "FALSE", # logicals
"NA", "NaN", "NULL", # lege waarden
ls(.GlobalEnv))) |
deparsed_in_cols == TRUE) {
deparsed
} else {
parsed
}
}
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 plot2
Documented in plot2
# ==================================================================== #
# 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. #
# ==================================================================== #
#' Grafiek van tabel of reeks
#'
#' Grafiek van tabel of reeks met Certe-kleuren. De data wordt automatsch geinterpreteerd en zonodig getransformeerd voordat de grafiek getekend wordt. \cr
#' Voor \code{x}, \code{y}, \code{x.category}, \code{y.category} en \code{datalabels} wordt \code{\link[rlang]{quasiquotation}} ondersteund. \cr
#' Geldige types (\code{type}) zijn \code{"bar"}, \code{"barpercent"}, \code{"boxplot"}, \code{"column"}, \code{"density"}, \code{"frequency"}, \code{"histogram"}, \code{"line"}, \code{"lollipop"}, \code{"point"}, \code{"rsi"} en \code{"mic"}. \cr \cr De \code{plot2.*}-functies zijn hier wrappers van.
#' @rdname plot2
#' @name plot2
#' @aliases plot2 plot2.bar plot2.barpercent plot2.boxplot plot2.column plot2.line plot2.point plot2.mic plot2.rsi plot2.density plot2.frequency plot2.histogram
#' @param data \code{data.frame} met gegevens.
#' @param x Standaard is eerste kolom van \code{data}. Naam van kolom (als tekst) met gegevens voor de x-as. Wanneer in deze kolom waarden meerdere keren voorkomen, worden daarvan de waarden van \code{y} bij elkaar opgeteld.
#' @param y Standaard is tweede of derde kolom van \code{data}. Naam van kolom (als tekst) met gegevens voor de y-as. Het is ook mogelijk om hier namen aan te geven, om de tekst in de legenda aan te passen; zie voorbeelden. Niet-numerieke waarden worden getransformeerd met \code{\link{as.double}}.
#' @param y.category Standaard is tweede kolom van \code{data}. Naam van kolom (als tekst) met gegevens voor de y-as.
#' @param x.category Standaard is \code{NA}. Splitsen in verschillende plots door middel van \code{\link[ggplot2]{facet_wrap}(scales = "free")}. Zie aldaar voor meer parameters.
#' @param type Standaard is \code{"column"}, in tegenstelling tot de standaard \code{type = "p"} van \code{\link{plot}}. Geldige opties zijn \code{"bar"} (\code{"b"}), \code{"barpercent"}, \code{"boxplot"} (\code{"box"}), \code{"column"} (\code{"c"}, \code{"col"}), \code{"density"} (\code{"d"}, \code{"dens"}), \code{"frequency"} (\code{"f"}, \code{"freq"}), \code{"histogram"} (\code{"h"}, \code{"hist"}), \code{"line"} (\code{"l"}), \code{"lollipop"}, \code{"point"} (\code{"p"}), \code{"rsi"} en \code{"mic"}.
#' @param x.title,y.title Standaard is de kolomnaam van \code{x} of \code{y}. Beschrijving van de x- en y-as. Laat deze ongedefinieerd om de kolomtitels van de data te gebruiken. Tekst tussen *enkele sterren* of _underscores_ wordt cursief gemaakt, tekst tussen **dubbele sterren** wordt vet gemaakt.
#' @param fun Standaard is \code{\link{portion_df}}. Functie die gebruikt wordt om data te transformeren voor \code{plot2.rsi}. Geldige opties zijn \code{\link{portion_df}} en \code{\link{count_df}}.
#' @param translate_ab Standaard is \code{"trivial_nl"}, zie \code{\link{portion_df}}.
#' @param minimum Standaard is \code{30}, zie \code{\link{portion_df}}.
#' @param title Standaard is \code{NA}, waarmee de asnamen van y en x weergegeven worden als "y per x". Titel van de grafiek. Tekst tussen *enkele sterren* of _underscores_ wordt cursief gemaakt, tekst tussen **dubbele sterren** wordt vet gemaakt. De teksten \code{n()} en \code{n_distinct(kolomnaam)} worden vertaald.
#' @param subtitle Standaard is leeg. Ondertitel van de grafiek. Tekst tussen *enkele sterren* of _underscores_ wordt cursief gemaakt, tekst tussen **dubbele sterren** wordt vet gemaakt. De teksten \code{n()} en \code{n_distinct(kolomnaam)} worden vertaald.
#' @param caption Standaard is leeg. Bijschrift van de grafiek. Gebruik \code{caption = ID()} om een \code{\link{ID}} te maken van standaard 6 tekens.
#' @param tag Standaard is leeg. Bovenschrift van de grafiek. Dit komt links bovenin de grafiek, is vetgedrukt en groter dan de titel.
#' @param title_maxlength Standaard is \code{60}. Maximale aantal tekens op een regel.
#' @param subtitle_maxlength Standaard is \code{60}. Maximale aantal tekens op een regel.
#' @param na.replace Standaard is \code{"(onbekend)"}. De tekst die geplaatst wordt in plaats van \code{NA} in de variabelen \code{x}, \code{x.category} en \code{y.category}. In geval van \code{plot2.calendar} is dit de kleur die gegeven wordt aan dagen met missende informatie.
#' @param na.rm Standaard is \code{FALSE}. Verwijderen van alle \code{NA}'s in de variabelen \code{x}, \code{y}, \code{x.category} en \code{y.category}.
#' @param x.category.fill Standaard is \code{NA}; doorzichtig. Kleur die doorgegeven wordt aan \code{\link{colourpicker}}.
#' @param x.category.position Standaard is \code{"top"}. Geldige opties zijn \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}.
#' @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.repeat.lbls.x Standaard is \code{TRUE}. Herhalen van de x-aslabels bij elke deelgrafiex.
#' @param x.category.repeat.lbls.y Standaard is \code{TRUE}. Herhalen van de y-aslabels bij elke deelgrafiek.
#' @param x.category.drop Standaard is \code{FALSE}. Verwijderen van factor levels die niet voorkomen in de data.
#' @param x.category.nrow Standaard is leeg, waardoor het automatisch wordt bepaald door \code{link[ggplot2]{facet_wrap}}. Aantal rijen met grafieken.
#' @param x.category.margin Standaard is 3.5. Marge van de tekst van \code{x.category}.
#' @param x.category.relative Standaard is \code{FALSE}. Hiermee wordt de breedte van grafieken afgestemd op de beschikbare waarden van de x-as.
#' @param x.date_breaks Standaard is \code{"1 month"}. Datumafstand op x-as, zoals \code{"2 weeks"} of \code{"10 years"}.
#' @param x.date_labels Standaard is \code{"mmm"}. Datumlabels op x-as. Wordt geëvalueerd met \code{\link{date_generic}}, dus ondersteunt ook \code{"d mmmm yyyy"}.
#' @param y.category.focus Standaard is leeg. Een waarde die voorkomt in \code{data$y.category} om te benadrukken. De andere waarden in \code{data$y.category} worden grijs gemaakt, en de benadrukte kleur is het eerste element van \code{colours}.
#' @param colours Standaard is \code{"certe"}. De standaard optie kan ook ingesteld worden met \code{options(plot2.colours = "gekozen_kleuren")}. Een tekst of vector van tekst die doorgegeven wordt aan \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{NA}, waardoor het uitlijnen berekend wordt op basis van \code{x.lbl.angle}. Andere geldige opties zijn \code{"left"}, \code{"center"} en \code{"right"}. Deze kunnen afgekort worden.
#' @param x.lbl.italic Standaard is \code{FALSE}. De categorieën van de x-as cursief maken. Dit is nodig bij namen van micro-organismen.
#' @param x.position Standaard is \code{"bottom"}. Geldige opties zijn \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}. Verplaatst de astitel en de astekst.
#' @param x.max Standaard is \code{10} bij \code{plot2.barpercent} en \code{NA} bij de rest. Maximaal aantal verschillende waarden op de x-as.
#' @param x.max.txt Standaard is \code{"(rest, x \%n)"}. Tekst die weergegeven wordt bij waarden op de x-as die buiten \code{x.max} vallen. Gebruik \code{"\%n"} om het aantal overige categorieën weer te geven.
#' @param x.remove Standaard is \code{FALSE}. De eenheden van x-as verwijderen. Om de \emph{tekst} (label) van de x-as te verwijderen, gebruik \code{x.title = ""}.
#' @param y.remove Standaard is \code{FALSE}. De eenheden van y-as verwijderen. Om de \emph{tekst} (label) van de y-as te verwijderen, gebruik \code{y.title = ""}.
#' @param y.24h Standaard is \code{FALSE}. De primaire lijnen van de y-as per 24 uur weergeven.
#' @param y.age Standaard is \code{FALSE}. De primaire lijnen van de y-as per leeftijdsgroep weergeven (zie \code{\link{age.group}}).
#' @param y.percent Standaard is \code{FALSE}. Toont de y-as als percentage.
#' @param y.percent.break Standaard is \code{10}. Labels worden geplaatst op elke \code{y.percent.break} procent.
#' @param y.scale Standaard is automatisch. Hiermee kan de schaal van de y-as aangepast worden, met bijvoorbeeld \code{y.scale = c(0, 25)}. Standaard wordt in tegenstelling tot \code{ggplot} wordt altijd \code{y = 0} weergegeven. De hoogste waarde op de y-as is standaard 1,25x de hoogst voorkomende y-waarde en de laagste waarde op de y-as is standaard 0 (of 1,25x de laagst voorkomende y-waarde wanneer dit lager is dan 0).
#' @param y.position Standaard is \code{"left"}, behalve bij \code{type = "barpercent"}. Geldige opties zijn \code{"left"}, \code{"right"}, \code{"top"}, \code{"bottom"}. Verplaatst de astitel en de astekst.
#' @param sort.x,sort.y.category,sort.x.category Standaard is \code{TRUE}. Sorteren van de \code{x} en/of \code{y.category} en/of \code{x.category} door deze te transformeren naar een geordende \code{\link{factor}}. Geldige waarden zijn: \cr
#' - \code{TRUE}, bij factors op levels sorteren, anders zoals \code{"asc"} sorteren. \cr
#' - \code{FALSE}, zoals volgorde in de data voortkomt sorteren. \cr
#' - \code{NULL}, helemaal niet sorteren/transformeren \cr
#' - \code{"asc"} of \code{"alpha"}, oplopend alfabetisch sorteren; \emph{ascending}. \cr
#' - \code{"desc"}, aflopend alfabetisch sorteren; \emph{descending}. \cr
#' - \code{"order"}, zoals \code{FALSE} sorteren. \cr
#' - \code{"freq"}, aflopend volgens de frequentie (\code{summarise_function}) van \code{y} sorteren (hoogste waarde eerst). \cr
#' - \code{"freq-asc"}, oplopend zoals \code{"freq"} sorteren (laagste waarde eerst). \cr
#' @param datalabels Standaard is \code{TRUE}, wat de waarden weergeeft van \code{y}. Geeft datalabels weer bij de kolommen, lijnen of punten. Dit kan een kolomnaam van \code{data} zijn, of een lijst met waarden. Gebruik \code{datalabels = FALSE} of \code{datalabels = NA} om geen datalabels weer te geven.
#' @param datalabels.round Standaard is \code{if_else(y.percent == FALSE, 2, 1)}. Aantal decimalen waarop \code{datalabels} afgerond wordt, wanneer dit (decimale) getallen zijn.
#' @param datalabels.fill Standaard is \code{'white'}. De achtergrondkleur van de labels die doorgegeven wordt aan \code{\link{colourpicker}}. Gebruik \code{datalabels.fill = NA} om geen achtergrond weer te geven.
#' @param summarise_function Standaard is \code{sum}. De functie die gebruikt wordt voor \code{link{summarise}} om de waarden van \code{y} te berekenen wanneer waarden van \code{x} vaker voorkomen. Kan ook uit een ander pakket komen: \code{plot2(summarise_function = base::mean)}.
#' @param stacked Standaard is \code{FALSE}. Met \code{FALSE} worden de kolommen naast elkaar geplaatst, in plaats van op elkaar.
#' @param stackedpercent Standaard is \code{FALSE}. Hiermee kan een 100\% gestapelde grafiek gemaakt worden.
#' @param horizontal Standaard is \code{FALSE}. Horizontale orientatie van de kolommen. Met \code{TRUE} worden er horizontale balken weergegeven.
#' @param reverse Standaard is \code{horizontal}, waardoor de waarde van \code{horizontal} overgenomen wordt. Hiermee worden gestapelde balken omgekeerd. Dit is soms nodig om de legenda synchroon te houden met de kleuren van de balken. Kan ook \code{TRUE} of \code{FALSE} zijn.
#' @param smooth Standaard is \code{FALSE}. Lijnen vloeiend weergeven.
#' @param size Standaard is \code{if_else(type == "line", 0.75, 2)}. Dikte van de lijnen in geval van een lijngrafiek en punten in geval van een puntgrafiek.
#' @param bins Standaard is \code{20} of, wanneer dit lager is, het unieke aantal waarden gedeeld door 3. Bij een histogram het aantal 'bins'.
#' @param width Standaard is automatisch. De breedte van kolommen en dergelijke.
#' @param show.mean Standaard is \code{FALSE}. Bij boxplots de gemiddelde lijn ook weergeven.
#' @param break.S Standaard is \code{NA}. De hoogste MIC die geïnterpreteerd wordt als S.
#' @param break.R Standaard is \code{break.S}. De laagste MIC die geïnterpreteerd wordt als R.
#' @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 legend.title Standaard is \code{""}. Titel van de legenda.
#' @param print Standaard is \code{FALSE}. Hiermee wordt de grafiek direct met \code{print} weergegeven. Met \code{FALSE} kan de output gebruikt worden om door te geven aan een variabele.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt moet worden voor tekst in de grafiek. Om alle lettertypen te kunnen gebruiken die momenteel in Windows geïnstalleerd zijn, moet de functie \code{\link{install.fonts}} eerst eenmalig gebruikt worden.
#' @param text.factor Standaard is \code{1}. Factor van de grootte van alle tekst.
#' @param format.NL Standaard is \code{Sys.isdecimalcomma()}, zie \code{\link{Sys.isdecimalcomma}}. Getallen Nederlands weergeven, met een komma als decimaal scheidingsteken.
#' @param ... Parameters voor oudere versies, die intern vertaald worden.
#' @param misses.data,misses.x,misses.y,misses.y.category,certe_theme Wordt alleen intern gebruikt.
#' @export
#' @keywords grafiek chart plot data x y y.category type x.title,y.title title subtitle colour.list x.lbl.angle x.lbl.align x.remove y.remove y.24h y.age y.percent y.scale datalabels datalabels.round stacked stackedpercent horizontal smooth size bins legend.position print font.family format.NL
#' @return Een \code{ggplot}-model.
#' @seealso \code{\link{plot2.save}} om een grafiek direct op te slaan. \cr
#' \code{\link{plot2.map_old}} om een prevalentiegrafiek met Google Maps te maken. \cr
#' \code{\link{plot2.map}} om een GIS-data te gebruiken voor ruimtelijke analyse. \cr
#' \code{\link{plot2.pie}} om een taartgrafiek te maken.
#'
#' @examples
#' \dontrun{
#' plot2.column(mmb.orders, 'jaar', 'aantal orders')
#'
#'
#' # Direct vanuit dplyr:
#'
#' df %>%
#' group_by(jaar, specialisme) %>%
#' summarise(aantal = n()) %>%
#' plot2(type = "column")
#'
#' # Legenda gedefinieerde namen geven:
#' df %>%
#' filter(...) %>%
#' group_by(...) %>%
#' summarise(aantal = n()
#' monsters = n_distinct(ordernr)) %>%
#' plot2(y = c('Aantal orders' = 'aantal',
#' 'Aantal monsters' = 'monsters'),
#' title = 'Aanvragen in 2018',
#' type = 'c')
#'
#' # Gevoeligheidsanalyse, maakt gebruik van AMR::portion_df
#' # kolommen `interpretatie`, `ab` en `waarde` worden hierdoor standaard gemaakt.
#' septic_patients %>%
#' select(hospital_id, amox, fosf, nitr, cipr) %>%
#' plot2.rsi(x = hospital_id, x.category = ab)
#' }
plot2 <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
type = 'column',
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.remove = FALSE,
x.position = 'bottom',
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
horizontal = FALSE,
reverse = horizontal,
smooth = FALSE,
size = if_else(type == 'line', 0.75, 2),
bins = NULL,
width = NULL,
show.mean = FALSE,
break.S = NA,
break.R = break.S,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
misses.data = FALSE,
misses.x = FALSE,
misses.y = FALSE,
misses.y.category = FALSE,
misses.datalabels = FALSE,
certe_theme = TRUE,
x.lbl = NA,
...) {
if (NROW(data) == 0) {
warning("No observations to plot.")
return(invisible())
}
# backward compatibility en typfouten ----
via_wrapper <- FALSE
dots <- list(...) %>% unlist()
if (length(dots) != 0) {
dots.names <- dots %>% names()
if ('via_wrapper' %in% dots.names) {
via_wrapper <- dots[which(dots.names == 'via_wrapper')]
}
if ('summarise_function_text' %in% dots.names) {
summarise_function_text <- dots[which(dots.names == 'summarise_function_text')]
}
if ('legend.location' %in% dots.names) {
legend.position <- dots[which(dots.names == 'legend.location')]
}
if ('colour.list' %in% dots.names) {
colours <- dots[which(dots.names == 'colour.list')]
}
if ('colors' %in% dots.names) {
colours <- dots[which(dots.names == 'colors')]
}
if ('color' %in% dots.names) {
colours <- dots[which(dots.names == 'color')]
}
if ('titel' %in% dots.names) {
title <- dots[which(dots.names == 'titel')]
}
if ('subtitel' %in% dots.names) {
subtitle <- dots[which(dots.names == 'subtitel')]
}
if ('xas.lbl' %in% dots.names) {
x.title <- dots[which(dots.names == 'xas.lbl')]
}
if ('xas.lbl.hoek' %in% dots.names) {
x.lbl.angle <- dots[which(dots.names == 'xas.lbl.hoek')]
}
if ('yas.lbl' %in% dots.names) {
y.title <- dots[which(dots.names == 'yas.lbl')]
}
if ('y.lbl' %in% dots.names) {
y.title <- dots[which(dots.names == 'y.lbl')]
}
if ('yas.categorie' %in% dots.names) {
y.category <- dots[which(dots.names == 'yas.categorie')]
}
if ('x.sort' %in% dots.names) {
sort.x <- dots[which(dots.names == 'x.sort')]
}
if ('y.category.sort' %in% dots.names) {
sort.y.category <- dots[which(dots.names == 'y.category.sort')]
}
if ('x.category.sort' %in% dots.names) {
sort.x.category <- dots[which(dots.names == 'x.category.sort')]
}
if ('x.category.repeat.lbls' %in% dots.names) {
x.category.repeat.lbls.y <- dots[which(dots.names == 'x.category.repeat.lbls')]
}
if ('nrow' %in% dots.names) {
x.category.nrow <- dots[which(dots.names == 'nrow')]
}
if ('legend.lbl' %in% dots.names) {
legend.title <- dots[which(dots.names == 'legend.lbl')]
}
if ('sort.column' %in% dots.names) {
stop('`sort.column` is no longer valid, use `sort.x` or `sort.y.category` instead.')
}
if ('sort.desc' %in% dots.names) {
stop('`sort.desc` is no longer valid, use `sort.x` or `sort.y.category` instead.')
}
}
if (!is.na(x.lbl)) {
x.title <- x.lbl
}
x.date_labels <- date_generic(x.date_labels)
if (certe_theme == FALSE) {
if (colours == "certe") {
colours <- "ggplot"
}
if (missing(datalabels) | misses.datalabels == TRUE) {
datalabels <- FALSE
}
}
if (via_wrapper == FALSE) {
# quasiquotation
if (!missing(x) & !misses.x) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y) & !misses.y) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category) & !misses.y.category) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
y.category.focus <- quasiquotate(deparse(substitute(y.category.focus)), y.category.focus)
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
}
# onmogelijke keuzen blokkeren ----
if ("sf" %in% class(data)) {
stop('Use `plot2.map` for spatial analysis.')
}
if (type == "rsi" & !all(c("interpretatie", "ab", "waarde") %in% colnames(data))) {
stop("Use plot2.rsi for resistance analysis.")
}
if (sum(y.percent, y.24h, y.age) > 1) {
stop('`y.percent`, `y.24h` and/or `y.age` cannot be used together.')
}
if (!(x.lbl.angle %in% c(0:360))) {
stop('No valid angle for the x-axis, must be 0-360.')
}
if (length(x) > 1 & (stacked == TRUE | stackedpercent == TRUE)) {
stop('`stacked` and `stackedpercent` cannot be used when there is more than 1 x-axis.')
}
if (any(colnames(data) %like% '[()<>{}\\/]')) {
warning('Possibly invalid variable name(s) which may lead to missing values.')
}
if (any(colours %>% class != 'character')) {
stop('`colours` must be a character or a character vector.')
}
if (text.factor < 0.1 | text.factor > 10) {
stop('`text.factor` must be a number between 0.1 and 10.')
}
if (!is.na(x.category)) {
if (!x.category %in% colnames(data)) {
stop('This variable does not exist: ', x.category)
}
}
allowed_sorting <- c(TRUE, FALSE, NULL, 'asc', 'desc', 'freq', 'freq-asc', 'freq-desc',
'infreq', 'infreq-asc', 'infreq-desc', 'inorder', 'order')
if (length(sort.x) > 1
| !all(sort.x %in% allowed_sorting)) {
stop('Invalid value for `sort.x`: ', sort.x %>% concat(', '))
}
if (length(sort.y.category) > 1
| !all(sort.y.category %in% allowed_sorting)) {
stop('Invalid value for `sort.y.category`: ', sort.y.category %>% concat(', '))
}
if (length(sort.x.category) > 1
| !all(sort.x.category %in% allowed_sorting)) {
stop('Invalid value for `sort.x.category`: ', sort.x.category %>% concat(', '))
}
type.input <- type
if (type %in% c('c', 'col', 'rsi', 'mic')) {
type <- 'column'
horizontal <- FALSE
}
if (type %in% c('b', 'lollipop')) {
type = 'bar'
}
if (type == 'box') {
type = 'boxplot'
}
if (type == 'l') {
type <- 'line'
}
if (type == 'm') {
type <- 'map'
}
if (type == 'p') {
type <- 'point'
}
if (type %in% c('h', 'hist', 'histogram', 'f', 'freq', 'freqency')) {
type <- 'frequency' # wordt later "histogram"
}
if (type %in% c('d', 'dens')) {
type <- 'density' # wordt later "histogram"
}
if (!type %in% c('area', 'column', 'bar', 'barpercent', 'line', 'path', 'point', 'frequency', 'density', 'boxplot', 'map')) {
stop('`plot2` does not recognise type "', type.input, '".')
}
if (type == 'boxplot' & !missing(y.category) & !is.na(y.category)) {
stop('Type "', type.input, '" is incompatible with `y.category`. Use `x` to split groups.')
}
if (horizontal == TRUE & type %in% c('density', 'frequency', 'mic')) {
# hier ook boxplot bij??
stop('Horizontal view is incompatible with type ', type, '.')
}
if (type == 'bar') {
type <- 'column'
horizontal <- TRUE
}
if (type == 'barpercent') {
horizontal <- TRUE
y.percent <- TRUE
y.category <- NA
y.position <- 'right'
}
# alle data transformeren, schatten hoe grafiek moet worden o.b.v. input ----
x.remove.bak <- x.remove
variabelen <- plot2.variables(data,
x,
y,
y.category,
x.category,
type,
(missing(data) | misses.data),
(missing(x) | misses.x),
(missing(y) | misses.y),
(missing(y.category) | misses.y.category),
sort.x,
sort.y.category,
sort.x.category,
horizontal,
datalabels,
x.max,
x.max.txt,
summarise_function,
summarise_function_text,
na.replace,
na.rm)
data <- variabelen$data
grafiek <- variabelen$grafiek
x <- variabelen$x
y <- variabelen$y
y.category <- variabelen$y.category
x.remove <- variabelen$x.remove
meerdere_series <- variabelen$meerdere_series
datalabels.show <- variabelen$datalabels.show
datalabels <- variabelen$datalabels
if (!is.null(y.category.focus)) {
if (!y.category.focus %in% (data %>% pull(y.category))) {
stop("value '", y.category.focus, "' for `y.category.focus` not found in data$", y.category, ".", call. = FALSE)
}
}
###
# print(data)
# print(grafiek$data)
# if (type.input == 'rsi') {
# data <- data %>% filter_at(vars(x), any_vars(!is.na(.)))
# grafiek$data <- data
# datalabels <- datalabels[1:3]
# }
if (is.na(x.lbl.align)) {
# berekenen wat beter is qua uitlijning
if (x.lbl.angle %in% c(0:10, 171:190, 351:360)) {
xas.align <- 0.5 # midden
}
if (x.lbl.angle %in% c(191:350)) {
xas.align <- 0 # links
}
if (x.lbl.angle %in% c(11:170)) {
xas.align <- 1 # rechts
}
} else {
# als uitlijnen ingesteld is, dan zo hanteren
if (x.lbl.align %in% c('l', 'left')) {
xas.align <- 0
} else if (x.lbl.align %in% c('c', 'center')) {
xas.align <- 0.5
} else if (x.lbl.align %in% c('r', 'right')) {
xas.align <- 1
} else {
stop('No valid value for `x.lbl.align`, must be "left", "center", or "right".')
}
}
y.percent.break <- y.percent.break / 100
histdata <- NULL
if (meerdere_series == FALSE) {
# Enkele serie ------------------------------------------------------------
if (stackedpercent == TRUE | stacked == TRUE) {
warning("`stackedpercent` and `stacked` will be ignored in plots with only one category.", call. = FALSE)
}
if (length(colours) == data %>% pull(x) %>% n_distinct()) {
colour.list <- colours %>% colourpicker()
colour.list.fill <- colours %>% colourpicker(length = 1, opacity = 0.9)
} else {
colour.list <- colourpicker(colours[1], length = 1)
colour.list.fill <- colourpicker(colours[1], length = 1, opacity = 0.9)
}
colour.list.bak <- colour.list
# kleuren van MIC's
if (type.input == 'mic') {
if (AMR::is.mic(data$level) & (!is.na(break.S) | !is.na(break.R))) {
data_mic <- data %>% mutate(breaks = as.double(level),
col = 'certeroze')
if (!is.na(break.R)) {
# alles lager dan break.R geel maken
data_mic <- data_mic %>%
mutate(col = if_else(breaks < break.R, 'certegeel', col))
if (is.na(break.S)) {
break.S <- break.R / 2 # 1 stap lager dan R
}
}
if (!is.na(break.S)) {
# alles vanaf break.S groen maken
data_mic <- data_mic %>%
mutate(col = if_else(breaks <= break.S, 'certegroen', col))
}
colour.list = colourpicker(data_mic$col)
}
}
if (type == 'point') {
grafiek <- grafiek +
geom_point(colour = colour.list,
size = size,
na.rm = TRUE)
datalabels.show <- FALSE
} else if (type == 'line') {
if (smooth == TRUE) {
grafiek <- grafiek +
geom_smooth(
aes_string(x = x,
y = y,
group = 1),
stat = "smooth",
method = 'lm',
span = 0.1,
se = FALSE,
colour = colour.list,
size = size,
na.rm = TRUE)
} else {
grafiek <- grafiek +
geom_line(
aes_string(x = x,
y = y,
group = 1),
colour = colour.list,
lineend = 'round',
size = size,
na.rm = TRUE)
}
datalabels.show <- FALSE
x.remove <- FALSE
} else if (type == 'path') {
if (smooth == TRUE) {
grafiek <- grafiek + geom_smooth(
aes_string(x = x,
y = y,
group = 1),
stat = "smooth",
method = 'lm',
span = 0.1,
se = FALSE,
colour = colour.list,
size = size,
na.rm = TRUE)
} else {
grafiek <- grafiek +
geom_path(
aes_string(x = x,
y = y,
group = 1),
colour = colour.list,
lineend = 'round',
size = size,
na.rm = TRUE)
}
datalabels.show <- FALSE
x.remove <- FALSE
} else if (type == 'area') {
grafiek <- ggplot(data) +
geom_area(aes_string(x = x,
y = y),
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels.show <- FALSE
} else if (type.input == "lollipop") {
grafiek <- grafiek +
geom_segment(
aes_string(xend = x, y = 0, yend = y),
colour = colour.list,
size = size / 4,
na.rm = TRUE) +
geom_point(
size = size,
color = colour.list[1],
na.rm = TRUE)
datalabels <- FALSE
datalabels.show <- FALSE
} else if (type %in% c('barpercent', 'column')) {
grafiek <- grafiek + geom_col(
colour = colour.list,
fill = colour.list,
width = ifelse(!is.null(width), width, 0.5),
na.rm = TRUE)
} else if (type %in% c('density', 'frequency')) {
histdata <- data %>% pull(y)
# NA's eruit, geeft anders warning: Removed 7 rows containing non-finite values (stat_density).
histdata <- histdata[!is.na(histdata)]
if (type == 'density') {
grafiek <- grafiek +
geom_density(inherit.aes = FALSE,
data = tibble(x = histdata),
mapping = aes(x = x),
colour = colour.list[1],
fill = paste0(colour.list[1], '15'),
na.rm = TRUE) # alpha toevoegen (00-AA)
} else if (type == 'frequency') {
if (is.null(bins)) {
bins <- min(20, n_distinct(histdata) / 3)
# minimaal aantal waarnemingen wanneer onder de 20 én onder n/3:
#bins <- max(min(20, n_distinct(histdata) / 3), n_distinct(histdata))
}
grafiek <- grafiek +
geom_histogram(inherit.aes = FALSE,
data = tibble(x = histdata),
mapping = aes(x = x),
colour = colour.list[1],
fill = paste0(colour.list[1], '15'), # alpha toevoegen (00-AA)
bins = bins,
na.rm = TRUE)
}
type <- 'histogram'
datalabels <- FALSE
datalabels.show <- FALSE
x.remove <- FALSE
# y-as
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.percent,
# breaks = seq(from = min(grafiek$data[, y]), to = max(grafiek$data[, y]), by = y.percent.break),
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.percent.EN,
# breaks = seq(from = min(grafiek$data[, y]), to = max(grafiek$data[, y]), by = y.percent.break),
position = y.position)
}
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.number.EN,
position = y.position)
}
}
} else if (type == 'boxplot') {
# alle waarden van x zijn uniek, dan geen categorieen van x gebruiken
data[, x] <- ''
grafiek <- ggplot(data, aes_string(x = x, y = y)) +
# whiskerlijn boven en onder:
stat_boxplot(geom = 'errorbar',
coef = 1.5, # 1.5 * IQR
colour = colour.list[1],
width = ifelse(!is.null(width), width, 0.5) * 0.66,
lwd = (size * 0.75) / 2.5) +
# boxplot met uitbijters:
geom_boxplot(
colour = colour.list[1],
fill = if_else(colours == 'certe', colourpicker('certeblauw3'), colour.list.fill[1]),
outlier.size = 1.5,
width = ifelse(!is.null(width), width, 0.5),
lwd = (size * 0.75) / 2.5, # line width, van hele vlak
fatten = 1.5, # factor om mediaan dikker te maken t.o.v. lwd
na.rm = TRUE)
x.remove <- TRUE
if (is.na(x.title)) {
x.title <- ''
}
}
if (length(y.scale) == 1 & type != 'histogram') {
# want length(NA) = 1
if (!is.na(y.scale)) {
stop('The scale for the y-axis cannot be a single value.')
} else {
# if (!is.numeric(data %>% pull(x))) {
# grafiek <- grafiek + scale_x_discrete(position = x.position,
# breaks = waiver())
# } else {
# grafiek <- grafiek + scale_x_continuous(position = x.position,
# breaks = waiver())
# }
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
labels = plot2.format.percent,
breaks = seq(from = min(0, 1.25 * min(data %>% pull(y))),
to = 1.25 * max(data %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
breaks = seq(from = min(0, 1.25 * min(data %>% pull(y))),
to = 1.25 * max(data %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
labels = plot2.format.percent.EN,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(data %>% pull(y))), 1.25 * max(data %>% pull(y))),
labels = plot2.format.number.EN,
position = y.position)
}
}
}
}
} else if (type != 'histogram') {
# if (!is.numeric(data %>% pull(x))) {
# grafiek <- grafiek + scale_x_discrete(position = x.position,
# breaks = waiver())
# } else {
# grafiek <- grafiek + scale_x_continuous(position = x.position,
# breaks = waiver())
# }
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent.EN,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.number.EN,
position = y.position)
}
}
}
}
} else {
# Meerdere series ---------------------------------------------------------
# kleuren
colour.list <- colourpicker(colours,
length = data %>% pull(y.category) %>% n_distinct())
colour.list.fill <- colourpicker(colours,
length = data %>% pull(y.category) %>% n_distinct(),
opacity = 0.9)
colour.list.bak <- colour.list
if (!is.null(y.category.focus)) {
# put focussed on top by reordering the factor: focussed one must come last
seq.old <- c(1:length(levels(data %>% pull(y.category))))
seq.new <- seq.old[levels(data %>% pull(y.category)) != y.category.focus]
seq.new <- c(seq.new, seq.old[!seq.old %in% seq.new])
data[, y.category] <- forcats::lvls_reorder(data %>% pull(y.category), seq.new)
# set focus colour to first of colour.list
colour.list[levels(data %>% pull(y.category)) == y.category.focus] <- colour.list[1]
colour.list.fill[levels(data %>% pull(y.category)) == y.category.focus] <- colour.list[1]
# set grey to all others
colour.list[levels(data %>% pull(y.category)) != y.category.focus] <- "lightgrey"
colour.list.fill[levels(data %>% pull(y.category)) != y.category.focus] <- "lightgrey"
}
if (length(x) > 1) {
# colour.list <- rep(colour.certe(length = 1, palette = palette), length(x))
# colour.list.fill <- rep(colour.certe(length = 1, palette = palette, tint = 0.9), length(x))
colour.list <- colourpicker(colours[1], length = length(x))
colour.list.fill <- colourpicker(colours[1], length = length(x), opacity = 0.9)
}
# colour.list2 bevat zoveel waarden als nrow(data).
for (k in 1:length(colour.list)) {
if (k == 1) {
colour.list2 <- rep(colour.list[k], nrow(data) / length(colour.list))
} else {
colour.list2 <- c(colour.list2, rep(colour.list[k], nrow(data) / length(colour.list)))
}
}
if (type == 'point') {
grafiek <- ggplot(data) +
geom_point(aes_string(x = x, y = y, colour = y.category),
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels.show <- FALSE
} else if (type == 'line') {
if (smooth == TRUE) {
poly.min <- min(8, data %>% pull(x) %>% n_distinct() - 1)
grafiek <- ggplot(data) +
stat_smooth(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
se = FALSE,
method = 'lm',
size = size,
formula = y ~ poly(x, poly.min)) +
scale_colour_manual(values = colour.list)
} else {
grafiek <- ggplot(data) +
geom_line(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
lineend = 'round',
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
}
datalabels.show <- FALSE
} else if (type == 'path') {
if (smooth == TRUE) {
poly.min <- min(8, data %>% pull(x) %>% n_distinct() - 1)
grafiek <- ggplot(data) +
stat_smooth(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
se = FALSE,
method = 'lm',
size = size,
formula = y ~ poly(x, poly.min)) +
scale_colour_manual(values = colour.list)
} else {
grafiek <- ggplot(data) +
geom_line(aes_string(x = x,
y = y,
colour = y.category,
group = y.category),
lineend = 'round',
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
}
datalabels.show <- FALSE
} else if (type == 'area') {
grafiek <- ggplot(data) +
geom_area(aes_string(x = x,
y = y,
colour = y.category,
fill = y.category,
group = y.category),
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels.show <- FALSE
} else if (type.input == "lollipop") {
grafiek <- grafiek +
geom_segment(
aes_string(xend = x, y = 0, yend = y),
colour = colour.list[1],
size = size / 4,
na.rm = TRUE) +
geom_point(
aes_string(colour = y.category),
size = size,
na.rm = TRUE) +
scale_colour_manual(values = colour.list)
datalabels <- FALSE
datalabels.show <- FALSE
} else if (type == 'column') {
breedte.a <- 0.5
breedte.b <- 0.5
breedte.c <- breedte.b * 1.05
if (length(x) > 1) {
breedte.a <- 0.95
breedte.b <- 0.95
breedte.c <- 0.95
}
if (stackedpercent == TRUE) {
if (!missing(stacked) & stacked == FALSE) {
# warning("'stacked = FALSE' will be ignored because stackedpercent = TRUE.")
}
grafiek <- grafiek + geom_bar(width = ifelse(!is.null(width), width, breedte.a),
stat = 'identity',
position = position_fill(reverse = reverse),
na.rm = TRUE)
# +
# # hoeft geen plot2.format.percent.EN van
# scale_y_continuous(labels = plot2.format.percent,
# breaks = seq(from = 0, to = 1, by = y.percent.break),
# minor_breaks = NULL,
# position = y.position)
} else {
if (stacked == TRUE) {
grafiek <- grafiek + geom_bar(width = ifelse(!is.null(width), width, breedte.a),
stat = 'identity',
position = position_stack(reverse = reverse),
na.rm = TRUE)
} else {
grafiek <- grafiek + geom_bar(width = ifelse(!is.null(width), width, breedte.b),
stat = 'identity',
# kleine witte ruimte tussen kolommen:
position = position_dodge2(width = ifelse(!is.null(width), width * 1.05, breedte.c), preserve = "single"),
na.rm = TRUE)
}
}
} else if (type == 'boxplot') {
if (data %>% pull(y.category) %>% is.na() %>% all()) {
data[, y.category] <- ''
x.remove <- TRUE
x.title <- ''
}
grafiek <- ggplot(data, aes_string(x = x, y = y)) +
# whiskerlijn boven en onder:
stat_boxplot(geom = 'errorbar',
coef = 1.5, # 1.5 * IQR
colour = colour.list[1],
width = ifelse(!is.null(width), width, 0.5) * 0.66,
lwd = (size * 0.75) / 2.5) +
# boxplot met uitbijters:
geom_boxplot(
colour = colour.list[1],
fill = if_else(colours == 'certe', colourpicker('certeblauw3'), colour.list.fill[1]),
outlier.size = 1.5,
width = ifelse(!is.null(width), width, 0.5),
lwd = (size * 0.75) / 2.5, # line width, van hele vlak
fatten = 1.5, # factor om mediaan dikker te maken t.o.v. lwd
na.rm = TRUE)
}
if (length(y.scale) == 1) {
# want length(NA) = 1
if (!is.na(y.scale)) {
stop('The scale for the y-axis cannot be a single value.')
} else if (stackedpercent == FALSE) {
max_vars <- c(x, x.category)
max_vars <- max_vars[!is.na(max_vars)]
if (stacked == TRUE) {
# sum per groep om maximale y op as te bepalen
suppressWarnings(
maxdata <- data %>%
as.data.frame() %>%
as.tibble() %>%
mutate_if(is.factor, as.character) %>%
group_by_at(vars(max_vars)) %>%
summarise_at(vars(y), sum, na.rm = TRUE)
)
} else {
# max per groep om maximale y op as te bepalen
suppressWarnings(
maxdata <- data %>%
as.data.frame() %>%
as.tibble() %>%
mutate_if(is.factor, as.character) %>%
group_by_at(vars(max_vars)) %>%
summarise_at(vars(y), max, na.rm = TRUE)
)
}
maxdata[, y] <- maxdata %>% pull(y) %>% gsub(Inf, 0, .)
maxdata[, y] <- maxdata %>% pull(y) %>% as.double() # soms nodig, omdat er anders een tibble ontstaat met <chr>
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = plot2.format.percent,
breaks = seq(from = min(0, 1.25 * min(maxdata %>% pull(y))),
to = 1.25 * max(maxdata %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = plot2.format.percent.EN,
breaks = seq(from = min(0, 1.25 * min(maxdata %>% pull(y))),
to = 1.25 * max(maxdata %>% pull(y)),
by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = c(min(0, 1.25 * min(maxdata %>% pull(y))), 1.25 * max(maxdata %>% pull(y))),
labels = plot2.format.number.EN,
position = y.position)
}
}
}
} else {
# stackedpercent = TRUE, y.percent = FALSE (gewone data op een 100% gestapelde grafiek)
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
labels = plot2.format.percent,
breaks = seq(from = 0, to = 1, by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.percent == TRUE) {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.percent.EN,
breaks = seq(from = min(y.scale), to = max(y.scale), by = y.percent.break),
minor_breaks = NULL,
position = y.position)
}
} else {
if (y.24h == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
breaks = seq(0, 1.25 * max(data %>% pull(y)), by = 24),
labels = paste0(seq(0, 1.25 * max(data %>% pull(y)), by = 24), 'u (', seq(0, 1.25 * max(data %>% pull(y)), by = 24) / 24, 'd)'),
position = y.position)
} else if (y.age == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
breaks = c(1:max(data %>% pull(y))) * 10,
labels = c(1:max(data %>% pull(y))) * 10,
position = y.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = format2,
position = y.position)
} else {
grafiek <- grafiek + scale_y_continuous(expand = c(0, 0),
limits = y.scale,
labels = plot2.format.number.EN,
position = y.position)
}
}
}
}
# if (!is.numeric(data %>% pull(x))) {
# grafiek <- grafiek + scale_x_discrete(position = x.position,
# breaks = waiver())
# } else {
# grafiek <- grafiek + scale_x_continuous(position = x.position,
# breaks = waiver())
# }
if (length(x) > 1) {
grafiek <- grafiek +
facet_grid(~pull(data, x[2]), space = "free_x", switch = 'y')
if (y.category %in% x) {
legend.position <- 'none'
}
}
# kleuren
grafiek <- grafiek + scale_fill_manual(values = colour.list)
}
# X-as --------------------------------------------------------------------
if (is.null(histdata)) {
x_classes <- data %>% pull(x) %>% class()
} else {
x_classes <- histdata %>% class()
}
if ("Date" %in% x_classes) {
grafiek <- grafiek + scale_x_date(position = x.position,
date_breaks = x.date_breaks,
date_labels = x.date_labels)
} else if (any(c('POSIXct', 'POSIXlt') %in% x_classes)) {
grafiek <- grafiek + scale_x_datetime(position = x.position,
date_breaks = x.date_breaks,
date_labels = x.date_labels)
} else {
if (!is.numeric(data %>% pull(x))) {
grafiek <- grafiek + scale_x_discrete(position = x.position)
} else {
if (format.NL == TRUE) {
grafiek <- grafiek + scale_x_continuous(labels = format2,
position = x.position)
} else {
grafiek <- grafiek + scale_x_continuous(labels = plot2.format.number.EN,
position = x.position)
}
}
}
# Rest --------------------------------------------------------------------
if (datalabels.show == TRUE) {
if (all(datalabels %>% is.double2())) {
datalabels <- datalabels %>% as.double()
}
if (type != 'boxplot') {
if (is.double(datalabels)) {
if (y.percent == TRUE) {
if (type == 'barpercent') {
datalabels <- paste0(datalabels %>%
format2(datalabels.round, format.NL = format.NL),
' (',
data %>%
pull(y) %>%
as.percent() %>%
format2(round = datalabels.round, format.NL = format.NL),
')')
} else {
datalabels <- datalabels %>% as.percent() %>% format2(round = datalabels.round, format.NL = format.NL)
}
} else {
datalabels <- datalabels %>% format2(datalabels.round, format.NL = format.NL)
}
}
# waarden als tekst en 0 vervangen door ""
datalabels <- datalabels %>% as.character() %>% gsub('^0[.,0]*$', '', .)
grafiek <- plot2.datalabels(grafiek,
data,
x,
y,
datalabels,
datalabels.fill,
y.category,
stacked,
stackedpercent,
horizontal,
reverse,
font.family,
text.factor,
width)
} else if (type == 'boxplot') {
# if (horizontal == TRUE) {
# v <- 0.5
# h <- 1.75
# } else {
# v <- 1.75
# h <- 0.5
# }
#
# if (meerdere_series == TRUE) {
# data.boxplotlbl <- data %>%
# mutate(x = data %>% pull(y.category))
# } else {
# data.boxplotlbl <- data
# }
#
# data.boxplotlbl <- data.boxplotlbl %>%
# group_by(x = eval(x)) %>%
# summarise(n = paste('n =', format2(n())))
#
# grafiek <- grafiek +
# geom_text(
# data = data.boxplotlbl,
# aes(x = x,
# y = 0,
# label = n),
# inherit.aes = FALSE,
# size = 3 * text.factor,
# colour = colour.list[1],
# vjust = v, # iets onder y = 0
# hjust = h, # of iets links van y = 0 bij horizontal == TRUE
# fontface = 'italic',
# na.rm = TRUE)
}
}
if (show.mean == TRUE) {
# voor boxplots
x.initlijst <- integer(0)
if (meerdere_series == TRUE) {
x.aantallen <- data %>%
mutate(x = data %>% pull(y.category))
} else {
x.aantallen <- data
}
x.aantallen <- x.aantallen %>%
group_by(x = eval(x)) %>%
summarise(n())
#for (i in 1:n_distinct(data[, x])) {
for (i in 1:nrow(x.aantallen)) {
# aantallen toevoegen
x.initlijst <- c(x.initlijst, rep(i, x.aantallen[i, 2]))
}
if (meerdere_series == TRUE) {
data.boxplotmean <- data %>%
mutate(x = data %>% pull(y.category))
} else {
data.boxplotmean <- data
}
data.boxplotmean <- data.boxplotmean %>%
mutate(y = data.boxplotmean[, y]) %>%
group_by(x = eval(x)) %>%
mutate(gem.y = mean(y)) %>%
arrange(x) %>%
as.data.frame()
data.boxplotmean <- data.boxplotmean %>%
mutate(x.init = x.initlijst) %>%
mutate(x.voor = x.init - (0.75 / 2),
x.na = x.init + (0.75 / 2))
colour.list.mean <- colourpicker(colours, length = 3)[3]
if (colour.list.mean == colour.list[1]) {
colour.list.mean <- colourpicker('certeroze')
}
if (colours %like% '^rug') {
colour.list.mean <- colourpicker('black')
}
grafiek <- grafiek +
geom_segment(data = data.boxplotmean,
aes_string(
y = 'gem.y',
yend = 'gem.y',
x = 'x.voor',
xend = 'x.na'),
colour = colour.list.mean,
size = 0.5,
linetype = 5,
na.rm = TRUE)
}
if (meerdere_series == TRUE) {
if (data %>% pull(y.category) %>% n_distinct() == 1) {
# geen legenda wanneer er maar 1 item in staat
legend.position <- 'none'
y <- unique(data %>% pull(y.category))
}
}
t <- function(x) {
lang <- Sys.getlocale("LC_CTYPE")
if (x == 'en') {
if (lang %like% 'English') {
x <- 'and'
} else if (lang %like% 'German') {
x <- 'und'
# } else if (!lang %like% 'Dutch') {
# x <- '/'
}
}
if (x == 'per') {
if (lang %like% 'English') {
x <- 'per'
} else if (lang %like% 'German') {
x <- 'pro'
# } else if (!lang %like% 'Dutch') {
# x <- '/'
}
}
x
}
word_wrapper <- function(x, width, markdown = FALSE) {
paste(strwrap(x = x, width = width), collapse = ifelse(markdown, "<br>", "\n"))
}
x <- gsub("^n$", ifelse(stackedpercent == TRUE, "aandeel", "aantal"), x)
y <- gsub("^n$", ifelse(stackedpercent == TRUE, "aandeel", "aantal"), y)
if (!is.expression(title) && is.na(title) & type.input != 'barpercent') {
if (!is.na(x.category)) {
title <- toproper(paste(y, t('per'), x.category, t('en'), x), every = FALSE)
} else if (!is.na(y.category)) {
title <- toproper(paste(y, t('per'), x, t('en'), y.category), every = FALSE)
} else {
title <- toproper(paste(y, t('per'), x), every = FALSE)
}
} else if (!is.expression(title) && is.na(title) & type.input == 'barpercent') {
title <- ''
}
if (is.expression(title)) {
grafiek <- grafiek + labs(title = title)
} else if (title != '') {
if (grepl('n()', title, fixed = TRUE)) {
title <- gsub('n()', data %>% ungroup() %>% nrow() %>% format2(format.NL = format.NL), title, fixed = TRUE)
}
if (grepl('n_distinct[(].+[)]', title)) {
kolom <- regmatches(title, regexpr('[(].+[)]', title, perl = TRUE))
kolom <- substr(kolom, 2, nchar(kolom) - 1)
title <- gsub('n_distinct[(].+[)]', data %>% pull(kolom) %>% n_distinct() %>% format2(format.NL = format.NL), title)
}
if (title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
title <- markdown_bolditalic(title)
} else {
title <- word_wrapper(title, title_maxlength)
}
grafiek <- grafiek + labs(title = title)
}
if (is.expression(subtitle)) {
grafiek <- grafiek + labs(subtitle = subtitle)
} else if (subtitle != '') {
if (grepl('n()', subtitle, fixed = TRUE)) {
subtitle <- gsub('n()', data %>% ungroup() %>% nrow() %>% format2(format.NL = format.NL), subtitle, fixed = TRUE)
}
if (grepl('n_distinct[(].+[)]', subtitle)) {
kolom <- regmatches(subtitle, regexpr('[(].+[)]', subtitle, perl = TRUE))
kolom <- substr(kolom, 2, nchar(kolom) - 1)
subtitle <- gsub('n_distinct[(].+[)]', data %>% pull(kolom) %>% n_distinct() %>% format2(format.NL = format.NL), subtitle)
}
if (subtitle %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
subtitle <- markdown_bolditalic(subtitle)
} else {
subtitle <- word_wrapper(subtitle, subtitle_maxlength)
}
grafiek <- grafiek + labs(subtitle = subtitle)
}
if (is.expression(caption)) {
grafiek <- grafiek + labs(caption = caption)
} else if (caption != '') {
if (caption %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
caption <- markdown_bolditalic(caption)
}
grafiek <- grafiek + labs(caption = caption)
}
if (is.expression(tag)) {
grafiek <- grafiek + labs(tag = tag)
} else if (tag != '') {
if (tag %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
tag <- markdown_bolditalic(tag)
}
grafiek <- grafiek + labs(tag = tag)
}
# thema toepassen
if (certe_theme == TRUE) {
grafiek <- grafiek +
theme_certe(subtitle.colour = ifelse(type.input == 'mic',
colourpicker('certeblauw'),
colour.list.bak[1]),
x.lbl.angle = x.lbl.angle,
x.lbl.align = xas.align,
horizontal = horizontal,
font.family = font.family,
legend.position = legend.position,
text.factor = text.factor,
x.category.fill = colourpicker(x.category.fill),
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.margin = x.category.margin,
has_subtitle = !subtitle %in% c("", NA))
}
if (type == 'histogram') {
grafiek <- grafiek +
theme(panel.grid.major = element_blank(),
panel.grid.minor = element_blank())
}
# legenda - moet na certe theme, anders wordt theme(legend.title) opnieuw gedefinieerd
if (is.expression(legend.title)) {
grafiek <- grafiek + labs(colour = legend.title, fill = legend.title)
} else if (legend.title != '') {
if (legend.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
legend.title <- markdown_bolditalic(legend.title)
}
grafiek <- grafiek + labs(colour = legend.title, fill = legend.title)
} else {
grafiek <- grafiek + theme(legend.title = element_blank())
}
#
# X en Y assen
#
if (x.remove.bak == TRUE) {
# overrulen
x.remove <- TRUE
}
if (is.na(x.title)) {
if (!is.na(x.category)) {
grafiek <- grafiek + labs(x = toproper(paste(x.category, t('en'), x)))
} else {
grafiek <- grafiek + labs(x = toproper(x, intelligent = TRUE))
}
} else {
if (x.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
x.title <- markdown_bolditalic(x.title)
}
grafiek <- grafiek + labs(x = x.title)
}
if (x.remove == TRUE) {
grafiek <- grafiek +
theme(
axis.text.x = element_blank()
)
}
if (x.lbl.italic == TRUE) {
if (horizontal == FALSE) {
grafiek <- grafiek + theme(axis.text.x = element_text(face = 'italic'))
} else {
grafiek <- grafiek + theme(axis.text.y = element_text(face = 'italic'))
}
}
if (is.na(y.title)) {
grafiek <- grafiek + labs(y = toproper(y, intelligent = TRUE))
#} else if (y.title != '') {
} else {
if (y.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
y.title <- markdown_bolditalic(y.title)
}
grafiek <- grafiek + labs(y = y.title)
}
if (y.remove == TRUE) {
grafiek <- grafiek +
theme(
axis.text.y = element_blank()
)
}
# als schaal van y-as tot max 100% loopt dan secundaire lijnen verwijderen
# if (y.percent == TRUE & length(y.scale) > 1) {
# if (max(y.scale) == 1) {
# grafiek <- grafiek +
# theme(panel.grid.minor.y = element_blank())
# }
# }
if (!is.na(x.category)) {
scales <- 'fixed'
if (x.category.repeat.lbls.x == TRUE & x.category.repeat.lbls.y == TRUE) {
scales <- 'free'
} else if (x.category.repeat.lbls.y == TRUE) {
scales <- 'free_y'
if (horizontal == TRUE) {
scales <- 'free_x'
}
} else if (x.category.repeat.lbls.x == TRUE) {
scales <- 'free_x'
if (horizontal == TRUE) {
scales <- 'free_y'
}
}
if (is.na(x.category.nrow)) {
x.category.nrow <- NULL
}
if (any(data %>% pull(x.category) %>% is.na())) {
# drop is droppen van factors levels. Als dit FALSE is en de kolom bevat NA, geeft het een fout:
# Error in scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales)
x.category.drop <- TRUE
}
if (x.category.relative == TRUE) {
switch <- "x"
if (horizontal == TRUE) {
switch <- "y"
}
grafiek$data <- grafiek$data %>%
ungroup() %>%
mutate("x.category" = grafiek$data %>% pull(x.category))
grafiek <- grafiek +
facet_grid(cols = vars(x.category),
space = scales,
drop = x.category.drop,
scales = scales,
switch = switch)
} else {
grafiek <- grafiek +
facet_wrap(x.category,
scales = scales,
strip.position = x.category.position,
drop = x.category.drop,
nrow = x.category.nrow)
}
}
if (horizontal == TRUE) {
grafiek <- grafiek + coord_flip()
}
if (print == TRUE) {
print(grafiek)
} else {
# Class toevoegen
class(grafiek) <- c('certedata_plot2', class(grafiek))
grafiek
}
}
#' @rdname plot2
#' @export
plot2.column <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
reverse = FALSE, # omdat bij bar horizontal = FALSE
width = NULL,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = FALSE,
reverse = reverse,
width = width,
type = 'column',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.area <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
#stacked = TRUE,
#stackedpercent = FALSE,
reverse = FALSE, # omdat bij bar horizontal = FALSE
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
#stacked = stacked,
#stackedpercent = stackedpercent,
stacked = TRUE,
stackedpercent = FALSE,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = FALSE,
reverse = reverse,
type = 'area',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.bar <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
reverse = TRUE, # want bij bar horizontal = TRUE
width = NULL,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
if (!missing(datalabels)) {
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
}
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = TRUE,
reverse = reverse,
width = width,
type = 'column',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.barpercent <- function(data = NA,
x = NA,
y = NA,
x.title = NA,
y.title = '',
x.category = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = 10,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.scale = NA,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = 1,
datalabels.fill = 'white',
width = NULL,
summarise_function = sum,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.percent = TRUE,
y.scale = y.scale,
y.position = 'right',
y.remove = y.remove,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
width = width,
summarise_function = summarise_function,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
sort.x = 'freq-desc',
horizontal = TRUE,
type = 'barpercent',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.lollipop <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
size = 2,
summarise_function = sum,
stacked = FALSE,
stackedpercent = FALSE,
reverse = TRUE, # want bij bar horizontal = TRUE
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = NA,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
size = size,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
horizontal = TRUE,
reverse = reverse,
type = 'lollipop',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.line <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
smooth = FALSE,
size = 0.75,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
smooth = smooth,
size = size,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'line',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.path <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
smooth = FALSE,
size = 0.75,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
smooth = smooth,
size = size,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'path',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.point <- function(data = NA,
x = NA,
y = NA,
y.category = NA,
x.category = NA,
x.title = NA,
y.title = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = if_else(y.percent == FALSE, 2, 1),
datalabels.fill = 'white',
summarise_function = sum,
size = 2,
legend.position = 'top',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
y.remove = y.remove,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
size = size,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'point',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = missing(y.category),
misses.datalabels = missing(datalabels),
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' @rdname plot2
#' @export
plot2.mic <- function(data = NA,
y = NA,
x = NA,
x.title = 'MIC-waarde',
y.title = 'Aantal',
title = 'Overzicht MIC-waarden',
subtitle = NA,
break.S = NA,
break.R = break.S,
...) {
if (is.na(subtitle)) {
subtitle <- deparse(substitute(data))
subtitle <- gsub('_mic$', '', subtitle)
if (subtitle %in% AMR::antibiotics$molis) {
subtitle <- abname_molis(subtitle)
}
}
plot2(data = data,
y = y,
x = x,
type = 'mic',
y.title = y.title,
x.title = x.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
break.S = break.S,
break.R = break.R,
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
...)
}
#' @rdname plot2
#' @export
plot2.rsi <- function(data = NA,
x = NA,
y.category = "interpretatie",
x.category = NA,
x.title = NA,
y.title = NA,
fun = portion_df,
translate_ab = "trivial_nl",
minimum = 30,
title = "Gevoeligheidsanalyse",
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = 1,
x.category.margin = 3.5,
x.category.relative = FALSE,
colours = "certe_rsi",
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
sort.x = TRUE,
sort.y.category = TRUE,
sort.x.category = TRUE,
datalabels = TRUE,
datalabels.round = 1,
datalabels.fill = 'white',
summarise_function = sum,
stacked = FALSE,
stackedpercent = TRUE,
reverse = FALSE, # omdat bij bar horizontal = FALSE
legend.position = 'right',
legend.title = '',
print = FALSE,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# if (is.na(subtitle)) {
# subtitle <- deparse(substitute(data))
# subtitle <- gsub('_mic$', '', subtitle)
# if (subtitle %in% AMR::antibiotics$molis) {
# subtitle <- abname_molis(subtitle)
# }
# }
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
# if (!missing(y)) {
# y <- quasiquotate(deparse(substitute(y)), y)
# }
if (!missing(y.category)) {
y.category <- quasiquotate(deparse(substitute(y.category)), y.category)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
fun_name <- deparse(substitute(fun))
if (!fun_name %in% c("portion_df", "count_df")) {
stop("`fun` must be portion_df or count_df")
}
if (fun_name == "portion_df") {
if (missing(y.percent)) {
y.percent <- TRUE
}
if (missing(y.scale)) {
y.scale <- c(0, 1)
}
}
if (!missing(data)) {
if (!missing(x) & x != "ab") {
data <- data %>% group_by_at(x)
}
if (!is.na(x.category)) {
if (!x.category %in% c("ab", "antibiotica", "Antibiotic")) {
data <- data %>% group_by_at(x.category)
}
}
data <- fun(data, translate_ab = translate_ab, minimum = minimum)
colnames(data) <- gsub("^Interpretation$", "interpretatie",
colnames(data))
colnames(data) <- gsub("^Antibiotic$", "ab", colnames(data))
colnames(data) <- gsub("^(Percentage|Count|Value)$", "waarde",
colnames(data))
if (missing(x)) {
x <- "ab"
}
y <- "waarde"
}
plot2(data = data,
x = x,
y = y,
y.category = y.category,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.position = x.position,
x.remove = x.remove,
x.max = x.max,
x.max.txt = x.max.txt,
y.remove = y.remove,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
sort.x = sort.x,
sort.y.category = sort.y.category,
sort.x.category = sort.x.category,
datalabels = datalabels,
datalabels.round = datalabels.round,
datalabels.fill = datalabels.fill,
summarise_function = summarise_function,
stacked = stacked,
stackedpercent = stackedpercent,
reverse = reverse,
legend.position = legend.position,
legend.title = legend.title,
print = print,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
via_wrapper = TRUE,
misses.data = missing(data),
misses.x = FALSE,
misses.y = FALSE,
...)
}
#' @rdname plot2
#' @export
plot2.boxplot <- function(data = NA,
x = NA,
y = NA,
x.title = NA,
y.title = NA,
x.category = NA,
title = NA,
subtitle = '',
caption = '',
tag = '',
title_maxlength = 60,
subtitle_maxlength = 60,
na.replace = "(onbekend)",
na.rm = FALSE,
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = TRUE,
x.category.repeat.lbls.y = TRUE,
x.category.drop = FALSE,
x.category.nrow = NA,
x.category.margin = 3.5,
x.category.relative = FALSE,
x.date_breaks = "1 month",
x.date_labels = "mmm",
y.category.focus = NULL,
colours = getOption("plot2.colours", "certe"),
x.lbl.angle = 0,
x.lbl.align = NA,
x.lbl.italic = FALSE,
x.position = 'bottom',
x.remove = FALSE,
x.max = NA,
x.max.txt = '(rest, x %n)',
y.remove = FALSE,
y.24h = FALSE,
y.age = FALSE,
y.percent = FALSE,
y.percent.break = 10,
y.scale = NA,
y.position = 'left',
datalabels = TRUE,
horizontal = FALSE,
show.mean = FALSE,
legend.position = 'top',
legend.title = '',
print = FALSE,
size = 2,
width = NULL,
font.family = 'Calibri',
text.factor = 1,
format.NL = Sys.isdecimalcomma(),
x.lbl = NA,
...) {
# quasiquotation
if (!missing(x)) {
x <- quasiquotate(deparse(substitute(x)), x)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
x.category <- quasiquotate(deparse(substitute(x.category)), x.category)
datalabels <- quasiquotate(deparse(substitute(datalabels)), datalabels)
summarise_function_text <- deparse(substitute(summarise_function))
plot2(data = data,
x = x,
y = y,
x.category = x.category,
x.title = x.title,
y.title = y.title,
title = title,
subtitle = subtitle,
caption = caption,
tag = tag,
title_maxlength = title_maxlength,
subtitle_maxlength = subtitle_maxlength,
na.replace = na.replace,
na.rm = na.rm,
x.category.fill = x.category.fill,
x.category.position = x.category.position,
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.repeat.lbls.x = x.category.repeat.lbls.x,
x.category.repeat.lbls.y = x.category.repeat.lbls.y,
x.category.drop = x.category.drop,
x.category.nrow = x.category.nrow,
x.category.margin = x.category.margin,
x.category.relative = x.category.relative,
x.date_breaks = x.date_breaks,
x.date_labels = x.date_labels,
y.category.focus = y.category.focus,
colours = colours,
x.lbl.angle = x.lbl.angle,
x.lbl.align = x.lbl.align,
x.lbl.italic = x.lbl.italic,
x.remove = x.remove,
x.position = x.position,
x.max = x.max,
x.max.txt = x.max.txt,
y.remove = y.remove,
y.24h = y.24h,
y.age = y.age,
y.percent = y.percent,
y.percent.break = y.percent.break,
y.scale = y.scale,
y.position = y.position,
datalabels = datalabels,
horizontal = horizontal,
show.mean = show.mean,
legend.position = legend.position,
legend.title = legend.title,
print = print,
size = size,
width = width,
font.family = font.family,
text.factor = text.factor,
format.NL = format.NL,
x.lbl = x.lbl,
type = 'boxplot',
misses.data = missing(data),
misses.x = missing(x),
misses.y = missing(y),
misses.y.category = TRUE,
via_wrapper = TRUE,
summarise_function_text = summarise_function_text,
...)
}
#' GIS-data plotten
#'
#' Hiermee kan GIS-data van \code{\link{get_map}} geplot worden.
#' @param y Naam van de antibioticumkolom.
#' @param y.scale Standaard is tussen 0 en 50\%. De schaal van y; in feite de schaal van de legenda.
#' @param colours Standaard is wit en Certe-roze. Twee kleuren voor het kleurenpalet van de grafiek; de overgang hiertussen wordt automatisch berekend. Zie \code{\link{colourpicker}}.
#' @param legend.title Standaard is \code{"\%IR"}. Titel van de legenda.
#' @inheritParams plot2
#' @export
plot2.map <- function(data,
y,
y.scale = c(0, 0.5),
title = '',
subtitle = '',
caption = '',
tag = '',
colours = c("white", colourpicker("certeroze")),
legend.title = "%IR",
legend.position = "right",
print = FALSE,
font.family = 'Calibri',
text.factor = 1) {
if (!"sf" %in% class(data)) {
stop("`data` must be a simple feature collection (class 'sf')", call. = FALSE)
}
if (!missing(y)) {
y <- quasiquotate(deparse(substitute(y)), y)
}
if (!y %in% colnames(data)) {
stop('column `', y, '` does not exist in simple feature collection', call. = FALSE)
}
if (all(is.na(data %>% pull(y)))) {
stop('All values of `', y, '` are NA - the map would be blank.', call. = FALSE)
}
library(sf)
limit <- y.scale
if (max(y.scale) >= 1) {
y.scale <- seq(min(y.scale), 1, 0.25)
y.scale.lbl <- paste0(y.scale, "%")
} else {
y.scale <- seq(min(y.scale), max(y.scale), 0.1)
y.scale.lbl <- c(paste0(y.scale[1:length(y.scale) - 1] * 100, "%"),
paste0(">=", y.scale[length(y.scale)] * 100, "%"))
}
grafiek <- ggplot(data) +
geom_sf(aes_string(fill = y,
colour = y),
na.rm = TRUE) +
theme_certe(legend.position = legend.position,
font.family = font.family,
text.factor = text.factor) +
theme(axis.title = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major = element_line(colour = "white"),
axis.text = element_blank()) +
scale_fill_gradient(low = colours[1],
high = colours[2],
na.value = "gray90",
limit = limit,
breaks = y.scale,
labels = y.scale.lbl) +
scale_colour_gradient(low = colours[1],
high = colours[2],
na.value = "gray90",
limit = limit,
breaks = y.scale,
labels = y.scale.lbl)
if (title != '') {
if (title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
title <- markdown_bolditalic(title)
}
grafiek <- grafiek + labs(title = title)
}
if (subtitle != '') {
if (subtitle %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
subtitle <- markdown_bolditalic(subtitle)
}
grafiek <- grafiek + labs(subtitle = subtitle)
}
if (caption != '') {
grafiek <- grafiek + labs(caption = caption)
}
if (tag != '') {
grafiek <- grafiek + labs(tag = tag)
}
# legenda
if (legend.title != '') {
if (legend.title %like% '[*_].*[*_]') {
# expressie van maken met hulpfunctie
legend.title <- markdown_bolditalic(legend.title)
}
grafiek <- grafiek + labs(colour = legend.title, fill = legend.title)
} else {
grafiek <- grafiek + theme(legend.title = element_blank())
}
if (print == TRUE) {
print(grafiek)
} else {
# Class toevoegen
class(grafiek) <- c('certedata_plot2', class(grafiek))
grafiek
}
}
#' @rdname plot2
#' @export
plot2.density <- function(y, x.title = 'Waarde', y.title = 'Dichtheid', y.percent = TRUE, ...) {
# quasiquotation
y <- quasiquotate(deparse(substitute(y)), y)
plot2(y = y,
type = 'density',
x.title = x.title,
y.title = y.title,
y.percent = y.percent,
...,
via_wrapper = TRUE)
}
#' @rdname plot2
#' @export
plot2.frequency <- function(y, x.title = '', y.title = 'Aantal', bins = NULL, ...) {
# quasiquotation
y <- quasiquotate(deparse(substitute(y)), y)
plot2(y = y,
type = 'frequency',
x.title = x.title,
y.title = y.title,
bins = bins,
...,
via_wrapper = TRUE)
}
#' @rdname plot2
#' @export
plot2.histogram <- function(y, x.title = '', y.title = 'Aantal', bins = NULL, ...) {
# quasiquotation
y <- quasiquotate(deparse(substitute(y)), y)
plot2(y = y,
type = 'frequency',
x.title = x.title,
y.title = y.title,
bins = bins,
...,
via_wrapper = TRUE)
}
#' @rdname plot2
#' @export
plot2.calendar <- function(data = NULL,
x = NULL,
y = NULL,
title = NULL,
subtitle = NULL,
x.title = "Week in de maand",
y.title = "Weekdag",
caption = '',
tag = '',
na.replace = "grey98",
x.category.fill = NA,
x.category.position = 'top',
x.category.bold = TRUE,
x.category.size = 10,
x.category.repeat.lbls.x = FALSE,
x.category.repeat.lbls.y = FALSE,
x.category.margin = 3.5,
legend.position = "right",
legend.title = "",
colours = c("grey85", "certeblauw"),
certe_theme = TRUE,
font.family = "Calibri",
text.factor = 1,
print = TRUE,
...) {
if (NROW(data) == 0) {
warning("No observations to plot.")
return(invisible())
}
if (length(colours) != 2) {
stop("`colours` must be of length 2 for a calendar plot")
}
if (missing(data)) {
# no data
if (missing(x)) {
stop("`x` must be dates")
}
if (!"Date" %in% class(x) & !"POSIXct" %in% class(x)) {
stop("`x` must be dates")
}
if (missing(y)) {
data <- tibble(datum = x, aantal = 1) %>%
group_by(datum) %>%
summarise(aantal = sum(aantal))
x <- "datum"
y <- "aantal"
} else {
# x en y missen niet
if (!is.numeric(y)) {
stop("`y` must be numeric")
}
data <- tibble(datum = x, aantal = y)
x <- "datum"
y <- "aantal"
}
} else {
# data mist niet
if (!is.data.frame(data)) {
stop("`data` must be a data.frame")
}
if (is.null(x)) {
# zoeken naar datum kolom
for (i in 1:ncol(data)) {
if ("Date" %in% class(data %>% pull(i)) | "POSIXct" %in% class(data %>% pull(i))) {
x <- colnames(data)[i]
message("Using column `", x, "` for dates")
break
}
}
}
if (is.null(x)) {
stop("no date columns found")
} else if (is.null(y)) {
data <- data %>%
group_by_at(x) %>%
summarise(aantal = n())
y <- "aantal"
colnames(data)[1] <- "datum"
}
# if (!"Date" %in% class(x) & !"POSIXct" %in% class(x)) {
# stop("`x` must be dates")
# }
}
# missende datums aanvullen met NAs
eom <- function(date) {
# date character string containing POSIXct date
date.lt <- as.POSIXlt(date) # add a month, then subtract a day:
mon <- date.lt$mon + 2
year <- date.lt$year
year <- year + as.integer(mon==13) # if month was December add a year
mon[mon==13] <- 1
iso = ISOdate(1900+year, mon, 1, hour=0) #, tz = attr(date,"tz"))
result = as.POSIXct(iso) - 86400 # subtract one day
result + (as.POSIXlt(iso)$isdst - as.POSIXlt(result)$isdst)*3600
}
x_dates <- seq(as.Date(paste0(year(min(data$datum)), "-", month(min(data$datum), label = FALSE), "-01")),
as.Date(eom(max(data$datum))),
by = 1)
x_dates <- x_dates[!x_dates %in% data$datum]
x_dates <- tibble(datum = x_dates, aantal = NA_integer_)
data <- bind_rows(data, x_dates) %>%
arrange(datum) %>%
mutate(jaar = format2(datum, "yyyy"),
maand = factor(format2(datum, "mmmm"),
levels = format2(as.Date(paste0("2018-", 1:12, "-01")), "mmmm"),
ordered = TRUE),
weekinmaand = stringi::stri_datetime_fields(datum)$WeekOfMonth,
weekdag = factor(format2(datum, "ddd"),
# 1 januari 2018 was maandag
levels = rev(format2(as.Date(paste0("2018-01-0", 1:7)), "ddd")),
ordered = TRUE))
p <- ggplot(data) +
geom_tile(mapping = aes_string(x = "weekinmaand",
y = "weekdag",
fill = "aantal"),
colour = "grey80",
na.rm = TRUE) +
scale_x_continuous(breaks = 0:5,
labels = c("", 1:4, "")) +
scale_fill_gradient(low = colourpicker(colours[1]),
high = colourpicker(colours[2]),
na.value = na.replace,
guide = "colourbar")
if (certe_theme == TRUE) {
p <- p +
theme_certe(subtitle.colour = colourpicker(colours[2]),
font.family = font.family,
legend.position = legend.position,
text.factor = text.factor,
x.category.fill = colourpicker(x.category.fill),
x.category.bold = x.category.bold,
x.category.size = x.category.size,
x.category.margin = x.category.margin,
has_subtitle = !subtitle %in% c("", NA)) +
theme(panel.grid.major = element_blank(),
axis.ticks = element_blank())
}
scales <- 'fixed'
if (x.category.repeat.lbls.x == TRUE & x.category.repeat.lbls.y == TRUE) {
scales <- 'free'
} else if (x.category.repeat.lbls.y == TRUE) {
scales <- 'free_y'
} else if (x.category.repeat.lbls.x == TRUE) {
scales <- 'free_x'
}
if (data %>% pull("jaar") %>% n_distinct() > 1) {
p <- p + facet_wrap(facets = c("jaar", "maand"),
scales = scales,
strip.position = x.category.position)
} else {
p <- p + facet_wrap(facets = "maand",
scales = scales,
strip.position = x.category.position)
}
p <- p +
labs(x = x.title,
y = y.title,
title = title,
subtitle = subtitle,
fill = legend.title,
caption = caption,
tag = tag)
if (print == TRUE) {
print(p)
} else {
p
}
}
#' Extra element toevoegen aan grafiek
#'
#' Dit maakt een extra element in een grafiek.
#' @param plot Een \code{ggplot}-model waaraan de lijn toegevoegd moet worden.
#' @param type Type element dat toegevoegd moet worden. Voor een lijst van mogelijkheden: \code{\link{plot2.elements}}.
#' @param move Standaard is \code{0}. Nieuwe type verplaatsen m.b.v. \code{\link{plot2.movelayer}}.
#' @param size Standaard is \code{0.75} bij lijnen en anders \code{2}. Dikte van de lijnen in geval van een lijngrafiek en punten in geval van een puntgrafiek.
#' @param linetype Standaard is \code{1}. Het type lijn. Uit \code{\link{linetype}}: \code{0 = blank, 1 = solid, 2 = dashed, 3 = dotted, 4 = dotdash, 5 = longdash, 6 = twodash}.
#' @param colour Standaard is \code{"certeroze"}. Kleur van het type. Ondersteunt \code{\link{colourpicker}}.
#' @param ... Parameters die doorgegeven worden aan het type, zoals \code{colour}, \code{fill} en \code{size}, maar ook \code{inherit.aes} en \code{mapping}. Ondersteunt \code{\link{colourpicker}}. Variabelen uit de data van \code{plot} worden automatisch vertaald, zie Examples.
#' @keywords plot2 chart plot lijn
#' @seealso \code{\link{plot2}}
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' # Variabelen uit plot$data worden vertaald, zoals hier uit `rr_ewma`:
#' plot2(y = (runif(52) * 100) + 300, type = "line") %>%
#' plot2.add("line", y = rr_ewma(y, lambda = 0.75))
#'
#'
#' # hier met gefingeerde weekaantallen
#' tibble(week = 1:52,
#' meetpuntjes = (runif(52) * 100) + 30) %>%
#' plot2(type = "point",
#' size = 2,
#' colour = "gray") %>%
#' plot2.add("line",
#' colour = "gray",
#' size = 0.5) %>%
#' # rrEWMA
#' plot2.add("line",
#' y = rr_ewma(meetpuntjes,
#' lambda = 0.9)) %>%
#' # 90e percentiel
#' plot2.add("line",
#' y = quantile(meetpuntjes,
#' 0.9,
#' info = FALSE),
#' linetype = 2,
#' colour = "certeblauw") %>%
#' # en een leesbaardere x-as: elke 4 weken en beginnen bij 1
#' plot2.axis("x",
#' breaks = c(1, seq(from = 0, to = 52, by = 4)))
plot2.add <- function(plot,
type,
move = 0,
size = if_else(type %like% 'line$', 0.75, 2),
linetype = 1,
colour = "certeroze",
...) {
if (missing(type)) {
type <- ""
}
if (!is.character(type)) {
stop("`type` must be a character vector.", call. = FALSE)
}
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
# geen enkel type eindigt op -s, dus die verwijderen voor
# als bijv. "points" of "lines" gebruikt wordt
type <- gsub('s$', '', type)
# als type = "geom_line" gebruikt wordt, moet dat ook kunnen
type <- gsub('^geom_', '', type)
type_valid <- plot2.elements()
if (!all(type %in% type_valid)) {
stop('`type` must all be one of: ', type_valid %>% concat(", "), call. = FALSE)
}
# dots vertalen
geom <- type
argnames <- names(as.list(match.call(expand.dots = FALSE)[-1]))
arguments <- as.list(match.call()[-1])
if (!'size' %in% argnames) {
argnames <- c(argnames, 'size')
arguments$size <- size
}
if (!'linetype' %in% argnames) {
argnames <- c(argnames, 'linetype')
arguments$linetype <- linetype
}
if (!'colour' %in% argnames) {
argnames <- c(argnames, 'colour')
arguments$colour <- colour
}
# group = 1 toevoegen als een lijn toegevoegd moet worden
# https://stackoverflow.com/a/16350805/4575331
if (any(type %in% c('line', 'path', 'step'))) {
if (!"group" %in% as.character(plot$mapping)) {
argnames <- c(argnames, 'group')
arguments$group <- 1
}
}
arguments <- arguments[!names(arguments) %in% c('plot', 'geom', 'type', 'move')]
if (type %in% c('blank', 'count', 'area', 'dotplot', 'hex', 'jitter', 'label', 'point', 'qq', 'qqline', 'text')) {
arguments <- arguments[names(arguments) != 'linetype']
}
# kleuren uit colourpicker ondersteunen
if ('fill' %in% names(arguments)) {
arguments[['fill']] <- colourpicker(eval(arguments[['fill']]))
}
if ('color' %in% names(arguments)) {
arguments[['color']] <- colourpicker(eval(arguments[['color']]))
}
if ('colour' %in% names(arguments)) {
arguments[['colour']] <- colourpicker(eval(arguments[['colour']]))
}
if ('.' %in% names(arguments)) {
arguments[['.']] <- eval(plot)
}
if (length(arguments) > 0) {
for (i in 1:length(arguments)) {
if (concat(as.character(arguments[[i]]), "") %in% colnames(plot$data)) {
# als parameter in plot$data voorkomt, direct oplossen
arg_text <- paste0('plot$data$', arguments[[i]])
arguments[[i]] <- unlist(list(eval(parse(text = arg_text))))
} else if (class(arguments[[i]]) == "call") {
# variabelen uit plot$data evalueren
params <- arguments[[i]] %>% as.character()
# 1e argument is functienaam, dus vanaf 2e controleren
for (j in 2:length(params)) {
if (params[j] %in% colnames(plot$data)) {
params[j] <- paste0('plot$data$', params[j])
}
}
names(params) <- names(arguments[[i]])
params_call <- params %>% as.list()
for (j in 2:length(params_call)) {
if (is.double2(params_call[j])) {
params_call[j] <- params_call[j] %>% as.double()
}
# hier evalueren
params_call[j] <- list(eval(parse(text = params_call[j])))
}
# eerste parameter als name; anders werkt `as.call` niet
params_call[[1]] <- as.name(params[1])
arguments[[i]] <- as.call(params_call)
}
}
}
# type toevoegen aan plot
for (g in geom) {
plot <- plot + do.call(paste0("geom_", g), arguments)
if (move != 0) {
plot <- plot %>% plot2.movelayer(move = move, info = FALSE)
}
}
plot
}
#' Aanpassen van \code{plot2}-assen
#'
#' Hierbij kunnen de x- en y-as van een \code{ggplot}-model aangepast worden.
#' @param plot Een \code{ggplot}-model waarvan de as(sen) aangepast moet(en) worden.
#' @param axis As die aangepast moet worden: \code{"x"}, \code{"y"}, \code{"xy"} of \code{c("x", "y")}.
#' @param breaks,date_breaks,minor_breaks,date_minor_breaks,labels,date_labels,limits,position,log Zie \code{\link{scale_x_continuous}}, \code{\link{scale_x_discrete}} en \code{\link{scale_x_date}} voor alle mogelijkheden.
#' @param trans Transformaties die gedaan kunnen worden aan een continuous schaal, zoals \code{"asn"}, \code{"atanh"}, \code{"boxcox"}, \code{"exp"}, \code{"identity"}, \code{"log"}, \code{"log10"}, \code{"log1p"}, \code{"log2"}, \code{"logit"}, \code{"probability"}, \code{"probit"}, \code{"reciprocal"}, \code{"reverse"} en \code{"sqrt"}.
#' @export
plot2.axis <- function(plot,
axis,
breaks = waiver(),
date_breaks = waiver(),
minor_breaks = waiver(),
date_minor_breaks = waiver(),
labels = waiver(),
date_labels = waiver(),
limits = NULL,
position = if_else(axis == "x", "bottom", "left"),
log = FALSE,
trans = NULL) {
if (!axis %like% "^[xy]{1,2}$") {
stop("`axis` must be x, y or both.", call. = FALSE)
}
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
axis <- axis %>% concat()
x_type <- class(plot$scales$scales[[1]])[1]
if (!axis %like% "x") {
x_type <- ""
}
y_type <- class(plot$scales$scales[[2]])[1]
if (!axis %like% "y") {
y_type <- ""
}
sup <- base::suppressMessages
if (is.null(trans)) {
trans <- "identity"
}
if (log == TRUE) {
trans <- "log2"
}
# x-as
if (x_type %like% 'continuous') {
sup(plot <- plot +
scale_x_continuous(breaks = breaks,
minor_breaks = minor_breaks,
labels = labels,
limits = limits,
position = position,
trans = trans))
} else if (x_type %like% 'discrete') {
sup(plot <- plot +
scale_x_discrete(breaks = breaks,
labels = labels,
limits = limits,
position = position))
} else if (x_type %like% 'datetime') {
sup(plot <- plot +
scale_x_datetime(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (x_type %like% 'date') {
sup(plot <- plot +
scale_x_date(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (x_type %like% 'time') {
sup(plot <- plot +
scale_x_time(breaks = breaks,
#date_breaks = date_breaks,
minor_breaks = minor_breaks,
#date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
}
# y-as
if (y_type %like% 'continuous') {
sup(plot <- plot +
scale_y_continuous(breaks = breaks,
minor_breaks = minor_breaks,
labels = labels,
limits = limits,
position = position,
trans = trans))
} else if (y_type %like% 'discrete') {
sup(plot <- plot +
scale_y_discrete(breaks = breaks,
labels = labels,
limits = limits,
position = position))
} else if (y_type %like% 'datetime') {
sup(plot <- plot +
scale_y_datetime(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (y_type %like% 'date') {
sup(plot <- plot +
scale_y_date(breaks = breaks,
date_breaks = date_breaks,
minor_breaks = minor_breaks,
date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
} else if (y_type %like% 'time') {
sup(plot <- plot +
scale_y_time(breaks = breaks,
#date_breaks = date_breaks,
minor_breaks = minor_breaks,
#date_minor_breaks = date_minor_breaks,
labels = labels,
limits = limits,
position = position))
}
plot
}
#' Lijst met elementen
#'
#' Lijst met mogelijke elementen die toegevoegd kunnen worden aan een plot2, door middel van \code{\link{plot2.add}}.
#' @export
plot2.elements <- function() {
ls(pattern = '^geom_', env = as.environment('package:ggplot2')) %>% gsub('^geom_', '', .)
}
#' Foutbalken toevoegen aan grafiek
#'
#' Dit voegt foutbalken in op de aangegeven plaatsen.
#' @param plot De grafiek waaraan de lijn toegevoegd moet worden.
#' @param ymin,ymax,x Kolomnaam in \code{plot$data}. Waarden met \code{NA} worden genegeerd.
#' @param size Standaard is \code{1}. Dikte van de lijnen in millimeters. Zie \code{\link{size}}.
#' @param linetype Standaard is \code{2}. Het type lijn. Uit \code{\link{linetype}}: \code{0 = blank, 1 = solid, 2 = dashed, 3 = dotted, 4 = dotdash, 5 = longdash, 6 = twodash}.
#' @param width Standaard is \code{0.33}. Breedte van de lijnen.
#' @param colour Standaard is \code{colourpicker("black")}. Kleur van de lijnen. Zie ook \code{\link{colourpicker}}.
#' @param type Standaard is \code{"errorbar"}. Geldige opties zijn \code{"errorbar"} en \code{"ribbon"}.
#' @keywords plot2 chart plot lijn
#' @seealso \code{\link{plot2}}
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' \donttest{
#' plot2(...) %>%
#' plot2.errorbar(ymin = "se_min",
#' ymax = "se_max")
#' }
plot2.errorbar <- function(plot,
ymin,
ymax,
x = colnames(plot$data)[1],
size = 1,
linetype = 1,
width = 0.33,
colour = colourpicker('black', opacity = 0.5),
type = 'errorbar') {
if (type == 'errorbar') {
plot + geom_errorbar(
aes_string(ymin = ymin,
ymax = ymax),
width = width,
linetype = linetype,
size = size,
colour = colour)
} else if (type == 'ribbon') {
# x-as continuous maken
plot$data[, x] <- plot$data %>% pull(x) %>% as.character() %>% as.integer()
plot +
scale_x_continuous(breaks = plot$data %>% pull(x)) +
geom_ribbon(
aes_string(ymin = ymin,
ymax = ymax),
fill = colourpicker(colour, opacity = 0.75))
}
}
#' Tekst toevoegen aan grafiek
#'
#' Dit voegt een annotatie toe aan een grafiek. De tekst wordt links uitgelijnd. BELANGRIJK: hiervoor moet een andere grafiekfunctie gebruikt worden met \code{print = FALSE}.
#' @param plot De grafiek waaraan de tekst toegevoegd moet worden
#' @param text De tekst die geplot moet worden.
#' @param y Plaats op de y-as.
#' @param x Standaard is \code{"0.5"}. Plaats op de x-as.
#' @param colour Standaard is \code{colourpicker("certeroze")}. Kleur van de tekst. Zie ook \code{\link{colourpicker}}.
# @param fill Standaard is \code{NA}. Kleur van de achtergrond. Zie ook \code{\link{colourpicker}}.
#' @param size Standaard is \code{"4"}. Grootte van de tekst.
#' @param bold Standaard is \code{FALSE}. Tekst vetgedrukt maken.
#' @param formula Standaard is \code{FALSE}. Wanneer de tekst een formule is (zoals \code{text = "R^2 =="}), moet \code{parse = TRUE} gebruikt worden.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt moet worden voor tekst in de grafiek.
#' @param ... Andere parameters die doorgegeven worden aan \code{\link[ggplot2]{layer}}.
#' @keywords grafiek chart plot lijn
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' \dontrun{
#' plot2.text('90e pct', 275)
#' }
plot2.text <- function(plot,
text,
y,
x = 0.5,
colour = "certeroze",
#fill = NA,
size = 4,
bold = FALSE,
formula = FALSE,
font.family = 'Calibri',
...) {
colour <- colour %>% colourpicker()
#fill <- fill %>% colourpicker()
bold.int <- bold + 1 # FALSE + 1 = 1 en TRUE + 1 = 2
plot <- plot +
annotate("text",
x = x,
y = y,
size = size,
colour = colour,
# fill = fill,
label = text,
hjust = 0, # links centreren
family = font.family,
fontface = bold.int,
parse = formula,
...)
plot
}
#' Verplaatsen van een laag van een ggplot-model
#'
#' Hiermee kan een laag binnen een ggplot (plot2) verplaatst worden, zodat ook na het maken van een plot toch de volgorde van de lagen veranderd kan worden.
#' @param plot De grafiek waaraan de lijn toegevoegd moet worden.
#' @param layer Standaard is de laatste laag. De index van de laag die verplaatst moet worden.
#' @param move Een positief of negatief getal die aangeeft hoeveel posities de laag \code{layer} verplaatst moet worden.
#' @param info Standaard is \code{TRUE}. Printen van de oude en nieuwe laagindeling.
#' @return Een \code{ggplot}-model.
#' @export
#' @examples
#' \dontrun{
#' plot2(..) %>%
#' plot2.errorbar(..) %>%
#' plot2.movelayer(move = -2)
#' }
plot2.movelayer <- function(plot, layer = length(plot$layers), move, info = TRUE) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
layers <- plot$layers
layer_old <- layer
layer_new <- layer + move
if (!layer_old %in% c(1:length(layers))) {
stop('This plot contains only ', length(layers), ' layers. Layer ',
layer_old, ' does not exist.', call. = FALSE)
}
if (!layer_new %in% c(1:length(layers))) {
stop('This plot contains only ', length(layers), ' layers; layer ',
layer_old, ' cannot be moved to position ', layer_new, '.', call. = FALSE)
}
# functie voor weergeven van lagen
layeroverview <- function(layers) {
for (i in 1:length(layers)) {
aes_params <- layers[[i]]$aes_params
for (p in 1:length(aes_params)) {
if (aes_params[p][[1]] %like% '#[0-f]{6,8}') {
aes_params[p][[1]] <- aes_params[p][[1]] %>% gsub('#[0-f]{6}', colour.name(.), .)
} else if (aes_params[p][[1]] %in% colors()) {
aes_params[p][[1]] <- paste0(
col2rgb(aes_params[p][[1]])) %>%
as.integer() %>%
as.hexmode() %>%
concat() %>%
paste0('#', .) %>%
colour.name()
}
}
aes_params <- paste(names(aes_params), aes_params, collapse = ', ', sep = ': ')
geom <- layers[[i]]$geom
geom_firstclass <- (geom %>% class())[1] %>%
gsub('Geom', 'Geom_', ., fixed = TRUE) %>%
tolower()
cat('[', i, '] ', geom_firstclass, ' (', aes_params, ')\n', sep = '')
}
}
if (info == TRUE) {
cat('Old layer order:\n')
plot2.listlayers(plot)
}
# nieuwe volgorde; layer_old wordt layer_new en de rest doorschuiven
layers_backup <- layers
layers[[layer_new]] <- layers[[layer_old]]
for (i in (layer_new + 1):length(layers)) {
layers[[i]] <- layers_backup[[i - 1]]
}
plot$layers <- layers
if (info == TRUE) {
cat('\nNew layer order:\n')
plot2.listlayers(plot)
}
plot
}
#' Weergeven van alle lagen van een ggplot-model
#'
#' Hiermee wordt een overzicht gegeven van alle lagen van een \code{ggplot}-model (of \code{plot2}).
#' @param plot Een \code{ggplot}-model.
#' @param as.data.frame Standaard is \code{FALSE}. Overzicht printen als \code{data.frame}.
#' @return Tekst
#' @export
#' @examples
#' \dontrun{
#' plot2(..) %>%
#' plot2.listlayers()
#' }
plot2.listlayers <- function(plot, as.data.frame = FALSE) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
layers <- plot$layers
df <- tibble(i = integer(0), type = character(0), params = character(0))
for (i in 1:length(layers)) {
aes_params <- layers[[i]]$aes_params
if (aes_params %>% length() > 0) {
for (p in 1:length(aes_params)) {
if (aes_params[p][[1]] %like% '#[0-f]{6,8}') {
aes_params[p][[1]] <- aes_params[p][[1]] %>% gsub('#[0-f]{6}', colour.name(.), .)
} else if (aes_params[p][[1]] %in% colors()) {
aes_params[p][[1]] <- paste0(
col2rgb(aes_params[p][[1]])) %>%
as.integer() %>%
as.hexmode() %>%
concat() %>%
paste0('#', .) %>%
colour.name()
}
}
}
aes_params <- paste(names(aes_params), aes_params, collapse = ', ', sep = ': ')
geom <- layers[[i]]$geom
geom_firstclass <- (geom %>% class())[1] %>%
gsub('Geom', 'Geom_', ., fixed = TRUE) %>%
tolower()
if (as.data.frame) {
df <- df %>% rbind(tibble(i = i, type = geom_firstclass, params = aes_params))
} else {
cat('[', i, '] ', geom_firstclass, ' (', aes_params, ')\n', sep = '')
}
}
if (as.data.frame) {
df
}
}
#' Prevalentiegrafiek van tabel
#'
#' Dit plot adressen op een Google Maps kaart met prevalentiekleuren.
#'
#' @param tbl De tabel met gegevens die geplot moet worden. \strong{De tabel moet de kolommen \code{lat} en \code{lng} bevatten.}
#' @param coord.round Standaard is \code{2}. Afronden van coordinaten. Met minder decimalen krijgen coordinaten betrekking op een groter gebied. Punten met dezelfde coordinaten worden opgeteld.
#' @param dot.size Standaard is \code{10}. Grootte van de stippen.
#' @param dot.alpha Standaard is \code{0.75}. De zichtbaarheid van de stippen, een waarden tussen 0 en 1.
#' @param text.show Standaard is \code{TRUE}. Met \code{FALSE} worden alleen stippen weergegeven.
#' @param text.size Standaard is \code{4}. Grootte van de tekst in de stippen.
#' @param text.colour Standaard is \code{"white"}. Kleur van de tekst in de stippen.
#' @param print Standaard is \code{FALSE}. Hiermee wordt de grafiek direct met \code{print} weergegeven. Met \code{FALSE} kan de output gebruikt worden om door te geven aan een variabele.
#' @param colours Standaard is \code{"prev"}. Zie \code{\link{colourpicker}}.
#' @keywords grafiek chart plot adres
#' @return Een \code{ggmap}-model.
#' @seealso \code{\link{tbl_address}} \code{\link{gps_from_address}}
#' @export
#' @examples
#' \dontrun{
#' plot2.map_old(tbl = tbl_address("Van Swietenlaan 2, Groningen"))
#' }
plot2.map_old <- function(tbl,
coord.round = 2,
dot.size = 10,
dot.alpha = 0.75,
text.show = TRUE,
text.size = 4,
text.colour = 'white',
print = FALSE,
colours = 'prev') {
# coordinaten afronden
tbl$lat.round <- round(tbl$lat, coord.round)
tbl$lng.round <- round(tbl$lng, coord.round)
df <- tbl %>%
mutate(gps = paste(lat.round, lng.round)) %>%
group_by(gps, lat.round, lng.round) %>%
summarise(n = n()) %>%
# zodat hogere aantallen als laatst geplot worden (donkerrood bovenop rood):
arrange(n) %>%
ungroup()
prevkleuren <- colourpicker(colours, length = max(max(df$n), 10))
df$kleur <- prevkleuren[df$n]
suppressMessages(
kaart <-
ggmap::get_map(
location = c(lng = mean(df$lng.round), lat = mean(df$lat.round)),
zoom = 9,
maptype = "roadmap",
scale = 2,
source = 'google',
language = "nl-NL",
api_key = maps_api_key()
)
)
grafiek <- ggmap::ggmap(kaart) +
theme(axis.line = element_blank(),
axis.text = element_blank(),
axis.ticks = element_blank(),
plot.margin = unit(c(0, 0, -1, -1), 'lines')) +
xlab('') +
ylab('') +
geom_point(
data = df,
aes(x = lng.round, y = lat.round),
colour = df$kleur,
fill = df$kleur,
size = dot.size,
alpha = dot.alpha,
shape = 21
)
if (text.show == TRUE) {
grafiek <- grafiek +
geom_text(
data = df,
aes(x = lng.round, y = lat.round, label = n),
colour = text.colour,
size = text.size,
vjust = 0.5,
hjust = 0.5
)
}
if (print == TRUE) {
print(grafiek)
} else {
grafiek
}
}
#' Taartgrafiek van tabel
#'
#' Dit maakt een taartgrafiek met Certe-kleuren.
#' @param data Tabel met gegevens.
#' @param x Standaard is de eerste kolom van \code{data}. Tekstlabels voor elke taartpunt.
#' @param y Standaard is de tweede kolom van \code{data}. Gegevens voor de taartpunten.
#' @param title Standaard is leeg. Titel van de grafiek.
#' @param show.percent Standaard is \code{TRUE}. Onder de labels het percentage weergeven.
#' @param show.count Standaard is \code{FALSE}. Onder de labels het aantal weergeven.
#' @param show.labels Standaard is \code{TRUE}. Met \code{FALSE} worden helemaal geen labels weergegeven.
#' @param sort.size Standaard is \code{TRUE}. De taartpunten sorteren van groot naar klein.
#' @param round Standaard is \code{2}. Aantal decimalen waarop de grootte van \code{n} afgerond moet worden.
#' @param restgroup.threshold Standaard is \code{90}. Het percentage dat gedefinieerd moet zijn voordat de rest onder de restgroep gevat wordt (mits er meer dan 1 waarde over is). De restgroepgrootte is dus tussen de 0 en (100 - \code{restgroup.threshold}) procent. Gebruik een waarde van \code{NA} of \code{100} om geen restgroep te maken. Waarden tussen 0 en 1 worden ook ondersteund.
#' @param restgroup.info Standaard is \code{TRUE}. Printen van de waarnemingen die in de restgroep vallen naar de console.
#' @param clockwise Standaard is \code{TRUE}. Gegevens met de klok mee weergeven.
#' @param colours Standaard is \code{"certe"}. Zie \code{\link{colourpicker}}.
#' @param font.family Standaard is \code{"Calibri"}. Het lettertype dat gebruikt moet worden voor tekst in de grafiek.
#' @keywords grafiek chart plot pie
#' @return Grafiek
#' @export
#' @examples
#' \dontrun{
#' plot2.pie(mmb$aanvragen, mmb$artsnaam, 'Overzicht')
#' }
plot2.pie <- function(data,
x = NA,
y = NA,
title = NA,
show.percent = TRUE,
show.count = FALSE,
show.labels = TRUE,
sort.size = TRUE,
round = 2,
restgroup.threshold = 90,
restgroup.info = TRUE,
clockwise = TRUE,
colours = getOption("plot2.colours", "certe"),
font.family = 'Calibri',
prefix.count = 'n = ') {
.Deprecated(msg = '`plot2.pie` is deprecated. Use `plot2.barpercent` instead.',
old = 'plot2.pie',
new = 'plot2.barpercent')
data <- as.data.frame(data)
if (is.na(x)) {
labels <- data[, 1]
} else {
labels <- data[, x]
}
if (is.na(y)) {
if (length(data) == 1) {
waarden <- data[, 1]
} else {
waarden <- data %>% pull(2)
}
} else {
waarden <- data[, y]
}
if (min(waarden) < 0) {
waarden <- abs(waarden)
warning('All values have been made positive.\n\n')
}
if (sum(waarden) == 0) {
stop('No values for this plot.')
}
if (is.na(title)) {
par(mar = c(0, 0, 0, 0), family = font.family)
} else {
par(mar = c(0, 0, 2, 0), family = font.family)
}
if (sort.size == TRUE) {
if (is.null(labels)) {
waarden <- sort(waarden, decreasing = TRUE)
} else {
temp <- data.frame(waarden, labels)
temp <- temp %>% arrange(desc(waarden))
waarden <- temp$waarden
labels <- temp$labels
}
}
labels <- as.character(labels)
aandeel <- waarden / sum(waarden)
if (!is.na(restgroup.threshold) & restgroup.threshold < 100) {
if (restgroup.threshold < 1) {
restgroup.threshold <- restgroup.threshold * 100
}
totaal <- 0
for (i in 1:length(waarden)) {
totaal <- totaal + waarden[i]
totaal.perc <- totaal / sum(waarden) * 100
waarden.resterend.perc <- (100 - totaal.perc) / 100
waarden.resterend.aantal <- length(waarden) - i
waarden.resterend.som <- sum(waarden[i + 1:length(waarden)])
if (totaal.perc >= restgroup.threshold & waarden.resterend.aantal > 1) {
if (restgroup.info == TRUE) {
cat('These observation are within the rest group:\n\n')
print(data.frame(
label = labels[i + 1:length(labels)][1:waarden.resterend.aantal],
waarde = format2(waarden[i + 1:length(waarden)][1:waarden.resterend.aantal], round),
aandeel = (aandeel[i + 1:length(aandeel)][1:waarden.resterend.aantal]) %>% as.percent() %>% format2()
))
}
waarden <- c(waarden[1:i], waarden.resterend.som)
labels <- c(labels[1:i], paste0('Rest (x', waarden.resterend.aantal, ')'))
aandeel <- waarden / sum(waarden)
break
}
}
}
if (show.percent == TRUE & show.count == TRUE) {
lbl <- paste0(prefix.count, format2(waarden, round), ' (', aandeel %>% as.percent() %>% format2(), ')')
} else if (show.percent == TRUE & show.count == FALSE) {
lbl <- aandeel %>% as.percent() %>% format2()
} else if (show.percent == FALSE & show.count == TRUE) {
lbl <- paste0(prefix.count, format2(waarden, round))
} else {
lbl <- ''
}
if (!is.null(labels) & !(length(labels) == 1)) {
lbl <- paste0(labels, '\n', lbl)
} else {
lbl <- labels
}
if (show.labels == FALSE) {
lbl <- NA
}
pie(
x = waarden,
labels = lbl,
clockwise = clockwise,
col = colourpicker(colours, length = length(waarden)),
border = colourpicker(colours, length = length(waarden)),
cex = 0.8,
cex.main = 1.1,
font.main = 1,
radius = 0.9,
main = title
)
}
#' @rdname qc
#' @export
plot2.qcc <- function(x, ..., plot.print = FALSE) {
qc.test(x, ..., text.show = FALSE, plot.show = TRUE, plot.print = plot.print)
}
#' Titel ophalen van grafiek
#'
#' @param plot Grafiek
#' @param validfilename Standaard is \code{TRUE}. Verandert de te retourneren tekst zodanig, dat dit een geldige bestandsnaam is.
#' @param append_ID Standaard is \code{TRUE}. Alleen als de caption van de grafiek een alfanumerieke tekst is (bijv. gemaakt met \code{\link{ID}}), wordt deze achter de output geplaatst.
#' @export
getplottitle <- function(plot, validfilename = TRUE, append_ID = TRUE) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
title <- plot$labels$title
if (is.null(title)) {
title <- 'plot'
} else {
title <- title %>%
as.character() %>%
gsub("\"", "***", .) %>%
strsplit("***", fixed = TRUE) %>%
unlist()
title <- title[which(title != ''
& title != 'paste('
& title != ', italic('
& title != ')'
& title != '), ')]
title <- title %>%
concat() %>%
trimws()
if (validfilename == TRUE) {
title <- title %>%
gsub("[?|<>|:/\\*]", "", .)
}
}
# caption toevoegen als dit een ID is
caption <- plot$labels$caption
if (!is.null(caption)) {
if (caption %like% '^[0-9a-f]+$') {
title <- paste0(title, " (", caption, ")")
}
}
title
}
#' Grafiek opslaan op schijf
#'
#' Hiermee wordt een plot2-grafiek opgeslagen op de schijf in de huidige werkmap. Het bestandstype wordt bepaald op basis van de extensie die gegeven wordt aan \code{filename}.
#' @details De maplocatie van de plot2-grafiek die met deze functie opgeslagen wordt, wordt vastgelegd in de functie \code{options} met de variabele \code{plot2.lastsave}. Zie \code{\link{plot2.opendir}} voor meer informatie.
#' @rdname plot2.save
#' @param plot Grafiek die opgeslagen moet worden.
#' @param width Standaard is \code{800}. Breedte van de grafiek in pixels.
#' @param height Standaard is \code{500}. Hoogte van de grafiek in pixels.
#' @param size Standaard is \code{NA}. Kan gebruikt worden \strong{in plaats van \code{width} en \code{height}} om de grootte aan te geven. Dit kan een waarde zijn als:
#'
#' - \code{"1200 * 800"}, voor een resolutie;
#'
#' - \code{"Office"}, \code{"vector"}, \code{"PowerPoint"} of \code{"Word"} voor een vectorafbeelding zonder kwaliteitsverlies (hierbij wordt altijd het .emf-bestandstype gebruikt);
#'
#' - in geval van PDF: \code{"A0"} t/m \code{"A6"};
#'
#' - een schermresolutie (niet-hoofdlettergevoelig): \code{"SVGA"}, \code{"XGA"}, \code{"WXGA"}, \code{"SXGA"}, \code{"HD"}, \code{"WXGA"}, \code{"WSXGA"}, \code{"FHD"}, \code{"FullHD"}, \code{"WUXGA"}, \code{"WQHD"}, \code{"UltraHD"} of \code{"4K"}.
#' @param portrait Standaard is \code{FALSE}. Bij PDF de pagina staand (\emph{portrait}) weergeven, wordt anders liggend (\emph{landscape}).
#' @param text.factor Standaard is \code{1}. Een factor tussen \code{0.5} en \code{2} die voor tekst in de grafiek gebruikt wordt. Op basis hiervan wordt intern het aantal dots per inch (DPI) en afbeeldingsgrootte in inch berekend:
#'
#' \code{breedte (inch) = width / (text.factor * 100)}, en
#'
#' \code{hoogte (inch) = height / (text.factor * 100)}
#' @param filename Standaard is de titel van \code{plot} of (wanneer deze niet beschikbaar is) de datum en tijd op deze manier: \code{"YYYYMMDD-hhmmss"}. Daarna wordt de extensie \code{.png} toegevoegd. Wordt opgeslagen in de huidige werkmap, tenzij \code{selectdir = TRUE}. De bestandsnaam kan eindigen op \code{"png"}, \code{"bmp"}, \code{"jpeg"}, \code{"tiff"}, \code{"pdf"}, \code{"svg"}, \code{"eps"}, \code{"ps"}, \code{"tex"}, \code{"wmf"} of \code{"emf"}.
#' @param selectdir Standaard is \code{FALSE}. Een popup weergeven zodat de map geselecteerd kan worden.
#' @param returnplot Standaard is \code{TRUE}. De plot niet alleen opslaan, maar ook printen.
#' @export
#' @seealso \code{\link{plot2.opendir}} om de map te openen waarin de afbeelding geplaatst is en \code{\link{ggsave}} voor de functie die intern gebruikt wordt.
#' @examples
#' \dontrun{
#' tbl %>%
#' filter(...) %>%
#' group_by(...) %>%
#' summarise(...) %>%
#' plot2() %>%
#' plot2.save(1200, 800)
#'
#' tbl %>%
#' plot2() %>%
#' plot2.save(size = "1200 * 800")
#'
#' tbl %>%
#' plot2() %>%
#' plot2.save(size = "FullHD", text.factor = 1.25)
#'
#' tbl %>%
#' plot2() %>%
#' plot2.save(size = "PowerPoint", filename = "Test") # will output `Test.emf`
#' }
plot2.save <- function(plot,
width = 800,
height = 500,
size = NA,
portrait = FALSE,
text.factor = 1,
title = if_else(is.na(getplottitle(plot)),
format(Sys.time(), format = '%Y%m%d-%H%M%S'),
getplottitle(plot)),
file_format = "png",
filename = paste0(title, ".", file_format),
selectdir = FALSE,
returnplot = TRUE) {
filename.deparse <- paste(deparse(substitute(filename)), collapse = "")
if (text.factor < 0.1 | text.factor > 10) {
stop('`text.factor` must be a number between 0.1 and 10.')
}
strip.extension <- function(filename) {
sapply(strsplit(basename(filename), "\\."), function(x)
paste(x[1:(length(x) - 1)], collapse = "."))
}
get.extension <- function(filename) {
gsub(filename %>% strip.extension(), '', filename) %>%
tolower() %>%
gsub('.', '', ., fixed = TRUE)
}
# standaard A4 voor pdf
if (is.na(size) & get.extension(filename) == 'pdf') {
size <- 'A4'
}
if (!is.na(size)) {
# zoals size = '1200 * 800' en '1200*800'
if (grepl(' * ', size, fixed = TRUE)) {
width <- (strsplit(size, " * ", fixed = TRUE) %>% unlist())[1] %>% as.integer()
height <- (strsplit(size, " * ", fixed = TRUE) %>% unlist())[2] %>% as.integer()
} else if (size %>% tolower() %in% tolower(c('Office', 'vector', 'PowerPoint', 'Word'))) {
# extensie verwijderen
filename <- filename %>% strip.extension()
filename <- paste0(filename, '.emf')
text.factor <- 1.75
width <- 1200
height <- 900
dpi <- 300
} else if (size %>% tolower() == "SVGA" %>% tolower()) {
width <- 800
height <- 600
} else if (size %>% tolower() == "XGA" %>% tolower()) {
width <- 1024
height <- 768
} else if (size %>% tolower() == "WXGA" %>% tolower()) {
width <- 1280
height <- 720
} else if (size %>% tolower() == "SXGA" %>% tolower()) {
width <- 1280
height <- 1024
} else if (size %>% tolower() == "HD" %>% tolower()) {
width <- 1366
height <- 768
} else if (size %>% tolower() == "WXGA" %>% tolower()) {
width <- 1440
height <- 900
} else if (size %>% tolower() == "WSXGA" %>% tolower()) {
width <- 1680
height <- 1050
} else if (size %>% tolower() == "FHD" %>% tolower()) {
width <- 1920
height <- 1080
} else if (size %>% tolower() == "FullHD" %>% tolower()) {
width <- 1920
height <- 1080
} else if (size %>% tolower() == "WUXGA" %>% tolower()) {
width <- 1920
height <- 1200
} else if (size %>% tolower() == "WQHD" %>% tolower()) {
width <- 2560
height <- 1440
} else if (size %>% tolower() == "UltraHD" %>% tolower()) {
width <- 3840
height <- 2160
} else if (size %>% tolower() == "4K" %>% tolower()) {
width <- 3840
height <- 2160
# PDF
} else if (get.extension(filename) == "pdf" | file_format == "pdf") {
a0_height <- sqrt(sqrt(2)) * 1000 # x1000 voor millimeters.
a1_height <- a0_height / sqrt(2)
a2_height <- a1_height / sqrt(2)
a3_height <- a2_height / sqrt(2)
a4_height <- a3_height / sqrt(2)
a5_height <- a4_height / sqrt(2)
a6_height <- a5_height / sqrt(2)
if (size %>% tolower() == "a0" %>% tolower()) {
height <- a0_height
width <- a0_height / sqrt(2)
} else if (size %>% tolower() == "a1" %>% tolower()) {
height <- a1_height
width <- a1_height / sqrt(2)
} else if (size %>% tolower() == "a2" %>% tolower()) {
height <- a2_height
width <- a2_height / sqrt(2)
} else if (size %>% tolower() == "a3" %>% tolower()) {
height <- a3_height
width <- a3_height / sqrt(2)
} else if (size %>% tolower() == "a4" %>% tolower()) {
height <- a4_height
width <- a4_height / sqrt(2)
} else if (size %>% tolower() == "a5" %>% tolower()) {
height <- a5_height
width <- a5_height / sqrt(2)
} else if (size %>% tolower() == "a6" %>% tolower()) {
height <- a6_height
width <- a6_height / sqrt(2)
} else {
warning('No valid value for size; A4 will be used.')
height <- a4_height
width <- a4_height / sqrt(2)
}
if (portrait == FALSE) {
height.bak <- height
height <- width
width <- height.bak
}
} else {
warning('No valid value for size; (default) values for width and height will be used.')
size <- NA
}
}
# if (!is.na(size) & (!missing(width) | !missing(height))) {
# warning('Width and height will be ignored, because size is set')
# }
if (selectdir == TRUE) {
map <- choose.dir(getwd(), "Select a folder:")
if (is.na(map)) {
stop('No folder selected to save to.')
}
map <- paste0(map, '/')
} else {
map <- ''
}
if (get.extension(filename) == '') {
filename <- paste0(filename, '.png')
}
filename.only <- filename
filename <- paste0(map, filename)
if (get.extension(filename) != 'pdf') {
dpi <- text.factor * 100
} else {
dpi <- 1
if (text.factor != 1) {
warning('`text.factor` has no use in PDF export.')
}
}
width.calc <- width / dpi
height.calc <- height / dpi
if (filename %like% '(.pdf)$') {
suppressWarnings(
ggsave(filename = filename,
device = cairo_pdf,
width = width.calc,
height = height.calc,
units = 'mm',
plot = plot)
)
} else {
suppressWarnings(
ggsave(filename = filename,
dpi = dpi,
width = width.calc,
height = height.calc,
units = 'in',
plot = plot)
)
}
filesize <- paste(round(file.size(filename) / 1024), 'kB')
if (!filename.only %like% '(.emf|.wmf|.pdf|.svg|.ps|.tex)$') {
filesize <- paste0(width, 'x', height, 'px, ', filesize)
} else {
if (get.extension(filename) == 'pdf') {
filesize <- paste0(toupper(size), ' format, ', filesize)
#cat('Exporting to a PDF document in', toupper(size), 'format...\n')
} else {
cat('Some vector types can be ungrouped (e.g. in PowerPoint or Word) and edited if needed.\n')
}
}
if (file.exists(filename)) {
if (map == "") {
last.save <- paste0(getwd(), '/', filename)
} else {
last.save <- filename
}
options(plot2.lastsave = last.save)
cat(paste0(
'[',
format2(Sys.time()),
'] Plot saved as `',
normalizePath(filename),
'` (', filesize, ')',
'.\n'
))
# altijd anderhalve seconde wachten zodat plots elkaar niet overschrijven met standaard filename
if (title %like% '(format|Sys.time)') {
Sys.sleep(1.5)
}
if (returnplot == TRUE) {
print(plot)
}
} else {
if (returnplot == TRUE) {
print(plot)
}
stop("Error while saving '", filename, "'")
}
# if (interactive()) {
# # focus naar Console:
# rstudioapi::sendToConsole("", FALSE)
# openplot <- readline("Would you like to open this folder now? [y/N] ")
# if (openplot %>% substr(1, 1) %>% tolower() %in% c('n', '')) {
# cat('Run plot2.opendir() to open this folder any moment in the future.\n')
# } else {
# plot2.opendir()
# }
# }
}
#' Interactieve grafiek maken
#'
#' Dit maakt van een plot2-model een interactief \code{plotly}-model.
#' @param plot Een \code{ggplot}-model.
#' @param ... Parameters die doorgegeven worden aan \code{\link[plotly]{ggplotly}}.
#' @export
plot2.interactive <- function(plot, ...) {
if (!is.ggplot(plot)) {
stop("`plot` must be a ggplot2 model.", call. = FALSE)
}
suppressMessages(
suppressWarnings(
plotly::ggplotly(p = plot, tooltip = c("x", "y"), ...)
)
)
}
#' Map openen van laatste \code{plot2.save()}.
#'
#' De locatie van de laatste plot2-grafiek openen in een nieuw scherm van Windows Verkenner.
#' @details De locatie van de laatste plot2-grafiek wordt opgeslagen met de functie \code{\link{options}}, onder variabele \code{plot2.lastsave}. Daarom kan de locatie opgehaald worden met de functie \code{getOption("plot2.lastsave")} of \code{options()$plot2.lastsave}.
#' @seealso \code{\link{plot2.save}}
#' @export
plot2.opendir <- function() {
filename <- getOption("plot2.lastsave")
if (is.null(filename)) {
stop("No last saved plot found.")
}
suppressWarnings(shell(
paste0('explorer /select, "', gsub('/', '\\', filename, fixed = TRUE), '"')
))
}
plot2.format.number.EN <- function(x) {
x %>% format2(format.NL = FALSE)
}
plot2.format.percent <- function(x) {
x %>% as.percent() %>% format2(round = 1, force.decimals = FALSE)
}
plot2.format.percent.EN <- function(x) {
x %>% as.percent() %>% format2(round = 1, force.decimals = FALSE, format.NL = FALSE)
}
plot2.datalabels <- function(grafiek,
data,
x,
y,
datalabels,
datalabels.fill,
y.category,
stacked,
stackedpercent,
horizontal,
reverse,
font.family,
text.factor,
width) {
width <- ifelse(!is.null(width), width, 0.5)
if (stacked == FALSE & stackedpercent == FALSE) {
kleur.label <- colourpicker(datalabels.fill)
kleur.tekst <- 'gray25'
} else {
kleur.label <- colourpicker(datalabels.fill, opacity = 0.75) # 75% doorzichtig
kleur.tekst <- 'black'
}
if (any(grepl('%*%', datalabels, fixed = TRUE) == TRUE)) {
datalabels <- as.expression(datalabels)
als.formule <- TRUE
} else {
als.formule <- FALSE
}
# datalabels toevoegen aan grafiekdata
grafiek$data <- grafiek$data %>% tibble::add_column(lbls.nieuw = datalabels)
grafiek$data$lbls.nieuw <- grafiek$data$lbls.nieuw %>% as.character()
h.label <- 0.5
h.tekst <- 0.5
v.label <- -0.1
v.tekst <- -0.75
if (horizontal == TRUE) {
v.label <- 0.5
v.tekst <- 0.5
h.label <- -0.1
h.tekst <- -0.25
}
textsize.txt <- text.factor * 3.0
textsize.lbl <- (text.factor * 1.25) + textsize.txt
if (text.factor == 1) {
textsize.lbl <- textsize.txt * 0.75
}
if (!is.na(y.category)) {
if (stackedpercent == TRUE) {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_fill(reverse = reverse, vjust = 0.5),
vjust = 0.5,
hjust = 0.5,
size = textsize.lbl,
fill = kleur.label,
colour = NA,
family = font.family
) +
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_fill(reverse = reverse, vjust = 0.5),
vjust = 0.5,
hjust = 0.5,
size = textsize.txt,
colour = kleur.tekst,
family = font.family)
} else if (stacked == TRUE) {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_stack(reverse = reverse, vjust = 0.5),
size = textsize.lbl,
fill = kleur.label,
colour = NA,
family = font.family,
na.rm = TRUE
) +
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_stack(reverse = reverse, vjust = 0.5),
size = textsize.txt,
colour = kleur.tekst,
family = font.family,
na.rm = TRUE)
} else {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_dodge2(width = width, preserve = "single"),
size = textsize.lbl,
colour = NA,
fill = kleur.label,
label.padding = unit(0.25, 'lines'),
label.r = unit(0, 'lines'),
vjust = v.label,
hjust = h.label,
family = font.family,
na.rm = TRUE) +
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
position = position_dodge2(width = width, preserve = "single"),
vjust = v.tekst,
hjust = h.tekst,
size = textsize.txt,
colour = kleur.tekst,
family = font.family,
na.rm = TRUE)
}
} else {
lbls <- grafiek +
# rechthoek achter tekst:
geom_label(
aes(label = lbls.nieuw),
parse = als.formule,
size = textsize.lbl,
colour = NA,
fill = kleur.label,
label.padding = unit(0.25, 'lines'),
label.r = unit(0, 'lines'),
vjust = v.label,
hjust = h.label,
family = font.family,
na.rm = TRUE) +
# tekst zelf:
geom_text(
aes(label = lbls.nieuw),
parse = als.formule,
size = textsize.txt,
colour = kleur.tekst,
vjust = v.tekst,
hjust = h.tekst,
family = font.family,
na.rm = TRUE)
}
if (stacked == FALSE & stackedpercent == FALSE) {
# laag label helemaal naar onderen verplaatsen, dat is de een na laatste;
# daardoor valt het label (kleur achtergrond) nooit over een bar heen
alle_lagen <- c(1:length(lbls$layers))
label_laag <- length(alle_lagen) - 1
rest_lagen <- alle_lagen[-label_laag]
lbls$layers <- lbls$layers[c(label_laag, rest_lagen)]
}
lbls
}
markdown_bolditalic <- function(text) {
if (text %like% '[*]{2}.+[*]{2}') {
# bold
locations <- unlist(gregexpr(pattern = '[*]{2}',
text))
locations <- locations[1:2]
text.left <- substr(text,
1,
min(locations) - 1)
text.middle <- substr(text,
min(locations) + 2,
max(locations) - 1)
text.right <- substr(text,
max(locations) + 2,
nchar(text))
text.new <- substitute(
expression(paste(
text.left, bold(text.middle), text.right
)),
list(
text.left = text.left,
text.middle = text.middle,
text.right = text.right
)
)
text.new %>% eval()
} else if (text %like% '(_.*_|\\*.*\\*)') {
# italic
if (text %like% '(_.*_)') {
locations <- unlist(gregexpr(pattern = '[_]',
text))
} else {
locations <- unlist(gregexpr(pattern = '[*]',
text))
}
locations <- locations[1:2]
text.left <- substr(text,
1,
min(locations) - 1)
text.middle <- substr(text,
min(locations) + 1,
max(locations) - 1)
text.right <- substr(text,
max(locations) + 1,
nchar(text))
text.new <- substitute(
expression(paste(
text.left, italic(text.middle), text.right
)),
list(
text.left = text.left,
text.middle = text.middle,
text.right = text.right
)
)
text.new %>% eval()
} else {
text
}
}
plot2.variables <- function(data,
x,
y,
y.category,
x.category,
type,
misses.data,
misses.x,
misses.y,
misses.y.category,
sort.x,
sort.y.category,
sort.x.category,
horizontal,
datalabels,
x.max,
x.max.txt,
summarise_function,
summarise_function_text,
na.replace,
na.rm) {
x.remove <- FALSE
# print(misses.x)
# if (type == 'boxplot') {
# if (!misses.x ) {
# y.category = x
# }
# }
if (misses.data == FALSE & is.data.frame(data)) {
# altijd groepen verwijderen voor plotten
data <- ungroup(data)
}
if (misses.y == FALSE & all(y %in% c(NA, NaN))) {
stop("Invalid values for y (all are NA or NaN)", call. = FALSE)
}
# als geen data opgegeven is, deze maken
if (misses.data == TRUE) {
if (misses.y == TRUE & misses.x == FALSE) {
data <- tibble(x = x) %>%
group_by(x) %>%
summarise(y = n())
x = 'x'
y = 'y'
datalabels <- FALSE
} else if (misses.y == FALSE & misses.x == TRUE) {
# alleen y opgegeven
if (is.na(datalabels)) {
datalabels <- 'y'
}
if (any(class(y) == 'factor')) {
class.bak <- class(data)
data <- tibble(level = y, count = 1) %>%
group_by(level) %>%
summarise(count = sum(count)) %>%
droplevels()
class(data$level) <- class.bak
x <- 'level'
y <- 'count'
} else {
data <- tibble(x = c(1:length(y)), y = y)
x <- 'x'
y <- 'y'
x.remove <- TRUE
}
} else if (misses.y == FALSE & misses.x == FALSE) {
# x en y opgegeven
if (length(x) == length(y) |
(length(x) != 1 | length(y) != 1)) {
data <- tibble(x = x, y = y)
x <- 'x'
y <- 'y'
} else {
stop('`x` and `y` must have the same length when both are defined manually.')
}
}
if (misses.y.category == FALSE) {
data <- data %>% tibble::add_column(y.category)
}
} else if (misses.x == TRUE & misses.y == TRUE & !is.data.frame(data)) {
# x en y missen, en data is een reeks getallen; dit wordt y
if (is.na(datalabels)) {
datalabels <- data
}
if (any(class(data) == 'factor')) {
class.bak <- class(data)
data <- tibble(level = data, count = 1) %>%
group_by(level) %>%
summarise(count = sum(count)) %>%
droplevels()
class(data$level) <- class.bak
x <- 'level'
y <- 'count'
} else {
data <- tibble(x = c(1:length(data)), y = data)
x <- 'x'
y <- 'y'
x.remove <- TRUE
}
} else {
# data mist niet, maar x en/of y mist
# dit komt door `df %>% plot2()` en komt dus veel voor
if (misses.y == TRUE) {
if (is.numeric(data %>% pull(2))) {
y <- colnames(data)[2]
} else {
if (misses.y.category == TRUE
& data %>% pull(2) %>% n_distinct() > 1) {
y.category <- colnames(data)[2]
}
y <- colnames(data)[3]
}
}
if (misses.x == TRUE) {
x <- colnames(data)[1]
}
}
if (identical(y, x) | identical(y, y.category) | identical(y, x.category)) {
# y is automatisch bepaald, maar is gelijk aan een ander
# op zoek naar eerste beste numerieke kolom, anders fout
y <- NA
for (i in 1:ncol(data)) {
if (is.numeric(data %>% pull(i))
& !(identical(colnames(data)[i], x)
& !identical(colnames(data)[i], y.category)
& !identical(colnames(data)[i], x.category))) {
y <- colnames(data)[i]
break
}
}
if (is.na(y)) {
stop('`y` cannot be determined.')
}
}
if (misses.x == FALSE & length(x) == 1) {
if (is.na(x)) {
x.remove <- TRUE
datalabels <- FALSE
}
}
if (type == 'boxplot') {
if (!misses.x) {
y.category <- x
} else if (!is.na(y.category) & x == "") {
# geen x opgegeven, maar y.category is wel beredeneerd
x <- y.category
}
}
if (type == 'barpercent') {
y.category <- NA
}
if (identical(x.category, y.category)) {
y.category <- NA
}
# Alle NA's verwijderen of vervangen
if (na.rm == TRUE) {
if (!is.na(x)) {
data <- data %>% filter_at(x, all_vars(!is.na(.)))
}
if (!is.na(y)) {
data <- data %>% filter_at(y, all_vars(!is.na(.)))
}
if (!is.na(x.category)) {
data <- data %>% filter_at(x.category, all_vars(!is.na(.)))
}
if (!is.na(y.category)) {
data <- data %>% filter_at(y.category, all_vars(!is.na(.)))
}
} else if (!is.na(na.replace)) {
# waar in kolom x, x.category of y.category NA voorkomt, vervangen door na.replace:
if (!is.na(x)) {
if (data %>% pull(x) %>% is.na() %>% sum(na.rm = TRUE) > 0) {
if (is.factor(data %>% pull(x))) {
data[, x] <- factor(x = data %>% pull(x),
levels = c(data %>% pull(x) %>% levels(), na.replace) %>% unique())
data[data %>% pull(x) %>% is.na(), x] <- na.replace
}
}
}
if (!is.na(x.category)) {
if (data %>% pull(x.category) %>% is.na() %>% sum(na.rm = TRUE) > 0) {
if (is.factor(data %>% pull(x.category))) {
data[, x.category] <- factor(x = data %>% pull(x.category),
levels = c(data %>% pull(x.category) %>% levels(), na.replace) %>% unique())
data[data %>% pull(x.category) %>% is.na(), x.category] <- na.replace
}
}
}
if (!is.na(y.category)) {
if (data %>% pull(y.category) %>% is.na() %>% sum(na.rm = TRUE) > 0) {
if (is.factor(data %>% pull(y.category))) {
data[, y.category] <- factor(x = data %>% pull(y.category),
levels = c(data %>% pull(y.category) %>% levels(), na.replace) %>% unique())
data[data %>% pull(y.category) %>% is.na(), y.category] <- na.replace
}
}
}
}
# controleren of kolommen wel bestaan
for (i in 1:length(x)) {
if (!is.na(x[i])) {
if (!x[i] %in% colnames(data)) {
stop('This variable does not exist: ', x[i], '.', call. = FALSE)
}
}
}
for (i in 1:length(y)) {
if (!is.na(y[i])) {
if (!y[i] %in% colnames(data)) {
stop('This variable does not exist: ', y[i], '.', call. = FALSE)
}
}
}
if (is.na(y.category) & length(y) == 1) {
meerdere_series <- FALSE
} else {
meerdere_series <- TRUE
}
# print(x)
# print(y)
# print(y.category)
# print(x.category)
# gaat anders problemen geven als `x` of `y` ook in de data voorkomt
col_x_ <- x
col_y_ <- y
# geen difftime voor y-as
for (i in 1:length(col_y_)) {
if (!is.numeric(data %>% pull(col_y_[i]))) {
class_y <- data %>% pull(col_y_[i]) %>% class()
if ("difftime" %in% class_y) {
values_type <- attributes(data %>% pull(col_y_[i]))$units
} else {
values_type <- "values"
}
warning("Column '", col_y_[i], "' (input for y) is of class '", rev(class_y)[1],
"'. These ", values_type, " are transformed to class 'double'.", call. = FALSE)
data[, col_y_[i]] <- data %>% pull(col_y_[i]) %>% as.double()
}
}
if (type == 'barpercent') {
if (meerdere_series == TRUE) {
stop('Type `barpercent` does not allow more than one category.', call. = FALSE)
}
data$y.bak <- data %>% pull(col_y_)
data[, col_y_] <- (data %>% pull(col_y_)) / sum(data %>% pull(col_y_))
}
if (!(type == 'boxplot' & meerdere_series == TRUE)
& is.na(x.category)
& !is.na(col_x_)
& ((is.na(y.category) & length(col_y_) == 1)
| identical(col_x_, y.category))) {
if (data %>% pull(col_x_) %>% n_distinct() < nrow(data)) {
# elke x komt vaker voorkomen dan 1x
if (type == 'barpercent') {
data <- data %>%
group_by_at(col_x_) %>%
summarise_at(vars(col_y_, y.bak), summarise_function)
} else {
data <- data %>%
group_by_at(col_x_) %>%
summarise_at(col_y_, summarise_function)
}
# if (!summarise_function_text %like% '[::]') {
# # locatie van de functie ophalen
# fn_location <- getAnywhere(summarise_function_text)[['where']][1] %>%
# gsub('package:', '', ., fixed = TRUE)
# summarise_function_text <- paste0(fn_location, '::', summarise_function_text)
# }
message('Using ', summarise_function_text, ' for `', col_y_,
'` (y), since `', col_x_ , '` (x) contains duplicate values (change this with `summarise_function`).')
}
}
if (!is.na(y.category) & length(col_y_) > 1) {
stop("`y.category` cannot be used while y has length > 1.")
} else if (meerdere_series == FALSE) {
# ################### #
# grafiek met 1 serie #
# ################### #
if (!col_y_ %in% colnames(data)) {
stop('This variable does not exist: ', col_y_, '.')
}
if (!is.na(col_x_)) { #is.na nodig voor boxplots wanneer plot2(x = NA) gebruikt wordt
grafiek <- ggplot(data, aes_string(x = col_x_, y = col_y_))
} else {
grafiek <- ggplot(data, aes_string(y = col_y_))
}
} else if (meerdere_series == TRUE) {
# #################### #
# grafiek met >1 serie #
# #################### #
if (is.na(y.category) & length(col_y_) > 1) {
# met categorieën, eerst gather nodig
exlude_vars <- character(0)
if (!is.na(x)) {
exlude_vars <- c(x, exlude_vars)
}
if (!is.na(x.category)) {
exlude_vars <- c(x.category, exlude_vars)
}
if (length(exlude_vars) > 0) {
data <- tidyr::gather(data, key = "y.category", value = "y", -exlude_vars)
} else {
data <- tidyr::gather(data, key = "y.category", value = "y")
}
lijst <- y
data <- data %>% filter(y.category %in% lijst)
if (nrow(data) == 0) {
stop('These variables do not exist: ', toString(lijst), '.')
}
if (data %>% pull('y.category') %>% n_distinct() < length(lijst)) {
warning('These variables do not exist: ',
toString(setdiff(lijst, unique(data %>% pull('y.category')))),
'.')
}
# ondersteuning voor legenda: y = c('Aantal orders' = 'aantal', 'Aantal monsters' = 'monsters')
if (!is.null(names(y))) {
for (i in 1:length(y)) {
if (names(y)[i] != '') {
data[, 'y.category'] <- gsub(paste0('^', (y)[i], '$'), names(y)[i], data %>% pull('y.category'))
}
}
}
col_y_ <- 'y'
y.category <- 'y.category'
}
if (length(y.category) > 1) {
# is data opgegeven
data$y.category <- y.category
y.category <- 'y.category'
}
grafiek <- ggplot(data, aes_string(x = col_x_, y = col_y_, fill = y.category, group = y.category))
}
if ('y' %in% colnames(grafiek$data)) {
if (class(grafiek$data$y) == 'character') {
grafiek$data$y <- grafiek$data$y %>% as.double()
}
}
if ('y.category' %in% colnames(grafiek$data)) {
if (class(grafiek$data$y.category) != 'character') {
grafiek$data$y.category <- grafiek$data$y.category %>% as.character()
}
}
if (!is.na(x.max)) {
if (data %>% pull(col_x_) %>% n_distinct() > x.max) {
# groeperen op x en alles > x.max de naam x.max.txt geven
data[, col_x_] <- data %>% pull(col_x_) %>% as.character() # krijgt namelijk x.max.txt erbij; dat is een tekst
desc_x <- data %>%
group_by_at(col_x_) %>%
summarise_at(vars(col_y_), funs(n = sum), na.rm = TRUE) %>%
arrange(desc(n)) %>%
pull(col_x_)
x.max.txt <- gsub('%n', length(desc_x) - x.max, x.max.txt, fixed = TRUE)
desc_x <- desc_x[1:x.max]
data[which(!(data %>% pull(col_x_)) %in% desc_x), col_x_] <- x.max.txt
if (meerdere_series == FALSE) {
if (!'sortering' %in% colnames(data)) {
data <- data %>% mutate(sortering = data %>% pull(col_y_))
}
if (!'y.bak' %in% colnames(data)) {
data <- data %>% mutate(y.bak = data %>% pull(col_y_))
}
data[which(data %>% pull(col_x_) == x.max.txt), 'sortering'] <- 0 # laagste sortering
data <- data %>%
group_by_at(col_x_) %>%
summarise_at(vars(col_y_, y.bak, sortering), sum, na.rm = TRUE) %>%
arrange(sortering)
data[, col_x_] <- factor(x = data %>% pull(col_x_),
levels = data %>% pull(col_x_))
}
grafiek$data <- data
}
}
# datalabels
if (length(datalabels) == 1) {
if (is.na(datalabels)) {
datalabels.show <- FALSE
} else {
if (datalabels == FALSE | datalabels == '') {
datalabels.show <- FALSE
} else if (datalabels == TRUE) {
datalabels.show <- TRUE
if (type == 'barpercent') {
datalabels <- data %>% pull(y.bak) # wordt in plot2() opgemaakt
} else if (length(col_y_) == 1) {
datalabels <- data %>% pull(col_y_)
} else {
datalabels <- data %>% pull(y)
}
} else if (datalabels != '') {
datalabels.show <- TRUE
if (class(datalabels) == 'character' & datalabels %in% colnames(data)) {
# plot2(..., datalabels = col_x) mogelijk maken, wanneer 'col_x' in data voorkomt
datalabels <- data %>% pull(datalabels)
}
}
}
} else {
if (meerdere_series == TRUE & sort(datalabels) %>% identical(sort(unique(grafiek$data$y.category)))) {
datalabels <- data %>% pull(col_y_)
}
datalabels.show <- TRUE
}
if (type == "rsi") {
datalabels.show <- FALSE
}
# sorteren van x
if (!is.na(x)) {
if (!is.null(sort.x)) { # sort.x = NULL niet sorteren
if (x != '') {
if (data %>% pull(col_x_) %>% is.numeric()) {
values <- data %>% pull(col_x_) %>% as.double()
} else {
values <- data %>% pull(col_x_) %>% as.character()
}
if (any(data %>% pull(col_x_) %>% class() %in% c("Date", "POSIXct", "POSIXlt"))) {
# melding bij datums op x-as, die worden een factor wanneer sort.x != "asis"
warning('x axis contains dates, that will be transformed to factors since sort.x = ', toString(sort.x), '. Use sort.x = NULL to prevent this.', call. = FALSE)
}
if (sort.x == TRUE) {
if ('factor' %in% (data %>% pull(col_x_) %>% class())) {
sort.x <- "" # helemaal niet sorteren
} else {
sort.x <- 'asc'
}
}
if (sort.x %like% 'freq$') {
sort.x <- paste0(sort.x, '-desc')
}
if (horizontal == TRUE) {
# asc en desc omdraaien
sort.x <- gsub('asc', 'asc2', sort.x)
sort.x <- gsub('desc', 'asc', sort.x)
sort.x <- gsub('asc2', 'desc', sort.x)
}
if (sort.x %in% c('alpha', 'asc')) {
data[, col_x_] <- base::factor(values,
levels = values %>%
unique() %>%
sort())
} else if (sort.x == 'desc') {
data[, col_x_] <- base::factor(values,
levels = values %>%
unique() %>%
sort() %>%
rev())
} else if (sort.x %in% c('inorder', 'order', FALSE)) {
data[, col_x_] <- forcats::fct_inorder(values %>% as.character())
} else if (sort.x %in% c('infreq-desc', 'freq-desc')) {
data[, col_x_] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = TRUE)
} else if (sort.x %in% c('infreq-asc', 'freq-asc')) {
data[, col_x_] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = FALSE)
} else if (sort.x == "asis") {
# helemaal niet transformeren
}
if (!is.na(x.max) & sort.x != "asis") {
# tekst '(rest x n)' als laatste level
if (horizontal == TRUE & type != 'barpercent') {
x.max.after = Inf
} else {
x.max.after = 0L
}
suppressWarnings(
data[, col_x_] <- forcats::fct_relevel(data %>% pull(col_x_), x.max.txt, after = x.max.after)
)
}
grafiek$data[, col_x_] <- data %>% pull(col_x_)
}
}
}
# sorteren van y.category
if (!is.na(y.category)) {
if (!is.null(sort.y.category)) { # sort.y.category = NULL niet sorteren
if (y.category != '') {
if (data %>% pull(y.category) %>% is.numeric()) {
values <- data %>% pull(y.category) %>% as.double()
} else {
values <- data %>% pull(y.category) %>% as.character()
}
if (sort.y.category == TRUE) {
if ('factor' %in% (data %>% pull(y.category) %>% class())) {
sort.y.category <- "" # helemaal niet sorteren
} else {
sort.y.category <- 'asc'
}
}
if (sort.y.category %like% 'freq$') {
sort.y.category <- paste0(sort.y.category, '-desc')
}
if (horizontal == TRUE) {
# asc en desc omdraaien
sort.y.category <- gsub('asc', 'asc2', sort.y.category)
sort.y.category <- gsub('desc', 'asc', sort.y.category)
sort.y.category <- gsub('asc2', 'desc', sort.y.category)
}
if (sort.y.category %in% c('alpha', 'asc')) {
data[, y.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort())
} else if (sort.y.category == 'desc') {
data[, y.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort() %>%
rev())
} else if (sort.y.category %in% c('inorder', 'order', FALSE)) {
data[, y.category] <- forcats::fct_inorder(values %>% as.character())
} else if (sort.y.category %in% c('infreq-desc', 'freq-desc')) {
data[, y.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = TRUE)
} else if (sort.y.category %in% c('infreq-asc', 'freq-asc')) {
data[, y.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = FALSE)
}
grafiek$data[, y.category] <- data %>% pull(y.category)
}
}
}
# sorteren van x.category
if (!is.na(x.category)) {
if (!is.null(sort.x.category)) { # sort.x.category = NULL niet sorteren
if (x.category != '') {
if (data %>% pull(x.category) %>% is.numeric()) {
values <- data %>% pull(x.category) %>% as.double()
} else {
values <- data %>% pull(x.category) %>% as.character()
}
if (sort.x.category == TRUE) {
if ('factor' %in% (data %>% pull(x.category) %>% class())) {
sort.x.category <- "" # helemaal niet sorteren
} else {
sort.x.category <- 'asc'
}
}
if (sort.x.category %like% 'freq$') {
sort.x.category <- paste0(sort.x.category, '-desc')
}
if (horizontal == TRUE) {
# asc en desc omdraaien
sort.x.category <- gsub('asc', 'asc2', sort.x.category)
sort.x.category <- gsub('desc', 'asc', sort.x.category)
sort.x.category <- gsub('asc2', 'desc', sort.x.category)
}
if (sort.x.category %in% c('alpha', 'asc')) {
data[, x.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort())
} else if (sort.x.category == 'desc') {
data[, x.category] <- base::factor(values,
levels = values %>%
unique() %>%
sort() %>%
rev())
} else if (sort.x.category %in% c('inorder', 'order', FALSE)) {
data[, x.category] <- forcats::fct_inorder(values %>% as.character())
} else if (sort.x.category %in% c('infreq-desc', 'freq-desc')) {
data[, x.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = TRUE)
} else if (sort.x.category %in% c('infreq-asc', 'freq-asc')) {
data[, x.category] <- forcats::fct_reorder(.f = values %>% as.character(),
.x = data %>% pull(col_y_),
.fun = summarise_function,
.desc = FALSE)
}
grafiek$data[, x.category] <- data %>% pull(x.category)
}
}
}
return(
list(
data = data,
grafiek = grafiek,
x = col_x_,
y = col_y_,
y.category = y.category,
x.remove = x.remove,
meerdere_series = meerdere_series,
datalabels.show = datalabels.show,
datalabels = datalabels
)
)
}
quasiquotate <- function(deparsed, parsed) {
# bij tekst: eerste en laatste " verwijderen
if (any(deparsed %like% '^".+"$' | deparsed %like% "^'.+'$")) {
deparsed <- deparsed %>% substr(2, nchar(.) - 1)
}
# als deparsed in de kolomnamen van parsed voorkomt, moet de voorkeur naar de kolomnaam gaan (deparsed),
# anders werkt dit niet: aantal$aantal bestaat, en je runt `aantal %>% plot2(y = aantal)`
deparsed_in_cols <- tryCatch(deparsed %in% colnames(parsed),
error = function(e) FALSE)
# toepassen als nodig
if (any(!deparsed %like% '[[$:()]'
& !deparsed %in% c('""', "''", "", # lege tekst
".", ".data", # dplyr referenties
"TRUE", "FALSE", # logicals
"NA", "NaN", "NULL", # lege waarden
ls(.GlobalEnv))) |
deparsed_in_cols == TRUE) {
deparsed
} else {
parsed
}
}
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.