#' @title rysuje tablicę na podstawie ramki danych
#' @description W wypadku, gdy liczba wierszy w tablicy jest nieprzewidywalna,
#' nie da się opisać tablicy w szablonie raportu za pomocą kodu markdown.
#' Funkcja \code{TAB} pozwala obejść to ograniczenie rysując tablicę na
#' podstawie dowolnej ramki danych.
#'
#' Tablica rysowana jest w składni multiline tables, a więc z zapewnieniem
#' łamania wierszy w komórkach.
#'
#' Kolumny zawierające wartości liczbowe są wyrównane do prawej, zaś kolumny
#' tekstowe do lewej (być może w przyszłości pojawi się możliwość ręcznego
#' określania wyrównania).
#'
#' Jeśli w parametrze \code{kolN} wskazana zostanie nazwa kolumny przechowującej
#' liczbę obserwacji, funkcja dokona anonimizacji (zamiany na '-') kolumn
#' liczbowych, dla których liczba obserwacji jest mniejsza niż wartość parametru
#' \code{nMin}, przy czym przy anonimizacji pominięte zostaną kolumny pasujące
#' do wyrażenia regularnego przekazanego w argumencie \code{pomin}.
#' @param dane ramka danych do narysowania w postaci tablicy
#' @param dodajLp czy dodać kolumnę z liczbą porządkową
#' @param kolN nazwa kolumny z liczbą obserwacji (lub NA, jeśli dane nie mają
#' być anonimizowane)
#' @param nMin wartość w kolumnie liczby obserwacji, poniżej której ma nastąpić
#' anonimizacja kolumn liczbowych
#' @param pomin wyrażenie regularne dopasowujące nazwy kolumn, które mają nie
#' być anonimizowane
#' @param szMin minimalna szerokość pojedynczej kolumny (gdy NA, ustawiana na
#' \code{0.75 / liczba kolumn})
#' @param backend backend używany do wygenerowania tabeli: \code{MLAK}
#' (oryginalny), \code{DT} (funkcja \code{DT::datatable()}) , \code{knitr}
#' (funkcja \code{knitr::kable})
#' @param ... pozostałe parametry, które zostaną przekazane do funkcji backendu
#' @return character vector
#' @import dplyr
#' @export
TAB = function(dane, dodajLp = TRUE, kolN = NA_character_, nMin = 10, pomin = '^[lL][.]?[pP][.]?$', szMin = NA_real_, backend = 'MLAK', ...){
stopifnot(
is.data.frame(dane),
is.vector(dodajLp), is.logical(dodajLp), length(dodajLp) == 1, all(!is.na(dodajLp)),
is.vector(kolN), is.character(kolN), length(kolN) == 1,
is.vector(nMin), is.numeric(nMin), length(nMin) == 1, all(!is.na(nMin)),
is.vector(pomin), is.character(pomin), length(pomin) == 1, all(!is.na(pomin)),
is.vector(szMin), is.numeric(szMin), length(szMin) == 1,
is.vector(backend), is.character(backend), length(backend) == 1, all(backend %in% c('MLAK', 'DT', 'knitr'))
)
# Pozbycie się ew. data_frame i factorów, zaradzenie NA w nazwach kolumn
dane = as.data.frame(dane, stringsAsFactors = FALSE)
colnames(dane) = paste0(colnames(dane))
for (k in colnames(dane)) {
if (is.factor(dane[, k])) {
dane[, k] = levels(dane[, k])[dane[, k]]
}
}
# Anonimizacja
if (!is.na(kolN) & nrow(dane) > 0) {
stopifnot(sum(colnames(dane) %in% kolN) == 1)
filtr = suppressWarnings(as.numeric(dane[, kolN])) < nMin | is.na(dane[, kolN])
for (kol in setdiff(colnames(dane)[!grepl(pomin, colnames(dane))], kolN)) {
tmp = dane[, kol]
# czy kolumna liczbowa
tmp2 = suppressWarnings(as.numeric(sub('%$', '', tmp)))
if (sum(is.na(tmp)) == sum(is.na(tmp2))) {
dane[filtr, kol] = '-'
}
}
dane[is.na(dane[, kolN]), kolN] = '-'
}
# Zamiana NA na `-` w kolumnach liczbowych
for (kol in setdiff(colnames(dane)[!grepl(pomin, colnames(dane))], kolN)) {
if (any(is.na(dane[, kol]))) {
dane[, kol] = dplyr::coalesce(as.character(dane[, kol]), '-')
}
}
# Kolumna LP
if (dodajLp & nrow(dane) > 0) {
tmp = colnames(dane)
dane = dane %>%
mutate_(lp = ~row_number())
dane = dane[, c('lp', tmp)]
}
# Właściwa funkcja
if (backend == 'DT') {
DT::datatable(dane, ...)
} else if (backend == 'knitr') {
knitr::kable(dane, ...)
} else {
if (is.na(szMin)) {
szMin = 0.75 / ncol(dane)
}
kolumny = data.frame(stringsAsFactors = FALSE, row.names = NULL,
naglowek = names(dane),
dlNagl = sapply(names(dane), stringi::stri_length),
dlWart = sapply(dane, function(x){
x = as.character(x)
return(suppressWarnings(max(stringi::stri_length(x), na.rm = TRUE)))
}),
czyChar = sapply(dane, function(x){
xx = suppressWarnings(as.numeric(sub('-$', 0, sub('%$', '', x))))
return(sum(is.na(x)) != sum(is.na(xx)))
})
)
kolumny$dlNagl[is.na(kolumny$dlNagl)] = 0
kolumny$dlWart[is.infinite(kolumny$dlWart)] = 0
kolumny$dlMax = apply(kolumny[, c('dlNagl', 'dlWart')], 1, function(x){
return(max(x['dlNagl'] + 2, x['dlWart']))
})
# ograniczenie
kolumny$dlMax = sapply(kolumny$dlMax, function(x){
return(round(max(c(x, sum(kolumny$dlMax) * szMin))))
})
for (i in seq_along(names(dane))) {
dane[, i] = as.character(dane[, i])
}
poczKon = paste0(rep('-', sum(kolumny$dlMax) + ncol(dane) - 1), collapse = '')
# Początek
cat('\n', poczKon, '\n', sep = '')
# Nagłówek
for (i in seq_along(names(dane))) {
komorka = ifelse(
kolumny$czyChar[i],
paste0(c(names(dane)[i], rep(' ', kolumny$dlMax[i] - kolumny$dlNagl[i])), collapse = ''),
paste0(c(rep(' ', kolumny$dlMax[i] - kolumny$dlNagl[i]), names(dane)[i]), collapse = '')
)
cat(komorka, ' ', sep = '')
}
cat('\n')
# Separator nagłówka
for (i in seq_along(names(dane))) {
cat(rep('-', kolumny$dlMax[i]), ' ', sep = '')
}
cat('\n')
# Wiersze
for (i in seq_along(dane[, 1])) {
for (j in seq_along(names(dane))) {
w = ifelse(is.na(dane[i, j]), '', dane[i, j])
cat(w, rep(' ', kolumny$dlMax[j] - stringi::stri_length(w)), ' ', sep = '')
}
cat('\n')
if (i < nrow(dane)) {
cat('\n')
}
}
# Koniec
cat(poczKon, '\n\n', sep = '')
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.