diff --git a/.Rbuildignore b/.Rbuildignore index 3184c29..ff2bdec 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -2,6 +2,7 @@ _pkgdown\.yml Makefile ^test\.R$ +^test-*\.R$ ^.*\.Rproj$ ^\.Rproj\.user$ README\.html diff --git a/.gitignore b/.gitignore index 94ce28c..86f8154 100644 --- a/.gitignore +++ b/.gitignore @@ -4,7 +4,8 @@ lastdose.Rcheck lastdose*.tar.gz src/*.o src/*.so -test*.R +/test-*.R +/test.R test*.cpp .Rproj.user .Rhistory diff --git a/NEWS.md b/NEWS.md index 4e59a45..bfb3d01 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,5 @@ +# lastdose (development version) + # lastdose 0.4.3 ## New features and changes diff --git a/R/RcppExports.R b/R/RcppExports.R index 992d871..ac32af9 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -1,7 +1,7 @@ # Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 -lastdose_impl <- function(id, time, amt, evid, addl, ii, fill, back_calc, sort1, comment) { - .Call(`_lastdose_lastdose_impl`, id, time, amt, evid, addl, ii, fill, back_calc, sort1, comment) +lastdose_impl <- function(id, time, amt, evid, addl, ii, fill, back_calc, sort1, comment, include_occ) { + .Call(`_lastdose_lastdose_impl`, id, time, amt, evid, addl, ii, fill, back_calc, sort1, comment, include_occ) } diff --git a/R/lastdose.R b/R/lastdose.R index 30d8b98..691221c 100644 --- a/R/lastdose.R +++ b/R/lastdose.R @@ -6,7 +6,8 @@ NULL #' Calculate last dose amount and times since previous doses #' #' This function calculates the last dose amount (`LDOS`), the time after -#' last dose (`TAD`), and time after first dose (`TAFD`). Use [lastdose()] +#' last dose (`TAD`), time after first dose (`TAFD`), and observation +#' occasion (`OCC`). Use [lastdose()] #' to add (or potentially replace) columns to the input data frame; #' [lastdose_list()] and [lastdose_df()] returns calculated information #' as either `list` or `data.frame` format without modifying the input data. @@ -44,8 +45,11 @@ NULL #' @param ... arguments passed to [lastdose_list()] #' @param include_ldos `logical`; if `FALSE` then the `LDOS` data is not #' appended to the data set. Only used for the [lastdose()] function. -#' @param include_tafd `logical`; if `FALSE`, then `TAFD` data is not appended -#' to the data set. Only used for the [lastdose()] function. +#' @param include_tafd `logical`; if `FALSE`, then time after first dose +#' (`TAFD`) data is not appended to the data set; this is only used for the +#' [lastdose()] function. +#' @param include_occ `logical`; if `FALSE` then observation occasion counter +#' (`OCC`; see **Details**) is not appended to the data set. #' #' @section Options: #' @@ -78,11 +82,17 @@ NULL #' accessible with `tad`, `tafd`, and `ldos` (note the lower case form here to #' distinguish from the columns that might be added to the data frame). #' -#' **Time after first dose**: note that time after first dose (`TAFD`) is the -#' time after the first dosing record (`EVID` 1 or 4) in the data frame that -#' you pass in. If you don't have a dosing record for the first dose to +#' **Time after first dose (TAFD)**: note that time after first dose (`TAFD`) +#' is the time after the first dosing record (`EVID` 1 or 4) in the data frame +#' that you pass in. If you don't have a dosing record for the first dose to #' anchor this calculation, you should opt out. #' +#' **Occasion (OCC)**: observation occasions (`OCC`) occur when there is an +#' observation record (with `EVID=0`) following a dose record (`EVID 1 or 4`); +#' `OCC` starts at `0` and increments with each dose that is followed by at +#' least one observation record. The `OCC` calculation ignores all commented +#' records (doses or observations). +#' #' **Handling of commented records**: Dosing records that have been "commented" #' (as indicated with the `comments` argument) will never be considered as #' actual doses when determining `TAD`, `TAFD`, and `LDOS`. But commented @@ -133,11 +143,13 @@ NULL #' #' @export lastdose <- function(data, ..., include_ldos = TRUE, - include_tafd = getOption("lastdose.include_tafd", FALSE)) { - ans <- lastdose_list(data, ...) + include_tafd = getOption("lastdose.include_tafd", FALSE), + include_occ = getOption("lastdose.include_occ", TRUE)) { + ans <- lastdose_list(data, include_occ = include_occ, ...) data[["TAD"]] <- ans[["tad"]] if(include_tafd) data[["TAFD"]] <- ans[["tafd"]] if(include_ldos) data[["LDOS"]] <- ans[["ldos"]] + if(include_occ) data[["OCC"]] <- ans[["occ"]] data } @@ -150,7 +162,8 @@ lastdose_list <- function(data, fill = -99, back_calc = TRUE, addl_ties = c("obs_first", "dose_first"), - comments = find_comments(data)) { + comments = find_comments(data), + include_occ = getOption("lastdose.include_occ", TRUE)) { if(length(comments) == 1) { comments <- rep(comments,nrow(data)) @@ -161,6 +174,8 @@ lastdose_list <- function(data, call. = FALSE ) } + back_calc <- isTRUE(back_calc) + include_occ <- isTRUE(include_occ) addl_ties <- match.arg(addl_ties) sort1 <- addl_ties == "obs_first" lower_names <- tolower(names(data)) @@ -253,7 +268,8 @@ lastdose_list <- function(data, fill, back_calc, sort1, - comments + comments, + include_occ ) if(has_na_time) { re_order <- order(c(which(!na_time), which(na_time))) @@ -268,13 +284,17 @@ lastdose_list <- function(data, #' @export lastdose_df <- function(data, ...) { ans <- lastdose_list(data, ...) - data.frame( + out <- data.frame( tad = ans[["tad"]], tafd = ans[["tafd"]], ldos = ans[["ldos"]], stringsAsFactors = FALSE, check.names = FALSE, fix.empty.names = FALSE, row.names = NULL ) + if(!is.null(ans[["occ"]])) { + out$occ <- ans[["occ"]] + } + out } #' Find commented records diff --git a/inst/test-data/occ/evid-2-3-a.csv b/inst/test-data/occ/evid-2-3-a.csv new file mode 100644 index 0000000..c0f09e2 --- /dev/null +++ b/inst/test-data/occ/evid-2-3-a.csv @@ -0,0 +1,9 @@ +ID,TIME,EVID,AMT +1,0,0,100 +1,1,1,100 +1,2,0,100 +1,3,1,100 +1,4,2,100 +1,5,1,100 +1,6,1,100 +1,7,0,100 diff --git a/inst/test-data/occ/evid-2-3-b.csv b/inst/test-data/occ/evid-2-3-b.csv new file mode 100644 index 0000000..94e4fbc --- /dev/null +++ b/inst/test-data/occ/evid-2-3-b.csv @@ -0,0 +1,9 @@ +ID,TIME,EVID,AMT +1,0,0,100 +1,1,1,100 +1,2,0,100 +1,3,1,100 +1,4,3,100 +1,5,1,100 +1,6,1,100 +1,7,0,100 diff --git a/inst/test-data/occ/evid-2-3-c.csv b/inst/test-data/occ/evid-2-3-c.csv new file mode 100644 index 0000000..0c06997 --- /dev/null +++ b/inst/test-data/occ/evid-2-3-c.csv @@ -0,0 +1,9 @@ +ID,TIME,EVID,AMT +1,0,0,100 +1,1,1,100 +1,2,0,100 +1,3,1,100 +1,4,3,100 +1,5,0,100 +1,6,1,100 +1,7,0,100 diff --git a/inst/test-data/occ/multi-dose-addl-no-obs.csv b/inst/test-data/occ/multi-dose-addl-no-obs.csv new file mode 100644 index 0000000..338c4f5 --- /dev/null +++ b/inst/test-data/occ/multi-dose-addl-no-obs.csv @@ -0,0 +1,10 @@ +ID,TIME,EVID,AMT,CMT,II,ADDL +1,0,0,0,0,0,0 +1,0,1,100,1,1,3 +1,6,0,0,0,0,0 +1,7,0,0,0,0,0 +1,8,0,0,0,0,0 +1,9,0,0,0,0,0 +1,10,0,0,0,0,0 +1,11,0,0,0,0,0 +1,12,0,0,0,0,0 diff --git a/inst/test-data/occ/multi-dose-addl.csv b/inst/test-data/occ/multi-dose-addl.csv new file mode 100644 index 0000000..5ecb9cd --- /dev/null +++ b/inst/test-data/occ/multi-dose-addl.csv @@ -0,0 +1,15 @@ +ID,TIME,EVID,AMT,CMT,II,ADDL +1,0,0,0,0,0,0 +1,0,1,100,1,12,1 +1,2,0,0,0,0,0 +1,4,0,0,0,0,0 +1,6,0,0,0,0,0 +1,8,0,0,0,0,0 +1,10,0,0,0,0,0 +1,12,0,0,0,0,0 +1,14,0,0,0,0,0 +1,16,0,0,0,0,0 +1,18,0,0,0,0,0 +1,20,0,0,0,0,0 +1,22,0,0,0,0,0 +1,24,0,0,0,0,0 diff --git a/inst/test-data/occ/multi-dose-explicit-no-obs.csv b/inst/test-data/occ/multi-dose-explicit-no-obs.csv new file mode 100644 index 0000000..cbb88a1 --- /dev/null +++ b/inst/test-data/occ/multi-dose-explicit-no-obs.csv @@ -0,0 +1,13 @@ +ID,TIME,EVID,AMT,CMT,II,ADDL +1,0,0,0,0,0,0 +1,0,1,100,1,0,0 +1,1,1,100,1,0,0 +1,2,1,100,1,0,0 +1,3,1,100,1,0,0 +1,6,0,0,0,0,0 +1,7,0,0,0,0,0 +1,8,0,0,0,0,0 +1,9,0,0,0,0,0 +1,10,0,0,0,0,0 +1,11,0,0,0,0,0 +1,12,0,0,0,0,0 diff --git a/inst/test-data/occ/multi-dose-explicit.csv b/inst/test-data/occ/multi-dose-explicit.csv new file mode 100644 index 0000000..1efd85c --- /dev/null +++ b/inst/test-data/occ/multi-dose-explicit.csv @@ -0,0 +1,16 @@ +ID,TIME,EVID,AMT,CMT +1,0,0,0,0 +1,0,1,100,1 +1,2,0,0,0 +1,4,0,0,0 +1,6,0,0,0 +1,8,0,0,0 +1,10,0,0,0 +1,12,0,0,0 +1,12,1,100,1 +1,14,0,0,0 +1,16,0,0,0 +1,18,0,0,0 +1,20,0,0,0 +1,22,0,0,0 +1,24,0,0,0 diff --git a/inst/test-data/occ/occ-data.R b/inst/test-data/occ/occ-data.R new file mode 100644 index 0000000..97eac32 --- /dev/null +++ b/inst/test-data/occ/occ-data.R @@ -0,0 +1,93 @@ + +#' +#' # Examples +#' +library(dplyr) +library(mrgsolve) +library(lastdose) +library(here) + +csv <- function(x, file) { + file <- here("inst/test-data/occ/", file) + x$CP <- NULL + x$cp <- NULL + write.csv(x, file, quote = FALSE, na = ".", row.names=FALSE) +} + +mod <- house(delta = 2, end = 24, outvars = "CP") + +#' ## Single dose +dose <- evd(amt = 100) +data <- mrgsim_df(mod, dose, carry_out = "AMT,EVID,CMT") +#' - `OCC` starts at zero +#' - `OCC` increments to 1 at the time of the first dose +csv(data, file = "single-dose.csv") + +data <- mrgsim_df(mod, dose, carry_out = "AMT,EVID,CMT", recsort = 3) +#' Here, `OCC` starts at 1 because it was the first record +csv(data, file = "single-dose-recsort3.csv") + +#' ## Multi-dose, with doses explicit in the data set +dose <- evd(amt = 100, ii = 12, addl = 1) %>% realize_addl() +data <- mrgsim_df(mod, dose, carry_out = "AMT,EVID,CMT") +#' - `OCC` starts at 0 again, increments with the first dose +#' - `OCC` increments at the time of the second dose because we have obserations following +csv(data, file = "multi-dose-explicit.csv") + +#' ## Multi-dose, with doses coded via addl +dose <- evd(amt = 100, ii = 12, addl = 1) +data <- mrgsim_df(mod, dose, carry_out = "AMT,EVID,CMT,ADDL,II") + +#' - `OCC` increments at 12 hours, the time of the second dose +csv(data, file = "multi-dose-addl.csv") + + +#' ## Multi-dose via addl, but no observations after the doses +dose <- evd(amt = 100, ii = 1, addl = 3) +data <- mrgsim_df(mod, dose, end = -1, add = c(0, seq(6,12)), carry_out = "AMT,EVID,CMT,ADDL,II") +#' - In this case, `OCC` doesn't increment at the time of the dose at `TIME==0`; +#' - This is because there wasn't an observation after the first dose, so we +#' (intentionally) don't increment `OCC` at that point +csv(data, file = "multi-dose-addl-no-obs.csv") + + +#' We can see this explicitly here +dose <- evd(amt = 100, ii = 1, addl = 3) %>% realize_addl() +data <- mrgsim_df(mod, dose, end = -1, add = c(0, seq(6,12)), carry_out = "AMT,EVID,CMT,ADDL,II") +#' The rule is: `OCC` doesn't increment unless there are observations after the dose +csv(data, file = "multi-dose-explicit-no-obs.csv") + + +#' # EVID 2 or 3 +#' +#' These currently don't count for establishing an occasion dose +#' +data <- data.frame( + ID = 1, + TIME = c(0, 1, 2, 3, 4, 5, 6, 7), + EVID = c(0, 1, 0, 1, 2, 1, 1, 0), + AMT = 100 +) + +csv(data, file = "evid-2-3-a.csv") + + +data <- data.frame( + ID = 1, + TIME = c(0, 1, 2, 3, 4, 5, 6, 7), + EVID = c(0, 1, 0, 1, 3, 1, 1, 0), + AMT = 100 +) + +csv(data, file = "evid-2-3-b.csv") + +#' But if we find an observation before the next dose, we start the occasion +#' there +data <- data.frame( + ID = 1, + TIME = c(0, 1, 2, 3, 4, 5, 6, 7), + EVID = c(0, 1, 0, 1, 3, 0, 1, 0), + AMT = 100 +) + +csv(data, file = "evid-2-3-c.csv") diff --git a/inst/test-data/occ/single-dose-recsort3.csv b/inst/test-data/occ/single-dose-recsort3.csv new file mode 100644 index 0000000..7d921be --- /dev/null +++ b/inst/test-data/occ/single-dose-recsort3.csv @@ -0,0 +1,15 @@ +ID,TIME,EVID,AMT,CMT +1,0,1,100,1 +1,0,0,0,0 +1,2,0,0,0 +1,4,0,0,0 +1,6,0,0,0 +1,8,0,0,0 +1,10,0,0,0 +1,12,0,0,0 +1,14,0,0,0 +1,16,0,0,0 +1,18,0,0,0 +1,20,0,0,0 +1,22,0,0,0 +1,24,0,0,0 diff --git a/inst/test-data/occ/single-dose.csv b/inst/test-data/occ/single-dose.csv new file mode 100644 index 0000000..a1ca251 --- /dev/null +++ b/inst/test-data/occ/single-dose.csv @@ -0,0 +1,15 @@ +ID,TIME,EVID,AMT,CMT +1,0,0,0,0 +1,0,1,100,1 +1,2,0,0,0 +1,4,0,0,0 +1,6,0,0,0 +1,8,0,0,0 +1,10,0,0,0 +1,12,0,0,0 +1,14,0,0,0 +1,16,0,0,0 +1,18,0,0,0 +1,20,0,0,0 +1,22,0,0,0 +1,24,0,0,0 diff --git a/man/lastdose.Rd b/man/lastdose.Rd index db0f623..8eec957 100644 --- a/man/lastdose.Rd +++ b/man/lastdose.Rd @@ -10,7 +10,8 @@ lastdose( data, ..., include_ldos = TRUE, - include_tafd = getOption("lastdose.include_tafd", FALSE) + include_tafd = getOption("lastdose.include_tafd", FALSE), + include_occ = getOption("lastdose.include_occ", TRUE) ) lastdose_list( @@ -21,7 +22,8 @@ lastdose_list( fill = -99, back_calc = TRUE, addl_ties = c("obs_first", "dose_first"), - comments = find_comments(data) + comments = find_comments(data), + include_occ = getOption("lastdose.include_occ", TRUE) ) lastdose_df(data, ...) @@ -34,8 +36,12 @@ lastdose_df(data, ...) \item{include_ldos}{\code{logical}; if \code{FALSE} then the \code{LDOS} data is not appended to the data set. Only used for the \code{\link[=lastdose]{lastdose()}} function.} -\item{include_tafd}{\code{logical}; if \code{FALSE}, then \code{TAFD} data is not appended -to the data set. Only used for the \code{\link[=lastdose]{lastdose()}} function.} +\item{include_tafd}{\code{logical}; if \code{FALSE}, then time after first dose +(\code{TAFD}) data is not appended to the data set; this is only used for the +\code{\link[=lastdose]{lastdose()}} function.} + +\item{include_occ}{\code{logical}; if \code{FALSE} then observation occasion counter +(\code{OCC}; see \strong{Details}) is not appended to the data set.} \item{time_col}{character name for the \code{TIME} column; this could be time after first dose or time after first record or time relative to any origin; input @@ -75,7 +81,8 @@ and \code{LDOS}.} } \description{ This function calculates the last dose amount (\code{LDOS}), the time after -last dose (\code{TAD}), and time after first dose (\code{TAFD}). Use \code{\link[=lastdose]{lastdose()}} +last dose (\code{TAD}), time after first dose (\code{TAFD}), and observation +occasion (\code{OCC}). Use \code{\link[=lastdose]{lastdose()}} to add (or potentially replace) columns to the input data frame; \code{\link[=lastdose_list]{lastdose_list()}} and \code{\link[=lastdose_df]{lastdose_df()}} returns calculated information as either \code{list} or \code{data.frame} format without modifying the input data. @@ -92,11 +99,17 @@ When calling \code{\link[=lastdose_list]{lastdose_list()}} or \code{\link[=lastd accessible with \code{tad}, \code{tafd}, and \code{ldos} (note the lower case form here to distinguish from the columns that might be added to the data frame). -\strong{Time after first dose}: note that time after first dose (\code{TAFD}) is the -time after the first dosing record (\code{EVID} 1 or 4) in the data frame that -you pass in. If you don't have a dosing record for the first dose to +\strong{Time after first dose (TAFD)}: note that time after first dose (\code{TAFD}) +is the time after the first dosing record (\code{EVID} 1 or 4) in the data frame +that you pass in. If you don't have a dosing record for the first dose to anchor this calculation, you should opt out. +\strong{Occasion (OCC)}: observation occasions (\code{OCC}) occur when there is an +observation record (with \code{EVID=0}) following a dose record (\verb{EVID 1 or 4}); +\code{OCC} starts at \code{0} and increments with each dose that is followed by at +least one observation record. The \code{OCC} calculation ignores all commented +records (doses or observations). + \strong{Handling of commented records}: Dosing records that have been "commented" (as indicated with the \code{comments} argument) will never be considered as actual doses when determining \code{TAD}, \code{TAFD}, and \code{LDOS}. But commented diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 9944538..bf32cc7 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -11,8 +11,8 @@ Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // lastdose_impl -Rcpp::List lastdose_impl(Rcpp::NumericVector id, Rcpp::NumericVector time, Rcpp::NumericVector amt, Rcpp::NumericVector evid, Rcpp::NumericVector addl, Rcpp::NumericVector ii, Rcpp::NumericVector fill, Rcpp::LogicalVector back_calc, Rcpp::LogicalVector sort1, Rcpp::LogicalVector comment); -RcppExport SEXP _lastdose_lastdose_impl(SEXP idSEXP, SEXP timeSEXP, SEXP amtSEXP, SEXP evidSEXP, SEXP addlSEXP, SEXP iiSEXP, SEXP fillSEXP, SEXP back_calcSEXP, SEXP sort1SEXP, SEXP commentSEXP) { +Rcpp::List lastdose_impl(Rcpp::NumericVector id, Rcpp::NumericVector time, Rcpp::NumericVector amt, Rcpp::NumericVector evid, Rcpp::NumericVector addl, Rcpp::NumericVector ii, Rcpp::NumericVector fill, Rcpp::LogicalVector back_calc, Rcpp::LogicalVector sort1, Rcpp::LogicalVector comment, Rcpp::LogicalVector include_occ); +RcppExport SEXP _lastdose_lastdose_impl(SEXP idSEXP, SEXP timeSEXP, SEXP amtSEXP, SEXP evidSEXP, SEXP addlSEXP, SEXP iiSEXP, SEXP fillSEXP, SEXP back_calcSEXP, SEXP sort1SEXP, SEXP commentSEXP, SEXP include_occSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -26,13 +26,14 @@ BEGIN_RCPP Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type back_calc(back_calcSEXP); Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type sort1(sort1SEXP); Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type comment(commentSEXP); - rcpp_result_gen = Rcpp::wrap(lastdose_impl(id, time, amt, evid, addl, ii, fill, back_calc, sort1, comment)); + Rcpp::traits::input_parameter< Rcpp::LogicalVector >::type include_occ(include_occSEXP); + rcpp_result_gen = Rcpp::wrap(lastdose_impl(id, time, amt, evid, addl, ii, fill, back_calc, sort1, comment, include_occ)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { - {"_lastdose_lastdose_impl", (DL_FUNC) &_lastdose_lastdose_impl, 10}, + {"_lastdose_lastdose_impl", (DL_FUNC) &_lastdose_lastdose_impl, 11}, {NULL, NULL, 0} }; diff --git a/src/lastdose.cpp b/src/lastdose.cpp index f1e306a..643833d 100644 --- a/src/lastdose.cpp +++ b/src/lastdose.cpp @@ -4,8 +4,9 @@ class record { public: - record(double time_, double amt_, int evid_,bool from_data_,bool comment_); + record(double time_, double amt_, int evid_, bool from_data_, bool comment_); bool is_dose(); + bool real_observation(); double time; double amt; int evid; @@ -14,7 +15,8 @@ class record { bool comment; }; -record::record(double time_, double amt_, int evid_,bool from_data_,bool comment_) { +record::record(double time_, double amt_, int evid_, bool from_data_, + bool comment_) { time = time_; amt = amt_; evid = evid_; @@ -35,6 +37,10 @@ bool is_dose(const int evid, const bool comment) { return (evid==1 || evid==4) && (!comment); } +bool record::real_observation() { + return evid==0 && !comment; +} + typedef std::vector recs; bool Comp1(const record& a, const record& b) { @@ -44,6 +50,20 @@ bool Comp1(const record& a, const record& b) { return a.time < b.time; } +bool obs_before_dose(recs::iterator it, recs::iterator it_end) { + auto it_next = std::next(it,1); + while(it_next != it_end) { + if(it_next->real_observation()) { + return true; + } + if(it_next->is_dose()) { + return false; + } + ++it_next; + } + return false; +} + // [[Rcpp::export]] Rcpp::List lastdose_impl(Rcpp::NumericVector id, Rcpp::NumericVector time, @@ -54,11 +74,13 @@ Rcpp::List lastdose_impl(Rcpp::NumericVector id, Rcpp::NumericVector fill, Rcpp::LogicalVector back_calc, Rcpp::LogicalVector sort1, - Rcpp::LogicalVector comment) { + Rcpp::LogicalVector comment, + Rcpp::LogicalVector include_occ) { amt = Rcpp::clone(amt); bool obs_first = sort1[0]; bool use_fill = !back_calc[0]; + bool get_occ = include_occ[0]; std::vector idn; std::vector idstart; std::vector idend; @@ -91,6 +113,7 @@ Rcpp::List lastdose_impl(Rcpp::NumericVector id, Rcpp::NumericVector tad(id.size()); // return vector for TAD Rcpp::NumericVector ldos(id.size()); // return vector for LDOS Rcpp::NumericVector tafd(id.size()); // return vector for TAFD + Rcpp::NumericVector occ(id.size()); // return vector for OCC std::vector tofd; // time of first dose tofd.assign(idn.size(),-1.0); int nid = idn.size(); @@ -162,6 +185,7 @@ Rcpp::List lastdose_impl(Rcpp::NumericVector id, double last_dose = 0; bool had_dose = false; bool no_dose = tofd[i] == -1; + last_time = 0; for(recs::iterator it = this_id.begin(); it !=this_id.end(); ++it) { if(it->is_dose()) { @@ -179,11 +203,32 @@ Rcpp::List lastdose_impl(Rcpp::NumericVector id, } ldos[it->pos] = last_dose; } + // To resort for OCC calculation + if(!it->from_data) { + it->pos = -1; + } } + // Start occ calculation -------------------------------------------------- + if(get_occ) { + int occ_n = 0; + std::sort(this_id.begin(), this_id.end(), Comp1); + for(auto it = this_id.begin(); it !=this_id.end(); ++it) { + if(it->is_dose() && obs_before_dose(it, this_id.end())) { + ++occ_n; + } + if(it->from_data) { + occ[it->pos] = occ_n; + } + } + } + // End occ calculation ----------------------------------------------------- } Rcpp::List ans; ans["tad"] = tad; ans["tafd"] = tafd; ans["ldos"] = ldos; + if(get_occ) { + ans["occ"] = occ; + } return ans; } diff --git a/tests/testthat/test-lastdose.R b/tests/testthat/test-lastdose.R index a99f1b2..8802e21 100644 --- a/tests/testthat/test-lastdose.R +++ b/tests/testthat/test-lastdose.R @@ -3,7 +3,7 @@ library(lastdose) context("basic functionality") set_file <- system.file("csv", "setn.csv", package = "lastdose") -df <- read.csv(set_file) +df <- read.csv(set_file, na.strings = ".", stringsAsFactors = FALSE) df$TIME <- df$time df$time <- NULL set1 <- subset(df, set==1) @@ -69,7 +69,7 @@ test_that("lastdose_df [LSD-TEST-007]", { test_that("lastdose_list [LSD-TEST-008]", { y <- lastdose_list(set1) expect_is(y,"list") - expect_identical(names(y), c("tad", "tafd","ldos")) + expect_identical(names(y), c("tad", "tafd","ldos", "occ")) }) test_that("required columns [LSD-TEST-009]", { @@ -181,7 +181,8 @@ test_that("commented records [LSD-TEST-016]", { com <- c(".", NA ,"C", "A","Comment") ans <- find_comments(com) expect_identical(ans, c(FALSE,FALSE,TRUE,TRUE,TRUE)) - df <- data.frame(C = com, DV=stats::rnorm(length(com))) + df <- data.frame(C = com, DV=stats::rnorm(length(com)), + stringsAsFactors=FALSE) ans2 <- find_comments(com) expect_identical(ans,ans2) df2 <- df @@ -307,7 +308,8 @@ test_that("ii detection issue-21 [LSD-TEST-023]", { EVID = c(0,1,0,0,0,0,0,0,0), II = c(0,2,0,0,0,0,0,0,0), ADDL = c(0,2,0,0,0,0,0,0,0), - ID = 1 + ID = 1, + stringsAsFactors=FALSE ) out <- lastdose(data, addl_ties = "dose_first") expect_true(all(out$LDOS[-1]==1)) @@ -340,7 +342,8 @@ test_that("error if ADDL requested by II le 0 [LSD-TEST-024]", { EVID = c(0,1,0,0), ADDL = c(0,2,0,0), II = 0, - ID = 1 + ID = 1, + stringsAsFactors=FALSE ) expect_error( lastdose(data), @@ -354,7 +357,8 @@ test_that("comments vector is subset for NA time #38 [LSD-TEST-025]", { C = c("C", NA, NA, "C", NA, NA), TIME = c(-1, 0, NA, -1, 0, 0.25), AMT = c(0, 100, 0, 0, 200, 0), - EVID = c(0, 1, 0, 0, 1, 0) + EVID = c(0, 1, 0, 0, 1, 0), + stringsAsFactors = FALSE ) data <- lastdose(data) expect_equal(data$TAD, c(-1, 0, NA, -1, 0, 0.25)) @@ -365,13 +369,15 @@ test_that("data frame is not modified", { ID = 1, AMT = c(0, 1, NA, 0, 0), TIME = c(1, 2, 3, 4, 5), - EVID = c(0, 1, 0, 0, 0) + EVID = c(0, 1, 0, 0, 0), + stringsAsFactors=FALSE ) data2 <- data.frame( ID = 1, AMT = c(0, 1, NA, 0, 0), TIME = c(1, 2, 3, 4, 5), - EVID = c(0, 1, 0, 0, 0) + EVID = c(0, 1, 0, 0, 0), + stringsAsFactors=FALSE ) expect_identical(data, data2) ld <- lastdose(data) @@ -392,7 +398,8 @@ test_that("TAD is the same for records with the same time", { ID = 1, TIME = c(1, 2, 3, 4, 4, 4, 4), AMT = c(0, 0, 1, 0, 0, 10, 0), - EVID = c(0, 0, 1, 0, 0, 1, 0) + EVID = c(0, 0, 1, 0, 0, 1, 0), + stringsAsFactors=FALSE ) ans3 <- lastdose(data) diff --git a/tests/testthat/test-occ.R b/tests/testthat/test-occ.R new file mode 100644 index 0000000..5118226 --- /dev/null +++ b/tests/testthat/test-occ.R @@ -0,0 +1,234 @@ +library(testthat) +library(lastdose) + + +occdata <- function(file) { + file <- system.file("test-data", "occ", file, package = "lastdose") + read.csv(file, stringsAsFactors = FALSE) +} + +test_that("OCC single dose", { + data <- occdata("single-dose.csv") + data <- lastdose(data) + expect_equal(data$OCC[1], 0) + expect_true(all(data$OCC[-1] ==1)) +}) + +test_that("OCC single dose, recsort==3", { + data <- occdata("single-dose-recsort3.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), 1L) + expect_equal(data$EVID[1], 1L) +}) + +test_that("OCC multi-dose, explicit", { + data <- occdata("multi-dose-explicit.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), c(0,1,2)) + sp <- split(data, data$OCC) + # Single observation prior to first dose + expect_equal(sp[[1]]$OCC, 0) + # First occasion + expect_equal(sp[[2]]$OCC[1], 1) + expect_equal(sp[[2]]$EVID[1], 1) + expect_equal(range(sp[[2]]$TIME), c(0,12)) + # Second occasion + expect_equal(sp[[3]]$OCC[1], 2) + expect_equal(sp[[3]]$EVID[1], 1) + expect_equal(range(sp[[3]]$TIME), c(12,24)) +}) + +test_that("OCC multi-dose, addl", { + data <- occdata("multi-dose-addl.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), c(0,1,2)) + sp <- split(data, data$OCC) + # Single observation prior to first dose + expect_equal(sp[[1]]$OCC, 0) + # First occasion + expect_equal(sp[[2]]$OCC[1], 1) + expect_equal(sp[[2]]$EVID[1], 1) + expect_equal(range(sp[[2]]$TIME), c(0,10)) + # Second occasion + expect_equal(sp[[3]]$OCC[1], 2) + expect_equal(sp[[3]]$EVID[1], 0) + expect_equal(range(sp[[3]]$TIME), c(12,24)) +}) + +test_that("OCC multi-dose, addl dose_first", { + data <- occdata("multi-dose-addl.csv") + data1 <- lastdose(data) + data2 <- lastdose(data, addl_ties = "dose_first") + expect_identical(data1$OCC, data2$OCC) + expect_false(all(data1$TAD==data2$TAD)) +}) + +test_that("OCC multi-dose, addl; no observations", { + data <- occdata("multi-dose-addl-no-obs.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), c(0,1)) + sp <- split(data, data$OCC) + # The first dose is not actually an OCC + expect_equal(sp[[1]]$OCC, c(0,0)) + expect_equal(sp[[1]]$AMT, c(0,100)) + # First and only occasion + expect_true(all(sp[[2]]$OCC==1)) + expect_equal(sp[[2]]$EVID[1], 0) +}) + +test_that("OCC multi-dose, explicit; no observations", { + data <- occdata("multi-dose-explicit-no-obs.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), c(0,1)) + sp <- split(data, data$OCC) + # The first several doses are not actually an OCCs + expect_equal(sp[[1]]$OCC, c(0,0,0,0)) + expect_equal(sp[[1]]$AMT, c(0,100,100,100)) + # First and only occasion + expect_true(all(sp[[2]]$OCC==1)) + expect_equal(sp[[2]]$EVID[1], 1) +}) + +test_that("OCC handle EVID 2 and 3", { + # Check EVID 2 + data <- occdata("evid-2-3-a.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), c(0,1,2)) + sp <- split(data, data$OCC) + # Pre-dose observation + expect_equal(sp[[1]]$OCC, 0) + # First occasion + expect_true(all(sp[[2]]$OCC==1)) + expect_equal(sp[[2]]$EVID[1], 1) + expect_equal(sp[[2]]$EVID[2], 0) + expect_true(all(sp[[2]]$EVID[c(3,4,5)] > 0)) + # Second occasion + expect_true(all(sp[[3]]$OCC==2)) + expect_equal(sp[[3]]$EVID[1], 1) + expect_equal(sp[[3]]$EVID[2], 0) + + # Check EVID 3 + data <- occdata("evid-2-3-b.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), c(0,1,2)) + sp <- split(data, data$OCC) + # Pre-dose observation + expect_equal(sp[[1]]$OCC, 0) + # First occasion + expect_true(all(sp[[2]]$OCC==1)) + expect_equal(sp[[2]]$EVID[1], 1) + expect_equal(sp[[2]]$EVID[2], 0) + expect_true(all(sp[[2]]$EVID[c(3,4,5)] > 0)) + # Second occasion + expect_true(all(sp[[3]]$OCC==2)) + expect_equal(sp[[3]]$EVID[1], 1) + expect_equal(sp[[3]]$EVID[2], 0) + + # Verify that EVID 0 triggers new OCC + data <- occdata("evid-2-3-c.csv") + data <- lastdose(data) + expect_equal(unique(data$OCC), c(0,1,2,3)) + sp <- split(data, data$OCC) + # Pre-dose observation + expect_equal(sp[[1]]$OCC, 0) + # First occasion + expect_true(all(sp[[2]]$OCC==1)) + expect_equal(sp[[2]]$EVID[1], 1) + expect_equal(sp[[2]]$EVID[2], 0) + # Second occasion + expect_true(all(sp[[3]]$OCC==2)) + expect_equal(sp[[3]]$EVID[1], 1) + expect_equal(sp[[3]]$EVID[2], 3) + expect_equal(sp[[3]]$EVID[3], 0) + # Third occasion + expect_true(all(sp[[4]]$OCC==3)) + expect_equal(sp[[4]]$EVID[1], 1) + expect_equal(sp[[4]]$EVID[2], 0) +}) + +test_that("OCC resets for multiple subjects", { + data1 <- occdata("evid-2-3-a.csv") + data1$ID <- 1 + data2 <- occdata("evid-2-3-b.csv") + data2$ID <- 2 + data3 <- occdata("evid-2-3-c.csv") + data3$ID <- 3 + + data <- rbind(data1,data2) + data <- rbind(data, data3) + data$CMT <- 1 + + data <- lastdose(data) + + expect_equal(unique(data$OCC), c(0,1,2,3)) + + start <- subset(data, TIME==0) + expect_true(all(start$OCC==0)) + + a <- subset(data, TIME==6) + expect_equal(a$ID, c(1,2,3)) + expect_equal(a$OCC, c(2,2,3)) + + b <- subset(data, TIME==1) + expect_equal(b$ID, c(1,2,3)) + expect_equal(unique(b$OCC), 1) + + d <- subset(data, TIME==3) + expect_equal(d$ID, c(1,2,3)) + expect_equal(d$OCC, c(1,1,2)) +}) + +test_that("OCC handles commented dose records", { + data <- data.frame( + ID = 1, + C = c(NA, NA, "C", NA, NA, NA, NA), + TIME = c( 1, 2, 3, 4, 5, 6, 7), + AMT = 1, + EVID = c(0, 0, 1, 0, 0, 1, 0), + stringsAsFactors = FALSE + ) + # + # ID C TIME AMT EVID + # 1 1 1 0 + # 1 2 1 0 + # 1 C 3 1 1 + # 1 4 1 0 + # 1 5 1 0 + # 1 6 1 1 + # 1 7 1 0 + data <- lastdose(data) + sp <- split(data, data$OCC) + expect_equal(length(sp), 2) + expect_equal(nrow(sp[[1]]), 5) + expect_true(all(sp[[1]]$OCC==0)) + expect_equal(nrow(sp[[2]]), 2) + expect_true(all(sp[[2]]$OCC==1)) +}) + +test_that("OCC handles commented observation records", { + + data <- data.frame( + ID = 1, + C = c(NA, NA, "C", NA, NA, NA, "C", NA), + TIME = c( 1, 2, 3, 4, 5, 6, 7, 8), + AMT = 1, + EVID = c( 1, 0, 1, 0, 0, 1, 0, 2), + stringsAsFactors = FALSE + ) + # Start with a dose + # Skip past a commented dose + # Another dose at TIME==6 + # The following observation record is commented (TIME==7) + # EVID==2 won't increment OCC + # ID C TIME AMT EVID + # 1 1 1 1 + # 1 2 1 0 + # 1 C 3 1 1 + # 1 4 1 0 + # 1 5 1 0 + # 1 6 1 1 + # 1 C 7 1 0 + # 1 8 1 2 + data <- lastdose(data) + expect_true(all(data$OCC==1)) +})