From 0eb2fbd24b9ae33456d4011eba8bfed9360403e8 Mon Sep 17 00:00:00 2001 From: Lauren-Eyler Date: Wed, 27 Jan 2021 16:43:03 -0800 Subject: [PATCH 1/6] Create folds_subgroup_funcs.R Add subgroup-specific cross-validation folds --- R/folds_subgroup_funcs.R | 61 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 R/folds_subgroup_funcs.R diff --git a/R/folds_subgroup_funcs.R b/R/folds_subgroup_funcs.R new file mode 100644 index 0000000..37235d9 --- /dev/null +++ b/R/folds_subgroup_funcs.R @@ -0,0 +1,61 @@ +`%notin%` <- Negate(`%in%`) + +fold_from_foldvec_subgroup <- function(v, foldsdf, n) { + validation_set <- foldsdf[,1][which(foldsdf[,2] == v)] + training_set <- which(seq_len(n) %notin% validation_set) + make_fold(v, training_set, validation_set) +} + +fold_from_foldvec_subgroup_stratoutcome <- function(v, foldsdf1, foldsdf2, n) { + validation_set <- c(foldsdf1[,1][which(foldsdf1[,2] == v)], foldsdf2[,1][which(foldsdf2[,2] == v)]) + training_set <- which(seq_len(n) %notin% validation_set) + make_fold(v, training_set, validation_set) +} + +folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { + + if(is.null(strat_outcome)==TRUE){ + + subgroup_index <- which(subgroup == 1) + + #if (length(subgroup_index) <= V) { + # warning("number in subgroup <= V so using leave-one-out CV") + # return(folds_loo(subgroup_index)) + #} + + folds <- rep(seq_len(V), length = length(subgroup_index)) + + # shuffle folds + folds <- sample(folds) + foldsdf <- data.frame(subgroup_index, folds) + + # generate fold vectors + folds <- lapply(seq_len(V), fold_from_foldvec_subgroup, foldsdf, n) + return(folds) + + } + else { + subgroup_index1 <- which(subgroup == 1 & strat_outcome == 1) + subgroup_index2 <- which(subgroup == 1 & strat_outcome == 0) + + #if (length(subgroup_index) <= V) { + # warning("number in subgroup <= V so using leave-one-out CV") + # return(folds_loo(subgroup_index)) + #} + + #Two sets of folds, one for outcome == 1 and one for outcome == 0 + folds1 <- rep(seq_len(V), length = length(subgroup_index1)) + folds2 <- rep(seq_len(V), length = length(subgroup_index2)) + + # shuffle folds + folds1 <- sample(folds1) + foldsdf1 <- data.frame(subgroup_index1, folds1) + + folds2 <- sample(folds2) + foldsdf2 <- data.frame(subgroup_index2, folds2) + + # generate fold vectors + folds <- lapply(seq_len(V), fold_from_foldvec_subgroup_stratoutcome, foldsdf1, foldsdf2, n) + return(folds) + } +} \ No newline at end of file From 7d7dc8400caa4a839d4153974a7330a221d0893e Mon Sep 17 00:00:00 2001 From: Lauren-Eyler Date: Wed, 27 Jan 2021 17:02:29 -0800 Subject: [PATCH 2/6] moved folds_subgroup into fold_funs --- R/fold_funs.R | 65 ++++++++++++++++++++++++++++++++++++++++ R/folds_subgroup_funcs.R | 61 ------------------------------------- 2 files changed, 65 insertions(+), 61 deletions(-) delete mode 100644 R/folds_subgroup_funcs.R diff --git a/R/fold_funs.R b/R/fold_funs.R index 67db76c..188d228 100644 --- a/R/fold_funs.R +++ b/R/fold_funs.R @@ -411,3 +411,68 @@ check_id_and_time <- function(id, time) { ) } } + +######################################################### +#Add option to make subgroup-specific cross-validation folds + +`%notin%` <- Negate(`%in%`) + +fold_from_foldvec_subgroup <- function(v, foldsdf, n) { + validation_set <- foldsdf[,1][which(foldsdf[,2] == v)] + training_set <- which(seq_len(n) %notin% validation_set) + make_fold(v, training_set, validation_set) +} + +fold_from_foldvec_subgroup_stratoutcome <- function(v, foldsdf1, foldsdf2, n) { + validation_set <- c(foldsdf1[,1][which(foldsdf1[,2] == v)], foldsdf2[,1][which(foldsdf2[,2] == v)]) + training_set <- which(seq_len(n) %notin% validation_set) + make_fold(v, training_set, validation_set) +} + +folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { + + if(is.null(strat_outcome)==TRUE){ + + subgroup_index <- which(subgroup == 1) + + #if (length(subgroup_index) <= V) { + # warning("number in subgroup <= V so using leave-one-out CV") + # return(folds_loo(subgroup_index)) + #} + + folds <- rep(seq_len(V), length = length(subgroup_index)) + + # shuffle folds + folds <- sample(folds) + foldsdf <- data.frame(subgroup_index, folds) + + # generate fold vectors + folds <- lapply(seq_len(V), fold_from_foldvec_subgroup, foldsdf, n) + return(folds) + + } + else { + subgroup_index1 <- which(subgroup == 1 & strat_outcome == 1) + subgroup_index2 <- which(subgroup == 1 & strat_outcome == 0) + + #if (length(subgroup_index) <= V) { + # warning("number in subgroup <= V so using leave-one-out CV") + # return(folds_loo(subgroup_index)) + #} + + #Two sets of folds, one for outcome == 1 and one for outcome == 0 + folds1 <- rep(seq_len(V), length = length(subgroup_index1)) + folds2 <- rep(seq_len(V), length = length(subgroup_index2)) + + # shuffle folds + folds1 <- sample(folds1) + foldsdf1 <- data.frame(subgroup_index1, folds1) + + folds2 <- sample(folds2) + foldsdf2 <- data.frame(subgroup_index2, folds2) + + # generate fold vectors + folds <- lapply(seq_len(V), fold_from_foldvec_subgroup_stratoutcome, foldsdf1, foldsdf2, n) + return(folds) + } +} diff --git a/R/folds_subgroup_funcs.R b/R/folds_subgroup_funcs.R deleted file mode 100644 index 37235d9..0000000 --- a/R/folds_subgroup_funcs.R +++ /dev/null @@ -1,61 +0,0 @@ -`%notin%` <- Negate(`%in%`) - -fold_from_foldvec_subgroup <- function(v, foldsdf, n) { - validation_set <- foldsdf[,1][which(foldsdf[,2] == v)] - training_set <- which(seq_len(n) %notin% validation_set) - make_fold(v, training_set, validation_set) -} - -fold_from_foldvec_subgroup_stratoutcome <- function(v, foldsdf1, foldsdf2, n) { - validation_set <- c(foldsdf1[,1][which(foldsdf1[,2] == v)], foldsdf2[,1][which(foldsdf2[,2] == v)]) - training_set <- which(seq_len(n) %notin% validation_set) - make_fold(v, training_set, validation_set) -} - -folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { - - if(is.null(strat_outcome)==TRUE){ - - subgroup_index <- which(subgroup == 1) - - #if (length(subgroup_index) <= V) { - # warning("number in subgroup <= V so using leave-one-out CV") - # return(folds_loo(subgroup_index)) - #} - - folds <- rep(seq_len(V), length = length(subgroup_index)) - - # shuffle folds - folds <- sample(folds) - foldsdf <- data.frame(subgroup_index, folds) - - # generate fold vectors - folds <- lapply(seq_len(V), fold_from_foldvec_subgroup, foldsdf, n) - return(folds) - - } - else { - subgroup_index1 <- which(subgroup == 1 & strat_outcome == 1) - subgroup_index2 <- which(subgroup == 1 & strat_outcome == 0) - - #if (length(subgroup_index) <= V) { - # warning("number in subgroup <= V so using leave-one-out CV") - # return(folds_loo(subgroup_index)) - #} - - #Two sets of folds, one for outcome == 1 and one for outcome == 0 - folds1 <- rep(seq_len(V), length = length(subgroup_index1)) - folds2 <- rep(seq_len(V), length = length(subgroup_index2)) - - # shuffle folds - folds1 <- sample(folds1) - foldsdf1 <- data.frame(subgroup_index1, folds1) - - folds2 <- sample(folds2) - foldsdf2 <- data.frame(subgroup_index2, folds2) - - # generate fold vectors - folds <- lapply(seq_len(V), fold_from_foldvec_subgroup_stratoutcome, foldsdf1, foldsdf2, n) - return(folds) - } -} \ No newline at end of file From 0b8bb3575b8deea7e1723039d66b229b2348fd92 Mon Sep 17 00:00:00 2001 From: Lauren-Eyler Date: Wed, 27 Jan 2021 17:32:04 -0800 Subject: [PATCH 3/6] Update fold_funs.R --- R/fold_funs.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/fold_funs.R b/R/fold_funs.R index 188d228..0fe9e07 100644 --- a/R/fold_funs.R +++ b/R/fold_funs.R @@ -415,20 +415,28 @@ check_id_and_time <- function(id, time) { ######################################################### #Add option to make subgroup-specific cross-validation folds +#' @rdname fold_funs +#' @export `%notin%` <- Negate(`%in%`) +#' @rdname fold_funs +#' @export fold_from_foldvec_subgroup <- function(v, foldsdf, n) { validation_set <- foldsdf[,1][which(foldsdf[,2] == v)] training_set <- which(seq_len(n) %notin% validation_set) make_fold(v, training_set, validation_set) } +#' @rdname fold_funs +#' @export fold_from_foldvec_subgroup_stratoutcome <- function(v, foldsdf1, foldsdf2, n) { validation_set <- c(foldsdf1[,1][which(foldsdf1[,2] == v)], foldsdf2[,1][which(foldsdf2[,2] == v)]) training_set <- which(seq_len(n) %notin% validation_set) make_fold(v, training_set, validation_set) } +#' @rdname fold_funs +#' @export folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { if(is.null(strat_outcome)==TRUE){ From 8c8bcbda24d30bd336901851ce3d22ce7633d667 Mon Sep 17 00:00:00 2001 From: Lauren-Eyler Date: Wed, 27 Jan 2021 17:41:35 -0800 Subject: [PATCH 4/6] Update fold_funs.R --- R/fold_funs.R | 89 ++++++++++++++++++++++++++------------------------- 1 file changed, 46 insertions(+), 43 deletions(-) diff --git a/R/fold_funs.R b/R/fold_funs.R index 0fe9e07..eb3a1d6 100644 --- a/R/fold_funs.R +++ b/R/fold_funs.R @@ -369,49 +369,6 @@ folds_vfold_rolling_window_pooled <- function(n, t, id = NULL, time = NULL, return(folds) } -############################################################################### - -#' Check ID and Time Compatibility -#' -#' @param id An optional vector of unique identifiers corresponding to the time -#' vector. These can be used to subset the time vector. -#' @param time An optional vector of integers of time points observed for each -#' subject in the sample. -#' -#' @importFrom assertthat assert_that -#' -#' @keywords internal -check_id_and_time <- function(id, time) { - # check that both time and ID are provided, or that neither are provided - msg_time_id <- paste( - "Cannot create flexible folds (allow for variability", - "in the amount of time observed for each id) unless", - "both `time` and `id` arguments are provided. Either", - "provide both `time` and `id` or neither." - ) - assertthat::assert_that(!(!is.null(id) & is.null(time)) || - !(is.null(id) & !is.null(time)), - msg = msg_time_id - ) - - # check that observed times are provided for each ID - msg_time_length <- paste( - "Cannot create flexible folds (allow for", - "variability in the amount of `time` observed for", - "each `id`) unless `time` vector is of same length", - "as `id` vector. `time` is a vector of integers of", - "time points observed for each subject, and `id`", - "is a vector of unique identifiers which", - "correspond to the time vector. The `id` vector", - "is used to subset the `time` vector." - ) - if (length(id) > 1) { - assertthat::assert_that(length(id) == length(time), - msg = msg_time_length - ) - } -} - ######################################################### #Add option to make subgroup-specific cross-validation folds @@ -435,6 +392,7 @@ fold_from_foldvec_subgroup_stratoutcome <- function(v, foldsdf1, foldsdf2, n) { make_fold(v, training_set, validation_set) } + #' @rdname fold_funs #' @export folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { @@ -484,3 +442,48 @@ folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { return(folds) } } + + +############################################################################### + +#' Check ID and Time Compatibility +#' +#' @param id An optional vector of unique identifiers corresponding to the time +#' vector. These can be used to subset the time vector. +#' @param time An optional vector of integers of time points observed for each +#' subject in the sample. +#' +#' @importFrom assertthat assert_that +#' +#' @keywords internal +check_id_and_time <- function(id, time) { + # check that both time and ID are provided, or that neither are provided + msg_time_id <- paste( + "Cannot create flexible folds (allow for variability", + "in the amount of time observed for each id) unless", + "both `time` and `id` arguments are provided. Either", + "provide both `time` and `id` or neither." + ) + assertthat::assert_that(!(!is.null(id) & is.null(time)) || + !(is.null(id) & !is.null(time)), + msg = msg_time_id + ) + + # check that observed times are provided for each ID + msg_time_length <- paste( + "Cannot create flexible folds (allow for", + "variability in the amount of `time` observed for", + "each `id`) unless `time` vector is of same length", + "as `id` vector. `time` is a vector of integers of", + "time points observed for each subject, and `id`", + "is a vector of unique identifiers which", + "correspond to the time vector. The `id` vector", + "is used to subset the `time` vector." + ) + if (length(id) > 1) { + assertthat::assert_that(length(id) == length(time), + msg = msg_time_length + ) + } +} + From d935eb46cc3ca82a002dd466fdbc1aad42972fcf Mon Sep 17 00:00:00 2001 From: Lauren-Eyler Date: Wed, 27 Jan 2021 17:57:27 -0800 Subject: [PATCH 5/6] Updated NAMESPACE file --- NAMESPACE | 4 ++++ R/fold_funs.R | 21 --------------------- R/utils.R | 19 +++++++++++++++++++ man/fold_funs.Rd | 3 +++ 4 files changed, 26 insertions(+), 21 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c1c0b8f..0d0472b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +export("%notin%") export(combine_results) export(combiner_array) export(combiner_c) @@ -7,6 +8,8 @@ export(combiner_factor) export(combiner_rbind) export(cross_validate) export(fold_from_foldvec) +export(fold_from_foldvec_subgroup) +export(fold_from_foldvec_subgroup_stratoutcome) export(fold_index) export(folds2foldvec) export(folds_bootstrap) @@ -17,6 +20,7 @@ export(folds_rolling_origin) export(folds_rolling_origin_pooled) export(folds_rolling_window) export(folds_rolling_window_pooled) +export(folds_subgroup) export(folds_vfold) export(folds_vfold_rolling_origin_pooled) export(folds_vfold_rolling_window_pooled) diff --git a/R/fold_funs.R b/R/fold_funs.R index eb3a1d6..47e8d1c 100644 --- a/R/fold_funs.R +++ b/R/fold_funs.R @@ -372,27 +372,6 @@ folds_vfold_rolling_window_pooled <- function(n, t, id = NULL, time = NULL, ######################################################### #Add option to make subgroup-specific cross-validation folds -#' @rdname fold_funs -#' @export -`%notin%` <- Negate(`%in%`) - -#' @rdname fold_funs -#' @export -fold_from_foldvec_subgroup <- function(v, foldsdf, n) { - validation_set <- foldsdf[,1][which(foldsdf[,2] == v)] - training_set <- which(seq_len(n) %notin% validation_set) - make_fold(v, training_set, validation_set) -} - -#' @rdname fold_funs -#' @export -fold_from_foldvec_subgroup_stratoutcome <- function(v, foldsdf1, foldsdf2, n) { - validation_set <- c(foldsdf1[,1][which(foldsdf1[,2] == v)], foldsdf2[,1][which(foldsdf2[,2] == v)]) - training_set <- which(seq_len(n) %notin% validation_set) - make_fold(v, training_set, validation_set) -} - - #' @rdname fold_funs #' @export folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { diff --git a/R/utils.R b/R/utils.R index f69a6b8..fc46d39 100644 --- a/R/utils.R +++ b/R/utils.R @@ -64,3 +64,22 @@ folds2foldvec <- function(folds) { fold_id <- nums[order(fold_index)] return(fold_id) } + +################################################################################ + +#' @export +`%notin%` <- Negate(`%in%`) + +#' @export +fold_from_foldvec_subgroup <- function(v, foldsdf, n) { + validation_set <- foldsdf[,1][which(foldsdf[,2] == v)] + training_set <- which(seq_len(n) %notin% validation_set) + make_fold(v, training_set, validation_set) +} + +#' @export +fold_from_foldvec_subgroup_stratoutcome <- function(v, foldsdf1, foldsdf2, n) { + validation_set <- c(foldsdf1[,1][which(foldsdf1[,2] == v)], foldsdf2[,1][which(foldsdf2[,2] == v)]) + training_set <- which(seq_len(n) %notin% validation_set) + make_fold(v, training_set, validation_set) +} diff --git a/man/fold_funs.Rd b/man/fold_funs.Rd index 11284c5..fea1655 100644 --- a/man/fold_funs.Rd +++ b/man/fold_funs.Rd @@ -13,6 +13,7 @@ \alias{folds_rolling_window_pooled} \alias{folds_vfold_rolling_origin_pooled} \alias{folds_vfold_rolling_window_pooled} +\alias{folds_subgroup} \title{Cross-Validation Schemes} \usage{ folds_vfold(n, V = 10L) @@ -74,6 +75,8 @@ folds_vfold_rolling_window_pooled( gap = 0L, batch = 1L ) + +folds_subgroup(n, V = 10L, subgroup, strat_outcome = NULL) } \arguments{ \item{n}{An integer indicating the number of observations.} From d47569f1eeb275a4cfb991c0f5bedeb64e811b9c Mon Sep 17 00:00:00 2001 From: Lauren-EylerDang Date: Thu, 17 Jun 2021 09:07:37 -0700 Subject: [PATCH 6/6] updated parameters for folds_subgroup --- R/fold_funs.R | 12 ++---------- man/fold_funs.Rd | 4 +++- 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/R/fold_funs.R b/R/fold_funs.R index 47e8d1c..3cd81e1 100644 --- a/R/fold_funs.R +++ b/R/fold_funs.R @@ -29,6 +29,8 @@ #' subject in the sample. #' @param id An optional vector of unique identifiers corresponding to the time #' vector. These can be used to subset the time vector. +#' @param subgroup Binary indicator vector of membership in the subgroup of interest for subgroup-specific cross-validation (eg data$S). +#' @param strat_outcome Optional binary outcome vector (eg data$Y) for subgroup-specific cross-validation if equal proportion of outcome in training and validation folds desired. #' #' @importFrom assertthat assert_that #' @@ -380,11 +382,6 @@ folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { subgroup_index <- which(subgroup == 1) - #if (length(subgroup_index) <= V) { - # warning("number in subgroup <= V so using leave-one-out CV") - # return(folds_loo(subgroup_index)) - #} - folds <- rep(seq_len(V), length = length(subgroup_index)) # shuffle folds @@ -400,11 +397,6 @@ folds_subgroup <- function(n, V = 10L, subgroup, strat_outcome = NULL) { subgroup_index1 <- which(subgroup == 1 & strat_outcome == 1) subgroup_index2 <- which(subgroup == 1 & strat_outcome == 0) - #if (length(subgroup_index) <= V) { - # warning("number in subgroup <= V so using leave-one-out CV") - # return(folds_loo(subgroup_index)) - #} - #Two sets of folds, one for outcome == 1 and one for outcome == 0 folds1 <- rep(seq_len(V), length = length(subgroup_index1)) folds2 <- rep(seq_len(V), length = length(subgroup_index2)) diff --git a/man/fold_funs.Rd b/man/fold_funs.Rd index fea1655..aab5a85 100644 --- a/man/fold_funs.Rd +++ b/man/fold_funs.Rd @@ -106,7 +106,9 @@ training sample.} time-series sample.} \item{id}{An optional vector of unique identifiers corresponding to the time -vector. These can be used to subset the time vector.} +vector. These can be used to subset the time vector. +@param subgroup Binary indicator vector of membership in the subgroup of interest for subgroup-specific cross-validation (eg data$S). +@param strat_outcome Optional binary outcome vector (eg data$Y) for subgroup-specific cross-validation if equal proportion of outcome in training and validation folds desired.} \item{time}{An optional vector of integers of time points observed for each subject in the sample.}