Skip to content

Commit

Permalink
Added GridEven and GridManual (#303)
Browse files Browse the repository at this point in the history
  • Loading branch information
gowerc authored Apr 8, 2024
1 parent bf5449a commit 2c22b29
Show file tree
Hide file tree
Showing 19 changed files with 415 additions and 62 deletions.
2 changes: 2 additions & 0 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -67,8 +67,10 @@ Collate:
'DataSurvival.R'
'DataJoint.R'
'Grid.R'
'GridEven.R'
'GridFixed.R'
'GridGrouped.R'
'GridManual.R'
'GridObserved.R'
'constants.R'
'StanModule.R'
Expand Down
8 changes: 8 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,11 +1,15 @@
# Generated by roxygen2: do not edit by hand

S3method(as.CmdStanMCMC,JointModelSamples)
S3method(as.QuantityCollapser,GridEven)
S3method(as.QuantityCollapser,GridFixed)
S3method(as.QuantityCollapser,GridGrouped)
S3method(as.QuantityCollapser,GridManual)
S3method(as.QuantityCollapser,GridObserved)
S3method(as.QuantityGenerator,GridEven)
S3method(as.QuantityGenerator,GridFixed)
S3method(as.QuantityGenerator,GridGrouped)
S3method(as.QuantityGenerator,GridManual)
S3method(as.QuantityGenerator,GridObserved)
S3method(as.StanModule,JointModel)
S3method(as.StanModule,Link)
Expand All @@ -27,8 +31,10 @@ S3method(as.list,DataJoint)
S3method(as.list,DataLongitudinal)
S3method(as.list,DataSubject)
S3method(as.list,DataSurvival)
S3method(as.list,GridEven)
S3method(as.list,GridFixed)
S3method(as.list,GridGrouped)
S3method(as.list,GridManual)
S3method(as.list,GridObserved)
S3method(as.list,Link)
S3method(as.list,LinkComponent)
Expand Down Expand Up @@ -113,8 +119,10 @@ export(DataJoint)
export(DataLongitudinal)
export(DataSubject)
export(DataSurvival)
export(GridEven)
export(GridFixed)
export(GridGrouped)
export(GridManual)
export(GridObserved)
export(JointModel)
export(Link)
Expand Down
4 changes: 2 additions & 2 deletions R/DataJoint.R
Original file line number Diff line number Diff line change
Expand Up @@ -188,7 +188,7 @@ subset.DataJoint <- function(x, patients, ...) {
dat <- data.frame(
time = data[["event_times"]],
event = as.numeric(seq_along(data[["event_times"]]) %in% data[["subject_event_index"]]),
patient = names(data[["pt_to_ind"]])
patient = names(data[["subject_to_index"]])
)
subset_and_add_grouping(dat, patients)
}
Expand Down Expand Up @@ -246,7 +246,7 @@ extract_observed_values <- function(object) {
assert_class(object, "DataJoint")
data <- as.list(object)
x <- data.frame(
subject = names(data$pt_to_ind)[data$subject_tumour_index],
subject = names(data$subject_to_index)[data$subject_tumour_index],
time = data$tumour_time,
Yob = data$tumour_value
)
Expand Down
2 changes: 1 addition & 1 deletion R/DataSubject.R
Original file line number Diff line number Diff line change
Expand Up @@ -111,7 +111,7 @@ as_stan_list.DataSubject <- function(object, ...) {
n_arms = length(unique(df[[vars$arm]])),
subject_study_index = as.numeric(df[[vars$study]]),
subject_arm_index = as.numeric(df[[vars$arm]]),
pt_to_ind = stats::setNames(
subject_to_index = stats::setNames(
seq_len(nlevels(df[[vars$subject]])),
levels(df[[vars$subject]])
)
Expand Down
55 changes: 54 additions & 1 deletion R/Grid.R
Original file line number Diff line number Diff line change
Expand Up @@ -7,11 +7,30 @@
#' If `NULL` will default to 201 evenly spaced timepoints between 0 and either the max
#' observation time (for [`LongitudinalQuantities`]) or max event time (for [`SurvivalQuantities`]).
#' @param groups (`list`)\cr named list of subjects to extract quantities for. See Group Specification.
#'
#' @param spec (`list`)\cr named list of subjects to extract quantities for. The names of each
#' element should be the required subjects with the element itself being a numeric vector of timepoints
#' to generate the quantity at.
#' @param length.out (`numeric`)\cr number of evenly spaced timepoints to generate quantities at.
#' @description
#' These functions are used to specify which subjects and timepoints should be generated
#' when calculating quantities via [`SurvivalQuantities`] and [`LongitudinalQuantities`].
#'
#' @details
#'
#' - `GridFixed()` is used to specify a fixed set of timepoints to generate quantities at for
#' all the specified subjects.
#'
#' - `GridGrouped()` is similar to `GridFixed()` but allows for groupwise averaging
#' (see Group Specification).
#'
#' - `GridObserved()` generates quantities at the observed longitudinal timepoints for each
#' subject.
#'
#' - `GridManual()` allows for individual timepoint specification for each subject.
#'
#' - `GridEven()` generates quantities for each subject at N evenly spaced timepoints
#' between each subjects first and last longitudinal observations.
#'
#' @section Group Specification:
#' For `GridGrouped()`, `groups` must be a named list of character vectors. Each element of the list
#' must be a character vector of the subjects that will form the group where the element name
Expand Down Expand Up @@ -163,3 +182,37 @@ setValidity(
length.QuantityCollapser <- function(x) {
length(x@indexes)
}


#' Expand and Validate Subjects
#'
#' @param subjects (`character`)\cr vector of subjects that should exist in `data`
#' @param data (`DataJoint`)\cr Survival and Longitudinal Data.
#'
#' @description
#' If `subjects` is `NULL` this will return a named list of all subjects in `data`.
#' Else it will return `subjects` as a named list ensuring that all subjects exist in `data`.
#'
#' @keywords internal
subjects_to_list <- function(subjects = NULL, data) {
data_list <- as.list(data)
subjects_exp <- if (is.null(subjects)) {
subs <- as.list(names(data_list$subject_to_index))
names(subs) <- names(data_list$subject_to_index)
subs
} else {
subs <- as.list(subjects)
names(subs) <- subjects
subs
}
subjects_exp_vec <- unlist(subjects_exp, use.names = FALSE)
assert_that(
identical(subjects_exp_vec, unique(subjects_exp_vec)),
msg = "All subject names must be unique"
)
assert_that(
all(subjects_exp_vec %in% names(data_list$subject_to_index)),
msg = "Not all subjects exist within the data object"
)
subjects_exp
}
82 changes: 82 additions & 0 deletions R/GridEven.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,82 @@

#' @include Grid.R
#' @include generics.R
NULL


#' @rdname Grid-Dev
.GridEven <- setClass(
"GridEven",
contains = "Grid",
slots = c(
"subjects" = "character",
"length.out" = "numeric"
)
)


#' @rdname Grid-Functions
#' @export
GridEven <- function(subjects = NULL, length.out = 30) {
.GridEven(
subjects = subjects,
length.out = length.out
)
}


setValidity(
"GridEven",
function(object) {
if (length(object@length.out) != 1 || all(object@length.out <= 0)) {
return("The `length.out` argument must be a positive integer")
}
}
)


#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridEven <- function(object, data, ...) {
assert_class(data, "DataJoint")
data_list <- as.list(data)
subjects <- unlist(as.list(object, data = data), use.names = FALSE)
assert_that(
all(subjects %in% names(data_list$subject_to_index)),
msg = "All subject names must be in the `DataSubject` object"
)

spec <- lapply(
subjects,
\(sub) {
subject_index <- data_list$subject_to_index[[sub]]
time_index <- data_list$subject_tumour_index == subject_index
subject_times <- data_list$tumour_time[time_index]
seq(min(subject_times), max(subject_times), length.out = object@length.out)
}
)
names(spec) <- subjects

as.QuantityGenerator(
GridManual(spec),
data = data
)
}


#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridEven <- function(object, data, ...) {
generator <- as.QuantityGenerator(object, data)
QuantityCollapser(
times = generator@times,
groups = generator@subjects,
indexes = as.list(seq_along(generator@times))
)
}


#' @export
as.list.GridEven <- function(x, data, ...) {
subjects_to_list(x@subjects, data)
}
18 changes: 1 addition & 17 deletions R/GridFixed.R
Original file line number Diff line number Diff line change
Expand Up @@ -56,21 +56,5 @@ as.QuantityCollapser.GridFixed <- function(object, data, ...) {

#' @export
as.list.GridFixed <- function(x, data, ...) {
data_list <- as.list(data)
subjects <- if (is.null(x@subjects)) {
subs <- as.list(names(data_list$pt_to_ind))
names(subs) <- names(data_list$pt_to_ind)
subs
} else {
subs <- as.list(x@subjects)
names(subs) <- x@subjects
subs
}
assert_that(
identical(
unlist(subjects, use.names = FALSE),
unique(unlist(subjects, use.names = FALSE))
)
)
subjects
subjects_to_list(x@subjects, data)
}
4 changes: 2 additions & 2 deletions R/GridGrouped.R
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ as.QuantityGenerator.GridGrouped <- function(object, data, ...) {
data_list <- as.list(data)
patients_unique <- unique(unlist(object@groups))
assert_that(
all(patients_unique %in% names(data_list$pt_to_ind))
all(patients_unique %in% names(data_list$subject_to_index))
)
as.QuantityGenerator(
GridFixed(
Expand All @@ -64,7 +64,7 @@ as.QuantityCollapser.GridGrouped <- function(object, data, ...) {
assert_class(data, "DataJoint")
data_list <- as.list(data)
assert_that(
all(unique(unlist(object@groups)) %in% names(data_list$pt_to_ind))
all(unique(unlist(object@groups)) %in% names(data_list$subject_to_index))
)
time_grid <- expand_time_grid(object@times, max(data_list[["tumour_time"]]))

Expand Down
81 changes: 81 additions & 0 deletions R/GridManual.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,81 @@

#' @include Grid.R
#' @include generics.R
NULL


#' @rdname Grid-Dev
.GridManual <- setClass(
"GridManual",
contains = "Grid",
slots = c(
"spec" = "list"
)
)


#' @rdname Grid-Functions
#' @export
GridManual <- function(spec) {
.GridManual(
spec = spec
)
}


setValidity(
"GridManual",
function(object) {
subject_names <- names(object@spec)
subject_names_valid <- subject_names[!is.na(subject_names) & subject_names != ""]
if (length(subject_names_valid) != length(object@spec)) {
return("Each element of `subjects` must be named")
}
for (times in object@spec) {
if (!is.numeric(times)) {
return("Each element of `spec` must be a numeric vector")
}
if (length(times) != length(unique(times))) {
return("Each time vector per subject must be unique")
}
}
return(TRUE)
}
)


#' @rdname Quant-Dev
#' @export
as.QuantityGenerator.GridManual <- function(object, data, ...) {
assert_class(data, "DataJoint")
data_list <- as.list(data)
assert_that(
all(names(object@spec) %in% names(data_list$subject_to_index)),
msg = "All subject names must be in the `DataSubject` object"
)
lens <- vapply(object@spec, length, numeric(1))
.QuantityGenerator(
times = unlist(object@spec, use.names = FALSE),
subjects = rep(names(object@spec), lens)
)
}


#' @rdname Quant-Dev
#' @export
as.QuantityCollapser.GridManual <- function(object, data, ...) {
generator <- as.QuantityGenerator(object, data)
QuantityCollapser(
times = generator@times,
groups = generator@subjects,
indexes = as.list(seq_along(generator@times))
)
}


#' @export
as.list.GridManual <- function(x, data, ...) {
subs <- as.list(names(x@spec))
names(subs) <- names(x@spec)
subs
}
20 changes: 2 additions & 18 deletions R/GridObserved.R
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,7 @@ as.QuantityGenerator.GridObserved <- function(object, data, ...) {
data_list <- as.list(data)
subjects <- unlist(as.list(object, data = data), use.names = FALSE)
unique_visits <- tapply(data_list$tumour_time, data_list$subject_tumour_index, unique)
patient_visits <- unique_visits[data_list$pt_to_ind[subjects]]
patient_visits <- unique_visits[data_list$subject_to_index[subjects]]
visit_lengths <- vapply(patient_visits, length, numeric(1))
.QuantityGenerator(
times = unlist(patient_visits, use.names = FALSE),
Expand All @@ -49,21 +49,5 @@ as.QuantityCollapser.GridObserved <- function(object, data, ...) {

#' @export
as.list.GridObserved <- function(x, data, ...) {
data_list <- as.list(data)
subjects <- if (is.null(x@subjects)) {
subs <- as.list(names(data_list$pt_to_ind))
names(subs) <- names(data_list$pt_to_ind)
subs
} else {
subs <- as.list(x@subjects)
names(subs) <- x@subjects
subs
}
assert_that(
identical(
unlist(subjects, use.names = FALSE),
unique(unlist(subjects, use.names = FALSE))
)
)
subjects
subjects_to_list(x@subjects, data)
}
Loading

0 comments on commit 2c22b29

Please sign in to comment.