#_______________________________________________________________________________
#---- observations class ----
#_______________________________________________________________________________
checkObservations <- function(object) {
check1 <- expectOneOrMore(object, "times")
check2 <- expectPositiveValues(object, "times")
check3 <- expectOne(object, "compartment")
check4 <- character()
if (object@dv %>% length() > 0 && object@dv %>% length() != object@times %>% length()) {
check4 <- "Slots 'times' and dv' don't have the same length"
}
return(c(check1, check2, check3, check4))
}
#'
#' Observations class.
#'
#' @slot times observation times, numeric vector
#' @slot compartment compartment index, integer
#' @slot dv observed values, numeric vector (FOR EXTERNAL USE)
#' @export
setClass(
"observations",
representation(
times = "numeric",
compartment = "integer",
dv="numeric"
),
contains = "pmx_element",
prototype = prototype(compartment=as.integer(NA), dv=numeric(0)),
validity = checkObservations
)
#'
#' Create an observations list. Please note that the provided 'times' will
#' automatically be sorted. Duplicated times will be removed.
#'
#' @param times observation times, numeric vector
#' @param compartment compartment index, integer
#' @return an observations list
#' @export
Observations <- function(times, compartment=NA) {
return(new("observations", times=base::sort(unique(times)), compartment=as.integer(compartment)))
}
setMethod("getName", signature = c("observations"), definition = function(x) {
return(paste0("OBS [", "TIMES=c(", paste0(x@times, collapse=","), "), ", "CMT=", x@compartment, "]"))
})
#_______________________________________________________________________________
#---- event_related_observations class ----
#_______________________________________________________________________________
setClass(
"event_related_observations",
representation(
),
contains = "observations"
)
#'
#' Create an event-related observations list. Please note that the provided 'times' will
#' automatically be sorted. Duplicated times will be removed.
#'
#' @param times observation times, numeric vector
#' @param compartment compartment index, integer
#' @return observations
#' @keywords internal
EventRelatedObservations <- function(times, compartment=NA) {
return(new("event_related_observations", times=base::sort(unique(times)), compartment=as.integer(compartment)))
}
#_______________________________________________________________________________
#---- sample ----
#_______________________________________________________________________________
#' @rdname sample
setMethod("sample", signature = c("observations", "integer"), definition = function(object, n, ...) {
args <- list(...)
config <- processExtraArg(args, name="config", mandatory=TRUE, default=DatasetConfig())
ids <- processExtraArg(args, name="ids", mandatory=TRUE, default=seq_len(n))
armID <- processExtraArg(args, name="armID", mandatory=TRUE, default=as.integer(0))
needsDV <- processExtraArg(args, name="needsDV", mandatory=TRUE, default=FALSE)
if (is.na(object@compartment)) {
obsCmt <- config@def_obs_cmt
} else {
obsCmt <- object@compartment
}
isEventRelated <- is(object, "event_related_observations")
retValue <- tibble::tibble(
ID=rep(ids, each=length(object@times)), ARM=as.integer(armID), TIME=rep(object@times, n),
EVID=as.integer(0), MDV=as.integer(0), AMT=as.numeric(NA), CMT=obsCmt, RATE=as.numeric(0), DOSENO=as.integer(NA),
INFUSION_TYPE=as.integer(NA), EVENT_RELATED=as.integer(isEventRelated)
)
if (needsDV) {
if (object@dv %>% length() > 0) {
dv <- object@dv
} else {
dv <- rep(as.numeric(0), object@times %>% length())
}
retValue <- retValue %>% tibble::add_column(DV=rep(dv, n), .before="INFUSION_TYPE")
}
return(retValue)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.