mirror of
https://github.com/msberends/AMR.git
synced 2025-07-12 05:02:03 +02:00
styled, unit test fix
This commit is contained in:
@ -9,7 +9,7 @@
|
||||
# (c) 2018-2022 Berends MS, Luz CF et al. #
|
||||
# Developed at the University of Groningen, the Netherlands, in #
|
||||
# collaboration with non-profit organisations Certe Medical #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# Diagnostics & Advice, and University Medical Center Groningen. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
@ -34,7 +34,7 @@
|
||||
#' @param ... arguments to pass on to `atc_property`
|
||||
#' @details
|
||||
#' Options for argument `administration`:
|
||||
#'
|
||||
#'
|
||||
#' - `"Implant"` = Implant
|
||||
#' - `"Inhal"` = Inhalation
|
||||
#' - `"Instill"` = Instillation
|
||||
@ -47,7 +47,7 @@
|
||||
#' - `"V"` = vaginal
|
||||
#'
|
||||
#' Abbreviations of return values when using `property = "U"` (unit):
|
||||
#'
|
||||
#'
|
||||
#' - `"g"` = gram
|
||||
#' - `"mg"` = milligram
|
||||
#' - `"mcg"` = microgram
|
||||
@ -56,18 +56,18 @@
|
||||
#' - `"MU"` = million units
|
||||
#' - `"mmol"` = millimole
|
||||
#' - `"ml"` = millilitre (e.g. eyedrops)
|
||||
#'
|
||||
#'
|
||||
#' **N.B. This function requires an internet connection and only works if the following packages are installed: `curl`, `rvest`, `xml2`.**
|
||||
#' @export
|
||||
#' @rdname atc_online
|
||||
#' @source <https://www.whocc.no/atc_ddd_alterations__cumulative/ddd_alterations/abbrevations/>
|
||||
#' @examples
|
||||
#' \donttest{
|
||||
#' if (requireNamespace("curl") && requireNamespace("rvest") && requireNamespace("xml2")) {
|
||||
#' if (requireNamespace("curl") && requireNamespace("rvest") && requireNamespace("xml2")) {
|
||||
#' # oral DDD (Defined Daily Dose) of amoxicillin
|
||||
#' atc_online_property("J01CA04", "DDD", "O")
|
||||
#' atc_online_ddd(ab_atc("amox"))
|
||||
#'
|
||||
#'
|
||||
#' # parenteral DDD (Defined Daily Dose) of amoxicillin
|
||||
#' atc_online_property("J01CA04", "DDD", "P")
|
||||
#'
|
||||
@ -84,7 +84,7 @@ atc_online_property <- function(atc_code,
|
||||
meet_criteria(administration, allow_class = "character", has_length = 1)
|
||||
meet_criteria(url, allow_class = "character", has_length = 1, looks_like = "https?://")
|
||||
meet_criteria(url_vet, allow_class = "character", has_length = 1, looks_like = "https?://")
|
||||
|
||||
|
||||
has_internet <- import_fn("has_internet", "curl")
|
||||
html_attr <- import_fn("html_attr", "rvest")
|
||||
html_children <- import_fn("html_children", "rvest")
|
||||
@ -93,20 +93,21 @@ atc_online_property <- function(atc_code,
|
||||
html_table <- import_fn("html_table", "rvest")
|
||||
html_text <- import_fn("html_text", "rvest")
|
||||
read_html <- import_fn("read_html", "xml2")
|
||||
|
||||
|
||||
check_dataset_integrity()
|
||||
|
||||
|
||||
if (!all(atc_code %in% unlist(antibiotics$atc))) {
|
||||
atc_code <- as.character(ab_atc(atc_code, only_first = TRUE))
|
||||
}
|
||||
|
||||
|
||||
if (!has_internet()) {
|
||||
message_("There appears to be no internet connection, returning NA.",
|
||||
add_fn = font_red,
|
||||
as_note = FALSE)
|
||||
add_fn = font_red,
|
||||
as_note = FALSE
|
||||
)
|
||||
return(rep(NA, length(atc_code)))
|
||||
}
|
||||
|
||||
|
||||
property <- tolower(property)
|
||||
# also allow unit as property
|
||||
if (property == "unit") {
|
||||
@ -119,12 +120,11 @@ atc_online_property <- function(atc_code,
|
||||
} else {
|
||||
returnvalue <- rep(NA_character_, length(atc_code))
|
||||
}
|
||||
|
||||
|
||||
progress <- progress_ticker(n = length(atc_code), 3)
|
||||
on.exit(close(progress))
|
||||
|
||||
|
||||
for (i in seq_len(length(atc_code))) {
|
||||
|
||||
progress$tick()
|
||||
|
||||
if (atc_code[i] %like% "^Q") {
|
||||
@ -134,19 +134,20 @@ atc_online_property <- function(atc_code,
|
||||
atc_url <- url
|
||||
}
|
||||
atc_url <- sub("%s", atc_code[i], atc_url, fixed = TRUE)
|
||||
|
||||
|
||||
if (property == "groups") {
|
||||
out <- tryCatch(
|
||||
read_html(atc_url) %pm>%
|
||||
html_node("#content") %pm>%
|
||||
html_children() %pm>%
|
||||
html_node("a"),
|
||||
error = function(e) NULL)
|
||||
html_node("a"),
|
||||
error = function(e) NULL
|
||||
)
|
||||
if (is.null(out)) {
|
||||
message_("Connection to ", atc_url, " failed.")
|
||||
return(rep(NA, length(atc_code)))
|
||||
}
|
||||
|
||||
|
||||
# get URLS of items
|
||||
hrefs <- out %pm>% html_attr("href")
|
||||
# get text of items
|
||||
@ -156,28 +157,28 @@ atc_online_property <- function(atc_code,
|
||||
# last one is antibiotics, skip it
|
||||
texts <- texts[seq_len(length(texts)) - 1]
|
||||
returnvalue <- c(list(texts), returnvalue)
|
||||
|
||||
} else {
|
||||
out <- tryCatch(
|
||||
read_html(atc_url) %pm>%
|
||||
html_nodes("table") %pm>%
|
||||
html_table(header = TRUE) %pm>%
|
||||
as.data.frame(stringsAsFactors = FALSE),
|
||||
error = function(e) NULL)
|
||||
as.data.frame(stringsAsFactors = FALSE),
|
||||
error = function(e) NULL
|
||||
)
|
||||
if (is.null(out)) {
|
||||
message_("Connection to ", atc_url, " failed.")
|
||||
return(rep(NA, length(atc_code)))
|
||||
}
|
||||
|
||||
|
||||
# case insensitive column names
|
||||
colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out)))
|
||||
|
||||
|
||||
if (length(out) == 0) {
|
||||
warning_("in `atc_online_property()`: ATC not found: ", atc_code[i], ". Please check ", atc_url, ".")
|
||||
returnvalue[i] <- NA
|
||||
next
|
||||
}
|
||||
|
||||
|
||||
if (property %in% c("atc", "name")) {
|
||||
# ATC and name are only in first row
|
||||
returnvalue[i] <- out[1, property, drop = TRUE]
|
||||
@ -195,11 +196,11 @@ atc_online_property <- function(atc_code,
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (property == "groups" & length(returnvalue) == 1) {
|
||||
returnvalue <- returnvalue[[1]]
|
||||
}
|
||||
|
||||
|
||||
returnvalue
|
||||
}
|
||||
|
||||
|
Reference in New Issue
Block a user