R/epidemiology.R
In msberends/certedata: Tools for Data Analysis at Certe
Defines functions
rsi_table
antibiotics_list
antibiotics_excel
tbl_first_isolates
age.group
abname_molis
mo_certe
gps_from_address
tbl_address
maps_api_key
get_map
add_map
normalise
Documented in
abname_molis
add_map
age.group
antibiotics_excel
antibiotics_list
get_map
gps_from_address
maps_api_key
mo_certe
normalise
rsi_table
tbl_address
tbl_first_isolates
# ==================================================================== #
# 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. #
# ==================================================================== #
#' Gevoeligheidstabel maken tussen ziekenhuizen
#'
#' Maakt een tabel van een gevoeligheidsvergelijking tussen ziekenhuizen. Voert een G-test uit bij >1000 observaties of een Exact-test bij minder.
#' @param ab_list Lijst met antibiotica. Zie \code{\link[AMR]{antibiotics}}.
#' @param hospitalname Naam van het ziekenhuis dat met andere ziekenhuizen vergeleken wordt.
#' @param df_all \code{data.frame} met alle gegevens.
#' @param df_thishospital \code{data.frame} met alle gegevens van het te onderzoeken ziekenhuis.
#' @param df_otherhospitals \code{data.frame} met alle gegevens van de overige ziekenhuizen.
#' @seealso \code{\link{g.test}} die uitgevoerd bij > 1000 observaties; \code{\link{exact.test}} die uitgevoerd bij <= 1000 observaties.
#' @export
#' @examples
#' \dontrun{
#' rsi_table(ab_list, 'MZ', df)
#'
#' septic_patients %>%
#' mutate(zkhgroep = hospital_id) %>%
#' rsi_table(ab_list = c("amox", "amcl"),
#' hospitalname = "A",
#' df_all = .)
#' }
rsi_table <- function(ab_list, hospitalname, df_all, df_thishospital = NULL, df_otherhospitals = NULL) {
tbl.rsi <- tibble(antibioticum = character(0),
rsi.dit = double(0),
rsi.rest = double(0),
p = double(0),
psym = character(0),
size = double(0),
meth = character(0))
if (is.null(df_thishospital)) {
if (!"zkhgroep" %in% colnames(df_all)) {
stop("Variable 'zkhgroep' is missing from `df_all`.", call. = FALSE)
}
df_thishospital <- df_all %>% filter(zkhgroep == hospitalname)
}
if (is.null(df_otherhospitals)) {
if (!"zkhgroep" %in% colnames(df_all)) {
stop("Variable 'zkhgroep' is missing from `df_all`.", call. = FALSE)
}
if (!"zkhgroep_code" %in% colnames(df_all)) {
warning("Variable 'zkhgroep_code' is missing from `df_all`. Are these all isolates from hospitals?")
df_all <- df_all %>% mutate(zkhgroep_code = 1)
}
df_otherhospitals <- df_all %>% filter(zkhgroep != hospitalname, zkhgroep_code != 0)
}
for (i in 1:length(ab_list)) {
ab <- ab_list[i]
abnaam <- ab %>% abname_molis()
susceptibility_hospitalname <- AMR::portion_S(df_thishospital %>% pull(ab))
susceptibility_rest <- AMR::portion_S(df_otherhospitals %>% pull(ab))
cont.tbl <- crosstab(data = df_all,
column1 = ab,
condition1 = 'S',
column2 = 'zkhgroep',
condition2 = hospitalname)
# bron voor de 1000: http://www.biostathandbook.com/gtestind.html
if (sum(cont.tbl) >= 1000) {
susceptibility_pwaarde <- g.test(cont.tbl)$p.value
method <- 'Onafh. G-toets'
} else {
susceptibility_pwaarde <- fisher.test(cont.tbl)$p.value
method <- "Fisher's Exact-toets"
}
tbl.rsi <- tbl.rsi %>%
tibble::add_row(antibioticum = abnaam,
rsi.dit = susceptibility_hospitalname,
rsi.rest = susceptibility_rest,
p = susceptibility_pwaarde,
psym = p.symbol(susceptibility_pwaarde),
size = sum(cont.tbl),
meth = method)
}
colnames(tbl.rsi) <- c('Antibioticum', hospitalname, 'Rest', 'p-waarde',
'Significantie', 'Grootte', 'Methode')
tbl.rsi
}
#' Antibioticalijst per klinisch specialisme of materiaal
#'
#' Retourneert een lijst met antibiotics die relevant zijn voor het gekozen specialism.
#' @param specialism Naam van de specialist, zoals \code{"Longarts"}, \code{"Internist"} of \code{"Uroloog"}.
#' @param specimen Naam van materiaal, zoals \code{"Bloed"}, \code{"Urine"} of \code{"Respiratoir"}.
#' @param search_term Tekst om naar te zoeken, die voorkomt in regel 1 van \code{file}.
#' @param file Excel-bestand met antibiotica-afkortingen per kolom.
#' @details De functie \code{antibiotics_excel} haalt de lijst met waarden op uit een Excel-bestand.
#' @keywords antibiotics
#' @return Tekst
#' @export
#' @rdname antibiotics_list
antibiotics_list <- function(specialism = NA, specimen = NA) {
if (is.na(specialism) & is.na(specimen)) {
stop('No specialism or specimen defined.')
}
specimen <- specimen %>% tolower()
specialism <- specialism %>% tolower()
if (!is.na(specimen)) {
if (specimen == 'urine') {
return(c('amcl', 'amox', 'cfur', 'cipr', 'fosf', 'gent', 'mero', 'nitr', 'pita', 'tobr', 'trim', 'trsu'))
} else if (specimen == 'bloed') {
return(c('amcl+tobr', 'amcl+gent', 'cfur+tobr', 'cfur+gent', 'pita+tobr', 'pita+gent', 'cfot', 'amcl', 'amcl+cipr', 'pita', 'cfur', 'mero'))
} else {
return(FALSE)
}
}
if (specialism == 'longarts') {
return(c('amcl', 'amox', 'cfta', 'cftr', 'cfur', 'cipr', 'clin', 'doxy', 'gent', 'mero', 'peni', 'pita', 'tobr', 'trsu'))
} else if (specialism == 'internist' | specialism == 'kinderarts' | specialism == 'geriater') {
return(c('amcl', 'amox', 'cfta', 'cftr', 'cfur', 'cipr', 'clin', 'doxy', 'gent', 'mero', 'peni', 'pita', 'tobr', 'trsu'))
} else if (specialism == 'intensivist') {
return(c('amcl', 'amox', 'cfta', 'cftr', 'cfur', 'cipr', 'clin', 'doxy', 'gent', 'mero', 'peni', 'pita', 'tobr', 'trsu'))
} else if (specialism == 'uroloog') {
return(c('amcl', 'amox', 'cfur', 'cipr', 'fosf', 'gent', 'mero', 'nitr', 'pita', 'tobr', 'trim', 'trsu'))
} else if (specialism %in% c('orthopaed', 'orthopeed')) {
return(c('moxi', 'rifa', 'mino', 'amcl', 'amox', 'cfur', 'cipr', 'fosf', 'gent', 'mero', 'nitr', 'pita', 'tobr', 'trim', 'trsu'))
} else if (specialism == 'gynaecoloog') {
return(c('amcl', 'amox', 'pita', 'peni', 'cfur', 'cftr', 'cipr', 'cfot', 'clin', 'mero', 'eryt'))
} else {
stop('No valid specialism.')
}
FALSE
}
#' @export
#' @rdname antibiotics_list
antibiotics_excel <- function(search_term, file = .R_REFMAP("ab_per_specialist.xlsx")) {
readxl::read_excel(file) %>% rename_all(tolower) %>% pull(tolower(search_term))
}
#' Bepaling eerste isolaten
#'
#' Hiermee worden direct alle eerste isolaten toegevoegd aan een tabel, zie \code{\link[AMR]{first_isolate}}.
#' @param x Een \code{data.frame} met isolaten.
#' @param col_mo Standaard is \code{"bacteriecode"}. De kolomnaam van de bacteriecodes voor het bepalen van sleutelantibiotica.
#' @param col_date Standaard is \code{"ontvangstdatum"}. De kolomnaam van de datum van ontvangst of uitslag.
#' @param col_patient_id Standaard is \code{"patid"}, of (als deze niet voorkomt) \code{"patidnb"}. De kolomnaam van de unieke ID's van de patient.
#' @param col_testcode Standaard is \code{"testcode"}. De kolomnaam van de testcode van de order. Gebruik \code{col_testcode = NULL} om de testcodes niet als exclusiecriterium te gebruiken. In dit geval wordt \code{testcodes_exclude} genegeerd.
#' @param col_specimen Standaard is \code{"mtrlgroep"}. De kolomnaam van de materiaalgroep van de order.
#' @param col_icu Standaard is \code{"is_ic"}. De kolomnaam van de logical of een afdeling/aanvrager bij de Intensive Care hoort.
#' @param episode_days Standaard is \code{365}. De episode in dagen waarna een isolaat opnieuw een 'eerste isolaat' genoemd moet worden.
#' @param testcodes_exclude Standaard is leeg. De lijst met testcodes waarvan de isolaten genegeerd moeten worden (hoofdletterONgevoelig). Gebruik voor het uitsluiten van screeningskweken \code{testcodes_exclude = c("KARE", "KBRMO", "KESBL", "KMNS", "KMR", "KMRP", "KVRE", "KWA22", "KWA35", "KWA37", "KWE", "KWKS", "KWKSD", "KWL", "KWS", "RESDEP")}.
#' @param icu_exclude Standaard is \code{FALSE}. Negeert alle isolaten waarbij \code{col_icu == TRUE}.
#' @param info Standaard is \code{TRUE}. Printen van voortgang.
#' @param timestamp Standaard is \code{FALSE}. Printen van timestamp.
#' @keywords isolaat isolaten eerste
#' @export
#' @return tabel
#' @examples
#' \dontrun{
#'
#' # snel alles toevoegen:
#' x <- tbl_first_isolates(x)
#'
#' # controleren dat het werkt:
#' examples_isolates %>%
#' tbl_first_isolates(col_date = "date",
#' col_patient_id = "patient_id",
#' col_mo = "bactid",
#' col_icu = NULL,
#' col_specimen = NULL) %>%
#' pull(eerste_isolaat_gewogen) %>%
#' sum()
#'
#' # of per type (AMR-pakket):
#'
#' x$sleutelab <- key_antibiotics(x)
#'
#' x$eerste_isolaat <-
#' first_isolate(x)
#'
#' x$eerste_isolaat_gewogen <-
#' first_isolate(x,
#' col_keyantibiotics = 'sleutelab')
#'
#' x$eerste_bloedisolaat <-
#' first_isolate(x,
#' specimen_group = 'Bloed')
#'
#' x$eerste_bloedisolaat_gewogen <-
#' first_isolate(x,
#' specimen_group = 'Bloed',
#' col_keyantibiotics = 'sleutelab')
#'
#' # enz.
#' }
tbl_first_isolates <- function(x,
col_mo = 'bacteriecode',
col_date = 'ontvangstdatum',
col_patient_id = sort(colnames(x))[sort(colnames(x)) %in% c("patid", "patidnb")][1],
col_testcode = NULL,
col_specimen = 'mtrlgroep',
col_icu = 'is_ic',
episode_days = 365,
testcodes_exclude = '',
icu_exclude = FALSE,
ignore_I = TRUE,
info = TRUE,
timestamp = FALSE) {
if (is.null(col_mo)) {
if ("mo" %in% lapply(x, class)) {
col_mo <- colnames(x)[lapply(x, class) == "mo"][1]
}
if (is.null(col_mo)) {
# niet gevonden
warning("No first isolates determined, since there is no reference column for `col_mo`")
return(x)
}
}
if (!col_mo %in% colnames(x)) {
warning("No first isolates determined, since there is no reference column for `col_mo`")
return(x)
}
if (!col_patient_id %in% colnames(x)) {
warning("No first isolates determined, since there is no reference column for `col_patient_id`")
return(x)
}
if (!col_date %in% colnames(x)) {
warning("No first isolates determined, since there is no reference column for `col_date`")
return(x)
}
if (!col_icu %in% colnames(x)) {
col_icu <- NULL
}
certedb_timestamp('Determining first isolates...', print = info, timestamp = timestamp, appendLF = FALSE)
x$eerste_isolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = NULL,
info = FALSE)
if (col_specimen %in% colnames(x)) {
x$eerste_bloedisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Bloed',
info = FALSE)
x$eerste_urineisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Urine',
info = FALSE)
x$eerste_pusisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Pus',
info = FALSE)
x$eerste_respisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Respiratoir',
info = FALSE)
x$eerste_fecesisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Feces',
info = FALSE)
}
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
certedb_timestamp('Determining first weighted isolates...', print = info, timestamp = timestamp, appendLF = FALSE)
x$sleutelab <- AMR::key_antibiotics(x,
col_mo = col_mo,
universal_1 = ifelse("amox" %in% colnames(x), "amox", NULL),
universal_2 = ifelse("amcl" %in% colnames(x), "amcl", NULL),
universal_3 = ifelse("cfur" %in% colnames(x), "cfur", NULL),
universal_4 = ifelse("pita" %in% colnames(x), "pita", NULL),
universal_5 = ifelse("cipr" %in% colnames(x), "cipr", NULL),
universal_6 = ifelse("trsu" %in% colnames(x), "trsu", NULL),
GramPos_1 = ifelse("vanc" %in% colnames(x), "vanc", NULL),
GramPos_2 = ifelse("teic" %in% colnames(x), "teic", NULL),
GramPos_3 = ifelse("tetr" %in% colnames(x), "tetr", NULL),
GramPos_4 = ifelse("eryt" %in% colnames(x), "eryt", NULL),
GramPos_5 = ifelse("oxac" %in% colnames(x), "oxac", NULL),
GramPos_6 = ifelse("rifa" %in% colnames(x), "rifa", NULL),
GramNeg_1 = ifelse("gent" %in% colnames(x), "gent", NULL),
GramNeg_2 = ifelse("tobr" %in% colnames(x), "tobr", NULL),
GramNeg_3 = ifelse("coli" %in% colnames(x), "coli", NULL),
GramNeg_4 = ifelse("cfot" %in% colnames(x), "cfot", NULL),
GramNeg_5 = ifelse("cfta" %in% colnames(x), "cfta", NULL),
GramNeg_6 = ifelse("mero" %in% colnames(x), "mero", NULL),
warnings = FALSE)
x$eerste_isolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = NULL,
col_keyantibiotics = 'sleutelab',
info = FALSE)
if (col_specimen %in% colnames(x)) {
x$eerste_bloedisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Bloed',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_urineisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Urine',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_pusisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Pus',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_respisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Respiratoir',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_fecesisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Feces',
col_keyantibiotics = 'sleutelab',
info = FALSE)
}
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
x
}
#' Leeftijdsgroep bepalen
#'
#' Hiermee wordt op basis van de leeftijd een groep bepaald; 0-17, 18-64, 65-84 en 85+. Met \code{split.children = TRUE} worden kinderen bovendien gesplitst in 00, 01, 02-03, 04-05, 06-12 en 13-17.
#' @param age Een getal tussen 0 en 120.
#' @param split.children Standaard is \code{FALSE}. Kinderen splitsen in 0, 1, 2-3, 4-5, 6-12 en 13-17.
#' @param split.every10 Standaard is \code{FALSE}. Splitst de leeftijd per 10 jaar: 0-9, 10-19, enz. Hiermee wordt \code{split.children} genegeerd.
#' @keywords age
#' @export
#' @return Factor
age.group <- function(age, split.children = FALSE, split.every10 = FALSE) {
if (split.every10 == TRUE) {
AMR::age_groups(age, "tens")
} else if (split.children == TRUE) {
AMR::age_groups(age, c(1, 2, 4, 6, 13, 18, 65, 85))
} else {
AMR::age_groups(age)
}
}
#' Naam van antibioticum
#'
#' Hiermee kan een MOLIS-code omgezet worden naar een (triviale) antibioticumnaam of ATC-code, of andersom.
#' @param abcode Een antibioticumcode of -naam, zoals \code{"amox"}, \code{"cftr"} of \code{"J01CA04"}.
#' @param from Standaard is \code{"certe"}. Type om van te transformeren. Geldige opties zijn alle variabelen van \code{\link[AMR]{antibiotics}}.
#' @param to Standaard is \code{"trivial_nl"}. Type om naar te transformeren. Geldige opties zijn alle variabelen van \code{\link[AMR]{antibiotics}}.
#' @param textbetween Standaard is \code{" + "}. De tekst die tussen twee of meer middelen komt te staan.
#' @param tolower Standaard is \code{FALSE}. Uitkomst als kleine letters weergeven met de functie \code{\link{tolower}}.
#' @keywords ab antibiotics
#' @export
#' @examples
#' abname_molis("amcl")
#' # "Amoxicilline/clavulaanzuur"
#'
#' abname_molis("amcl+gent")
#' # "Amoxicilline/clavulaanzuur + gentamicine"
#'
#' abname_molis(c("amox", "amcl"))
#' # "Amoxicilline" "Amoxicilline/clavulaanzuur"
#' @source \code{\link[AMR]{antibiotics}}
abname_molis <- function(abcode, textbetween = " + ", tolower = FALSE, ...) {
codes <- suppressWarnings(AMR::ab_name(abcode, language = "nl", tolower = tolower))
if (sum(abcode %like% "[+]") > 0) {
for (i in 1:length(abcode)) {
if (abcode[i] %like% "[+]") {
codes[i] <- paste0(AMR::ab_name(strsplit.select(abcode[i], 1, "[+]"),
language = "nl",
tolower = tolower),
textbetween,
AMR::ab_name(strsplit.select(abcode[i], 2, "[+]"),
language = "nl",
tolower = TRUE))
}
}
}
codes
}
#' Certe bacteriecode
#'
#' Input wordt geevalueerd met \code{\link[AMR]{as.mo}} en dit wordt vergeleken met de data set \code{certedata:::bacteriecode} om een Certe bacteriecode op te halen.
#' @param x,... Zie \code{\link[AMR]{mo_property}}.
#' @details Reference gemaakt met:
#' \preformatted{
#' bacterien <- certedb_query("select * from temporary_certemm_bacterienlijst")
#'
#' bacterien <- bacterien %>%
#' transmute(bacteriecode,
#' bacteriecode_oud,
#' systeemcode,
#' fullname = gsub(" species$", "", volledigenaam) %>%
#' gsub("[)(]", "", .)) %>%
#' filter(nchar(bacteriecode) > 3, !grepl("^_", bacteriecode)) %>%
#' arrange(bacteriecode)
#'
#' usethis::use_data(bacterien, internal = TRUE)
#' }
#' @export
mo_certe <- function(x, ...) {
if (all(x %in% AMR::microorganisms.codes$code)) {
return(x)
} else {
data.frame(fullname = AMR::mo_fullname(x, ...),
stringsAsFactors = FALSE) %>%
left_join(bacterien, # is interne data in dit pakket
by = "fullname") %>%
pull(bacteriecode)
}
}
#' Adresgegevens ophalen van Google Maps
#'
#' Hiermee worden adreseigenschappen opgehaald m.b.v. \href{https://developers.google.com/maps/documentation/geocoding/start}{de Google Maps Geocoding API}. Het limiet is ca. 15.000 requests per dag en ca. 300 requests per seconde.
#' @param address Een of meerdere adressen om naar te zoeken. Mag alles zijn dat Google Maps begrijpt (zelfs \code{"Certe"}, dit wordt vertaald naar Damsterdiep 191, Groningen).
#' @param type Standaard is \code{NULL} voor alle eigenschappen. Geldige opties zijn: \code{"lat"}, \code{"lng"}, \code{"straat"}, \code{"nummer"}, \code{"postcode"}, \code{"plaats"}, \code{"gemeente"}, \code{"provincie"}, \code{"land"}, \code{"landcode"} of \code{NA} voor alle eigenschappen.
#' @param country Standaard is \code{"Nederland"}. Deze tekst wordt toegevoegd aan \code{address}.
#' @keywords address
#' @source \code{\link{maps_api_key}}
#' @export
#' @return Lijst of tekst
gps_from_address <- function(address, type = NULL, country = 'Nederland') {
if (country != '') {
address <- paste(address, country, sep = ', ')
}
address.bak <- address
lijst <- vector('list', length(address))
# progress bar maken
if (length(address) > 5) {
voortgang <- txtProgressBar(min = 0, max = length(address), style = 3)
}
for (n in 1:length(address)) {
if (length(address) > 5) {
setTxtProgressBar(voortgang, n)
#Sys.sleep(0.1)
}
lat <- 0.0
lng <- 0.0
straat <- ''
nummer <- ''
postcode <- ''
plaats <- ''
gemeente <- ''
provincie <- ''
land <- ''
landcode <- ''
url <-
paste0(
'https://maps.googleapis.com/maps/api/geocode/json?&address=',
URLencode(address[n]),
# Nederlandse landnamen:
'&language=nl&key=',
maps_api_key()
)
json <- readLines(url)
json <- gsub('\"', '', json, fixed = TRUE)
# alle meerdere spaties verwijderen
json <- gsub("(?<=[\\s])\\s*|^\\s+|\\s+$", "", json, perl = TRUE)
json <- strsplit(json, ' : ', fixed = TRUE)
for (i in 1:length(json)) {
rij <- unlist(json[i][1])
# eerste lat en lng zijn de werkelijke locatie, niet de bounds of viewport
if (rij[1] == 'location') {
rij.plus1 <- unlist(json[i + 1])
rij.plus2 <- unlist(json[i + 2])
if (rij.plus1[1] == 'lat') {
lat <- rij.plus1[2]
}
if (rij.plus2[1] == 'lng') {
lng <- rij.plus2[2]
}
lat <- gsub(',', '', lat, fixed = TRUE)
lng <- gsub(',', '', lng, fixed = TRUE)
}
if (grepl('country', toString(rij))) {
rij.min1 <- unlist(json[i - 1][1])
rij.min2 <- unlist(json[i - 2][1])
landcode <- gsub(',', '', rij.min1[2], fixed = TRUE)
land <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('administrative_area_level_1', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
provincie <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('administrative_area_level_2', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
gemeente <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('postal_code', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
postcode <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('locality', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
plaats <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('route', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
straat <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('street_number', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
nummer <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (rij[1] == 'location_type') {
if (grepl('APPROXIMATE', rij[2]) &
# bij postcodes geen melding, die zijn logischerwijs geschat
!grepl('^[0-9]{4} ?[a-zA-Z]{2}', address.bak[n])) {
message('approximate result: ', address.bak[n])
}
}
}
if (!is.null(type)) {
if (type == 'lat') {
lijst[n] <- as.double(lat)
}
if (type == 'lng') {
lijst[n] <- as.double(lng)
}
if (type == 'straat') {
lijst[n] <- straat
}
if (type == 'nummer') {
lijst[n] <- nummer
}
if (type == 'postcode') {
lijst[n] <- postcode
}
if (type == 'plaats') {
lijst[n] <- plaats
}
if (type == 'gemeente') {
lijst[n] <- gemeente
}
if (type == 'provincie') {
lijst[n] <- provincie
}
if (type == 'land') {
lijst[n] <- land
}
if (type == 'landcode') {
lijst[n] <- landcode
}
} else if (is.null(type) | type == 'alle') {
lijst[n] <- list(c('lat' = as.double(lat),
'lng' = as.double(lng),
'straat' = straat,
'nummer' = nummer,
'postcode' = postcode,
'plaats' = plaats,
'gemeente' = gemeente,
'provincie' = provincie,
'land' = land,
'landcode' = landcode))
}
}
if (length(address) > 5) {
close(voortgang)
}
if (is.null(type) | type == 'alle') {
lijst
} else {
unlist(lijst)
}
}
#' Tabel maken van adressen
#'
#' Hiermee worden adressen omgezet naar een tbl met het adres, de lengte- en de breedtegraad.
#' @param address Een of meerdere adressen om naar te zoeken. Mag alles zijn dat Google Maps begrijpt (zelfs \code{"Certe"}, dit wordt vertaald naar Van Swietenlaan 2, Groningen).
#' @keywords address
#' @export
#' @return Tabel
tbl_address <- function(address) {
df <- tibble(address = address)
addresslist <- gps_from_address(df$address)
address.nieuw <- character(length(addresslist))
lat <- double(length(addresslist))
lng <- double(length(addresslist))
for (i in 1:length(addresslist)) {
address.nieuw[i] <- paste0(as.list(unlist(addresslist[i]))$straat,
' ',
as.list(unlist(addresslist[i]))$nummer,
', ',
as.list(unlist(addresslist[i]))$plaats)
lat[i] <- as.list(unlist(addresslist[i]))$lat
lng[i] <- as.list(unlist(addresslist[i]))$lng
}
df$address.zoek <- address
df$address <- address.nieuw
df$lat <- as.double(lat)
df$lng <- as.double(lng)
df
}
#' Willekeurige Google Maps Geocoding API-sleutel
#'
#' Deze API-sleutels worden gebruikt voor het ophalen van \code{\link{gps_from_address}}. Er zijn 6 sleutels aangemaakt met elk een limiet van 2.500 requests per dag en 50 requests per seconde. De sleutel wordt iedere keer willekeurig geselecteerd met \code{\link[base]{sample}}.
#' @keywords api API Google adres
#' @seealso \code{\link{gps_from_address}} \code{\link{tbl_address}} \code{\link{plot2.map_old}}
#' @export
#' @return Tekst
maps_api_key <- function() {
stop("Google Maps ondersteunt geen gratis Geolocation API's meer.")
}
#' GIS-data ophalen
#'
#' Hiermee kan Nederlandse GIS-data opgehaald worden voor ruimtelijke analyse (\emph{spatial analysis}) met \code{\link{plot2.map}}.
#' @param maptype Standaard is \code{"pc3"}. Geldige waarden zijn \code{"provincies"}, \code{"gemeenten"}, \code{"postcodes"}, \code{"pc4"}, \code{"pc3"}, \code{"pc2"}.
#' @param only_adherence Standaard is \code{TRUE}. Data filteren op alleen het adherentiegebied van Certe. Hiermee worden postcodes gefilterd op >7300, of provincies gefilterd op Friesland, Groningen, Drenthe.
#' @param data Gegevens (zoals isolaten) waar GIS-data aan gekoppeld moet worden.
#' @param by Kolommen die voor de join gebruikt worden, zie \code{\link{left_join}}.
#' @details De kolom met geogegevens heeft de volgende naam:
#' \itemize{
#' \item{Bij provincies \code{provincies} (oorspronkelijk \code{provincien})}
#' \item{Bij gemeenten: \code{gemeenten} (oorspronkelijk \code{gemeentena})}
#' \item{Bij postcodes \code{postcode} (oorspronkelijk \code{pc4})}
#' }
#' Deze worden gebruikt bij een join, zoals met \code{add_map}.
#' @rdname get_map
#' @export
#' @examples
#' \dontrun{
#'
#' # Werkend voorbeeld:
#' urines <- certedb_getmmb(2015,
#' 2018,
#' zipcodes = TRUE,
#' ziplength = 3,
#' first_isolates = TRUE)
#' urines %>%
#' filter(eerste_urineisolaat_gewogen == TRUE,
#' bacteriecode %like% "ESCCOL") %>%
#' group_by(postcode) %>%
#' summarise(amox = portion_R(amox)) %>%
#' add_map(maptype = "pc3") %>%
#' plot2.map(y = amox,
#' title = "Amoxicilline-resistentie bij *E. coli*",
#' subtitle = "Eerste urinekweekisolaten in 2018")
#' }
get_map <- function(maptype = "pc3",
only_adherence = TRUE) {
maptype.bak <- maptype
if (maptype %in% paste0("pc", 2:4)) {
maptype <- 'postcodes'
}
if (!maptype %in% c('provincies', 'gemeenten', 'postcodes')) {
stop("Invalid `maptype` for spatial data.", call. = FALSE)
}
shp_file <- paste0(Sys.getenv("R_REFMAP"), "GIS/", maptype, ".shp")
if (!file.exists(shp_file)) {
stop('file not found: ', shp_file, call. = FALSE)
}
library(sf)
data <- st_read(dsn = shp_file,
stringsAsFactors = FALSE,
quiet = TRUE)
if (only_adherence == TRUE) {
if (maptype == "postcodes") {
data <- data %>% filter(pc4 > 7300)
} else if (maptype == "provincies") {
data <- data %>% filter(provincien %in% c("Friesland", "Groningen", "Drenthe", "Overijssel"))
} else {
warning("Data cannot be filtered for maptype: ", maptype, call. = FALSE)
}
}
if (maptype.bak %in% paste0("pc", 2:4)) {
pc_count <- maptype.bak %>% strsplit.select(3, "") %>% as.integer()
data <- data %>% mutate(pc4 = pc4 %>% substr(1, pc_count))
}
# kolom hernoemen
if (maptype == "postcodes") {
data <- data %>% rename(postcode = pc4)
} else if (maptype == "provincies") {
data <- data %>% rename(provincies = provincien)
} else if (maptype == "gemeenten") {
data <- data %>% rename(gemeenten = gemeentena)
}
data
}
#' @rdname get_map
#' @export
add_map <- function(data, maptype = "pc3", by = NULL) {
suppressMessages(left_join(get_map(maptype), data, by = by))
}
#' Normaliseren van aantallen
#'
#' Normaliseert aantallen op basis van referntiewaarden.
#' @param n aantal, zoals aantal verrichte testen
#' @param n_ref referentie-aantal, zoals aantal opnames of verpleegdagen
#' @param per normalisatiefactor
#' @export
#' @examples
#' testen <- c(zkh1 = 4524,
#' zkh2 = 2864,
#' zkh3 = 5875)
#' opnames <- c(zkh1 = 345923,
#' zkh2 = 204178,
#' zkh3 = 560363)
#'
#' # aantal testen per 100.000 opnames:
#' normalise(testen, opnames, 100000)
normalise <- function(n, n_ref, per = 1000) {
(n / n_ref) * per
# gelijk aan: n / (n_ref / per)
# gelijk aan: (per / n_ref) * n
}
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 rsi_table antibiotics_list antibiotics_excel tbl_first_isolates age.group abname_molis mo_certe gps_from_address tbl_address maps_api_key get_map add_map normalise
Documented in abname_molis add_map age.group antibiotics_excel antibiotics_list get_map gps_from_address maps_api_key mo_certe normalise rsi_table tbl_address tbl_first_isolates
# ==================================================================== #
# 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. #
# ==================================================================== #
#' Gevoeligheidstabel maken tussen ziekenhuizen
#'
#' Maakt een tabel van een gevoeligheidsvergelijking tussen ziekenhuizen. Voert een G-test uit bij >1000 observaties of een Exact-test bij minder.
#' @param ab_list Lijst met antibiotica. Zie \code{\link[AMR]{antibiotics}}.
#' @param hospitalname Naam van het ziekenhuis dat met andere ziekenhuizen vergeleken wordt.
#' @param df_all \code{data.frame} met alle gegevens.
#' @param df_thishospital \code{data.frame} met alle gegevens van het te onderzoeken ziekenhuis.
#' @param df_otherhospitals \code{data.frame} met alle gegevens van de overige ziekenhuizen.
#' @seealso \code{\link{g.test}} die uitgevoerd bij > 1000 observaties; \code{\link{exact.test}} die uitgevoerd bij <= 1000 observaties.
#' @export
#' @examples
#' \dontrun{
#' rsi_table(ab_list, 'MZ', df)
#'
#' septic_patients %>%
#' mutate(zkhgroep = hospital_id) %>%
#' rsi_table(ab_list = c("amox", "amcl"),
#' hospitalname = "A",
#' df_all = .)
#' }
rsi_table <- function(ab_list, hospitalname, df_all, df_thishospital = NULL, df_otherhospitals = NULL) {
tbl.rsi <- tibble(antibioticum = character(0),
rsi.dit = double(0),
rsi.rest = double(0),
p = double(0),
psym = character(0),
size = double(0),
meth = character(0))
if (is.null(df_thishospital)) {
if (!"zkhgroep" %in% colnames(df_all)) {
stop("Variable 'zkhgroep' is missing from `df_all`.", call. = FALSE)
}
df_thishospital <- df_all %>% filter(zkhgroep == hospitalname)
}
if (is.null(df_otherhospitals)) {
if (!"zkhgroep" %in% colnames(df_all)) {
stop("Variable 'zkhgroep' is missing from `df_all`.", call. = FALSE)
}
if (!"zkhgroep_code" %in% colnames(df_all)) {
warning("Variable 'zkhgroep_code' is missing from `df_all`. Are these all isolates from hospitals?")
df_all <- df_all %>% mutate(zkhgroep_code = 1)
}
df_otherhospitals <- df_all %>% filter(zkhgroep != hospitalname, zkhgroep_code != 0)
}
for (i in 1:length(ab_list)) {
ab <- ab_list[i]
abnaam <- ab %>% abname_molis()
susceptibility_hospitalname <- AMR::portion_S(df_thishospital %>% pull(ab))
susceptibility_rest <- AMR::portion_S(df_otherhospitals %>% pull(ab))
cont.tbl <- crosstab(data = df_all,
column1 = ab,
condition1 = 'S',
column2 = 'zkhgroep',
condition2 = hospitalname)
# bron voor de 1000: http://www.biostathandbook.com/gtestind.html
if (sum(cont.tbl) >= 1000) {
susceptibility_pwaarde <- g.test(cont.tbl)$p.value
method <- 'Onafh. G-toets'
} else {
susceptibility_pwaarde <- fisher.test(cont.tbl)$p.value
method <- "Fisher's Exact-toets"
}
tbl.rsi <- tbl.rsi %>%
tibble::add_row(antibioticum = abnaam,
rsi.dit = susceptibility_hospitalname,
rsi.rest = susceptibility_rest,
p = susceptibility_pwaarde,
psym = p.symbol(susceptibility_pwaarde),
size = sum(cont.tbl),
meth = method)
}
colnames(tbl.rsi) <- c('Antibioticum', hospitalname, 'Rest', 'p-waarde',
'Significantie', 'Grootte', 'Methode')
tbl.rsi
}
#' Antibioticalijst per klinisch specialisme of materiaal
#'
#' Retourneert een lijst met antibiotics die relevant zijn voor het gekozen specialism.
#' @param specialism Naam van de specialist, zoals \code{"Longarts"}, \code{"Internist"} of \code{"Uroloog"}.
#' @param specimen Naam van materiaal, zoals \code{"Bloed"}, \code{"Urine"} of \code{"Respiratoir"}.
#' @param search_term Tekst om naar te zoeken, die voorkomt in regel 1 van \code{file}.
#' @param file Excel-bestand met antibiotica-afkortingen per kolom.
#' @details De functie \code{antibiotics_excel} haalt de lijst met waarden op uit een Excel-bestand.
#' @keywords antibiotics
#' @return Tekst
#' @export
#' @rdname antibiotics_list
antibiotics_list <- function(specialism = NA, specimen = NA) {
if (is.na(specialism) & is.na(specimen)) {
stop('No specialism or specimen defined.')
}
specimen <- specimen %>% tolower()
specialism <- specialism %>% tolower()
if (!is.na(specimen)) {
if (specimen == 'urine') {
return(c('amcl', 'amox', 'cfur', 'cipr', 'fosf', 'gent', 'mero', 'nitr', 'pita', 'tobr', 'trim', 'trsu'))
} else if (specimen == 'bloed') {
return(c('amcl+tobr', 'amcl+gent', 'cfur+tobr', 'cfur+gent', 'pita+tobr', 'pita+gent', 'cfot', 'amcl', 'amcl+cipr', 'pita', 'cfur', 'mero'))
} else {
return(FALSE)
}
}
if (specialism == 'longarts') {
return(c('amcl', 'amox', 'cfta', 'cftr', 'cfur', 'cipr', 'clin', 'doxy', 'gent', 'mero', 'peni', 'pita', 'tobr', 'trsu'))
} else if (specialism == 'internist' | specialism == 'kinderarts' | specialism == 'geriater') {
return(c('amcl', 'amox', 'cfta', 'cftr', 'cfur', 'cipr', 'clin', 'doxy', 'gent', 'mero', 'peni', 'pita', 'tobr', 'trsu'))
} else if (specialism == 'intensivist') {
return(c('amcl', 'amox', 'cfta', 'cftr', 'cfur', 'cipr', 'clin', 'doxy', 'gent', 'mero', 'peni', 'pita', 'tobr', 'trsu'))
} else if (specialism == 'uroloog') {
return(c('amcl', 'amox', 'cfur', 'cipr', 'fosf', 'gent', 'mero', 'nitr', 'pita', 'tobr', 'trim', 'trsu'))
} else if (specialism %in% c('orthopaed', 'orthopeed')) {
return(c('moxi', 'rifa', 'mino', 'amcl', 'amox', 'cfur', 'cipr', 'fosf', 'gent', 'mero', 'nitr', 'pita', 'tobr', 'trim', 'trsu'))
} else if (specialism == 'gynaecoloog') {
return(c('amcl', 'amox', 'pita', 'peni', 'cfur', 'cftr', 'cipr', 'cfot', 'clin', 'mero', 'eryt'))
} else {
stop('No valid specialism.')
}
FALSE
}
#' @export
#' @rdname antibiotics_list
antibiotics_excel <- function(search_term, file = .R_REFMAP("ab_per_specialist.xlsx")) {
readxl::read_excel(file) %>% rename_all(tolower) %>% pull(tolower(search_term))
}
#' Bepaling eerste isolaten
#'
#' Hiermee worden direct alle eerste isolaten toegevoegd aan een tabel, zie \code{\link[AMR]{first_isolate}}.
#' @param x Een \code{data.frame} met isolaten.
#' @param col_mo Standaard is \code{"bacteriecode"}. De kolomnaam van de bacteriecodes voor het bepalen van sleutelantibiotica.
#' @param col_date Standaard is \code{"ontvangstdatum"}. De kolomnaam van de datum van ontvangst of uitslag.
#' @param col_patient_id Standaard is \code{"patid"}, of (als deze niet voorkomt) \code{"patidnb"}. De kolomnaam van de unieke ID's van de patient.
#' @param col_testcode Standaard is \code{"testcode"}. De kolomnaam van de testcode van de order. Gebruik \code{col_testcode = NULL} om de testcodes niet als exclusiecriterium te gebruiken. In dit geval wordt \code{testcodes_exclude} genegeerd.
#' @param col_specimen Standaard is \code{"mtrlgroep"}. De kolomnaam van de materiaalgroep van de order.
#' @param col_icu Standaard is \code{"is_ic"}. De kolomnaam van de logical of een afdeling/aanvrager bij de Intensive Care hoort.
#' @param episode_days Standaard is \code{365}. De episode in dagen waarna een isolaat opnieuw een 'eerste isolaat' genoemd moet worden.
#' @param testcodes_exclude Standaard is leeg. De lijst met testcodes waarvan de isolaten genegeerd moeten worden (hoofdletterONgevoelig). Gebruik voor het uitsluiten van screeningskweken \code{testcodes_exclude = c("KARE", "KBRMO", "KESBL", "KMNS", "KMR", "KMRP", "KVRE", "KWA22", "KWA35", "KWA37", "KWE", "KWKS", "KWKSD", "KWL", "KWS", "RESDEP")}.
#' @param icu_exclude Standaard is \code{FALSE}. Negeert alle isolaten waarbij \code{col_icu == TRUE}.
#' @param info Standaard is \code{TRUE}. Printen van voortgang.
#' @param timestamp Standaard is \code{FALSE}. Printen van timestamp.
#' @keywords isolaat isolaten eerste
#' @export
#' @return tabel
#' @examples
#' \dontrun{
#'
#' # snel alles toevoegen:
#' x <- tbl_first_isolates(x)
#'
#' # controleren dat het werkt:
#' examples_isolates %>%
#' tbl_first_isolates(col_date = "date",
#' col_patient_id = "patient_id",
#' col_mo = "bactid",
#' col_icu = NULL,
#' col_specimen = NULL) %>%
#' pull(eerste_isolaat_gewogen) %>%
#' sum()
#'
#' # of per type (AMR-pakket):
#'
#' x$sleutelab <- key_antibiotics(x)
#'
#' x$eerste_isolaat <-
#' first_isolate(x)
#'
#' x$eerste_isolaat_gewogen <-
#' first_isolate(x,
#' col_keyantibiotics = 'sleutelab')
#'
#' x$eerste_bloedisolaat <-
#' first_isolate(x,
#' specimen_group = 'Bloed')
#'
#' x$eerste_bloedisolaat_gewogen <-
#' first_isolate(x,
#' specimen_group = 'Bloed',
#' col_keyantibiotics = 'sleutelab')
#'
#' # enz.
#' }
tbl_first_isolates <- function(x,
col_mo = 'bacteriecode',
col_date = 'ontvangstdatum',
col_patient_id = sort(colnames(x))[sort(colnames(x)) %in% c("patid", "patidnb")][1],
col_testcode = NULL,
col_specimen = 'mtrlgroep',
col_icu = 'is_ic',
episode_days = 365,
testcodes_exclude = '',
icu_exclude = FALSE,
ignore_I = TRUE,
info = TRUE,
timestamp = FALSE) {
if (is.null(col_mo)) {
if ("mo" %in% lapply(x, class)) {
col_mo <- colnames(x)[lapply(x, class) == "mo"][1]
}
if (is.null(col_mo)) {
# niet gevonden
warning("No first isolates determined, since there is no reference column for `col_mo`")
return(x)
}
}
if (!col_mo %in% colnames(x)) {
warning("No first isolates determined, since there is no reference column for `col_mo`")
return(x)
}
if (!col_patient_id %in% colnames(x)) {
warning("No first isolates determined, since there is no reference column for `col_patient_id`")
return(x)
}
if (!col_date %in% colnames(x)) {
warning("No first isolates determined, since there is no reference column for `col_date`")
return(x)
}
if (!col_icu %in% colnames(x)) {
col_icu <- NULL
}
certedb_timestamp('Determining first isolates...', print = info, timestamp = timestamp, appendLF = FALSE)
x$eerste_isolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = NULL,
info = FALSE)
if (col_specimen %in% colnames(x)) {
x$eerste_bloedisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Bloed',
info = FALSE)
x$eerste_urineisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Urine',
info = FALSE)
x$eerste_pusisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Pus',
info = FALSE)
x$eerste_respisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Respiratoir',
info = FALSE)
x$eerste_fecesisolaat <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
col_keyantibiotics = NULL,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Feces',
info = FALSE)
}
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
certedb_timestamp('Determining first weighted isolates...', print = info, timestamp = timestamp, appendLF = FALSE)
x$sleutelab <- AMR::key_antibiotics(x,
col_mo = col_mo,
universal_1 = ifelse("amox" %in% colnames(x), "amox", NULL),
universal_2 = ifelse("amcl" %in% colnames(x), "amcl", NULL),
universal_3 = ifelse("cfur" %in% colnames(x), "cfur", NULL),
universal_4 = ifelse("pita" %in% colnames(x), "pita", NULL),
universal_5 = ifelse("cipr" %in% colnames(x), "cipr", NULL),
universal_6 = ifelse("trsu" %in% colnames(x), "trsu", NULL),
GramPos_1 = ifelse("vanc" %in% colnames(x), "vanc", NULL),
GramPos_2 = ifelse("teic" %in% colnames(x), "teic", NULL),
GramPos_3 = ifelse("tetr" %in% colnames(x), "tetr", NULL),
GramPos_4 = ifelse("eryt" %in% colnames(x), "eryt", NULL),
GramPos_5 = ifelse("oxac" %in% colnames(x), "oxac", NULL),
GramPos_6 = ifelse("rifa" %in% colnames(x), "rifa", NULL),
GramNeg_1 = ifelse("gent" %in% colnames(x), "gent", NULL),
GramNeg_2 = ifelse("tobr" %in% colnames(x), "tobr", NULL),
GramNeg_3 = ifelse("coli" %in% colnames(x), "coli", NULL),
GramNeg_4 = ifelse("cfot" %in% colnames(x), "cfot", NULL),
GramNeg_5 = ifelse("cfta" %in% colnames(x), "cfta", NULL),
GramNeg_6 = ifelse("mero" %in% colnames(x), "mero", NULL),
warnings = FALSE)
x$eerste_isolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = NULL,
col_keyantibiotics = 'sleutelab',
info = FALSE)
if (col_specimen %in% colnames(x)) {
x$eerste_bloedisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Bloed',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_urineisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Urine',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_pusisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Pus',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_respisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Respiratoir',
col_keyantibiotics = 'sleutelab',
info = FALSE)
x$eerste_fecesisolaat_gewogen <- AMR::first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
col_testcode = col_testcode,
col_specimen = col_specimen,
col_icu = col_icu,
episode_days = episode_days,
testcodes_exclude = testcodes_exclude,
icu_exclude = icu_exclude,
specimen_group = 'Feces',
col_keyantibiotics = 'sleutelab',
info = FALSE)
}
certedb_timestamp('OK', print = info, timestamp = FALSE, appendLF = TRUE)
x
}
#' Leeftijdsgroep bepalen
#'
#' Hiermee wordt op basis van de leeftijd een groep bepaald; 0-17, 18-64, 65-84 en 85+. Met \code{split.children = TRUE} worden kinderen bovendien gesplitst in 00, 01, 02-03, 04-05, 06-12 en 13-17.
#' @param age Een getal tussen 0 en 120.
#' @param split.children Standaard is \code{FALSE}. Kinderen splitsen in 0, 1, 2-3, 4-5, 6-12 en 13-17.
#' @param split.every10 Standaard is \code{FALSE}. Splitst de leeftijd per 10 jaar: 0-9, 10-19, enz. Hiermee wordt \code{split.children} genegeerd.
#' @keywords age
#' @export
#' @return Factor
age.group <- function(age, split.children = FALSE, split.every10 = FALSE) {
if (split.every10 == TRUE) {
AMR::age_groups(age, "tens")
} else if (split.children == TRUE) {
AMR::age_groups(age, c(1, 2, 4, 6, 13, 18, 65, 85))
} else {
AMR::age_groups(age)
}
}
#' Naam van antibioticum
#'
#' Hiermee kan een MOLIS-code omgezet worden naar een (triviale) antibioticumnaam of ATC-code, of andersom.
#' @param abcode Een antibioticumcode of -naam, zoals \code{"amox"}, \code{"cftr"} of \code{"J01CA04"}.
#' @param from Standaard is \code{"certe"}. Type om van te transformeren. Geldige opties zijn alle variabelen van \code{\link[AMR]{antibiotics}}.
#' @param to Standaard is \code{"trivial_nl"}. Type om naar te transformeren. Geldige opties zijn alle variabelen van \code{\link[AMR]{antibiotics}}.
#' @param textbetween Standaard is \code{" + "}. De tekst die tussen twee of meer middelen komt te staan.
#' @param tolower Standaard is \code{FALSE}. Uitkomst als kleine letters weergeven met de functie \code{\link{tolower}}.
#' @keywords ab antibiotics
#' @export
#' @examples
#' abname_molis("amcl")
#' # "Amoxicilline/clavulaanzuur"
#'
#' abname_molis("amcl+gent")
#' # "Amoxicilline/clavulaanzuur + gentamicine"
#'
#' abname_molis(c("amox", "amcl"))
#' # "Amoxicilline" "Amoxicilline/clavulaanzuur"
#' @source \code{\link[AMR]{antibiotics}}
abname_molis <- function(abcode, textbetween = " + ", tolower = FALSE, ...) {
codes <- suppressWarnings(AMR::ab_name(abcode, language = "nl", tolower = tolower))
if (sum(abcode %like% "[+]") > 0) {
for (i in 1:length(abcode)) {
if (abcode[i] %like% "[+]") {
codes[i] <- paste0(AMR::ab_name(strsplit.select(abcode[i], 1, "[+]"),
language = "nl",
tolower = tolower),
textbetween,
AMR::ab_name(strsplit.select(abcode[i], 2, "[+]"),
language = "nl",
tolower = TRUE))
}
}
}
codes
}
#' Certe bacteriecode
#'
#' Input wordt geevalueerd met \code{\link[AMR]{as.mo}} en dit wordt vergeleken met de data set \code{certedata:::bacteriecode} om een Certe bacteriecode op te halen.
#' @param x,... Zie \code{\link[AMR]{mo_property}}.
#' @details Reference gemaakt met:
#' \preformatted{
#' bacterien <- certedb_query("select * from temporary_certemm_bacterienlijst")
#'
#' bacterien <- bacterien %>%
#' transmute(bacteriecode,
#' bacteriecode_oud,
#' systeemcode,
#' fullname = gsub(" species$", "", volledigenaam) %>%
#' gsub("[)(]", "", .)) %>%
#' filter(nchar(bacteriecode) > 3, !grepl("^_", bacteriecode)) %>%
#' arrange(bacteriecode)
#'
#' usethis::use_data(bacterien, internal = TRUE)
#' }
#' @export
mo_certe <- function(x, ...) {
if (all(x %in% AMR::microorganisms.codes$code)) {
return(x)
} else {
data.frame(fullname = AMR::mo_fullname(x, ...),
stringsAsFactors = FALSE) %>%
left_join(bacterien, # is interne data in dit pakket
by = "fullname") %>%
pull(bacteriecode)
}
}
#' Adresgegevens ophalen van Google Maps
#'
#' Hiermee worden adreseigenschappen opgehaald m.b.v. \href{https://developers.google.com/maps/documentation/geocoding/start}{de Google Maps Geocoding API}. Het limiet is ca. 15.000 requests per dag en ca. 300 requests per seconde.
#' @param address Een of meerdere adressen om naar te zoeken. Mag alles zijn dat Google Maps begrijpt (zelfs \code{"Certe"}, dit wordt vertaald naar Damsterdiep 191, Groningen).
#' @param type Standaard is \code{NULL} voor alle eigenschappen. Geldige opties zijn: \code{"lat"}, \code{"lng"}, \code{"straat"}, \code{"nummer"}, \code{"postcode"}, \code{"plaats"}, \code{"gemeente"}, \code{"provincie"}, \code{"land"}, \code{"landcode"} of \code{NA} voor alle eigenschappen.
#' @param country Standaard is \code{"Nederland"}. Deze tekst wordt toegevoegd aan \code{address}.
#' @keywords address
#' @source \code{\link{maps_api_key}}
#' @export
#' @return Lijst of tekst
gps_from_address <- function(address, type = NULL, country = 'Nederland') {
if (country != '') {
address <- paste(address, country, sep = ', ')
}
address.bak <- address
lijst <- vector('list', length(address))
# progress bar maken
if (length(address) > 5) {
voortgang <- txtProgressBar(min = 0, max = length(address), style = 3)
}
for (n in 1:length(address)) {
if (length(address) > 5) {
setTxtProgressBar(voortgang, n)
#Sys.sleep(0.1)
}
lat <- 0.0
lng <- 0.0
straat <- ''
nummer <- ''
postcode <- ''
plaats <- ''
gemeente <- ''
provincie <- ''
land <- ''
landcode <- ''
url <-
paste0(
'https://maps.googleapis.com/maps/api/geocode/json?&address=',
URLencode(address[n]),
# Nederlandse landnamen:
'&language=nl&key=',
maps_api_key()
)
json <- readLines(url)
json <- gsub('\"', '', json, fixed = TRUE)
# alle meerdere spaties verwijderen
json <- gsub("(?<=[\\s])\\s*|^\\s+|\\s+$", "", json, perl = TRUE)
json <- strsplit(json, ' : ', fixed = TRUE)
for (i in 1:length(json)) {
rij <- unlist(json[i][1])
# eerste lat en lng zijn de werkelijke locatie, niet de bounds of viewport
if (rij[1] == 'location') {
rij.plus1 <- unlist(json[i + 1])
rij.plus2 <- unlist(json[i + 2])
if (rij.plus1[1] == 'lat') {
lat <- rij.plus1[2]
}
if (rij.plus2[1] == 'lng') {
lng <- rij.plus2[2]
}
lat <- gsub(',', '', lat, fixed = TRUE)
lng <- gsub(',', '', lng, fixed = TRUE)
}
if (grepl('country', toString(rij))) {
rij.min1 <- unlist(json[i - 1][1])
rij.min2 <- unlist(json[i - 2][1])
landcode <- gsub(',', '', rij.min1[2], fixed = TRUE)
land <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('administrative_area_level_1', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
provincie <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('administrative_area_level_2', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
gemeente <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('postal_code', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
postcode <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('locality', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
plaats <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('route', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
straat <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (grepl('street_number', toString(rij))) {
rij.min2 <- unlist(json[i - 2][1])
nummer <- gsub(',', '', rij.min2[2], fixed = TRUE)
}
if (rij[1] == 'location_type') {
if (grepl('APPROXIMATE', rij[2]) &
# bij postcodes geen melding, die zijn logischerwijs geschat
!grepl('^[0-9]{4} ?[a-zA-Z]{2}', address.bak[n])) {
message('approximate result: ', address.bak[n])
}
}
}
if (!is.null(type)) {
if (type == 'lat') {
lijst[n] <- as.double(lat)
}
if (type == 'lng') {
lijst[n] <- as.double(lng)
}
if (type == 'straat') {
lijst[n] <- straat
}
if (type == 'nummer') {
lijst[n] <- nummer
}
if (type == 'postcode') {
lijst[n] <- postcode
}
if (type == 'plaats') {
lijst[n] <- plaats
}
if (type == 'gemeente') {
lijst[n] <- gemeente
}
if (type == 'provincie') {
lijst[n] <- provincie
}
if (type == 'land') {
lijst[n] <- land
}
if (type == 'landcode') {
lijst[n] <- landcode
}
} else if (is.null(type) | type == 'alle') {
lijst[n] <- list(c('lat' = as.double(lat),
'lng' = as.double(lng),
'straat' = straat,
'nummer' = nummer,
'postcode' = postcode,
'plaats' = plaats,
'gemeente' = gemeente,
'provincie' = provincie,
'land' = land,
'landcode' = landcode))
}
}
if (length(address) > 5) {
close(voortgang)
}
if (is.null(type) | type == 'alle') {
lijst
} else {
unlist(lijst)
}
}
#' Tabel maken van adressen
#'
#' Hiermee worden adressen omgezet naar een tbl met het adres, de lengte- en de breedtegraad.
#' @param address Een of meerdere adressen om naar te zoeken. Mag alles zijn dat Google Maps begrijpt (zelfs \code{"Certe"}, dit wordt vertaald naar Van Swietenlaan 2, Groningen).
#' @keywords address
#' @export
#' @return Tabel
tbl_address <- function(address) {
df <- tibble(address = address)
addresslist <- gps_from_address(df$address)
address.nieuw <- character(length(addresslist))
lat <- double(length(addresslist))
lng <- double(length(addresslist))
for (i in 1:length(addresslist)) {
address.nieuw[i] <- paste0(as.list(unlist(addresslist[i]))$straat,
' ',
as.list(unlist(addresslist[i]))$nummer,
', ',
as.list(unlist(addresslist[i]))$plaats)
lat[i] <- as.list(unlist(addresslist[i]))$lat
lng[i] <- as.list(unlist(addresslist[i]))$lng
}
df$address.zoek <- address
df$address <- address.nieuw
df$lat <- as.double(lat)
df$lng <- as.double(lng)
df
}
#' Willekeurige Google Maps Geocoding API-sleutel
#'
#' Deze API-sleutels worden gebruikt voor het ophalen van \code{\link{gps_from_address}}. Er zijn 6 sleutels aangemaakt met elk een limiet van 2.500 requests per dag en 50 requests per seconde. De sleutel wordt iedere keer willekeurig geselecteerd met \code{\link[base]{sample}}.
#' @keywords api API Google adres
#' @seealso \code{\link{gps_from_address}} \code{\link{tbl_address}} \code{\link{plot2.map_old}}
#' @export
#' @return Tekst
maps_api_key <- function() {
stop("Google Maps ondersteunt geen gratis Geolocation API's meer.")
}
#' GIS-data ophalen
#'
#' Hiermee kan Nederlandse GIS-data opgehaald worden voor ruimtelijke analyse (\emph{spatial analysis}) met \code{\link{plot2.map}}.
#' @param maptype Standaard is \code{"pc3"}. Geldige waarden zijn \code{"provincies"}, \code{"gemeenten"}, \code{"postcodes"}, \code{"pc4"}, \code{"pc3"}, \code{"pc2"}.
#' @param only_adherence Standaard is \code{TRUE}. Data filteren op alleen het adherentiegebied van Certe. Hiermee worden postcodes gefilterd op >7300, of provincies gefilterd op Friesland, Groningen, Drenthe.
#' @param data Gegevens (zoals isolaten) waar GIS-data aan gekoppeld moet worden.
#' @param by Kolommen die voor de join gebruikt worden, zie \code{\link{left_join}}.
#' @details De kolom met geogegevens heeft de volgende naam:
#' \itemize{
#' \item{Bij provincies \code{provincies} (oorspronkelijk \code{provincien})}
#' \item{Bij gemeenten: \code{gemeenten} (oorspronkelijk \code{gemeentena})}
#' \item{Bij postcodes \code{postcode} (oorspronkelijk \code{pc4})}
#' }
#' Deze worden gebruikt bij een join, zoals met \code{add_map}.
#' @rdname get_map
#' @export
#' @examples
#' \dontrun{
#'
#' # Werkend voorbeeld:
#' urines <- certedb_getmmb(2015,
#' 2018,
#' zipcodes = TRUE,
#' ziplength = 3,
#' first_isolates = TRUE)
#' urines %>%
#' filter(eerste_urineisolaat_gewogen == TRUE,
#' bacteriecode %like% "ESCCOL") %>%
#' group_by(postcode) %>%
#' summarise(amox = portion_R(amox)) %>%
#' add_map(maptype = "pc3") %>%
#' plot2.map(y = amox,
#' title = "Amoxicilline-resistentie bij *E. coli*",
#' subtitle = "Eerste urinekweekisolaten in 2018")
#' }
get_map <- function(maptype = "pc3",
only_adherence = TRUE) {
maptype.bak <- maptype
if (maptype %in% paste0("pc", 2:4)) {
maptype <- 'postcodes'
}
if (!maptype %in% c('provincies', 'gemeenten', 'postcodes')) {
stop("Invalid `maptype` for spatial data.", call. = FALSE)
}
shp_file <- paste0(Sys.getenv("R_REFMAP"), "GIS/", maptype, ".shp")
if (!file.exists(shp_file)) {
stop('file not found: ', shp_file, call. = FALSE)
}
library(sf)
data <- st_read(dsn = shp_file,
stringsAsFactors = FALSE,
quiet = TRUE)
if (only_adherence == TRUE) {
if (maptype == "postcodes") {
data <- data %>% filter(pc4 > 7300)
} else if (maptype == "provincies") {
data <- data %>% filter(provincien %in% c("Friesland", "Groningen", "Drenthe", "Overijssel"))
} else {
warning("Data cannot be filtered for maptype: ", maptype, call. = FALSE)
}
}
if (maptype.bak %in% paste0("pc", 2:4)) {
pc_count <- maptype.bak %>% strsplit.select(3, "") %>% as.integer()
data <- data %>% mutate(pc4 = pc4 %>% substr(1, pc_count))
}
# kolom hernoemen
if (maptype == "postcodes") {
data <- data %>% rename(postcode = pc4)
} else if (maptype == "provincies") {
data <- data %>% rename(provincies = provincien)
} else if (maptype == "gemeenten") {
data <- data %>% rename(gemeenten = gemeentena)
}
data
}
#' @rdname get_map
#' @export
add_map <- function(data, maptype = "pc3", by = NULL) {
suppressMessages(left_join(get_map(maptype), data, by = by))
}
#' Normaliseren van aantallen
#'
#' Normaliseert aantallen op basis van referntiewaarden.
#' @param n aantal, zoals aantal verrichte testen
#' @param n_ref referentie-aantal, zoals aantal opnames of verpleegdagen
#' @param per normalisatiefactor
#' @export
#' @examples
#' testen <- c(zkh1 = 4524,
#' zkh2 = 2864,
#' zkh3 = 5875)
#' opnames <- c(zkh1 = 345923,
#' zkh2 = 204178,
#' zkh3 = 560363)
#'
#' # aantal testen per 100.000 opnames:
#' normalise(testen, opnames, 100000)
normalise <- function(n, n_ref, per = 1000) {
(n / n_ref) * per
# gelijk aan: n / (n_ref / per)
# gelijk aan: (per / n_ref) * n
}
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.