| 1 | 1 | #' Warn if new t_j are used |
|
| 2 | 2 | #' |
|
| 3 | 3 | #' @keywords internal |
|
| 4 | - | warn_about_new_time_points <- function(newdata, object, time_var) { |
|
| 4 | + | warn_about_new_time_points <- function(object, newdata, ...) { |
|
| 5 | + | ||
| 6 | + | UseMethod("warn_about_new_time_points", object) |
|
| 7 | + | ||
| 8 | + | } |
|
| 9 | + | ||
| 10 | + | ||
| 11 | + | warn_about_new_time_points.glm <- function(object, newdata, time_var, ...) { |
|
| 5 | 12 | ||
| 6 | 13 | is_pam <- inherits(object, "gam") |
|
| 7 | 14 | ||
| 15 | + | if(is_pam & is.null(object$model)){ |
|
| 16 | + | return(invisible()) |
|
| 17 | + | } |
|
| 18 | + | ||
| 8 | 19 | original_intervals <- if (is_pam) { |
|
| 9 | 20 | unique(model.frame(object)[[time_var]]) |
|
| 10 | 21 | } else levels(model.frame(object)[[time_var]]) |
| 14 | 25 | new_ints <- which(!(prediction_intervals %in% original_intervals)) |
|
| 15 | 26 | n_out <- pmin(10, length(new_ints)) |
|
| 16 | 27 | if (length(new_ints)) { |
|
| 17 | - | message <- paste0("Intervals in <newdata> contain values (", |
|
| 18 | - | paste(prediction_intervals[new_ints[1:n_out]], collapse = ","), |
|
| 19 | - | " ...) not used in original fit.", |
|
| 20 | - | " Setting intervals to values not used for original fit in <object>", |
|
| 21 | - | "can invalidate the PEM assumption and yield incorrect predictions.") |
|
| 28 | + | message <- paste0( |
|
| 29 | + | "Time points/intervals in new data not equivalent to time points/intervals during model fit.", |
|
| 30 | + | " Setting intervals to values not used for original fit", |
|
| 31 | + | "can invalidate the PEM assumption and yield incorrect predictions.") |
|
| 22 | 32 | if (is_pam) warning(message) else stop(message) |
|
| 23 | 33 | } |
|
| 24 | 34 | } |
|
| 25 | 35 | ||
| 26 | 36 | ||
| 37 | + | #' @rdname warn_about_new_time_points |
|
| 38 | + | warn_about_new_time_points.pamm <- function(object, newdata, ...) { |
|
| 39 | + | ||
| 40 | + | if (inherits(object, "pamm")) { |
|
| 41 | + | cut <- object$trafo_args$cut |
|
| 42 | + | int_original <- int_info(cut)$interval |
|
| 43 | + | if ("interval" %in% colnames(newdata)) { |
|
| 44 | + | int_new <- unique(newdata[["interval"]]) |
|
| 45 | + | if(!all(int_new %in% int_original)) { |
|
| 46 | + | warning( |
|
| 47 | + | paste0( |
|
| 48 | + | "Time points/intervals in new data not equivalent to time points/intervals during model fit.", |
|
| 49 | + | " Setting intervals to values not used for original fit", |
|
| 50 | + | "can invalidate the PEM assumption and yield incorrect predictions." |
|
| 51 | + | ) |
|
| 52 | + | ) |
|
| 53 | + | } |
|
| 54 | + | ||
| 55 | + | } |
|
| 56 | + | } |
|
| 57 | + | ||
| 58 | + | } |
|
| 59 | + | ||
| 27 | 60 | # #' @keywords internal |
|
| 28 | 61 | # #' @importFrom dplyr intersect union setequal |
|
| 29 | 62 | # warn_partial_overlap <- function(event_id, tdc_id) { |
| 237 | 237 | if (any(names(int_df) %in% names(ndf))) { |
|
| 238 | 238 | int_tend <- get_intervals(x, ndf$tend)$tend |
|
| 239 | 239 | if (!all(ndf$tend == int_tend)) { |
|
| 240 | - | message("Some values of 'tend' have been set to the respecitve interval end-points") |
|
| 240 | + | message("Some values of 'tend' have been set to the respective interval end-points") |
|
| 241 | 241 | } |
|
| 242 | 242 | ndf$tend <- int_tend |
|
| 243 | 243 | suppressMessages( |
| 72 | 72 | } |
|
| 73 | 73 | ||
| 74 | 74 | make_X <- function(object, ...) { |
|
| 75 | + | ||
| 75 | 76 | UseMethod("make_X", object) |
|
| 77 | + | ||
| 76 | 78 | } |
|
| 77 | 79 | ||
| 78 | 80 | make_X.default <- function(object, newdata, ...) { |
|
| 81 | + | ||
| 79 | 82 | X <- model.matrix(object$formula[-2], data = newdata, ...) |
|
| 80 | 83 | ||
| 81 | 84 | } |
| 239 | 242 | # throw warning or error if evaluation time points/intervals do not correspond |
|
| 240 | 243 | # to evaluation time-points/intervals do not correspond to the ones used for |
|
| 241 | 244 | # estimation |
|
| 242 | - | warn_about_new_time_points(newdata, object, time_var) |
|
| 245 | + | warn_about_new_time_points(object, newdata, time_var) |
|
| 243 | 246 | ||
| 244 | 247 | X <- prep_X(object, newdata, reference, ...) |
|
| 245 | 248 | coefs <- coef(object) |
| Files | Coverage |
|---|---|
| R | 94.37% |
| Project Totals (27 files) | 94.37% |
adibender
