Skip to content

Commit

Permalink
Merge pull request #96 from ramses-antibiotics/feature/no_error_clini…
Browse files Browse the repository at this point in the history 
…cal_feature

Ramses 0.4.4
  • Loading branch information
@peterdutey
peterdutey authored Aug 22, 2022
2 parents 10c0814 + 26989ef commit c32bec1
Show file tree
Hide file tree
Showing 6 changed files with 167 additions and 105 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: Ramses
Type: Package
Title: R Package for Antimicrobial Stewardship & Surveillance
Version: 0.4.3
Version: 0.4.4
Authors@R: c(
person(given = "Peter",
family = "Dutey-Magni",
Expand Down
10 changes: 10 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,14 @@


# Ramses 0.4.4

*22 August 2022*

## Improvements

* `clinical_feature_*()` functions trigger a warning rather than an error if
no value matching `observation_code` is found in the`inpatient_investigations` table.

# Ramses 0.4.3

*2 August 2022*
Expand Down
117 changes: 72 additions & 45 deletions R/clinical_features.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@
#' code system identifier (eg \code{"http://snomed.info/sct"}) to use.
#' The default is \code{NULL} and will only filter observation using
#' \code{observation_code}.
#' @return a string
#' @return `TRUE` if validation passes, `FALSE` otherwise
#' @noRd
.clinical_investigation_code_validate <- function(
conn,
Expand Down Expand Up @@ -47,16 +47,19 @@
"observation_code"], collapse = "', '"), "'\n",
"Please use the `observation_code_system` option to avoid ambiguity."
), call. = FALSE)
}

