Nothing
#' Conditional imputation helper
#'
#' Sorry, the \code{ifdo()} function is not yet implemented.
#' @aliases ifdo
#' @param cond a condition
#' @param action the action to do
#' @return Currently returns an error message.
#' @author Stef van Buuren, 2012
#' @keywords internal
ifdo <- function(cond, action) {
cat("Function ifdo() not yet implemented.\n")
}
#' Appends specified break to the data
#'
#' A custom function to insert rows in long data with new pseudo-observations
#' that are being done on the specified break ages. There should be a
#' column called \code{first} in \code{data} with logical data that codes whether
#' the current row is the first for subject \code{id}. Furthermore,
#' the function assumes that columns \code{age}, \code{occ},
#' \code{hgt.z}, \code{wgt.z} and
#' \code{bmi.z} are available. This function is used on the \code{tbc}
#' data in FIMD chapter 9. Check that out to see it in action.
#' @aliases appendbreak
#' @param data A data frame in the long long format
#' @param brk A vector of break ages
#' @param warp.model A time warping model
#' @param id The subject identifier
#' @param typ Label to signal that this is a newly added observation
#' @return A long data frame with additional rows for the break ages
#' @export
appendbreak <- function(data, brk, warp.model = warp.model, id = NULL, typ = "pred") {
k <- length(brk)
app <- data[data$first, ]
if (!is.null(id)) {
idx <- app$id %in% id
app <- app[idx, ]
}
nap <- nrow(app)
## update administrative variables
app$first <- FALSE
app$typ <- typ
app$occ <- NA
app <- app[rep.int(seq_len(nap), length(brk)), ]
## update age variables
app$age <- rep(brk, each = nap)
app$age2 <- predict(warp.model, newdata = app)
X <- splines::bs(app$age,
knots = brk,
Boundary.knots = c(brk[1], brk[k] + 0.0001),
degree = 1
)
X <- X[, -(k + 1)]
app[, paste0("x", seq_len(ncol(X)))] <- X
## update outcome variable (set to missing)
app[, c("hgt.z", "wgt.z", "bmi.z")] <- NA
app <- rbind(data, app)
app[order(app$id, app$age), ]
}
#' Extract broken stick estimates from a \code{lmer} object
#'
#' @param fit An object of class \code{lmer}
#' @return A matrix containing broken stick estimates
#' @author Stef van Buuren, 2012
#' @export
extractBS <- function(fit) {
siz <- t(lme4::ranef(fit)[[1]]) + lme4::fixef(fit)
matrix(siz, nrow = nrow(siz) * ncol(siz), ncol = 1)
}
## used by mice.impute.midastouch
bootfunc.plain <- function(n) {
random <- sample.int(n, replace = TRUE)
as.numeric(table(factor(random, levels = seq_len(n))))
}
minmax <- function(x, domin = TRUE, domax = TRUE) {
maxx <- sqrt(.Machine$double.xmax)
minx <- sqrt(.Machine$double.eps)
if (domin) {
x <- pmin(x, maxx)
}
if (domax) {
x <- pmax(x, minx)
}
x
}
single2imputes <- function(single, mis) {
nmis <- colSums(mis)
vars <- names(single)[nmis > 0]
z <- vector("list", length(vars))
names(z) <- vars
for (j in vars) z[[j]] <- single[mis[, j], j]
z
}
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.