Nothing
#' @importFrom nlme getGroups
#' @export
nlme::getGroups
#' Get the dependent variable (left hand side of the formula) from a
#' PKNCA object.
#'
#' @param x The object to extract the formula from
#' @param \dots Unused
#' @return The vector of the dependent variable from the object.
#' @family PKNCA object extractors
#' @export
getDepVar <- function(x, ...) {
UseMethod("getDepVar", x)
}
#' Get the independent variable (right hand side of the formula) from
#' a PKNCA object.
#'
#' @param x The object to extract the formula from
#' @param \dots Unused
#' @return The vector of the independent variable from the object.
#' @family PKNCA object extractors
#' @export
getIndepVar <- function(x, ...) {
UseMethod("getIndepVar", x)
}
#' Get the value from a column in a data frame if the value is a column
#' there, otherwise, the value should be a scalar or the length of the
#' data.
#'
#' @param data A data.frame or similar object
#' @param value A character string giving the name of a column in the
#' \code{data}, a scalar, or a vector the same length as the
#' \code{data}
#' @param prefix The prefix to use if a column must be added (it will be
#' used as the full column name if it is not already in the dataset or
#' it will be prepended to the maximum column name if not.)
#' @return A list with elements named "data", "name" giving the
#' \code{data} with a column named "name" with the value in that
#' column.
getColumnValueOrNot <- function(data, value, prefix="X") {
col.name <- setdiff(c(prefix, paste(prefix, max(names(data)), sep=".")), names(data))[1]
if (is.character(value) && length(value) == 1 && (value %in% names(data))) {
# It was a column from the data.frame
ret <- list(data=data, name=value)
} else if (length(value) %in% c(1, nrow(data))) {
data[[col.name]] <- value
ret <- list(data=data, name=col.name)
} else {
stop("value was not a column name nor was it a scalar or a vector matching the length of the data.")
}
ret
}
#' Get the name of the element containing the data for the current
#' object.
#'
#' @param object The object to get the data name from.
#' @family PKNCA object extractors
#' @return A character scalar with the name of the data object (or NULL
#' if the method does not apply).
#' @keywords Internal
getDataName <- function(object) {
UseMethod("getDataName")
}
#' @describeIn getDataName If no data name exists, returns NULL.
getDataName.default <- function(object) {
NULL
}
#' Add an attribute to an object where the attribute is added as a name
#' to the names of the object.
#'
#' @param object The object to set the attribute column on.
#' @param attr_name The attribute name to set
#' @param col_or_value If this exists as a column in the data, it is used as the
#' \code{col_name}. If not, this becomes the \code{default_value}.
#' @param col_name The name of the column within the dataset to use (if missing,
#' uses \code{attr_name})
#' @param default_value The value to fill in the column if the column does not
#' exist (the column is filled with \code{NA} if it does not exist and no
#' value is provided).
#' @param stop_if_default,warn_if_default,message_if_default A character string
#' to provide as an error, a warning, or a message to the user if the
#' \code{default_value} is used. They are tested in order (if stop, the code
#' stops; if warning, the message is ignored; and message last).
#' @return The object with the attribute column added to the data.
#' @seealso \code{\link{getAttributeColumn}}
setAttributeColumn <- function(object, attr_name, col_or_value, col_name, default_value,
stop_if_default, warn_if_default, message_if_default) {
dataname <- getDataName(object)
# Check inputs
if (!is.character(attr_name) | (length(attr_name) != 1)) {
stop("attr_name must be a character scalar.")
}
if (!missing(col_or_value) &
any(!c(missing(col_name), missing(default_value)))) {
stop("Cannot provide col_or_value and col_name or default_value")
}
# Apply col_or_value to col_name or to default_value
if (!missing(col_or_value)) {
if (all(col_or_value %in% names(object[[dataname]]))) {
col_name <- col_or_value
} else {
default_value <- col_or_value
}
}
# Set the column name
if (missing(col_name)) {
col_name <- attr_name
if (attr_name %in% names(object[[dataname]])) {
rlang::inform(
message = paste0("Found column named ", attr_name, ", using it for the attribute of the same name."),
class = paste0("pknca_foundcolumn_", attr_name)
)
}
} else if (!is.character(col_name) | (length(col_name) != 1)) {
stop("col_name must be a character scalar.")
}
# Set the default value
if (missing(default_value)) {
if (col_name %in% names(object[[dataname]])) {
default_value <- object[[dataname]][[col_name]]
} else {
default_value <- NA
# React to using the default value, if requested
if (!missing(stop_if_default)) {
stop(stop_if_default)
} else if (!missing(warn_if_default)) {
warning(warn_if_default)
} else if (!missing(message_if_default)) {
message(message_if_default)
}
}
}
# Check that the default_value can work
if (!(length(default_value) %in% c(1, nrow(object[[dataname]])))) {
stop("default_value must be a scalar or the same length as the rows in the data.")
}
object[[dataname]][[col_name]] <- default_value
# Inform the object that the column exists
if (!("columns" %in% names(object))) {
object$columns <- list()
}
object$columns[[attr_name]] <- col_name
object
}
#' Retrieve the value of an attribute column.
#'
#' @param object The object to extract the attribute value from.
#' @param attr_name The name of the attribute to extract
#' @param warn_missing Give a warning if the "attr"ibute or "column" is
#' missing. Character vector with zero, one, or both of "attr" and
#' "column".
#' @return The value of the attribute (or \code{NULL} if the attribute
#' is not set or the column does not exist)
getAttributeColumn <- function(object, attr_name, warn_missing=c("attr", "column")) {
if (length(setdiff(warn_missing, c("attr", "column")))) {
stop("warn_missing must have a valid value or be empty")
}
warn_missing <- warn_missing[warn_missing %in% c("attr", "column")]
columns <- object$columns[[attr_name]]
dataname <- getDataName(object)
if (is.null(columns)) {
if ("attr" %in% warn_missing)
warning(attr_name, " is not set.")
NULL
} else if (length(missing_cols <- setdiff(columns, names(object[[dataname]])))) {
if ("column" %in% warn_missing)
warning("Columns ", paste(missing_cols, collapse=", "), " are not present.")
NULL
} else {
object[[dataname]][, columns, drop=FALSE]
}
}
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.