-
Notifications
You must be signed in to change notification settings - Fork 23
/
class-general.R
176 lines (169 loc) · 6.64 KB
/
class-general.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
#' @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
#' @returns 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
#' @returns 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 `data`, a
#' scalar, or a vector the same length as the `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.)
#' @returns A list with elements named "data", "name" giving the `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
#' `col_name`. If not, this becomes the `default_value`.
#' @param col_name The name of the column within the dataset to use (if missing,
#' uses `attr_name`)
#' @param default_value The value to fill in the column if the column does not
#' exist (the column is filled with `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
#' `default_value` is used. They are tested in order (if stop, the code
#' stops; if warning, the message is ignored; and message last).
#' @returns The object with the attribute column added to the data.
#' @seealso [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".
#' @returns The value of the attribute (or `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]
}
}