2019-05-10 16:44:59 +02:00
# ==================================================================== #
# TITLE #
2022-10-05 09:12:22 +02:00
# AMR: An R Package for Working with Antimicrobial Resistance Data #
2019-05-10 16:44:59 +02:00
# #
# SOURCE #
2020-07-08 14:48:06 +02:00
# https://github.com/msberends/AMR #
2019-05-10 16:44:59 +02:00
# #
2022-10-05 09:12:22 +02:00
# CITE AS #
# Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C #
# (2022). AMR: An R Package for Working with Antimicrobial Resistance #
# Data. Journal of Statistical Software, 104(3), 1-31. #
# doi:10.18637/jss.v104.i03 #
# #
2020-10-08 11:16:03 +02:00
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
2022-08-28 10:31:50 +02:00
# Diagnostics & Advice, and University Medical Center Groningen. #
2019-05-10 16:44:59 +02:00
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
2020-01-05 17:22:09 +01:00
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
2020-10-08 11:16:03 +02:00
# #
# Visit our website for the full manual and a complete tutorial about #
2021-02-02 23:57:35 +01:00
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
2019-05-10 16:44:59 +02:00
# ==================================================================== #
2021-01-18 16:57:56 +01:00
#' Get Properties of an Antibiotic
2019-05-10 16:44:59 +02:00
#'
2019-11-28 22:32:17 +01:00
#' Use these functions to return a specific property of an antibiotic from the [antibiotics] data set. All input values will be evaluated internally with [as.ab()].
2020-07-30 15:15:52 +02:00
#' @param x any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
2021-05-12 18:15:03 +02:00
#' @param tolower a [logical] to indicate whether the first [character] of every output should be transformed to a lower case [character]. This will lead to e.g. "polymyxin B" and not "polymyxin b".
2021-08-16 21:54:34 +02:00
#' @param property one of the column names of one of the [antibiotics] data set: `vector_or(colnames(antibiotics), sort = FALSE)`.
2021-12-12 09:42:03 +01:00
#' @param language language of the returned text, defaults to system language (see [get_AMR_locale()]) and can also be set with `getOption("AMR_locale")`. Use `language = NULL` or `language = ""` to prevent translation.
2019-11-28 22:32:17 +01:00
#' @param administration way of administration, either `"oral"` or `"iv"`
2020-05-22 20:29:55 +02:00
#' @param open browse the URL using [utils::browseURL()]
2021-12-11 13:41:31 +01:00
#' @param ... in case of [set_ab_names()] and `data` is a [data.frame]: variables to select (supports tidy selection such as `column1:column4`), otherwise other arguments passed on to [as.ab()]
2021-09-29 12:12:35 +02:00
#' @param data a [data.frame] of which the columns need to be renamed, or a [character] vector of column names
2021-08-16 21:54:34 +02:00
#' @param snake_case a [logical] to indicate whether the names should be in so-called [snake case](https://en.wikipedia.org/wiki/Snake_case): in lower case and all spaces/slashes replaced with an underscore (`_`)
2021-08-17 14:34:11 +02:00
#' @param only_first a [logical] to indicate whether only the first ATC code must be returned, with giving preference to J0-codes (i.e., the antimicrobial drug group)
2021-02-08 14:18:42 +01:00
#' @details All output [will be translated][translate] where possible.
2022-08-28 10:31:50 +02:00
#'
2020-05-25 01:01:14 +02:00
#' The function [ab_url()] will return the direct URL to the official WHO website. A warning will be returned if the required ATC code is not available.
2022-08-28 10:31:50 +02:00
#'
2021-08-16 21:54:34 +02:00
#' The function [set_ab_names()] is a special column renaming function for [data.frame]s. It renames columns names that resemble antimicrobial drugs. It always makes sure that the new column names are unique. If `property = "atc"` is set, preference is given to ATC codes from the J-group.
2019-05-10 16:44:59 +02:00
#' @inheritSection as.ab Source
#' @rdname ab_property
#' @name ab_property
2022-08-28 10:31:50 +02:00
#' @return
2020-09-18 16:05:53 +02:00
#' - An [integer] in case of [ab_cid()]
2021-08-16 21:54:34 +02:00
#' - A named [list] in case of [ab_info()] and multiple [ab_atc()]/[ab_synonyms()]/[ab_tradenames()]
2020-09-18 16:05:53 +02:00
#' - A [double] in case of [ab_ddd()]
2021-08-16 21:54:34 +02:00
#' - A [data.frame] in case of [set_ab_names()]
2020-09-18 16:05:53 +02:00
#' - A [character] in all other cases
2019-05-10 16:44:59 +02:00
#' @export
2019-11-28 22:32:17 +01:00
#' @seealso [antibiotics]
2021-01-18 16:57:56 +01:00
#' @inheritSection AMR Reference Data Publicly Available
2019-05-10 16:44:59 +02:00
#' @examples
#' # all properties:
2022-08-28 10:31:50 +02:00
#' ab_name("AMX") # "Amoxicillin"
#' ab_atc("AMX") # "J01CA04" (ATC code from the WHO)
#' ab_cid("AMX") # 33613 (Compound ID from PubChem)
#' ab_synonyms("AMX") # a list with brand names of amoxicillin
2019-05-10 16:44:59 +02:00
#' ab_tradenames("AMX") # same
2022-08-28 10:31:50 +02:00
#' ab_group("AMX") # "Beta-lactams/penicillins"
2019-05-10 16:44:59 +02:00
#' ab_atc_group1("AMX") # "Beta-lactam antibacterials, penicillins"
#' ab_atc_group2("AMX") # "Penicillins with extended spectrum"
2022-08-28 10:31:50 +02:00
#' ab_url("AMX") # link to the official WHO page
2019-05-10 16:44:59 +02:00
#'
2020-01-26 20:20:00 +01:00
#' # smart lowercase tranformation
2022-08-28 10:31:50 +02:00
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
#' ab_name(
#' x = c("AMC", "PLB"),
#' tolower = TRUE
#' ) # "amoxicillin/clavulanic acid" "polymyxin B"
2019-05-10 16:44:59 +02:00
#'
2020-01-26 20:20:00 +01:00
#' # defined daily doses (DDD)
2022-08-28 10:31:50 +02:00
#' ab_ddd("AMX", "oral") # 1.5
2021-08-16 21:54:34 +02:00
#' ab_ddd_units("AMX", "oral") # "g"
2022-08-28 10:31:50 +02:00
#' ab_ddd("AMX", "iv") # 3
#' ab_ddd_units("AMX", "iv") # "g"
2019-05-10 16:44:59 +02:00
#'
2022-08-28 10:31:50 +02:00
#' ab_info("AMX") # all properties as a list
2019-05-16 21:20:00 +02:00
#'
2020-01-26 20:20:00 +01:00
#' # all ab_* functions use as.ab() internally, so you can go from 'any' to 'any':
2022-08-28 10:31:50 +02:00
#' ab_atc("AMP") # ATC code of AMP (ampicillin)
#' ab_group("J01CA01") # Drug group of ampicillins ATC code
#' ab_loinc("ampicillin") # LOINC codes of ampicillin
#' ab_name("21066-6") # "Ampicillin" (using LOINC)
#' ab_name(6249) # "Ampicillin" (using CID)
#' ab_name("J01CA01") # "Ampicillin" (using ATC)
#'
2020-01-08 11:30:33 +01:00
#' # spelling from different languages and dyslexia are no problem
#' ab_atc("ceftriaxon")
#' ab_atc("cephtriaxone")
#' ab_atc("cephthriaxone")
#' ab_atc("seephthriaaksone")
2022-08-28 10:31:50 +02:00
#'
2021-08-16 21:54:34 +02:00
#' # use set_ab_names() for renaming columns
#' colnames(example_isolates)
#' colnames(set_ab_names(example_isolates))
2021-12-05 22:06:45 +01:00
#' colnames(set_ab_names(example_isolates, NIT:VAN))
2021-08-16 21:54:34 +02:00
#' \donttest{
#' if (require("dplyr")) {
#' example_isolates %>%
2022-08-21 16:37:20 +02:00
#' set_ab_names() %>%
#' head()
2022-08-28 10:31:50 +02:00
#'
2021-09-29 12:12:35 +02:00
#' # this does the same:
#' example_isolates %>%
2022-08-28 10:31:50 +02:00
#' rename_with(set_ab_names) %>%
2022-08-21 16:37:20 +02:00
#' head()
2022-08-28 10:31:50 +02:00
#'
2021-08-16 21:54:34 +02:00
#' # set_ab_names() works with any AB property:
#' example_isolates %>%
2022-08-28 10:31:50 +02:00
#' set_ab_names(property = "atc") %>%
2022-08-21 16:37:20 +02:00
#' head()
2022-08-28 10:31:50 +02:00
#'
#' example_isolates %>%
#' set_ab_names(where(is.rsi)) %>%
#' colnames()
#'
#' example_isolates %>%
#' set_ab_names(NIT:VAN) %>%
#' colnames()
2021-08-16 21:54:34 +02:00
#' }
#' }
2021-12-12 09:42:03 +01:00
ab_name <- function ( x , language = get_AMR_locale ( ) , tolower = FALSE , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2022-10-05 09:12:22 +02:00
language <- validate_language ( language )
2020-10-19 17:09:19 +02:00
meet_criteria ( tolower , allow_class = " logical" , has_length = 1 )
2022-08-28 10:31:50 +02:00
2022-08-19 12:33:14 +02:00
x <- translate_into_language ( ab_validate ( x = x , property = " name" , ... ) , language = language , only_affect_ab_names = TRUE )
2019-05-10 16:44:59 +02:00
if ( tolower == TRUE ) {
# use perl to only transform the first character
# as we want "polymyxin B", not "polymyxin b"
2019-06-11 14:18:25 +02:00
x <- gsub ( " ^([A-Z])" , " \\L\\1" , x , perl = TRUE )
2019-05-10 16:44:59 +02:00
}
2021-08-16 21:54:34 +02:00
x
}
2019-05-10 16:44:59 +02:00
#' @rdname ab_property
#' @export
ab_cid <- function ( x , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2019-05-10 16:44:59 +02:00
ab_validate ( x = x , property = " cid" , ... )
}
#' @rdname ab_property
#' @export
ab_synonyms <- function ( x , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2019-05-10 16:44:59 +02:00
syns <- ab_validate ( x = x , property = " synonyms" , ... )
names ( syns ) <- x
if ( length ( syns ) == 1 ) {
unname ( unlist ( syns ) )
} else {
syns
}
}
#' @rdname ab_property
#' @export
ab_tradenames <- function ( x , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2019-05-10 16:44:59 +02:00
ab_synonyms ( x , ... )
}
#' @rdname ab_property
#' @export
2021-12-12 09:42:03 +01:00
ab_group <- function ( x , language = get_AMR_locale ( ) , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2022-10-05 09:12:22 +02:00
language <- validate_language ( language )
2022-08-19 12:33:14 +02:00
translate_into_language ( ab_validate ( x = x , property = " group" , ... ) , language = language , only_affect_ab_names = TRUE )
2019-05-10 16:44:59 +02:00
}
2021-08-17 14:34:11 +02:00
#' @rdname ab_property
#' @aliases ATC
#' @export
ab_atc <- function ( x , only_first = FALSE , ... ) {
meet_criteria ( x , allow_NA = TRUE )
meet_criteria ( only_first , allow_class = " logical" , has_length = 1 )
2022-08-28 10:31:50 +02:00
2021-08-17 14:34:11 +02:00
atcs <- ab_validate ( x = x , property = " atc" , ... )
2022-08-28 10:31:50 +02:00
2021-08-17 14:34:11 +02:00
if ( only_first == TRUE ) {
2022-08-28 10:31:50 +02:00
atcs <- vapply (
FUN.VALUE = character ( 1 ) ,
# get only the first ATC code
atcs ,
function ( x ) {
# try to get the J-group
if ( any ( x %like% " ^J" ) ) {
x [x %like% " ^J" ] [1L ]
} else {
as.character ( x [1L ] )
}
}
)
2021-08-17 14:34:11 +02:00
} else if ( length ( atcs ) == 1 ) {
atcs <- unname ( unlist ( atcs ) )
} else {
names ( atcs ) <- x
}
2022-08-28 10:31:50 +02:00
2021-08-17 14:34:11 +02:00
atcs
}
2019-05-10 16:44:59 +02:00
#' @rdname ab_property
#' @export
2021-12-12 09:42:03 +01:00
ab_atc_group1 <- function ( x , language = get_AMR_locale ( ) , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2022-10-05 09:12:22 +02:00
language <- validate_language ( language )
2022-08-19 12:33:14 +02:00
translate_into_language ( ab_validate ( x = x , property = " atc_group1" , ... ) , language = language , only_affect_ab_names = TRUE )
2019-05-10 16:44:59 +02:00
}
#' @rdname ab_property
#' @export
2021-12-12 09:42:03 +01:00
ab_atc_group2 <- function ( x , language = get_AMR_locale ( ) , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2022-10-05 09:12:22 +02:00
language <- validate_language ( language )
2022-08-19 12:33:14 +02:00
translate_into_language ( ab_validate ( x = x , property = " atc_group2" , ... ) , language = language , only_affect_ab_names = TRUE )
2019-05-10 16:44:59 +02:00
}
2020-01-26 20:20:00 +01:00
#' @rdname ab_property
#' @export
ab_loinc <- function ( x , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-01-26 20:20:00 +01:00
loincs <- ab_validate ( x = x , property = " loinc" , ... )
names ( loincs ) <- x
if ( length ( loincs ) == 1 ) {
unname ( unlist ( loincs ) )
} else {
loincs
}
}
2019-05-10 16:44:59 +02:00
#' @rdname ab_property
#' @export
2021-08-16 21:54:34 +02:00
ab_ddd <- function ( x , administration = " oral" , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( administration , is_in = c ( " oral" , " iv" ) , has_length = 1 )
2022-08-28 10:31:50 +02:00
2021-08-16 21:54:34 +02:00
x <- as.ab ( x , ... )
2019-05-10 16:44:59 +02:00
ddd_prop <- administration
2021-08-16 21:54:34 +02:00
# old behaviour
units <- list ( ... ) $ units
if ( ! is.null ( units ) && isTRUE ( units ) ) {
if ( message_not_thrown_before ( " ab_ddd" , entire_session = TRUE ) ) {
2022-08-28 10:31:50 +02:00
warning_ (
" in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead." ,
" This warning will be shown once per session."
)
2021-08-16 21:54:34 +02:00
}
2019-05-10 16:44:59 +02:00
ddd_prop <- paste0 ( ddd_prop , " _units" )
} else {
ddd_prop <- paste0 ( ddd_prop , " _ddd" )
}
2021-08-19 23:43:02 +02:00
out <- ab_validate ( x = x , property = ddd_prop )
2022-08-28 10:31:50 +02:00
2021-08-29 23:50:45 +02:00
if ( any ( ab_name ( x , language = NULL ) %like% " /" & is.na ( out ) ) ) {
2022-08-28 10:31:50 +02:00
warning_ (
" in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package." ,
" Please refer to the WHOCC website:\n" ,
" www.whocc.no/ddd/list_of_ddds_combined_products/"
)
2021-08-19 23:43:02 +02:00
}
out
2021-08-16 21:54:34 +02:00
}
#' @rdname ab_property
#' @export
ab_ddd_units <- function ( x , administration = " oral" , ... ) {
meet_criteria ( x , allow_NA = TRUE )
meet_criteria ( administration , is_in = c ( " oral" , " iv" ) , has_length = 1 )
2022-08-28 10:31:50 +02:00
2021-08-16 21:54:34 +02:00
x <- as.ab ( x , ... )
if ( any ( ab_name ( x , language = NULL ) %like% " /" ) ) {
2022-08-28 10:31:50 +02:00
warning_ (
" in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package." ,
" Please refer to the WHOCC website:\n" ,
" www.whocc.no/ddd/list_of_ddds_combined_products/"
)
2021-08-16 21:54:34 +02:00
}
2022-08-28 10:31:50 +02:00
2021-08-16 21:54:34 +02:00
ddd_prop <- paste0 ( administration , " _units" )
ab_validate ( x = x , property = ddd_prop )
2019-05-10 16:44:59 +02:00
}
2019-05-16 22:07:31 +02:00
#' @rdname ab_property
#' @export
2021-12-12 09:42:03 +01:00
ab_info <- function ( x , language = get_AMR_locale ( ) , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2022-10-05 09:12:22 +02:00
language <- validate_language ( language )
2022-08-28 10:31:50 +02:00
2020-02-14 19:54:13 +01:00
x <- as.ab ( x , ... )
2022-08-28 10:31:50 +02:00
list (
ab = as.character ( x ) ,
cid = ab_cid ( x ) ,
name = ab_name ( x , language = language ) ,
group = ab_group ( x , language = language ) ,
atc = ab_atc ( x ) ,
atc_group1 = ab_atc_group1 ( x , language = language ) ,
atc_group2 = ab_atc_group2 ( x , language = language ) ,
tradenames = ab_tradenames ( x ) ,
loinc = ab_loinc ( x ) ,
ddd = list (
oral = list (
amount = ab_ddd ( x , administration = " oral" ) ,
units = ab_ddd_units ( x , administration = " oral" )
) ,
iv = list (
amount = ab_ddd ( x , administration = " iv" ) ,
units = ab_ddd_units ( x , administration = " iv" )
)
)
)
2019-05-16 21:20:00 +02:00
}
2020-05-22 20:15:19 +02:00
#' @rdname ab_property
#' @export
ab_url <- function ( x , open = FALSE , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2020-10-19 17:09:19 +02:00
meet_criteria ( open , allow_class = " logical" , has_length = 1 )
2022-08-28 10:31:50 +02:00
2021-08-17 14:34:11 +02:00
ab <- as.ab ( x = x , ... )
atcs <- ab_atc ( ab , only_first = TRUE )
u <- paste0 ( " https://www.whocc.no/atc_ddd_index/?code=" , atcs , " &showdescription=no" )
u [is.na ( atcs ) ] <- NA_character_
2020-05-22 20:15:19 +02:00
names ( u ) <- ab_name ( ab )
2022-08-28 10:31:50 +02:00
2021-08-17 14:34:11 +02:00
NAs <- ab_name ( ab , tolower = TRUE , language = NULL ) [ ! is.na ( ab ) & is.na ( atcs ) ]
2020-05-22 20:15:19 +02:00
if ( length ( NAs ) > 0 ) {
2022-03-02 15:38:55 +01:00
warning_ ( " in `ab_url()`: no ATC code available for " , vector_and ( NAs , quotes = FALSE ) , " ." )
2020-05-22 20:15:19 +02:00
}
2022-08-28 10:31:50 +02:00
2020-05-22 20:15:19 +02:00
if ( open == TRUE ) {
2022-10-05 09:12:22 +02:00
if ( length ( u ) > 1 && ! is.na ( u [1L ] ) ) {
2022-03-02 15:38:55 +01:00
warning_ ( " in `ab_url()`: only the first URL will be opened, as `browseURL()` only suports one string." )
2020-05-22 20:15:19 +02:00
}
if ( ! is.na ( u [1L ] ) ) {
utils :: browseURL ( u [1L ] )
}
}
u
}
2019-05-10 16:44:59 +02:00
#' @rdname ab_property
#' @export
2021-12-12 09:42:03 +01:00
ab_property <- function ( x , property = " name" , language = get_AMR_locale ( ) , ... ) {
2020-10-20 21:00:57 +02:00
meet_criteria ( x , allow_NA = TRUE )
2022-10-05 09:12:22 +02:00
meet_criteria ( property , is_in = colnames ( AMR :: antibiotics ) , has_length = 1 )
2020-10-19 17:09:19 +02:00
meet_criteria ( language , is_in = c ( LANGUAGES_SUPPORTED , " " ) , has_length = 1 , allow_NULL = TRUE , allow_NA = TRUE )
2022-08-19 12:33:14 +02:00
translate_into_language ( ab_validate ( x = x , property = property , ... ) , language = language )
2019-05-10 16:44:59 +02:00
}
2021-09-29 12:12:35 +02:00
#' @rdname ab_property
#' @aliases ATC
#' @export
2021-12-12 09:42:03 +01:00
set_ab_names <- function ( data , ... , property = " name" , language = get_AMR_locale ( ) , snake_case = NULL ) {
2021-09-29 12:12:35 +02:00
meet_criteria ( data , allow_class = c ( " data.frame" , " character" ) )
2022-10-05 09:12:22 +02:00
meet_criteria ( property , is_in = colnames ( AMR :: antibiotics ) , has_length = 1 , ignore.case = TRUE )
language <- validate_language ( language )
2021-09-29 12:12:35 +02:00
meet_criteria ( snake_case , allow_class = " logical" , has_length = 1 , allow_NULL = TRUE )
2022-08-28 10:31:50 +02:00
2021-09-29 12:12:35 +02:00
x_deparsed <- deparse ( substitute ( data ) )
if ( length ( x_deparsed ) > 1 || any ( x_deparsed %unlike% " [a-z]+" ) ) {
x_deparsed <- " your_data"
}
2022-08-28 10:31:50 +02:00
2021-09-29 12:12:35 +02:00
property <- tolower ( property )
if ( is.null ( snake_case ) ) {
snake_case <- property == " name"
}
2022-08-28 10:31:50 +02:00
2021-09-29 12:12:35 +02:00
if ( is.data.frame ( data ) ) {
2021-12-05 23:11:10 +01:00
if ( tryCatch ( length ( list ( ... ) ) > 0 , error = function ( e ) TRUE ) ) {
2022-08-30 21:48:02 +02:00
out <- tryCatch ( suppressWarnings ( c ( ... ) ) , error = function ( e ) NULL )
if ( ! is.null ( out ) ) {
df <- data [ , out , drop = FALSE ]
} else {
df <- pm_select ( data , ... )
}
2021-12-05 22:59:06 +01:00
} else {
df <- data
}
2021-12-11 13:41:31 +01:00
vars <- get_column_abx ( df , info = FALSE , only_rsi_columns = FALSE , sort = FALSE , fn = " set_ab_names" )
2021-09-29 12:12:35 +02:00
if ( length ( vars ) == 0 ) {
message_ ( " No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged." )
return ( data )
}
} else {
# quickly get antibiotic codes
vars_ab <- as.ab ( data , fast_mode = TRUE )
vars <- data [ ! is.na ( vars_ab ) ]
}
2022-08-28 10:31:50 +02:00
x <- vapply (
FUN.VALUE = character ( 1 ) ,
ab_property ( vars , property = property , language = language ) ,
function ( x ) {
if ( property == " atc" ) {
# try to get the J-group
if ( any ( x %like% " ^J" ) ) {
x [x %like% " ^J" ] [1L ]
} else {
as.character ( x [1L ] )
}
} else {
as.character ( x [1L ] )
}
} ,
USE.NAMES = FALSE
)
2021-09-29 12:12:35 +02:00
if ( any ( x %in% c ( " " , NA ) ) ) {
2022-08-28 10:31:50 +02:00
warning_ (
" in `set_ab_names()`: no " , property , " found for column(s): " ,
vector_and ( vars [x %in% c ( " " , NA ) ] , sort = FALSE )
)
2021-09-29 12:12:35 +02:00
x [x %in% c ( " " , NA ) ] <- vars [x %in% c ( " " , NA ) ]
}
2022-08-28 10:31:50 +02:00
2021-09-29 12:12:35 +02:00
if ( snake_case == TRUE ) {
x <- tolower ( gsub ( " [^a-zA-Z0-9]+" , " _" , x ) )
}
2022-08-28 10:31:50 +02:00
2022-10-05 09:12:22 +02:00
if ( anyDuplicated ( x ) ) {
2021-09-29 12:12:35 +02:00
# very hacky way of adding the index to each duplicate
# so "Amoxicillin", "Amoxicillin", "Amoxicillin"
# will be "Amoxicillin", "Amoxicillin_2", "Amoxicillin_3"
2022-08-28 10:31:50 +02:00
invisible ( lapply (
unique ( x ) ,
function ( u ) {
dups <- which ( x == u )
if ( length ( dups ) > 1 ) {
# there are duplicates
dup_add_int <- dups [2 : length ( dups ) ]
2022-10-05 09:12:22 +02:00
x [dup_add_int ] <<- paste0 ( x [dup_add_int ] , " _" , 2 : length ( dups ) )
2022-08-28 10:31:50 +02:00
}
}
) )
2021-09-29 12:12:35 +02:00
}
if ( is.data.frame ( data ) ) {
colnames ( data ) [colnames ( data ) %in% vars ] <- x
data
} else {
data [which ( ! is.na ( vars_ab ) ) ] <- x
data
}
}
2019-05-10 16:44:59 +02:00
ab_validate <- function ( x , property , ... ) {
2021-08-16 21:54:34 +02:00
if ( tryCatch ( all ( x [ ! is.na ( x ) ] %in% AB_lookup $ ab ) , error = function ( e ) FALSE ) ) {
# special case for ab_* functions where class is already <ab>
x <- AB_lookup [match ( x , AB_lookup $ ab ) , property , drop = TRUE ]
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
2022-10-10 21:03:39 +02:00
tryCatch ( x [1L ] %in% AB_lookup [1 , property , drop = TRUE ] ,
2022-08-28 10:31:50 +02:00
error = function ( e ) stop ( e $ message , call. = FALSE )
)
2022-08-27 20:49:37 +02:00
if ( ! all ( x %in% AB_lookup [ , property , drop = TRUE ] ) ) {
2021-08-16 21:54:34 +02:00
x <- as.ab ( x , ... )
2022-08-28 21:13:26 +02:00
if ( all ( is.na ( x ) ) && is.list ( AB_lookup [ , property , drop = TRUE ] ) ) {
x <- rep ( NA_character_ , length ( x ) )
} else {
x <- AB_lookup [match ( x , AB_lookup $ ab ) , property , drop = TRUE ]
}
2021-08-16 21:54:34 +02:00
}
2019-05-10 16:44:59 +02:00
}
2022-08-28 10:31:50 +02:00
2019-06-27 11:57:45 +02:00
if ( property == " ab" ) {
2020-11-16 16:57:55 +01:00
return ( set_clean_class ( x , new_class = c ( " ab" , " character" ) ) )
2019-05-10 16:44:59 +02:00
} else if ( property == " cid" ) {
return ( as.integer ( x ) )
} else if ( property %like% " ddd" ) {
return ( as.double ( x ) )
} else {
2021-08-16 21:54:34 +02:00
x [is.na ( x ) ] <- NA
2019-05-10 16:44:59 +02:00
return ( x )
}
}