Nothing
# Copyright (C) 2013 - 2023 Metrum Research Group
#
# This file is part of mrgsolve.
#
# mrgsolve is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# mrgsolve is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with mrgsolve. If not, see <http://www.gnu.org/licenses/>.
is.valid_data_set <- function(x) {
inherits(x, "valid_data_set")
}
is.valid_idata_set <- function(x) {
inherits(x, "valid_idata_set")
}
idcol <- function(x) {
match("ID", colnames(x))
}
timename <- function(x) {
y <- c("time", "TIME")
y[y %in% .colnames(x)][1]
}
cmtname <- function(x) {
y <- c("cmt", "CMT")
y[y %in% .colnames(x)][1]
}
numeric_data_matrix <- function(x, quiet = FALSE) {
x <- do.call(cbind, numerics_only(x, quiet))
if(ncol(x)==0) stop("invalid data set.", call.=FALSE)
x
}
##' Prepare data.frame for input to mrgsim
##'
##' @param x a input data set
##' @param quiet logical indicating whether or not warnings
##' should be printed
##' @param convert_lgl if \code{TRUE}, convert logical
##' columns with \code{\link{as.integer}}
##'
##' @export
numerics_only <- function(x, quiet = FALSE, convert_lgl = FALSE) {
if(convert_lgl) {
if(any(vapply(x,is.logical,TRUE))) {
x <- mutate_if(x, is.logical, as.integer)
}
}
nu <- vapply(x, bare_numeric, TRUE)
if(!all(nu)) {
if(!quiet) {
message(
"Dropping non-numeric columns: \n ",
paste(names(x)[!nu], collapse = " ")
)
}
x <- x[, which(nu), drop = FALSE]
}
x
}
convert_character_cmt <- function(data, mod) {
cmtcol <- cmtname(data)
for(cm in cmtcol) {
if(is.character(data[[cm]])) {
data[[cm]] <- match(data[[cm]], Cmt(mod), 0L)
}
}
return(data)
}
signal_drop <- function(dm, x, to_signal, context) {
drop <- setdiff(names(x), dimnames(dm)[[2]])
drop <- intersect(drop, to_signal)
for(d in drop) {
type <- paste0(class(x[[d]]), collapse = ",")
msg <- c(context, " dropped column: ", d, " (", type, ")")
message(msg)
}
invisible(NULL)
}
##' Validate and prepare a data sets for simulation
##'
##' This function is called by mrgsim. Users may also call this function
##' to pre-validate data when the same data set is used for repeated
##' simulation.
##'
##' @param x data.frame or matrix
##' @param m a model object
##' @param verbose logical
##' @param quiet if \code{TRUE}, messages will be suppressed
##'
##' @return A matrix with non-numeric columns dropped; if x is a
##' data.frame with character \code{cmt} column comprised of valid
##' compartment names and \code{m} is a model object,
##' the \code{cmt} column will be converted to the corresponding
##' compartment number.
##'
##' @seealso \code{\link{valid_idata_set}}, \code{\link{idata_set}},
##' \code{\link{data_set}}
##'
##' @examples
##'
##' mod <- mrgsolve::house()
##'
##' data(exTheoph)
##'
##' d <- valid_data_set(exTheoph,mod)
##'
##' @export
valid_data_set <- function(x, m = NULL, verbose = FALSE, quiet = FALSE) {
if(is.valid_data_set(x)) return(x)
if(verbose) quiet <- FALSE
if(!is.mrgmod(m)) {
stop("a valid model object is required to validate the data set.",
call. = FALSE)
}
x <- as.data.frame(x)
if(nrow(x)==0) {
stop("input data event object has zero rows", call. = FALSE)
}
# check for ID column
if(!has_ID(x)) {
stop("could not find ID column in data set", call. = FALSE)
}
# special case
if(ncol(x)==1) {
x <- numeric_data_matrix(x,quiet=TRUE)
class(x) <- c("valid_data_set", "matrix")
return(x)
}
# First, check for compartment
cmtcol <- cmtname(x)
if(!is.na(cmtcol)) {
if(any(is.na(x[,cmtcol]))) {
stop("Found missing value in cmt/CMT column")
}
if(is.character(x[[cmtcol]])) {
if(verbose) message("Converting cmt to integer")
x[[cmtcol]] <- match(x[[cmtcol]], Cmt(m), 0)
}
}
tcol <- timename(x)
if(is.na(tcol)) {
if(neq(m) > 0) {
stop(
"A time or TIME column is required in the data set item with this model.",
call. = FALSE
)
}
}
# Drop character columns
dm <- numeric_data_matrix(x,quiet=TRUE)
if((ncol(dm) != ncol(x)) && !quiet) {
to_signal <- c(Pars(m), GLOBALS$CARRY_TRAN)
signal_drop(dm, x, to_signal, context = "[data-set]")
}
has_na <- check_data_set_na(dm,m)
if(has_na) {
dm <- fill_tran_na(dm)
}
dm <- cbind(dm, matrix(0,
ncol=1,
nrow=nrow(dm),
dimnames=list(NULL, "..zeros..")))
# Look for both upper and lower case column names
uc <- any(dimnames(dm)[[2]] %in% GLOBALS[["TRAN_UPPER"]])
lc <- any(dimnames(dm)[[2]] %in% GLOBALS[["TRAN_LOWER"]])
if(uc & lc) {
warning("Both lower- & upper-case names found in the data set.\n",
"Please use either:\n",
" time,amt,cmt,evid,ii,addl,ss,rate\n",
"or:\n",
" TIME,AMT,CMT,EVID,II,ADDL,SS,RATE\n", call.=FALSE)
}
class(dm) <- c("valid_data_set", "matrix")
dm
}
##' Validate and prepare idata data sets for simulation
##'
##' @return A numeric matrix with class \code{valid_idata_set}.
##'
##' @inheritParams valid_data_set
##'
##' @seealso \code{\link{valid_data_set}}, \code{\link{idata_set}},
##' \code{\link{data_set}}
##'
##' @export
valid_idata_set <- function(x, m, verbose = FALSE, quiet = FALSE) {
if(verbose) quiet <- FALSE
if(is.valid_idata_set(x)) return(x)
x <- as.data.frame(x)
if(!has_ID(x)) {
stop("ID is a required column for idata_set.",call.=FALSE)
}
if(anyDuplicated(x[["ID"]])) {
stop("Duplicate IDs not allowed in idata_set.",call.=FALSE)
}
dm <- numeric_data_matrix(x, quiet = TRUE)
if((ncol(dm) != ncol(x)) && !quiet) {
to_signal <- Pars(m)
signal_drop(dm, x, to_signal, context = "[idata-set]")
}
check_data_set_na(dm, m)
class(dm) <- c("valid_idata_set", "matrix")
dm
}
#' @rdname valid_data_set
#' @export
valid_data_set.matrix <- function(x,verbose=FALSE) {
if(is.valid_data_set(x)) return(x)
if(is.numeric(x)) {
return(valid_data_set(as.data.frame(x)))
}
stop("Input data matrix is not numeric.",call.=FALSE)
}
check_data_set_na <- function(data,m) {
if(!anyNA(data)) return(invisible(FALSE))
err <- FALSE
flagged <- check_column_na(data, Pars(m))
for(col in flagged) {
warning(
"Parameter column ", col, " must not contain missing values.",
call.=FALSE, immediate.=TRUE
)
}
flagged <- check_column_na(data, c("ID", "TIME", "time"))
for(col in flagged) {
message(
col,
" column must not contain missing values.",
call.=FALSE, immediate.=TRUE
)
err <- TRUE
}
if(err) stop("Found missing values in input data.", call.=FALSE)
return(invisible(TRUE))
}
#' Look for TRAN columns replace NA with 0
#' Columns to scan are found in `GLOBALS$TRAN_FILL_NA`
#' @noRd
fill_tran_na <- function(data) {
cols_to_zero <- check_column_na(data, GLOBALS[["TRAN_FILL_NA"]])
data[, cols_to_zero][is.na(data[, cols_to_zero])] <- 0
data
}
check_column_na <- function(data, cols) {
to_check <- unique(cols[cols %in% dimnames(data)[[2L]]])
if(length(to_check)==0L) return(character(0))
if(!anyNA(data[,to_check])) return(character(0))
flagged <- character(0)
for(col in to_check) {
if(anyNA(data[,col])) {
flagged <- c(flagged, col)
}
}
flagged
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.