P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 17:02:03 +02:00
Code Releases Activity

(v2.1.1.9217) allow + in amr selectors

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2025-03-18 16:35:22 +01:00
parent 8d8444c607
commit 4dc4398ad1
23 changed files with 543 additions and 440 deletions
Download Patch File Download Diff File Expand all files Collapse all files

15
R/ab.R
View File

@ -155,6 +155,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
x_new[known_names] <- AMR_env$AB_lookup$ab[match(x[known_names], AMR_env$AB_lookup$generalised_name)]
known_codes_ab <- x %in% AMR_env$AB_lookup$ab
known_codes_atc <- vapply(FUN.VALUE = logical(1), gsub(" ", "", x), function(x_) x_ %in% unlist(AMR_env$AB_lookup$atc), USE.NAMES = FALSE)
known_codes_synonyms <- vapply(FUN.VALUE = logical(1), gsub(" ", "", tolower(x)), function(x_) x_ %in% tolower(unlist(AMR_env$AB_lookup$synonyms)), USE.NAMES = FALSE)
known_codes_cid <- x %in% AMR_env$AB_lookup$cid
x_new[known_codes_ab] <- AMR_env$AB_lookup$ab[match(x[known_codes_ab], AMR_env$AB_lookup$ab)]
x_new[known_codes_atc] <- AMR_env$AB_lookup$ab[vapply(
@ -169,6 +170,18 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
},
USE.NAMES = FALSE
)]
x_new[known_codes_synonyms] <- AMR_env$AB_lookup$ab[vapply(
FUN.VALUE = integer(1),
gsub(" ", "", tolower(x[known_codes_synonyms])),
function(x_) {
which(vapply(
FUN.VALUE = logical(1),
AMR_env$AB_lookup$synonyms,
function(syns) x_ %in% tolower(syns)
))[1L]
},
USE.NAMES = FALSE
)]
x_new[known_codes_cid] <- AMR_env$AB_lookup$ab[match(x[known_codes_cid], AMR_env$AB_lookup$cid)]
previously_coerced <- x %in% AMR_env$ab_previously_coerced$x
x_new[previously_coerced & is.na(x_new)] <- AMR_env$ab_previously_coerced$ab[match(x[is.na(x_new) & x %in% AMR_env$ab_previously_coerced$x], AMR_env$ab_previously_coerced$x)]
@ -180,7 +193,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
)
}
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_cid | previously_coerced
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_synonyms | known_codes_cid | previously_coerced
# fix for NAs
x_new[is.na(x)] <- NA