1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-12 20:21:58 +02:00

styled, unit test fix

This commit is contained in:
2022-08-28 10:31:50 +02:00
parent 4cb1db4554
commit 4d050aef7c
147 changed files with 10897 additions and 8169 deletions

View File

@ -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
}