P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 11:51:59 +02:00
Code Releases Activity

(v1.1.0.9017) as.ab() update, added ab_url()

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-05-22 20:15:19 +02:00
parent 1b1e243d14
commit e467cc103e
90 changed files with 269 additions and 2694 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
R/ab_property.R
View File

@ -31,6 +31,8 @@
#' @param units a logical to indicate whether the units instead of the DDDs itself must be returned, see Examples
#' @param ... other parameters passed on to [as.ab()]
#' @details All output will be [translate]d where possible.
#'
#' The function [ab_url()] will return the direct URL to the official WHO website. A warning will be returned if the reauired ATC code is not available.
#' @inheritSection as.ab Source
#' @rdname ab_property
#' @name ab_property
@ -52,6 +54,7 @@
#' ab_group("AMX") # "Beta-lactams/penicillins"
#' ab_atc_group1("AMX") # "Beta-lactam antibacterials, penicillins"
#' ab_atc_group2("AMX") # "Penicillins with extended spectrum"
#' ab_url("AMX") # link to the official WHO page
#'
#' # smart lowercase tranformation
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
@ -183,6 +186,31 @@ ab_info <- function(x, language = get_locale(), ...) {
units = ab_ddd(x, administration = "iv", units = TRUE))))
}
#' @rdname ab_property
#' @export
ab_url <- function(x, open = FALSE, ...) {
ab <- as.ab(x = x, ... = ...)
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", ab_atc(ab), "&showdescription=no")
u[is.na(ab_atc(ab))] <- NA_character_
names(u) <- ab_name(ab)
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(ab_atc(ab))]
if (length(NAs) > 0) {
warning("No ATC code available for ", paste0(NAs, collapse = ", "), ".")
}
if (open == TRUE) {
if (length(u) > 1 & !is.na(u[1L])) {
warning("only the first URL will be opened, as `browseURL()` only suports one string.")
}
if (!is.na(u[1L])) {
utils::browseURL(u[1L])
}
}
u
}
#' @rdname ab_property
#' @export
ab_property <- function(x, property = "name", language = get_locale(), ...) {
@ -217,8 +245,7 @@ ab_validate <- function(x, property, ...) {
} else if (property %like% "ddd") {
return(as.double(x))
} else {
# return "(input)" for NAs
x[is.na(x) & !is.na(x_bak)] <- paste0("(", x_bak[is.na(x) & !is.na(x_bak)], ")")
x[is.na(x) & !is.na(x_bak)] <- NA
return(x)
}
}