if ( any(!observation_code %in% db_observation_codes[["observation_code"]]) ) {
stop(paste0(
} else if ( any(!observation_code %in% db_observation_codes[["observation_code"]]) ) {
warning(paste0(
"Some `observation_code` were not found in the database: '",
paste(
observation_code[which(!observation_code %in%
db_observation_codes[["observation_code"]])],
collapse = "', '"), "'"
), call. = FALSE)

return(FALSE)
} else {

return(TRUE)
}
}

Expand Down Expand Up @@ -109,10 +112,13 @@
if( nrow(parameter_name) == 0 ) {
stop(paste0("`observation_code` ", observation_code, " not found in database."),
call. = FALSE)
NULL
} else {
parameter_name <- parameter_name[["observation_display"]]
parameter_name <- gsub("[[:punct:]]", "", tolower(unique(parameter_name)))
parameter_name <- gsub(" ", "_", trimws(parameter_name))
}
parameter_name <- parameter_name[["observation_display"]]
parameter_name <- gsub("[[:punct:]]", "", tolower(unique(parameter_name)))
parameter_name <- gsub(" ", "_", trimws(parameter_name))

if (!is.null(range_threshold)){
parameter_name <- paste0(parameter_name, range_threshold)
}
Expand Down Expand Up @@ -261,9 +267,14 @@ setMethod(
function(x, observation_code, hours, observation_code_system = NULL, compute = TRUE) {
stopifnot(is.character(observation_code))
stopifnot(is.numeric(hours) & length(hours) == 1 & hours >= 0)
.clinical_investigation_code_validate(conn = x@conn,
observation_code = observation_code,
observation_code_system = observation_code_system)

obs_code_valid <- .clinical_investigation_code_validate(
x@conn,
observation_code,
observation_code_system
)

if (obs_code_valid) {

for (i in seq_len(length(observation_code))) {
x <- .clinical_feature_last(x = x,
Expand All @@ -272,6 +283,7 @@ setMethod(
observation_code_system = observation_code_system,
compute = compute)
}
}

return(x)
}
Expand Down Expand Up @@ -376,14 +388,19 @@ setMethod(
function(x, observation_code, hours, observation_code_system = NULL, compute = TRUE) {
stopifnot(is.character(observation_code))
stopifnot(is.numeric(hours) & length(hours) == 1 & hours >= 0)
.clinical_investigation_code_validate(x@conn,
observation_code,
observation_code_system)

for (i in seq_len(length(observation_code))) {
x <- .clinical_feature_mean(x, observation_code[[i]], hours, observation_code_system, compute = compute)
}
obs_code_valid <- .clinical_investigation_code_validate(
x@conn,
observation_code,
observation_code_system
)

if (obs_code_valid) {
for (i in seq_len(length(observation_code))) {
x <- .clinical_feature_mean(x, observation_code[[i]], hours, observation_code_system, compute = compute)
}
}

return(x)
}
)
Expand Down Expand Up @@ -543,12 +560,17 @@ setMethod(
function(x, observation_code, hours, observation_code_system = NULL, compute = TRUE) {
stopifnot(is.character(observation_code))
stopifnot(is.numeric(hours) & length(hours) == 1 & hours >= 0)
.clinical_investigation_code_validate(x@conn,
observation_code,
observation_code_system)

for (i in seq_len(length(observation_code))) {
x <- .clinical_feature_ols_trend(x, observation_code[[i]], hours, observation_code_system, compute = compute)
obs_code_valid <- .clinical_investigation_code_validate(
x@conn,
observation_code,
observation_code_system
)

if (obs_code_valid) {
for (i in seq_len(length(observation_code))) {
x <- .clinical_feature_ols_trend(x, observation_code[[i]], hours, observation_code_system, compute = compute)
}
}

return(x)
Expand Down Expand Up @@ -729,30 +751,35 @@ setMethod(
stopifnot(is.numeric(hours) & length(hours) == 1 & hours >= 0)

input_observation_codes <- names(observation_intervals)
.clinical_investigation_code_validate(x@conn,
input_observation_codes,
observation_code_system)

for (i in seq_len(length(observation_intervals))) {
if(length(observation_intervals[[i]]) == 1) {
stopifnot(!is.na(observation_intervals[[i]]) &
!is.infinite(observation_intervals[[i]]))
x <- .clinical_feature_threshold(x = x,
observation_code = input_observation_codes[[i]],
threshold = observation_intervals[[i]],
hours = hours,
observation_code_system = observation_code_system,
compute = compute)
} else {
stopifnot(!any(is.na(observation_intervals[[i]])) &
!any(is.infinite(observation_intervals[[i]])))
x <- .clinical_feature_interval(x = x,
observation_code = input_observation_codes[[i]],
lower_bound = sort(observation_intervals[[i]])[1],
upper_bound = sort(observation_intervals[[i]])[2],
hours = hours,
observation_code_system = observation_code_system,
compute = compute)
obs_code_valid <- .clinical_investigation_code_validate(
x@conn,
input_observation_codes,
observation_code_system
)

if (obs_code_valid) {
for (i in seq_len(length(observation_intervals))) {
if(length(observation_intervals[[i]]) == 1) {
stopifnot(!is.na(observation_intervals[[i]]) &
!is.infinite(observation_intervals[[i]]))
x <- .clinical_feature_threshold(x = x,
observation_code = input_observation_codes[[i]],
threshold = observation_intervals[[i]],
hours = hours,
observation_code_system = observation_code_system,
compute = compute)
} else {
stopifnot(!any(is.na(observation_intervals[[i]])) &
!any(is.infinite(observation_intervals[[i]])))
x <- .clinical_feature_interval(x = x,
observation_code = input_observation_codes[[i]],
lower_bound = sort(observation_intervals[[i]])[1],
upper_bound = sort(observation_intervals[[i]])[2],
hours = hours,
observation_code_system = observation_code_system,
compute = compute)
}
}
}

Expand Down
16 changes: 9 additions & 7 deletions tests/testthat/test-clinical-features.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,20 +23,22 @@ test_that(".clinical_investigation_code_validate", {
observation_code_system = c("http://codeA.com/",
"http://codeB.com/"))
)
expect_invisible(
expect_true(
.clinical_investigation_code_validate(conn = fake_db_conn,
observation_code = "A",
observation_code_system = "http://codeA.com/")
)
expect_invisible(
expect_true(
.clinical_investigation_code_validate(conn = fake_db_conn,
observation_code = c("A", "B"),
observation_code_system = "http://codeA.com/")
)
expect_error(
.clinical_investigation_code_validate(conn = fake_db_conn,
observation_code = "D",
observation_code_system = NULL)
expect_false(
expect_warning(
.clinical_investigation_code_validate(conn = fake_db_conn,
observation_code = "D",
observation_code_system = NULL)
)
)
DBI::dbDisconnect(fake_db_conn)
})
Expand Down Expand Up @@ -79,4 +81,4 @@ test_that(".clinical_feature_field_name_generate", {
.clinical_feature_field_name_generate(fake_db_conn, "mean", "8480-6", NULL, NA, NULL)
)
DBI::dbDisconnect(fake_db_conn)
})
})
3 changes: 0 additions & 3 deletions tests/testthat/test-objects.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -598,6 +598,3 @@ test_that("TherapyEpisode..constructor", {
expect_error(TherapyEpisode(fake_db_conn, "999999"))
DBI::dbDisconnect(fake_db_conn)
})



Loading

0 comments on commit c32bec1

Please sign in to comment.