# ==================================================================== #
# 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. #
# ==================================================================== #
#' MMB-gegevens ophalen van MySQL-/MariaDB-database
#'
#' @description Gegevens van Certe Medische Microbiologie uit de Certe-database downloaden. De benodigde tabellen worden als \code{LEFT JOIN} automatisch toegevoegd op basis van de input bij \code{where} en \code{select}. Nadien kan met \code{\link{qry}} de query bekeken worden, die als eigenschap bij het object opgeslagen wordt.
#'
#' \code{certedb_getmmb} haalt orders en resultaten op, met uitslagen. \cr
#' \code{certedb_getmmb_tat} haalt van deze orders de doorlooptijden op (TAT = Turn Around Time).
#' @rdname certedb_getmmb
#' @param dates Standaard is dit hele jaar. Geldige opties zijn: leeg (selecteert dit hele jaar) of een vector met 2 datums (bestaande uit oudste en nieuwste datum) of een enkele datum (einddatum wordt laatste dag van dat jaar).
#' @param where Standaard is leeg. Syntax om toe te voegen aan de WHERE-clausule. \cr \cr
#' R-syntax wordt omgezet naar SQL-syntax, zie Examples. Deze syntax wordt geëvalueerd, dus gebruik van variabelen is ook mogelijk, zoals \code{certedb_getmmb(where = where(o.jaar == mijnjaar))}. \cr \cr
#' \strong{NB.} Wanneer tabelvelden in meerdere brontabellen voorkomen, moet de tabelreferentie opgegeven worden. Zie Details voor de tabelreferenties en Examples voor voorbeelden.
#' @param select_preset,preset Standaard is \code{"mmb"} of \code{"tat"} bij doorlooptijden. Variabelen om te selecteren volgens de voorgedefinieerde lijst met variabelen, zie \code{\link{preset.list}}. Kan ook een vector met meerdere presets zijn. Voor het selecteren van de eerste preset uit de huidige map (bestandsnaam moet beginnen met \code{"preset"}), gebruik \code{select_preset = \link{preset.thisfolder}()}.
#' @param select Standaard is leeg. Variabelen om \strong{handmatig} te selecteren. Deze kunnen het best geselecteerd worden met \code{\link{db}} en dit overschrijft \code{select_preset}.
#' @param add_cols Standaard is leeg. Variabelen in een vector of \code{list} om \strong{extra} te selecteren. Deze kunnen het best geselecteerd worden met \code{\link{db}}. Gebruik \code{add_cols = c("naam" = db$t.kolom)} voor \code{"t.kolom AS naam"}.
#' @param limit Standaard is 10.000.000. Het aantal rijen dat maximaal opgehaald moet worden.
#' @param con Standaard is leeg, waarmee de verbinding gemaakt wordt op basis van de omgevingsvariabelen van de huidige gebruiker: \code{"DB_HOST"}, \code{"DB_PORT"}, \code{"DB_USERNAME"} en \code{"DB_PASSWORD"}.
#' @param dbname Standaard is \code{"certemmb"}. Naam van de database die geselecteerd moet worden. Wordt genegeerd als \code{con} al een bestaande verbinding is.
#' @param info Standaard is \code{TRUE}. Printen van voortgang en het uiteindelijke aantal rijen en kolommen dat gedownload is.
#' @param first_isolates Standaard is \code{FALSE}. Bepaling van eerste isolaten toevoegen.
#' @param eucast_rules Standaard is \code{"all"}. EUCAST expert rules toepassen, zie \code{\link{eucast_rules}}.
#' @param MIC Standaard is \code{FALSE}. Toevoegen van MIC's aan alle RSI-kolommen van de de standaard query (i.e. zonder dat \code{select} gebruikt wordt).
#' @param zipcodes Standaard is \code{FALSE}. Toevoegen van postcodes van de patiënt, als \code{p.postcode}. Met name voor gebruik met \code{\link{get_map}} en \code{\link{plot2.map}}.
#' @param ziplength Standaard is \code{3}. De gewenste lengte van de postcode.
#' @param tat_hours Standaard is \code{TRUE}. Turn-around-times toevoegen in uren \emph{(alleen voor doorlooptijden)}.
#' @param only_real_patients Standaard is \code{TRUE}. Hiermee worden alleen daadwerkelijke patiënten gedownload (geen rondzendingen en testorders). Dit voegt automatisch \code{AND u.is_echte_patient = TRUE} toe aan de \code{WHERE}.
#' @param only_conducted_tests Standaard is \code{TRUE}. Hiermee worden alleen verrichte testen gedownload (geen testen die niet verricht zijn). Dit voegt automatisch \code{AND u.is_verricht = TRUE} toe aan de \code{WHERE}.
#' @param only_show_query Standaard is \code{FALSE}. Draait de query niet, maar toont hem alleen.
#' @param review_where Standaard is \code{FALSE} als \code{info = FALSE} of de sessie in niet-interactief (RMarkdown). Bij een interactieve sessie (d.w.z. niet in RMarkdown) wordt de WHERE weergegeven die de gebruiker moet accorderen. Dit kan standaard op \code{FALSE} gezet worden met \code{\link{getOption}("review_where")}.
#' @param ... Overige parameters die doorgegeven worden aan \code{\link{certedb_query}}, zoals \code{auto_transform} en \code{timezone}.
#' @details Voor gebruik van \code{where} staan hieronder de tabelreferenties. Deze zijn ook beschikbaar via de \emph{list} \code{\link[certedata]{db}}:
#' \itemize{
#' \item{\strong{\code{a}}} \cr {\code{temporary_certemm_aanvragers_praktijken}}
#' \item{\strong{\code{aanvr}}} \cr {\code{temporary_certemm_aanvragers_praktijken}}
#' \item{\strong{\code{beh}}} \cr {\code{temporary_certemm_aanvragers_praktijken}}
#' \item{\strong{\code{b}}} \cr {\code{temporary_certemm_bacterienlijst}}
#' \item{\strong{\code{d}}} \cr {\code{temporary_certemm_aanmaakdatums}}
#' \item{\strong{\code{dlt}} \emph{(alleen voor doorlooptijden)}} \cr {\code{temporary_certemm_doorlooptijden}}
#' \item{\strong{\code{i}}} \cr {\code{temporary_certemm_isolaten_rsi}}
#' \item{\strong{\code{i_mic}}} \cr {\code{temporary_certemm_isolaten_mic}}
#' \item{\strong{\code{l_instelling}}} \cr {\code{temporary_certemm_locaties}}
#' \item{\strong{\code{l_ontvangst}}} \cr {\code{temporary_certemm_locaties}}
#' \item{\strong{\code{l_uitvoer}}} \cr {\code{temporary_certemm_locaties}}
#' \item{\strong{\code{m}}} \cr {\code{temporary_certemm_materiaalgroepen}}
#' \item{\strong{\code{o}}} \cr {\code{temporary_certemm_orders}}
#' \item{\strong{\code{p}}} \cr {\code{certemm_pat}}
#' \item{\strong{\code{pat}}} \cr {\code{temporary_certemm_patienten}}
#' \item{\strong{\code{t}}} \cr {\code{temporary_certemm_testgroepen}}
#' \item{\strong{\code{u}}} \cr {\code{temporary_certemm_uitslagen}}
#' }
#'
#' Locatie wordt dus op \strong{drie manieren gekoppeld}; als \code{l_instelling} (op \code{o.instelling}, zoals huisarts), als \code{l_ontvangst} (op \code{o.recsitenb}, zoals Assen) en als \code{l_uitvoer} (op \code{u.uitvafd}, zoals Moleculair).
#' @importFrom crayon silver
#' @export
#' @seealso \code{\link{certedb_query}} voor het direct gebruik van query's.
#' @examples
#' ################
#' # MMB-gegevens #
#' ################
#' mmb.2017_Q1 <- certedb_getmmb(dates = c("2017-01-01", "2017-03-31")
#'
#' mmb.2018 <- certedb_getmmb(2018)
#'
#'
#' # GEBRUIK VAN PRESETS:
#'
#' # zoeken naar preset_mmb.sql in de map Sys.getenv("R_REFMAP")
#' data <- certedb_getmmb(2018,
#' select_preset = "mmb")
#'
#' # zoeken naar preset_VOLUMES.sql in de map Sys.getenv("R_REFMAP")
#' data <- certedb_getmmb(2018,
#' select_preset = "VOLUMES")
#'
#' # zoeken naar eerste preset_*.sql in huidige map
#' data <- certedb_getmmb(2018,
#' select_preset = preset.thisfolder())
#'
#'
#' # GEBRUIK VAN WHERE:
#' # Het object `db` is een lijst met alle tabelvelden.
#'
#' # Typ de WHERE in gewone SQL-taal:
#' data <- certedb_getmmb(2018,
#' where = "o.instelling = 'MZ'")
#'
#' data <- certedb_getmmb(dates = c(2015, 2018),
#' where = "a.zorglijn = 'Eerste lijn'")
#'
#'
#' # Of in R-syntax; dit wordt vertaald naar SQL-syntax, dus dit werkt hetzelfde:
#' data <- certedb_getmmb(2018,
#' where = db$a.postcode %in% c("1234AA", "1234BB"))
#' data <- certedb_getmmb(2018,
#' where = a.postcode %in% c("1234AA", "1234BB"))
#' data <- certedb_getmmb(2018,
#' where = "a.postcode IN ('1234AA', '1234BB')")
#'
#' # Specifieke microorganismen:
#' data <- certedb_getmmb(2018, where(db$b.bacteriecode == mo_certe("T. vaginalis")))
#'
#' # Wanneer de WHERE gevat wordt in de functie `where`:
#' data <- certedb_getmmb(2018,
#' where = where(db$a.postcode %in% c("1234AA", "1234BB")))
#' data <- certedb_getmmb(2018,
#' where(db$a.postcode %in% c("1234AA", "1234BB")))
#'
#'
#' # Reguliere expressie:
#' data <- certedb_getmmb(2018,
#' where = db$a.postcode %like% "1234")
#' data <- certedb_getmmb(2018,
#' where(db$a.postcode %like% "1234"))
#' data <- certedb_getmmb(2018,
#' where = "a.postcode REGEXP '1234'")
#'
#' # Logische negatie:
#' data <- certedb_getmmb(2018,
#' where(!db$a.postcode %like% "1234"))
#' data <- certedb_getmmb(2018,
#' where = "a.postcode NOT REGEXP '1234'")
#'
#' # Variabelen uit de Global Environment:
#' postcodelijst <- c("1234AA", "1234BB")
#' data <- certedb_getmmb(2018,
#' where(db$a.postcode %in% postcodelijst))
#' data <- certedb_getmmb(2018,
#' where = "a.postcode IN ('1234AA','1234BB')")
#'
#' # Getallenbereik:
#' data <- certedb_getmmb(where = where(db$o.jaar %in% c(2012:2015)
#' & db$o.kwartaal %in% 1:3))
#' data <- certedb_getmmb(where = "o.jaar IN (2012, 2013, 2014, 2015)
#' AND o.kwartaal IN (1, 2, 3)")
#' # (deze laatste overschrijft `dates`)
#'
#' ##################
#' # Doorlooptijden #
#' ##################
#' # voorbeelden voor GeneXpert-testen:
#' data <- certedb_getmmb_tat(2018,
#' where(db$t.testcode %like% "^PX"))
#'
#' data <- certedb_getmmb_tat(2018,
#' where(db$t.apparaat == "GeneXpert"))
#'
#' data <- certedb_getmmb_tat(2018,
#' where(db$t.testcode == "PXNORO"))
#'
certedb_getmmb <- function(dates = NULL,
where = NULL,
select_preset = "mmb",
preset = "mmb",
select = NULL,
add_cols = NULL,
limit = 10000000,
con = NULL,
dbname = 'certemmb',
info = TRUE,
first_isolates = FALSE,
eucast_rules = "all",
MIC = FALSE,
zipcodes = FALSE,
ziplength = 3,
tat_hours = FALSE,
only_real_patients = TRUE,
only_conducted_tests = TRUE,
only_show_query = FALSE,
review_where = as.logical(min(c(getOption("review_where", TRUE),
info,
interactive()))),
...) {
dates_depsub <- deparse(substitute(dates))
where_depsub <- deparse(substitute(where))
if (all(gsub("-", "", where_depsub, fixed = TRUE) %like% "^[0-9]+$")) {
#stop("Invalid `where`, it contains a date or year. ")
warning("Using `where` as `dates[2]` (", where_depsub, ")", immediate. = TRUE, call. = FALSE)
where <- NULL
if (length(dates) == 1) {
dates <- c(dates, where_depsub)
} else if (length(dates) == 2) {
dates[2] <- where_depsub
}
}
dots <- list(...) %>% unlist()
if (length(dots) != 0) {
dots.names <- dots %>% names()
if ('startdate' %in% dots.names | 'enddate' %in% dots.names) {
dates <- character(2)
}
if ('startdate' %in% dots.names) {
if (!is.null(dots[which(dots.names == 'startdate')])) {
dates[1] <- dots[which(dots.names == 'startdate')]
if (!dates[1] %like% '[12][90][0-9][0-9]-[01][0-9]-[0123][0-9]') {
dates[1] <- as.character(as.Date(as.integer(dates[1]), origin = "1970-01-01"))
}
}
}
if ('enddate' %in% dots.names) {
if (!is.null(dots[which(dots.names == 'enddate')])) {
dates[2] <- dots[which(dots.names == 'enddate')]
if (!dates[2] %like% '[12][90][0-9][0-9]-[01][0-9]-[0123][0-9]') {
dates[2] <- as.character(as.Date(as.integer(dates[2]), origin = "1970-01-01"))
}
}
}
if ('EUCAST_rules' %in% dots.names) {
eucast_rules <- dots[which(dots.names == 'EUCAST_rules')]
}
}
# datumbereik
if (is.null(dates)) {
# dit hele jaar
dates <- c(paste0(year(Sys.Date()), '-01-01'), paste0(year(Sys.Date()), '-12-31'))
} else {
# alleen jaar opgegeven
if (dates[1] %like% "^[12][90][0-9][0-9]$") {
dates[1] <- paste0(dates[1], "-01-01")
}
if (dates[2] %like% "^[12][90][0-9][0-9]$") {
dates[2] <- paste0(dates[2], "-12-31")
}
dates <- as.character(dates)
dates_int <- suppressWarnings(as.integer(dates))
if (!is.na(dates_int[1])) {
dates[1] <- as.character(as.Date(as.integer(dates[1]), origin = "1970-01-01"))
}
if (!is.na(dates_int[2])) {
dates[2] <- as.character(as.Date(as.integer(dates[2]), origin = "1970-01-01"))
}
if (!all(dates %like% '^[12][90][0-9][0-9]-[01][0-9]-[0123][0-9]$') & all(dates %in% c("", NA))) {
# bestaat nog niet uit yyyy-mm-dd
stop("Invalid value(s) for `dates`. Use format yyyy-mm-dd.")
}
if (length(dates) == 1 | (identical(dates[2], "") | identical(dates[2], NA_character_))) {
# datum tot einde van jaar
dates <- c(dates[1], paste0(year(dates[1]), '-12-31'))
} else if (length(dates) > 2) {
stop("`dates` can have a maximum length of 2.")
}
if (is.na(dates[1])) {
warning("First `dates` element is NA.", immediate. = TRUE, call. = FALSE)
}
if (is.na(dates[2])) {
warning("Second `dates` element is NA.", immediate. = TRUE, call. = FALSE)
}
}
dates <- paste0("'", gsub('["\']', '', dates), "'")
if (is.null(select)) {
if (preset != "mmb") {
select <- preset.read(preset)
} else {
select <- preset.read(select_preset)
}
}
select <- select_translate_asterisk(select)
# extra kolommen
if (!is.null(add_cols)) {
add_cols <- unlist(add_cols) # wanneer add_cols = list(a = t.kolom) gebruikt wordt
select <- c(select, select_translate_asterisk(add_cols))
}
# MIC toevoegen
if (MIC == TRUE) {
select <- c(select,
'i_mic.peni_mic',
'i_mic.oxac_mic',
'i_mic.clox_mic',
'i_mic.amox_mic',
'i_mic.amcl_mic',
'i_mic.ampi_mic',
'i_mic.pita_mic',
'i_mic.czol_mic',
'i_mic.cfep_mic',
'i_mic.cfur_mic',
'i_mic.cfox_mic',
'i_mic.cfot_mic',
'i_mic.cfta_mic',
'i_mic.cftr_mic',
'i_mic.gent_mic',
'i_mic.tobr_mic',
'i_mic.amik_mic',
'i_mic.kana_mic',
'i_mic.trim_mic',
'i_mic.trsu_mic',
'i_mic.nitr_mic',
'i_mic.fosf_mic',
'i_mic.line_mic',
'i_mic.cipr_mic',
'i_mic.moxi_mic',
'i_mic.vanc_mic',
'i_mic.teic_mic',
'i_mic.tetr_mic',
'i_mic.tige_mic',
'i_mic.doxy_mic',
'i_mic.mino_mic',
'i_mic.eryt_mic',
'i_mic.clin_mic',
'i_mic.azit_mic',
'i_mic.clar_mic',
'i_mic.imip_mic',
'i_mic.mero_mic',
'i_mic.metr_mic',
'i_mic.chlo_mic',
'i_mic.coli_mic',
'i_mic.mupi_mic',
'i_mic.rifa_mic')
}
if (zipcodes == TRUE) {
select <- c(select, "p.postcode")
message("Note: Adding 'p.postcode'.")
}
select <- gsub(",$", "", select)
select <- unique(select)
select <- select %>% concat(',\n ')
query <- paste0('SELECT\n ',
select, '\n',
'FROM\n ',
'{from}\n',
'WHERE\n ',
'{datelimit}',
'{additional_where}')
ignore_start_stop <- FALSE
if (tat_hours == FALSE) {
# geen TAT, moet nog gedeparsed worden
if (any(dates_depsub %like% '^where\\(')) {
#enddate <- NULL
where <- where_R2SQL(dates_depsub, info = info)
} else {
where <- where_R2SQL(deparse(substitute(where)), info = info)
}
# deparse-foutje als getmm_tat gebruikt wordt:
if (where == 'enddate') {
where <- ''
}
}
# extra where
if (where != '') {
if (where %like% '[.]ontvangstdatum ' | where %like% '[.]jaar ') {
if (info == TRUE) {
warning('`dates` will be ignored because date criteria has been set with `where`.',
call. = FALSE,
immediate. = TRUE)
}
ignore_start_stop <- TRUE
query <- query %>%
sub("{additional_where}", where, ., fixed = TRUE)
} else {
query <- query %>%
sub("{additional_where}", paste0('\n AND ', where), ., fixed = TRUE)
}
} else {
query <- query %>%
sub("{additional_where}", '', ., fixed = TRUE)
}
if (ignore_start_stop == FALSE) {
# if (is.null(startdate)) {
# start.year <- year(Sys.Date())
# startdate <- paste0("'", start.year, '-01-01', "'")
# } else if (is.double2(startdate)) {
# start.year <- startdate
# startdate <- paste0("'", start.year, '-01-01', "'")
# } else if (!startdate %>% substr(1, 1) %in% c('"', "'")) {
# start.year <- NULL
# startdate <- paste0("'", startdate, "'")
# }
#
# if (is.null(enddate)) {
# if (!is.null(start.year)) {
# enddate <- paste0("'", start.year, '-12-31', "'")
# } else {
# enddate <- startdate
# }
# } else if (is.double2(enddate)) {
# enddate <- paste0("'", enddate, '-12-31', "'")
# } else if (!enddate %>% substr(1, 1) %in% c('"', "'")) {
# enddate <- paste0("'", enddate, "'")
# }
if (dates[1] > dates[2]) {
stop('First date cannot be later than second date, it would return zero results.')
}
query <- query %>%
sub("{datelimit}", paste('o.ontvangstdatum BETWEEN', dates[1], 'AND', dates[2]), ., fixed = TRUE)
} else {
query <- query %>%
sub("{datelimit}", '', ., fixed = TRUE)
}
if (only_real_patients == TRUE) {
if (query %like% '[.]is_echte_patient =') {
stop('`is_echte_patient` cannot be set while `only_real_patients = TRUE`.')
}
query <- paste(query, '\n AND u.is_echte_patient = TRUE')
}
if (only_conducted_tests == TRUE) {
if (query %like% '[.]is_verricht =') {
stop('`is_verricht` cannot be set while `only_conducted_tests = TRUE`.')
}
query <- paste(query, '\n AND u.is_verricht = TRUE')
}
# FROM clausule
if (query %like% ' dlt[.]') {
# primair van dlt halen, orders en uitslagen eraan
from <- paste0('temporary_certemm_doorlooptijden AS dlt',
"\n LEFT JOIN\n ",
"temporary_certemm_orders AS o ON o.ordernr = dlt.ordernr",
"\n LEFT JOIN\n ",
"temporary_certemm_uitslagen AS u ON u.ordernr_testcode_mtrlcode = dlt.ordernr_testcode_mtrlcode")
} else {
# primair van uitslagen halen, orders eraan
from <- paste0('temporary_certemm_uitslagen AS u',
"\n LEFT JOIN\n ",
"temporary_certemm_orders AS o ON o.ordernr = u.ordernr")
}
from <- from_addjoins(query, from)
query <- sub("{from}", from, query, fixed = TRUE)
if (only_show_query == TRUE) {
sql(paste0('\n', query, '\n'))
} else {
if (review_where == TRUE & base::interactive() == TRUE) {
note <- ""
if (is.null(getOption("review_where")) & runif(1) < 0.5) {
# notitie in helft van de gevallen, wanneer gebruiker dit niet heeft ingesteld
note <- silver("\nStel dit standaard in met options(review_where = TRUE/FALSE).")
}
# met qry_beautify, omdat dit in certedb_query ook gebruikt wordt
choice <- utils::menu(choices = c("OK", "Annuleren", "Hele query weergeven"),
title = paste0(paste0("Query met deze WHERE uitvoeren?", note, "\n\n"),
gsub("(.*)\nWHERE\n (.*)", "\\2", qry_beautify(query))))
if (choice == 3) {
cat(paste0("\nHele query:\n\n", qry_beautify(query), "\n\n"))
choice <- utils::menu(choices = c("OK", "Annuleren"),
title = "\nQuery uitvoeren?")
}
if (choice %in% c(0, 2)) { # 'Enter an item from the menu, or 0 to exit'
return(invisible())
}
}
starttime_total <- Sys.time()
totaal <- certedb_query(query = query, con = con, dbname = dbname, info = info, limit = limit, ...)
if (tat_hours == TRUE & select %like% ' dlt[.]') {
# berekeningen in tijd toevoegen
certedb_timestamp("Calculating time differences in hours...", print = info)
totaal <- totaal %>%
mutate(val1_usr_1e = val1_usr_1e %>% as.character(),
val2_usr_1e = val2_usr_1e %>% as.character(),
aut_usr_1e = aut_usr_1e %>% as.character(),
val1_usr_def = val1_usr_def %>% as.character(),
val2_usr_def = val2_usr_def %>% as.character(),
aut_usr_def = aut_usr_def %>% as.character()) %>%
mutate(val1_1e.val2_1e = (difftime(val2_1e, val1_1e, units = 'mins') / 60) %>% as.double(),
val2_1e.aut_1e = (difftime(aut_1e, val2_1e, units = 'mins') / 60) %>% as.double(),
ontvangst.val2_1e = (difftime(val2_1e, ontvangstdatumtijd, units = 'mins') / 60) %>% as.double(),
val1_def.val2_def = (difftime(val2_def, val1_def, units = 'mins') / 60) %>% as.double(),
val2_def.aut_def = (difftime(aut_def, val2_def, units = 'mins') / 60) %>% as.double(),
ontvangst.val2_def = (difftime(val2_def, ontvangstdatumtijd, units = 'mins') / 60) %>% as.double(),
# aut_def.rpt_def = (difftime(rpt_def, aut_def, units = 'mins') / 60) %>% as.double(),
dgn_ontvangst.val1_1e = as.Date(val1_1e) - ontvangstdatum,
dgn_ontvangst.val1_def = as.Date(val1_def) - ontvangstdatum,
dgn_ontvangst.val2_1e = as.Date(val2_1e) - ontvangstdatum,
dgn_ontvangst.val2_def = as.Date(val2_def) - ontvangstdatum,
# dgn_tot_rpt_1e = as.Date(rpt_1e) - ontvangstdatum
weekdag = weekdays(as.Date(ontvangstdatum), abbreviate = FALSE)
)
certedb_timestamp("Adding region/year/quarter column `reg_jr_q`...", print = info)
totaal <- totaal %>%
mutate(reg_jr_q = paste0(noord_zuid %>% substr(1, 1), '|', format2(ontvangstdatum, 'yyyy-QQ')))
}
if (select %like% ' i[.]' & nrow(totaal) > 0) {
if (!"mo" %in% colnames(totaal) & "bacteriecode" %in% colnames(totaal)) {
if (!all(is.na(totaal$bacteriecode))) {
suppressWarnings(
totaal <- totaal %>%
rename(bacteriecode_oud = bacteriecode) %>%
mutate(bacteriecode = as.mo(bacteriecode_oud))
)
}
}
if (all(is.na(totaal$bacteriecode))) {
message('Note: No isolates available.')
} else {
if (eucast_rules != FALSE & "bacteriecode" %in% colnames(totaal)) {
certedb_timestamp(paste('Applying EUCAST', eucast_rules, 'rules...'), print = info, appendLF = FALSE)
totaal <- suppressMessages(suppressWarnings(AMR::eucast_rules(totaal, col_mo = 'bacteriecode', rules = eucast_rules, info = FALSE)))
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
}
if (first_isolates == TRUE) {
totaal <- suppressMessages(tbl_first_isolates(totaal, info = info, timestamp = TRUE))
}
difference <- difftime(Sys.time(), starttime_total, units = 'mins')
if (eucast_rules == TRUE | first_isolates == TRUE) {
certedb_timestamp('Done.', print = info)
}
if (info == TRUE) {
cat('\nTotal run time:', diff_min_sec(difference), '\n\n')
}
if (info == TRUE) {
if (eucast_rules == FALSE) {
message('Note: No EUCAST expert rules applied.')
}
if (first_isolates == FALSE) {
message('Note: No first isolates determined.')
}
}
}
}
if (zipcodes == TRUE & ziplength < 6) {
certedb_timestamp("Transforming zip codes...", print = info)
totaal <- totaal %>% mutate(postcode = postcode %>% substr(1, ziplength))
}
qry(totaal) <- query
# label voor hele df
label(totaal) <- paste0(Sys.getenv("R_USERNAME"), ", ",
format2(Sys.time(), "yyyy-mm-dd HH:MM:SS"))
# label per kolom, uitleg van antibiotica
# label(totaal) <- c("5flu" = "Flucytosine",
# amcl = "Amoxicilline/clavulaanzuur",
# amik = "Amikacine",
# amox = "Amoxicilline",
# amph = "Amfotericine B",
# ampi = "Ampicilline",
# amsu = "Ampicilline/sulbactam",
# anid = "Anidulafungine",
# ansa = "Ansamycine",
# azit = "Azitromycine",
# azlo = "Azlocilline",
# aztr = "Aztreonam",
# baci = "Bacitacine",
# bepe = "Benzylpenicilline",
# casp = "Caspofungine",
# cefa = "Cefaloridine",
# cfac = "Cefaclor",
# cfal = "Cefalotine",
# cfam = "Cefamandol",
# cfep = "Cefepim",
# cfix = "Cefixim",
# cfot = "Cefotaxim",
# cfox = "Cefoxitine",
# cfpo = "Cefpodoxim",
# cfra = "Cefradine",
# cfsc = "Cefoxitine screen",
# cfsu = "Cefsulodine",
# cfta = "Ceftazidim",
# cftr = "Ceftriaxon",
# cfur = "Cefuroxim",
# chlo = "Chlooramfenicol",
# cipr = "Ciprofloxacine",
# clar = "Claritromycine",
# clin = "Clindamycine",
# clof = "Clofazimine",
# clot = "Clotrimazol",
# clox = "Flucloxacilline",
# cnox = "Cinoxacine",
# coli = "Colistine",
# cycl = "Cycloserine",
# czol = "Cefazoline",
# dapt = "Daptomycine",
# doxy = "Doxycycline",
# dum = "dummy antibioticum",
# econ = "Econazol",
# eryt = "Erytromycine",
# etha = "Ethambutol",
# ethi = "Ethionamide",
# fluo = "Fluorocytosine",
# fluz = "Fluconazol",
# fosf = "Fosfomycine",
# fusi = "Fusidinezuur",
# gehl = "Gentamicine high level",
# gent = "Gentamicine",
# imip = "Imipenem",
# incl = "ind. clinda",
# inh = "Isoniazide",
# itra = "Itraconazol",
# kana = "Kanamycine",
# keto = "Ketoconazol",
# levo = "Levofloxacine",
# linc = "Lincomycine",
# line = "Linezolid",
# lome = "Lomefloxacine",
# mero = "Meropenem",
# meti = "Meticilline",
# metr = "Metronidazol",
# mico = "Miconazol",
# mino = "Minocycline",
# moxa = "Moxalactamase",
# moxi = "Moxifloxacine",
# mupi = "Mupirocine",
# nali = "Nalidixinezuur",
# neom = "Neomycine",
# neti = "Netilmicine",
# nitr = "Nitrofurantoine",
# norf = "Norfloxacine",
# novo = "Novobiocine",
# nyst = "Nystatine",
# oflo = "Ofloxacine",
# oxac = "Oxacilline",
# peni = "Penicilline",
# pipe = "Piperacilline",
# pita = "Piperacilline/tazobactam",
# pizu = "Pipemidinezuur",
# poly = "Polymyxine B",
# posa = "Posaconazol",
# prot = "Protionamide",
# pyra = "Pyrazinamide",
# qida = "Quinupristine/dalfopristine",
# rifa = "Rifampicine",
# rifb = "Rifabutine",
# roxi = "Roxitromycine",
# siso = "Sisomicine",
# spec = "Spectinomycine",
# sthl = "Streptomycine high level",
# stre = "Streptomycine",
# sulf = "Sulfamethoxazol",
# tazo = "Tazobactam",
# teic = "Teicoplanine",
# tes2 = "test automatisering",
# test = "test automatisering",
# tetr = "Tetracycline",
# thio = "Metisazon",
# tica = "Ticarcilline",
# ticl = "Ticarcilline/clavulaanzuur",
# tige = "Tigecycline",
# tobr = "Tobramycine",
# trim = "Trimethoprim",
# trsu = "Cotrimoxazol",
# tsta = "Testantibioticum",
# vanc = "Vancomycine",
# vori = "Voriconazol",
# xct = "Cefotaxim",
# xctl = "cefotaxim+clavulaanzuur",
# xpm = "Cefepim",
# xpml = "cefepim+clavulaanzuur",
# xtz = "Ceftazidim",
# xtzl = "ceftazidim+clavulaanzuur")
totaal
}
}
#' @rdname certedb_getmmb
#' @export
certedb_getmmb_tat <- function(dates = NULL,
where = NULL,
add_cols = NULL,
limit = 10000000,
con = NULL,
dbname = 'certemmb',
info = TRUE,
only_real_patients = TRUE,
only_conducted_tests = TRUE,
only_show_query = FALSE,
...) {
where_test <- deparse(substitute(where))
if (any(where_test %like% '^where\\(')) {
where <- where_R2SQL(where_test, info = info)
} else {
where <- where_R2SQL(deparse(substitute(where)), info = info)
}
# deparse-foutje als getmm_tat gebruikt wordt:
if (where == 'enddate') {
where <- ''
}
certedb_getmmb(dates = dates,
where = where,
add_cols = add_cols,
limit = limit,
con = con,
dbname = dbname,
info = info,
only_real_patients = only_real_patients,
only_conducted_tests = only_conducted_tests,
only_show_query = only_show_query,
select_preset = "tat",
first_isolates = FALSE,
eucast_rules = FALSE,
MIC = FALSE,
tat_hours = TRUE,
...)
}
select_translate_asterisk <- function(select) {
select.bak <- select
select_list <- select %>% as.list()
for (i in 1:length(select)) {
# alle tabel.* uitschrijven naar c(tabel.a, tabel.b, ...)
if (select[i] %like% '[.][*]') {
found <- gregexpr('[.][*]', select[i])
select_tbl <- substr(select[i], 1, found %>% as.integer() - 1)
select_items <-
certedata::db[names(certedata::db) %like% paste0('^', select_tbl, '[.][a-z]+')] %>%
unlist() %>%
unname()
select_list[[i]] <- select_items
}
}
select_list <- select_list %>% unlist()
# ondersteuning voor add_cols = c("test" = db$m.mtrlcode) -> "m.mtrlcode AS test"
for (i in 1:length(select.bak)) {
if (!is.null(names(select.bak)[i])) {
if (names(select.bak)[i] != "") {
select_list[i] <- paste(select_list[i], "AS", names(select.bak)[i])
}
}
}
select_list
}
from_addjoins <- function(query, from) {
# dependencies:
# alleen TAT:
# dlt < u
# dlt < o
# alles:
# u < o
# u < d (datums)
# u < l_uitvoer
# u < o < l_instelling
# u < o < l_ontvangst
# u < t
# u < m
# u < o < a
# u < o < aanvr
# u < o < beh
# u < o < p
# u < i
# u < i_mic
# u < b
if (query %like% ' r[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"certemm_res AS r ON r.ordernr = u.ordernr AND r.anamc = u.testcode AND r.mtrlcode = u.mtrlcode AND r.stamteller = u.stam")
}
if (query %like% ' d[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_aanmaakdatums AS d ON d.ordernr_testcode_mtrlcode = u.ordernr_testcode_mtrlcode")
}
if (query %like% ' l_instelling[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_locaties AS l_instelling ON l_instelling.instelling = o.instelling")
}
if (query %like% ' l_ontvangst[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_locaties AS l_ontvangst ON l_ontvangst.instelling = o.recsitenb")
}
if (query %like% ' l_uitvoer[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_locaties AS l_uitvoer ON l_uitvoer.instelling = u.uitvafd")
}
if (query %like% ' t[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_testgroepen AS t ON t.testcode = u.testcode")
}
if (query %like% ' m[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_materiaalgroepen AS m ON m.mtrlcode = u.mtrlcode")
}
if (query %like% ' aanvr[.]' & query %like% ' a[.]') {
warning("Encountered table references `a.*` and `aanvr.*`. This will lead to an extra and unnecessary LEFT JOIN.",
call. = FALSE,
immediate. = TRUE)
}
if (query %like% ' a[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_aanvragers_praktijken AS a ON a.aanvragercode = o.aanvrager")
}
if (query %like% ' aanvr[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_aanvragers_praktijken AS aanvr ON aanvr.aanvragercode = o.aanvrager")
}
if (query %like% ' beh[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_aanvragers_praktijken AS beh ON beh.aanvragercode = o.behandelaar")
}
if (query %like% ' p[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"certemm_pat AS p ON p.patidnb = o.patidnb")
}
if (query %like% ' pat[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_patienten AS pat ON pat.patidnb = o.patidnb")
}
if (query %like% ' i[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_isolaten_rsi AS i ON i.ordernr_testcode_mtrlcode_stam = u.ordernr_testcode_mtrlcode_stam")
}
if (query %like% ' i_mic[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_isolaten_mic AS i_mic ON i_mic.ordernr_testcode_mtrlcode_stam = u.ordernr_testcode_mtrlcode_stam")
}
if (query %like% ' b[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_bacterienlijst AS b ON b.bacteriecode = u.bacteriecode")
}
if (query %like% ' g[.]') {
from <- paste0(from, "\n ",
"LEFT JOIN\n ",
"temporary_certemm_grampreparaten AS g ON g.ordernr = u.ordernr")
}
from
}
where_R2SQL <- function(where = NULL, info = TRUE) {
where <- where %>%
paste0(' ', ., ' ') %>%
gsub('"', "'", ., fixed = TRUE) %>%
concat(' ') %>%
gsub(' {2,255}', ' ', .)
if (where %>% substr(1, 1) == "'") {
where <- where %>% substr(2, nchar(.))
}
if (where %>% substr(nchar(.), nchar(.)) == "'") {
where <- where %>% substr(1, nchar(.) - 1)
}
if (where %like% '^ [where(].*[)] $') {
where <- paste0(' ', substr(where, 8, nchar(where) - 2), ' ')
}
if (where == ' NULL ') {
return('')
}
where <- where %>%
# spaties voor en na toevoegen
paste0(' ', ., ' ') %>%
# logische negatie verwerken:
# !test LIKE 'a' -> test NOT LIKE 'a'
# !(test LIKE 'a') -> (test NOT LIKE 'a')
gsub(' [!]([(]*)([0-9a-zA-Z$_.]+) ', ' \\1\\2 NOT ', .) %>%
# !is.na(test) of !is.null(test) -> test IS NOT NULL
gsub(' (!is.na|!is.null)[(]([0-9a-zA-Z$_.]+)[)] ', ' \\2 IS NOT NULL ', .) %>%
# is.na(test) of is.null(test) -> test IS NULL
gsub(' (is.na|is.null)[(]([0-9a-zA-Z$_.]+)[)] ', ' \\2 IS NULL ', .) %>%
# komma's naar '&' als dit niet opgevolgd wordt door een getal of aanhalingsteken
# gsub(', ?([a-zA-Z])', ' & \\1', .) %>% # 2018-10-16 zie mailwisseling - gaat fout bij waarden die , bevatten
# env var van certedata
gsub('db$', '', ., fixed = TRUE) %>%
# operators vertalen
gsub(' & ', ' AND ', ., fixed = TRUE) %>%
gsub(' && ', ' AND ', ., fixed = TRUE) %>%
gsub(' | ', ' OR ', ., fixed = TRUE) %>%
gsub(' || ', ' OR ', ., fixed = TRUE) %>%
gsub(' == ', ' = ', ., fixed = TRUE) %>%
gsub(' %in% ', ' IN ', ., fixed = TRUE) %>%
gsub(' c(', ' (', ., fixed = TRUE) %>%
gsub(' %like_case% ', ' REGEXP BINARY ', ., fixed = TRUE) %>%
gsub(' %like% ', ' REGEXP ', ., fixed = TRUE) %>%
gsub(' NOT = ', ' != ', ., fixed = TRUE) # anders fout: !a == b -> a NOT = b
# ondersteuning voor R-evaluaties:
# o.jaar IN 2016:2018 -> o.jaar IN (2016, 2017, 2018)
eval_num <- gregexpr(' [(]*[0-9]+[:][0-9]+[)]*', where)
if (unlist(eval_num)[1] != -1) {
starts <- eval_num %>% unlist()
lengths <- attributes(eval_num[[1]])$match.length
where_backup <- where
for (i in 1:length(starts)) {
# getallen als 2015:2017 zoeken
nums_old <- where_backup %>%
substr(starts[i] + 1,
starts[i] + lengths[i])
# uitrekenen en omzetten naar lijst
nums_new <- eval(parse(text = nums_old)) %>%
concat(', ') %>%
paste0(' (', . , ') ')
# nieuwe where maken
where <- sub(nums_old, nums_new, where, fixed = TRUE)
}
}
# ondersteuning voor variabelen uit Global Environment
where_list <- where %>% strsplit(' ') %>% unlist()
for (i in 1:length(where_list)) {
if (where_list[i] %in% ls(envir = .GlobalEnv)) {
newval <- eval(parse(text = where_list[i]))
if (NCOL(newval) == 1) {
if (!all(is.double2(newval))) {
newval <- paste0("'", newval, "'")
}
newval <- newval %>%
concat(', ') %>%
paste0('(', . , ')')
if (info == TRUE) {
message(paste0('Replacing value `',
where_list[i],
'` in query by variable: ',
ifelse(nchar(newval) > 25,
paste0(newval %>% substr(1, 25), '...)'),
newval)))
}
where_list[i] <- newval
} else {
stop(paste0('variable `',
where_list[i],
'` can only be a single value or vector.'))
}
}
}
where <- where_list %>% concat(' ') %>%
# extra spaties verwijderen
gsub(' {2,255}', ' ', .) %>%
trimws('both')
# proberen om expressie te evalueren als er een functie voorkomt (dus met haakje)
where_list <- where %>% strsplit('=') %>% unlist()
for (i in 1:length(where_list)) {
if (where_list[i] %like% "[(]") {
where_list[i] <- tryCatch(paste0("'",
eval(parse(text = trimws(where_list[i]))),
"'"),
error = function(e) where_list[i])
}
}
where <- where_list %>% concat(' = ') %>%
# extra spaties verwijderen
gsub(' {2,255}', ' ', .) %>%
trimws('both')
if (where %like% "^['].+[']$" | where %like% '^["].+["]$') {
where <- where %>% substr(2, nchar(.) - 1)
}
# extra witregels maken zodat SQL-query de juiste indents krijgt
if (where %like% ' OR ') {
where <- paste0('(', where %>% gsub(' OR ', '\n OR ', ., fixed = TRUE), ')')
if (where %like% ' AND ') {
where <- paste0(where %>% gsub(' AND ', '\n AND ', ., fixed = TRUE))
}
} else if (where %like% ' AND ') {
where <- paste0(where %>% gsub(' AND ', '\n AND ', ., fixed = TRUE))
}
where
}
diff_min_sec <- function(diff) {
mins <- diff %>% as.integer() %>% as.double()
secs <- ((diff %>% as.double() - mins) * 60) %>% round(0)
if (mins != 0) {
diff_text <- paste(mins, 'minutes and ')
} else {
diff_text <- ''
}
diff_text <- paste0(diff_text, secs, ' seconds.')
diff_text
}
#' SQL-query uitvoeren op MySQL-/MariaDB-database
#'
#' Een SQL-query uitvoeren op een MySQL-/MariaDB-database van bijv. Certe. De output krijgt een \code{qry}-attribuut, dat met \code{\link{qry}} opgehaald kan worden.
#' @param query (Bestand met) SQL-tekst die uitgevoerd moet worden. Tabelnamen in de query hoeven geen \code{"temporary_"} of \code{"certemm_"} te bevatten en zijn hoofdletterongevoelig. Deze query wordt bij het object opgeslagen als eigenschap \code{query} dat bekeken kan worden met de functie \code{\link{qry}}.
#' @param limit Standaard is 10.000.000. Het aantal rijen dat maximaal opgehaald moet worden.
#' @param con Standaard is leeg, waarmee de verbinding gemaakt wordt op basis van de omgevingsvariabelen van de huidige gebruiker: \code{"DB_HOST"}, \code{"DB_PORT"}, \code{"DB_USERNAME"} en \code{"DB_PASSWORD"}.
#' @param dbname Standaard is \code{"certemmb"}. Naam van de database die geselecteerd moet worden. Wordt genegeerd als \code{con} al een bestaande verbinding is.
#' @param info Standaard is \code{TRUE}. Printen van voortgang van run/fetch en het uiteindelijke aantal rijen en kolommen dat gedownload is.
#' @param check_mtrl_test_codes Standaard is \code{TRUE}. Controleren van materiaal- en testcodes in de tijdelijke tabellen van de database. Hiervoor moet ook \code{info = TRUE} zijn.
#' @param binary_as_logical Standaard is \code{TRUE}. Kolommen die alleen de waarden \code{0} en/of \code{1} bevatten, tranformeren naar logical m.b.v. \code{\link{tbl_binary2logical}}.
#' @param auto_append_prefix Standaard is \code{TRUE}. Wanneer tabellen die voorkomen in de query niet bestaan, wordt gezocht naar tabellen met dezelfde naam die beginnen met \code{"temporary_"} of \code{"certemm_"}. Wanneer zo'n tabel gevonden, wordt die gebruikt.
#' @param auto_transform Standaard is \code{TRUE}. Automatisch alle gedownloade kolommen transformeren met \code{\link{tbl_guess_columns}}.
#' @inheritParams tbl_guess_columns
#' @param ... Overige ongebruikte parameters
#' @export
#' @seealso \code{\link{certedb}} voor alleen het verbinden met de Certe-databaseserver en \code{\link{certedb_getmmb}} om ineens alle relevante MMB-gegevens te downloaden.
#' @examples
#' \dontrun{
#' locaties <- certedb_query("SELECT * FROM temporary_certemm_locaties")
#' locaties <- certedb_query("SELECT * FROM temporary_certemm_locaties", limit = 5)
#'
#' # Door `auto_append_prefix = TRUE` wordt:
#' locaties <- certedb_query("SELECT * FROM locaties")
#' # vertaald naar:
#' locaties <- certedb_query("SELECT * FROM temporary_certemm_locaties")
#' }
certedb_query <- function(query,
limit = 10000000,
con = NULL,
dbname = 'certemmb',
info = TRUE,
check_mtrl_test_codes = TRUE,
binary_as_logical = TRUE,
auto_append_prefix = TRUE,
auto_transform = TRUE,
datenames = 'en',
dateformat = '%Y-%m-%d',
timeformat = '%H:%M',
decimal.mark = '.',
big.mark = '',
timezone = 'UTC',
na = c("", "NULL", "NA"),
...) {
if (!is.numeric(limit)) {
stop('Not a valid limit.')
}
# voor als certedb_query(sql(...)) gebruikt wordt:
query <- query %>% as.character()
# als query bestand is, dan deze lezen
if (file.exists(query)) {
certedb_timestamp('Reading query from file... ', print = info, timestamp = FALSE, appendLF = FALSE)
file_con <- file(query, encoding = "UTF-8")
# bestand inlezen, wordt een vector met elk element = 1 regel
query <- readLines(file_con, warn = FALSE, ok = TRUE)
close(file_con)
if (info == TRUE) {
cat('OK.\n')
}
}
query <- qry_beautify(query)
if (!qry_isvalid(query)) {
if (nchar(query) > 20) {
subquery <- paste0(substr(query, 0, 20), '...')
} else {
subquery <- query
}
stop("Not a valid SQL-query: '", subquery, "'. If this is a file, please check its existance.",
call. = FALSE)
}
if (!missing(limit)) {
if (query %like% ' LIMIT ') {
if (info == TRUE) {
warning('LIMIT already set in query, ignoring `limit = ',
format(limit, scientific = FALSE),
'`',
call. = FALSE,
immediate. = TRUE)
}
} else {
query <- paste(query, 'LIMIT', format(limit, scientific = FALSE))
}
}
# verbinden met database
if (!isS4(con)) {
dbcon <- certedb(dbname = dbname, info = info)
on.exit(certedb_close(dbcon))
} else {
dbcon <- con
}
if (auto_append_prefix == TRUE) {
query_tbls <- strsplit(query, " ", fixed = TRUE) %>% unlist()
# alle tabellen die voorkomen in deze query, alles wat na FROM of JOIN komt:
query_tbls_index <- which(tolower(query_tbls) %in% tolower(c("FROM", "JOIN"))) + 1
tbls_this_qry <- query_tbls[query_tbls_index]
tbls_checked <- tbls_this_qry %>% certedb_check_tbls(con = dbcon, info = info)
query_tbls[query_tbls_index] <- tbls_checked
query <- query_tbls %>% concat(" ")
}
if (check_mtrl_test_codes == TRUE & info == TRUE) {
certedb_checkmmb_mtrlcodes(con = dbcon, dbname = dbname)
certedb_checkmmb_testcodes(con = dbcon, dbname = dbname)
}
starttime <- Sys.time()
# Run + Fetch
certedb_timestamp('Running query...', print = info, appendLF = FALSE)
db_data <- dbcon %>% tbl(sql(query)) %>% collect()
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
# Transform
if (auto_transform == TRUE & nrow(db_data) > 0) {
certedb_timestamp('Transforming data...', print = info, appendLF = FALSE)
if (info == TRUE) {
db_data <- db_data %>% tbl_guess_columns(datenames = datenames,
dateformat = dateformat,
timeformat = timeformat,
decimal.mark = decimal.mark,
big.mark = big.mark,
timezone = timezone,
na = na)
} else {
suppressMessages(
db_data <- db_data %>% tbl_guess_columns(datenames = datenames,
dateformat = dateformat,
timeformat = timeformat,
decimal.mark = decimal.mark,
big.mark = big.mark,
timezone = timezone,
na = na)
)
}
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
} else if (nrow(db_data) > 0 & "POSIXct" %in% unlist(lapply(db_data, class))) {
# er komen wel tijden voor, terwijl dit mogelijk verkeerde tijdzones zijn!
warning("Data may contain wrong timezones. Correct with as.UTC(x).")
}
if (binary_as_logical == TRUE) {
db_data <- db_data %>% tbl_binary2logical()
}
difference <- difftime(Sys.time(), starttime, units = 'mins')
certedb_timestamp('Done.', print = info)
if (info == TRUE & nrow(db_data) == 0) {
message("NOTE: NO OBSERVATIONS FOUND.")
}
if (info == TRUE) {
cat('Downloaded',
nrow(db_data) %>% format2(),
'obs. of',
ncol(db_data) %>% format2(),
'variables, in',
diff_min_sec(difference),
'\n\n')
}
qry(db_data) <- query
db_data
}
#' Verbinding maken met MySQL-/MariaDB-database
#'
#' Dit maakt verbinding met een MySQL-/MariaDB-database zoals de Certe-databaseserver.
#' @param host,port,username,password Standaard zijn omgevingsvariabelen van de huidige gebruiker: \code{"DB_HOST"} (bij ontbreken wordt dit \code{localhost}), \code{"DB_PORT"} (bij ontbreken wordt dit \code{3306}), \code{"DB_USERNAME"} en \code{"DB_PASSWORD"}. Inloggegevens voor de MySQL/MariaDB-server.
#' @param dbname Standaard is \code{"certemmb"}. Naam van de database die geselecteerd moet worden.
#' @param info Standaard is \code{FALSE}. Weergeven van informatie over het verbinden.
#' @export
#' @seealso \code{\link{certedb_query}} voor het direct gebruik van query's en \code{\link{certedb_close}} voor het sluiten van een verbinding.
#' @examples
#' \dontrun{
#'
#' # gegevens direct downloaden naar tibble:
#' locaties <- certe_db() %>%
#' tbl("temporary_certemm_locaties") %>%
#' collect()
#'
#' # alleen query weergeven en niet uitvoeren:
#' locaties <- certe_db() %>%
#' tbl("temporary_certemm_locaties") %>%
#' show_query()
#'
#' # rest werkt met dpylr, zoals filter() en select():
#' locaties <- certe_db() %>%
#' tbl("temporary_certemm_locaties") %>%
#' filter(zkhgroepcode > 0, cu_sd == "Noord") %>%
#' select(instelling) %>%
#' collect()
#'
#' # gebruik head() zoals LIMIT in MySQL:
#' locaties <- certe_db() %>%
#' tbl("temporary_certemm_locaties") %>%
#' head(5) %>%
#' collect()
#' }
certedb <- function(host = Sys.getenv("DB_HOST"),
port = Sys.getenv("DB_PORT"),
username = Sys.getenv("DB_USERNAME"),
password = Sys.getenv("DB_PASSWORD"),
dbname = 'certemmb',
info = FALSE) {
if (host == "") {
host <- 'localhost'
}
if (port == "") {
port <- 3306
} else if (!is.double2(port)) {
stop('`port` must be a numeric value.')
}
if (username == "" | password == "") {
if (info == TRUE) {
warning('`username` or `password` is empty.', call. = FALSE, immediate. = TRUE)
}
}
if (info == TRUE) {
cat(paste0('Connecting to database `', dbname, '`... '))
}
# set proxy met als wachtwoord de omgevingsvariabele "R_WW"
set_certe_proxy()
con <- RMariaDB::dbConnect(RMariaDB::MariaDB(),
dbname = dbname,
host = host,
port = port %>% as.integer(),
username = username,
password = password,
fetch.default.rec = 10000000) # 10M
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
con
}
#' @inherit DBI::dbDisconnect
#' @seealso \code{\link{certedb_query}} voor het direct gebruik van query's.
#' @export
certedb_close <- function(conn, ...) {
RMariaDB::dbDisconnect(conn = conn, ...)
}
#' Tabellen ophalen uit MySQL-/MariaDB-database
#'
#' Alle tabellen uit een MySQL-/MariaDB-database zoals de Certe-database ophalen en in een \code{\link{list}} plaatsen, waarbij elke waarde in de lijst ook de naam is van het element in de lijst.
#' @param con Standaard is leeg, waarmee de verbinding gemaakt wordt op basis van de omgevingsvariabelen van de huidige gebruiker: \code{"DB_HOST"}, \code{"DB_PORT"}, \code{"DB_USERNAME"} en \code{"DB_PASSWORD"}.
#' @param dbname Standaard is \code{"certemmb"}. Naam van de database die geselecteerd moet worden. Wordt genegeerd als \code{con} al een bestaande verbinding is.
#' @export
#' @return \code{\link{list}} met alle gevonden SQL-tabellen.
#' @seealso \code{\link{certedb_query}} voor het direct gebruik van query's.
certedb_tbls <- function(con = NULL, dbname = 'certemmb') {
if (!isS4(con)) {
dbcon <- certedb(dbname = dbname)
on.exit(certedb_close(dbcon))
} else {
dbcon <- con
}
tbls <- dbcon %>% RMariaDB::dbListTables()
tbls <- tbls %>% as.list() %>% setNames(tbls)
for (i in 1:length(tbls)) {
tblcols <- dbcon %>% RMariaDB::dbListFields(tbls[[i]])
tblcols_values <- paste0(tbls[[i]], '.', tblcols)
tblcols_values <- c(tbls[[i]], tblcols_values)
names(tblcols_values) <- c('.', tblcols)
tblcols_values <- tblcols_values %>% as.list()
tbls[[i]] <- tblcols_values
}
tbls
}
#' Controleren van nieuwe materiaal- en testcodes
#'
#' Controleert originele materiaal- en testcodes en vergelijkt ze met de nieuwe \code{temporary_*}-tabellen.
#' @param ... Parameters die doorgegeven worden aan \code{\link{certedb_query}}.
#' @export
#' @aliases certedb_checkmmb_mtrlcodes certedb_checkmmb_testcodes
#' @rdname certedb_checkmmb
certedb_checkmmb_mtrlcodes <- function(...) {
cat("Checking database for new mtrlcodes... ")
query <- c("SELECT m1.*",
"FROM certemm_materialen AS m1",
"LEFT JOIN temporary_certemm_materiaalgroepen AS m2 ON m1.mtrlcode = m2.mtrlcode",
"WHERE m2.mtrlcode IS NULL") %>% concat(" ")
suppressWarnings(
result <- certedb_query(query, info = FALSE, ...)
)
if (nrow(result) > 0) {
message("Warning\nSome mtrlcodes not found in temporary_certemm_materiaalgroepen:")
print(result[, c('mtrlcode', 'kortenaam', 'langenaam')], header = FALSE, row.names = FALSE)
} else {
cat("No new codes found.\n")
}
}
#' @export
#' @rdname certedb_checkmmb
certedb_checkmmb_testcodes <- function(info = TRUE, ...) {
cat("Checking database for new testcodes... ")
query <- c("SELECT t1.*",
"FROM certemm_testen AS t1",
"LEFT JOIN temporary_certemm_testgroepen AS t2 ON t1.anamc = t2.testcode",
"WHERE t2.testcode IS NULL") %>% concat(" ")
suppressWarnings(
result <- certedb_query(query, info = FALSE, ...)
)
if (nrow(result) > 0) {
message("Warning\nSome testcodes not found in temporary_certemm_testgroepen:")
r <- result[, c('anamc', 'kortenaam', 'langenaam')]
colnames(r) <- c('testcode', 'kortenaam', 'langenaam')
print(r, header = FALSE, row.names = FALSE)
} else {
cat("No new codes found.\n")
}
}
#' Query van een object
#'
#' Hiermee kan snel de eigenschap (\emph{attribute}) \code{qry} van een object weergegeven worden of aan een object toegewezen worden. Deze eigenschap wordt altijd toegewezen aan de output van \code{\link{certedb_query}} en vóór toewijzing gevalideerd.
#' @param x Object.
#' @param value Waarde om toe te kennen.
#' @param query Bestaande query als tekst.
#' @details De functie \code{qry_beautify} wordt intern gebruikt om een query netjes op te maken door statements (zoals SELECT en FROM) als hoofdletters weer te geven, commentaren te verwijderen en enters toe te voegen. \cr
#' De functie \code{qry_isvalid} toetst of een query begint met een van de statements op \url{https://mariadb.com/kb/en/library/basic-sql-statements/}.
#' @rdname qry
#' @export
#' @encoding UTF-8
#' @examples
#' \dontrun{
#' data <- certedb_query("SELECT * FROM certemm_ord LIMIT 1")
#' qry(data)
#' }
qry <- function(x) {
q <- attributes(x)$qry
if (is.null(q)) {
message('No query found.')
} else {
q
}
}
#' @rdname qry
#' @export
`qry<-` <- function(x, value) {
query <- qry_beautify(value)
if (!qry_isvalid(query)) {
stop("This is not a valid SQL query.", call. = FALSE)
}
attr(x, 'qry') <- sql(query)
x
}
#' @rdname qry
#' @export
qry_beautify <- function(query) {
query <- query %>%
strsplit('\n') %>%
unlist()
for (i in 1:length(query)) {
query[i] <- query[i] %>%
# alles na "--" en "#" verwijderen
strsplit.select(1, "(--|#)") %>%
# tabelnamen worden ongeldig als ze ';' bevatten, spaties ervoor
gsub(';', ' ;', ., fixed = TRUE) %>%
# meerdere spaties door enkele vervangen
gsub(' {2,255}', ' ', ., fixed = FALSE) %>%
# tabs en spates voor en na elke regel verwijderen
trimws('both')
}
query <- query[query != "" & !is.na(query)] %>% concat(' ')
if (query %>% substr(nchar(.), nchar(.)) == ';') {
query <- query %>% substr(0, nchar(.) - 1)
}
# query met hoofdletter statements
# eerste woord:
query <- gsub("^([a-z]+) ",
"\\U\\1 ",
query,
perl = TRUE,
ignore.case = TRUE)
# alle andere statements:
query <- gsub(" (select|from|left|right|join|as|on|in|where|group by|order by|limit|trim|and|case|when|then|end|else|min|max|date|time|replace|asc|desc|between) ",
" \\U\\1 ",
query,
perl = TRUE,
ignore.case = TRUE)
# opmaken met enters
query <- query %>%
gsub("^(CREATE DATABASE|DROP DATABASE|USE|CREATE TABLE|ALTER TABLE|DROP TABLE|DESCRIBE|SELECT|INSERT|UPDATE|DELETE|REPLACE|TRUNCATE|START TRANSACTION|COMMIT|ROLLBACK) ", "\\U\\1\n", ., ignore.case = TRUE, perl = TRUE) %>%
gsub(" (SELECT|FROM|LEFT JOIN|RIGHT JOIN|JOIN|WHERE|LIMIT|GROUP BY|ORDER BY) ", "\n\\U\\1\n", ., ignore.case = TRUE, perl = TRUE) %>%
# gsub(', ?', ',\n', .) %>%
gsub("\n", "\n ", .) %>%
gsub(" (SELECT|FROM|LEFT JOIN|RIGHT JOIN|JOIN|WHERE|LIMIT|GROUP BY|ORDER BY)\n", "\\U\\1\n", ., ignore.case = TRUE, perl = TRUE) %>%
gsub("( BETWEEN '[0-9-]+' AND)", "\\1_betweendate", .) %>% # AND van BETWEEN datums niet aanpassen
gsub(" AND ", "\n AND ", .) %>% # alle AND in WHERE op nieuwe regel
gsub("AND_betweendate", "AND", .) # de 'between AND' terugzetten
# deel tussen SELECT en FROM met enters
if (query %>% strsplit("(SELECT|FROM)") %>% unlist() %>% length() == 3) {
# bevat een SELECT en een FROM
select_list <- query %>%
gsub(".*SELECT(.*)FROM.*", "\\1", .) %>%
gsub(", ", ",\n ", .) %>%
trimws() %>%
paste(" ", .)
query <- gsub("(.*SELECT).*(FROM.*)", paste0("\\1\n", select_list, "\n\\2"), query)
}
query
}
#' @rdname qry
#' @export
qry_isvalid <- function(query) {
# query moet starten met een van deze statements
# bron: https://mariadb.com/kb/en/library/basic-sql-statements/
qry_beautify(query) %like% "^(CREATE DATABASE|DROP DATABASE|USE|CREATE TABLE|ALTER TABLE|DROP TABLE|DESCRIBE|SELECT|INSERT|UPDATE|DELETE|REPLACE|TRUNCATE|START TRANSACTION|COMMIT|ROLLBACK)(\n| )"
}
#' Tabellen valideren in MySQL-/MariaDB-database
#'
#' Hiermee worden tabellen opgezocht in een MySQL-/MariaDB-database. Niet-bestaande tabellen worden hoofdletterongevoelig vergeleken met bestaande tabellen. Wanneer een niet-bestaande tabel wel voorkomt met een prefix eindigend op een underscore (\code{"_"}, wordt de tabelnaam overschreven door de bestaande tabelnaam die alfabetisch als laatste voorkomt.
#' @param tbls Tabellen in de database die gecontroleerd moeten worden.
#' @param con Standaard is leeg, waarmee de verbinding gemaakt wordt op basis van de omgevingsvariabelen van de huidige gebruiker: \code{"DB_HOST"}, \code{"DB_PORT"}, \code{"DB_USERNAME"} en \code{"DB_PASSWORD"}.
#' @param dbname Standaard is \code{"certemmb"}. Naam van de database die geselecteerd moet worden. Wordt genegeerd als \code{con} al een bestaande verbinding is.
#' @param info Standaard is \code{TRUE}. Waarschuwing weergeven over niet-bestaande tabellen die vervangen worden door bestaande tabellen.
#' @export
certedb_check_tbls <- function(tbls, con = NULL, dbname = 'certemmb', info = TRUE) {
if (!isS4(con)) {
dbcon <- certedb(dbname = dbname, info = info)
on.exit(certedb_close(dbcon))
} else {
dbcon <- con
}
existing_tbls <- certedb_tbls(dbcon) %>% unlist() %>% unname()
not_existing <- tbls[!tbls %in% existing_tbls]
not_existing <- not_existing[which(not_existing %like% '^[0-9A-Z$_]+$')]
if (length(not_existing) != 0) {
# proberen tabel te vinden die er dan wel op lijkt
for (i in 1:length(not_existing)) {
available_tbls <- existing_tbls[which(existing_tbls %like% paste0('_', not_existing[i], '$'))]
# altijd laatste selecteren:
available_tbls <- rev(available_tbls)
if (length(available_tbls) == 0) {
stop('Table not found in database: `', not_existing[i], '`.', call. = FALSE)
} else {
if (info == TRUE) {
message(paste0('Note: Selecting table `',
available_tbls[1],
'` instead of non-existing table `',
not_existing[i],
'`'))
}
tbls <- gsub(not_existing[i], available_tbls[1], tbls, fixed = TRUE)
}
}
}
tbls
}
# Timestamp plaatsen in Console
certedb_timestamp <- function(subject, print, timestamp = TRUE, appendLF = TRUE) {
if (print == TRUE) {
if (timestamp == FALSE) {
cat(subject)
} else {
cat(paste0('[',
format2(Sys.time()),
'] ',
subject))
}
if (appendLF == TRUE) {
cat('\n')
}
}
}
#' Voorgedefinieerde variabelen selecteren
#'
#' Dit downloadt bestanden uit de map \code{Sys.getenv("R_REFMAP")} die de structuur \code{preset_*.sql} hebben. Gebruik een of meerdere van deze (zelf te maken) bestanden als parameter \code{select_preset} in de functies \code{\link{certedb_getmmb}} en \code{\link{certedb_getmmb_tat}}. Zie Details.
#' @param name Tekst(vector) om te zoeken in de map \code{Sys.getenv("R_REFMAP")}.
#' @param vector Tekst(vector) met kolomnamen die opgeslagen moet worden als nieuwe preset. Deze kunnen geselecteerd worden met \code{\link{db}}.
#' @param fullname Standaard is \code{FALSE}. Bestandsnamen weergeven met prefix \code{prefix_} en suffix \code{.sql}.
#' @param recursive Ook onderliggende mappen doorzoeken.
#' @details Gebruik: \cr
#' - \code{preset.list} voor het weergeven van alle presets in de map \code{Sys.getenv("R_REFMAP")}; \cr
#' - \code{preset.add} voor het toevoegen van een nieuwe preset; \cr
#' - \code{preset.read} voor het uitlezen van een preset; \cr
#' - \code{preset.thisfolder.list} voor het weergeven van alle presets in de huidige map(pen); \cr
#' - \code{preset.thisfolder} voor het weergeven van de eerst gevonden preset in de huidge map; \cr
#' - \code{preset.exists} voor toetsen of een preset bestaat.
#' @aliases preset
#' @name preset
#' @rdname preset
#' @export
preset.list <- function(fullname = FALSE, recursive = FALSE) {
lst <- list.files(path = Sys.getenv("R_REFMAP"),
pattern = "^(preset_).*(.sql)$",
ignore.case = FALSE,
recursive = recursive)
if (fullname == TRUE) {
lst
} else {
gsub("^(preset_)(.*)(.sql)$", "\\2", lst)
}
}
#' @rdname preset
#' @export
preset.thisfolder.list <- function(fullname = FALSE, recursive = TRUE) {
lst <- list.files(path = getwd(),
pattern = "^(preset_).*(.sql)$",
ignore.case = FALSE,
recursive = recursive)
if (fullname == TRUE) {
lst
} else {
gsub("^(preset_)(.*)(.sql)$", "\\2", lst)
}
}
#' @rdname preset
#' @export
preset.exists <- function(name, returnlocation = FALSE) {
found <- all(paste0('preset_', name, '.sql') %in% preset.list(TRUE))
if (returnlocation == TRUE) {
.R_REFMAP(paste0('preset_', name, '.sql'))
} else {
found
}
}
#' @rdname preset
#' @export
preset.read <- function(name) {
lst <- list(0)
for (i in 1:length(name)) {
if (!name[i] %like% '.*[/\\].*') {
# controleer Sys.getenv("R_REFMAP")
if (!preset.exists(name[i])) {
stop('Preset `', name[i], '` not found, file does not exist: ',
preset.exists(name[i], returnlocation = TRUE), '.',
call. = FALSE)
}
lst[[i]] <- read.table(file = .R_REFMAP(paste0('preset_', name[i], '.sql')),
sep = "\n",
header = FALSE,
stringsAsFactors = FALSE)[,1]
} else {
# dan is het een volledige bestandsnaam
if (file.exists(name[i])) {
lst[[i]] <- read.table(file = name[i],
sep = "\n",
header = FALSE,
stringsAsFactors = FALSE)[,1]
} else if (file.exists(paste0(getwd(), '/', name[i]))) {
lst[[i]] <- read.table(file = paste0(getwd(), '/', name[i]),
sep = "\n",
header = FALSE,
stringsAsFactors = FALSE)[,1]
} else {
stop('File `', name[i], '` not found.', call. = FALSE)
}
}
}
lst %>% unlist() %>% unique() %>% gsub(",$", "", .)
}
#' @rdname preset
#' @export
preset.add <- function(name, vector) {
if (length(name) > 1) {
stop('`name` must be of length 1.', call. = FALSE)
}
if (preset.exists(name)) {
if (!readline("This preset already exists. Would you like to overwrite it? [Y/n] ") %in% c("", "Y", "y", "J", "j")) {
return(invisible())
}
}
vector <- select_translate_asterisk(vector)
vector <- unique(vector)
write(x = concat(vector, sep = "\n"),
file = .R_REFMAP(paste0('preset_', name, '.sql')),
append = FALSE,
ncolumns = 1)
if (preset.exists(name)) {
cat("Preset `", name, "` succesfully saved.\n", sep = "")
}
}
#' @rdname preset
#' @export
preset.thisfolder <- function(recursive = TRUE) {
f <- list.files(path = getwd(),
pattern = "^(preset_).*(.sql)$",
ignore.case = TRUE,
recursive = recursive)
if (length(f) == 0) {
stop("This folder does not contain a preset. File names of presets must start with 'preset'.", call. = FALSE)
} else if (length(f) > 1) {
cat(paste0("Selecting first preset found: ", f[1], ".\n"))
} else {
cat(paste0("Selecting preset: ", f, ".\n"))
}
paste0(getwd(), "/", f[1])
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.