Nothing
R/utils.R
In misty: Miscellaneous Functions 'T. Yanagida'
Defines functions
.r2mlm
.extract.section
splitFilePath
convert_to_filelist
.detect.mplus
os
is.linux
is.macos
is.windows
.extract.lca.result
.section.ind.from.to
.delta_var
.delta_mean_item
.expected_value
.item_dmacs
.dmacs_summary_single
.dmacs_summary
.chr.round
.sim.fit
.sim.data.categ
.contord
.ordsample
.sim.data.likert
.items.n.crossload
.cross.load
.misspec.multi
.resid.cov
.items.no.cor
.misspec.one
.n.factors
.cot
.csc
.polar2r
.r2polar
.opdyke
.opdyke.percentiles
.icomp
.sic
.ibic
.spbic
.hbic
.hqc
.aicc
.sabic
.caic
.cor.polyserial
.it.cor
.adt.cor
.model.fit.param
.conv.ident
.p2
.refit
.polycorLavaan
.getThreshold
.categ.omega
.omega
.alpha
.qprodnormalMeeker
.get_ncp_chi
.fei
.cohen.w
.cont
.tschuprow
.cramer
.phi
.DA
.combinations
.domin
.find.c2
.binBvn
.cor.test.kendall.c
.cor.test.kendall.b
.cor.test.spearman
.cor.test.pearson
.internal.d.function
.reverse.helmert
.forward.helmert
.contr.repeat
.contr.sum
.output_template
.allocate_column
.make_names
.plot.boot
.plot.ci
.prop.diff.conf
.m.diff.conf
.boot.func.sd
.sd.conf
.boot.func.var
.var.conf
.prop.conf
.boot.func.median
.med.conf
.boot.func.mean
.m.conf
.ci.boot
.ci.boot.cor
.boot.func.cor
.norm.inter
.write.result
.rmvnorm
.fixed2free
.str.affix
.sim.standardized.matrices
.waldtest
.coeftest
.sandw
.write.table
.round
.AndersonDarling
.LegNorm
.SimNey
.TestUNey
.Hawkins
.MimputeS
.Mimpute
.Impute
.Ddf
.Sexpect
.Mls
.DelLessData
.OrderMissing
.TestMCARNormality
.LittleMCAR
.var.random
.cohens.d.na.auxiliary
.variable.section
.sort_variables
.get_interaction_vars
.get_cwc
.get_random_slope_vars
.get_covs
.add_interaction_vars_to_data
.prepare_data
.r2mlm_manual
.r2mlm_nlme
.r2mlm_lmer
.ci.kendall.c
.ci.kendall.c.estimate
.ci.kendall.b
.ci.spearman.cor.se
.ci.pearson.cor.adjust
.estskkufun
.zciofrfun
.smpmjkfun
.smpmomvecfun
.Tf2fun
.VMparstomoms
.sqerrVMintr
.sqerrVMc
.multsolvefun
.worker
.getMatches
.filterOverlap
.fastReplace
.calc_ranef
.resid.partial
.fitBootSample
.getBootSample
.trans2
.trans1
.mcse
.ess
.autocovariance
.zscale
.split.chains
.rhat
.hdi
.map
.detect_blimp_windows
.detect_blimp_linux
.detect_blimp_macos
.detect.blimp
.blimp.source
.as.na
.exclude.non.numeric
.var.group
.var.names
.check.input
#_______________________________________________________________________________
#
# Internal Functions
#
# Collection of internal functions used within functions of the misty package
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Check Argument Specification -------------------------------------------------
.check.input <- function(logical = NULL, numeric = NULL, character = NULL, m.character = NULL, s.character = NULL, args = NULL, package = NULL, envir = environment(), input.check = check) {
# Check input 'input.check'
if (isTRUE(!is.null(dim(input.check)) || length(input.check) != 1L || !is.logical(input.check) || is.na(input.check))) { stop("Please specify TRUE or FALSE for the argument 'check'.", call. = FALSE) }
# Check inputs
if (isTRUE(input.check)) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check TRUE/FALSE Input ####
if (isTRUE(!is.null(logical))) { invisible(sapply(logical, function(y) { eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!is.null(dim(p)) || length(p) != 1L || !is.logical(p) || is.na(p))) { stop(paste0("Please specify TRUE or FALSE for the argument '", y, "'."), call. = FALSE) })() })) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Numeric Input ####
if (isTRUE(!is.null(numeric))) {
invisible(sapply(names(numeric), function(y) {
eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!all(is.na(p)) && !is.null(p) && (!is.numeric(p) || length(p) != numeric[[y]]))) {
if (isTRUE(numeric[[y]] == 1L)) {
stop(paste0("Please specify a numeric value for the argument '", y, "'."), call. = FALSE)
} else {
stop(paste0("Please specify a numeric vector with ", switch(as.character(numeric[[y]]), "1" = "one", "2" = "two", "3" = "three", "4" = "four"), " elements for the argument '", y, "'."), call. = FALSE)
}
})()
}))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Character Input ####
if (isTRUE(!is.null(character))) {
invisible(sapply(names(character), function(y) {
eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!is.null(p) && (!is.character(p) || length(p) != character[[y]]))) {
if (isTRUE(character[[y]] == 1L)) {
stop(paste0("Please specify a character string for the argument '", y, "'."), call. = FALSE)
} else {
stop(paste0("Please specify a character vector with ", switch(as.character(character[[y]]), "1" = "one", "2" = "two", "3" = "three", "4" = "four", "5" = "five", "6" = "six"), " elements for the argument '", y, "'."), call. = FALSE)
}
})()
}))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Multiple Character Input ####
if (isTRUE(!is.null(m.character))) {
invisible(sapply(names(m.character), function(y) eval(parse(text = y), envir = envir) |> (\(p) {
if (isTRUE(!any(is.character(p)) || any(is.na(p)))) {
stop(paste0("Please specify a character string or character vector for the argument ", sQuote(y, q = FALSE)), call. = FALSE)
}
if (isTRUE(any(!p %in% m.character[[y]]))) {
if (isTRUE(length(p) == 1L)) {
stop(paste0("Character string specified in the argument '", y , "' does not match with ", paste0(paste(unlist(m.character[y]) |> (\(q) paste(sapply(q[-length(q)], dQuote, q = FALSE)))(), collapse = ", "), ", or ", dQuote(rev(unlist(m.character[y]))[1L], q = FALSE)), "."), call. = FALSE)
} else {
stop(paste0("Character strings specified in the argument '", y , "' do not all match with ", paste0(paste(unlist(m.character[y]) |> (\(q) paste(sapply(q[-length(q)], dQuote, q = FALSE)))(), collapse = ", "), ", or ", dQuote(rev(unlist(m.character[y]))[1L], q = FALSE)), "."), call. = FALSE)
}
}
})()))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Single Character Input ####
if (isTRUE(!is.null(s.character))) {
invisible(sapply(names(s.character), function(y) eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!is.character(p) || any(!p %in% s.character[[y]]) || (!all(p %in% s.character[[y]]) && length(p) != 1L))) {
stop(paste0("Please specify ", paste0(paste(unlist(s.character[y]) |> (\(p) paste(sapply(p[-length(p)], dQuote, q = FALSE)))(), collapse = ", "), ", or ", dQuote(rev(unlist(s.character[y]))[1L], q = FALSE)), " for the argument ", sQuote(y, q = FALSE), "."), call. = FALSE)
})()))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Additional Arguments ####
if (isTRUE(!is.null(args))) {
# Check input 'alpha'
if (isTRUE("alpha" %in% args)) { eval(parse(text = "alpha"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'alpha'", call. = FALSE) })() }
# Check input 'alternative'
if (isTRUE("alternative" %in% args)) { eval(parse(text = "alternative"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("two.sided", "less", "greater") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("two.sided", "less", "greater"))))) { stop("Character string specified in the argument 'alternative' does not match with \"two.sided\", \"less\", or \"greater\".", call. = FALSE) })() }
# Check input 'conf.level'
if (isTRUE("conf.level" %in% args)) { eval(parse(text = "conf.level"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'start'", call. = FALSE) })() }
# Check input 'color'
if (isTRUE("color" %in% args)) { eval(parse(text = "color"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && all(y != "default") && (!is.character(y) || any(!y %in% c("black", "red", "green", "yellow", "blue", "violet", "cyan", "white", "gray1", "gray2", "gray3", "b.red", "b.green", "b.yellow", "b.blue", "b.violet", "b.cyan", "b.white"))))) { stop("Character string specified in the argument 'color' does not match with \"black\", \"red\", \"green\", \"yellow\", \"blue\", \"violet\", \"cyan\", \"white\", \"gray1\" etc.", call. = FALSE) })() }
# Check input 'digits'
if (isTRUE("digits" %in% args)) { eval(parse(text = "digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'digits'.", call. = FALSE) })() }
# Check input 'end'
if (isTRUE("end" %in% args)) { eval(parse(text = "end"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specifiy a numeric value between 0 and 1 for the argument 'end '.", call. = FALSE) })() }
# Check input 'ess.digits'
if (isTRUE("ess.digits" %in% args)) { eval(parse(text = "ess.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'ess.digits'.", call. = FALSE) })() }
# Check input 'facet.scales'
if (isTRUE("facet.scales" %in% args)) { eval(parse(text = "facet.scales"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("fixed", "free_x", "free_y", "free") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("fixed", "free_x", "free_y", "free"))))) { stop("Character string specified in the argument 'facet.scales' does not match with \"fixed\", \"free_x\", \"free_y\", or \"free\".", call. = FALSE) })() }
# Check input 'fit.digits'
if (isTRUE("fit.digits" %in% args)) { eval(parse(text = "fit.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'fit.digits'.", call. = FALSE) })() }
# Check input 'hist.alpha'
if (isTRUE("hist.alpha" %in% args)) { eval(parse(text = "hist.alpha"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specifiy a numeric value between 0 and 1 for the argument 'hist.alpha '.", call. = FALSE) })() }
# Check input 'ic.digits'
if (isTRUE("ic.digits" %in% args)) { eval(parse(text = "ic.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'ic.digits'.", call. = FALSE) })() }
# Check input 'icc.digits'
if (isTRUE("icc.digits" %in% args)) { eval(parse(text = "icc.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'icc.digits'.", call. = FALSE) })() }
# Check input 'legend.position'
if (isTRUE("legend.position" %in% args)) { eval(parse(text = "legend.position"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("right", "top", "left", "bottom", "none") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("right", "top", "left", "bottom", "none"))))) { stop("Character string specified in the argument 'legend.position' does not match with \"right\", \"top\", \"left\", \"bottom\", or \"none\".", call. = FALSE) })() }
# Check input 'linetype'
if (isTRUE("linetype" %in% args)) { eval(parse(text = "linetype"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.character(y) || any(!y %in% c("twodash", "solid", "longdash", "dotted", "dotdash", "dashed"))))) { stop("Character string specified in the argument 'linetype' does not match with \"twodash\", \"solid\", \"longdash\", \"dotted\", \"ldotdash\", or \"dashed\".", call. = FALSE) })() }
# Check input 'mcse.digits'
if (isTRUE("mcse.digits" %in% args)) { eval(parse(text = "mcse.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'mcse.digits'.", call. = FALSE) })() }
# Check input 'n'
if (isTRUE("n" %in% args)) { eval(parse(text = "n"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'n'.", call. = FALSE) })() }
# Check input 'nrep'
if (isTRUE("nrep" %in% args)) { eval(parse(text = "nrep"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'nrep'.", call. = FALSE) })() }
# Check input 'p.adj'
if (isTRUE("p.adj" %in% args)) { eval(parse(text = "p.adj"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("none", "holm", "bonferroni", "hochberg", "hommel", "BH", "BY", "fdr") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("none", "holm", "bonferroni", "hochberg", "hommel", "BH", "BY", "fdr"))))) { stop("Character string specified in the argument 'p.adj' does not match with \"none\", \"bonferroni\", \"holm\", \"hochberg\", \"hommel\", \"BH\", \"BY\", or \"fdr\".", call. = FALSE) })() }
# Check input 'p.digits'
if (isTRUE("p.digits" %in% args)) { eval(parse(text = "p.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'p.digits'.", call. = FALSE) })() }
# Check input 'res.cor'
if (isTRUE("res.cor" %in% args)) { eval(parse(text = "res.cor"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'res.cor'", call. = FALSE) })() }
# Check input 'r.digits'
if (isTRUE("r.digits" %in% args)) { eval(parse(text = "r.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'r.digits'.", call. = FALSE) })() }
# Check input 'seed'
if (isTRUE("seed" %in% args)) { eval(parse(text = "seed"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (length(y) != 1L || (mode(y) != "numeric")))) { stop("Please specify a numeric value for the argument 'seed'.", call. = FALSE) })() }
# Check input 'sensitiv'
if (isTRUE("sensitiv" %in% args)) { eval(parse(text = "sensitiv"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'sensitiv'", call. = FALSE) })() }
# Check input 'specific'
if (isTRUE("specific" %in% args)) { eval(parse(text = "specific"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'specific'", call. = FALSE) })() }
# Check input 'start'
if (isTRUE("start" %in% args)) { eval(parse(text = "start"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specifiy a numeric value between 0 and 1 for the argument 'start '.", call. = FALSE) })() }
# Check input 'units'
if (isTRUE("units" %in% args)) { eval(parse(text = "units"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("in", "cm", "mm", "px") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("in", "cm", "mm", "px"))))) { stop("Character string specified in the argument 'units' does not match with \"in\", \"cm\", \"mm\", or \"px\".", call. = FALSE) })() }
# Check input 'write' text file
if (isTRUE("write1" %in% args)) { eval(parse(text = "write"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.null(y) && (!is.character(y) || !grepl(".txt", y))))) { stop("Please specify a character string with file extenstion '.txt' for the argument 'write'.") })() }
# Check input 'write' text and Excel file
if (isTRUE("write2" %in% args)) { eval(parse(text = "write"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.null(y) && (!is.character(y) || all(!misty::chr.grepl(c(".txt", ".xlsx"), y)))))) { stop("Please specify a character string with file extenstion '.txt' or '.xlsx' for the argument 'write'.") })() }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Packages ####
if (isTRUE(!is.null(package))) { invisible(sapply(package, function(y) { if (isTRUE(!requireNamespace(y, quietly = TRUE))) { stop(paste0("Package \"", y ,"\" is needed for this function to work, please install it."), call. = FALSE) } })) }
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Extract Variable Names Specified in the ... Argument ------------------------
.var.names <- function(data, ..., group = NULL, split = NULL, cluster = NULL, id = NULL, obs = NULL, day = NULL, time = NULL) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check if Input 'data' is a Data Frame ####
# Check if input 'data' is data frame
if (isTRUE(!is.data.frame(data))) { stop("Please specify a data frame for the argument 'data'.", call. = FALSE) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Convert Tibble into Data Frame ####
if (isTRUE("tbl" %in% substr(class(data), 1L, 3L))) { data <- as.data.frame(data) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Extract Elements in the '...' Argument ####
var.names <- sapply(substitute(list(...)), as.character)[-1L]
#—————————————————————————————————————— #
### Check for ! operators ####
var.names.excl <- sapply(var.names, function(y) any(y %in% "!"))
if (isTRUE(any(var.names.excl))) {
for (i in which(var.names.excl)) {
var.names.i <- unlist(strsplit(var.names[[i]], ""))
# Plus (+) Operator
if (isTRUE("+" %in% var.names.i)) {
var.names[[i]] <- unlist(strsplit(var.names[[i]], "(?=[/+])", perl = TRUE))
# Minus (-) Operator
} else if (isTRUE("-" %in% var.names.i)) {
var.names[[i]] <- unlist(strsplit(var.names[[i]], "(?=[/-])", perl = TRUE))
# Tilde (~) Operator
} else if (isTRUE("~" %in% var.names.i)) {
var.names[[i]] <- unlist(strsplit(var.names[[i]], "(?=[/~])", perl = TRUE))
# Colon (:) operator
} else if (isTRUE(sum(var.names.i %in% ":") == 1L)) {
var.names[[i]] <- c("!", ":", unlist(strsplit(var.names[[i]], ":"))[2L:3L])
# Double Colon (::) Operator
} else if (isTRUE(sum(var.names.i %in% ":") == 2L)) {
var.names[[i]] <- c("!", "::", unlist(strsplit(var.names[[i]], "::"))[2L:3L])
}
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Remove Variables ####
var.exclude <- NULL
#—————————————————————————————————————— #
### Starts with a Prefix: List Elements with + ####
var.plus <- sapply(var.names, function(y) any(y == "+"))
if (isTRUE(any(var.plus))) {
# List elements with +
for (i in which(var.plus)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "+", check = FALSE)
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- colnames(data)[which(substr(colnames(data), start = 1L, stop = nchar(var.i)) == var.i)]
# Complement !
} else {
var.i <- misty::chr.omit(var.i, omit = "!", check = FALSE)
var.exclude <- c(var.exclude, colnames(data)[which(substr(colnames(data), start = 1L, stop = nchar(var.i)) == var.i)])
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Ends with a Suffix: List Elements with - ####
var.minus <- sapply(var.names, function(y) any(y == "-"))
if (isTRUE(any(var.minus))) {
# List elements with -
for (i in which(var.minus)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "-", check = FALSE)
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- colnames(data)[which(substr(colnames(data), start = nchar(colnames(data)) - nchar(var.i) + 1L, stop = nchar(colnames(data))) == var.i)]
# Complement !
} else {
var.i <- misty::chr.omit(var.i, omit = "!", check = FALSE)
var.exclude <- c(var.exclude, colnames(data)[which(substr(colnames(data), start = nchar(colnames(data)) - nchar(var.i) + 1L, stop = nchar(colnames(data))) == var.i)])
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Contains a Literal String: List Elements with ~ ####
var.tilde <- sapply(var.names, function(y) any(y == "~"))
if (isTRUE(any(var.tilde))) {
# List elements with ~
for (i in which(var.tilde)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "~", check = FALSE)
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- grep(var.i, colnames(data), value = TRUE)
# Complement !
} else {
var.exclude <- c(var.exclude, misty::chr.grep(misty::chr.omit(var.i, omit = "!", check = FALSE), colnames(data), value = TRUE))
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Consecutive Variables: List Elements with : ####
var.colon <- sapply(var.names, function(y) any(y == ":"))
if (isTRUE(any(var.colon))) {
# List elements with :
for (i in which(var.colon)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = ":", check = FALSE)
setdiff(misty::chr.omit(var.i, omit = "!", check = FALSE), colnames(data)) |>
(\(y) if (isTRUE(length(y) != 0L)) {
stop(paste0(ifelse(length(y) == 1L, "Variable name involved in the : operator was not found in 'data': ", "Variable names involved in the : operator were not found in 'data': "), paste0(y, collapse = ", ")), call. = FALSE)
})()
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- colnames(data)[which(colnames(data) == var.i[1L]):which(colnames(data) == var.i[2L])]
# Complement !
} else {
var.exclude <- c(var.exclude, colnames(data)[which(colnames(data) == var.i[2L]):which(colnames(data) == var.i[3L])])
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Numerical Range: List Elements with :: ####
var.dcolon <- sapply(var.names, function(y) any(y == "::"))
if (isTRUE(any(var.dcolon))) {
# List elements with ::
for (i in which(var.dcolon)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "::", check = FALSE)
var.j <- misty::chr.omit(var.i, omit = "!", check = FALSE)
# Check if more than two variables were specified in the : operator
if (isTRUE(length(misty::chr.omit(unlist(strsplit(var.j, ":")), omit = "", check = FALSE)) > 2L)) { stop("More than two variables specified in the : operator.", call. = FALSE) }
# Split starting variable
var.i1.split <- unlist(strsplit(var.j[1L], "", fixed = TRUE))
# Split ending variable
var.i2.split <- unlist(strsplit(var.j[2L], "", fixed = TRUE))
# Numeric values starting variable
var.i1.log <- sapply(var.i1.split, function(y) y %in% as.character(0L:9L))
# Numeric values ending variable
var.i2.log <- sapply(var.i2.split, function(y) y %in% as.character(0L:9L))
# Variable name root starting variable
var.i1.root <- paste0(var.i1.split[-((max(which(var.i1.log == FALSE)) + 1L):length(var.i1.split))], collapse = "")
# Variable name root ending variable
var.i2.root <- paste0(var.i2.split[-((max(which(var.i2.log == FALSE)) + 1L):length(var.i2.split))], collapse = "")
# Check if variable names match
if (var.i1.root != var.i2.root) { stop(paste0("Variable names involvd in the :: operator do not match: ", paste(var.i1.root, "vs.", var.i2.root)), call. = FALSE) }
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- paste0(var.i1.root,
as.numeric(paste(var.i1.split[(max(which(var.i1.log == FALSE)) + 1L):length(var.i1.split)], collapse = "")):
as.numeric(paste(var.i2.split[(max(which(var.i2.log == FALSE)) + 1L):length(var.i2.split)], collapse = "")))
} else {
var.exclude <- c(var.exclude,
paste0(var.i1.root,
as.numeric(paste(var.i1.split[(max(which(var.i1.log == FALSE)) + 1L):length(var.i1.split)], collapse = "")):
as.numeric(paste(var.i2.split[(max(which(var.i2.log == FALSE)) + 1L):length(var.i2.split)], collapse = ""))))
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### List Elements with ! ####
var.exclude <- c(var.exclude, unlist(sapply(var.names, function(y) if (isTRUE(any(y == "!"))) { misty::chr.omit(y, omit = "!", check = FALSE) } )))
var.names <- var.names[which(sapply(var.names, function(y) !"!" %in% y))]
#—————————————————————————————————————— #
### Remove "" Elements ####
var.names <- misty::chr.omit(var.names, omit = "", check = FALSE)
#—————————————————————————————————————— #
### Unique Element ####
var.names <- unique(var.names)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Select All Variables ####
if (isTRUE(length(var.names) == 0L)) { var.names <- colnames(data) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Grouping, Split, Cluster and Other Variables ####
#—————————————————————————————————————— #
### Exclude Grouping Variable ####
if (isTRUE(!is.null(group))) {
if (isTRUE(!is.character(group) || length(group) != 1L)) { stop("Please specify a character string for the argument 'group'.", call. = FALSE) }
if (isTRUE(!group %in% colnames(data))) { stop("Grouping variable specifed in 'group' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, group)
}
#—————————————————————————————————————— #
### Exclude Split Variable ####
if (isTRUE(!is.null(split))) {
if (isTRUE(!is.character(split) || length(split) != 1L)) { stop("Please specify a character string for the argument 'split'.", call. = FALSE) }
if (isTRUE(!split %in% colnames(data))) { stop("Split variable specifed in 'split' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, split)
}
#—————————————————————————————————————— #
### Exclude Cluster Variable ####
if (isTRUE(!is.null(cluster))) {
if (isTRUE(!is.character(cluster) || !length(cluster) %in% c(1L, 2L))) { stop("Please specify a character vector for the argument 'cluster'.", call. = FALSE) }
#···················
#### One Cluster Variable ####
if (isTRUE(length(cluster) == 1L)) {
if (isTRUE(!cluster %in% colnames(data))) { stop("Cluster variable specifed in 'cluster' was not found in 'data'.", call. = FALSE) }
#···················
#### Two Cluster Variables ####
} else {
# Cluster variable in 'data'
(!cluster %in% colnames(data)) |>
(\(y) if (isTRUE(any(y))) {
if (isTRUE(sum(y) == 1L)) {
stop(paste0("Cluster variable specifed in 'cluster' was not found in 'data': ", cluster[which(y)]), call. = FALSE)
} else {
stop("Cluster variables specifed in 'cluster' were not found in 'data'.", call. = FALSE)
}
})()
# Order of cluster variables
suppressWarnings(tapply(data[, cluster[2L]], data[, cluster[1L]], var, na.rm = TRUE)) |>
(\(y) if (isTRUE(all(y == 0) || all(is.na(y)))) { stop("Please specify the Level 3 cluster variable first, e.g., cluster = c(\"level3\", \"level2\").", call. = FALSE) })()
}
var.names <- setdiff(var.names, cluster)
}
#—————————————————————————————————————— #
### Exclude 'id' Variable ####
if (isTRUE(!is.null(id))) {
if (isTRUE(!is.character(id) || length(id) != 1L)) { stop("Please specify a character string for the argument 'id'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Split variable specifed in 'id' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, id)
}
#—————————————————————————————————————— #
### Exclude 'obs' Variable ####
if (isTRUE(!is.null(obs))) {
if (isTRUE(!is.character(obs) || length(obs) != 1L)) { stop("Please specify a character string for the argument 'obs'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Observation number variable specifed in 'obs' was not found in 'data'.", call. = FALSE) }
if (isTRUE(any(sapply(split(obs, id), function(x) length(x) != length(unique(x)))))) { stop("There are duplicated observations specified in 'obs' within subjects specified in 'id'.", call. = FALSE) }
var.names <- setdiff(var.names, obs )
}
#—————————————————————————————————————— #
### Exclude 'day' Variable ####
if (isTRUE(!is.null(day))) {
if (isTRUE(!is.character(day) || length(day) != 1L)) { stop("Please specify a character string for the argument 'day'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Day variable specifed in 'day' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, day)
}
#—————————————————————————————————————— #
### Exclude 'time' Variable ####
if (isTRUE(!is.null(time))) {
if (isTRUE(!is.character(time) || length(time) != 1L)) { stop("Please specify a character string for the argument 'time'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Date and time variable specifed in 'time' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, time)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Remove Variables ####
if (isTRUE(!is.null(var.exclude))) { var.names <- setdiff(var.names, var.exclude) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check if Variables in '...' are Available in 'data' ####
if (isTRUE(!is.null(data))) { setdiff(var.names, colnames(data)) |> (\(y) if (isTRUE(length(y) != 0L)) { stop(paste0(ifelse(length(y) == 1L, "Variable specified in '...' was not found in 'data': ", "Variables specified in '...' were not found in 'data': "), paste(y, collapse = ", ")), call. = FALSE) })() }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Return Object ####
return(var.names)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Extract Grouping, Split, or Cluster Variable —————————————————————————————————
.var.group <- function(data, group = NULL, split = NULL, cluster = NULL, id = NULL,
obs = NULL, day = NULL, time = NULL, drop = TRUE) {
# Grouping, split, or cluster variable specified with the variable name
group.chr <- split.chr <- cluster.chr <- id.chr <- obs.chr <- day.chr <- time.chr <- FALSE
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Grouping Variable ####
if (isTRUE(!is.null(group))) {
#—————————————————————————————————————— #
### Tibble ####
# Convert 'group' as tibble into data frame
if (isTRUE("tbl" %in% substr(class(group), 1L, 3L))) { group <- unname(unlist(cluster)) }
#—————————————————————————————————————— #
### Grouping Variable Specified with the Variable Name ####
group.chr <- is.character(group)
if (isTRUE(group.chr && (length(group) < nrow(data)))) {
##### Check if one grouping variable ####
if (isTRUE(length(group) > 1L)) { stop("Please specify one grouping variable for the argument 'group'.", call. = FALSE) }
##### Check if grouping variable in 'data' ####
if (isTRUE(any(!group %in% colnames(data)))) { stop("Grouping variable specifed in 'group' was not found in '...'.", call. = FALSE) }
##### Extract 'data' and 'group' ####
# Index of grouping variable in 'data'
group.col <- which(colnames(data) == group)
# Replace variable name with grouping variable
group <- data[, group.col]
# Remove grouping variable from 'data'
data <- data[, -group.col, drop = drop]
#—————————————————————————————————————— #
### Grouping Variable Not Specified with the Variable Name ####
} else {
# Check if length of grouping variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(group)) != nrow(as.data.frame(data)))) { stop("Grouping variable specified in 'group' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if grouping variable is completely missing
if (isTRUE(all(is.na(group)))) { stop("The grouping variable specified in 'group' is completely missing.", call. = FALSE) }
# Check if only one group represented in the grouping variable
if (isTRUE(length(unique(na.omit(unlist(group)))) == 1L)) { stop("There is only one group represented in the grouping variable specified in 'group'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Split Variable ####
if (isTRUE(!is.null(split))) {
#—————————————————————————————————————— #
### Tibble ####
# Convert 'group' as tibble into data frame
if (isTRUE("tbl" %in% substr(class(split), 1L, 3L))) { split <- unname(unlist(split)) }
#—————————————————————————————————————— #
### Split Variable Specified with the Variable Name ####
split.chr <- is.character(split)
if (isTRUE(split.chr && (length(split) < nrow(data)))) {
# Check if one split variable
if (isTRUE(length(split) > 1L)) { stop("Please specify one split variable for the argument 'split'.", call. = FALSE) }
# Check if split variable in 'data'
if (isTRUE(any(!split %in% colnames(data)))) { stop("Split variable specifed in 'split' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'split' ####
# Index of split variable in 'data'
split.col <- which(colnames(data) == split)
# Replace variable name with split variable
split <- data[, split.col]
# Remove split variable from 'data'
data <- data[, -split.col, drop = drop]
#—————————————————————————————————————— #
### Split Variable Not Specified with the Variable Name ####
} else {
# Check if length of split variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(split)) != nrow(as.data.frame(data)))) { stop("Split variable specified in 'split' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if split variable is completely missing
if (isTRUE(all(is.na(split)))) { stop("The split variable specified in 'split' is completely missing.", call. = FALSE) }
# Check if only one group represented in the split variable
if (isTRUE(length(unique(na.omit(unlist(split)))) == 1L)) { stop("There is only one split represented in the grouping variable specified in 'split'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Cluster Variable ####
if (isTRUE(!is.null(cluster))) {
#—————————————————————————————————————— #
### Tibble ####
# Convert 'cluster' as tibble into data frame
if (isTRUE("tbl" %in% substr(class(cluster), 1L, 3L))) { if (isTRUE(ncol(as.data.frame(cluster)) == 1L)) { cluster <- unname(unlist(cluster)) } else { cluster <- as.data.frame(cluster) } }
#—————————————————————————————————————— #
### Cluster Variable Specified with the Variable Name ####
cluster.chr <- is.character(cluster)
if (isTRUE(cluster.chr && (length(cluster) < nrow(data)))) {
# Check if one or two cluster variables
if (isTRUE(length(cluster) > 2L)) { stop("Please specify one or two cluster variables for the argument 'cluster'.", call. = FALSE) }
# Check if cluster variable in 'data'
if (isTRUE(any(!cluster %in% colnames(data)))) {
# One cluster variable
if (isTRUE(length(cluster) == 1L)) {
stop("Cluster variable specifed in 'cluster' was not found in '...'.", call. = FALSE)
# Two cluster variables
} else {
# Cluster variable in 'data'
setdiff(cluster, colnames(data)) |>
(\(y) if (isTRUE(length(y) == 1L)) {
stop(paste0("Cluster variable \"", y, "\" specifed in 'cluster' was not found in '...'."), call. = FALSE)
} else {
stop("Cluster variables specifed in 'cluster' were not found in '...'.", call. = FALSE)
})()
# Order of cluster variables
if (isTRUE(length(unique(data[, cluster[, 2L]])) < length(unique(data[, cluster[, 1L]])))) { stop("Please specify the Level 3 cluster variable first, e.g., cluster = c(\"level3\", \"level2\").", call. = FALSE) }
}
}
#···················
#### Extract 'data' and 'cluster' ####
# One cluster variable
if (isTRUE(length(cluster) == 1L)) {
# Index of cluster variable in 'data'
cluster.col <- which(colnames(data) %in% cluster)
# Replace variable name with cluster variable
cluster <- data[, cluster.col]
# Remove cluster variable from 'data'
data <- data[, -cluster.col, drop = drop]
} else {
# Index of Level-3 cluster variable in 'data'
cluster3.col <- which(colnames(data) == cluster[1L])
# Index of Level-2 cluster variable in 'data'
cluster2.col <- which(colnames(data) == cluster[2L])
# Replace variable name with cluster variable
cluster <- data[, c(cluster3.col, cluster2.col)]
# Remove cluster variable from 'data'
data <- data[, -c(cluster3.col, cluster2.col), drop = drop]
}
#—————————————————————————————————————— #
### Cluster Variable Not Specified with the Variable Name ####
} else {
# Check if length of cluster variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(cluster)) != nrow(as.data.frame(data)))) {
stop("Cluster variables specified in 'cluster' do not match with the number of rows in '...'.", call. = FALSE)
}
}
#···················
#### Check if Cluster Variable is Completely Missing ####
# One cluster variable
if (isTRUE(ncol(as.data.frame(cluster)) == 1L)) {
if (isTRUE(all(is.na(cluster)))) { stop("The cluster variable specified in 'cluster' is completely missing.", call. = FALSE) }
# Two cluster variables
} else {
sapply(cluster, function(y) all(is.na(y))) |>
(\(y) if (isTRUE(any(y))) {
if (isTRUE(sum(y)) == 1L) {
stop(paste0("A cluster variable specified in 'cluster' is completely missing.: ", names(which(y))), call. = FALSE)
} else {
stop("Cluster variables specified in 'cluster' are completely missing.", call. = FALSE)
}
})()
}
##### Check if only one group represented in the cluster variable ####
# One cluster variable
if (isTRUE(ncol(as.data.frame(cluster)) == 1L)) {
if (isTRUE(length(unique(na.omit(unlist(cluster)))) == 1L)) { stop("There is only one group represented in the cluster variable 'cluster'.", call. = FALSE) }
# Two cluster variables
} else {
sapply(cluster, function(y) length(unique(na.omit(unlist(y)))) == 1L) |>
(\(y) if (isTRUE(any(y))) {
if (isTRUE(sum(y)) == 1L) {
stop(paste0("There is only one group represented in a cluster variable specified in 'cluster': ", names(which(y))), call. = FALSE)
} else {
stop("There is only one group represented in both cluster variables specified in 'cluster'.", call. = FALSE)
}
})()
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Subject ID Variable ####
if (isTRUE(!is.null(id))) {
#—————————————————————————————————————— #
### Subject ID Variable Specified with the Variable Name ####
id.chr <- is.character(id)
if (isTRUE(id.chr && (length(id) < nrow(data)))) {
# Check if one ID variable
if (isTRUE(length(id) > 1L)) { stop("Please specify one id variable for the argument 'id'.", call. = FALSE) }
# Check if ID variable in 'data'
if (isTRUE(any(!id %in% colnames(data)))) { stop("ID variable specifed in 'id' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'id' ####
# Index of ID variable in 'data'
id.col <- which(colnames(data) == id)
# Replace variable name with id variable
id <- data[, id.col]
# Remove id variable from 'data'
data <- data[, -id.col, drop = drop]
#—————————————————————————————————————— #
### ID Variable Not Specified with the Variable Name ####
} else {
# Check if length of id variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(id)) != nrow(as.data.frame(data)))) { stop("ID variable specified in 'id' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if ID variable is completely missing
if (isTRUE(all(is.na(id)))) { stop("The ID variable specified in 'id' is completely missing.", call. = FALSE) }
# Check if only one ID represented in the ID variable
if (isTRUE(length(unique(na.omit(id))) == 1L)) { stop("There is only one ID represented in the ID variable specified in 'id'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Observation Number Variable ####
if (isTRUE(!is.null(obs))) {
#—————————————————————————————————————— #
### Observation Number Variable Specified with the Variable Name ####
obs.chr <- is.character(obs)
if (isTRUE(obs.chr && (length(obs) < nrow(data)))) {
# Check if one observation number variable
if (isTRUE(length(obs) > 1L)) { stop("Please specify one observation number variable for the argument 'obs'.", call. = FALSE) }
# Check if observation number variable in 'data'
if (isTRUE(any(!obs %in% colnames(data)))) { stop("Observation number variable specifed in 'obs' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'obs' ####
# Index of observation number variable in 'data'
obs.col <- which(colnames(data) == obs)
# Replace variable name with observation number variable
obs <- data[, obs.col]
# Remove observation number variable from 'data'
data <- data[, -obs.col, drop = drop]
#—————————————————————————————————————— #
### Observation number variable not specified with the variable name ####
} else {
# Check if length of observation number variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(obs)) != nrow(as.data.frame(data)))) { stop("ObservationnNumber variable specified in 'obs' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if observation number variable is completely missing
if (isTRUE(all(is.na(obs)))) { stop("The observation number variable specified in 'obs' is completely missing.", call. = FALSE) }
# Check if duplicated obs within id
check.obs.dupli <- sapply(split(obs, id), function(x) length(x) != length(unique(x)))
if (isTRUE(any(check.obs.dupli))) { stop("There are duplicated observations specified in 'obs' within subjects specified in 'id'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Day Number Variable ####
if (isTRUE(!is.null(day))) {
#—————————————————————————————————————— #
### Day Number Variable Specified with the Variable Name ####
day.chr <- is.character(day)
if (isTRUE(day.chr && (length(day) < nrow(data)))) {
# Check if one day variable
if (isTRUE(length(day) > 1L)) { stop("Please specify one day number variable for the argument 'day'.", call. = FALSE) }
# Check if day number variable in 'data'
if (isTRUE(any(!day %in% colnames(data)))) { stop("Day number variable specifed in 'day' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'day' ####
# Index of day number variable in 'data'
day.col <- which(colnames(data) == day)
# Replace variable name with day number variable
day <- data[, day.col]
# Remove day number variable from 'data'
data <- data[, -day.col, drop = drop]
#—————————————————————————————————————— #
### Day Number Variable Not Specified with the Variable Name ####
} else {
# Check if length of day number variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(day)) != nrow(as.data.frame(data)))) { stop("Day number variable specified in 'day' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if day number variable is completely missing
if (isTRUE(all(is.na(day)))) { stop("The day variable specified in 'day' is completely missing.", call. = FALSE) }
# Check if only one group represented in the day number variable
if (isTRUE(length(unique(na.omit(day))) == 1L)) { stop("There is only one day number represented in the grouping variable specified in 'day'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Actual Date and Time Variable ####
if (isTRUE(!is.null(time))) {
#—————————————————————————————————————— #
### Actual Date and Time Variable Specified with the Variable Name ####
time.chr <- is.character(time)
if (isTRUE(time.chr && (length(time) < nrow(data)))) {
# Check if one actual date and time variable
if (isTRUE(length(time) > 1L)) { stop("Please specify one date and time variable for the argument 'time'.", call. = FALSE) }
# Check if actual date and time variable in 'data'
if (isTRUE(any(!time %in% colnames(data)))) { stop("Date and time variable specifed in 'time' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'time' ####
# Index of actual date and time variable in 'data'
time.col <- which(colnames(data) == time)
# Replace variable name with actual date and time variable
time <- data[, time.col]
# Remove actual date and time variable from 'data'
data <- data[, -time.col, drop = drop]
#—————————————————————————————————————— #
### Actual Date and Time Variable Not Specified with the Variable Name ####
} else {
# Check if length of actual date and time variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(time)) != nrow(as.data.frame(data)))) { stop("Date and time variable specified in 'time' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if actual date and time variable is completely missing
if (isTRUE(all(is.na(time)))) { stop("The date and time variable specified in 'time' is completely missing.", call. = FALSE) }
# Check if only one group represented in the actual date and time variable
if (isTRUE(length(unique(na.omit(time))) == 1L)) { stop("There is only one date and time represented in the grouping variable specified in 'time'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Return Object ####
# Grouping, split, or cluster variable specified with the variable name
if (isTRUE(any(c(group.chr, split.chr, cluster.chr, id.chr, obs.chr, day.chr, time.chr)))) {
return(list(data = data, group = group, split = split, cluster = cluster, id = id, obs = obs, day = day, time = time))
# Grouping, split, or cluster variable not specified with the variable name
} else {
return(list(data = NULL, group = NULL, split = NULL, cluster = NULL, id = NULL, obs = NULL, day = NULL, time = NULL))
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Exclude Non-Numeric Variables ————————————————————————————————————————————————
.exclude.non.numeric <- function(x, func = NULL, ordered = FALSE) {
x <- (if (ordered) {
(!vapply(x, function(z) is.numeric(z) | is.ordered(z), FUN.VALUE = logical(1L)))
} else {
(!vapply(x, function(z) is.numeric(z), FUN.VALUE = logical(1L)))
}) |> (\(p) if (isTRUE(any(p))) {
if (isTRUE(sum(p) == 1L)) {
warning(paste0("Non-numeric variable was excluded from the analysis: ", paste(names(which(p)), collapse = ", ")), call. = FALSE)
} else {
warning(paste0("Non-numeric variables were excluded from the analysis: ", paste(names(which(p)), collapse = ", ")), call. = FALSE)
}
return(x[, -which(p), drop = FALSE])
} else {
return(x)
})()
# No variables left
if (isTRUE(ncol(x) == 0L)) { stop("No variables left for analysis after excluding non-numeric variables.", call. = FALSE) }
# At least two variables
if (isTRUE(func == "cor.matrix" && ncol(x) == 1L)) { stop("At least two variables after excluding non-numeric variables are needed to compute the correlation coefficient.", call. = FALSE) }
# At least two variables
if (isTRUE(func == "item.alpha" && ncol(x) == 1L)) { stop("At least two items after excluding non-numeric variables are needed to compute coefficient alpha.", call. = FALSE) }
# At least three variables
if (isTRUE(func == "item.omega" && ncol(x) == 2L)) { stop("At least three items after excluding non-numeric variables are needed to compute coefficient omega.", call. = FALSE) }
# At least two variables
if (isTRUE(func == "item.stats" && ncol(x) == 1L)) { stop("At least two items after excluding non-numeric variables are needed to compute item statistics.", call. = FALSE) }
# At least three variables
if (isTRUE(func == "multilevel.cor" && ncol(x) == 2L)) { stop("At least two variables after excluding non-numeric variables are needed to compute a correlation coefficient.", call. = FALSE) }
# Return object
return(x)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Convert user-missing values into NA ——————————————————————————————————————————
.as.na <- function(x, na) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Replace user-specified values with NAs ####
x <- misty::as.na(x, na = na, check = FALSE)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Vector or factor ####
if (isTRUE(is.null(dim(x)))) {
# Check for missing values only
if (isTRUE(all(is.na(x)))) { stop("After converting user-missing values into NA, 'x' is completely missing.", call. = FALSE) }
# Check for zero variance
if (isTRUE(length(na.omit(unique(x))) == 1L)) { stop("After converting user-missing values into NA, 'x' has zero variance.", call. = FALSE) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Matrix or Data Frame ####
} else {
# Check for variables with missing values only
x.na.all <- vapply(as.data.frame(x), function(y) all(is.na(y)), FUN.VALUE = logical(1L))
if (isTRUE(any(x.na.all))) {
if (isTRUE(sum(x.na.all) == 1L)) {
stop(paste0("After converting user-missing values into NA, following variable has zero variance: ", names(which(x.na.all))), call. = FALSE)
} else {
stop(paste0("After converting user-missing values into NA, following variables have zero variance: ", paste(names(which(x.na.all)), collapse = ", ")), call. = FALSE)
}
}
# Check for variables with zero variance
x.zero.var <- vapply(as.data.frame(x), function(y) length(na.omit(unique(y))) == 1L, FUN.VALUE = logical(1L))
if (isTRUE(any(x.zero.var))) {
if (isTRUE(sum(x.zero.var) == 1L)) {
stop(paste0("After converting user-missing values into NA, following variable has zero variance: ", names(which(x.zero.var))), call. = FALSE)
} else {
stop(paste0("After converting user-missing values into NA, following variables have zero variance: ", paste(names(which(x.zero.var)), collapse = ", ")), call. = FALSE)
}
}
}
return(x)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the blimp.run() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Run Blimp ####
.blimp.source <- function(target, Blimp, posterior, folder, format, clear) {
#—————————————————————————————————————— #
### File Name, Blimp Path, and Plot Folder ####
# File name
base <- sub("\\.imp", "", basename(target))
# Path name
dirnam <- dirname(target)
# Blimp path
blimp_path <- Blimp
# Preprocess path for non-UNIX platform
if (isTRUE(.Platform$OS.type != "unix")) { blimp_path <- paste0('"', blimp_path, '"') }
# Make Posterior folder
if (isTRUE(posterior)) { dir.create(file.path(dirnam, paste0(folder, base)), showWarnings = FALSE) }
#—————————————————————————————————————— #
### Modify Input ####
if (isTRUE(posterior)) {
target.read <- suppressWarnings(readLines(target))
suppressWarnings(writeLines(target.read |>
(\(x) c(x, paste("SAVE:\n",
if (isTRUE(any(grepl("BYGROUP:", x, ignore.case = TRUE)))) {
paste0("estimates = ", folder, base, "/estimates*.csv;\n")
} else {
paste0("estimates = ", folder, base, "/estimates.csv;\n")
},
paste0("iterations = ", folder, base, "/iter*.csv;\n"))))(), target))
}
#—————————————————————————————————————— #
### Make Command ####
if (isTRUE(posterior)) {
cmd <- paste(blimp_path, shQuote(target), "--traceplot", shQuote(file.path(paste0(folder, base))), "--truncate 100", "--output", shQuote(file.path(dirnam, paste0(base, ".blimp-out"))))
} else {
cmd <- paste(blimp_path, shQuote(target), "--truncate 100", "--output", shQuote(file.path(dirnam, paste0(base, ".blimp-out"))))
}
#—————————————————————————————————————— #
### Run Command ####
out <- tryCatch(system(cmd), error = function(y) { stop("Running Blimp failed.", call. = FALSE) })
# ERROR message
if (isTRUE(out != 0)) {
sink(file.path(dirnam, paste0(base, ".blimp-out")), append = TRUE)
cat("ERROR:\n\n",
suppressWarnings(system(cmd, intern = TRUE)) |> (\(y) paste("", sub("ERROR: ", "", y)))())
sink()
}
#—————————————————————————————————————— #
### Post-Process Posterior Data ####
if (isTRUE(posterior && file.exists(paste0(folder, base, "/labels.dat")))) {
if (isTRUE(all(!grepl("BYGROUP:", target.read, ignore.case = TRUE)))) {
param <- chain <- iter <- latent1 <- latent2 <- latent3 <- NULL
#···················
#### Message ####
cat("Saving posterior distribution for all parameters, this may take a while.\n")
#···················
#### Labels ####
labels <- read.table(paste0(folder, base, "/labels.dat"), header = TRUE) |>
setNames(object = _, nm = c("latent1", "latent2", "latent3", "param", "block")) |>
(\(z) within(z, param <- paste0("p", param)))()
#···················
#### Burn-In Data ####
# Data in long format
burnin <- lapply(list.files(paste0(folder, base), pattern = "burn", full.names = TRUE), function(y) {
read.csv(y, header = FALSE) |>
setNames(object = _, nm = c("iter", labels$param)) |>
(\(z) reshape(z, varying = list(colnames(z)[-1L]), v.names = "value", idvar = colnames(z)[1L], times = colnames(z)[-1], direction = "long"))()
})
# Add chain
for (i in seq_along(burnin)) { burnin[[i]] <- data.frame(chain = i, burnin[[i]]) }
# Row bind
burnin <- do.call(rbind, burnin)
#···················
#### Post-Burn-In Data ####
# Data in long format
postburn <- lapply(list.files(paste0(folder, base), pattern = "iter", full.names = TRUE), function(y) {
read.csv(y, header = FALSE) |>
setNames(object = _, nm = labels$param) |>
(\(z) data.frame(iter = max(burnin$iter) + 1L:nrow(z), z))() |>
(\(w) reshape(w, varying = list(colnames(w)[-1L]), v.names = "value", idvar = colnames(w)[1L], times = colnames(w)[-1], direction = "long"))()
})
# Add chain
for (i in seq_along(postburn)) { postburn[[i]] <- data.frame(chain = i, postburn[[i]]) }
# Row bind
postburn <- do.call(rbind, postburn)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Combine Burn-in Data and Post-Burn-In Data ####
# Row bind and merge with labels
posterior <- misty::df.rename(rbind(data.frame(postburn = 0L, burnin), data.frame(postburn = 1L, postburn)), from = "time", to = "param") |>
(\(z) misty::df.move(latent1, latent2, latent3, data = merge(x = z, labels, by = "param"), after = "param"))() |>
(\(w) misty::df.sort(w, param, chain, iter))() |>
(\(q) within(q, param <- as.numeric(sub("p", "", param))))()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Save Data ####
if (isTRUE("csv" %in% format)) { utils::write.csv(posterior, file.path(paste0(folder, base), "posterior.csv"), row.names = FALSE) }
if (isTRUE("csv2" %in% format)) { utils::write.csv2(posterior, file.path(paste0(folder, base), "posterior.csv"), row.names = FALSE) }
if (isTRUE("xlsx" %in% format)) { misty::write.xlsx(posterior, file.path(paste0(folder, base), "posterior.xlsx")) }
if (isTRUE("rds" %in% format)) { base::saveRDS(posterior, file = file.path(paste0(folder, base), "posterior.rds")) }
if (isTRUE("RData" %in% format)) { base::save(posterior, file = file.path(paste0(folder, base), "posterior.RData")) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Save Parameter Table ####
labels[, c("param", "latent1", "latent2", "latent3")] |>
(\(z) within(z, param <- as.numeric(gsub("p", "", param))))() |>
(\(w) format(rbind(c("Param", "L1", "L2", "L3"), w), justify = "left"))() |>
write.table(x = _, file = paste0(folder, base, "/partable.txt"), quote = FALSE, row.names = FALSE, col.names = FALSE)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Post-Process Estimates ####
write.csv(read.csv(paste0(folder, base, "/estimates.csv"), check.names = FALSE) |>
(\(z) data.frame(param = as.numeric(sub("p", "", labels$param)), latent1 = labels$latent1, latent2 = labels$latent2, latent3 = labels$latent3, z, check.names = FALSE))(), paste0(folder, base, "/estimates.csv"), row.names = FALSE)
}
}
#—————————————————————————————————————— #
### Clear Console ####
if (isTRUE(clear && .Platform$GUI == "RStudio")) { misty::clear() }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Detect Blimp Location ####
.detect.blimp <- function(exec = "blimp") {
env_r_blimp <- Sys.getenv("R_BLIMP", unset = NA)
if (isTRUE(!is.na(env_r_blimp))) { if (isTRUE(file.exists(env_r_blimp) & !dir.exists(env_r_blimp))) { return(env_r_blimp) } }
user_os <- tolower(R.Version()$os)
# Mac
if (isTRUE(grepl("darwin", user_os))) {
return(.detect_blimp_macos(exec))
# Linux
} else if (isTRUE(grepl("linux", user_os))) {
return(.detect_blimp_linux(exec))
# Windows
} else if (isTRUE(grepl("windows", user_os) || grepl("mingw32", user_os))) {
return(.detect_blimp_windows(paste0(exec, ".exe")))
}
stop("Unable to detect the operating system.", call. = FALSE)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Find Blimp on MacOS ####
.detect_blimp_macos <- function(exec) {
output <- suppressWarnings(system(paste("which", exec), intern = TRUE, ignore.stderr = TRUE)[1L])
if (isTRUE(length(output) != 0L)) { if (isTRUE(file.exists(output))) { return(output) } }
output <- paste0("/Applications/Blimp/", exec)
if (isTRUE(file.exists(output))) { return(output) }
output <- paste0("~", output)
if (isTRUE(file.exists(output))) { return(output) }
stop("Unable to find blimp executable, make sure Blimp is installed.", call. = FALSE)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Find Blimp on Linux ####
.detect_blimp_linux <- function(exec) {
output <- suppressWarnings(system(paste("which", exec), intern = TRUE, ignore.stderr = TRUE)[1L])
if (isTRUE(length(output) != 0L)) { if (isTRUE(file.exists(output))) { return(output) } }
stop("Unable to find blimp executable, ,ake sure Blimp is installed.", call. = FALSE)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Find Blimp on Windows ####
.detect_blimp_windows <- function(exec) {
output <- suppressWarnings(system(paste("where", exec), intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(output) != 0L)) { if (isTRUE(file.exists(output))) { return(output) } }
output <- paste0("C:\\Program Files\\Blimp\\", exec)
if (isTRUE(file.exists(output))) { return(output) }
output <- paste0("D:\\Program Files\\Blimp\\", exec)
if (isTRUE(file.exists(output))) { return(output) }
stop("Unable to find blimp executable, ,ake sure Blimp is installed.", call. = FALSE)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the blimp.bayes() function ----------------------------
# mplus.bayes() function ----------------------------
#
# - .map
# - .hdi
# - .rhat
# - .split.chains
# - .zscale
# - .autocovariance
# - .ess
# - .mcse
#
# rstan package
# https://github.com/stan-dev/rstan/blob/develop/rstan/rstan/R/monitor.R
#
# bayestestR package
# https://github.com/easystats/bayestestR/blob/main/R/map_estimate.R
# https://github.com/easystats/bayestestR/blob/main/R/hdi.R
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified map_estimate Function from the bayestestR Package ####
#
# Maximum A Posteriori probability estimate
.map <- function(x) {
x.density <- density(na.omit(x), n = 2L^10L, bw = "SJ", from = range(x)[1L], to = range(x)[2L])
x.density$x[which.max(x.density$y)]
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified hdi Function from the bayestestR Package ####
#
# Highest density interval
.hdi <- function(x, conf.level = NULL) {
x.sorted <- unname(sort.int(x, method = "quick"))
window.size <- ceiling(conf.level * length(x.sorted))
if (isTRUE(window.size < 2L)) { return(data.frame(low = NA, upp = NA)) }
nCIs <- length(x.sorted) - window.size
if (isTRUE(nCIs < 1L)) { return(data.frame(low = NA, upp = NA)) }
ci.width <- sapply(seq_len(nCIs), function(y) x.sorted[y + window.size] - x.sorted[y])
min.i <- which(ci.width == min(ci.width))
if (isTRUE(length(min.i) > 1L)) {
if (isTRUE(any(diff(sort(min.i)) != 1L))) {
min.i <- max(min.i)
} else {
min.i <- floor(mean(min.i))
}
}
c(low = x.sorted[min.i], upp = x.sorted[min.i + window.size])
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified rhat_rfun Function from the rstan Package ####
#
# Compute the Rhat convergence diagnostic for a single parameter
.rhat <- function(x, fold, split, rank) {
# One chain
if (isTRUE(is.vector(x))) { dim(x) <- c(length(x), 1L) }
# Fold
if (isTRUE(fold)) { x <- abs(x - median(x)) }
# Split chains
if (isTRUE(split)) { x <- .split.chains(x) }
# Rank-normalization
if (isTRUE(rank)) { x <- .zscale(x) }
# Number of iterations
n.iter <- nrow(x)
# Compute R hat
rhat <- sqrt((n.iter * var(colMeans(x)) / mean(apply(x, 2L, var)) + n.iter - 1L) / n.iter)
# Return value
return(rhat)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified split_chains Function from the rstan Package ####
#
# Split Markov Chains
.split.chains <- function(x) {
# One chain
if (isTRUE(is.vector(x))) { dim(x) <- c(length(x), 1L) }
# Number of iterations
n.iter <- nrow(x)
# Combine by columns
x <- cbind(x[1L:floor(n.iter / 2L), ], x[ceiling(n.iter / 2L + 1L):n.iter, ])
# Return value
return(x)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified z_scale Function from the rstan Package ####
#
# Compute rank normalization for a numeric array
.zscale <- function(x) {
z <- qnorm((rank(x, ties.method = "average") - 1L / 2L) / length(x))
z[is.na(x)] <- NA
if (!is.null(dim(x))) { z <- array(z, dim = dim(x), dimnames = dimnames(x)) }
return(z)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified autocovariance Function from the rstan Package ####
#
# Compute autocorrelation estimates for every lag for the specified input sequence
# using a fast Fourier transform approach
.autocovariance <- function(x) {
N <- length(x)
varx <- var(x)
if (isTRUE(varx == 0L)) { return(rep(0L, N)) }
ac <- Re(fft(abs(fft(c((x - mean(x)), rep.int(0L, (2L * nextn(N)) - N))))^2L, inverse = TRUE)[1L:N])
ac <- ac / ac[1L] * varx * (N - 1L) / N
return(ac)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified ess_rfun Function from the rstan Package ####
#
# Compute the effective sample size estimate for a sample of several chains for
# one parameter
.ess <- function(x, split, rank) {
# One chain
if (isTRUE(is.vector(x))) { dim(x) <- c(length(x), 1L) }
# Split chains
if (isTRUE(split)) { x <- .split.chains(x) }
# Rank-normalization
if (isTRUE(rank)) { x <- .zscale(x) }
chains <- ncol(x)
n_samples <- nrow(x)
if (isTRUE(n_samples < 3L)) { return(NA_real_) }
acov <- do.call(cbind, lapply(seq_len(chains), function(y) .autocovariance(x[, y])))
mean_var <- mean(acov[1L, ]) * n_samples / (n_samples - 1L)
var_plus <- mean_var * (n_samples - 1L) / n_samples
if (isTRUE(chains > 1L)) { var_plus <- var_plus + var(colMeans(x)) }
rho_hat_t <- rep.int(0L, n_samples)
t <- 0L
rho_hat_even <- 1L
rho_hat_t[t + 1L] <- rho_hat_even
rho_hat_odd <- 1L - (mean_var - mean(acov[t + 2L, ])) / var_plus
rho_hat_t[t + 2L] <- rho_hat_odd
while (isTRUE(t < nrow(acov) - 5L && !is.nan(rho_hat_even + rho_hat_odd) && (rho_hat_even + rho_hat_odd > 0L))) {
t <- t + 2L
rho_hat_even <- 1L - (mean_var - mean(acov[t + 1L, ])) / var_plus
rho_hat_odd <- 1L - (mean_var - mean(acov[t + 2L, ])) / var_plus
if (isTRUE((rho_hat_even + rho_hat_odd) >= 0L)) {
rho_hat_t[t + 1L] <- rho_hat_even
rho_hat_t[t + 2L] <- rho_hat_odd
}
}
max_t <- t
if (isTRUE(rho_hat_even > 0L)) { rho_hat_t[max_t + 1L] <- rho_hat_even }
t <- 0L
while (isTRUE(t <= max_t - 4L)) {
t <- t + 2L
if (isTRUE(rho_hat_t[t + 1L] + rho_hat_t[t + 2L] > rho_hat_t[t - 1L] + rho_hat_t[t])) {
rho_hat_t[t + 1L] = (rho_hat_t[t - 1L] + rho_hat_t[t]) / 2L
rho_hat_t[t + 2L] = rho_hat_t[t + 1L]
}
}
ess <- chains * n_samples
tau_hat <- -1L + 2L * sum(rho_hat_t[1L:max_t]) + rho_hat_t[max_t + 1L]
tau_hat <- max(tau_hat, 1L/log10(ess))
ess <- ess / tau_hat
return(ess)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified conv_quantile and mcse_mean Function from the rstan Package ####
#
# Compute Monte Carlo standard error for the mean and a quantile
.mcse <- function(x, quant = FALSE, prob = NULL, split = TRUE, rank = TRUE) {
# MCSE for a quantile
if (isTRUE(quant)) {
ess <- .ess(x <= quantile(x, prob), split = split, rank = rank)
a <- qbeta(c(0.1586553, 0.8413447), ess * prob + 1L, ess * (1L - prob) + 1L)
x.sort <- sort(x)
S <- length(x.sort)
mcse <- (x.sort[min(round(a[2L] * S), S)] - x.sort[max(round(a[1L] * S), 1L)] ) / 2L
# MCSE for the mean
} else {
mcse <- sd(x) / sqrt(.ess(x, split = split, rank = rank))
}
return(mcse)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the boot.bs() function --------------------------------
#
# https://github.com/simsem/semTools/blob/master/semTools/R/missingBootstrap.R
#
# .trans1
# .trans2
# .getBootSample
# .fitBootSample
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Execute Transformation 1 on a Single Missing-Data Pattern ####
.trans1 <- function(MDpattern, pattern, dat, sigma, mu) {
X <- apply(dat[which(pattern == MDpattern), ], 2, scale, scale = FALSE)
observed <- !is.na(X[1, ])
Xreduced <- X[ , observed]
Y <- replace(X, !is.na(X), t((t(chol(sigma[observed, observed])) %*% t(solve(chol(t(Xreduced) %*% Xreduced / nrow(X))))) %*% t(Xreduced) + as.numeric(mu[observed])))
return(Y)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Execute Transformation 2 on a Single Group ####
.trans2 <- function(dat, sigma, mu, em.cov) {
# Function of A (eq. 12)
eq12 <- function(A) {
ga <- rep(0L, pStar)
for (j in seq_len(J)) {
ga <- ga + Njs[j] * Dupinv %*% c(Mjs[[j]] %*% A %*% Hjs[[j]] %*% A %*% Mjs[[j]] - Mjs[[j]])
}
return(ga)
}
# Derivative of Function of A (eq. 13)
eq13 <- function(A) {
deriv12 <- matrix(0L, nrow = pStar, ncol = pStar)
for (j in seq_len(J)) {
deriv12 <- deriv12 + 2L*Njs[j]*Dupinv %*% kronecker((Mjs[[j]] %*% A %*% Hjs[[j]]), Mjs[[j]]) %*% Dup
}
return(deriv12)
}
# Missing data patterns
rowMissPatt <- apply(ifelse(is.na(dat), 1L, 0L), 1L, function(x) paste(x, collapse = ""))
MDpattern <- unique(rowMissPatt)
# Sample size within each MD pattern
Njs <- sapply(MDpattern, function(patt) sum(rowMissPatt == patt))
J <- length(MDpattern)
p <- ncol(dat)
pStar <- p*(p + 1L) / 2L
# Empty lists for each MD pattern
Xjs <- vector("list", J)
Hjs <- vector("list", J)
Mjs <- vector("list", J)
# Duplication Matrix and its inverse (Magnus & Neudecker, 1999)
Dup <- lavaan::lav_matrix_duplication(p)
Dupinv <- solve(t(Dup) %*% Dup) %*% t(Dup)
# Step through each MD pattern, populate Hjs and Mjs
for (j in seq_len(J)) {
Xjs[[j]] <- apply(dat[rowMissPatt == MDpattern[j], ], 2L, scale, scale = FALSE)
if (isTRUE(!is.matrix(Xjs[[j]]))) { Xjs[[j]] <- t(Xjs[[j]]) }
observed <- !is.na(Xjs[[j]][1L, ])
Sj <- t(Xjs[[j]]) %*% Xjs[[j]] / Njs[j]
Hjs[[j]] <- replace(Sj, is.na(Sj), 0L)
Mjs[[j]] <- replace(Sj, !is.na(Sj), solve(sigma[observed, observed]))
Mjs[[j]] <- replace(Mjs[[j]], is.na(Mjs[[j]]), 0L)
}
## Compute starting Values for A
if (isTRUE(is.null(em.cov))) {
A <- diag(p)
} else {
EMeig <- eigen(em.cov)
Sigeig <- eigen(sigma)
B <- (Sigeig$vectors %*% diag(sqrt(Sigeig$values)) %*% t(Sigeig$vectors)) %*% (EMeig$vectors %*% diag(1L / sqrt(EMeig$values)) %*% t(EMeig$vectors))
A <- 0.5*(B + t(B))
}
# Newton Algorithm for finding root (eq. 14)
crit <- 0.1
a <- c(A)
fA <- eq12(A)
while (isTRUE(crit > 1e-11)) {
dvecF <- eq13(A)
a <- a - Dup %*% solve(dvecF) %*% fA
A <- matrix(a, ncol = p)
fA <- eq12(A)
crit <- max(abs(fA))
}
# Transform dataset X to dataset Y
Yjs <- Xjs
for (j in seq_len(J)) {
Yjs[[j]] <- (!is.na(Xjs[[j]][1L, ])) |> (\(p) replace(Yjs[[j]], !is.na(Yjs[[j]]), (t((A[p, p, drop = FALSE]) %*% t((Xjs[[j]][ , p, drop = FALSE])) + as.numeric(mu[p])))))()
}
Y <- setNames(as.data.frame(do.call("rbind", Yjs)), nm = colnames(dat))
return(Y)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Draw a Single Bootstrap Sample from the Transformed Data ####
.getBootSample <- function(dat, group, group.label) {
bootSamp <- list()
for (i in seq_along(dat)) {
temp <- dat[[i]]
temp[ , group] <- group.label[i]
bootSamp[[i]] <- temp[sample(seq_len(nrow(temp)), nrow(temp), replace = TRUE), ]
}
return(do.call("rbind", bootSamp))
}
## fit the model to a single bootstrapped sample and return chi-squared
.fitBootSample <- function(dat, args) {
args$data <- dat
lavaanlavaan <- function(...) { lavaan::lavaan(...) }
fit <- do.call(lavaanlavaan, args)
if (isTRUE(!exists("fit"))) { return(c(chisq = NA)) }
if (isTRUE(lavaan::lavInspect(fit, what = "converged"))) {
chisq <- lavaan::lavInspect(fit, what = "fit")[c("chisq", "chisq.scaled")]
} else {
chisq <- NA
}
if (isTRUE(is.na(chisq[2L]))) { return(chisq[1L]) } else { return(chisq[2L]) }
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the check.resid() function ----------------------------
#
# - .resid.partial
# - .calc_ranef
#
# remef: Remove Partial Effects
# https://github.com/hohenstein/remef/
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Calculate Partial Effects ####
#
# Adapted function partial()
.resid.partial <- function(model, fix = NULL, ran = "all") {
#—————————————————————————————————————— #
### Part 1: Fixed Effects ####
is.na(match(fix, colnames(model.matrix(model)) |> (\(y) if (isTRUE(as.logical(attr(terms(model), "intercept")))) { y[-1L] } else { y })())) |> (\(y) if (isTRUE(any(y))) { stop("The following effects are not present in the model: ", paste(fix[y], collapse = ", "), call. = FALSE) })()
DV <- lme4::getME(model, "y") - as.vector(model.matrix(model)[ , fix, drop = FALSE] %*% lme4::fixef(model)[fix])
#—————————————————————————————————————— #
### Part 2: Random effects ####
DV <- DV - .calc_ranef(model, lapply(lapply(lme4::ranef(model), names), seq_along))
return(unname(DV))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Calculate Random Effects based on a Subset of Variance Terms ####
#
# Adapted function calc_ranef()
.calc_ranef <- function(model, ran) {
if (isTRUE(length(ran) == 0L)) { return(numeric(length = lme4::getME(model, "n"))) }
if (isTRUE(is.list(ran) && length(ran) > 0L)) {
stopifnot(is.numeric(unlist(ran)))
ran <- lapply(ran, unique)
ran <- ran[vapply(ran, length, 1L) > 0L]
}
ran_labs <- lapply(lme4::ranef(model), names)
if (isTRUE(is.null(names(ran)) || any( !names(ran) %in% names(ran_labs)) || any(duplicated(names(ran))))) { stop("The list 'ran' has invalid names.", call. = FALSE) }
num_re <- vapply(ran_labs, length, FUN.VALUE = 1L, USE.NAMES = FALSE)
num_re_previous <- c(0L, cumsum(head(num_re, -1L)))
rf_idx <- match(names(ran), names(ran_labs))
ran_model <- lme4::ranef(model)
ran_model_sub <- lapply(mapply(`[`, ran_model[rf_idx], ran, SIMPLIFY = FALSE), unlist)
re_list <- lapply(mapply(function(x, y) seq_len(x) + y, num_re, num_re_previous, SIMPLIFY = FALSE), function(x) lme4::getME(model, "Ztlist")[x])
re_list_sub <- mapply(`[`, re_list[rf_idx], ran, SIMPLIFY = FALSE)
ran_model_sub <- mapply(`[`, ran_model[rf_idx], ran, SIMPLIFY = FALSE)
ranef_sums <- rowSums(do.call(cbind, mapply(function(mats, vecs) mapply(function(v, m) as.vector(v %*% m), vecs, mats), re_list_sub, ran_model_sub, SIMPLIFY = FALSE)))
return(ranef_sums)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the chr.gsub() function -------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Fast escape replace ####
#
# Fast escape function for limited case where only one pattern
# provided actually matches anything
#
# Argument string: a character vector where replacements are sought
# Argument pattern: a character string to be matched in the given character vector
# Argument replacement: Character string equal in length to pattern or of length
# one which are a replacement for matched pattern.
# Argument ...: arguments to pass to gsub()
.fastReplace <- function(string, pattern, replacement, ...) {
for (i in seq_along(pattern)) {
string <- gsub(pattern[i], replacement[i], string, ...)
}
return(string)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Filter Overlaps from Matches ####
#
# Helper function used to identify which results from gregexpr()
# overlap other matches and filter out shorter, overlapped results
#
# Argument x: a matrix of gregexpr() results, 4 columns, index of column matched,
# start of match, length of match, end of match. Produced exclusively from
# a .worker function in chr.gsub
.filterOverlap <- function(x) {
for (i in nrow(x):2L) {
s <- x[i, 2L]
ps <- x[1L:(i - 1L), 2L]
e <- x[i, 4]
pe <- x[1L:(i - 1L), 4L]
if (any(ps <= s & pe >= s)){
x <- x[-i, ]
next
}
if (any(ps <= e & pe >= e)) {
x <- x[-i,]
next
}
}
return(matrix(x, ncol = 4L))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Get all Matches ####
#
# Helper function to be used in a loop to check each pattern
# provided for matches
#
# Argument string: a character vector where replacements are sought
# Argument pattern: a character string to be matched in the given character vector
# Argument i: an iterator provided by a looping function
# Argument ...: arguments to pass to gregexpr()
.getMatches <- function(string ,pattern, i, ...){
tmp <- gregexpr(pattern[i], string,...)
start <- tmp[[1L]]
length <- attr(tmp[[1L]], "match.length")
return(matrix(cbind(i, start, length, start + length - 1L), ncol = 4L))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## chr.gsub() .worker ####
#
# Argument string: a character vector where replacements are sought
# Argument pattern: a character string to be matched in the given character vector
# Argument replacement: a character string equal in length to pattern or of length
# one which are a replacement for matched pattern.
# Argument ...: arguments to pass to regexpr family
.worker <- function(string, pattern, replacement,...){
x0 <- do.call(rbind, lapply(seq_along(pattern), .getMatches, string = string, pattern = pattern, ...))
x0 <- matrix(x0[x0[, 2L] != -1L, ], ncol = 4L)
uid <- unique(x0[, 1L])
if (nrow(x0) == 0L) {
return(string)
}
if (length(unique(x0[, 1])) == 1L) {
return(.fastReplace(string, pattern[uid], replacement[uid], ...))
}
if (nrow(x0) > 1L) {
x <- x0[order(x0[, 3L], decreasing = TRUE), ]
x <- .filterOverlap(x)
uid <- unique(x[, 1L])
if (length(uid) == 1L) {
return(.fastReplace(string, pattern[uid], replacement[uid], ...))
}
x <- x[order(x[, 2L]), ]
}
for (i in nrow(x):1L){
s <- x[i, 2L]
e <- x[i, 4L]
p <- pattern[x[i, 1L]]
r <- replacement[x[i, 1L]]
pre <- if (s > 1L) { substr(string, 1L, s - 1L) } else { "" }
r0 <- sub(p,r,substr(string, s, e), ...)
end <- if (e < nchar(string)) { substr(string, e + 1, nchar(string)) } else { "" }
string <- paste0(pre, r0, end)
}
return(string)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.cor() function ---------------------------------
#
# - .multsolvefun
# - .sqerrVMc
# - .sqerrVMintr
# - .VMparstomoms
# - .Tf2fun
# - .smpmomvecfun
# - .smpmjkfun
# - .zciofrfun
# - .estskkufun
# - .ci.pearson.cor.adjust
# - .ci.spearman.cor.adjust
# - .ci.kendall.b
# - .ci.kendall.c
# - .ci.kendall.c.estimate
# - .norm.inter
# - .boot.func.cor
# - .ci.boot.cor
#
# Bishara et al. (2018) Supporting Information
# https://bpspsychub.onlinelibrary.wiley.com/action/downloadSupplement?doi=10.1111%2Fbmsp.12113&file=bmsp12113-sup-0002-DataS2.txt
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Multiple Attempts to find 3rd order Polynomial Parameters ####
.multsolvefun <- function(xskku, yskku, obsr, seed = NULL, maxtol = 0.0001, nudge = 0.01, tryrndpars = 5L) {
if (isTRUE(!is.null(seed))) { set.seed(seed) }
failsolve <- FALSE
failcountvec <- nudgesmadevec <- rep(0L, 3L)
xskku.small <- xskku
yskku.small <- yskku
obsr.small <- obsr
Xmod <- try(stats::optim(c(1L, 0L, 0L), .sqerrVMc, sk = xskku[1L], ku = xskku[2L], method = "N"))
if (isTRUE(Xmod$value > maxtol)) { failsolve <- TRUE }
while (isTRUE(failsolve)) {
failcountvec <- failcountvec + c(1L, 0L, 0L)
randpars <- (stats::runif(3L) - 0.5)*c(3L, 1L, 0.5)
if (isTRUE((failcountvec[1L] %% tryrndpars == 1L) & (failcountvec[1L] > 1L))) {
nudgesmadevec <- nudgesmadevec + c(1L, 0L, 0L)
nudgemult <- 1L - nudge*nudgesmadevec[1L]
xskku.small <- xskku*nudgemult
}
Xmod <- try(optim(randpars, .sqerrVMc, sk = xskku.small[1L], ku = xskku.small[2L], method = "N"))
if(isTRUE((Xmod$value < maxtol) | (nudgesmadevec[1L] >= 100L))) { failsolve <- FALSE }
}
Ymod <- try(optim(c(1L, 0L, 0L), .sqerrVMc, sk = yskku[1L], ku = yskku[2L], method = "N"))
if (isTRUE(Ymod$value > maxtol)) { failsolve <- TRUE }
while (isTRUE(failsolve)) {
failcountvec <- failcountvec + c(0L, 1L, 0L)
randpars <- (runif(3L) - 0.5)*c(3L, 1L, 0.5)
if (isTRUE((failcountvec[2] %% tryrndpars == 1) & (failcountvec[2] > 1))) {
nudgesmadevec <- nudgesmadevec + c(0L, 1L, 0L)
nudgemult <- 1L - nudge*nudgesmadevec[2L]
yskku.small <- yskku*nudgemult
}
Ymod <- try(optim(randpars, .sqerrVMc, sk = yskku.small[1L], ku = yskku.small[2L], method = "N"))
if (isTRUE((Ymod$value < maxtol) | (nudgesmadevec[2L] >= 100L))) { failsolve <- FALSE }
}
estconstvec <- c(Xmod$par,Ymod$par)
if (isTRUE(nudgesmadevec[1L] >= 100)) { estconstvec[1L:3L] <- c(1L, 0L, 0L) }
if (isTRUE(nudgesmadevec[2L] >= 100)) { estconstvec[4L:6L] <- c(1L, 0L, 0L) }
intrmod <- try(optimize(.sqerrVMintr, cpars = estconstvec, obsr = obsr, interval = c(-1L, 1L)))
if (isTRUE(intrmod$objective > maxtol)) { failsolve <- TRUE }
while (isTRUE(failsolve)) {
failcountvec <- failcountvec + c(0L, 0L, 1L)
nudgesmadevec <- nudgesmadevec + c(0L, 0L, 1L)
nudgemult <- 1L - nudge*nudgesmadevec[3L]
obsr.small <- obsr*nudgemult
intrmod <- try(optimize(.sqerrVMintr, cpars = estconstvec, obsr = obsr.small, interval = c(-1L, 1L)))
if (isTRUE((intrmod$objective < maxtol) | (nudgesmadevec[3L] >= 100L))) { failsolve <- FALSE }
}
if (isTRUE(nudgesmadevec[3L] < 100L)) {
intr <- intrmod$minimum
} else {
intr <- 0L
}
estconstmat <- rbind(estconstvec[1L:3L], estconstvec[4L:6L])
rownames(estconstmat) <- c("X","Y")
colnames(estconstmat) <- c("b","c","d")
return(list(estxyc = estconstmat, intr = intr, totsqerr = Xmod$value + Ymod$value + intrmod$objective, failed = failcountvec, nudgesmade = nudgesmadevec))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Squared Error of 3rd Order Polynomial Parameters ####
.sqerrVMc <- function(trypars, sk, ku) {
devvec <- rep(NA, 3L)
b <- trypars[1L]
c1 <- trypars[2L]
d <- trypars[3L]
devvec[1L] <- b^2L + 6L*b*d + 2L*c1^2L + 15L*d^2L - 1L
devvec[2L] <- 2L*c1*(b^2L + 24L*b*d + 105L*d^2L + 2L) - sk
devvec[3L] <- 24L*(b*d + c1^2L*(1 + b^2L + 28L*b*d) + d^2L*(12L + 48L*b*d + 141L*c1^2L + 225L*d^2L)) - ku
return(sum(devvec^2L))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Squared Error for Intermediate Correlation Parameter ####
.sqerrVMintr <- function(tryintr, cpars, obsr) {
b1 <- cpars[1L]
c1 <- cpars[2L]
d1 <- cpars[3L]
b2 <- cpars[4L]
c2 <- cpars[5L]
d2 <- cpars[6L]
return((((b1*b2 + 3L*b1*d2 + 3L*d1*b2 + 9L*d1*d2)*tryintr) + ((2L*c1*c2)*tryintr^2L) + ((6L*d1*d2)*tryintr^3L) - obsr)^2L)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Third Order Polynomial Parameters to Analytically Solve ####
.VMparstomoms <- function(consX, consY, intr) {
Power <- function(g, h) { g^h }
b1 <- consX[1L]
c1 <- consX[2L]
d1 <- consX[3L]
b2 <- consY[1L]
c2 <- consY[2L]
d2 <- consY[3L]
r <- intr
VMm22 <- Power(b1, 2L)*Power(b2, 2L) +
2L*Power(r, 2L)*Power(b1, 2L)*Power(b2, 2L) +
2L*Power(b2, 2L)*Power(c1, 2L) +
8L*Power(r, 2L)*Power(b2, 2L)*Power(c1, 2L) +
16L*r*b1*b2*c1*c2 +
24L*Power(r, 3L)*b1*b2*c1*c2 +
2L*Power(b1, 2L)*Power(c2, 2L) +
8L*Power(r, 2L)*Power(b1, 2L)*Power(c2, 2L) +
4L*Power(c1, 2L)*Power(c2, 2L) +
32L*Power(r, 2L)*Power(c1, 2L)*Power(c2, 2L) +
24L*Power(r, 4L)*Power(c1, 2L)*Power(c2, 2L) +
6L*b1*Power(b2, 2L)*d1 +
24L*Power(r, 2L)*b1*Power(b2, 2L)*d1 +
96L*r*b2*c1*c2*d1 +
216L*Power(r, 3L)*b2*c1*c2*d1 +
12L*b1*Power(c2, 2L)*d1 +
96L*Power(r, 2L)*b1*Power(c2, 2L)*d1 +
48L*Power(r, 4L)*b1*Power(c2, 2L)*d1 +
15L*Power(b2, 2L)*Power(d1, 2L) +
90L*Power(r, 2L)*Power(b2, 2L)*Power(d1, 2L) +
30L*Power(c2, 2L)*Power(d1, 2L) +
360L*Power(r, 2L)*Power(c2, 2L)*Power(d1, 2L) +
360L*Power(r, 4L)*Power(c2, 2L)*Power(d1, 2L) +
6L*Power(b1, 2L)*b2*d2 +
24L*Power(r, 2L)*Power(b1, 2L)*b2*d2 +
12L*b2*Power(c1, 2L)*d2 +
96L*Power(r, 2L)*b2*Power(c1, 2L)*d2 +
48L*Power(r, 4L)*b2*Power(c1, 2L)*d2 +
96L*r*b1*c1*c2*d2 +
216L*Power(r, 3L)*b1*c1*c2*d2 +
36L*b1*b2*d1*d2 +
288L*Power(r, 2L)*b1*b2*d1*d2 +
96L*Power(r, 4L)*b1*b2*d1*d2 +
576L*r*c1*c2*d1*d2 +
1944L*Power(r, 3L)*c1*c2*d1*d2 +
480L*Power(r, 5L)*c1*c2*d1*d2 +
90L*b2*Power(d1, 2L)*d2 +
1080L*Power(r, 2L)*b2*Power(d1, 2L)*d2 +
720L*Power(r, 4L)*b2*Power(d1, 2L)*d2 +
15L*Power(b1, 2L)*Power(d2, 2L) +
90L*Power(r, 2L)*Power(b1, 2L)*Power(d2, 2L) +
30L*Power(c1, 2L)*Power(d2, 2L) +
360L*Power(r, 2L)*Power(c1, 2L)*Power(d2, 2L) +
360L*Power(r, 4L)*Power(c1, 2L)*Power(d2, 2L) +
90L*b1*d1*Power(d2, 2L) +
1080L*Power(r, 2L)*b1*d1*Power(d2, 2L) +
720L*Power(r, 4L)*b1*d1*Power(d2, 2L) +
225L*Power(d1, 2L)*Power(d2, 2L) +
4050L*Power(r, 2L)*Power(d1, 2L)*Power(d2, 2L) +
5400L*Power(r, 4L)*Power(d1, 2L)*Power(d2, 2L) +
720L*Power(r, 6L)*Power(d1, 2L)*Power(d2, 2L)
VMm13 <- 3L*r*b1*Power(b2, 3L) +
30L*Power(r, 2L)*Power(b2, 2L)*c1*c2 +
30L*r*b1*b2*Power(c2, 2L) +
60L*Power(r, 2L)*c1*Power(c2, 3L) +
9L*r*Power(b2, 3L)*d1 +
6L*Power(r, 3L)*Power(b2, 3L)*d1 +
90L*r*b2*Power(c2, 2L)*d1 +
144L*Power(r, 3L)*b2*Power(c2, 2L)*d1 +
45L*r*b1*Power(b2, 2L)*d2 +
468L*Power(r, 2L)*b2*c1*c2*d2 +
234L*r*b1*Power(c2, 2L)*d2 +
135L*r*Power(b2, 2L)*d1*d2 +
180L*Power(r, 3L)*Power(b2, 2L)*d1*d2 +
702L*r*Power(c2, 2L)*d1*d2 +
1548L*Power(r, 3L)*Power(c2, 2L)*d1*d2 +
315L*r*b1*b2*Power(d2, 2L) +
2250L*Power(r, 2L)*c1*c2*Power(d2, 2L) +
945L*r*b2*d1*Power(d2, 2L) +
1890L*Power(r, 3L)*b2*d1*Power(d2, 2L) +
945L*r*b1*Power(d2, 3L) +
2835L*r*d1*Power(d2, 3L) +
7560L*Power(r, 3L)*d1*Power(d2, 3L)
VMm31 <- 3L*r*Power(b1, 3L)*b2 +
30L*r*b1*b2*Power(c1, 2L) +
30L*Power(r, 2L)*Power(b1, 2L)*c1*c2 +
60L*Power(r, 2L)*Power(c1, 3L)*c2 +
45L*r*Power(b1, 2L)*b2*d1 +
234L*r*b2*Power(c1, 2L)*d1 +
468L*Power(r, 2L)*b1*c1*c2*d1 +
315L*r*b1*b2*Power(d1, 2L) +
2250L*Power(r, 2L)*c1*c2*Power(d1, 2L) +
945L*r*b2*Power(d1, 3L) +
9L*r*Power(b1, 3L)*d2 +
6L*Power(r, 3L)*Power(b1, 3L)*d2 +
90L*r*b1*Power(c1, 2L)*d2 +
144L*Power(r, 3L)*b1*Power(c1, 2L)*d2 +
135L*r*Power(b1, 2L)*d1*d2 +
180L*Power(r, 3L)*Power(b1, 2L)*d1*d2 +
702L*r*Power(c1, 2L)*d1*d2 +
1548L*Power(r, 3L)*Power(c1, 2L)*d1*d2 +
945L*r*b1*Power(d1, 2L)*d2 +
1890L*Power(r, 3L)*b1*Power(d1, 2L)*d2 +
2835L*r*Power(d1, 3L)*d2 +
7560L*Power(r, 3L)*Power(d1, 3L)*d2
VMm40 <- 936L*b1*c1^2L*d1 + 60L*b1^2L*c1^2L + 60L*b1^3L*d1 + 630L*b1^2L*d1^2L + 3780L*b1*d1^3L + 3L*b1^4L + 4500L*c1^2L*d1^2L + 60L*c1^4L + 10395L*d1^4L
VMm04 <- 936L*b2*c2^2L*d2 + 60L*b2^2L*c2^2L + 60L*b2^3L*d2 + 630L*b2^2L*d2^2L + 3780L*b2*d2^3L + 3L*b2^4L + 4500L*c2^2L*d2^2L + 60L*c2^4L + 10395L*d2^4L
return(c(VMmu04 = VMm04, VMmu13 = VMm13, VMmu22 = VMm22, VMmu31 = VMm31, VMmu40 = VMm40))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Hawkins (1989) tau_f^2 term ####
.Tf2fun <- function(rho, mujkvec) {
m04 <- mujkvec[1L]
m13 <- mujkvec[2L]
m22 <- mujkvec[3L]
m31 <- mujkvec[4L]
m40 <- mujkvec[5L]
return(unname((((1L - rho^2L)^(-2L))*0.25)*((m40 + 2L*m22 + m04)*(rho^2L) - 4L*(m31 + m13)*rho + 4L*m22)))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Vector of Relevant Sample Joint Moments ####
.smpmomvecfun <- function(x, y) {
momvec <- rep(NA, 5L)
xcent <- x - mean(x)
ycent <- y - mean(y)
xstand <- scale(x)
ystand <- scale(y)
for (i in 0L:4L) {
momvec[i + 1L] <- .smpmjkfun(xstand, ystand, i, 4L - i)
names(momvec)[i + 1L] <- paste0("m", i, 4L - i)
}
return(momvec)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Sample Joint Moment ####
.smpmjkfun <- function(x, y, j, k) {
(1L / length(x))*sum((x^j)*(y^k))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## CI of Correlation using Mean and Standard Error of z ####
.zciofrfun <- function(z, zsd, alternative, conf.level) {
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
object <- tanh(z + c(qnorm(alphavec[1L]), qnorm(alphavec[2L]))*zsd)
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { object[1L] <- -1L }, greater = { object[2L] <- 1L }) }
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Skewness and Kurtosis in a Sample ####
.estskkufun <- function(x, sample = TRUE, center = TRUE) {
return(c(g1 = misty::skewness(x, sample = sample, check = FALSE), g2 = misty::kurtosis(x, sample = sample, center = center, check = FALSE)))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Main Function to Estimate Confidence Intervals for Pearson Correlation ####
.ci.pearson.cor.adjust <- function(x, y, adjust = c("none", "joint", "approx"), alternative = c("two.sided", "less", "greater"),
conf.level = 0.95, sample = TRUE, center = TRUE, seed = NULL, maxtol = 0.00001, nudge = 0.001) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
adjmethnames <- c("none", "joint", "approx")
boundsmat <- matrix(NA, nrow = 2L, ncol = 3L, dimnames = list(c("low", "upp"), adjmethnames))
sdzvec <- setNames(rep(NA, length(adjmethnames)), nm = adjmethnames)
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
r <- cor(x1, x2)
r.z <- atanh(r)
#···················
#### Unadjusted Standard Error ####
if (isTRUE("none" %in% adjust)) {
sdzvec[1L] <- 1L / sqrt(n - 3L)
} else {
sdzvec[1L] <- NA
}
#···················
#### Adjusted by Sample Joint Moments ####
if (isTRUE("joint" %in% adjust)) {
smpmomvec <- .smpmomvecfun(x1, x2)
jointmomTf2 <- .Tf2fun(rho = r, mujkvec = smpmomvec)
sdzvec[2L] <- sqrt(jointmomTf2 / (n - 3L))
} else {
smpmomvec <- jointmomTf2 <- NA
}
#···················
#### Adjusted by Approximate Distributing using Marginal Skewness and Kurtosis ####
XYg12mat <- matrix(c(.estskkufun(x1, sample = sample, center = center), .estskkufun(x2, sample = sample, center = center)),
nrow = 2L, ncol = 2L, byrow = TRUE, dimnames = list(c("X", "Y"), c("g1", "g2")))
if (isTRUE("approx" %in% adjust)) {
VMparlist <- .multsolvefun(xskku = XYg12mat[1L, ], yskku = XYg12mat[2L, ], obsr = r, maxtol = maxtol, nudge = nudge)
# Optimization succeeded
if (isTRUE(is.list(VMparlist))) {
VMmoms <- .VMparstomoms(VMparlist$estxyc[1, ], VMparlist$estxyc[2L, ], VMparlist$intr)
nudgedrho <- r*(1L - 0.01*VMparlist$nudgesmade[3L])
ApproxDistTf2 <- .Tf2fun(rho = nudgedrho, mujkvec = VMmoms)
sdzvec[3L] <- sqrt(ApproxDistTf2 / (n - 3L))
# Optimization failed
} else {
VMmoms <- setNames(rep(NA, 5L), nm = c("VMmu04", "VMmu13", "VMmu22", "VMmu31", "VMmu40"))
sdzvec[3L] <- ApproxDistTf2 <- NA
}
} else {
VMmoms <- setNames(rep(NA, 5L), nm = c("VMmu04", "VMmu13", "VMmu22", "VMmu31", "VMmu40"))
sdzvec[3L] <- ApproxDistTf2 <- NA
}
#···················
#### Confidence intervals ####
for (curadj in seq_len(length(adjmethnames))) {
boundsmat[, curadj] <- .zciofrfun(r.z, sdzvec[curadj], alternative = alternative, conf.level = conf.level)
}
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = XYg12mat[1L, "g1"], kurt1 = XYg12mat[1L, "g2"], skew2 = XYg12mat[2L, "g1"], kurt2 = XYg12mat[2L, "g2"],
cor = r, adjust = adjust, se = sdzvec, ci = boundsmat, skew.kurt = XYg12mat, joint.moments = smpmomvec, approx.moments = VMmoms, joint.tau2.f = jointmomTf2, approx.tau2.f = ApproxDistTf2)
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
cor = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(cor(x1, x2)) } else { NA }, adjust = adjust, se = sdzvec, ci = boundsmat, skew.kurt = NA, joint.moments = NA, approx.moments = NA, joint.tau2.f = NA, approx.tau2.f = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## CI for the Spearman Correlation with Fieller et al (1957), Bonett and Wright (2000), and RIN Standard Error ####
#
# Bishara and Hittner (2017) Supplementary Materials A
# https://static-content.springer.com/esm/art%3A10.3758%2Fs13428-016-0702-8/MediaObjects/13428_2016_702_MOESM1_ESM.pdf
#
# RIN transformation
# https://rpubs.com/seriousstats/616206
.ci.spearman.cor.se <- function(x, y, se = c("fisher", "fieller", "bonett", "rin"), sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
rs <- cor(x1, x2, method = "spearman")
if (isTRUE(se %in% c("fieller", "bonett"))) {
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
ci <- tanh(atanh(rs) + c(qnorm(alphavec[1L]), qnorm(alphavec[2L])) * switch(se, "fisher" = { sqrt(1 / (n - 3L)) }, "fieller" = { sqrt(1.06 / (n - 3L)) }, "bonett" = { sqrt((1L + (rs^2L) / 2L) / (n - 3L)) }))
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { ci[1L] <- -1L }, greater = { ci[2L] <- 1L }) }
} else {
RIN <- function(y) { qnorm((rank(y) - 0.5) / (length(rank(y)))) }
ci <- cor.test(RIN(x1), RIN(x2), alternative = alternative, conf.level = conf.level)$conf.int
}
object <- list(se = se, sample = sample, alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x1, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x1, sample = sample, check = FALSE), skew2 = misty::skewness(x2, sample = sample, check = FALSE), kurt2 = misty::kurtosis(x2, sample = sample, check = FALSE), cor = rs, ci = ci)
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
object <- list(se = se, sample = sample, alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA, cor = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(cor(x1, x2, method = "spearman")) } else { NA }, ci = c(NA, NA))
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .ci.kendall.b Function ####
.ci.kendall.b <- function(x, y, sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
#···················
#### Significance Testing ####
# Test for Association
test.tau.b <- cor.test(x1, x2, method = "kendall", alternative = alternative, exact = FALSE, continuity = FALSE)
# Kendall's tau b
tau <- unname(test.tau.b$estimate)
# Fieler et al. (1957) standard error
tau.se <- sqrt(0.437 / (length(x) - 4L))
#···················
#### Confidence Interval ####
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
if (isTRUE(!is.na(tau.se))) {
ci <- tanh(atanh(tau) + c(qnorm(alphavec[1L]), qnorm(alphavec[2L]))*tau.se)
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { ci[1L] <- -1L }, greater = { ci[2L] <- 1L }) }
} else {
ci <- c(NA, NA)
}
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x1, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x1, sample = sample, check = FALSE), skew2 = misty::skewness(x2, sample = sample, check = FALSE), kurt2 = misty::kurtosis(x2, sample = sample, check = FALSE),
stat = test.tau.b$statistic, tau = tau, se = tau.se, pval = test.tau.b$p.value, ci = ci)
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
stat = NA, tau = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(cor(x1, x2, method = "kendall")) } else { NA }, se = NA, pval = NA, ci = c(NA, NA))
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .ci.kendall.c.estimate Function ####
.ci.kendall.c.estimate <- function(x, y) {
# Contingency table
x.table <- table(x, y)
# Number of rows
x.nrow <- nrow(x.table)
# Number of columns
x.ncol <- ncol(x.table)
# Sample size
x.n <- sum(x.table)
# Minimum of number of rows/columns
x.m <- min(dim(x.table))
pi.c <- pi.d <- matrix(0L, nrow = x.nrow, ncol = x.ncol)
x.col <- col(x.table)
x.row <- row(x.table)
for (i in seq_len(x.nrow)) {
for (j in seq_len(x.ncol)) {
pi.c[i, j] <- sum(x.table[x.row < i & x.col < j]) + sum(x.table[x.row > i & x.col > j])
pi.d[i, j] <- sum(x.table[x.row < i & x.col > j]) + sum(x.table[x.row > i & x.col < j])
}
}
# Concordant
x.con <- sum(pi.c * x.table) / 2L
# Discordant
x.dis <- sum(pi.d * x.table) / 2L
#—————————————————————————————————————— #
### Kendall Tau-c ####
tau <- (x.m*2L * (x.con - x.dis)) / (x.n^2L * (x.m - 1L))
#—————————————————————————————————————— #
### Return Object ####
return(tau)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .ci.kendall.c Function ####
.ci.kendall.c <- function(x, y, sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
#···················
#### Kendall Tau-c ####
tau <- .ci.kendall.c.estimate(x1, x2)
# Fieler et al. (1957) standard error
tau.se <- sqrt(0.437 / (length(x) - 4L))
# Test statistic
z <- tau / tau.se
# p-value
switch(alternative, "two.sided" = {
pval <- pnorm(abs(z), lower.tail = FALSE)*2L
}, "less" = {
pval <- ifelse(z < 0L, pnorm(abs(z), lower.tail = FALSE), 1 - pnorm(abs(z), lower.tail = FALSE))
}, "greater" = {
pval <- ifelse(z > 0L, pnorm(abs(z), lower.tail = FALSE), 1 - pnorm(abs(z), lower.tail = FALSE))
})
#···················
#### Confidence Interval ####
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
ci <- tanh(atanh(tau) + c(qnorm(alphavec[1L]), qnorm(alphavec[2L]))*tau.se)
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { ci[1L] <- -1L }, greater = { ci[2L] <- 1L }) }
#···················
#### Return Object ####
return(list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x, sample = sample, check = FALSE), skew2 = misty::skewness(y, sample = sample, check = FALSE), kurt2 = misty::kurtosis(y, sample = sample, check = FALSE),
tau = tau, se = tau.se, stat = z, pval = pval, ci = ci))
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
tau = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(.ci.kendall.c.estimate(x1, x2)) } else { NA }, se = NA, stat = NA, pval = NA, ci = c(NA, NA))
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Interpolation on the Normal Quantile Scale ####
# Equation 5.8 of Davison and Hinkley (1997)
#
# .norm.inter from the R package 'boot'
# see: https://github.com/cran/boot/blob/master/R/bootfuns.q
.norm.inter <- function(t, alpha) {
t <- t[is.finite(t)]
R <- length(t)
rk <- (R + 1L)*alpha
k <- trunc(rk)
inds <- seq_along(k)
out <- inds
kvs <- k[k > 0L & k < R]
tstar <- sort(t, partial = sort(union(c(1L, R), c(kvs, kvs + 1L))))
ints <- (k == rk)
if (isTRUE(any(ints))) { out[inds[ints]] <- tstar[k[inds[ints]]] }
out[k == 0L] <- tstar[1L]
out[k == R] <- tstar[R]
not <- function(v) { xor(rep(TRUE,length(v)), v) }
temp <- inds[not(ints) & k != 0L & k != R]
temp1 <- qnorm(alpha[temp])
temp2 <- qnorm(k[temp] / (R + 1L))
temp3 <- qnorm((k[temp] + 1L)/(R + 1L))
tk <- tstar[k[temp]]
tk1 <- tstar[k[temp] + 1L]
out[temp] <- tk + (temp1 - temp2) / (temp3 - temp2)*(tk1 - tk)
return(out)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Correlation Coefficient ####
.boot.func.cor <- function(data, ind, method) {
data.boot <- data[ind, ]
if (isTRUE(method != "kendall-c")) { cor <- cor(data.boot[, 1L], data.boot[, 2L], method = method) } else { cor <- .ci.kendall.c.estimate(data.boot[, 1L], data.boot[, 2L]) }
return(cor = cor)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Nonparametric Bootstrap Confidence Intervals for the Correlation Coefficient ####
.ci.boot.cor <- function(data, x, y, method, statistic = .boot.func.cor, nrep = 1000, min.n = 10,
boot = c("norm", "basic", "perc", "bc", "bca"),
fisher = TRUE, sample = TRUE, alternative = c("two.sided", "less", "greater"),
conf.level = 0.95, seed = NULL) {
#—————————————————————————————————————— #
### Correlation Coefficient ####
method <- ifelse(isTRUE(method == "kendall-b"), "kendall", method)
#—————————————————————————————————————— #
### Fisher-z Transformation ####
if (isTRUE(fisher)) { h <- function(t) atanh(t); hinv <- function(t) tanh(t) } else { h <- function(t) t; hinv <- function(t) t }
#—————————————————————————————————————— #
### Adjust Confidence Level ####
if (isTRUE(alternative %in% c("less", "greater"))) { conf.level.alter <- conf.level - (1 - conf.level) } else { conf.level.alter <- conf.level }
#—————————————————————————————————————— #
### Data ####
xy <- na.omit(data.frame(x = data[, x], y = data[, y]))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- nrow(data) - n
pNA <- (nNA / (n + nNA)) * 100L
#—————————————————————————————————————— #
### At least n = min.n Cases and Variance Unequal 0 ####
if (isTRUE(n >= min.n && var(x1) != 0L && var(x2) != 0L)) {
#···················
#### Bootstrap Replicates ####
if (isTRUE(!is.null(seed))) { set.seed(seed) }
boot.repli <- suppressWarnings(boot::boot(xy, statistic = statistic, method = method, R = nrep))
#···················
#### Bootstrap Confidence Interval ####
switch(boot, "norm" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "norm", conf = conf.level.alter, h = h, hinv = hinv)) |>
(\(y) data.frame(low = y$normal[2L], upp = y$normal[3L]))()
}, "basic" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "basic", conf = conf.level.alter, h = h, hinv = hinv)) |>
(\(y) data.frame(low = y$basic[4L], upp = y$basic[5L]))()
}, "perc" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "perc", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$perc[4L], upp = y$perc[5L]))()
}, "bc" = {
result <- qnorm(mean(boot.repli$t < boot.repli$t0, na.rm = TRUE)) |>
(\(y) suppressWarnings(.norm.inter(boot.repli$t[, 1L], pnorm(y + (y + qnorm((1L + c(-conf.level.alter, conf.level.alter)) / 2L))))))() |>
(\(z) data.frame(low = z[1L], upp = z[2L]))()
}, "bca" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "bca", method = method, conf = conf.level.alter)) |>
(\(y) data.frame(low = y$bca[4L], upp = y$bca[5L]))()
})
#···················
#### Adjust Lower or Upper Bound ####
switch(alternative, "less" = { result$low <- -1 }, "greater" = { result$upp <- 1 })
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x1, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x1, sample = sample, check = FALSE), skew2 = misty::skewness(x2, sample = sample, check = FALSE), kurt2 = misty::kurtosis(x2, sample = sample, check = FALSE),
cor = boot.repli$t0, t = as.vector(boot.repli$t), ci = result)
#—————————————————————————————————————— #
### Number of Cases n < min.n or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
cor = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) {
if (isTRUE(method != "kendall-c")) {
suppressWarnings(cor(x1, x2, method = ifelse(isTRUE(method == "kendall-b"), "kendall", method)))
} else {
suppressWarnings(.ci.kendall.c.estimate(x1, x2))
}
} else {
NA
}, t = rep(NA, times = nrep), ci = c(NA, NA))
}
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci._() functions ----------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Nonparametric Bootstrap Confidence Intervals ####
.ci.boot <- function(data, statistic, nrep = 1000, min.n = 10, boot = c("norm", "basic", "stud", "perc", "bc", "bca"),
sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95, seed = NULL) {
#—————————————————————————————————————— #
### Adjust Confidence Level ####
if (isTRUE(alternative %in% c("less", "greater"))) { conf.level.alter <- conf.level - (1 - conf.level) } else { conf.level.alter <- conf.level }
#—————————————————————————————————————— #
### Data ####
x <- na.omit(data)
n <- length(x)
nNA <- length(data) - n
pNA <- (nNA / (n + nNA)) * 100L
#—————————————————————————————————————— #
### At least n = min.n Cases and Variance Unequal 0 ####
if (isTRUE(n >= min.n && var(x) != 0L)) {
#···················
#### Bootstrap Replicates ####
if (isTRUE(!is.null(seed))) { set.seed(seed) }
boot.repli <- suppressWarnings(boot::boot(x, statistic = statistic, R = nrep))
#···················
#### Bootstrap Confidence Interval ####
switch(boot, "norm" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "norm", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$normal[2L], upp = y$normal[3L]))()
}, "basic" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "basic", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$basic[4L], upp = y$basic[5L]))()
}, "stud" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "stud", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$student[4L], upp = y$student[5L]))()
}, "perc" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "perc", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$perc[4L], upp = y$perc[5L]))()
}, "bc" = {
result <- qnorm(mean(boot.repli$t[, 1L] < boot.repli$t0[1L], na.rm = TRUE)) |>
(\(y) suppressWarnings(.norm.inter(boot.repli$t[, 1L], pnorm(y + (y + qnorm((1L + c(-conf.level.alter, conf.level.alter)) / 2L))))))() |>
(\(z) data.frame(low = z[1L], upp = z[2L]))()
}, "bca" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "bca", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$bca[4L], upp = y$bca[5L]))()
})
#···················
#### Adjust Lower or Upper Bound ####
switch(alternative, "less" = { result$low <- -1 }, "greater" = { result$upp <- 1 })
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, m = mean(x), sd = sd(x), iqr = IQR(x), freq = sum(x == 1), skew = suppressWarnings(misty::skewness(x, sample = sample, check = FALSE)), kurt = suppressWarnings(misty::kurtosis(x, sample = sample, check = FALSE)), t0 = boot.repli$t0[1L], t = as.vector(boot.repli$t[, 1L]), ci = result)
#—————————————————————————————————————— #
### Number of Cases n < min.n or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, m = if (isTRUE(length(x) >= 2L && var(x) != 0L)) { mean(x) } else { NA }, sd = if (isTRUE(length(x) >= 2L && var(x) != 0L)) { sd(x) } else { NA }, iqrt = if (isTRUE(length(x) >= 2L && var(x) != 0L)) { IQR(x) } else { NA }, freq = if (isTRUE(length(x) >= 1L)) { sum(x == 1, na.rm = TRUE) } else { NA },
skew = if (isTRUE(length(x) >= 3L && var(x) != 0L)) { suppressWarnings(misty::skewness(x, sample = sample, check = FALSE)) } else { NA }, kurt = if (isTRUE(length(x) >= 4L && var(x) != 0L)) { suppressWarnings(misty::kurtosis(x, sample = sample, check = FALSE))} else { NA }, t0 = NA, t = rep(NA, times = nrep), ci = c(NA, NA)) }
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.mean() function --------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the mean ####
.m.conf <- function(x, sigma, adjust, alternative, conf.level, side) {
# Data
x <- na.omit(x)
# Difference-adjustment factor
adjust.factor <- ifelse(isTRUE(adjust), sqrt(2L) / 2L, 1L)
# One observation or SD = 0
if (isTRUE(length(x) <= 1L || sd(x) == 0L)) {
ci <- c(NA, NA)
# More than one observation
} else {
x.m <- mean(x)
#—————————————————————————————————————— #
### Known Population Standard Deviation ####
if (isTRUE(!is.null(sigma))) {
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
se <- sigma / sqrt(length(na.omit(x)))
#—————————————————————————————————————— #
### Unknown Population Standard Deviation ####
} else {
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = length(x) - 1L)
se <- sd(x) / sqrt(length(x))
}
#—————————————————————————————————————— #
### Confidence Interval ####
ci <- switch(alternative,
two.sided = c(low = x.m - adjust.factor * crit * se,
upp = x.m + adjust.factor * crit * se),
less = c(low = -Inf,
upp = x.m + adjust.factor * crit * se),
greater = c(low = x.m - adjust.factor * crit * se,
upp = Inf))
}
#—————————————————————————————————————— #
### Return object ####
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Arithmetic Mean ####
.boot.func.mean <- function(data, ind) { return(c(mean(data[ind], na.rm = TRUE), var(data[ind], na.rm = TRUE) / length(na.omit(data[ind])))) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.median() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the median ####
.med.conf <- function(x, alternative, conf.level, side) {
# Data
x <- na.omit(x)
n <- length(x)
# Number of observations less than 6 observations
if (isTRUE(n < 6L)) {
ci <- c(NA, NA)
# At least six observations
} else {
#—————————————————————————————————————— #
### Confidence Interval ####
# Two-sided CI
switch(alternative, two.sided = {
k <- qbinom((1L - conf.level)/2L, size = n, prob = 0.5, lower.tail = TRUE)
ci <- sort(x)[c(k, n - k + 1L)]
# One-sided CI: less
}, less = {
k <- qbinom(1L - 2L * (1L - conf.level), size = n, prob = 0.5, lower.tail = TRUE)
ci <- c(-Inf, sort(x)[k])
# One-sided CI: greater
}, greater = {
k <- qbinom(1L - 2L * (1L - conf.level), size = n, prob = 0.5, lower.tail = FALSE)
ci <- c(sort(x)[k], Inf)
})
}
#—————————————————————————————————————— #
### Return Object ####
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Median ####
.boot.func.median <- function(data, ind) { return(c(median(data[ind], na.rm = TRUE), (pi / 2L) * var(data[ind], na.rm = TRUE) / length(na.omit(data[ind])))) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.prop() function --------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence Interval for the Proportion ####
.prop.conf <- function(x, method, alternative, conf.level, side) {
# Data
x <- na.omit(x)
n <- length(x)
# Number of observations
if (isTRUE(n <= 1L)) {
ci <- c(NA, NA)
} else {
s <- sum(x)
p <- s / n
q <- 1L - p
z <- switch(alternative,
two.sided = qnorm(1L - (1 - conf.level)/2L),
less = qnorm(1L - (1L - conf.level)),
greater = qnorm(1L - (1L - conf.level)))
#—————————————————————————————————————— #
### Wald Method ####
if (isTRUE(method == "wald")) {
term <- z * sqrt(p * q) / sqrt(n)
ci <- switch(alternative,
two.sided = c(low = max(0L, p - term), upp = min(1L, p + term)),
less = c(low = 0L, upp = min(1, p + term)),
greater = c(low = max(0L, p - term), upp = 1L))
#—————————————————————————————————————— #
### Wilson Method ####
} else if (isTRUE(method == "wilson")) {
term1 <- (s + z^2 / 2L) / (n + z^2L)
term2 <- z * sqrt(n) / (n + z^2L) * sqrt(p * q + z^2L / (4L * n))
ci <- switch(alternative,
two.sided = c(low = max(0L, term1 - term2), upp = min(1L, term1 + term2)),
less = c(0L, upp = min(1L, term1 + term2)),
greater = c(low = max(0L, term1 - term2), upp = 1L))
}
}
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.var() function ---------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the variance ####
.var.conf <- function(x, method, alternative, conf.level, side) {
# Data
x <- na.omit(x)
x.var <- var(x)
# Number of observations
if (isTRUE((length(x) < 2L && method == "chisq") || (length(x) < 4L && method == "bonett"))) {
ci <- c(NA, NA)
} else {
#—————————————————————————————————————— #
### Chi-Square Method ####
if (isTRUE(method == "chisq")) {
df <- length(x) - 1L
# Two-sided CI
switch(alternative, two.sided = {
crit.low <- qchisq((1L - conf.level)/2L, df = df, lower.tail = FALSE)
crit.upp <- qchisq((1L - conf.level)/2L, df = df, lower.tail = TRUE)
ci <- c(low = df*x.var / crit.low, upp = df*x.var / crit.upp)
# One-sided CI: less
}, less = {
crit.upp <- qchisq((1L - conf.level), df = df, lower.tail = TRUE)
ci <- c(low = 0L, upp = df*x.var / crit.upp)
# One-sided CI: greater
}, greater = {
crit.low <- qchisq((1L - conf.level), df = df, lower.tail = FALSE)
ci <- c(low = df*x.var / crit.low, upp = Inf)
})
#—————————————————————————————————————— #
### Bonett Method ####
} else if (isTRUE(method == "bonett")) {
n <- length(x)
z <- switch(alternative,
two.sided = qnorm(1L - (1L - conf.level)/2L),
less = qnorm(1L - (1L - conf.level)),
greater = qnorm(1L - (1L - conf.level)))
cc <- n/(n - z)
gam4 <- n * sum((x - mean(x, trim = 1L / (2L * (n - 4L)^0.5)))^4L) / (sum((x - mean(x))^2L))^2L
se <- cc * sqrt((gam4 - (n - 3L)/n) / (n - 1L))
ci <- switch(alternative,
two.sided = c(low = exp(log(cc * x.var) - z * se), upp = exp(log(cc * x.var) + z * se)),
less = c(low = 0L, upp = exp(log(cc * x.var) + z * se)),
greater = c(low = exp(log(cc * x.var) - z * se), upp = Inf))
}
}
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Variance ####
.boot.func.var <- function(data, ind) { return(var(data[ind], na.rm = TRUE)) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.sd() function ----------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the standard deviation ####
.sd.conf <- function(x, method, alternative, conf.level, side) {
# Data
x <- na.omit(x)
x.var <- var(x)
# Number of observations
if (isTRUE((length(x) < 2L && method == "chisq") || (length(x) < 4L && method == "bonett"))) {
ci <- c(NA, NA)
} else {
#—————————————————————————————————————— #
### Chi-Square Method ####
if (isTRUE(method == "chisq")) {
df <- length(x) - 1L
# Two-sided CI
switch(alternative, two.sided = {
crit.low <- qchisq((1L - conf.level)/2L, df = df, lower.tail = FALSE)
crit.upp <- qchisq((1L - conf.level)/2L, df = df, lower.tail = TRUE)
ci <- sqrt(c(low = df*x.var / crit.low, upp = df*x.var / crit.upp))
# One-sided CI: less
}, less = {
crit.upp <- qchisq((1L - conf.level), df = df, lower.tail = TRUE)
ci <- c(low = 0L, upp = sqrt(df*x.var / crit.upp))
# One-sided CI: greater
}, greater = {
crit.low <- qchisq((1L - conf.level), df = df, lower.tail = FALSE)
ci <- c(low = sqrt(df*x.var / crit.low), upp = Inf)
})
#—————————————————————————————————————— #
### Bonett Method ####
} else if (isTRUE(method == "bonett")) {
n <- length(x)
z <- switch(alternative,
two.sided = qnorm(1L - (1L - conf.level)/2L),
less = qnorm(1L - (1L - conf.level)),
greater = qnorm(1L - (1L - conf.level)))
cc <- n/(n - z)
gam4 <- n * sum((x - mean(x, trim = 1L / (2L * (n - 4L)^0.5)))^4L) / (sum((x - mean(x))^2))^2L
se <- cc * sqrt((gam4 - (n - 3L)/n) / (n - 1L))
ci <- switch(alternative,
two.sided = sqrt(c(low = exp(log(cc * x.var) - z * se), upp = exp(log(cc * x.var) + z * se))),
less = c(low = 0, upp = sqrt(exp(log(cc * x.var) + z * se))),
greater = c(low = sqrt(exp(log(cc * x.var) - z * se)), upp = Inf))
}
}
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Standard Deviation ####
.boot.func.sd <- function(data, ind) { return(sd(data[ind], na.rm = TRUE)) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.mean.diff() function ---------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the difference of arithmetic means ####
.m.diff.conf <- function(x, y, sigma, var.equal, alternative, paired, conf.level, side) {
#—————————————————————————————————————— #
### Independent Samples ####
if (!isTRUE(paired)) {
#···················
#### Data ####
x <- na.omit(x)
y <- na.omit(y)
x.n <- length(x)
y.n <- length(y)
yx.mean <- mean(y) - mean(x)
x.var <- var(x)
y.var <- var(y)
# At least 2 observations for x and y
if (isTRUE(x.n >= 2L && y.n >= 2L & (x.var != 0L && y.var != 0L))) {
##### Known Population SD ####
if (isTRUE(!is.null(sigma))) {
se <- sqrt((sigma[1L]^2L / x.n) + (sigma[2L]^2L / y.n))
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
term <- crit*se
##### Unknown Population SD ####
} else {
###### Equal variance ####
if (isTRUE(var.equal)) {
se <- sqrt(((x.n - 1L)*x.var + (y.n - 1L)*y.var) / (x.n + y.n - 2L)) * sqrt(1 / x.n + 1L / y.n)
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = sum(x.n, y.n) - 2L)
term <- crit*se
###### Unequal variance ####
} else {
se <- sqrt(x.var / x.n + y.var / y.n)
df <- (x.var / x.n + y.var / y.n)^2L / (((x.var / x.n)^2L / (x.n - 1L)) + ((y.var / y.n)^2L / (y.n - 1L)))
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = df)
term <- crit*se
}
}
#···················
#### Confidence Interval ####
ci <- switch(alternative,
two.sided = c(low = yx.mean - term, upp = yx.mean + term),
less = c(low = -Inf, upp = yx.mean + term),
greater = c(low = yx.mean - term, upp = Inf))
# Less than 2 observations for x and y
} else {
ci <- c(NA, NA)
}
#—————————————————————————————————————— #
### Dependent Samples ####
} else {
xy.dat <- na.omit(data.frame(x = x, y = y, stringsAsFactors = FALSE))
xy.diff <- xy.dat$y - xy.dat$x
xy.diff.mean <- mean(xy.diff)
xy.diff.sd <- sd(xy.diff)
xy.diff.n <- nrow(xy.dat)
# At least 2 observations for x
if (isTRUE(xy.diff.n >= 2L && xy.diff.sd != 0L)) {
#···················
#### Known Population SD ####
if (isTRUE(!is.null(sigma))) {
se <- sigma / sqrt(xy.diff.n)
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
term <- crit*se
#···················
#### Unknown Population SD ####
} else {
se <- xy.diff.sd / sqrt(xy.diff.n)
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = xy.diff.n - 1L)
term <- crit*se
}
ci <- switch(alternative,
two.sided = c(low = xy.diff.mean - term, upp = xy.diff.mean + term),
less = c(low = -Inf, upp = xy.diff.mean + term),
greater = c(low = xy.diff.mean - term, upp = Inf))
# Less than 2 observations for x
} else {
ci <- c(NA, NA)
}
}
#—————————————————————————————————————— #
### Return Object ####
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.prop.diff() function ---------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence Interval for the Difference of Proportions ####
.prop.diff.conf <- function(x, y, method, alternative, paired, conf.level, side) {
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
#—————————————————————————————————————— #
### Independent Samples ####
if (!isTRUE(paired)) {
#···················
#### Data ####
x <- na.omit(x)
y <- na.omit(y)
x.n <- length(x)
y.n <- length(y)
p1 <- sum(x) / x.n
p2 <- sum(y) / y.n
p.diff <- p2 - p1
#···················
#### Wald Confidence Interval ####
if (isTRUE(method == "wald")) {
#......
# At least 2 observations for x or y
if (isTRUE((x.n >= 2L || y.n >= 2L) && (var(x) != 0L || var(y) != 0L))) {
term <- crit * sqrt(p1*(1 - p1) / x.n + p2*(1 - p2) / y.n)
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = max(-1L, p.diff - term), upp = min(1L, p.diff + term)),
less = c(low = -1, upp = min(1, p.diff + term)),
greater = c(low = max(-1L, p.diff - term), upp = 1L))
# Less than 2 observations for x or y
} else {
ci <- c(NA, NA)
}
#···················
#### Newcombes Hybrid Score Interval ####
} else if (isTRUE(method == "newcombe")) {
# At least 1 observations for x and y
if (isTRUE((x.n >= 1L && y.n >= 1L))) {
if (isTRUE(alternative == "two.sided")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "less")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "greater")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
}
# Confidence interval
ci <- switch(alternative,
two.sided = c(p.diff - crit * sqrt((x.ci.wilson$upp*(1 - x.ci.wilson$upp) / x.n) + (y.ci.wilson$low*(1 - y.ci.wilson$low) / y.n)),
p.diff + crit * sqrt((x.ci.wilson$low*(1 - x.ci.wilson$low) / x.n) + (y.ci.wilson$upp*(1 - y.ci.wilson$upp) / y.n))),
less = c(-1, p.diff + crit * sqrt((x.ci.wilson$low*(1 - x.ci.wilson$low) / x.n) + (y.ci.wilson$upp*(1 - y.ci.wilson$upp) / y.n))),
greater = c(p.diff - crit * sqrt((x.ci.wilson$upp*(1 - x.ci.wilson$upp) / x.n) + (y.ci.wilson$low*(1 - y.ci.wilson$low) / y.n)), 1))
# Less than 1 observations for x or y
} else {
ci <- c(NA, NA)
}
}
#—————————————————————————————————————— #
### Dependent Samples ####
} else {
xy.dat <- na.omit(data.frame(x = x, y = y, stringsAsFactors = FALSE))
x.p <- mean(xy.dat$x)
y.p <- mean(xy.dat$y)
xy.diff.mean <- y.p - x.p
xy.diff.n <- nrow(xy.dat)
a <- as.numeric(sum(xy.dat$x == 1 & xy.dat$y == 1))
b <- as.numeric(sum(xy.dat$x == 1 & xy.dat$y == 0))
c <- as.numeric(sum(xy.dat$x == 0 & xy.dat$y == 1))
d <- as.numeric(sum(xy.dat$x == 0 & xy.dat$y == 0))
#···················
#### Wald Confidence Interval ####
if (isTRUE(method == "wald")) {
#......
# At least 2 observations for x or y
if (isTRUE(xy.diff.n >= 2 && (var(xy.dat$x) != 0 || var(xy.dat$y) != 0))) {
term <- crit * sqrt((b + c) - (b - c)^2 / xy.diff.n) / xy.diff.n
#......
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = max(-1, xy.diff.mean - term), upp = min(1, xy.diff.mean + term)),
less = c(low = -1, upp = min(1, xy.diff.mean + term)),
greater = c(low = max(-1, xy.diff.mean - term), upp = 1))
} else {
ci <- c(NA, NA)
}
#···················
#### Newcombes Hybrid Score Interval ####
} else if (isTRUE(method == "newcombe")) {
# At least 1 observations for x and y
if (isTRUE(xy.diff.n >= 1L)) {
if (isTRUE(alternative == "two.sided")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "less")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "greater")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
}
A <- (a + b) * (c + d) * (a + c) * (b + d)
as.numeric(a)
if (isTRUE(A == 0L)) {
phi <- 0L
} else {
phi <- (a * d - b * c) / sqrt(A)
}
ci <- switch(alternative,
two.sided = c(xy.diff.mean - sqrt((y.p - y.ci.wilson$low)^2 - 2L * phi * (y.p - y.ci.wilson$low) * (x.ci.wilson$upp - x.p) + (x.ci.wilson$upp - x.p)^2L),
xy.diff.mean + sqrt((x.p - x.ci.wilson$low)^2 - 2L * phi * (x.p - x.ci.wilson$low) * (y.ci.wilson$upp - y.p) + (y.ci.wilson$upp - y.p)^2L)),
less = c(-1L, xy.diff.mean + sqrt((x.p - x.ci.wilson$low)^2 - 2L * phi * (x.p - x.ci.wilson$low) * (y.ci.wilson$upp - y.p) + (y.ci.wilson$upp - y.p)^2L)),
greater = c(xy.diff.mean - sqrt((y.p - y.ci.wilson$low)^2 - 2L * phi * (y.p - y.ci.wilson$low) * (x.ci.wilson$upp - x.p) + (x.ci.wilson$upp - x.p)^2), 1L))
} else {
ci <- c(NA, NA)
}
}
}
#—————————————————————————————————————— #
### Return Object ####
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for Plotting Confidence Intervals -------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Plot Function Confidence Interval ####
.plot.ci <- function(result, stat, group = NULL, split = NULL, point.size, point.shape, errorbar.width, dodge.width,
line, intercept, linetype, line.col, xlab, ylab, xlim , ylim, xbreaks, ybreaks,
axis.title.size, axis.text.size, strip.text.size, title, subtitle, group.col, plot.margin,
legend.title, legend.position, legend.box.margin, facet.ncol, facet.nrow, facet.scales) {
low <- upp <- x <- NULL
#—————————————————————————————————————— #
### No Grouping, No Split ####
if (isTRUE(is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(x = paste(result$var1, result$var2, sep = "\n"), y = result$cor, low = result$low, upp = result$upp)
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(x = factor(result$variable, levels = unique(result$variable)), y = result[, stat], low = result$low, upp = result$upp)
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p + ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width) +
ggplot2::geom_point(size = point.size, shape = point.shape) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#—————————————————————————————————————— #
### Grouping, No Split ####
} else if (isTRUE(!is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(group = result$group, x = paste(result$var1, result$var2, sep = "\n"), y = result$cor, low = result$low, upp = result$upp)
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(group = result$group, x = factor(result$variable, levels = unique(result$variable)), y = result[, stat], low = result$low, upp = result$upp)
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y, group = group, color = group))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p +
ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width,
position = ggplot2::position_dodge(dodge.width)) +
ggplot2::geom_point(size = point.size, shape = point.shape, position = ggplot2::position_dodge(dodge.width)) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.background = ggplot2::element_blank(),
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) }
#—————————————————————————————————————— #
### No Grouping, Split ####
} else if (isTRUE(is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()),
do.call("rbind", result)) |> (\(y) data.frame(split = y$split, x = paste(y$var1, y$var2, sep = "\n"), y = y$cor, low = y$low, upp = y$upp))()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()), do.call("rbind", result)) |>
(\(z) data.frame(split = z$split, x = factor(z$variable, levels = unique(z$variable)), y = z[, stat], low = z$low, upp = z$upp))()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p + ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width) +
ggplot2::geom_point(size = point.size, shape = point.shape) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::facet_wrap(~ split, ncol = facet.ncol, nrow = facet.nrow) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#—————————————————————————————————————— #
### Grouping, Split ####
} else if (isTRUE(!is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()),
do.call("rbind", result)) |> (\(y) data.frame(group = y$group, split = y$split, x = paste(y$var1, y$var2, sep = "\n"), y = y$cor, low = y$low, upp = y$upp))()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()), do.call("rbind", result)) |>
(\(z) data.frame(group = z$group, split = z$split, x = factor(z$variable, levels = unique(z$variable)), y = z[, stat], low = z$low, upp = z$upp))()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y, group = group, color = group))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p +
ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width,
position = ggplot2::position_dodge(dodge.width)) +
ggplot2::geom_point(size = point.size, shape = point.shape, position = ggplot2::position_dodge(dodge.width)) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::facet_wrap(~ split, ncol = facet.ncol, nrow = facet.nrow) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) }
}
return(list(p = p, plotdat = plotdat))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Plot Function Bootstrap Samples ####
.plot.boot <- function(result, boot.sample, stat, group = NULL, split = NULL, hist, binwidth, bins, alpha, fill,
density, density.col, density.linewidth, density.linetype, plot.point, point.col, point.linewidth, point.linetype,
plot.ci, ci.col, ci.linewidth, ci.linetype, line, intercept, linetype, line.col,
xlab, ylab, xlim, ylim, xbreaks, ybreaks, axis.title.size, axis.text.size, strip.text.size, title, subtitle, group.col,
plot.margin, legend.title, legend.position, legend.box.margin, facet.ncol, facet.nrow, facet.scales) {
point <- low <- upp <- NULL
#—————————————————————————————————————— #
### No Grouping, No Split ####
if (isTRUE(is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), y = boot.sample$cor),
data.frame(x = paste(result$var1, result$var2, sep = " - "), point = result$cor, low = result$low, upp = result$upp), by = "x")
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(x = factor(boot.sample$variable, levels = unique(result$variable)), y = boot.sample[, stat]),
data.frame(x = factor(result$variable, levels = unique(result$variable)), point = result[, stat], low = result$low, upp = result$upp), by = "x")
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y)) +
ggplot2::facet_wrap(~ x, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density)), binwidth = binwidth, bins = bins, color = "black", alpha = alpha, fill = fill) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- p + ggplot2::geom_density(color = density.col, linewidth = density.linewidth, linetype = density.linetype) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = point), color = point.col, linetype = point.linetype, linewidth = point.linewidth) }
#...................
### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low), color = ci.col, linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp), color = ci.col, linetype = ci.linetype , linewidth = ci.linewidth) }
#—————————————————————————————————————— #
### Grouping, No Split ####
} else if (isTRUE(!is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$group, boot.sample$var1, boot.sample$var2, sep = " - ")), x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), group = factor(boot.sample$group, levels = unique(result$group)), y = boot.sample$cor),
data.frame(by = factor(paste(result$group, result$var1, result$var2, sep = " - ")), point = result$cor, low = result$low, upp = result$upp), by = "by") |> (\(y) y[, -grep("by", colnames(y))])()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$group, boot.sample$variable, sep = " - ")), x = factor(boot.sample$variable, levels = unique(result$variable)), group = factor(boot.sample$group, levels = unique(result$group)), y = boot.sample[, stat]),
data.frame(by = factor(paste(result$group, result$variable, sep = " - ")), point = result[, stat], low = result$low, upp = result$upp), by = "by") |> (\(y) y[, -grep("by", colnames(y))])()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y, group = group, color = group)) +
ggplot2::facet_wrap(~ x, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title, fill = legend.title) +
ggplot2::guides(color = "none") +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.background = ggplot2::element_blank(),
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density), fill = group), position = "identity", binwidth = binwidth, bins = bins, color = "black", alpha = alpha) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- suppressMessages(p + ggplot2::geom_density(alpha = alpha, linewidth = density.linewidth, linetype = density.linetype)) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = point, color = group), linetype = point.linetype, linewidth = point.linewidth) }
#...................
#### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low, color = group), linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp, color = group), linetype = ci.linetype, linewidth = ci.linewidth) }
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) + ggplot2::scale_fill_manual(values = group.col) }
#—————————————————————————————————————— #
### No Grouping, Split ####
} else if (isTRUE(is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$var1, boot.sample$var2, sep = " - ")), x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), split = factor(boot.sample$split, levels = names(result)), y = boot.sample$cor),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$var1, y$var2, sep = " - ")), point = y$cor, low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$variable, sep = " - ")), x = factor(boot.sample$variable, levels = unique(do.call("rbind", result)$variable)), split = factor(boot.sample$split, levels = names(result)), y = boot.sample[, stat]),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$variable, sep = " - ")), point = y[, stat], low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y)) +
ggplot2::facet_wrap(~ x + split, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density)), binwidth = binwidth, bins = bins, color = "black", alpha = alpha, fill = fill) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- p + ggplot2::geom_density(color = density.col, linewidth = density.linewidth, linetype = density.linetype) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = point), color = point.col, linetype = point.linetype, linewidth = point.linewidth) }
#...................
#### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low), color = ci.col, linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp), color = ci.col, linetype = ci.linetype, linewidth = ci.linewidth) }
#—————————————————————————————————————— #
### Grouping, Split ####
} else if (isTRUE(!is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$group, boot.sample$var1, boot.sample$var2, sep = " - ")), x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), split = factor(boot.sample$split, levels = names(result)), group = factor(boot.sample$group, levels = unique(do.call("rbind", result)$group)), y = boot.sample$cor),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$group, y$var1, y$var2, sep = " - ")), point = y$cor, low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$group, boot.sample$variable, sep = " - ")), x = factor(boot.sample$variable, levels = unique(do.call("rbind", result)$variable)), split = factor(boot.sample$split, levels = names(result)), group = factor(boot.sample$group, levels = unique(do.call("rbind", result)$group)), y = boot.sample[, stat]),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$group, y$variable, sep = " - ")), point = y[, stat], low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y, group = group, color = group)) +
ggplot2::facet_wrap(~ x + split, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title, fill = legend.title) +
ggplot2::guides(color = "none") +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.background = ggplot2::element_blank(),
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density), fill = group), position = "identity", binwidth = binwidth, bins = bins, color = "black", alpha = alpha) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- p + ggplot2::geom_density(alpha = alpha, linewidth = density.linewidth, linetype = density.linetype) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(plotdat, ggplot2::aes(xintercept = point, color = group), linetype = point.linetype, linewidth = point.linewidth) }
#...................
#### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low, color = group), linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp, color = group), linetype = ci.linetype, linewidth = ci.linewidth) }
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) }
}
return(list(p = p, plotdat = plotdat))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the df.rbind() function -------------------------------
#
# - .make_names
# - .quickdf
# - .make_assignment_call
# - .allocate_column
# - .output_template
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .make_names ####
.make_names <- function(x, prefix = "X") {
nm <- names(x)
if (isTRUE(is.null(nm))) {
nm <- rep.int("", length(x))
}
n <- sum(nm == "", na.rm = TRUE)
nm[nm == ""] <- paste0(prefix, seq_len(n))
return(nm)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .quickdf ####
.quickdf <- function (list) {
rows <- unique(unlist(lapply(list, NROW)))
stopifnot(length(rows) == 1L)
names(list) <- .make_names(list, "X")
class(list) <- "data.frame"
attr(list, "row.names") <- c(NA_integer_, -rows)
return(list)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .make_assignment_call ####
.make_assignment_call <- function (ndims) {
assignment <- quote(column[rows] <<- what)
if (isTRUE(ndims >= 2L)) {
assignment[[2L]] <- as.call(c(as.list(assignment[[2]]), rep(list(quote(expr = )), ndims - 1L)))
}
return(assignment)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .allocate_column ####
.allocate_column <- function(example, nrows, dfs, var) {
a <- attributes(example)
type <- typeof(example)
class <- a$class
isList <- is.recursive(example)
a$names <- NULL
a$class <- NULL
if (isTRUE(is.data.frame(example))) {
stop("Data frame column '", var, "' not supported by the df.rbind() function.", call. = FALSE)
}
if (isTRUE(is.array(example))) {
if (isTRUE(length(dim(example)) > 1L)) {
if (isTRUE("dimnames" %in% names(a))) {
a$dimnames[1L] <- list(NULL)
if (isTRUE(!is.null(names(a$dimnames))))
names(a$dimnames)[1L] <- ""
}
# Check that all other args have consistent dims
df_has <- vapply(dfs, function(df) var %in% names(df), FALSE)
dims <- unique(lapply(dfs[df_has], function(df) dim(df[[var]])[-1]))
if (isTRUE(length(dims) > 1L))
stop("Array variable ", var, " has inconsistent dimensions.", call. = FALSE)
a$dim <- c(nrows, dim(example)[-1L])
length <- prod(a$dim)
} else {
a$dim <- NULL
a$dimnames <- NULL
length <- nrows
}
} else {
length <- nrows
}
if (isTRUE(is.factor(example))) {
df_has <- vapply(dfs, function(df) var %in% names(df), FALSE)
isfactor <- vapply(dfs[df_has], function(df) is.factor(df[[var]]), FALSE)
if (isTRUE(all(isfactor))) {
levels <- unique(unlist(lapply(dfs[df_has], function(df) levels(df[[var]]))))
a$levels <- levels
handler <- "factor"
} else {
type <- "character"
handler <- "character"
class <- NULL
a$levels <- NULL
}
} else if (isTRUE(inherits(example, "POSIXt"))) {
tzone <- attr(example, "tzone")
class <- c("POSIXct", "POSIXt")
type <- "double"
handler <- "time"
} else {
handler <- type
}
column <- vector(type, length)
if (isTRUE(!isList)) {
column[] <- NA
}
attributes(column) <- a
assignment <- .make_assignment_call(length(a$dim))
setter <- switch(
handler,
character = function(rows, what) {
what <- as.character(what)
eval(assignment)
},
factor = function(rows, what) {
#duplicate what `[<-.factor` does
what <- match(what, levels)
#no need to check since we already computed levels
eval(assignment)
},
time = function(rows, what) {
what <- as.POSIXct(what, tz = tzone)
eval(assignment)
},
function(rows, what) {
eval(assignment)
})
getter <- function() {
class(column) <<- class
column
}
list(set = setter, get = getter)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .output_template ####
.output_template <- function(dfs, nrows) {
vars <- unique(unlist(lapply(dfs, base::names)))
output <- vector("list", length(vars))
names(output) <- vars
seen <- rep(FALSE, length(output))
names(seen) <- vars
for (df in dfs) {
matching <- intersect(names(df), vars[!seen])
for (var in matching) {
output[[var]] <- .allocate_column(df[[var]], nrows, dfs, var)
}
seen[matching] <- TRUE
if (isTRUE(all(seen))) break
}
list(setters = lapply(output, `[[`, "set"), getters = lapply(output, `[[`, "get"))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the coding() function ---------------------------------
#
# - .contr.sum
# - .contr.wec
# - .contr.repeat
# - .forward.helmert
# - .reverse.helmert
#
# wec: wec: Weighted Effect Coding
# https://cran.r-project.org/web/packages/wec/index.html
#
# MASS: Support Functions and Datasets for Venables and Ripley's MASS
# https://cran.r-project.org/web/packages/MASS/index.html
#
# codingMatrices: Alternative Factor Coding Matrices for Linear Model Formulae
# https://cran.r-project.org/web/packages/codingMatrices/index.html
#
# faux: Simulation for Factorial Designs
# https://cran.r-project.org/web/packages/faux/index.html
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr.sum Function from the stats Package ####
.contr.sum <- function(n, omitted) {
cont <- structure(diag(1L, length(n), length(n)), dimnames = list(n, n))
cont <- cont[, -omitted, drop = FALSE]
cont[omitted, ] <- -1L
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr.wec Function from the wec Package ####
.contr.wec <- function (x, omitted) {
frequ <- table(x)
omitted <- which(names(frequ) == omitted)
cont <- contr.treatment(length(frequ), base = omitted)
cont[omitted, ] <- -1L * frequ[-omitted] / frequ[omitted]
colnames(cont) <- names(frequ[-omitted])
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr.sdif Function from the MASS Package ####
.contr.repeat <- function(n) {
n.length <- length(n)
cont <- col(matrix(nrow = n.length, ncol = n.length - 1L))
upper.tri <- !lower.tri(cont)
cont[upper.tri] <- cont[upper.tri] - n.length
cont <- structure(cont / n.length, dimnames = list(n, n[-1L]))
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified code_helmert_forward Function from the codingMatrices Package ####
.forward.helmert <- function(n) {
n.length <- length(n)
cont <- rbind(diag(n.length:2L - 1L), 0)
cont[lower.tri(cont)] <- -1L
cont <- cont / rep(n.length:2L, each = n.length)
dimnames(cont) <- list(n, n[1L:ncol(cont)])
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr_code_helmert Function from the faux Package ####
.reverse.helmert <- function(n) {
n.length <- length(n)
cont <- contr.helmert(n.length)
for (i in 1L:(n.length - 1L)) {
cont[, i] <- cont[, i] / (i + 1L)
}
comparison <- lapply(1L:(n.length - 1L), function(y) {
paste(n[1L:y], collapse = ".")
})
dimnames(cont) <- list(n, n[-1L])
return(cont)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the cohens.d() function -------------------------------
.internal.d.function <- function(x, y, mu, paired, weighted, cor, ref, correct,
alternative, conf.level) {
#—————————————————————————————————————— #
### One-Sample ####
if (isTRUE(is.null(y))) {
# Unstandardized mean difference
yx.diff <- mean(x, na.rm = TRUE) - mu
# Standard deviation
sd.group <- x.sd <- sd(x, na.rm = TRUE)
# Sample size
x.n <- length(na.omit(x))
#···················
#### Cohen's d ####
d <- yx.diff / sd.group
#···················
#### Correction Factor ####
# Bias-corrected Cohen's d
if (isTRUE(correct)) {
v <- x.n - 1
# Correction factor based on gamma function
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2L)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation method
if (isTRUE(is.na(corr.factor) || is.nan(corr.factor) || is.infinite(corr.factor))) {
corr.factor <- (1L - (3L / (4L * v - 1L)))
}
d <- d*corr.factor
}
#···················
#### Confidence Interval ####
# Standard error
d.se <- sqrt((x.n / (x.n / 2L)^2L) + 0.5*(d^2L / x.n))
# Noncentrality parameter
t <- yx.diff / (x.sd / sqrt(x.n))
df <- x.n - 1
conf1 <- ifelse(alternative == "two.sided", (1L + conf.level) / 2L, conf.level)
conf2 <- ifelse(alternative == "two.sided", (1L - conf.level) / 2L, 1L - conf.level)
st <- max(0.1, abs(t))
###
end1 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end1)) < conf1) { end1 <- end1 - st }
ncp1 <- uniroot(function(x) conf1 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(end1, 2*t - end1))$root
###
end2 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end2)) > conf2) { end2 <- end2 + st }
ncp2 <- uniroot(function(x) conf2 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(2*t - end2, end2))$root
# Confidence interval around ncp
conf.int <- switch(alternative,
two.sided = c(low = ncp1 / sqrt(df), upp = ncp2 / sqrt(df)),
less = c(low = -Inf, upp = ncp2 / sqrt(df)),
greater = c(low = ncp1 / sqrt(df), upp = Inf))
# With correction factor
if(isTRUE(correct)) {
conf.int <- conf.int*corr.factor
}
#—————————————————————————————————————— #
### Two-Sample ####
} else if (!isTRUE(paired)) {
#···················
#### Data ####
# x and y
x <- na.omit(x)
y <- na.omit(y)
# Sample size for x and y
x.n <- length(x)
y.n <- length(y)
# Total sample size
xy.n <- sum(c(x.n, y.n))
# Unstandardized mean difference
yx.diff <- mean(y) - mean(x)
# Variance
x.var <- var(x)
y.var <- var(y)
# Standard deviation
x.sd <- sd(x)
y.sd <- sd(y)
# At least 2 observations for x/y and variance in x/y
if (isTRUE((x.n >= 2L && y.n >= 2L) && (x.var != 0L && y.var != 0L))) {
#···················
#### Standard Deviation ####
# Pooled standard deviation
if (isTRUE(is.null(ref))) {
# Weighted pooled standard deviation, Cohen's d.s
if (isTRUE(weighted)) {
sd.group <- sqrt(((x.n - 1L)*x.var + (y.n - 1L)*y.var) / (xy.n - 2L))
# Unweighted pooled standard deviation
} else {
sd.group <- sqrt(sum(c(x.var, y.var)) / 2L)
}
# Standard deviation from reference group x or y, Glass's delta
} else {
sd.group <- ifelse(ref == "x", x.sd, y.sd)
}
#···················
#### Cohen's d ####
d <- yx.diff / sd.group
#···················
#### Correction Factor ####
# Bias-corrected Cohen's d, i.e., Hedges' g
if (isTRUE(correct)) {
# Degrees of freedom
v <- xy.n - 2L
# Correction factor based on gamma function
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2L)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation method
if (isTRUE(is.na(corr.factor) || is.nan(corr.factor) || is.infinite(corr.factor))) {
corr.factor <- (1L - (3L / (4L * v - 1L)))
}
# Applying correction factor
d <- d*corr.factor
}
#···················
#### Confidence Interval ####
# No reference group
if (isTRUE(is.null(ref))) {
# Cohen's d.s
# Pooled standard deviation
if (isTRUE(weighted)) {
d.se <- sd.group * sqrt(1 / x.n + 1 / y.n)
df <- xy.n - 2
# Unpooled standard deviation
} else {
d.se <- sqrt(sqrt(x.sd^2 / x.n)^2 + sqrt(y.sd^2 / y.n)^2)
df <- d.se^4 / ( sqrt(x.sd^2 / x.n)^4 / (x.n - 1) + sqrt(y.sd^2 / y.n)^4 / (y.n - 1))
}
t <- yx.diff / d.se
hn <- sqrt(1 / x.n + 1 / y.n)
# Reference group
} else {
d.se <- sqrt(sd(c(x, y))^2*(1 / x.n + 1 / y.n))
df <- x.n + y.n - 2
t <- yx.diff / d.se
hn <- sqrt(1 / x.n + 1 / y.n)
}
conf1 <- ifelse(alternative == "two.sided", (1 + conf.level) / 2, conf.level)
conf2 <- ifelse(alternative == "two.sided", (1 - conf.level) / 2, 1 - conf.level)
# Noncentrality parameter
st <- max(0.1, abs(t))
###
end1 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end1)) < conf1) { end1 <- end1 - st }
ncp1 <- uniroot(function(x) conf1 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(end1, 2*t - end1))$root
###
end2 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end2)) > conf2) { end2 <- end2 + st }
ncp2 <- uniroot(function(x) conf2 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(2*t - end2, end2))$root
# Confidence interval around ncp
conf.int <- switch(alternative,
two.sided = c(low = ncp1 * hn, upp = ncp2 * hn),
less = c(low = -Inf, upp = ncp2 * hn),
greater = c(low = ncp1 * hn, upp = Inf))
# With correction factor
if(isTRUE(correct)) {
conf.int <- conf.int*corr.factor
}
# Not at least 2 observations for x/y and variance in x/y
} else {
d <- d.se <- sd.group <- NA
conf.int <- c(NA, NA)
}
#—————————————————————————————————————— #
### Paired-Sample ####
} else if (isTRUE(paired)) {
#···················
#### Data ####
xy.dat <- na.omit(data.frame(x = x, y = y, stringsAsFactors = FALSE))
x <- xy.dat$x
y <- xy.dat$y
# Standard deviation of x and y
x.sd <- sd(x)
y.sd <- sd(y)
# Unstandardized mean difference
yx.diff <- mean(y - x)
# Sample size
xy.n <- nrow(xy.dat)
#···················
#### Standard Deviation ####
# SD of difference score, Cohen's d.z
if (isTRUE(weighted)) {
sd.group <- sd(y - x)
} else {
# Controlling correlation, Cohen's d.rm
if (isTRUE(cor)) {
# Variance of x and y
x.var <- var(x)
y.var <- var(y)
# Sum of the variances
xy.var.sum <- sum(c(x.var, y.var))
# Correlation between x and y
xy.r <- cor(x, y)
sd.group <- sqrt(xy.var.sum - 2L * xy.r * prod(c(sqrt(x.var), sqrt(y.var))))
# Ignoring correlation, Cohen's d.av
} else {
sd.group <- (x.sd + y.sd) / 2
}
}
#···················
#### Cohen's d ####
# Cohen's d.rm
if (isTRUE(cor && !isTRUE(weighted))) {
d <- yx.diff / sd.group * sqrt(2L*(1L -xy.r))
# Cohen's d.z, d.av, and Glass's delta
} else {
d <- yx.diff / sd.group
}
#···················
#### Correction Factor ####
# Degrees of freedom
v <- xy.n - 1
# Correction factor based on gamma function
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2L)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation method
if (isTRUE(is.na(corr.factor) || is.nan(corr.factor) || is.infinite(corr.factor))) {
corr.factor <- 1L - 3L / (4L * v - 1L)
}
# Bias-corrected Cohen's d
if (isTRUE(correct)) {
d <- d*corr.factor
}
#···················
#### Confidence Interval ####
# Standard error
d.se <- sqrt((xy.n / (xy.n / 2)^2) + 0.5*(d^2 / xy.n))
# Noncentrality parameter
t <- yx.diff / (sd.group / sqrt(xy.n))
df <- xy.n - 1
conf1 <- ifelse(alternative == "two.sided", (1L + conf.level) / 2L, conf.level)
conf2 <- ifelse(alternative == "two.sided", (1L - conf.level) / 2L, 1L - conf.level)
st <- max(0.1, abs(t))
###
end1 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end1)) < conf1) { end1 <- end1 - st }
ncp1 <- uniroot(function(x) conf1 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(end1, 2*t - end1))$root
###
end2 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end2)) > conf2) { end2 <- end2 + st }
ncp2 <- uniroot(function(x) conf2 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(2*t - end2, end2))$root
# Confidence interval around ncp
conf.int <- switch(alternative,
two.sided = c(low = ncp1 / sqrt(df), upp = ncp2 / sqrt(df)),
less = c(low = -Inf, upp = ncp2 / sqrt(df)),
greater = c(low = ncp1 / sqrt(df), upp = Inf))
# With correction factor
if(isTRUE(correct)) {
conf.int <- conf.int*corr.factor
}
}
# Return object
object <- data.frame(m.diff = yx.diff, sd = sd.group,
d = d, se = d.se,
low = conf.int[1L], upp = conf.int[2], row.names = NULL)
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the cor.matrix() function -----------------------------
#
# - .cor.test.pearson
# - .cor.test.spearman
# - .cor.test.kendall.b
# - .cor.test.kendall.c
# - .polychoric
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.pearson Function ####
.cor.test.pearson <- function(x, y) {
# At least three cases
object <- if (isTRUE(nrow(na.omit(data.frame(x = x, y = y))) >= 3L)) {
suppressWarnings(cor.test(x, y, method = "pearson")) |> (\(p) list(cor = p$estimate, stat = p$statistic, df = p$parameter, pval = p$p.value))()
# Less than three cases
} else {
list(cor = NA, stat = NA, df = NA, pval = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.spearman Function ####
.cor.test.spearman <- function(x, y, exact, continuity) {
# At least three cases
object <- if (isTRUE(nrow(na.omit(data.frame(x = x, y = y))) >= 3L)) {
# Complete data
xy <- na.omit(data.frame(x = x, y = y))
# Statistical test for the correlation coefficient
if (isTRUE(exact)) {
suppressWarnings(cor.test(xy$x, xy$y, method = "spearman", exact = TRUE, continuity = continuity)) |> (\(p) list(cor = p$estimate, stat = p$statistic, df = NA, pval = p$p.value))()
} else {
cor(xy$x, xy$y, method = "spearman", use = "pairwise.complete.obs") |> (\(p) list(cor = p, stat = p*sqrt((nrow(xy) - 2L) / (1L - p^2L)), df = nrow(xy) - 2L, pval = cor.test(xy$x, xy$y, method = "spearman", exact = FALSE, continuity = continuity)$p.value) )()
}
# Less than three cases
} else {
list(cor = NA, stat = NA, df = NA, pval = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .internal.cor.test.kendall.b Function ####
.cor.test.kendall.b <- function(x, y, exact, continuity) {
# At least three cases
if (isTRUE(nrow(na.omit(data.frame(x = x, y = y))) >= 3L)) {
# Statistical test for the correlation coefficient
object <- suppressWarnings(cor.test(x, y, method = "kendall", exact = exact, continuity = continuity)) |> (\(p) list(cor = p$estimate, stat = p$statistic, df = NA, pval = p$p.value))()
# Less than three cases
} else {
object <- list(stat = NA, df = NA, pval = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.kendall.c Function ####
.cor.test.kendall.c <- function(x, y) {
# Contingency table
x.table <- table(x, y)
# Number of rows
x.nrow <- nrow(x.table)
# Number of columns
x.ncol <- ncol(x.table)
# Sample size
x.n <- sum(x.table)
# Minimum of number of rows/columns
x.m <- min(dim(x.table))
if (isTRUE(x.n > 1L && x.nrow > 1L && x.ncol > 1L)) {
pi.c <- pi.d <- matrix(0L, nrow = x.nrow, ncol = x.ncol)
x.col <- col(x.table)
x.row <- row(x.table)
for (i in 1L:x.nrow) {
for (j in 1L:x.ncol) {
pi.c[i, j] <- sum(x.table[x.row < i & x.col < j]) + sum(x.table[x.row > i & x.col > j])
pi.d[i, j] <- sum(x.table[x.row < i & x.col > j]) + sum(x.table[x.row > i & x.col < j])
}
}
# Concordant
x.con <- sum(pi.c * x.table)/2L
# Discordant
x.dis <- sum(pi.d * x.table)/2L
# Kendall-Stuart Tau-c
tau.c <- (x.m*2L * (x.con - x.dis)) / ((x.n^2L) * (x.m - 1L))
} else {
tau.c <- NA
}
#—————————————————————————————————————— #
### If n > 2 ####
if (isTRUE(x.n > 2L & x.nrow > 1L & x.ncol > 1L)) {
# Test statistic
z <- tau.c / sqrt(4L * x.m^2L / ((x.m - 1L)^2L * x.n^4L) * (sum(x.table * (pi.c - pi.d)^2L) - 4L * (x.con - x.dis)^2L / x.n))
# Two-tailed p-value
pval <- pnorm(abs(z), lower.tail = FALSE)*2L
} else {
z <- NA
pval <- NA
}
object <- list(result = list(cor = tau.c, n = x.n, stat = z, df = NA, pval = pval))
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.polychoric Function ####
#
# Modified function polychor() from the polycor package
# see: https://github.com/cran/polycor/blob/master/R/polychor.R
.cor.test.polychoric <- function (x, y, ml = FALSE, se = FALSE, maxcor = 0.9999) {
#—————————————————————————————————————— #
### Function ####
f <- function(pars) {
if (isTRUE(length(pars) == 1L)) {
rho <- pars
if (isTRUE(abs(rho) > maxcor)) { rho <- sign(rho)*maxcor }
row.cuts <- rc
col.cuts <- cc
} else {
rho <- pars[1L]
if (isTRUE(abs(rho) > maxcor)) { rho <- sign(rho)*maxcor }
row.cuts <- pars[2L:r]
col.cuts <- pars[(r + 1L):(r + c - 1L)]
if (isTRUE(any(diff(row.cuts) < 0L) || any(diff(col.cuts) < 0))) { return(Inf) }
}
P <- .binBvn(rho, row.cuts, col.cuts)
return(-sum(tab * log(P)))
}
#—————————————————————————————————————— #
valid <- complete.cases(x, y)
x <- x[valid]
y <- y[valid]
tab <- if (isTRUE(missing(y))) { x } else { table(x, y) }
zerorows <- apply(tab, 1L, function(x) all(x == 0))
zerocols <- apply(tab, 2L, function(x) all(x == 0))
zr <- sum(zerorows)
zc <- sum(zerocols)
tab <- tab[!zerorows, , drop = FALSE]
tab <- tab[, !zerocols, drop = FALSE]
r <- nrow(tab)
c <- ncol(tab)
if (isTRUE(r < 2 || c < 2)) { return(NA) }
n <- sum(tab)
rc <- qnorm(cumsum(rowSums(tab)) / n)[-r]
cc <- qnorm(cumsum(colSums(tab)) / n)[-c]
#—————————————————————————————————————— #
### Maximum-Likelihood Estimate ####
if (isTRUE(ml)) {
res.optim <- tryCatch(optim(c(stats::optimise(f, interval = c(-1L, 1L))$minimum, rc, cc), f, hessian = se),
error = function(y) {
return(list(par = NA, se = NA, hessian = NA))
})
if (isTRUE(res.optim$par[1L] > 1L)) { res.optim$par[1L] <- maxcor } else if (isTRUE(res.optim$par[1L] < -1L)) { res.optim$par[1L] <- -maxcor }
if (isTRUE(se)) {
result <- list(cor = res.optim$par[1L], se = ifelse(!is.na(res.optim$hessian), sqrt(solve(res.optim$hessian)[1L, 1L]), NA))
} else {
result <- list(cor = as.vector(res.optim$par[1L]), se = NA)
}
#—————————————————————————————————————— #
### Two-Step Approximation ####
} else if (isTRUE(se)) {
res.optim <- tryCatch(suppressWarnings(optim(0L, f, hessian = TRUE, method = "BFGS")),
error = function(y) {
return(list(par = NA, se = NA, hessian = NA))
})
if (isTRUE(res.optim$par > 1L)) { res.optim$par <- maxcor } else if (isTRUE(res.optim$par < -1L)) { res.optim$par <- -maxcor }
result <- list(cor = res.optim$par, se = ifelse(!is.na(res.optim$hessian), sqrt(1L / res.optim$hessian), NA))
} else {
result <- list(cor = stats::optimise(f, interval = c(-maxcor, maxcor))$minimum, se = NA)
}
#—————————————————————————————————————— #
### Return Object ####
return(list(result = list(cor = result$cor,
n = sum(valid),
stat = ifelse(!is.na(result$se), result$cor / result$se, NA),
df = NA,
pval = ifelse(!is.na(result$se), pnorm(abs(result$cor / result$se), lower.tail = FALSE) * 2L, NA))))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .binBvn Function from the polycor Package ####
.binBvn <- function(rho, row.cuts, col.cuts, bins = 4L){
row.cuts <- if (isTRUE(missing(row.cuts))) { c(-Inf, 1:(bins - 1L) / bins, Inf) } else { c(-Inf, row.cuts, Inf) }
col.cuts <- if (isTRUE(missing(col.cuts))) { c(-Inf, 1:(bins - 1L) / bins, Inf) } else { c(-Inf, col.cuts, Inf) }
r <- length(row.cuts) - 1L
c <- length(col.cuts) - 1L
P <- matrix(0L, r, c)
R <- matrix(c(1L, rho, rho, 1L), 2L, 2L)
for (i in seq_len(r)) {
for (j in seq_len(c)) {
P[i, j] <- mvtnorm::pmvnorm(lower=c(row.cuts[i], col.cuts[j]), upper = c(row.cuts[i + 1L], col.cuts[j + 1]), corr = R)
}
}
return(P)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the difftest.chibarsq() function ----------------------
.find.c2 <- function(weight, k, u, alpha) {
function(x) {
y <- numeric(1L)
p <- 0L
for (i in 1L:(k + 1L)) { p = p + weight[i] * (1L - pchisq(x, (u + i - 1L))) }
y <- p - alpha
return(y)
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the dominance() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Dominance analysis supporting formula-based modeling functions ####
.domin <- function(formula_overall, reg, fitstat, sets = NULL, all = NULL,
conditional = TRUE, complete = TRUE, consmodel = NULL, reverse = FALSE, ...) {
# Input check
if (isTRUE(!inherits(formula_overall, "formula"))) { stop(paste(formula_overall, "is not a 'formula' class object."), call. = FALSE) }
if (isTRUE(!is.null(attr(stats::terms(formula_overall), "offset")))) { stop("'offset()' terms not allowed in formula object.", call. = FALSE) }
if (isTRUE(!is.list(fitstat))) { stop("fitstat is not a list.", call. = FALSE) }
if (isTRUE(length(sets) > 0L & !is.list(sets))) { stop("sets is not a list.", call. = FALSE) }
if (isTRUE(is.list(all))) { stop("all is a list. Please submit it as a vector.", call. = FALSE) }
if (isTRUE(!attr(stats::terms(formula_overall), "response"))) { stop(paste(deparse(formula_overall), "missing a response."), call. = FALSE) }
if (isTRUE(any(attr(stats::terms(formula_overall), "order") > 1L))) { warning(paste(deparse(formula_overall), "contains second or higher order terms, fsunction may not handle them correctly."), call. = FALSE) }
if (isTRUE(length(fitstat) < 2L)) { stop("fitstat requires at least two elements.", call. = FALSE) }
# Process variable lists
Indep_Vars <- attr(stats::terms(formula_overall), "term.labels")
intercept <- as.logical(attr(stats::terms(formula_overall), "intercept"))
if (isTRUE(length(sets) > 0L)) {
set_aggregated <- sapply(sets, paste0, collapse = " + ")
Indep_Vars <- append(Indep_Vars, set_aggregated)
}
Dep_Var <- attr(stats::terms(formula_overall), "variables")[[2L]]
Total_Indep_Vars <- length(Indep_Vars)
# IV-based exit conditions
if (isTRUE(Total_Indep_Vars < 2L)) { stop(paste("Total of", Total_Indep_Vars, "independent variables or sets. At least 2 needed for useful dominance analysis."), call. = FALSE) }
# Create independent variable/set combination list
Combination_Matrix <- expand.grid(lapply(1:Total_Indep_Vars, function(x) c(FALSE, TRUE)), KEEP.OUT.ATTRS = FALSE)[-1L, ]
Total_Models_to_Estimate <- 2L**Total_Indep_Vars - 1L
# Define function to call regression models
doModel_Fit <- function(Indep_Var_Combin_lgl, Indep_Vars, Dep_Var, reg, fitstat, all = NULL, consmodel = NULL, intercept, ...) {
Indep_Var_Combination <- Indep_Vars[Indep_Var_Combin_lgl]
formula_to_use <- stats::reformulate(c(Indep_Var_Combination, all, consmodel), response = Dep_Var, intercept = intercept)
Model_Result <- list(do.call(reg, list(formula_to_use, ...)))
if (isTRUE(length(fitstat) > 2L)) { Model_Result <- append(Model_Result, fitstat[3L:length(fitstat)]) }
Fit_Value <- do.call(fitstat[[1L]], Model_Result)
return( Fit_Value[[ fitstat[[2L]]]])
}
# Constant model adjustments
Cons_Result <- NULL
FitStat_Adjustment <- 0L
if (isTRUE(length(consmodel) > 0L)) {
FitStat_Adjustment <- Cons_Result <- doModel_Fit(NULL, Indep_Vars, Dep_Var, reg, fitstat, consmodel = consmodel, intercept = intercept, ...)
}
# All subsets adjustment
All_Result <- NULL
if (isTRUE(length(all) > 0L)) {
FitStat_Adjustment <- All_Result <- doModel_Fit(NULL, Indep_Vars, Dep_Var, reg, fitstat, all = all, consmodel = consmodel, intercept = intercept, ...)
}
# Obtain all subsets regression results
Ensemble_of_Models <- sapply(1L:nrow(Combination_Matrix), function(x) { doModel_Fit(unlist(Combination_Matrix[x, ]), Indep_Vars, Dep_Var, reg, fitstat, all = all, consmodel = consmodel, intercept = intercept, ...) },
simplify = TRUE, USE.NAMES = FALSE)
# Conditional dominance statistics
Conditional_Dominance <- NULL
if (isTRUE(conditional)) {
Conditional_Dominance <- matrix(nrow = Total_Indep_Vars, ncol = Total_Indep_Vars)
Combination_Matrix_Anti <-!Combination_Matrix
IVs_per_Model <- rowSums(Combination_Matrix)
Combins_at_Order <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars, x), simplify = TRUE, USE.NAMES = FALSE)
Combins_at_Order_Prev <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars - 1L, x), simplify = TRUE, USE.NAMES = FALSE)
Weighted_Order_Ensemble <- ((Combination_Matrix*(Combins_at_Order - Combins_at_Order_Prev))**-1L)*Ensemble_of_Models
Weighted_Order_Ensemble <- replace(Weighted_Order_Ensemble, Weighted_Order_Ensemble == Inf, 0L)
Weighted_Order_Ensemble_Anti <- ((Combination_Matrix_Anti*Combins_at_Order_Prev)**-1L)*Ensemble_of_Models
Weighted_Order_Ensemble_Anti <- replace(Weighted_Order_Ensemble_Anti, Weighted_Order_Ensemble_Anti == Inf, 0L)
for (order in seq_len(Total_Indep_Vars)) {
Conditional_Dominance[, order] <- t(colSums(Weighted_Order_Ensemble[IVs_per_Model == order, ]) - colSums(Weighted_Order_Ensemble_Anti[IVs_per_Model == (order - 1L), ]))
}
Conditional_Dominance[, 1L] <- Conditional_Dominance[, 1L] - FitStat_Adjustment
}
# Complete dominance statistics
Complete_Dominance <- NULL
if (isTRUE(complete)) {
Complete_Dominance <- matrix(data = NA, nrow = Total_Indep_Vars, ncol = Total_Indep_Vars)
Complete_Combinations <- utils::combn(seq_len(Total_Indep_Vars), 2L)
for (pair in 1L:ncol(Complete_Combinations)) {
Focal_Cols <- Complete_Combinations[, pair]
NonFocal_Cols <- setdiff(1:Total_Indep_Vars, Focal_Cols)
Select_2IVs <- cbind(Combination_Matrix, 1L:nrow(Combination_Matrix))[rowSums(Combination_Matrix[, Focal_Cols]) == 1L, ]
Sorted_2IVs <- Select_2IVs[do.call("order", as.data.frame(Select_2IVs[,c(NonFocal_Cols, Focal_Cols)])), ]
Compare_2IVs <- cbind(Ensemble_of_Models[Sorted_2IVs[(1L:nrow(Sorted_2IVs) %% 2L) == 0L, ncol(Sorted_2IVs)]], Ensemble_of_Models[Sorted_2IVs[(1L:nrow(Sorted_2IVs) %% 2) == 1L, ncol(Sorted_2IVs)]])
Complete_Designation <- ifelse(all(Compare_2IVs[, 1L] > Compare_2IVs[, 2L]), FALSE, ifelse(all(Compare_2IVs[, 1L] < Compare_2IVs[, 2L]), TRUE, NA))
Complete_Dominance[Focal_Cols[[2L]], Focal_Cols[[1L]]] <- Complete_Designation
Complete_Dominance[Focal_Cols[[1L]], Focal_Cols[[2L]]] <- !Complete_Designation
}
}
if (isTRUE(reverse)) { Complete_Dominance <- !Complete_Dominance }
# General dominance statistics
General_Dominance <- rowMeans(Conditional_Dominance)
if (isTRUE(!conditional)) {
Combination_Matrix_Anti <-!Combination_Matrix
IVs_per_Model <- rowSums(Combination_Matrix)
Combins_at_Order <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars, x), simplify = TRUE, USE.NAMES = FALSE)
Combins_at_Order_Prev <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars - 1L, x), simplify = TRUE, USE.NAMES = FALSE)
Indicator_Weight <- Combination_Matrix*(Combins_at_Order - Combins_at_Order_Prev)
Indicator_Weight_Anti <- (Combination_Matrix_Anti*Combins_at_Order_Prev)*-1L
Weight_Matrix <- ((Indicator_Weight + Indicator_Weight_Anti)*Total_Indep_Vars)^-1L
General_Dominance <- colSums(Ensemble_of_Models*Weight_Matrix)
General_Dominance <- General_Dominance - FitStat_Adjustment/Total_Indep_Vars
}
# Overall fit statistic and ranks
FitStat <- sum(General_Dominance) + FitStat_Adjustment
if (isTRUE(!reverse)) { General_Dominance_Ranks <- rank(-General_Dominance) } else { General_Dominance_Ranks <- rank(General_Dominance) }
# Return values and attributes
if (isTRUE(length(sets) == 0L)) { IV_Labels <- attr(stats::terms(formula_overall), "term.labels") } else { IV_Labels <- c( attr(stats::terms(formula_overall), "term.labels"), paste0("set", 1:length(sets))) }
names(General_Dominance) <- IV_Labels
names(General_Dominance_Ranks) <- IV_Labels
if (isTRUE(conditional)) { dimnames(Conditional_Dominance) <- list(IV_Labels, paste0("IVs_", seq_along(Indep_Vars))) }
if (isTRUE(complete)) { dimnames(Complete_Dominance) <- list(paste0("Dmnates_", IV_Labels), paste0("Dmnated_", IV_Labels)) }
if (isTRUE(!reverse)) { Standardized <- General_Dominance / (FitStat - ifelse(length(Cons_Result) > 0L, Cons_Result, 0L)) } else { Standardized <- -General_Dominance / -(FitStat - ifelse(length(Cons_Result) > 0L, Cons_Result, 0L)) }
# Return object
return_list <- list(General_Dominance = General_Dominance,
Standardized = Standardized,
Ranks = General_Dominance_Ranks,
Conditional_Dominance = Conditional_Dominance,
Complete_Dominance = Complete_Dominance,
Fit_Statistic_Overall = FitStat,
Fit_Statistic_All_Subsets = All_Result - ifelse(is.null(Cons_Result), 0, Cons_Result),
Fit_Statistic_Constant_Model = Cons_Result,
Call = match.call(),
Subset_Details = list(Full_Model = stats::reformulate(c(Indep_Vars, all, consmodel), response = Dep_Var, intercept = intercept),
Formula = attr(stats::terms(formula_overall), "term.labels"),
All = all, Sets = sets, Constant = consmodel))
class(return_list) <- c("domin", "list")
return(return_list)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the dominance.manual() function -----------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Enumerate the Combinations or Permutation of the ELements of a Vector ####
# combinations() from the gtools package
.combinations <- function(n, r, v = 1:n, set = TRUE, repeats.allowed = FALSE) {
if (isTRUE(mode(n) != "numeric" || length(n) != 1L || n < 1L || (n %% 1L) != 0L)) { stop("bad value of n") }
if (isTRUE(mode(r) != "numeric" || length(r) != 1L || r < 1L || (r %% 1L) != 0L)) { stop("bad value of r") }
if (isTRUE(!is.atomic(v) || length(v) < n)) { stop("v is either non-atomic or too short") }
if (isTRUE((r > n) & !repeats.allowed)) { stop("r > n and repeats.allowed = FALSE", call. = FALSE) }
if (isTRUE(set)) {
v <- unique(sort(v))
if (length(v) < n) stop("Too few different elements", call. = FALSE)
}
v0 <- vector(mode(v), 0L)
## Inner workhorse
if (repeats.allowed) {
sub <- function(n, r, v) {
if (isTRUE(r == 0L)) { v0 } else if (isTRUE(r == 1L)) { matrix(v, n, 1) } else if (isTRUE(n == 1L)) { matrix(v, 1L, r) } else { rbind(cbind(v[1L], Recall(n, r - 1L, v)), Recall(n - 1L, r, v[-1L])) }
}
} else {
sub <- function(n, r, v) {
if (isTRUE(r == 0L)) { v0 } else if (isTRUE(r == 1L)) { matrix(v, n, 1) } else if (isTRUE(r == n)) { matrix(v, 1L, n) } else { rbind(cbind(v[1], Recall(n - 1L, r - 1L, v[-1L])), Recall(n - 1L, r, v[-1L])) }
}
return(sub(n, r, v[1L:n]))
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Dominance analysis functions ####
.DA <- function(cormat, index = NULL) {
# Correlation matrix of the predictors
Px <- cormat[-1L, -1L]
# Correlation vector
rx <- cormat[-1L, 1L]
if (isTRUE(is.null(index))) { index = as.list(1:length(rx)) }
# Number of predictors or groups of predictors
J <- length(index)
# R2 for model with subset xi
R2 <- function(xi) {
xi <- unlist(index[xi])
R2 <- t(rx[xi])%*%solve(Px[xi, xi])%*%rx[xi]
}
# Average R2 change for a subset model with k size
# Possible subset models before adding a predictor
submodel <- function(k) {
temp0 <- lapply(1L:J, function(i) .combinations(J - 1L, k, (1L:J)[-i]))
# Possible subset models after adding a predictor
temp1 <- lapply(1:J, function(i) t(apply(temp0[[i]], 1L, function(x) c(x, i))))
# R2 before adding a predictor
R0 <- lapply(temp0, function(y) apply(y, 1L, R2))
# R2 after adding a predictor
R1 <- lapply(temp1, function(y) apply(y, 1L, R2))
# R2 change
deltaR2 <- mapply(function(x, y) x - y, R1, R0)
# Average R2 change
adeltaR2 <- apply(matrix(deltaR2, ncol = J), 2L, mean)
return(adeltaR2)
}
# Different model size k
R2matrix <- t(sapply(1L:(J - 1L), submodel))
R2matrix <- rbind(sapply(1L:J, R2), R2matrix)
# Overall average
DA <- apply(R2matrix, 2L, mean)
return(DA)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the effsize() function --------------------------------
#
# - .phi
# - .cramer
# - .tschuprow
# - .cont
# - .cohen.w
# - .fei
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .phi Function ####
.phi <- function(x, adjust, p = NULL, conf.level, alternative, fei = FALSE) {
# Cross tabulation
tab <- table(x)
# Vector of probabilities
if (isTRUE(is.null(p))) { p <- rep(1 / length(tab), times = length(tab)) }
# Chi-squared Test
model <- tryCatch(suppressWarnings(chisq.test(tab, correct = FALSE, p = p)), error = function(y) { list(statistic = NA, parameter = NA) })
# Table with at least two rows and two columns and chi-square statistic is not NA or NaN
if (isTRUE(((ncol(tab) >= 2L && nrow(tab) >= 2L) || fei) && !is.na(model$parameter) && !is.nan(model$statistic))) {
# Test statistic
chisq <- model$statistic
# Degrees of freedom
df <- model$parameter
# Sample size
n <- sum(tab)
# Noncentral parameter
chisqs <- vapply(chisq, .get_ncp_chi, FUN.VALUE = numeric(2L), df = df, conf.level = conf.level, alternative = alternative)
# Result table
result <- data.frame(phi = sqrt(chisq / n), low = sqrt(chisqs[1L, ] / n), upp = sqrt(chisqs[2L, ] / n), row.names = NULL)
# Adjusted phi coefficient
if (isTRUE(adjust)) { result <- result / min(c(sqrt((sum(tab[1L, ])*sum(tab[, 2L])) / (sum(tab[, 1L])*sum(tab[2L, ]))), sqrt((sum(tab[, 1L])*sum(tab[2L, ])) / (sum(tab[1L, ])*sum(tab[, 2L]))))) }
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size
result <- data.frame(n = n, result)
} else {
result <- data.frame(n = sum(tab), phi = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cramer Function ####
.cramer <- function(x, adjust, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Number of rows and columns
nrow <- nrow(tab)
ncol <- ncol(tab)
# Phi coefficient
result <- .phi(x, adjust = FALSE, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
#—————————————————————————————————————— #
### Finite Sample Bias-Correction ####
if (isTRUE(adjust)) {
# Sample size
n <- sum(tab)
# Correction
result <- lapply(result, function(y) { sqrt(pmax(0, y^2L - ((nrow - 1L)*(ncol - 1L)) / (n - 1L))) })
# Cramer's V
result <- data.frame(lapply(result, function(y) y / sqrt(pmin((nrow - ((nrow - 1L)^2L) / (n - 1L)) - 1L, (ncol - ((ncol - 1L)^2L) / (n - 1L)) - 1L))))
#—————————————————————————————————————— #
### No Finite Sample Bias-Correction ####
} else {
# Cramer's V
result <- data.frame(lapply(result, function(y) y / sqrt(pmin(nrow - 1L, ncol - 1L))))
}
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("v", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), v = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .tschuprow Function ####
.tschuprow <- function(x, adjust, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Number of rows and columns
nrow <- nrow(tab)
ncol <- ncol(tab)
# Sample size
n <- sum(tab)
# Phi coefficient
result <- .phi(x, adjust = FALSE, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
#—————————————————————————————————————— #
### Finite Sample Bias-Correction ####
if (isTRUE(adjust)) {
# Correction
result <- lapply(result, function(y) { sqrt(pmax(0, y^2L - ((nrow - 1L)*(ncol - 1L)) / (n - 1L))) })
# Tschuprow's T
result <- data.frame(lapply(result, function(y) y / sqrt(sqrt(((nrow - ((nrow - 1L)^2L) / (n - 1L)) - 1L) * ((ncol - ((ncol - 1L)^2L) / (n - 1L)) - 1L)))))
#—————————————————————————————————————— #
### No Finite Sample Bias-Correction ####
} else {
# Tschuprow's T
result <- data.frame(lapply(result, function(y) y / sqrt(sqrt((nrow - 1L) * (ncol - 1L)))))
}
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size and column names
result <- data.frame(n = n, setNames(result, nm = c("t", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), t = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cont Function ####
.cont <- function(x, adjust, p = NULL, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Phi coefficient
result <- .phi(x, adjust = FALSE, p = p, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
# Contingency coefficient
result <- data.frame(lapply(result, function(y) y / sqrt(y^2L + 1L)))
# Sakoda's adjustment
if (isTRUE(adjust)) {
k <- min(c(nrow(tab), ncol(tab)))
result <- result / sqrt((k - 1L) / k)
}
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("c", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), c = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cohen.w Function ####
.cohen.w <- function(x, adjust, p = NULL, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Number of rows and columns
nrow <- nrow(tab)
ncol <- ifelse(isTRUE(is.na(ncol(tab))), 1L, ncol(tab))
# Phi coefficient
result <- .phi(x, adjust = FALSE, p = p, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
# Cohen's w
if (isTRUE(ncol == 1L || nrow == 1L)) {
if (isTRUE(is.null(p))) {
max.poss <- Inf
} else {
max.poss <- sqrt((1L / min(p / sum(p))) - 1L)
}
} else {
max.poss <- sqrt((pmin(ncol, nrow) - 1L))
}
# One-sided confidence interval
switch(alternative, less = { result$upp <- pmin(result$upp, max.poss) }, greater = { result$upp <- max.poss })
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("w", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), w = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .fei Function ####
.fei <- function(x, adjust, p = NULL, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Vector of probabilities
if (isTRUE(is.null(p))) { p <- rep(1L / length(tab), times = length(tab)) }
# Fei
result <- .phi(x, adjust = FALSE, fei = TRUE, p = p, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
result <- data.frame(lapply(result, function(y) y / sqrt(1L / min(p) - 1L)))
# One-sided confidence interval
switch(alternative, less = { result$upp <- pmin(result$upp, 1L) }, greater = { result$upp <- 1L})
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("fei", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), fei = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .get_ncp_chi Function ####
.get_ncp_chi <- function(chi, df, conf.level, alternative) {
alpha <- 1L - ifelse(alternative != "two.sided", 2L * conf.level - 1L, conf.level)
probs <- c(alpha / 2L, 1L - alpha / 2L)
ncp <- suppressWarnings(stats::optim(par = 1.1 * rep(chi, 2L), fn = function(y) {
p <- pchisq(q = chi, df, ncp = y)
abs(max(p) - probs[2L]) + abs(min(p) - probs[1L])
}, control = list(abstol = 1e-09)))
chi_ncp <- sort(ncp$par)
if (chi <= stats::qchisq(probs[1L], df)) { chi_ncp[2L] <- 0L }
if (chi <= stats::qchisq(probs[2L], df)) { chi_ncp[1L] <- 0L }
return(chi_ncp)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the indirect() function -------------------------------
#
# - .qprodnormalMeeker
.qprodnormalMeeker <- function(p, a, b, se.a, se.b, lower.tail = TRUE) {
max.iter <- 10000L
mu.a <- a / se.a
mu.b <- b / se.b
se.ab <- sqrt(1L + mu.a^2L + mu.b^2L)
if (isTRUE(lower.tail == FALSE)) {
u0 <- mu.a*mu.b + 6L*se.ab
l0 <- mu.a*mu.b - 6L*se.ab
alpha <- 1L - p
} else {
l0 <- mu.a*mu.b - 6L*se.ab
u0 <- mu.a*mu.b + 6L*se.ab
alpha <- p
}
gx <- function(x, z) {
mu.a.on.b <- mu.a
integ <- pnorm(sign(x)*(z / x - mu.a.on.b))*dnorm(x - mu.b)
return(integ)
}
fx <- function(z) {
return(integrate(gx, lower = -Inf, upper = Inf, z = z)$value - alpha)
}
p.l <- fx(l0)
p.u <- fx(u0)
iter <- 0L
while (p.l > 0L) {
iter <- iter + 1L
l0 <- l0 - 0.5*se.ab
p.l <- fx(l0)
if (iter > max.iter) {
return(list(q = NA, error = NA))
}
}
iter <- 0L
while (p.u < 0L) {
iter <- iter + 1L
u0 <- u0 + 0.5*se.ab
p.u <- fx(u0)
if (iter > max.iter) {
return(list(q = NA,error = NA))
}
}
new <- uniroot(fx, c(l0, u0))$root*se.a*se.b |> (\(p) if (isTRUE(is.list(p))) { NA } else { p })()
return(new)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.alpha() function -----------------------------
#
# - .alpha
.alpha <- function(y, ordered, rescov = NULL, std = std, estimator = estimator, missing = missing, check = TRUE) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Coefficient Alpha for Continuous Items ####
mod.fit <- NULL
if (isTRUE(!ordered)) {
#—————————————————————————————————————— #
### Formula-Based Coefficient Alpha ####
if (missing != "fiml" && estimator == "ULS" && is.null(rescov)) {
##### Correlation Matrix ####
if (isTRUE(std)) {
mat.sigma <- cor(y, use = ifelse(missing == "listwise", "complete.obs", "pairwise.complete.obs"), method = "pearson")
##### Covariance Matrix ####
} else {
mat.sigma <- cov(y, use = ifelse(missing == "listwise", "complete.obs", "pairwise.complete.obs"), method = "pearson")
}
##### Coefficient Alpha ####
alpha <- (ncol(mat.sigma) / (ncol(mat.sigma) - 1L)) * (1L - sum(diag(as.matrix(mat.sigma))) / sum(as.matrix(mat.sigma)))
#—————————————————————————————————————— #
### CFA-Based Coefficient Alpha ####
} else {
##### Model specification ####
# Measurement model
mod.factor <- paste("f =~", paste(paste0("L*", colnames(y)), collapse = " + "))
# Residual covariance
if (isTRUE(!is.null(rescov))) { mod.factor <- vapply(rescov, function(y) paste(y, collapse = " ~~ "), FUN.VALUE = character(1L)) |> (\(y) paste(mod.factor, "\n", paste(y, collapse = " \n ")))() }
##### Model Estimation ####
mod.fit <- tryCatch(suppressWarnings(lavaan::cfa(mod.factor, data = y, ordered = FALSE, se = "none", test = "none", std.lv = TRUE, estimator = estimator, missing = missing)),
error = function(y) {
stop(paste0("CFA model for computing coefficient coefficient alpha could not be estimated."), call. = FALSE)
})
##### Model Convergence ####
# Model convergence
if (isTRUE(check)) { if (!isTRUE(lavaan::lavInspect(mod.fit, "converged"))) { warning("CFA model did not converge, results are most likely unreliable.", call. = FALSE) } }
##### Parameter Estimates ####
# Unstandardized parameter estimates
if (isTRUE(!std)) {
param <- lavaan::parameterestimates(mod.fit)
# Standardized parameter estimates
} else {
param <- misty::df.rename(lavaan::standardizedSolution(mod.fit), from = "est.std", to = "est")
}
##### Factor Loadings ####
param.load <- param[which(param$op == "=~"), ]
##### Residual Covariance ####
param.rcov <- param[param$op == "~~" & param$lhs != param$rhs, ]
##### Residuals Variances ####
param.resid <- param[param$op == "~~" & param$lhs == param$rhs & param$lhs != "f" & param$rhs != "f", ]
##### Numerator ####
load.sum2 <- sum(param.load$est)^2L
##### Denominator ####
resid.sum <- sum(param.resid$est)
##### Residual Covariances ####
if (isTRUE(!is.null(rescov))) { resid.sum <- resid.sum + 2L*sum(param.rcov$est) }
##### Coefficient Alpha ####
alpha <- load.sum2 / (load.sum2 + resid.sum)
}
#—————————————————————————————————————— #
### Return Object ####
object <- list(mod.fit = mod.fit, alpha = alpha)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Coefficient Alpha for Ordered-Categorical Items ####
} else {
##### Correlation Matrix ####
mat.sigma <- misty::cor.matrix(y, na.omit = ifelse(missing == "listwise", TRUE, FALSE), method = "poly", check = check, output = FALSE)$result$cor
diag(mat.sigma) <- 1
#—————————————————————————————————————— #
### Ordinal Coefficient Alpha ####
alpha <- (ncol(mat.sigma) / (ncol(mat.sigma) - 1L)) * (1L - sum(diag(as.matrix(mat.sigma)), na.rm = TRUE) / sum(as.matrix(mat.sigma), na.rm = TRUE))
#—————————————————————————————————————— #
### Return Object ####
object <- list(mod.fit = NULL, alpha = alpha)
}
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.omega() function -----------------------------
#
# - .omega
# - .categ.alpha.omega
# - .getThreshold
# - .polycorLavaan
# - .refit
# - .p2
#
# MBESS: The MBESS R Package
# https://cran.r-project.org/web/packages/MBESS/index.html
.omega <- function(y, rescov = NULL, type = type, std = std, estimator = estimator, missing = missing, check = TRUE) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Omega for Continuous Items ####
if (isTRUE(type != "categ")) {
# Variable names
vnames <- colnames(y)
#—————————————————————————————————————— #
### Mode Specification ####
# Measurement model
mod.factor <- paste("f =~", paste(vnames, collapse = " + "))
# Residual covariance
if (isTRUE(!is.null(rescov))) { mod.factor <- vapply(rescov, function(y) paste(y, collapse = " ~~ "), FUN.VALUE = character(1L)) |> (\(y) paste(mod.factor, "\n", paste(y, collapse = " \n ")))() }
#—————————————————————————————————————— #
### Mode Estimation ####
mod.fit <- tryCatch(suppressWarnings(lavaan::cfa(mod.factor, data = y, ordered = FALSE, se = "none", test = "none", std.lv = TRUE, estimator = estimator, missing = missing)),
error = function(y) {
stop(paste0("CFA model for computing coefficient ", type, " could not be estimated."), call. = FALSE)
})
#—————————————————————————————————————— #
### Check for Convergence ####
# Model convergence
if (isTRUE(check)) { if (!isTRUE(lavaan::lavInspect(mod.fit, "converged"))) { warning("CFA model did not converge, results are most likely unreliable.", call. = FALSE) } }
#—————————————————————————————————————— #
### Parameter Estimates ####
# Unstandardized parameter estimates
if (isTRUE(!std)) {
param <- lavaan::parameterestimates(mod.fit)
# Standardized parameter estimates
} else {
param <- misty::df.rename(lavaan::standardizedSolution(mod.fit), from = "est.std", to = "est")
}
#—————————————————————————————————————— #
### Factor Loadings ####
param.load <- param[which(param$op == "=~"), ]
#—————————————————————————————————————— #
### Residual Covariance ####
param.rcov <- param[param$op == "~~" & param$lhs != param$rhs, ]
#—————————————————————————————————————— #
### Residuals ####
param.resid <- param[param$op == "~~" & param$lhs == param$rhs & param$lhs != "f" & param$rhs != "f", ]
#—————————————————————————————————————— #
### Omega ####
# Numerator
load.sum2 <- sum(param.load$est)^2L
# Total alpha
if (isTRUE(type != "hierarch")) {
resid.sum <- sum(param.resid$est)
# Residual covariances
if (isTRUE(!is.null(rescov))) { resid.sum <- resid.sum + 2L*sum(param.rcov$est) }
omega <- load.sum2 / (load.sum2 + resid.sum)
#—————————————————————————————————————— #
### Hierarchical Omega ####
} else {
mod.cov.fit <- paste(apply(combn(seq_len(length(vnames)), m = 2L), 2L, function(z) paste(vnames[z[1L]], "~~", vnames[z[2L]])), collapse = " \n ") |>
(\(z) suppressWarnings(lavaan::cfa(z, data = y, ordered = FALSE, se = "none", test = "none", estimator = estimator, missing = missing)))()
if (isTRUE(!std)) {
var.total <- lavaan::parameterEstimates(mod.cov.fit) |> (\(y) sum(y[y$lhs == y$rhs, "est"], 2*y[y$lhs != y$rhs & y$op == "~~", "est"]))()
} else {
var.total <- lavaan::standardizedSolution(mod.cov.fit) |> (\(y) sum(y[y$lhs == y$rhs, "est"], 2*y[y$lhs != y$rhs & y$op == "~~", "est"]))()
}
omega <- load.sum2 / var.total
}
#—————————————————————————————————————— #
### Return Object ####
object <- list(mod.fit = mod.fit, omega = omega)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Omega for Ordered-Categorical Items ####
} else {
object <- .categ.omega(dat = y, rescov = rescov, estimator = estimator, missing = missing, check = TRUE)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .categ.alpha.omega Function ####
.categ.omega <- function(dat, rescov = NULL, estimator = estimator, missing = missing, check = TRUE) {
# Variable names
vnames <- colnames(dat)
# Sequence from 1 to the number of columns
q <- seq_len(ncol(dat))
# Convert to ordered factor
dat <- data.frame(lapply(dat, ordered))
# Measurement model
mod.factor <- paste("f =~", paste(vnames, collapse = " + "))
# Residual covariances
if (isTRUE(!is.null(rescov))) { mod.factor <- vapply(rescov, function(y) paste(y, collapse = " ~~ "), FUN.VALUE = character(1L)) |> (\(y) paste(mod.factor, "\n", paste(y, collapse = " \n ")))() }
# Estimate model
mod.fit <- tryCatch(suppressWarnings(lavaan::cfa(mod.factor, data = dat, estimator = estimator, missing = missing, std.lv = TRUE, se = "none", test = "none", ordered = TRUE)),
error = function(y) {
stop(paste0("CFA model for computing categorical coefficient omega could not be estimated."), call. = FALSE)
})
# Model convergence
if (isTRUE(check)) { if (!isTRUE(lavaan::lavInspect(mod.fit, "converged"))) { warning("CFA model did not converge, results are most likely unreliable.", call. = FALSE) } }
param <- lavaan::inspect(mod.fit, "coef")
ly <- param[["lambda"]]
ps <- param[["psi"]]
threshold <- .getThreshold(mod.fit)[[1L]]
denom <- .polycorLavaan(mod.fit, data = dat, estimator = estimator, missing = missing)[vnames, vnames]
invstdvar <- 1L / sqrt(diag(lavaan::lavInspect(mod.fit, "implied")$cov))
polyr <- diag(invstdvar) %*% ly%*%ps%*%t(ly) %*% diag(invstdvar)
sumnum <- 0L
addden <- 0L
for (j in q) {
for (jp in q) {
sumprobn2 <- 0L
addprobn2 <- 0L
t1 <- threshold[[j]]
t2 <- threshold[[jp]]
for(c in seq_along(t1)) {
for(cp in seq_along(t2)) {
sumprobn2 <- sumprobn2 + .p2(t1[c], t2[cp], polyr[j, jp])
addprobn2 <- addprobn2 + .p2(t1[c], t2[cp], denom[j, jp])
}
}
sumprobn1 <- sum(pnorm(t1))
sumprobn1p <- sum(pnorm(t2))
sumnum <- sumnum + (sumprobn2 - sumprobn1 * sumprobn1p)
addden <- addden + (addprobn2 - sumprobn1 * sumprobn1p)
}
}
return(list(mod.fit = mod.fit, omega = sumnum / addden))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .getThreshold Function ####
.getThreshold <- function(object) {
ngroups <- lavaan::inspect(object, "ngroups")
coef <- lavaan::inspect(object, "coef")
result <- NULL
if (isTRUE(ngroups == 1L)) {
targettaunames <- rownames(coef$tau)
barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|"))
varthres <- apply(data.frame(targettaunames, barpos - 1L, stringsAsFactors = FALSE), 1L, function(x) substr(x[1], 1L, x[2L]))
result <- list(split(coef$tau, varthres))
} else {
result <- list()
for (g in seq_len(ngroups)) {
targettaunames <- rownames(coef[[g]]$tau)
barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|"))
varthres <- apply(data.frame(targettaunames, barpos - 1L, stringsAsFactors = FALSE), 1L, function(x) substr(x[1L], 1L, x[2L]))
result[[g]] <- split(coef[[g]]$tau, varthres)
}
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .polycorLavaan Function ####
.polycorLavaan <- function(object, data, estimator = estimator, missing = missing) {
ngroups <- lavaan::inspect(object, "ngroups")
coef <- lavaan::inspect(object, "coef")
targettaunames <- NULL
if (isTRUE(ngroups == 1L)) {
targettaunames <- rownames(coef$tau)
} else {
targettaunames <- rownames(coef[[1L]]$tau)
}
barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|"))
vnames <- unique(apply(data.frame(targettaunames, barpos - 1L, stringsAsFactors = FALSE), 1L, function(x) substr(x[1L], 1L, x[2L])))
script <- ""
for(i in 2L:length(vnames)) {
temp <- paste0(vnames[1L:(i - 1L)], collapse = " + ")
temp <- paste0(vnames[i], " ~~ ", temp, "\n")
script <- paste(script, temp)
}
suppressWarnings(newobject <- .refit(pt = script, data = data, vnames = vnames, object = object, estimator = estimator, missing = missing))
if (isTRUE(ngroups == 1L)) {
return(lavaan::inspect(newobject, "coef")$theta)
} else {
return(lapply(lavaan::inspect(newobject, "coef"), "[[", "theta"))
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .refit Function ####
.refit <- function(pt, data, vnames, object, estimator = estimator, missing = missing) {
args <- lavaan::lavInspect(object, "call")
args$model <- pt
args$data <- data
args$ordered <- vnames
tempfit <- do.call(eval(parse(text = paste0("lavaan::", "lavaan"))), args[-1])
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .p2 Function ####
.p2 <- function(t1, t2, r) { mnormt::pmnorm(c(t1, t2), c(0L, 0L), matrix(c(1L, r, r, 1L), 2L, 2L)) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.invar() function -----------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Convergence and Model Identification Checks ####
.conv.ident <- function(model.fit, invar, long) {
check.vcov <- check.theta <- check.cov.lv <- TRUE
switch(invar, config = {
invar.upp <- "Configural"
invar.low <- "configural"
}, thres = {
invar.upp <- "Threshold"
invar.low <- "threshold"
}, metric = {
invar.upp <- "Metric"
invar.low <- "metric"
}, scalar = {
invar.upp <- "Scalar"
invar.low <- "scalar"
}, strict = {
invar.upp <- "Strict"
invar.low <- "strict"
})
#—————————————————————————————————————— #
### Model Not Converged ####
if (isTRUE(!lavaan::lavInspect(model.fit, what = "converged"))) {
stop(paste0(invar.upp, " invariance model did not converge."), call. = FALSE)
#—————————————————————————————————————— #
### Model Converged ####
} else {
#···················
#### Degrees of Freedom ####
if (isTRUE(suppressWarnings(lavaan::lavInspect(model.fit, what = "fit")["df"] < 0L))) { stop(paste0(invar.upp, " invariance model has negative degrees of freedom, model is not identified."), call. = FALSE) }
#···················
#### Standard Error ####
if (isTRUE(any(is.na(unlist(lavaan::lavInspect(model.fit, what = "se")))))) { stop(paste0("Standard errors of the ", invar.low, " invariance model could not be computed."), call. = FALSE) }
#···················
#### Variance-Covariance Matrix of the Estimated Parameters ####
eigvals <- eigen(lavaan::lavInspect(model.fit, what = "vcov"), symmetric = TRUE, only.values = TRUE)$values
# Correct for equality constraints
if (isTRUE(any(lavaan::parTable(model.fit)$op == "=="))) { eigvals <- rev(eigvals)[-seq_len(sum(lavaan::parTable(model.fit)$op == "=="))] }
if (isTRUE(min(eigvals) < .Machine$double.eps^(3L/4L))) {
warning(paste0("The variance-covariance matrix of the estimated parameters in the ", invar.low, " invariance model is not positive definite."), call. = FALSE)
check.vcov <- FALSE
}
#···················
#### Negative Variance of Observed Variables ####
if (isTRUE(!long)) {
cond.theta1 <- any(sapply(lavaan::lavInspect(model.fit, what = "theta"), diag) < 0)
cond.theta2 <- any(sapply(lavaan::lavTech(model.fit, what = "theta"), function(y) eigen(y, symmetric = TRUE, only.values = TRUE)$values) < (-1L * .Machine$double.eps^(3L/4L)))
} else {
cond.theta1 <- any(diag(lavaan::lavInspect(model.fit, what = "theta")) < 0L)
cond.theta2 <- any(eigen(lavaan::lavTech(model.fit, what = "theta")[[1L]], symmetric = TRUE, only.values = TRUE)$values < (-1L * .Machine$double.eps^(3L/4L)))
}
if (isTRUE(cond.theta1)) {
warning(paste0("Some estimated variances of the observed variables in the ", invar.low, " invariance model are negative."), call. = FALSE)
check.theta <- FALSE
} else if (isTRUE(cond.theta2)) {
warning(paste0("The model-implied variance-covariance matrix of the residuals of the observed variables in the ", invar.low, " invariance model is not positive definite."), call. = FALSE)
check.theta <- FALSE
}
#···················
#### Negative Variance of Latent Variables ####
if (isTRUE(!long)) {
cond.theta1 <- any(sapply(lavaan::lavTech(model.fit, what = "cov.lv"), diag) < 0L)
cond.theta1 <- any(sapply(lavaan::lavTech(model.fit, what = "cov.lv"), function(y) eigen(y, symmetric = TRUE, only.values = TRUE)$values) < (-1L * .Machine$double.eps^(3L/4L)))
} else {
cond.theta1 <- any(diag(lavaan::lavTech(model.fit, what = "cov.lv")[[1L]]) < 0L)
cond.theta2 <- any(eigen(lavaan::lavTech(model.fit, what = "cov.lv")[[1L]], symmetric = TRUE, only.values = TRUE)$values < (-1L * .Machine$double.eps^(3L/4L)))
}
if (isTRUE(cond.theta1)) {
warning(paste0("Some estimated variances of the latent variables in the ", invar.low, " invariance model are negative."), call. = FALSE)
check.cov.lv <- FALSE
# Model-implied variance-covariance matrix of the latent variables
} else if (isTRUE(cond.theta2)) {
warning("The model-implied variance-covariance matrix of the latent variables in the ", invar.low, " invariance model is not positive definite.", call. = FALSE)
check.cov.lv <- FALSE
}
}
# Return object
return(c(check.vcov = check.vcov, check.theta = check.theta, check.cov.lv = check.cov.lv))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Parameter Estimates ####
.model.fit.param <- function(model.param, long = long) {
group <- NULL
# Latent variables
print.latent <- model.param[which(model.param$op == "=~"), ]
# Latent variable covariances
print.lv.cov <- model.param[which(model.param$op == "~~" & (model.param$lhs != model.param$rhs) & (model.param$lhs %in% print.latent$lhs) & (model.param$rhs %in% print.latent$lhs)), ]
# Residual covariances
print.res.cov <- model.param[which(model.param$op == "~~" & (model.param$lhs != model.param$rhs) & (!model.param$lhs %in% print.latent$lhs) & (!model.param$rhs %in% print.latent$lhs)), ]
# Latent mean
print.mean <- model.param[which(model.param$op == "~1" & model.param$lhs %in% print.latent$lhs), ]
# Latent variance
print.var <- model.param[which(model.param$op == "~~" & (model.param$lhs %in% print.latent$lhs) & (model.param$lhs == model.param$rhs)), ]
# Intercepts
print.interc <- model.param[which(model.param$op == "~1" & !model.param$lhs %in% print.latent$lhs), ]
# Thresholds
print.thres <- model.param[which(model.param$op == "|"), ]
# Scales
print.scale <- model.param[which(model.param$op == "~*~"), ]
# Residual variance
print.resid <- model.param[which(model.param$op == "~~" & (model.param$lhs == model.param$rhs) & (!model.param$lhs %in% print.latent$lhs) & (!model.param$rhs %in% print.latent$lhs)), ]
# Model parameters
model.param <- rbind(data.frame(param = "latent variable", print.latent),
if (nrow(print.lv.cov) > 0L) { data.frame(param = "latent variable covariance", print.lv.cov) } else { NULL },
if (nrow(print.res.cov) > 0L) { data.frame(param = "residual covariance", print.res.cov) } else { NULL },
if (nrow(print.mean) > 0L) { data.frame(param = "latent mean", print.mean) } else { NULL },
if (nrow(print.var) > 0L) { data.frame(param = "latent variance", print.var) } else { NULL },
if (nrow(print.interc) > 0L) { data.frame(param = "intercept", print.interc) } else { NULL },
if (nrow(print.thres) > 0L) { data.frame(param = "threshold", print.thres) } else { NULL },
if (nrow(print.scale) > 0L) { data.frame(param = "scale", print.scale) } else { NULL },
if (nrow(print.resid) > 0L) { data.frame(param = "residual variance", print.resid) } else { NULL })
#—————————————————————————————————————— #
### Add Label ####
# Latent mean, intercept, and threshold
model.param[model.param$param %in% c("latent mean", "intercept"), "rhs"] <- model.param[model.param$param %in% c("latent mean", "intercept"), "lhs"]
if (isTRUE(any(model.param$param == "threshold"))) {
model.param[model.param$param == "threshold", "rhs"] <- apply(model.param[model.param$param == "threshold", c("lhs", "rhs")], 1L, paste, collapse = "|")
}
#—————————————————————————————————————— #
### Latent Variables ####
#···················
#### Between-Group Measurement Invariance ####
if (isTRUE(!long)) {
print.lv <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable"), "lhs"])) {
# Loop across groups
for (j in unique(model.param$group)) {
print.lv <- rbind(print.lv,
data.frame(param = "latent variable", group = j, lhs = i, op = "", rhs = paste(i, "=~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable" & model.param$lhs == i & model.param$group == j), ])
}
}
#···················
#### Longitudinal Measurement Invariance ####
} else {
print.lv <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable"), "lhs"])) {
print.lv <- rbind(print.lv,
data.frame(param = "latent variable", lhs = i, op = "", rhs = paste(i, "=~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable" & model.param$lhs == i), ])
}
}
#—————————————————————————————————————— #
### Latent Variable Covariances ####
#···················
#### Between-Group Measurement Invariance ####
if (isTRUE(!long)) {
print.lv.cov <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable covariance"), "lhs"])) {
# Loop across groups
for (j in unique(model.param$group)) {
print.lv.cov <- rbind(print.lv.cov,
data.frame(param = "latent variable covariance", group = j, lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable covariance" & model.param$lhs == i & model.param$group == j), ])
}
}
#···················
#### Longitudinal Measurement Invariance ####
} else {
print.lv.cov <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable covariance"), "lhs"])) {
print.lv.cov <- rbind(print.lv.cov,
data.frame(param = "latent variable covariance", lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable covariance" & model.param$lhs == i), ])
}
}
#—————————————————————————————————————— #
### Residual Covariances ####
#···················
#### Between-Group Measurement Invariance ####
if (isTRUE(!long)) {
print.res.cov <- NULL
for (i in unique(model.param[which(model.param$param == "residual covariance"), "lhs"])) {
# Loop across groups
for (j in unique(model.param$group)) {
print.res.cov <- rbind(print.res.cov,
data.frame(param = "residual covariance", group = j, lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "residual covariance" & model.param$lhs == i & model.param$group == j), ])
}
}
#···················
#### Longitudinal Measurement Invariance ####
} else {
print.res.cov <- NULL
for (i in unique(model.param[which(model.param$param == "residual covariance"), "lhs"])) {
print.res.cov <- rbind(print.res.cov,
data.frame(param = "residual covariance", lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "residual covariance" & model.param$lhs == i), ])
}
}
#—————————————————————————————————————— #
### Merge Parameter Tables ####
model.param <- data.frame(rbind(print.lv, print.lv.cov, print.res.cov,
model.param[which(!model.param$param %in% c("latent variable", "latent variable covariance", "residual covariance")), ]), row.names = NULL)
# Sort by group
if (isTRUE(!long)) { model.param <- data.frame(misty::df.sort(model.param, group), row.names = NULL) }
#—————————————————————————————————————— #
### Labels in Parentheses ####
model.param$label <- sapply(model.param$label, function(y) ifelse(y != "", paste0("(", y, ")"), y))
#—————————————————————————————————————— #
### Return Object ####
return(model.param)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.distract() function --------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Attractor-Distractor-Total Correlation ####
.adt.cor <- function(x, y, method, ml = FALSE) {
#—————————————————————————————————————— #
### Point-Biserial Correlation ####
switch(method, "pbiser" = {
xy.cor <- suppressWarnings(cor(x, y, use = "complete.obs"))
#—————————————————————————————————————— #
### Biserial Correlation ####
}, "biser" = {
xy.cor <- suppressWarnings(.cor.polyserial(x, y, se = FALSE, ml = ml))
})
return(xy.cor)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.stats() function -----------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Item-Total Correlation with Confidence Intervals ####
.it.cor <- function(x, y, method, alternative = "two.sided", conf.level = 0.95) {
#—————————————————————————————————————— #
### Point-Biserial Correlation ####
switch(method, "pbiser" = {
# Point-biserial correlation
misty::descript(y, group = x, output = FALSE)$result |>
(\(p) {
# Sample size for each group
n1 <- p$n[2L]
n2 <- p$n[1L]
# Total sample size
n <- n1 + n2
# Proportion of members in category 1
pi <- n1 / n
# Degrees of freedom
df1 <- n1 - 1L
df2 <- n2 - 1L
# Quantile of the standard normal distribution
z <- qnorm(switch(alternative, two.sided = 1L - (1L - conf.level) / 2L, less = conf.level, greater = conf.level))
# Bonnett (2020) Formula (4)
d <- (p$m[2L] - p$m[1L]) / sqrt((df1*p$var[2L] + df2*p$var[1L]) / (df1 + df2))
# Bonnett (2020) Formula (21)
se <- sqrt((d^2L*(1L / df1 + 1L / df2) / 8L) + 1L / n1 + 1L / n2)
# Formula (25)
low.d <- d - z*se
upp.d <- d + z*se
b <- (n - 2L) / (n*pi*(1L - pi))
# Confidence interval, Bonnett (2020) Formula (26)
ci <- switch(alternative,
two.sided = c(low = low.d / sqrt(low.d^2L + b), upp = upp.d / sqrt(upp.d^2L + b)),
less = c(low = -Inf, upp = upp.d / sqrt(upp.d^2L + b)),
greater = c(low = low.d / sqrt(low.d^2L + b), upp = Inf))
return(c(r = d / sqrt(d^2 + b), ci))
})()
#—————————————————————————————————————— #
### Biserial Correlation ####
}, "biser" = {
# Compute biserial correlation coefficient and standard error
r.se <- .cor.polyserial(x, y)
# Quantile of the standard normal distribution
z <- qnorm(switch(alternative, two.sided = 1L - (1L - conf.level) / 2L, less = conf.level, greater = conf.level))
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
less = c(low = -Inf, upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
greater = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = Inf))
return(c(r = unname(r.se["cor"]), ci))
#—————————————————————————————————————— #
### Polyserial Correlation ####
}, "polyser" = {
# Compute polyserial correlation coefficient and standard error
r.se <- .cor.polyserial(x, y)
# Quantile of the standard normal distribution
z <- qnorm(switch(alternative, two.sided = 1L - (1L - conf.level) / 2L, less = conf.level, greater = conf.level))
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
less = c(low = -Inf, upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
greater = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = Inf))
return(c(r = unname(r.se["cor"]), ci))
})
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Polyserial Correlation Coefficient with SE ####
#
# Function polyserial() from the polycor package
.cor.polyserial <- function(x, y, ml = TRUE, se = TRUE) {
#—————————————————————————————————————— #
### Function ####
f <- function(pars) {
rho <- pars[1L]
cts <- if (isTRUE(length(pars) == 1L)) {
c(-Inf, cuts, Inf)
} else {
c(-Inf, pars[-1L], Inf)
}
if (isTRUE(any(diff(cts) < 0L))) { return(Inf) }
tau <- (matrix(cts, n, s + 1L, byrow = TRUE) - matrix(rho * z, n, s + 1L)) / sqrt(1L - rho^2)
return(-sum(log(dnorm(z) * (pnorm(tau[cbind(indices, y + 1L)]) - pnorm(tau[cbind(indices, y)])))))
}
#—————————————————————————————————————— #
valid <- complete.cases(x, y)
x <- x[valid]
y <- y[valid]
z <- scale(x)
tab <- table(y)
n <- sum(tab)
s <- length(tab)
indices <- seq_len(n)
cuts <- qnorm(cumsum(tab) / n)[-length(tab)]
y <- as.numeric(as.factor(y))
rho <- sqrt((n - 1L) / n) * sd(y) * cor(x, y) / sum(dnorm(cuts))
#—————————————————————————————————————— #
### Maximum-Likelihood Estimate ####
if (isTRUE(ml)) {
#···················
#### With Standard Error ####
if (isTRUE(se)) {
tryCatch(optim(c(rho, cuts), f, hessian = TRUE) |> (\(p) c(cor = p$par[1L], se = sqrt(diag(solve(p$hessian)))[1L]))(),
error = function(y) {
return(cor = NA, se = NA)
})
#···················
#### Without Standard Error ####
} else {
tryCatch(c(cor = optim(c(rho, cuts), f, hessian = FALSE)$par[1L]),
error = function(y) {
return(cor = NA)
})
}
#—————————————————————————————————————— #
### Two-Step Approximation ####
} else {
return(rho)
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the modcomp() function --------------------------------
#
# .caic
# .sabic
#
# https://github.com/cran/semTools/blob/master/R/fitIndices.R
#
# .aicc
# .hqc
# .hbic
# .spbic
# .ibic
# .sic
# .icomp
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Consistent Akaike's Information Criterion ####
.caic <- function(x) {
caic <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(BIC(x) + unname(lavaan::fitmeasures(x)["npar"]), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(BIC(x) + attr(logLik(x), which = "df"), error = function(e) { return(NA) }))
}
return(caic)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Sample-Size Adjusted BIC ####
.sabic <- function(x) {
sabic <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(unname(lavaan::fitmeasures(x) |> (\(p) -2L*p["logl"] + p["npar"] * log((lavaan::nobs(x) + 2L) / 24L))()), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(as.numeric(-2L*logLik(x) + attr(logLik(x), which = "df") * log((nobs(x) + 2L) / 24L)), error = function(e) { return(NA) }))
}
return(sabic)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Corrected Akaike Information Criterion ####
.aicc <- function(x) {
aicc <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(unname(lavaan::fitmeasures(x)["npar"]) |> (\(p) AIC(x) + (2L * p * (p + 1L)) / (lavaan::nobs(x) - p - 1L))(), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(attr(lavaan::logLik(x), which = "df") |> (\(p) AIC(x) + (2L * p * (p + 1L)) / (nobs(x) - p - 1L))(), error = function(e) { return(NA) }))
}
return(unname(aicc))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Hannan-Quinn Information Criterion ####
.hqc <- function(x) {
hqc <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(lavaan::fitmeasures(x) |> (\(p) unname(-2L*p["logl"] + 2L*p["npar"]*log(log(lavaan::nobs(x)))))(), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(unname(-2L*as.numeric(logLik(x)) + 2L*attr(logLik(x), which = "df")*log(log(nobs(x)))), error = function(e) { return(NA) }))
}
return(unname(hqc))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Haughton’s BIC ####
.hbic <- function(x) {
hbic <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(lavaan::fitmeasures(x) |> (\(p) unname(-2L*p["logl"] + p["npar"]*log(lavaan::nobs(x) / (2L * pi))))(), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(-2L*as.numeric(logLik(x)) + attr(logLik(x), which = "df") * log(nobs(x) / (2L * pi)), error = function(e) { return(NA) }))
}
return(unname(hbic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Scaled Unit-Information Prior BIC ####
.spbic <- function(x) {
spbic <- suppressWarnings(tryCatch({
lavaan::coef(x) |> (\(p) t(p) %*% lavaan::lavInspect(x, "information.observed") %*% p)() |>
(\(q) if (lavaan::fitmeasures(x)["npar"] < q) {
return(as.vector(-2L*lavaan::fitmeasures(x)["logl"] + lavaan::fitmeasures(x)["npar"]*(1L - log(lavaan::fitmeasures(x)["npar"] / q))))
} else {
return(as.vector(-2L*lavaan::fitmeasures(x)["logl"] + q))
})()
}, error = function(e) { return(NA) })) |> (\(p) if (is.nan(p)) { return(NA) } else { return(p) } )()
return(unname(spbic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Information-Matrix-based BIC ####
.ibic <- function(x) {
ibic <- suppressWarnings(tryCatch({
det(lavaan::lavInspect(x, what = "vcov")) |> (\(p) if (isTRUE(p <= 0L)) {
return(NA)
} else {
return(-2L*lavaan::fitmeasures(x)["logl"] - lavaan::fitmeasures(x)["npar"]*log(2L*pi) - log(p))
})()
}, error = function(e) { return(NA) })) |> (\(p) if (isTRUE(is.nan(p))) { return(NA) } else { return(p) } )()
return(unname(ibic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Stochastic Information Criterion ####
.sic <- function(x) {
sic <- suppressWarnings(tryCatch({
det(lavaan::lavInspect(x, what = "vcov")) |> (\(p) if (isTRUE(p <= 0L)) {
return(NA)
} else {
return(-2L*lavaan::fitmeasures(x)["logl"] - log(p))
})()
}, error = function(e) { return(NA) })) |> (\(p) if (isTRUE(is.nan(p))) { return(NA) } else { return(p) } )()
return(unname(sic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bozdogan Information Complexity ####
.icomp <- function(x) {
icomp <- suppressWarnings(tryCatch({
suppressWarnings(unname(lavaan::lavInspect(x, "inverted.information.expected") |> (\(p) -2L*lavaan::fitmeasures(x)["logl"] + 2L*qr(p)$rank |> (\(q) (q / 2L)*log((sum(diag(p))) / q) - 0.5*log(det(p)))())()))
}, error = function(e) { return(NA) })) |> (\(p) if (isTRUE(is.nan(p))) { return(NA) } else { return(p) } )()
return(icomp)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.cfa() and multilevel.cfa function ------------
#
# https://github.com/dmcneish18/opdyke/tree/main/R
#
# .opdyke.percentiles
# .opdyke
# .r2polar
# .polar2r
# .csc
# .cot
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Calculating the Opdyke Percentile ####
# S = observed correlation matrix, P = predicted correlation matrix
.opdyke.percentiles <- function(S, P, prec = 1) {
# Matrix of percentiles
W <- matrix(NA, nrow = nrow(S), ncol = ncol(S), dimnames = list(colnames(S), colnames(S)))
# Opdyke distribution PDF
W[lower.tri(W)] <- .opdyke(S, prec = prec) |> (\(p) do.call("rbind", lapply(seq_along(p), function(k) p[[k]][which.min(abs(p[[k]]$r - P[p[[k]]$row, p[[k]]$column])), ])) |> (\(q) q[order(q$column, q$row), ]$cdf_exact |> (\(r) ifelse(is.nan(r), NA, r))() )())()
W[upper.tri(W)] <- t(W)[upper.tri(W)]
return(W)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Calculating tge Opdyke Distribution PDF ####
.opdyke <- function(A, prec) {
I <- seq_len(ncol(A))
I5 <- matrix(0L, ncol = length(I), nrow = 1L)
sapply(seq_len((length(I) - 1L)), function(r2) {
sapply(0L:(r2 - 1L), function(r1) {
I5 <<- rbind(I5, c(I[-c((length(I) - r2), length(I) - r1)], (length(I) - r2), length(I) - r1))
})
})
com3 <- matrix(I5[-1L, ], ncol = ncol(I5), dimnames = list(NULL, colnames(A)))
pdf <- list()
sapply(seq_len(nrow(com3)), function(c) {
X <- .r2polar(A[com3[c, ], com3[c, ]])
k <- ncol(X) - 1L
theta <- X[ncol(X), k]
ck <- gamma((0.5*k + 1L)) / (sqrt(pi)*gamma(0.5*k + 0.5))
d <- data.frame(matrix(NA, nrow = 314L*prec, ncol = 4L, dimnames = list(NULL, c("r", "cdf_exact", "row", "column"))))
cot.theta <- .cot(theta)
sapply(seq_len(314L*prec), function(r) {
z <- r / (100L*prec)
X2 <- X
X2[ncol(X), k] <- z
cot.z <- .cot(z)
d[r, 1L] <<- .polar2r(X2)[ncol(X), k]
d[r, 2L] <<- 1L - (0.5 + ck*(cot.theta - cot.z)*gsl::hyperg_2F1(a = 0.5, b = (1L + 0.5*k), c = 1.5, x = -1L*(cot.z - cot.theta)^2L))
})
d[, 3L] <- com3[c, ncol(com3)]
d[, 4L] <- com3[c, ncol(com3) - 1L]
pdf[[c]] <<- d
})
return(pdf)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Convert Correlation Matrix to Polar Angles ####
.r2polar<-function(S) {
A3 <- t(chol(S))
A4 <- matrix(0L, nrow = nrow(A3), ncol = ncol(A3))
A4[1L, 1L] <- 1L
for (i in 2L:ncol(A3)) {
A4[i, 1] <- acos(A3[i, 1])
for (j in 2L:ncol(A3)) {
if (isTRUE(j < i)) {
A4[i, j] <- acos(A3[i, j] / cumprod(sin(A4[i, ]))[j - 1L])
}
}
}
return(A4)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Convert Polar Angles to a Correlation Matrix ####
.polar2r <- function(polar) {
A5 <- matrix(0L, nrow = nrow(polar), ncol = ncol(polar))
A5[1L, 1L] <- 1L
for (i in 2L:ncol(A5)) {
A5[i, 1L] <- cos(polar[i, 1L])
p <- cumprod(sin(polar[i, ]))
A5[i, i] <- p[i - 1L]
for(j in 2L:ncol(A5)) {
if (isTRUE(j < i)) {
A5[i, j] <- cos(polar[i, j])*p[j - 1L]
}
}
}
return(A5%*%t(A5))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Inverse of sin and tan ####
.csc <- function(x) { 1L / sin(x) }
.cot <- function(x) { 1L / tan(x) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.dfi() function -------------------------------
#
# https://github.com/melissagwolf/dynamic/tree/master/R
# - .sim.fit
# - .n.factors
# - .misspec.one
# - .items.no.cor
# - .resid.cov
# - .misspec.multi
# - .cross.load
# - .items.n.crossload
# - .sim.data.likert
# - .ordsample
# - .ordsample
# - .contord
# - .sim.data.categ
# - .sim.fit
#
# https://stackoverflow.com/questions/19796736/changing-numbers-within-string-in-r
# - .chr.round
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Determine the Number of Factors ####
.n.factors <- function(model.syntax) {
return(lavaan::lavaanify(model.syntax, fixed.x = FALSE) |> (\(p) misty::uniq.n(p[p$op == "=~", "lhs"]))())
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Simulating Fit Indices for Misspecified and True Models in One-Factor CFA Model ####
#
# # Function DGM_one() in the dynamic package
.misspec.one <- function(model.syntax, res.cor) {
# Number of items without residual correlation
n.items <- nrow(.items.no.cor(model.syntax))
# Number of levels given number of items without residual correlation
if (isTRUE(n.items == 4L)) {
levels <- 1L
} else if (isTRUE(n.items == 5L)) {
levels <- rbind(1L, 2L)
} else {
levels <- floor(n.items / 2L) |> (\(p) rbind(floor(p / 3L), floor((2L*p) / 3L), as.numeric(p)))()
}
# Residual covariance misspecification
mod.resid.cov <- .resid.cov(model.syntax, res.cor)
# Model misspecification
mod.syntax.misspec <- setNames(lapply(levels, function(y) paste0(model.syntax, "\n", paste(mod.resid.cov[seq_len(y)], collapse = "\n"))), nm = paste0("Level ", levels))
return(mod.syntax.misspec)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Extracting Items Without Residual Correlations in One-Factor CFA Model ####
#
# Function one_num() in the dynamic package
.items.no.cor <- function(model.syntax){
# lavaan parameter table
model.lavaan <- lavaan::lavaanify(model.syntax, fixed.x = FALSE) |> (\(p) p[which(p$lhs != p$rhs), ])()
# Factor loadings
model.lavaan.load <- model.lavaan |> (\(p) p[which(p$op == "=~"), ] )()
model.lavaan.load <- model.lavaan |> (\(s) s[which(s$op == "=~"), ] )()
# Factor labels
factor.labels <- model.lavaan |> (\(p) unique(p[which(p$op == "=~"), "lhs"]))()
# Items without residual correlation
items.result <- model.lavaan |> (\(p) p[which(p$op == "~~"), ])() |>
(\(q) setdiff(unique(c(q$lhs, q$rhs)), factor.labels))() |>
(\(r) model.lavaan.load[which(!model.lavaan.load$rhs %in% r), ])()
return(items.result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Creating Residual Correlation Misspecification in One-Factor CFA Model ####
#
# Function one_add() in the dynamic package
.resid.cov <- function(model.syntax, res.cor){
# Items without residual correlation
items <- .items.no.cor(model.syntax) |> (\(p) p[order(p$ustart), ])()
# Number of items without residual correlation
n.items <- nrow(items)
# Select items for misspecification
if (isTRUE(n.items == 4L)) {
items.m <- items[1L:2L, ]
} else if (isTRUE(n.items == 5L)) {
items.m <- items[1L:4L, ]
} else {
items.m <- items[seq_len(floor(n.items / 2L)*2L), ]
}
# Residual correlation
resid.cor <- paste0(items.m[seq(1L, nrow(items.m), by = 2), "rhs"] , " ~~ ", res.cor, "*", items.m[seq(2L, nrow(items.m), by = 2), "rhs"])
return(resid.cor)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Simulating Fit Indices for Misspecified and True Models in Multi-Factor CFA Model ####
#
# Function DGM_Multi_HB() in the dynamic package
.misspec.multi <- function(model.syntax) {
# Cross loading misspecification
mod.cross.load <- .cross.load(model.syntax)
# Model misspecification
mod.syntax.misspec <- setNames(lapply(seq_len(length(mod.cross.load)), function(y) paste0(model.syntax, "\n", paste(mod.cross.load[seq_len(y)], collapse = "\n"))), nm = paste0("Level ", seq_len(length(mod.cross.load))))
return(mod.syntax.misspec)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Creating Cross-Loading Misspecification in Multi-Factor CFA Model ####
#
# Function multi_add_HB() in the dynamic package
.cross.load <- function(model.syntax) {
priority <- loading <- NULL
# lavaan model syntax
model.lavaan <- lavaan::lavaanify(model.syntax, fixed.x = FALSE) |>(\(p) p[p$lhs != p$rhs, ])()
# Number of factors
n.fact <- .n.factors(model.syntax)
# Viable items from each factor
itemoptions <- .items.n.crossload(model.syntax)
# Lowest loading from each factor
crosses <- do.call("rbind", lapply(split(itemoptions, itemoptions$lhs), function(y) y[which.min(abs(y$loading)), ])) |> (\(p) p[order(abs(p$loading)), ])() |> (\(q) q[seq_len(n.fact - 1L), ])()
# Factor names
factors <- data.frame(lhs = unique(model.lavaan[model.lavaan$op == "=~", "lhs"]))
# Coefficient H for each factor
coef.H <- suppressMessages(model.lavaan[model.lavaan$op == "=~", ] |> (\(p) data.frame(p, L_Sq = p$ustart^2L, E_Var = 1L - (p$ustart^2L), Div = (p$ustart^2L) / (1L - (p$ustart^2L))))() |>
(\(q) do.call("rbind", lapply(split(q, f = q$lhs), function(y) data.frame(sum = sum(y$Div), rand = runif(n = length(factors), 0L, 0.001)) |> (\(r) data.frame(H = ((1 + (r$sum^-1L))^-1L) + r$rand ))())))() |>
(\(s) data.frame(rhs = row.names(s), s, row.names = NULL))() |> (\(t) t[order(t$H, decreasing = TRUE), ])())
# Factors and factor correlations
fact.cor1 <- model.lavaan[model.lavaan$op == "~~", ] |> (\(p) data.frame(p[p$lhs %in% unlist(factors) & p$rhs %in% unlist(factors), c("lhs", "op", "rhs", "ustart")], type = "Factor"))()
# Factors and factor correlations reversed
fact.cor2 <- setNames(fact.cor1, nm = c("rhs", "op", "lhs", "ustart", "type"))[, c("lhs", "op", "rhs", "ustart", "type")]
# Isolate items
dup1 <- merge(merge(rbind(fact.cor1, fact.cor2), crosses, by = "lhs", all = TRUE), coef.H, by = "rhs")[, c("lhs", "op", "rhs", "ustart", "type", "item", "loading", "priority", "H")] |>
(\(p) p[which(!is.na(p$item)), ])() |>(\(q) q[order(abs(q$loading)), ])()
# Run twice for cleaning later
dup2 <- dup1
# Manipulate to create model statement
setup <- misty::df.unique(rbind(dup1, dup2) |> (\(p) data.frame(p, facts = paste(pmin(p$lhs, p$rhs), pmax(p$lhs, p$rhs), sep = "_")))())
# Rename for iteration
setup.copy <- setup
# Create empty data frame
cleaned <- setup[0L, ]
# Select the highest H for first item i for cross-loading
for (i in unique(setup.copy$item)){
cleaned[i, ] <- setup.copy[setup.copy$item == i, ] |> (\(p) p[which.max(p$H), ])()
setup.copy <- setup.copy[which(!setup.copy$facts %in%cleaned$facts), ]
}
# Data frame
modinfo <- data.frame(cleaned, operator = "=~") |> (\(p) misty::df.sort(p, priority, loading) |> (\(q) do.call("rbind", lapply(split(q, f = paste0(q$priority, q$loading)), function(y) y[order(y$H, decreasing = TRUE), ])))()) ()
# Compute maximum cross loading value
cross.loading <- data.frame(modinfo, F1 = modinfo$ustart, F1.sq = modinfo$ustart^2L, L1 = modinfo$loading, L1.sq = modinfo$loading^2, E = 1L - modinfo$loading^2L) |>
(\(p) data.frame(modinfo, loading.final = pmin(abs(p$loading), abs(round((sqrt(((p$L1.sq * p$F1.sq) + p$E)) - (abs(p$L1 * p$F1)))*0.95, digits = 4))), times = "*" )[, c("rhs", "operator", "loading.final", "times", "item")])() |>
(\(q) unname(apply(q, 1L, function(y) paste0(paste(y["rhs"], y["operator"], y["loading.final"], collapse = " "), y["times"], y["item"], collapse = ""))))()
return(cross.loading)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Extracting Items Without Residual Correlations and Cross Loadings in Multi-Factor CFA Model ####
#
# Function multi_num_HB() in the dynamic package
.items.n.crossload <- function(model.syntax){
# lavaan model syntax
model.lavaan <- lavaan::lavaanify(model.syntax, fixed.x = FALSE) |>(\(p) p[p$lhs != p$rhs, ])()
# Factor names
factors <- unique(model.lavaan[model.lavaan$op == "=~", "lhs"])
# Number of items per factor
n.items <- model.lavaan[model.lavaan$op == "=~", ] |> (\(p) sapply(split(p, f = p$lhs), nrow))() |> (\(q) data.frame(lhs = names(q), original = q))()
# Items that have an error covariance
item.covar <- intersect(model.lavaan[model.lavaan$op == "=~", "rhs"], unlist(model.lavaan[model.lavaan$op == "~~", c("lhs", "rhs")]))
# Items that have a cross loading
item.crossload <- model.lavaan[model.lavaan$op == "=~", ] |> (\(p) p[duplicated(p$rhs), "rhs"])()
# Items that do not already have an error covariance or cross-loading
solo.items <- model.lavaan[model.lavaan$op == "=~" & !model.lavaan$rhs %in% union(item.covar, item.crossload), ]
# Number of remaining and original items per factor
remaining <- merge(if (isTRUE(nrow(solo.items) != 0L)) { solo.items |> (\(p) sapply(split(p, f = p$lhs), nrow))() |> (\(q) data.frame(lhs = names(q), remaining = q))() } else { data.frame(lhs = factors, remaining = 0L) }, n.items, by = "lhs", all = TRUE)
# Add factor loadings, group by number of items per factor (>2 or 2), sort factor loadings within group
itemoptions <- merge(solo.items, remaining, by = "lhs", all = TRUE) |>
(\(p) data.frame(p, priority = ifelse(p$original > 2 & !is.na(p$remaining), "three", "two")))() |>
(\(q) data.frame(setNames(do.call("rbind", lapply(split(q, q$priority), function(y) y[order(abs(y$ustart)), ]))[, c("lhs", "rhs", "ustart", "priority")], nm = c("lhs","item","loading","priority")), row.names = NULL))()
return(itemoptions)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Converting Continuous Data into Likert-Type Item Data ####
#
# Function true_fit_one_likert() and one_fit_likert() from the dynamic package
.sim.data.likert <- function(model.syntax, data, n = n, nrep = nrep) {
# Number of factors
n.fac <- .n.factors(model.syntax)
# Model-implied covariance matrix
sigma <- .sim.standardized.matrices(model.syntax, max.iter = 100L, check = FALSE)$correlations$R |> (\(p) p[seq_len(nrow(p) - n.fac), seq_len(nrow(p) - n.fac)])()
diag(sigma) <- 1
# Remove cases with missing on all variables
data1 <- data[, colnames(sigma)] |> (\(p) p[rowSums(is.na(p)) != ncol(p), ])()
# Rescale so that minimum value is always 1
d2 <- matrix(sapply(data1, function(y) min(y, na.rm = TRUE) - 1L), nrow = 1L, ncol = ncol(data1))
d3 <- matrix(rep(d2, each = nrow(data1)), nrow = nrow(data1), ncol = ncol(data1), dimnames = list(NULL, colnames(data1)))
d4 <- matrix(rep(d2, each = nrow(data1)), nrow = nrep*nrow(data1), ncol = ncol(data1), dimnames = list(NULL, colnames(data1)))
data1 <- data1 - d3
# Create empty matrix for proportions in each category (g)
g <- matrix(nrow = (max(data1, na.rm = TRUE) - min(data1, na.rm = TRUE)), ncol = ncol(data1))
p <- list()
# Loop through all variables in the fitted model
for (i in seq_len(ncol(data1))) {
# Loop through all categories for each variable
for (h in min(data1[, i], na.rm = TRUE):(max(data1[, i], na.rm = TRUE) - 1L)) {
# Proportion of responses at or below each category, only count non-missing in the denominator
g[h, i] <- sum(table(data1[, i])[names(table(data1[, i])) <= h]) / sum(!is.na(data1[, i]))
p[[i]] <- g[, i]
}
}
# Handle different number of categories per item
marginal <- list()
for (i in seq_len(length(p))) {
marginal[[i]] <- p[[i]][!is.na(p[[i]])]
}
# Simulate ordinal data with same observed correlation matrix as observed data
return(setNames(as.data.frame(.ordsample(n = n*nrep, marginal = marginal, Sigma = sigma) + d4), nm = colnames(d4)))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Drawing a Sample of Discrete Data ####
#
# Function ordsample() from the GenOrd package
.ordsample <- function(n, marginal, Sigma, support = list(), df = Inf) {
# k = number of variables
k <- length(marginal)
# kj = number of categories for the k variables (vector of k integer numbers)
kj <- numeric(k)
len <- length(support)
for (i in seq_len(k)) {
kj[i] <- length(marginal[[i]]) + 1L
if (isTRUE(len == 0L)) { support[[i]] <- seq_len(kj[i]) }
}
Sigma <- .ordcont(marginal = marginal, Sigma = Sigma, support = support, df = df)[[1L]]
# Sample of size n from k-dimensional Student's t or normal with vector of zero means and correlation matrix Sigma
restab <- mvtnorm::rmvt(n, sigma = Sigma, delta = rep(0L, k), df = df, type = "shifted")
if (isTRUE(n == 1L)) { restab <- matrix(restab, nrow = 1L) }
# Discretization according to the marginal distributions
for(i in seq_len(k)) {
restab[,i] <- as.integer(cut(restab[, i], breaks = c(min(restab[, i]) - 1L, qt(marginal[[i]], df = df), max(restab[, i]) + 1L)))
restab[,i] <- support[[i]][restab[, i]]
}
return(restab)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing the "intermediate" Correlation mMtrix for the Multivariate Standard Normal ####
#
# Function ordcont() from the GenOrd package
.ordcont <- function (marginal, Sigma, support = list(), epsilon = 1e-06, maxit = 100, df = Inf) {
len <- length(support)
k <- length(marginal)
niter <- matrix(0L, k, k)
kj <- numeric(k)
for (i in seq_len(k)) {
kj[i] <- length(marginal[[i]]) + 1L
if (isTRUE(len == 0L)) {
support[[i]] <- seq_len(kj[i])
}
}
Sigmaold <- Sigma0 <- Sigma
Sigmaordold <- Sigmaord <- .contord(marginal, Sigma, support, df = df)
for (q in 1:(k - 1L)) {
for (r in (q + 1L):k) {
if (isTRUE(Sigma0[q, r] == 0L)) {
Sigma[q, r] <- 0L
} else {
it <- 0L
while (max(abs(Sigmaord[q, r] - Sigma0[q, r]) > epsilon) & it < maxit) {
if (Sigma0[q, r] * (Sigma0[q, r]/Sigmaordold[q, r]) >= 1L) {
Sigma[q, r] <- Sigmaold[q, r] * (1L + 0.1 * (1L - Sigmaold[q, r]) * sign(Sigma0[q, r] - Sigmaord[q, r]))
} else {
Sigma[q, r] <- Sigmaold[q, r] * (Sigma0[q, r] / Sigmaord[q, r])
}
Sigma[r, q] <- Sigma[q, r]
Sigmaord[r, q] <- .contord(list(marginal[[q]], marginal[[r]]), matrix(c(1L, Sigma[q, r],Sigma[q, r], 1L), 2L, 2L), list(support[[q]], support[[r]]), df = df)[2L]
Sigmaord[q, r] <- Sigmaord[r, q]
Sigmaold[q, r] <- Sigma[q, r]
Sigmaold[r, q] <- Sigmaold[q, r]
it <- it + 1L
}
niter[q, r] <- it
niter[r, q] <- it
}
}
}
if (eigen(Sigma)$values[k] <= 0) {
message("The Sigma matrix is not coherent with the given margins or
it is impossible to find a feasible correlation matrix for MVN
ensuring Sigma for the given margins")
Sigma <- matrix(NA, k, k)
diag(Sigma) <- 1L
}
emax <- max(abs(Sigmaord - Sigma0))
list(SigmaC = Sigma, SigmaO = Sigmaord, Sigma = Sigma0, niter = niter, maxerr = emax)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing the Correlations of Discretized Variables ####
#
# Function contord() from the GenOrd package
.contord <- function(marginal, Sigma, support = list(), df = Inf) {
len <- length(support)
k <- length(marginal)
kj <- numeric(k)
Sigmaord <- diag(k)
for (i in seq_len(k)) {
kj[i] <- length(marginal[[i]]) + 1L
if (isTRUE(len == 0L)) {
support[[i]] <- 1L:kj[i]
}
}
L <- vector("list", k)
for (i in seq_len(k)) {
L[[i]] <- qt(marginal[[i]], df = df)
L[[i]] <- c(-Inf, L[[i]], +Inf)
}
for (q in seq_len(k - 1L)) {
for (r in (q + 1L):k) {
pij <- matrix(0, kj[q], kj[r])
for (i in seq_len(kj[q])) {
for (j in seq_len(kj[r])) {
low <- rep(-Inf, k)
upp <- rep(Inf, k)
low[q] <- L[[q]][i]
low[r] <- L[[r]][j]
upp[q] <- L[[q]][i + 1L]
upp[r] <- L[[r]][j + 1L]
pij[i, j] <- mvtnorm::pmvt(low, upp, rep(0L, k), corr = Sigma, df = df)
low <- rep(-Inf, k)
upp <- rep(Inf, k)
}
}
my <- sum(apply(pij, 2L, sum) * support[[r]])
sigmay <- sqrt(sum(apply(pij, 2L, sum) * support[[r]]^2L) - my^2L)
mx <- sum(apply(pij, 1L, sum) * support[[q]])
sigmax <- sqrt(sum(apply(pij, 1L, sum) * support[[q]]^2L) - mx^2L)
mij <- support[[q]] %*% t(support[[r]])
muij <- sum(mij * pij)
covxy <- muij - mx * my
corxy <- covxy / (sigmax * sigmay)
Sigmaord[q, r] <- corxy
}
}
SO <- as.matrix(Matrix::forceSymmetric(Sigmaord))
return(SO)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Converting Continuous Data into Categorical Item Data ####
#
# Function true_fit_one_cat() from the dynamic package
.sim.data.categ <- function(model.syntax, model.syntax.thres, n = n, nrep = nrep) {
# Simulate standardized data
all_data_true <- sim.data <- misty::sim.lavaan(model.syntax, n = n*nrep, std = TRUE)
# Thresholds
a2 <- as.data.frame(t(unique(model.syntax.thres[model.syntax.thres$op == "|", "lhs"])))
a1 <- setNames(reshape(model.syntax.thres, idvar = "rhs", timevar = "lhs", direction = "wide", drop = "op")[, -1L], nm = a2)
for (i in seq_len(ncol(a1))) {
u <- as.numeric(sum(!is.na(a1[, i])))
# Column name to modify
colname <- a2[, i]
# Original and current values
res <- x <- sim.data[[colname]]
# Piecewise updates
res[which(!is.na(x) & x <= a1[1, i])] <- 100L
res[which(!is.na(x) & x > a1[u, i])] <- 100L * (u + 1L)
# Write back to data frame
sim.data[[colname]] <- res
if (isTRUE(sum(!is.na(a1[, i])) > 1L)) {
for (j in seq_len(sum(!is.na(a1[, i])))) {
colname <- a2[, i]
x <- sim.data[[colname]]
x[!is.na(x) & x >= a1[j, i] & x <= a1[j + 1L, i]] <- as.numeric(100L * (j + 1L))
sim.data[[colname]] <- x
}
}
}
#sim.data <- sim.data / 100
return(sim.data)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Simulating Fit Indices for Misspecified and True Models ####
#
# Function one_fit() from the dynamic package
.sim.fit <- function(model.syntax, model.syntax.thres, sim.model = sim.model, type, data, n, estimator, se, sim.fit.indices, nrep, seed = seed, progress) {
# Model without Parameter Estimates
model.syntax.free <- .fixed2free(model.syntax)
#—————————————————————————————————————— #
### Simulate Data ####
#...................
#### Normal Continuous Indicators ####
switch(type, "norm" = {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = split(misty::sim.lavaan(sim.model[[1L]], n = n*nrep, std = TRUE), f = rep(seq_len(nrep), times = n)))
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[2L]) }
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) misty::sim.lavaan(y, n = n*nrep, std = TRUE)) |> (\(p) lapply(p, function(z) split(z, f = rep(seq_len(nrep), times = n))))()
# Append lists
sim.data <- append(sim.data0, sim.data1)
#...................
#### Non-Normal Continuous Indicators ####
}, "nnorm" = {
# Number of factors
n.fac <- .n.factors(model.syntax)
# Model-implied covariance matrix
sigma <- .sim.standardized.matrices(sim.model[[1L]], max.iter = 100L, check = FALSE)$correlations$R |> (\(p) p[seq_len(nrow(p) - n.fac), seq_len(nrow(p) - n.fac)])() |> (\(q) q[order(rownames(q)), order(rownames(q))])()
# Remove cases with missing on all variables
data1 <- data[, colnames(sigma)] |> (\(p) p[rowSums(is.na(p)) != ncol(p), ])()
# Model-implied mean vector
mu <- colMeans(data1, na.rm = TRUE)
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = misty::boot.bs(sigma = sigma, mu = mu, data = data1, R = nrep, return = "bootsamp"))
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) misty::boot.bs(sigma = .sim.standardized.matrices(y, max.iter = 100L, check = FALSE)$correlations$R |> (\(p) p[seq_len(nrow(p) - n.fac), seq_len(nrow(p) - n.fac)])() |> (\(q) q[order(rownames(q)), order(rownames(q))])(), mu = mu, data = data1, R = nrep, return = "bootsamp", seed = seed[2]))
# Append lists
sim.data <- append(sim.data0, sim.data1)
#...................
#### Likert-Type Indicators ####
}, "likert" = {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = split(.sim.data.likert(sim.model[[1L]], data = data, n = n, nrep = nrep), f = rep(seq_len(nrep), times = n)))
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[2L]) }
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) .sim.data.likert(y, data = data, n = n, nrep = nrep)) |> (\(p) lapply(p, function(z) split(z, f = rep(seq_len(nrep), times = n))))()
# Append lists
sim.data <- append(sim.data0, sim.data1)
#...................
#### Categorical Indicators ####
}, "categ" = {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = split(.sim.data.categ(sim.model[[1L]], model.syntax.thres = model.syntax.thres, n = n, nrep = nrep), f = rep(seq_len(nrep), times = n)))
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[2L]) }
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) .sim.data.categ(y, model.syntax.thres = model.syntax.thres, n = n, nrep = nrep)) |> (\(p) lapply(p, function(z) split(z, f = rep(seq_len(nrep), times = n))))()
# Append lists
sim.data <- append(sim.data0, sim.data1)
})
#—————————————————————————————————————— #
### Estimate Models ####
#···················
#### With Progress Bar ####
fit.result <- vector(mode = "list", length = length(sim.data))
if (isTRUE(progress)) {
for (i in seq_along(sim.data)) {
message(paste0(" Simulating Misspecification ", names(sim.data)[i]))
# Open progress bar
progress.bar <- txtProgressBar(min = 1L, max = nrep, initial = 1L, char = "=", width = getOption("width") - 13L, style = 3, file = "")
for (j in seq_len(nrep)) {
fit.result[[i]][[j]] <- tryCatch(suppressWarnings(lavaan::fitmeasures(lavaan::cfa(model = model.syntax.free, estimator = estimator, data = sim.data[[i]][[j]],
std.lv = TRUE, ordered = ifelse(type == "categ", TRUE, FALSE),
se = se, warn = FALSE, check.lv.names = FALSE, check.gradient = FALSE,
check.start = FALSE, check.post = FALSE, check.vcov = FALSE, h1 = FALSE,
baseline = FALSE, store.vcov = FALSE, control = list(rel.tol = 0.001)), fit.measures = sim.fit.indices)),
error = function(y) { return(setNames(rep(NA, times = 4L), sim.fit.indices)) })
setTxtProgressBar(progress.bar, value = j)
}
# Close progress bar
close(progress.bar)
}
#···················
#### Without Progress Bar ####
} else {
# Model estimation
fit.result <- lapply(sim.data, function(y) lapply(y, function(z) tryCatch(suppressWarnings(lavaan::fitmeasures(lavaan::cfa(model = model.syntax.free, estimator = estimator, data = z, std.lv = TRUE,
se = se, warn = FALSE, check.lv.names = FALSE, check.gradient = FALSE,
check.start = FALSE, check.post = FALSE, check.vcov = FALSE, h1 = FALSE,
baseline = FALSE, store.vcov = FALSE, control = list(rel.tol = 0.001)), fit.measures = sim.fit.indices)),
error = function(y) { return(setNames(rep(NA, times = 4L), sim.fit.indices)) })))
}
# Combine Results
sim.result <- setNames(lapply(fit.result, function(y) setNames(as.data.frame(do.call("rbind", y)), nm = c("cfi", "tli", "rmsea", "srmr"))), nm = names(sim.data))
# Return object
return(sim.result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Rounding Number Within a Character String ####
.chr.round <- function(x, digits) {
m <- gregexpr("(-)?[[:digit:]]+\\.[[:digit:]]*", x)
regmatches(x, m) <- lapply(regmatches(x, m), function(y) round(as.numeric(y), digits = digits))
return(x)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.nonequi() function ---------------------------
#
# https://github.com/ddueber/dmacs/blob/master/R/MeasEquiv_EffectSize_Wrappers.R
#
# .dmacs_summary
# .dmacs_summary_single
#
# https://github.com/ddueber/dmacs/blob/master/R/MeasEquiv_EffectSize_Base.R
#
# .item_dmacs
# .expected_value
# .delta_mean_item
# .delta_var
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Summary of Measurement Non-Equivalence ####
#
# Returns a list of dMACS measurement nonequivalence from Nye and Drasgow (2011)
.dmacs_summary <- function(LambdaList, NuList, MeanList, VarList, SDList, Groups = NULL, RefGroup = 1, ThreshList = NULL, ThetaList = NULL, signed = FALSE, ordered = FALSE) {
#—————————————————————————————————————— #
### Continuous Indicators ####
if (!ordered) {
#···················
#### Two Groups or Time Points ####
if (isTRUE(length(Groups) == 2L)) {
.dmacs_summary_single(LambdaF = LambdaList[-RefGroup][[1L]], LambdaR = LambdaList[[RefGroup]],
NuF = NuList[-RefGroup][[1L]], NuR = NuList[[RefGroup]],
MeanF = MeanList[-RefGroup][[1L]], VarF = VarList[-RefGroup][[1L]],
SD = SDList[-RefGroup][[1L]], signed = signed, ordered = ordered)
#···················
#### More than Two Groups or Time Points ####
} else {
mapply(.dmacs_summary_single, LambdaF = LambdaList[-RefGroup], NuF = NuList[-RefGroup], MeanF = MeanList[-RefGroup], VarF = VarList[-RefGroup], SD = SDList[-RefGroup],
MoreArgs = list(LambdaR = LambdaList[[RefGroup]], NuR = NuList[[RefGroup]], signed = signed, ordered = ordered), SIMPLIFY = FALSE)
}
#—————————————————————————————————————— #
### Ordered Categorical Indicators ####
} else {
#...................
#### Two Groups or Time Points ####
if (isTRUE(length(Groups) == 2L)) {
.dmacs_summary_single(LambdaF = LambdaList[-RefGroup][[1L]], LambdaR = LambdaList[[RefGroup]], NuF = NuList[-RefGroup][[1L]], NuR = NuList[[RefGroup]],
ThreshF = ThreshList[-RefGroup][[1L]], ThreshR = ThreshList[[RefGroup]], ThetaF = ThetaList[-RefGroup][[1L]], ThetaR = ThetaList[[RefGroup]],
MeanF = MeanList[-RefGroup][[1L]], VarF = VarList[-RefGroup][[1L]], SD = SDList[-RefGroup][[1L]], signed = signed, ordered = ordered)
#...................
#### More than Two Groups or Time Points ####
} else {
mapply(.dmacs_summary_single, LambdaF = LambdaList[-RefGroup], NuF = NuList[-RefGroup], ThreshF = ThreshList[-RefGroup], ThetaF = ThetaList[-RefGroup], MeanF = MeanList[-RefGroup], VarF = VarList[-RefGroup], SD = SDList[-RefGroup],
MoreArgs = list(LambdaR = LambdaList[[RefGroup]], NuR = NuList[[RefGroup]], ThreshR = ThreshList[[RefGroup]], ThetaR = ThetaList[[RefGroup]], signed = signed, ordered = ordered), SIMPLIFY = FALSE)
}
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Summary of Measurement Non-Equivalence for a Single Group ####
#
# A list of dMACS measurement nonequivalence effects from Nye and Drasgow (2011)
.dmacs_summary_single <- function(LambdaR, LambdaF, NuR, NuF, MeanF, VarF, SD, ThreshR = NULL, ThreshF = NULL, ThetaR = NULL, ThetaF = NULL, signed = FALSE, ordered = FALSE) {
#—————————————————————————————————————— #
### Continuous Indicators ####
if (!ordered) {
#...................
#### One Factor ####
if (isTRUE(ncol(LambdaR) == 1L)) {
dmacs <- setNames(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, signed = signed, ordered = FALSE), nm = rownames(LambdaR))
m.diff <- setNames(sum(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ordered = FALSE), na.rm = TRUE), nm = colnames(LambdaR))
v.diff <- setNames(.delta_var(LambdaR = LambdaR, LambdaF = LambdaF, VarF = VarF), nm = colnames(LambdaR))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = v.diff)
#...................
#### More than One Factor ####
} else {
MeanF <- matrix(rep(as.vector(MeanF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
VarF <- matrix(rep(as.vector(VarF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
dmacs <- setNames(as.data.frame(matrix(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, signed = signed, ordered = FALSE), nrow = nrow(LambdaR)), row.names = rownames(LambdaR)), nm = colnames(LambdaR))
m.diff <- as.data.frame(matrix(colSums(matrix(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ordered = FALSE), nrow = nrow(LambdaR)), na.rm = TRUE), ncol = ncol(LambdaR), dimnames = list(NULL, colnames(LambdaR))))
v.diff <- as.data.frame(matrix(sapply(seq_len(ncol(LambdaR)), function(y) { .delta_var(LambdaR[, y] |> (\(p) p[p != 0])(), LambdaF[, y] |> (\(p) p[p != 0])(), VarF[y]) }), ncol = ncol(LambdaR), dimnames = list(NULL, colnames(LambdaR))))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = v.diff)
}
#—————————————————————————————————————— #
### Ordered Categorical Indicators ####
} else {
#...................
#### One Factor ####
if (isTRUE(ncol(LambdaR) == 1L)) {
dmacs <- setNames(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, signed = signed, ordered = ordered), nm = rownames(LambdaR))
m.diff <- setNames(sum(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, ordered = ordered), na.rm = TRUE), nm = colnames(LambdaR))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = NULL)
#...................
#### More than One Factor ####
} else {
MeanF <- matrix(rep(as.vector(MeanF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
VarF <- matrix(rep(as.vector(VarF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
dmacs <- setNames(data.frame(matrix(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, signed = signed, ordered = ordered), nrow = nrow(LambdaR)), row.names = rownames(LambdaR)), nm = colnames(LambdaR))
m.diff <- as.data.frame(matrix(colSums(matrix(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, ordered = ordered), nrow = nrow(LambdaR)), na.rm = TRUE), ncol = ncol(LambdaR), dimnames = list(NULL, colnames(LambdaR))))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = NULL)
}
}
return(summary_single)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing dMACS Effect Size for Measurement Non-Equivalence ####
#
# Returns dMACS effect size, see equation 3 in Nye & Drasgow (2011).
.item_dmacs <- function(LambdaR, LambdaF, NuR, NuF, MeanF, VarF, SD, ThreshR = NULL, ThreshF = NULL, ThetaR = NULL, ThetaF = NULL, signed, ordered = FALSE) {
# Check the number of thresholds
if (isTRUE(ordered)) { if (isTRUE(length(ThreshR) != length(ThreshF))) { stop("Items must have the same number of thresholds in both reference and focal group.", call. = FALSE) } }
## Check if items load on the factor
if (isTRUE(LambdaR != 0L)) {
# Function for the integrand
integrand <- function(z, LambdaR, LambdaF, NuR, NuF, ThreshR, ThreshF, ThetaR, ThetaF, MeanF, VarF, signed, ordered) {
if (isTRUE(!signed)) {
(.expected_value(LambdaF, NuF, MeanF + z*sqrt(VarF), ThreshF, ThetaF, ordered) - .expected_value(LambdaR, NuR, MeanF + z*sqrt(VarF), ThreshR, ThetaR, ordered))^2L * dnorm(z)
} else {
(.expected_value(LambdaF, NuF, MeanF + z*sqrt(VarF), ThreshF, ThetaF, ordered) - .expected_value(LambdaR, NuR, MeanF + z*sqrt(VarF), ThreshR, ThetaR, ordered)) * dnorm(z)
}
}
# Compute dMACS
if (isTRUE(!signed)) {
dmacs <- tryCatch(suppressWarnings(sqrt(integrate(integrand, -Inf, Inf, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, MeanF = MeanF, VarF = VarF, signed = signed, ordered = ordered)$value) / SD),
error = function(y) {
stop("There was an estimation problem, dMACS could not be computed.", call. = FALSE)
})
} else {
# Compute Signed dMACS
dmacs <- tryCatch(suppressWarnings(integrate(integrand, -Inf, Inf, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, MeanF = MeanF, VarF = VarF, signed = signed, ordered = ordered)$value / SD),
error = function(y) {
stop("There was an estimation problem, signed dMACS could not be computed.", call. = FALSE)
})
}
} else {
dmacs <- NA
}
return(dmacs)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Expected Value of an Indicator ####
#
# Returns the expected value of an indicator given item parameters and factor value
.expected_value <- function(Lambda, Nu, Eta, Thresh = NULL, Theta = NULL, ordered = FALSE) {
#—————————————————————————————————————— #
### Continuous Indicators ####
if (isTRUE(!ordered)) {
expected <- Nu + Lambda*Eta
#—————————————————————————————————————— #
### Ordered Categorical Indicators ####
} else {
Mu <- Nu + Lambda*Eta
max <- length(Thresh)
Thresh[max + 1L] <- Inf
expected <- 0L
for (i in seq_len(max)) { expected <- expected + i*(pnorm(Mu - Thresh[i], sd = sqrt(Theta)) - pnorm(Mu - Thresh[i + 1L], sd = sqrt(Theta))) }
}
return(expected)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Expected Bias to the Item Mean ####
#
# Returns the expected bias in the item mean due to measurement non-equivalence
# in equation 4 of Nye & Drasgow (2011).
.delta_mean_item <- function(LambdaR, LambdaF, NuR, NuF, MeanF, VarF, ThreshR = NULL, ThreshF = NULL, ThetaR = NULL, ThetaF = NULL, ordered = FALSE) {
# Check the number of thresholds
if (isTRUE(ordered)) { if (isTRUE(length(ThreshR) != length(ThreshF))) { stop("Items must have the same number of thresholds in both reference and focal group.", call. = FALSE) } }
## Check if items load on the factor
if (isTRUE(LambdaR != 0L)) {
integrand <- function(z, LambdaR, LambdaF, NuR, NuF, ThreshR, ThreshF, ThetaR, ThetaF, MeanF, VarF, ordered) {
(.expected_value(LambdaF, NuF, MeanF + z*sqrt(VarF), ThreshF, ThetaF, ordered) - .expected_value(LambdaR, NuR, MeanF + z*sqrt(VarF), ThreshR, ThetaR, ordered)) * dnorm(z)
}
delta_mean_item <- integrate(integrand, -Inf, Inf, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, MeanF = MeanF, VarF = VarF, ordered = ordered)$value
} else {
delta_mean_item <- NA
}
return(delta_mean_item)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Expected Bias to the Total Score Variance ####
#
# Returns the expected bias in the total score variance due to measurement non-equivalence
# in equation 7, 8, and 9 of Nye & Drasgow (2011).
.delta_var <- function(LambdaR, LambdaF, VarF, ordered = FALSE) {
delta_cov_mat <- matrix(nrow = length(LambdaR), ncol = length(LambdaR))
for (i in seq_along(LambdaR)) {
for (j in seq_along(LambdaR)) {
(delta_cov_mat[i, j] <- LambdaR[[j]]*(LambdaF[[i]] - LambdaR[[i]])*VarF) + (LambdaR[[i]]*(LambdaF[[j]] - LambdaR[[j]])*VarF) + ((LambdaF[[i]] - LambdaR[[i]])*(LambdaF[[j]] - LambdaR[[j]])*VarF)
}
}
return(sum(delta_cov_mat))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.print() function ----------------------------
#
# - .section.ind.from.to
.section.ind.from.to <- function(x, cur.section, run, input = FALSE) {
# Input
if (isTRUE(input)) {
parse.text <- parse(text = paste0("min(unlist(sapply(x, function(z) if (isTRUE(any(grep(z, run)))) {
sapply(grep(z, run), function(q) if (isTRUE(q > max(", paste0(sapply(cur.section, function(w) paste0("grep(", paste0("\"", w, "\""), ", run")), collapse = " | "), ")))) { q } else { length(run) + 1L })
} )))"))
# Output
} else {
parse.text <- parse(text = paste0("min(unlist(sapply(x, function(z) if (isTRUE(any(run == z))) {
sapply(which(run == z), function(q) if (isTRUE(q > max(which(", paste0(sapply(cur.section, function(w) paste0("run == ", paste0("\"", w, "\""))), collapse = " | "), ")))) { q } else { length(run) + 1L })
})))"))
}
return(eval(parse.text) - 1L)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.lca.summa() function ------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Extracting Results ####
.extract.lca.result <- function(lca.out.extract, max.class, conf.level, return) {
# Return objects
model.summary <- model.class <- model.descript <- nclass <- NA
#—————————————————————————————————————— #
### Model Convergence ####
conv <- any(grep("THE MODEL ESTIMATION TERMINATED NORMALLY", lca.out.extract, useBytes = TRUE))
#—————————————————————————————————————— #
### Number of Classes ####
if (isTRUE(any(grepl("CLASSES ", lca.out.extract, ignore.case = TRUE, useBytes = TRUE)))) { nclass <- unlist(strsplit(grep("CLASSES ", lca.out.extract, value = TRUE, ignore.case = TRUE, useBytes = TRUE), "")) |> (\(p) as.numeric(misty::chr.trim(paste(p[(grep("\\(", p, useBytes = TRUE) + 1L):(grep("\\)", p, useBytes = TRUE) - 1L)], collapse = ""))))() }
#—————————————————————————————————————— #
### Model Converged ####
if (isTRUE(conv)) {
if (isTRUE(return == "model.summary")) {
#···················
#### Model Summary ####
model.summary <- data.frame(# Number of classes
nclass = nclass,
# Model converged
conv = conv,
# Number of parameters
nparam = as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Loglikelihood
LL = as.numeric(misty::chr.trim(sub("H0 Value", "", grep("H0 Value ", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Loglikelihood Scaling correction factor
LL.scale = ifelse(any(grepl("H0 Scaling Correction Factor", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("H0 Scaling Correction Factor", "", grep("H0 Scaling Correction Factor", lca.out.extract, value = TRUE, useBytes = TRUE)))), NA),
# Loglikelihood replicated
LL.rep = ifelse(any(grepl("THE BEST LOGLIKELIHOOD VALUE WAS NOT REPLICATED", lca.out.extract, useBytes = TRUE)), FALSE, TRUE),
# AIC, CAIC, BIC, SABIC
aic = as.numeric(misty::chr.trim(sub("Akaike \\(AIC\\)", "", grep("Akaike \\(AIC\\)", lca.out.extract, value = TRUE, useBytes = TRUE)))),
caic = as.numeric(misty::chr.trim(sub("Bayesian \\(BIC\\)", "", grep("Bayesian \\(BIC\\)", lca.out.extract, value = TRUE, useBytes = TRUE)))) + as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE)))),
bic = as.numeric(misty::chr.trim(sub("Bayesian \\(BIC\\)", "", grep("Bayesian \\(BIC\\)", lca.out.extract, value = TRUE, useBytes = TRUE)))),
sabic = as.numeric(misty::chr.trim(sub("Sample-Size Adjusted BIC", "", grep("Sample-Size Adjusted BIC", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Approximate weight of evidence criterion (AWE)
awe = -2*as.numeric(misty::chr.trim(sub("H0 Value", "", grep("H0 Value ", lca.out.extract, value = TRUE, useBytes = TRUE)))) + 2 * as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE))))*(log(as.numeric(misty::chr.trim(sub("Number of observations", "", grep("Number of observations ", lca.out.extract, value = TRUE, useBytes = TRUE))))) + 1.5),
# Pearson Chi-Square
chi.pear = ifelse(any(grepl("Chi-Square Test of Model Fit", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("Pearson Chi-Square", lca.out.extract, useBytes = TRUE)[1L] + 4L]))), NA),
# Likelihood Ratio Chi-Square
chi.lrt = ifelse(any(grepl("Chi-Square Test of Model Fit", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("Likelihood Ratio Chi-Square", lca.out.extract, useBytes = TRUE)[1L] + 4L]))), NA),
# LMR-LRT
lmr.lrt = ifelse(any(grepl("VUONG-LO-MENDELL-RUBIN LIKELIHOOD RATIO TEST", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("Standard Deviation", lca.out.extract, useBytes = TRUE) + 1L]))), NA),
# Adjusted LMR-LRT
almr.lrt = ifelse(any(grepl("LO-MENDELL-RUBIN ADJUSTED", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("LO-MENDELL-RUBIN ADJUSTED", lca.out.extract, useBytes = TRUE) + 3L]))), NA),
# Bootstrap LRT
blrt = ifelse(any(grepl("PARAMETRIC BOOTSTRAPPED LIKELIHOOD", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("Approximate P-Value", "", lca.out.extract[grep("Approximate P-Value", lca.out.extract, useBytes = TRUE)]))), NA),
# Entropy
entropy = ifelse(any(grepl("Entropy", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("Entropy", "", grep("Entropy", lca.out.extract, value = TRUE, useBytes = TRUE)))), NA),
# Minimum average posterior class probability (AvePP)
avemin = min(as.numeric(diag(matrix(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(misty::chr.trim(lca.out.extract[grep("Average Latent Class Probabilities", lca.out.extract, useBytes = TRUE) + z]), " "))[-1L])
}), ncol = nclass))), na.rm = TRUE),
# Minimum class size of most likely latent class membership
nmin = min(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z], " ")))[[2L]]
})), na.rm = TRUE),
# Minimum average posterior class probability (AvePP)
pmin = min(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(misty::chr.trim(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z]), " "))) |> (\(p) p[which(grepl("\\.", p, useBytes = TRUE))])()
})), na.rm = TRUE))
}
#···················
#### Classification Diagnostics ####
if (isTRUE(return == "model.class")) {
model.class <- data.frame(# Number of classes
nclass = nclass,
# Model converged
conv = conv,
# Number of parameters
nparam = as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Loglikelihood replicated
LL.rep = ifelse(any(grepl("THE BEST LOGLIKELIHOOD VALUE WAS NOT REPLICATED", lca.out.extract, useBytes = TRUE)), FALSE, TRUE),
# Model-estimated class counts
as.data.frame(matrix(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z], " ")))[[2L]]
})) |> (\(q) if (isTRUE(length(q) != max.class)) { c(q, rep(NA, times = max.class - length(q))) } else { return(q) })(), ncol = max.class, dimnames = list(NULL, paste0("n", seq_len(max.class))))),
# Model-estimated proportion (pi)
as.data.frame(matrix(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
unlist(strsplit(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z], " ")) |> (\(p) p[which(grepl("\\.", p, useBytes = TRUE))][2L])()
})) |> (\(q) if (isTRUE(length(q) != max.class)) { c(q, rep(NA, times = max.class - length(q))) } else { return(q) })(), ncol = max.class, dimnames = list(NULL, paste0("p", seq_len(max.class))))),
# Entropy
entropy = ifelse(any(grepl("Entropy", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("Entropy", "", grep("Entropy", lca.out.extract, value = TRUE, useBytes = TRUE)))), NA),
# Average posterior class probability (AvePP)
as.data.frame(matrix(diag(sapply(5L:(5L + nclass - 1), function(z) {
as.numeric(misty::chr.omit(unlist(strsplit(misty::chr.trim(lca.out.extract[grep("Average Latent Class Probabilities", lca.out.extract, useBytes = TRUE) + z]), " "))[-1L]))
})) |> (\(p) if (isTRUE(length(p) != max.class)) { c(p, rep(NA, times = max.class - length(p))) } else { return(p) })(), ncol = max.class, dimnames = list(NULL, paste0("ave.pp", seq_len(max.class)))))) |>
# Odds of correct classification ratio (OCC)
(\(p) data.frame(p, matrix(((misty::chr.omit(p[, grep("ave.pp", names(p))], na.omit = TRUE, check = FALSE) / (1 - misty::chr.omit(p[, grep("ave.pp", names(p))], na.omit = TRUE, check = FALSE))) / (misty::chr.omit(p[, substr(names(p), 1, 1) == "p"], na.omit = TRUE, check = FALSE) / (1 - misty::chr.omit(p[, substr(names(p), 1, 1) == "p"], na.omit = TRUE, check = FALSE)))) |> (\(q) ifelse(is.nan(q), NA, q))() |>
(\(r) if (isTRUE(length(r) != max.class)) { c(r, rep(NA, times = max.class - length(r))) } else { return(r) })(),
ncol = max.class, dimnames = list(NULL, paste0("occ", seq_len(max.class))))))()
}
#···················
#### Means and Variances ####
if (isTRUE(return == "model.descript")) {
# Number of indicators
n.ind <- as.numeric(misty::chr.trim(sub("Number of dependent variables", "", grep("Number of dependent variables", lca.out.extract, value = TRUE, useBytes = TRUE))))
##### Continuous Indicators ####
if (isTRUE(all(lca.out.extract != " Binary and ordered categorical (ordinal)") && all(lca.out.extract != " Unordered categorical (nominal)"))) {
# Split CONFIDEN INTERVALS section
lca.out.extract.ci <- NULL
if (any(grep("CONFIDENCE INTERVALS OF MODEL RESULTS", lca.out.extract))) {
# Output CONFIDENCE INTERVALS OF MODEL RESULTS
lca.out.extract.ci <- lca.out.extract[c(grep("CONFIDENCE INTERVALS OF MODEL RESULTS", lca.out.extract):length(lca.out.extract))]
# Output without CONFIDENCE INTERVALS OF MODEL RESULTS
lca.out.extract <- lca.out.extract[-c(grep("CONFIDENCE INTERVALS OF MODEL RESULTS", lca.out.extract):length(lca.out.extract))]
}
# Extract means
out.means <- lapply(data.frame(sapply(if (isTRUE(nclass == 1L)) { grep("Means", lca.out.extract) } else { head(grep("Means", lca.out.extract), n = -1L) }, function(y) misty::chr.trim(misty::chr.omit(strsplit(lca.out.extract[(y + 1L):(y + n.ind)], " "), omit = "")))),
function(z) data.frame(param = "Mean", matrix(z, ncol = 5L, byrow = TRUE, dimnames = list(NULL, c("ind", "est", "se", "z", "pval"))))) |>
(\(p) do.call(rbind, lapply(seq_along(p), function(y) data.frame(class = y, p[y][[1L]]))))()
# Extract variances
out.var <- lapply(data.frame(sapply(grep("Variances", lca.out.extract), function(y) misty::chr.trim(misty::chr.omit(strsplit(lca.out.extract[(y + 1L):(y + n.ind)], " "), omit = "")))),
function(z) data.frame(param = "Variance", matrix(z, ncol = 5L, byrow = TRUE, dimnames = list(NULL, c("ind", "est", "se", "z", "pval"))))) |>
(\(p) do.call(rbind, lapply(seq_along(p), function(y) data.frame(class = y, p[y][[1L]]))))()
# Class count based on the estimated model
class.count <- matrix(as.numeric(misty::chr.omit(strsplit(lca.out.extract[(grep("BASED ON THE ESTIMATED MODEL", lca.out.extract) + 5L):(grep("BASED ON ESTIMATED POSTERIOR PROBABILITIES", lca.out.extract) - 2L)], " "), "")), ncol = 3, byrow = TRUE)
# Merge means and variances
model.descript <- data.frame(nclass = nclass, n = class.count[match(out.means[, "class"], class.count[, 1L]), 2L], rbind(out.means, out.var))
# Numeric
model.descript[, c("class", "est", "se", "z", "pval")] <- sapply(model.descript[, c("class", "est", "se", "z", "pval")], function(y) as.numeric(gsub("*********", NA, y, fixed = TRUE)))
# Mplus CONFIDENCE INTERVALS section
if (isTRUE(!is.null(lca.out.extract.ci))) {
if (isTRUE(!conf.level %in% c(0.9, 0.95, 0.99))) { stop("Please specifiy 0.9, 0.95, or 0.99 for the argument 'conf.level' when extracting confidence intervals from Mplus outputs.", call. = FALSE) }
lapply(data.frame(sapply(if (isTRUE(nclass == 1L)) { grep("Means", lca.out.extract.ci) } else { head(grep("Means", lca.out.extract.ci), n = -1L) }, function(y) misty::chr.trim(misty::chr.omit(strsplit(lca.out.extract.ci[(y + 1L):(y + n.ind)], " "), omit = "")))),
function(z) data.frame(param = "Mean", matrix(z, ncol = 8L, byrow = TRUE, dimnames = list(NULL, c("ind", "low05", "low25", "low50", "est", "upp50", "upp25", "upp05"))))) |>
(\(p) do.call(rbind, lapply(seq_along(p), function(y) data.frame(class = y, p[y][[1L]]))))() |>
(\(q) switch(as.character(conf.level), "0.99" = {
model.descript[model.descript$param == "Mean", "low"] <<- as.numeric(q[, "low05"])
model.descript[model.descript$param == "Mean", "upp"] <<- as.numeric(q[, "upp05"])
}, "0.95" = {
model.descript[model.descript$param == "Mean", "low"] <<- as.numeric(q[, "low25"])
model.descript[model.descript$param == "Mean", "upp"] <<- as.numeric(q[, "upp25"])
}, "0.9" = {
model.descript[model.descript$param == "Mean", "low"] <<- as.numeric(q[, "low50"])
model.descript[model.descript$param == "Mean", "upp"] <<- as.numeric(q[, "upp50"])
}))()
# No Mplus CONFIDENCE INTERVALS section
} else {
(model.descript$se * qnorm((1 - conf.level) / 2L, lower.tail = FALSE)) |>
(\(p) {
model.descript[model.descript$param == "Mean", "low"] <<- model.descript[model.descript$param == "Mean", "est"] - p[model.descript$param == "Mean"]
model.descript[model.descript$param == "Mean", "upp"] <<- model.descript[model.descript$param == "Mean", "est"] + p[model.descript$param == "Mean"]
})()
}
# Factor
model.descript$class <- factor(model.descript$class)
# Indicator names
model.descript$ind <- sapply(model.descript$ind, function(y) grep(y, unique(misty::chr.trim(gsub(";", "", misty::chr.omit(unlist(strsplit(lca.out.extract[grep("USEVARIABLES", lca.out.extract, ignore.case = TRUE):grep("CLASSES", lca.out.extract, ignore.case = TRUE)[1L]], " ")))))), ignore.case = TRUE, value = TRUE))
# Sort variables
model.descript <- model.descript[, c("nclass", "class", "n", "param", "ind", "est", "se", "z", "pval", "low", "upp")]
##### Ordered-Categorical or Nominal Indicators ####
} else if (isTRUE(any(lca.out.extract == " Binary and ordered categorical (ordinal)") || any(lca.out.extract == " Unordered categorical (nominal)"))) {
# Indicator names
ind.name <- misty::chr.omit(unlist(strsplit(lca.out.extract[which(lca.out.extract %in% c(" Binary and ordered categorical (ordinal)", " Unordered categorical (nominal)"))[1L] + 1L], " ")))
# Extract PROBABILITY SCALE section
lca.out.extract.prob <- lca.out.extract[(grep("RESULTS IN PROBABILITY SCALE", lca.out.extract) + 5L) |> (\(p) p:(which(diff(ifelse(lca.out.extract == "", 1, NA)) == 0L) |> (\(q) q[q > p][1L] )()))()]
# Extract probabilities
out.prob <- lapply(sapply(apply(matrix(which(lca.out.extract.prob == ""), ncol = 2L, byrow = TRUE), 1L, paste, collapse = ":"), function(y) list(lca.out.extract.prob[eval(parse(text = y))])) |>
(\(p) lapply(p, function(z) misty::chr.trim(misty::chr.omit(z))))(), function(w) {
matrix(t(sapply(misty::chr.omit(w, omit = ind.name), function(x) { as.numeric(misty::chr.trim(sub("Category", "", misty::chr.omit(strsplit(x, " "))))) })), ncol = 5L, dimnames = list(NULL, c("categ", "est", "se", "z", "pval"))) |>
(\(r) data.frame(ind = unlist(r[c(which(r[, "categ"] == 1L)[-1] - 1L, nrow(r)), "categ"] |> (\(s) sapply(seq_along(s), function(q) rep(ind.name[q], times = s[q])))()), r))()
}) |> (\(t) do.call(rbind, lapply(seq_along(t), function(y) data.frame(class = y, t[y][[1L]]))))()
# Class count based on the estimated model
class.count <- matrix(as.numeric(misty::chr.omit(strsplit(lca.out.extract[(grep("BASED ON THE ESTIMATED MODEL", lca.out.extract) + 5L):(grep("BASED ON ESTIMATED POSTERIOR PROBABILITIES", lca.out.extract) - 2L)], " "), "")), ncol = 3, byrow = TRUE)
# Merge class counts
model.descript <- data.frame(nclass = nclass, n = class.count[match(out.prob[, "class"], class.count[, 1L]), 2L], out.prob, row.names = NULL)
# Numeric
model.descript[, c("class", "est", "se", "z", "pval")] <- sapply(model.descript[, c("class", "est", "se", "z", "pval")], function(y) as.numeric(gsub("*********", NA, y, fixed = TRUE)))
# Factor
model.descript$class <- factor(model.descript$class)
# Indicator names
model.descript$ind <- sapply(model.descript$ind, function(y) grep(y, unique(misty::chr.trim(gsub(";", "", misty::chr.omit(unlist(strsplit(lca.out.extract[grep("USEVARIABLES", lca.out.extract, ignore.case = TRUE):grep("CLASSES", lca.out.extract, ignore.case = TRUE)[1L]], " ")))))), ignore.case = TRUE, value = TRUE))
# Sort variables
model.descript <- model.descript[, c("nclass", "class", "n", "ind", "categ", "est", "se", "z", "pval")]
}
}
#—————————————————————————————————————— #
### Model Not Converged ####
} else {
model.summary <- data.frame(nclass = nclass, conv = conv, nparam = NA, LL = NA, LL.scale = NA, LL.rep = NA,
aic = NA, caic = NA, bic = NA, sabic = NA, awe = NA, chi.pear = NA, chi.lrt = NA, lmr.lrt = NA, almr.lrt = NA, blrt = NA, entropy = NA)
model.class <- data.frame(nclass = nclass, conv = conv, nparam = NA, entropy = NA)
model.descript <- data.frame(matrix(nrow = 0L, ncol = 9L, dimnames = list(NULL, c("nclass", "n", "class", "param", "ind", "est", "se", "z", "pval"))))
}
return(list(model.summary = model.summary, model.class = model.class, model.descript = model.descript))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.run() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions to Identify the Operating System ####
is.windows <- function() {
if (isTRUE(exists("Sys.info"))) {
os <- Sys.info()[["sysname"]]
} else {
os <- .Platform$OS.type
}
os <- tolower(os)
if (isTRUE(grepl("windows", os))) {
return(TRUE)
} else {
return(FALSE)
}
}
is.macos <- function() {
if (isTRUE(exists("Sys.info"))) {
os <- Sys.info()[["sysname"]]
} else {
os <- R.version$os
}
os <- tolower(os)
if (isTRUE(grepl("darwin", os))) {
return(TRUE)
} else {
return(FALSE)
}
}
is.linux <- function() {
if (isTRUE(exists("Sys.info"))) {
os <- Sys.info()[["sysname"]]
} else {
os <- R.version$os
}
os <- tolower(os)
if (isTRUE(grepl("linux", os))) {
return(TRUE)
} else {
return(FALSE)
}
}
os <- function() {
windows <- is.windows()
macos <- is.macos()
linux <- is.linux()
count <- windows + macos + linux
if (isTRUE(count > 1L) || isTRUE(count == 0L)) {
return("unknown")
} else if (windows) {
return("windows")
} else if (macos) {
return("macos")
} else if (linux) {
return("linux")
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Detect the Location/Name of the Mplus Command ####
.detect.mplus <- function() {
ostype <- os()
if (identical(ostype, "windows")) {
suppressWarnings(mplus <- system("where Mplus", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0) && isTRUE(file.exists(mplus))) {
mplus <- "Mplus"
} else {
if (isTRUE(file.exists("C:\\Program Files\\Mplus\\Mplus.exe"))) {
mplus <- "C:\\Program Files\\Mplus\\Mplus.exe"
} else {
suppressWarnings(mplus <- system("where Mpdemo8", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0 && file.exists(mplus))) {
mplus <- "Mpdemo8"
} else {
if (isTRUE(file.exists("C:\\Program Files\\Mplus Demo\\Mpdemo8.exe"))) {
mplus <- "C:\\Program Files\\Mplus Demo\\Mpdemo8.exe"
} else {
note <- paste0(
"Mplus and Mpdemo8 are either not installed or could not be found\n",
"Try installing Mplus or Mplus Demo. If Mplus or Mplus Demo are already installed, \n",
"make sure one can be found on your PATH. The following may help\n\n",
"Windows 10:\n",
" (1) In Search, search for and then select: System (Control Panel)\n",
" (2) Click the Advanced system settings link.\n",
" (3) Click Environment Variables ...\n",
" (4) In the Edit System Variable (or New System Variable ) window,\n",
" (5) specify the value of the PATH environment variable...\n",
" (6) Close and reopen R and run:\n\n",
"mplusAvailable(silent=FALSE)",
"\n")
stop(note)
}
}
}
}
}
if (isTRUE(identical(ostype, "macos"))) {
suppressWarnings(mplus <- system("which mplus", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0 && file.exists(mplus))) {
mplus <- "mplus"
} else {
if (isTRUE(file.exists("/Applications/Mplus/mplus"))) {
mplus <- "/Applications/Mplus/mplus"
} else {
suppressWarnings(mplus <- system("which mpdemo", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0 && file.exists(mplus))) {
mplus <- "mpdemo"
} else {
if (isTRUE(file.exists("/Applications/MplusDemo/mpdemo"))) {
mplus <- "/Applications/MplusDemo/mpdemo"
} else {
stop("mplus and mpdemo not found on the system path or in the 'usual' /Applications/Mplus location. Ensure Mplus or the Mplus Demo are installed and that the location of the command is on your system path.")
}
}
}
}
}
if (isTRUE(identical(ostype, "linux"))) {
failure_note <- paste0(
"Mplus is either not installed or could not be found\n",
"Try installing Mplus or if it already is installed,\n",
"making sure it can be found by adding it to your PATH or adding a symlink\n\n",
"To see directories on your PATH, From a terminal, run:\n\n",
" echo $PATH",
"\n\nthen try something along these lines:\n\n",
" sudo ln -s /path/to/mplus/on/your/system /directory/on/your/PATH",
"\n")
mplus_found <- FALSE
suppressWarnings(mplus <- system("which mplus", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0L && file.exists(mplus))) {
mplus <- "mplus"
mplus_found <- TRUE
} else {
if (isTRUE(dir.exists("/opt/mplus"))) {
test <- file.path(list.dirs("/opt/mplus", recursive = FALSE)[1], "mplus")
if (isTRUE(file.exists(test))) {
mplus <- test
mplus_found <- TRUE
}
} else {
suppressWarnings(mplus <- system("which mpdemo", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0L && file.exists(mplus))) {
mplus <- "mpdemo"
mplus_found <- TRUE
}
}
}
if (isTRUE(!mplus_found)) { stop(failure_note) }
}
if (isTRUE(identical(ostype, "unknown"))) { stop("OS Type not known. Cannot auto detect Mplus command name. You must specify it.") }
return(mplus)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## convert_to_filelist() ####
convert_to_filelist <- function(target, filefilter = NULL, recursive = FALSE) {
filelist <- c()
for (tt in target) {
fi <- file.info(tt)
if (isTRUE(is.na(fi$size))) { stop("Cannot find target: ", tt) }
if (isTRUE(fi$isdir)) {
directory <- sub("(\\\\|/)?$", "", tt, perl = TRUE)
if (is.windows() && isTRUE(grepl("^[a-zA-Z]:$", directory))) {directory <- paste0(directory, "/") }
if (isTRUE(!file.exists(directory))) stop("Cannot find directory: ", directory)
this_set <- list.files(path = directory, recursive = recursive, pattern = ".*\\.inp?$", full.names = TRUE)
filelist <- c(filelist, this_set)
} else {
if (isTRUE(!grepl(".*\\.inp?$", tt, perl = TRUE))) {
warning("Target: ", tt, "does not appear to be an .inp file. Ignoring it.")
next
} else {
if (isTRUE(!file.exists(tt))) { stop("Cannot find input file: ", tt) }
filelist <- c(filelist, tt)
}
}
}
if (isTRUE(!is.null(filefilter))) filelist <- grep(filefilter, filelist, perl = TRUE, value = TRUE)
filelist <- normalizePath(filelist)
return(filelist)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## splitFilePath() ####
splitFilePath <- function(filepath, normalize = FALSE) {
if (isTRUE(!is.character(filepath))) stop("Path not a character string")
if (isTRUE(nchar(filepath) < 1L || is.na(filepath))) stop("Path is missing or of zero length")
filepath <- sub("(\\\\|/)?$", "", filepath, perl = TRUE)
components <- strsplit(filepath, split="[\\/]")[[1L]]
lcom <- length(components)
stopifnot(lcom > 0L)
relFilename <- components[lcom]
absolute <- FALSE
if (isTRUE(lcom == 1L)) {
dirpart <- NA_character_
} else if (isTRUE(lcom > 1L)) {
components <- components[-lcom]
dirpart <- do.call("file.path", as.list(components))
if (grepl("^([A-Z]{1}:|~/|/|//|\\\\)+.*$", dirpart, perl=TRUE)) absolute <- TRUE
if (normalize) { #convert to absolute path
dirpart <- normalizePath(dirpart)
absolute <- TRUE
}
}
return(list(directory = dirpart, filename = relFilename, absolute = absolute))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus() and mplus.update() function ---------------
# the blimp() and blimp.update() function ---------------
#
# - .extract.section
# Function for Extracting Input Command Sections ####
.extract.section <- function(section, x, section.pos) {
# Sort section position
section.pos <- sort(section.pos)
# Split input
split.x <- strsplit(x, "")[[1L]]
# Start position of the section
start <- setdiff(as.numeric(gregexec(section, toupper(x))[[1L]]),
c(as.numeric(gregexec(paste0("\\.", section), toupper(x))[[1L]]) + 1L, as.numeric(gregexec(paste0("\\_", section), toupper(x))[[1L]]) + 1L, as.numeric(gregexec("SAVEDATA:", toupper(x))[[1L]]) + 4L))
# Multiple sections
if (isTRUE(length(start) > 1L && section != "TEST:")) {
stop(paste0("There are more than one ", dQuote(section), " sections in the input text."), call. = FALSE)
# One section
} else if (isTRUE(length(start) == 1L)) {
# End position of the section
end <- if (isTRUE(any(section.pos > start))) { section.pos[which(section.pos > start)][1L] - 1L } else { length(split.x) }
# Extract section
object <- misty::chr.trim(strsplit(paste(split.x[start:end], collapse = ""), "\n")[1L], side = "right", check = FALSE)
# Remove last "\n"
object[length(object)] <- gsub("\n", "", object[length(object)])
# Collapse with "\n" and return object
object <- paste(object, collapse = "\n")
# Multiple TEST: sections in Blimp
} else if (isTRUE(length(start) > 1L)) {
# End position of the section
end <- sapply(start, function(y) {
if (isTRUE(any(section.pos > y))) { section.pos[which(section.pos > y)][1L] - 1L } else { length(split.x) }
})
# Extract section
object <- sapply(seq_along(start), function(y) {
misty::chr.trim(strsplit(paste(split.x[start[y]:end[y]], collapse = ""), "\n")[1L], side = "right", check = FALSE)
})
# Paste sections
object <- paste(object, collapse = "\n")
}
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the multilevel.r2() Function —-------------------------
#
# - .variable.section
# - .r2mlm
# - .r2mlm_lmer
# - .r2mlm_nlme
# - .r2mlm_manual
# - .prepare_data
# - .add_interaction_vars_to_data
# - .get_random_slope_vars
# - .get_cwc
# - .get_interaction_vars
# - .sort_variables
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Internal Functions from the r2mlm package ####
#—————————————————————————————————————— #
### .r2mlm() Function ####
.r2mlm <- function(model) {
temp_formula <- formula(model)
grepl_array <- grepl("I(", temp_formula, fixed = TRUE)
for (bool in grepl_array) {
if (isTRUE(bool)) { stop("Error: r2mlm does not allow for models fit using the I() function; user must thus manually include any desired transformed predictor variables such as x^2 or x^3 as separate columns in dataset.") }
}
# call appropriate .r2mlm helper function
if (isTRUE(typeof(model) == "list")) {
.r2mlm_nlme(model)
} else if (isTRUE(typeof(model) == "S4")) {
.r2mlm_lmer(model)
} else {
stop("You must input a model generated using either the lme4 or nlme package.")
}
}
#—————————————————————————————————————— #
### .r2mlm_lmer() Function ####
.r2mlm_lmer <- function(model) {
# R-Squared for more than one cluster variable only available for "NS" using lme4
if (isTRUE(length(names(lme4::getME(model, "flist"))) > 1L)) { stop("This function can only deal with models with a single cluster variable.", call. = FALSE) }
# Visible global function definition
is <- fixef <- getME <- NULL
# Step 1) check if model has_intercept
if (isTRUE(attr(terms(model), which = "intercept") == 1L)) {
has_intercept <- TRUE
} else {
has_intercept <- FALSE
}
# Step 2) Pull all variable names from the formula
all_variables <- all.vars(formula(model))
cluster_variable <- all_variables[length(all_variables)]
# Step 3a) Pull and prepare data
data <- .prepare_data(model, "lme4", cluster_variable)
# Step 3b) Determine whether data is appropriate format
# a) Pull all variables except for cluster
outcome_and_predictors <- all_variables[1L:(length(all_variables) - 1L)]
# b) If any of those variables is non-numeric, then throw an error
for (variable in outcome_and_predictors) {
if (isTRUE(!is(data[[variable]], "integer") && !is(data[[variable]], "numeric"))) {
stop("Your data must be numeric. Only the cluster variable can be a factor.")
}
}
# Step 4a) Define variables you'll be sorting
if (isTRUE(length(outcome_and_predictors) == 1L)) {
predictors <- .get_interaction_vars(model)
} else {
predictors <- append(outcome_and_predictors[2L:length(outcome_and_predictors)], .get_interaction_vars(model))
}
# Step 4b) Create and fill vectors
l1_vars <- .sort_variables(data, predictors, cluster_variable)$l1_vars
l2_vars <- .sort_variables(data, predictors, cluster_variable)$l2_vars
# Step 5) Pull variable names for L1 predictors with random slopes into a variable called random_slope_vars
random_slope_vars <- .get_random_slope_vars(model, has_intercept, "lme4")
# Step 6) Determine value of centered within cluster
if (is.null(l1_vars)) {
centeredwithincluster <- TRUE
} else {
centeredwithincluster <- .get_cwc(l1_vars, cluster_variable, data)
}
# 7a) within_covs (l1 variables)
within <- .get_covs(l1_vars, data)
# 7b) pull column numbers for between_covs (l2 variables)
between <- .get_covs(l2_vars, data)
# 7c) pull column numbers for random_covs (l1 variables with random slopes)
random <- .get_covs(random_slope_vars, data)
# 8a) gamma_w, fixed slopes for L1 variables (from l1_vars list)
gammaw <- c()
i <- 1L
for (variable in l1_vars) {
gammaw[i] <- fixef(model)[variable]
i <- i + 1L
}
# 8b) gamma_b, intercept value if hasintercept = TRUE, and fixed slopes for L2 variables (from between list)
gammab <- c()
if (isTRUE(has_intercept)) {
gammab[1L] <- fixef(model)[1L]
i <- 2L
} else {
i <- 1L
}
for (var in l2_vars) {
gammab[i] <- fixef(model)[var]
i = i + 1L
}
# Step 9) Tau matrix, results from VarCorr(model)
vcov <- VarCorr(model)
tau <- as.matrix(Matrix::bdiag(vcov))
# Step 10) Sigma^2 value, Rij
sigma2 <- getME(model, "sigma")^2L
# Step 11) Input everything into r2mlm_manual
.r2mlm_manual(as.data.frame(data), within_covs = within, between_covs = between, random_covs = random,
gamma_w = gammaw, gamma_b = gammab, Tau = tau, sigma2 = sigma2, has_intercept = has_intercept, clustermeancentered = centeredwithincluster)
}
#—————————————————————————————————————— #
### .r2mlm_nlme() Function ####
.r2mlm_nlme <- function(model) {
# R-Squared for more than one cluster variable only available for "NS" using lme4
if (isTRUE(length(nlme::getGroupsFormula(model, asList = TRUE)) > 1L)) { stop("This function can only deal with models with a single cluster variable.", call. = FALSE) }
# Visible global function definition
is <- getME <- NULL
# Step 1) check if model has_intercept
if (isTRUE(attr(terms(model), which = "intercept") == 1L)) {
has_intercept = TRUE
} else {
has_intercept = FALSE
}
# Step 2) Pull all variable names from the formula
all_variables <- all.vars(formula(model))
cluster_variable <- attr(nlme::getGroups(model), which = "label")
# Add the grouping var to list of all variables, and calculate formula length (for later use, to iterate)
all_variables[length(all_variables) + 1L] <- cluster_variable
formula_length <- length(all_variables) # this returns the number of elements in the all_vars list TODO remove this
# Step 3a) Pull and prepare data
data <- .prepare_data(model, "nlme", cluster_variable)
# Step 3b) Determine whether data is appropriate format. Only the cluster variable can be a factor, for now
outcome_and_predictors <- all_variables[1L:length(all_variables) - 1L]
for (variable in outcome_and_predictors) {
if (isTRUE(!is(data[[variable]], "integer") && !is(data[[variable]], "numeric"))) {
stop("Your data must be numeric. Only the cluster variable can be a factor.")
}
}
# Step 4a) Define variables you'll be sorting
if (isTRUE(length(outcome_and_predictors) == 1L)) {
predictors <- .get_interaction_vars(model)
} else {
predictors <- append(outcome_and_predictors[2:length(outcome_and_predictors)], .get_interaction_vars(model))
}
# Step 4b) Create and fill vectors
l1_vars <- .sort_variables(data, predictors, cluster_variable)$l1_vars
l2_vars <- .sort_variables(data, predictors, cluster_variable)$l2_vars
# Step 5) pull variable names for L1 predictors with random slopes into a variable called random_slope_vars
random_slope_vars <- .get_random_slope_vars(model, has_intercept, "nlme")
# Step 6) determine value of centeredwithincluster
if (isTRUE(is.null(l1_vars))) {
centeredwithincluster <- TRUE
} else {
centeredwithincluster <- .get_cwc(l1_vars, cluster_variable, data)
}
# 7a) within_covs (l1 variables)
within <- .get_covs(l1_vars, data)
# 7b) Pull column numbers for between_covs (l2 variables)
between <- .get_covs(l2_vars, data)
# 7c) Pull column numbers for random_covs (l1 variables with random slopes)
random <- .get_covs(random_slope_vars, data)
# 8a) gamma_w, fixed slopes for L1 variables (from l1_vars list)
gammaw <- c()
i = 1L
for (variable in l1_vars) {
gammaw[i] <- nlme::fixef(model)[variable]
i = i + 1L
}
# 8b) gamma_b, intercept value if hasintercept = TRUE, and fixed slopes for L2 variables (from between list)
gammab <- c()
if (isTRUE(has_intercept)) {
gammab[1L] <- nlme::fixef(model)[1L]
i = 2L
} else {
i = 1L
}
for (variable in l2_vars) {
gammab[i] <- nlme::fixef(model)[variable]
i = i + 1L
}
# Step 9) Tau matrix
tau <- nlme::getVarCov(model)
# Step 10) sigma^2 value, Rij
sigma2 <- model$sigma^2
# Step 11) Input everything into r2mlm_manual
.r2mlm_manual(as.data.frame(data), within_covs = within, between_covs = between, random_covs = random,
gamma_w = gammaw, gamma_b = gammab, Tau = tau, sigma2 = sigma2, has_intercept = has_intercept, clustermeancentered = centeredwithincluster)
}
#—————————————————————————————————————— #
### .r2mlm_manual() Function ####
.r2mlm_manual <- function(data, within_covs, between_covs, random_covs,
gamma_w, gamma_b, Tau, sigma2, has_intercept = TRUE, clustermeancentered = TRUE) {
if (isTRUE(has_intercept)) {
if (isTRUE(length(gamma_b) > 1L)) gamma <- c(1L, gamma_w, gamma_b[2:length(gamma_b)])
if (isTRUE(length(gamma_b) == 1L)) gamma <- c(1L, gamma_w)
if (isTRUE(is.null(within_covs))) gamma_w <- 0L
}
if (isTRUE(!has_intercept)) {
gamma <- c(gamma_w, gamma_b)
if (isTRUE(is.null(within_covs))) gamma_w <- 0L
if (isTRUE(is.null(between_covs))) gamma_b <- 0L
}
if (isTRUE(is.null(gamma))) gamma <- 0L
# Compute phi
phi <- var(cbind(1L, data[, c(within_covs)], data[, c(between_covs)]), na.rm = TRUE)
if (isTRUE(!has_intercept)) phi <- var(cbind(data[, c(within_covs)], data[, c(between_covs)]), na.rm = TRUE)
if (isTRUE(is.null(within_covs) && is.null(within_covs) && !has_intercept)) phi <- 0L
phi_w <- var(data[, within_covs], na.rm = TRUE)
if (isTRUE(is.null(within_covs))) phi_w <- 0L
phi_b <- var(cbind(1L, data[, between_covs]), na.rm = TRUE)
if (isTRUE(is.null(between_covs))) phi_b <- 0L
# Compute psi and kappa
var_randomcovs <- var(cbind(1, data[, c(random_covs)]), na.rm = TRUE)
if (isTRUE(length(Tau) > 1L)) psi <- matrix(c(diag(Tau)), ncol = 1L)
if (isTRUE(length(Tau) == 1L)) psi <- Tau
if (isTRUE(length(Tau) > 1L)) kappa <- matrix(c(Tau[lower.tri(Tau) == TRUE]), ncol = 1)
if (isTRUE(length(Tau) == 1L)) kappa <- 0L
v <- matrix(c(diag(var_randomcovs)), ncol = 1L)
r <- matrix(c(var_randomcovs[lower.tri(var_randomcovs) == TRUE]), ncol = 1L)
if (isTRUE(is.null(random_covs))) {
v <- 0L
r <- 0L
m <- matrix(1L, ncol = 1L)
}
if (isTRUE(length(random_covs) > 0L)) m <- matrix(c(colMeans(cbind(1, data[, c(random_covs)]), na.rm = TRUE)), ncol = 1L)
# Total variance
totalvar_notdecomp <- t(v)%*%psi + 2L*(t(r)%*%kappa) + t(gamma)%*%phi%*%gamma + t(m)%*%Tau%*%m + sigma2
totalwithinvar <- (t(gamma_w)%*%phi_w%*%gamma_w) + (t(v)%*%psi + 2L*(t(r)%*%kappa)) + sigma2
totalbetweenvar <- (t(gamma_b)%*%phi_b%*%gamma_b) + Tau[1L]
totalvar <- totalwithinvar + totalbetweenvar
# Total decomp
decomp_fixed_notdecomp <- (t(gamma)%*%phi%*%gamma) / totalvar_notdecomp
decomp_varslopes_notdecomp <- (t(v)%*%psi + 2L*(t(r)%*%kappa)) / totalvar_notdecomp
decomp_varmeans_notdecomp <- (t(m)%*%Tau%*%m) / totalvar_notdecomp
decomp_sigma_notdecomp <- sigma2/totalvar_notdecomp
decomp_fixed_within <- (t(gamma_w)%*%phi_w%*%gamma_w) / totalvar
decomp_fixed_between <- (t(gamma_b)%*%phi_b%*%gamma_b) / totalvar
decomp_fixed <- decomp_fixed_within + decomp_fixed_between
decomp_varslopes <- (t(v)%*%psi + 2L*(t(r)%*%kappa)) / totalvar
decomp_varmeans <- (t(m)%*%Tau%*%m) / totalvar
decomp_sigma <- sigma2 / totalvar
# Within decomp
decomp_fixed_within_w <- (t(gamma_w)%*%phi_w%*%gamma_w) / totalwithinvar
decomp_varslopes_w <- (t(v)%*%psi + 2L*(t(r)%*%kappa)) / totalwithinvar
decomp_sigma_w <- sigma2 / totalwithinvar
# Between decomp
decomp_fixed_between_b <- (t(gamma_b)%*%phi_b%*%gamma_b) / totalbetweenvar
decomp_varmeans_b <- Tau[1L] / totalbetweenvar
# New measures
if (isTRUE(clustermeancentered)) {
R2_f <- decomp_fixed
R2_f1 <- decomp_fixed_within
R2_f2 <- decomp_fixed_between
R2_fv <- decomp_fixed + decomp_varslopes
R2_fvm <- decomp_fixed + decomp_varslopes + decomp_varmeans
R2_v <- decomp_varslopes
R2_m <- decomp_varmeans
R2_f_w <- decomp_fixed_within_w
R2_f_b <- decomp_fixed_between_b
R2_fv_w <- decomp_fixed_within_w + decomp_varslopes_w
R2_v_w <- decomp_varslopes_w
R2_m_b <- decomp_varmeans_b
}
if (isTRUE(!clustermeancentered)) {
R2_f <- decomp_fixed_notdecomp
R2_fv <- decomp_fixed_notdecomp + decomp_varslopes_notdecomp
R2_fvm <- decomp_fixed_notdecomp + decomp_varslopes_notdecomp + decomp_varmeans_notdecomp
R2_v <- decomp_varslopes_notdecomp
R2_m <- decomp_varmeans_notdecomp
}
if (isTRUE(clustermeancentered)) {
decomp_table <- matrix(c(decomp_fixed_within, decomp_fixed_between, decomp_varslopes, decomp_varmeans, decomp_sigma,
decomp_fixed_within_w, "NA", decomp_varslopes_w, "NA", decomp_sigma_w,
"NA", decomp_fixed_between_b, "NA", decomp_varmeans_b, "NA"), ncol = 3L)
decomp_table <- suppressWarnings(apply(decomp_table, 2, as.numeric))
rownames(decomp_table) <- c("fixed, within", "fixed, between", "slope variation", "mean variation", "sigma2")
colnames(decomp_table) <- c("total", "within", "between")
R2_table <- matrix(c(R2_f1, R2_f2, R2_v, R2_m, R2_f, R2_fv, R2_fvm,
R2_f_w, "NA", R2_v_w, "NA", "NA", R2_fv_w, "NA",
"NA", R2_f_b, "NA", R2_m_b, "NA", "NA", "NA"), ncol = 3L)
R2_table <- suppressWarnings(apply(R2_table, 2, as.numeric)) # make values numeric, not character
rownames(R2_table) <- c("f1", "f2", "v", "m", "f", "fv", "fvm")
colnames(R2_table) <- c("total", "within", "between")
}
if (isTRUE(!clustermeancentered)) {
decomp_table <- matrix(c(decomp_fixed_notdecomp, decomp_varslopes_notdecomp, decomp_varmeans_notdecomp, decomp_sigma_notdecomp), ncol = 1L)
decomp_table <- suppressWarnings(apply(decomp_table, 2L, as.numeric))
rownames(decomp_table) <- c("fixed", "slope variation", "mean variation", "sigma2")
colnames(decomp_table) <- c("total")
R2_table <- matrix(c(R2_f, R2_v, R2_m, R2_fv, R2_fvm), ncol = 1L)
R2_table <- suppressWarnings(apply(R2_table, 2L, as.numeric))
rownames(R2_table) <- c("f", "v", "m", "fv", "fvm")
colnames(R2_table) <- c("total")
}
Output <- list(noquote(decomp_table), noquote(R2_table))
names(Output) <- c("Decompositions", "R2s")
return(Output)
}
#—————————————————————————————————————— #
### .prepare_data() Function ####
.prepare_data <- function(model, calling_function, cluster_variable, second_model = NULL) {
# Step 1a: Pull data frame associated with model
if (isTRUE(calling_function == "lme4")) {
data <- model@frame
} else {
data <- model[["data"]]
}
# Step 2a) pull interaction terms into list
interaction_vars <- .get_interaction_vars(model)
if (isTRUE(!is.null(second_model))) {
interaction_vars_2 <- .get_interaction_vars(second_model)
interaction_vars <- unique(append(interaction_vars, interaction_vars_2))
}
# Step 2b) split interaction terms into halves, multiply halves to create new columns in dataframe
data <- .add_interaction_vars_to_data(data, interaction_vars)
return(data)
}
#—————————————————————————————————————— #
### .add_interaction_vars_to_data() Function ####
.add_interaction_vars_to_data <- function(data, interaction_vars) {
for (whole in interaction_vars) {
half1 <- unlist(strsplit(whole, ":"))[1L]
half2 <- unlist(strsplit(whole, ":"))[2L]
newcol <- data[[half1]] * data[[half2]]
data <- within(data, assign(whole, newcol))
}
return(data)
}
#—————————————————————————————————————— #
### .get_covs() Function ####
.get_covs <- function(variable_list, data) {
cov_list <- c()
i <- 1L
for (variable in variable_list) {
tmp <- match(variable, names(data))
cov_list[i] <- tmp
i <- i + 1L
}
return(cov_list)
}
#—————————————————————————————————————— #
### .get_random_slope_vars() Function ####
.get_random_slope_vars <- function(model, has_intercept, calling_function) {
# Visible global function defnition
ranef <- NULL
if (isTRUE(calling_function == "lme4")) {
temp_cov_list <- ranef(model)[[1L]]
} else if (calling_function == "nlme") {
temp_cov_list <- nlme::ranef(model)
}
if (isTRUE(has_intercept == 1L)) {
running_count <- 2L
} else {
running_count <- 1L
}
random_slope_vars <- c()
x <- 1L
while (running_count <= length(temp_cov_list)) {
random_slope_vars[x] <- names(temp_cov_list[running_count])
x <- x + 1L
running_count <- running_count + 1L
}
return(random_slope_vars)
}
#—————————————————————————————————————— #
### .get_cwc() Function ####
.get_cwc <- function(l1_vars, cluster_variable, data) {
for (variable in l1_vars) {
t <- tapply(data[, variable], data[, cluster_variable], sum, na.rm = TRUE)
temp_tracker <- 0L
# sum all of the sums
for (i in t) { temp_tracker <- temp_tracker + i }
if (abs(temp_tracker) < 0.0000001) {
centeredwithincluster <- TRUE
} else {
centeredwithincluster <- FALSE
break
}
}
return(centeredwithincluster)
}
#—————————————————————————————————————— #
### .get_interaction_vars() Function ####
.get_interaction_vars <- function(model) {
interaction_vars <- c()
x <- 1L
for (term in attr(terms(model), "term.labels")) {
if (isTRUE(grepl(":", term))) {
interaction_vars[x] <- term
x <- x + 1L
}
}
return(interaction_vars)
}
#—————————————————————————————————————— #
### .sort_variables() Function ####
.sort_variables <- function(data, predictors, cluster_variable) {
l1_vars <- c()
l2_vars <- c()
l1_counter <- 1L
l2_counter <- 1L
for (variable in predictors) {
t <- tapply(data[, variable], data[, cluster_variable], var, na.rm = TRUE)
counter <- 1L
while (counter <= length(t)) {
if (is.na(t[[counter]])) { t[[counter]] <- 0L }
counter <- counter + 1L
}
variance_tracker <- 0L
for (i in t) { variance_tracker <- variance_tracker + i }
if (isTRUE(variance_tracker == 0L)) {
l2_vars[l2_counter] <- variable
l2_counter <- l2_counter + 1L
} else {
l1_vars[l1_counter] <- variable
l1_counter <- l1_counter + 1L
}
}
return(list("l1_vars" = l1_vars, "l2_vars" = l2_vars))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.update() function ---------------------------
#
# - .variable.section
.variable.section <- function(section, input, update) {
# Colon or semicolon position
input.semicol <- misty::chr.grep(c(":", ";"), unlist(strsplit(input, "")))
update.semicol <- misty::chr.grep(c(":", ";"), unlist(strsplit(update, "")))
# Section in update input
if (isTRUE(grepl(section, toupper(update)))) {
# Start and end position of the updated section
start.update <- rev(update.semicol[which(update.semicol < rev(unlist(gregexec(section, toupper(update))))[1L])])[1L] + 1L
end.update <- update.semicol[which(update.semicol > unlist(gregexec(section, toupper(update)))[1L])][1L]
## Subsection is in Input Object
if (isTRUE(grepl(section, toupper(input)))) {
### Start/End Position of the Removal Section
start.inp <- rev(input.semicol[which(input.semicol < rev(unlist(gregexec(section, toupper(input))))[1L])])[1L] + 1L
end.inp <- input.semicol[which(input.semicol > unlist(gregexec(section, toupper(input)))[1L])][1L]
### Insert Updated Sub-Section
input <- sub("...", "",
paste(c(unlist(strsplit(input, ""))[seq_len(start.inp - 1L)], "\n",
unlist(strsplit(update, ""))[start.update:end.update],
if (isTRUE(end.inp != nchar(input))) { unlist(strsplit(input, ""))[((end.inp + 1L):nchar(input))] }),
collapse = ""), fixed = TRUE)
## Subsection is not in Input Object
} else {
input <- sub("...", "", paste(c(input, "\n\n", unlist(strsplit(update, ""))[start.update:end.update]), collapse = ""), fixed = TRUE)
}
}
return(invisible(input))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the na.auxiliary() function ———————————————————————————
.cohens.d.na.auxiliary <- function(formula, data, weighted = TRUE, correct = FALSE) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Formula ####
# Variables
var.formula <- all.vars(as.formula(formula))
# Outcome(s)
y.var <- var.formula[-length(var.formula)]
# Grouping variable
group.var <- var.formula[length(var.formula)]
# Data
data <- as.data.frame(data[, var.formula], stringsAsFactors = FALSE)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Data and Arguments ####
# Outcome
x.dat <- data[, y.var]
# Grouping
group.dat <- data[, group.var]
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Descriptives ####
# Mean difference
x.diff <- diff(tapply(x.dat, group.dat, mean, na.rm = TRUE))
# Sample size by group
n.group <- tapply(x.dat, group.dat, function(y) length(na.omit(y)))
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Standard Deviation ####
# Variance by group
var.group <- tapply(x.dat, group.dat, var, na.rm = TRUE)
# Weighted pooled standard deviation
if (isTRUE(weighted)) {
sd.group <- sqrt(((n.group[1L] - 1L)*var.group[1] + (n.group[2L] - 1L)*var.group[2L]) / (sum(n.group) - 2L))
# Unweighted pooled standard deviation
} else {
sd.group <- sum(var.group) / 2L
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Cohen's d Estimate ####
estimate <- x.diff / sd.group
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Correction Factor ####
# Bias-corrected Cohen's d
if (isTRUE(correct && weighted)) {
v <- sum(n.group) - 2L
# Correction factor based on gamma function
if (isTRUE(sum(n.group) < 200L)) {
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation
} else {
corr.factor <- (1L - (3L / (4L * v - 1L)))
}
estimate <- estimate*corr.factor
}
return(estimate)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the multilevel.omega() function ———————————————————————
#
# - .internal.mvrnorm
.internal.mvrnorm <- function (n = 1L, mu, Sigma, tol = 1e-06, empirical = FALSE, EISPACK = FALSE) {
p <- length(mu)
if (isTRUE(!all(dim(Sigma) == c(p, p)))) { stop("incompatible arguments") }
eS <- eigen(Sigma, symmetric = TRUE)
ev <- eS$values
if (isTRUE(!all(ev >= -tol * abs(ev[1L])))) { stop("'Sigma' is not positive definite") }
X <- matrix(rnorm(p * n), n)
X <- drop(mu) + eS$vectors %*% diag(sqrt(pmax(ev, 0L)), p) %*% t(X)
nm <- names(mu)
if (is.null(nm) && !is.null(dn <- dimnames(Sigma))) { nm <- dn[[1L]] }
dimnames(X) <- list(nm, NULL)
if (n == 1L) { drop(X) } else { t(X) }
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the multilevel.r2() function ——————————————————————————
# - .var.random
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified Function from the MuMIn Package ####
.var.random <- function(model) {
matmultdiag <- function(x, y, ty = t(y)) { return(rowSums(x * ty)) }
mmRE <- do.call("cbind", suppressWarnings(model.matrix(model, type = "randomListRaw"))) |> (\(p) p[, !duplicated(colnames(p)), drop = FALSE] )()
vc <- unclass(lme4::VarCorr(model))
if(isTRUE(!is.null(vc))) {
varRE <- sum(sapply(vc, function(y) {
mmRE[, rownames(y), drop = FALSE] |> (\(p) sum(matmultdiag(p %*% y, ty = p)) / nrow(mmRE))()
}))
} else {
varRE <- 0L
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the na.test() function ————————————————————————————————
#
# - .LittleMCAR
# - .TestMCARNormality
# - .OrderMissing
# - .DelLessData
# - .Mls
# - .Sexpect
# - .Impute
# - .Mimpute
# - .MimputeS
# - .Hawkins
# - .TestUNey
# - .SimNey
# - .AndersonDarling
#
# BaylorEdPsych:
# https://rdrr.io/cran/BaylorEdPsych/src/R/LittleMCAR.R
#
# MissMech
# https://github.com/cran/MissMech/tree/master/R
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Little's missing completely at random (MCAR) test ####
.LittleMCAR <- function(x) {
n.var <- ncol(x)
r <- 1L * is.na(x)
x.mp <- data.frame(cbind(x, ((r %*% (2L^((seq_len(n.var) - 1L)))) + 1L)))
colnames(x.mp) <- c(colnames(x), "MisPat")
n.mis.pat <- length(unique(x.mp$MisPat))
gmean <- suppressWarnings(mvnmle::mlest(x)$muhat)
gcov <- suppressWarnings(mvnmle::mlest(x)$sigmahat)
colnames(gcov) <- rownames(gcov) <- colnames(x)
x.mp$MisPat2 <- rep(NA, nrow(x))
for (i in seq_len(n.mis.pat)) { x.mp$MisPat2[x.mp$MisPat == sort(unique(x.mp$MisPat), partial = (i))[i]] <- i }
x.mp$MisPat <- x.mp$MisPat2
x.mp <- x.mp[, -which(names(x.mp) %in% "MisPat2")]
datasets <- list()
for (i in seq_len(n.mis.pat)) { datasets[[paste0("DataSet", i)]] <- x.mp[which(x.mp$MisPat == i), seq_len(n.var)] }
kj <- 0L
for (i in seq_len(n.mis.pat)) {
no.na <- as.matrix(1L * !is.na(colSums(datasets[[i]])))
kj <- kj + colSums(no.na)
}
df <- kj - n.var
d2 <- 0L
for (i in seq_len(n.mis.pat)) {
mean <- (colMeans(datasets[[i]]) - gmean)
mean <- mean[!is.na(mean)]
keep <- 1L * !is.na(colSums(datasets[[i]]))
keep <- keep[which(keep[seq_len(n.var)] != 0L)]
cov <- gcov
cov <- cov[which(rownames(cov) %in% names(keep)), which(colnames(cov) %in% names(keep))]
d2 <- as.numeric(d2 + (sum(x.mp$MisPat == i)*(t(mean) %*% solve(cov) %*% mean)))
}
return(list(chi.square = d2, df = df, p.value = 1L - pchisq(d2, df), missing.patterns = n.mis.pat))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Testing Homoscedasticity, Multivariate Normality, and MCAR ####
.TestMCARNormality <- function(data, delete = 6, m = 20, method = "npar", nrep = 10000,
n.min = 30, seed = NULL, pool = "med", impdat = NULL) {
#—————————————————————————————————————— #
### Imputation ####
if (isTRUE(is.null(impdat))) {
# Order missing data pattern
newdata <- .OrderMissing(data, delete)
#—————————————————————————————————————— #
### Imputed Data Provided ####
} else {
# Number of imputations
m <- impdat$m
# Order missing data pattern
newdata <- .OrderMissing(impdat$data[, colnames(data)], delete)
}
#—————————————————————————————————————— #
### Data Check ####
if(isTRUE(length(newdata$data) == 0L)) { stop("There are no cases left after deleting insufficient cases.", call. = FALSE) }
if (isTRUE(newdata$g == 1L)) { stop("There is only one missing data pattern present.", call. = FALSE) }
if (isTRUE(sum(newdata$patcnt == 1L) > 0L)) { stop("At least 2 cases needed in each missing data patterns.", call. = FALSE) }
#—————————————————————————————————————— #
### Extract Data ####
y <- newdata$data
patused <- newdata$patused
patcnt <- newdata$patcnt
spatcnt <- newdata$spatcnt
caseorder <- newdata$caseorder
removedcases <- newdata$removedcases
colnam <- colnames(patused)
n <- nrow(y)
p <- ncol(y)
g <- newdata$g
spatcntz <- c(0L, spatcnt)
pvalsn <- matrix(0L, m, g)
adistar <- matrix(0L, m, g)
pnormality <- c()
x <- vector("list", g)
n4sim <- vector("list", g)
#—————————————————————————————————————— #
### Imputation ####
if (isTRUE(is.null(impdat))) {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed) }
yimp <- y
#...................
#### Non-Parametric ####
if (isTRUE(method == "npar")) {
iscomp <- rowSums(patused, na.rm = TRUE) == p
cind <- which(iscomp)
ncomp <- patcnt[cind]
if (isTRUE(length(ncomp) == 0L)) { ncomp <- 0L }
use.normal <- FALSE
if (isTRUE(ncomp >= 10L && ncomp >= 2L*p)) {
compy <- y[seq(spatcntz[cind] + 1L, spatcntz[cind + 1L]), ]
ybar <- matrix(colMeans(compy))
sbar <- stats::cov(compy)
resid <- (ncomp / (ncomp - 1L))^0.5 * (compy - matrix(ybar, ncomp, p, byrow = TRUE))
} else {
warning("There are not sufficient number of complete cases for non-parametric imputation, imputation method \"normal\" will be used instead.", call. = FALSE)
use.normal <- TRUE
mu <- matrix(0L, p, 1L)
sig <- diag(1L, p)
emest <- .Mls(newdata, mu, sig, 1e-6)
}
#...................
#### Parametric Normal ####
} else {
mu <- matrix(0L, p, 1L)
sig <- diag(1L, p)
emest <- .Mls(newdata, mu, sig, 1e-6)
}
#...................
#### Impute and Analyze ####
for (k in seq_len(m)) {
##### Parametric Normal ####
if (isTRUE(method == "normal" || use.normal)) {
yimp <- .Impute(data = y, emest$mu, emest$sig, method = "normal")
yimp <- yimp$yimpOrdered
##### Non-Parametric ####
} else {
yimp <- .Impute(data = y, ybar, sbar, method = "npar", resid)$yimpOrdered
}
if (isTRUE(k == 1L)) { yimptemp <- yimp }
##### Hawkins Test ####
templist <- .Hawkins(yimp, spatcnt)
fij <- templist$fij
tail <- templist$a
ni <- templist$ni
for (i in seq_len(g)) {
if (isTRUE(ni[i] < n.min && k == 1L)) { n4sim[[i]] <- .SimNey(ni[i], nrep) }
templist <- .TestUNey(tail[[i]], nrep, sim = n4sim[[i]], n.min)
pn <- templist$pn
n4 <- templist$n4
pn <- pn + (pn == 0L) / nrep
pvalsn[k, i] <- pn
}
##### Anderson-Darling Non-Parametric Test ####
if (isTRUE(length(ni) < 2L)) { stop("Not enough groups for Anderson Darling test.", call. = FALSE) }
templist <- .AndersonDarling(fij, ni)
adistar[k, ] <- templist$adk.all
pnormality <- c(pnormality, templist$pn)
}
#—————————————————————————————————————— #
### Imputed Data Provided ####
} else {
for (k in seq_len(m)) {
#...................
#### Hawkins Test ####
templist <- .Hawkins(as.matrix(mice::complete(impdat, action = k)[newdata$caseorder, colnam]), spatcnt)
fij <- templist$fij
tail <- templist$a
ni <- templist$ni
for (i in seq_len(g)) {
if (isTRUE(ni[i] < n.min && k == 1L)) { n4sim[[i]] <- .SimNey(ni[i], nrep) }
templist <- .TestUNey(tail[[i]], nrep, sim = n4sim[[i]], n.min)
pn <- templist$pn
n4 <- templist$n4
pn <- pn + (pn == 0L) / nrep
pvalsn[k, i] <- pn
}
#...................
#### Anderson-Darling Non-Parametric Test ####
if (isTRUE(length(ni) < 2L)) { stop("Not enough groups for Anderson Darling test.", call. = FALSE) }
templist <- .AndersonDarling(fij, ni)
adistar[k, ] <- templist$adk.all
pnormality <- c(pnormality, templist$pn)
}
}
#—————————————————————————————————————— #
### Result Table ####
#### Test Statistics and p-Values ####
ts.hawkins <- -2L * rowSums(log(pvalsn))
p.hawkins <- stats::pchisq(-2L * rowSums(log(pvalsn)), 2L*g, lower.tail = FALSE)
ts.anderson <- rowSums(adistar)
p.anderson <- pnormality
switch(pool,
"m" = {
tsa.hawkins <- mean(ts.hawkins)
pa.hawkins <- mean(p.hawkins)
tsa.anderson <- mean(ts.anderson)
pa.anderson <- mean(p.anderson)
}, "med" = {
tsa.hawkins <- median(ts.hawkins)
pa.hawkins <- median(p.hawkins)
tsa.anderson <- median(ts.anderson)
pa.anderson <- median(p.anderson)
}, "min" = {
tsa.hawkins <- max(ts.hawkins)
pa.hawkins <- min(p.hawkins)
tsa.anderson <- max(ts.anderson)
pa.anderson <- min(p.anderson)
}, "max" = {
tsa.hawkins <- min(ts.hawkins)
pa.hawkins <- max(p.hawkins)
tsa.anderson <- min(ts.anderson)
pa.anderson <- max(p.anderson)
}, "random" = {
ind.hawkins <- sample(seq_along(ts.hawkins), size = 1L)
tsa.hawkins <- ts.hawkins[ind.hawkins]
pa.hawkins <- p.hawkins[ind.hawkins]
ind.anderson <- sample(seq_along(ts.anderson), size = 1L)
tsa.anderson <- ts.anderson[ind.anderson]
pa.anderson <- p.anderson[ind.anderson]
})
#—————————————————————————————————————— #
### Analysis Data ####
if (isTRUE(length(removedcases) == 0L)) {
dataused <- data
} else {
dataused <- data[-1L * removedcases, ]
}
#—————————————————————————————————————— #
### Return Object ####
restab <- list(dat.analysis = dataused, dat.ordered = y, case.order = caseorder, g = g, pattern = patused, n.pattern = patcnt,
t.hawkins = pvalsn, ts.hawkins = ts.hawkins, tsa.hawkins = tsa.hawkins, p.hawkins = p.hawkins, pa.hawkins = pa.hawkins,
t.anderson = adistar, ts.anderson = ts.anderson, tsa.anderson = tsa.anderson, p.anderson = p.anderson, pa.anderson = pa.anderson)
return(restab)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Order Missing Data Pattern ####
.OrderMissing <- function(y, del.lesscases = 0L) {
if (isTRUE(is.data.frame(y))) { y <- as.matrix(y) }
if (isTRUE(!is.matrix(y))) { stop("Data is not a matrix or data frame", call. = FALSE) }
if (isTRUE(length(y) == 0L)) { stop("Data is empty", call. = FALSE) }
names <- colnames(y)
pp <- ncol(y)
yfinal <- c()
patused <- c()
patcnt <- c()
caseorder <- c()
removedcases <- c()
ordertemp <- seq_len(nrow(y))
ntemp <- nrow(y)
ptemp <- ncol(y)
done <- FALSE
yatone <- FALSE
while (isTRUE(!done)) {
pattemp <- is.na(y[1L, ])
indin <- c()
indout <- c()
done <- TRUE
for (i in seq_len(ntemp)) {
if (isTRUE(all(is.na(y[i, ]) == pattemp))) {
indout <- c(indout, i)
} else {
indin <- c(indin, i)
done <- FALSE
}
}
if (isTRUE(length(indin) == 1L)) { yatone <- TRUE }
yfinal <- rbind(yfinal, y[indout, ])
y <- y[indin, ]
caseorder <- c(caseorder, ordertemp[indout])
ordertemp <- ordertemp[indin]
patcnt <- c(patcnt, length(indout))
patused <- rbind(patused, pattemp)
if (isTRUE(yatone)) {
pattemp <- is.na(y)
yfinal <- rbind(yfinal, matrix(y, ncol = pp))
y <- c()
indin <- c()
indout <- c(1L)
caseorder <- c(caseorder, ordertemp[indout])
ordertemp <- ordertemp[indin]
patcnt <- c(patcnt, length(indout))
patused <- rbind(patused, pattemp)
done <- TRUE
}
if (isTRUE(!done)) { ntemp <- nrow(y) }
}
caseorder <- c(caseorder, ordertemp)
patused <- ifelse(patused, NA, 1L)
rownames(patused) <- NULL
colnames(patused) <- names
dataorder <- list(data = yfinal, patused = patused, patcnt = patcnt,
spatcnt = cumsum(patcnt), g = length(patcnt),
caseorder = caseorder, removedcases = removedcases)
dataorder$call <- match.call()
class(dataorder) <- "orderpattern"
if (isTRUE(del.lesscases > 0L)) { dataorder <- .DelLessData(dataorder, del.lesscases) }
dataorder$patused <- matrix(dataorder$patused, ncol = pp)
colnames(dataorder$patused) <- names
return(dataorder)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Removes groups with identical missing data patterns ####
.DelLessData <- function(data, ncases = 0) {
if (isTRUE(length(data) == 0L)) { stop("Data is empty", call. = FALSE) }
if (isTRUE(is.matrix(data))) { data <- .OrderMissing(data) }
ind <- which(data$patcnt <= ncases)
spatcntz <- c(0L, data$spatcnt)
rm <- c()
removedcases <- c()
if (isTRUE(length(ind) != 0L)) {
for (i in seq_len(length(ind))) {
rm <- c(rm, seq(spatcntz[ind[i]] + 1L, spatcntz[ind[i] + 1L]));
}
y <- data$data[-1L * rm, ]
removedcases <- data$caseorder[rm]
patused <- data$patused[-1L * ind, ]
patcnt <- data$patcnt[-1L * ind]
caseorder <- data$caseorder[-1L * rm]
spatcnt <- cumsum(patcnt)
} else {
patused <- data$patused
patcnt <- data$patcnt
spatcnt <- data$spatcnt
caseorder <- data$caseorder
y <- data$data
}
newdata <- list(data = y, patused = patused, patcnt = patcnt,
spatcnt = spatcnt, g = length(patcnt), caseorder = caseorder,
removedcases = removedcases)
class(newdata) <- "orderpattern"
return(newdata)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## ML Estimates of Mean and Covariance Based on Incomplete Data ####
.Mls <- function(data, mu = NA, sig = NA, tol = 1e-6, Hessian = FALSE) {
if (isTRUE(!is.matrix(data) && !inherits(data, "orderpattern"))) { stop("Data must have the classes of matrix or orderpattern.", call. = FALSE) }
if (isTRUE(is.matrix(data))) {
allempty <- which(rowSums(!is.na(data)) == 0L)
if (isTRUE(length(allempty) != 0L)) { data <- data[rowSums(!is.na(data)) != 0L, ] }
data <- .OrderMissing(data)
}
if (isTRUE(inherits(data, "orderpattern"))) {
allempty <- which(rowSums(!is.na(data$data)) == 0L)
if (isTRUE(length(allempty) != 0L)) {
data <- data$data
data <- data[rowSums(!is.na(data)) != 0L, ]
data <- .OrderMissing(data)
}
}
if (isTRUE(length(data$data) == 0L)) { stop("Data is empty", call. = FALSE) }
if (isTRUE(ncol(data$data) < 2L)) { stop("More than one variable is required.", call. = FALSE) }
y <- data$data
patused <- data$patused
spatcnt <- data$spatcnt
if (isTRUE(is.na(mu[1L]))) {
mu <- matrix(0L, ncol(y), 1L)
sig <- diag(1L, ncol(y))
}
itcnt <- 0L
em <- 0L
repeat {
emtemp <- .Sexpect(y, mu, sig, patused, spatcnt)
ysbar <- emtemp$ysbar
sstar <- emtemp$sstar
em <- max(abs(sstar - mu %*% t(mu) - sig), abs(mu - ysbar))
mu <- ysbar
sig <- sstar - mu %*% t(mu)
itcnt <- itcnt + 1L
if (isTRUE(!(em > tol || itcnt < 2L))) break
}
rownames(mu) <- colnames(y)
colnames(sig) <- colnames(y)
if (isTRUE(Hessian)) {
templist <- .Ddf(y, mu, sig)
hessian <- templist$dd
stderror <- templist$se
return (list(mu = mu, sig = sig, hessian = hessian, stderror = stderror, iteration = itcnt))
}
return(list(mu = mu, sig = sig, iteration = itcnt))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.Sexpect <- function(y, mu, sig, patused, spatcnt) {
n <- nrow(y)
pp <- ncol(y)
sstar <- matrix(0L, pp, pp)
ysbar <- matrix(0L, nrow(mu), ncol(mu))
first <- 1L
for (i in seq_len(length(spatcnt))) {
ni <- spatcnt[i] - first + 1L
stemp <- matrix(0L, pp, pp)
indm <- which(is.na(patused[i, ]))
indo <- which(!is.na(patused[i, ]))
yo <- matrix(y[first:spatcnt[i], indo], ni, length(indo))
first <- spatcnt[i] + 1L
muo <- mu[indo]
mum <- mu[indm]
sigoo <- sig[indo, indo]
sigooi <- solve(sigoo)
soo <- t(yo) %*% yo
stemp[indo, indo] <- soo
ystemp <- matrix(0L, ni, pp)
ystemp[, indo] <- yo
if (isTRUE(length(indm)!= 0L)) {
sigmo <- matrix(sig[indm, indo], length(indm), length(indo))
sigmm <- sig[indm, indm]
temp1 <- matrix(mum, ni, length(indm), byrow = TRUE)
temp2 <- yo - matrix(muo, ni, length(indo), byrow = TRUE)
ym <- temp1 + temp2 %*% sigooi %*% t(sigmo)
som <- t(yo) %*% ym
smm <- ni * (sigmm - sigmo %*% sigooi %*% t(sigmo))+ t(ym)%*%ym
stemp[indo, indm] <- som
stemp[indm, indo] <- t(som)
stemp[indm, indm] <- smm
ystemp[, indm] <- ym
}
sstar <- sstar + stemp
if (isTRUE(ni == 1L)) {
ysbar <- t(ystemp) + ysbar
} else {
ysbar <- colSums(ystemp) + ysbar
}
}
ysbar <- (1L / n) * ysbar
sstar <- (1L / n) * sstar
sstar <- (sstar + t(sstar)) / 2L
return(list(ysbar = ysbar, sstar = sstar))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Hessian of the Observed Data ####
.Ddf <- function(data, mu, sig) {
y <- data
n <- nrow(y)
p <- ncol(y)
ns <- p * (p + 1L) / 2L
nparam <- ns + p
ddss <- matrix(0L, ns, ns)
ddmm <- matrix(0L, p, p)
ddsm <- matrix(0L, ns, p)
for (i in seq_len(n)) {
obs <- which(!is.na(y[i, ]))
lo <- length(obs)
tmp <- cbind(rep(obs, 1L, each = lo), rep(obs, lo))
tmp <- matrix(tmp[tmp[, 1L] >= tmp[, 2L], ], ncol = 2L)
lolo = lo*(lo + 1L) / 2L
subsig <- sig[obs, obs]
submu <- mu[obs, ]
temp <- matrix(y[i, obs] - submu, nrow = 1L)
a <- solve(subsig)
b <- a %*% (2L * t(temp) %*% temp - subsig) * a
d <- temp %*% a
ddimm <- 2L * a
ddmm[obs, obs] <- ddmm[obs, obs] + ddimm
rcnt <- 0L
ddism <- matrix(0L, lolo, lo)
for (k in seq_len(lo)) {
for (l in seq_len(k)) {
rcnt <- rcnt + 1L
ccnt <- 0L
for (kk in seq_len(lo)) {
ccnt <- ccnt + 1L
ddism[rcnt, ccnt] <- 2L * (1L - 0.5 * (k == l)) * (a[kk, l] %*% d[k] + a[kk, k] %*% d[l])
}
}
}
for (k in seq_len(lolo)) {
par1 <- tmp[k, 1L] * (tmp[k, 1L] -1L) / 2L + tmp[k, 2L]
for (j in seq_len(lo)) {
ddsm[par1, obs[j]] <- ddsm[par1, obs[j]] + ddism[k, j]
}
}
ssi <- matrix(0L, lolo, lolo)
for (m in seq_len(lolo)) {
u <- which(obs == tmp[m, 1L])
v <- which(obs == tmp[m, 2L])
for (q in seq_len(m)) {
k <- which(obs == tmp[q, 1L])
l <- which(obs == tmp[q, 2L])
ssi[m, q] <- (b[v, k] * a[l, u] + b[v, l] * a[k, u] + b[u, k] * a [l, v] + b[u, l] * a[k, v]) * (1L - 0.5 * (u == v)) * (1L - 0.5 * (k == l))
}
}
for (k in seq_len(lolo)) {
par1 <- tmp[k, 1L] * (tmp[k, 1L] - 1L) / 2L + tmp[k, 2L]
for (l in seq_len(k)) {
par2 <- tmp[l, 1L] * (tmp[l, 1L] - 1L) / 2L + tmp[l, 2L]
ddss[par1, par2] <- ddss[par1, par2] + ssi[k, l]
ddss[par2, par1] <- ddss[par1, par2]
}
}
}
dd <- -1L * rbind(cbind(ddmm, t(ddsm)), cbind(ddsm, ddss)) / 2L
se <- -solve(dd)
return(list(dd = dd, se = se))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Parametric and Non-Parameric Imputation ####
.Impute <- function(data, mu = NA, sig = NA, method = "normal", resid = NA) {
if (isTRUE(!is.matrix(data) && !inherits(data, "orderpattern"))) { stop("Data must have the classes of matrix or orderpattern.", call. = FALSE) }
if (isTRUE(is.matrix(data))) {
allempty <- which(rowSums(!is.na(data)) == 0L)
if (isTRUE(length(allempty) != 0L)) {
data <- data[rowSums(!is.na(data)) != 0L, ]
warning(length(allempty), " Cases with all variables missing have been removed from the data.", call. = FALSE)
}
data <- .OrderMissing(data)
}
if (isTRUE(inherits(data, "orderpattern"))) {
allempty <- which(rowSums(!is.na(data$data)) == 0L)
if (isTRUE(length(allempty) != 0L)) {
data <- data$data
data <- data[rowSums(!is.na(data)) != 0L, ]
warning(length(allempty), " Cases with all variables missing have been removed from the data.", call. = FALSE)
data <- .OrderMissing(data)
}
}
if(isTRUE(length(data$data) == 0L)) { stop("Data is empty", call. = FALSE) }
if (isTRUE(ncol(data$data) < 2L)) { stop("More than one variable is required.", call. = FALSE) }
y <- data$data
patused <- data$patused
spatcnt <- data$spatcnt
patcnt <- data$patcnt
g <- data$g
caseorder <- data$caseorder
spatcntz <- c(0L, spatcnt)
p <- ncol(y)
n <- nrow(y)
yimp <- y
use.normal <- TRUE
#—————————————————————————————————————— #
### Imputation Method: Distribution Free ####
if (isTRUE(method == "npar")) {
if (isTRUE(is.na(mu[1L]))) {
ybar <- matrix(0L, p, 1L)
sbar <- diag(1L, p)
cind <- which(rowSums(patused, na.rm = TRUE) == p)
ncomp <- patcnt[cind]
use.normal <- FALSE
if (isTRUE(ncomp >= 10L && ncomp >= 2L*p)) {
compy <- y[seq(spatcntz[cind] + 1L, spatcntz[cind + 1L]), ]
ybar <- matrix(colMeans(compy))
sbar <- stats::cov(compy)
if (isTRUE(is.na(resid[1L]))) {
resid <- (ncomp / (ncomp - 1)) ^ 0.5 * (compy - matrix(ybar, ncomp, p, byrow = TRUE))
}
} else {
stop("There is not sufficient number of complete cases.\n Dist.free imputation requires a least 10 complete cases\n or 2*number of variables, whichever is bigger.\n", call. = FALSE)
}
}
if (isTRUE(!is.na(mu[1L]))) {
ybar <- mu
sbar <- sig
cind <- which(rowSums(patused, na.rm = TRUE) == p)
ncomp <- patcnt[cind]
use.normal <- FALSE
compy <- y[seq(spatcntz[cind] + 1L, spatcntz[cind + 1L]), ]
if (isTRUE(is.na(resid[1L]))) {
resid <- (ncomp / (ncomp - 1L)) ^ 0.5 * (compy - matrix(ybar, ncomp, p, byrow = TRUE))
}
}
resstar <- resid[sample(ncomp, n - ncomp, replace = TRUE), ]
indres1 <- 1L
for (i in seq_len(g)) {
if (isTRUE(sum(patused[i, ], na.rm = TRUE) != p)) {
test <- y[(spatcntz[i] + 1L) : spatcntz[i + 1L], ]
indres2 <- indres1 + patcnt[i] - 1L
test <- .MimputeS(matrix(test, ncol = p), patused[i, ], ybar, sbar, matrix(resstar[indres1:indres2, ], ncol = p))
indres1 <- indres2 + 1L
yimp[(spatcntz[i] + 1L) : spatcntz[i + 1L], ] <- test
}
}
}
#—————————————————————————————————————— #
### Imputation Method: Norml ####
if (isTRUE(method == "normal" | use.normal)) {
if (isTRUE(is.na(mu[1L]))) {
emest <- .Mls(data, tol = 1e-6)
mu <- emest$mu
sig <- emest$sig
}
for (i in seq_len(g)) {
if (sum(patused[i, ], na.rm = TRUE) != p) {
test <- y[(spatcntz[i] + 1L) : spatcntz[i + 1L], ]
test <- .Mimpute(matrix(test, ncol = p), patused[i, ], mu, sig)
yimp[(spatcntz[i] + 1L) : spatcntz[i + 1L], ] <- test
}
}
}
imputed <- list(yimp = yimp[order(caseorder), ], yimpOrdered = yimp, caseorder = caseorder, patused = patused, patcnt = patcnt)
return(imputed)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.Mimpute <- function(data, patused, mu, sig) {
ni <- nrow(data)
indm <- which(is.na(patused))
indo <- which(!is.na(patused))
pm <- length(indm)
sigmo <- matrix(sig[indm, indo], pm, length(indo))
ss1 <- sigmo %*% solve(sig[indo, indo])
varymiss <- matrix(sig[indm, indm], pm, pm) - ss1 %*% t(sigmo)
if (isTRUE(pm == 1L)) {
a <- sqrt(varymiss)
} else {
svdvar <- svd(varymiss)
a <- diag(sqrt(svdvar$d)) %*% t(svdvar$u)
}
data[, indm] <- matrix(rnorm(ni * pm), ni, pm) %*% a + (matrix(mu[indm], ni, pm, byrow = TRUE) + (data[, indo] - matrix(mu[indo], ni, length(indo), byrow = TRUE)) %*% t(ss1))
return(data)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.MimputeS <- function(data, patused, y1, s1, e) {
ni <- nrow(data)
indm <- which(is.na(patused))
indo <- which(!is.na(patused))
pm <- length(indm)
po <- length(indo)
a <- matrix(s1[indm, indo], pm, po) %*% solve(s1[indo, indo])
zij <- (matrix(y1[indm], ni, pm, byrow = TRUE) + (data[, indo] - matrix(y1[indo], ni, po, byrow = TRUE)) %*% t(a)) + matrix(e[, indm], ni, pm) - matrix(e[, indo], ni, po) %*% t(a)
data[, indm] <- zij
return(data)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Test Statistic for the Hawkins Homoscedasticity Test ####
.Hawkins <- function(y, spatcnt) {
n <- nrow(y)
p <- ncol(y)
g <- length(spatcnt)
spool <- matrix(0L, p, p)
gind <- c(0L, spatcnt)
ygc <- matrix(0L, n, p)
ni <- matrix(0L, g, 1L)
for (i in seq_len(g)) {
yg <- y[seq(gind[i] + 1L, gind[i + 1L]), ]
ni[i] <- nrow(yg)
spool <- spool + (ni[i] - 1L) * stats::cov(yg)
ygmean <- colMeans(yg)
ygc[seq(gind[i] + 1L, gind[i + 1L]), ] <- yg - matrix(ygmean, ni[i], p, byrow = TRUE)
}
spool <- solve(spool / (n - g))
f <- matrix(0L, n, 1L)
nu <- n - g - 1L
a <- vector("list", g)
for (i in seq_len(g)) {
vij <- ygc [seq(gind[i] + 1L, gind[i + 1L]), ]
vij <- rowSums(vij %*% spool * vij)
vij <- vij*ni[i]
f[seq(gind[i] + 1L, gind[i + 1L])] <- ((n - g - p) * vij)/ (p * ((ni[i] - 1L ) * (n - g) - vij))
a[[i]] <- 1L - stats::pf(f[seq(gind[i] + 1L, gind[i + 1L])], p, (nu - p + 1L))
}
return(list(fij = f, a = a, ni = ni))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Test of Goodness of Fit (Uniformity) ####
.TestUNey <- function(x, nrep = 10000, sim = NA, n.min = 30) {
n <- length(x)
pi <- .LegNorm(x)
n4 <- (colSums(pi$p1)^2 + colSums(pi$p2)^2L + colSums(pi$p3)^2L + colSums(pi$p4)^2L) / n
if (isTRUE(n < n.min)) {
if (isTRUE(is.na(sim[1L]))) {
sim <- .SimNey(n, nrep)
}
pn <- length(which(sim > n4)) / nrep
} else {
pn <- stats::pchisq(n4, 4L, lower.tail = FALSE)
}
return(list(pn = pn, n4 = n4))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.SimNey <- function(n, nrep) {
pi <- .LegNorm(matrix(stats::runif(nrep * n), ncol = nrep))
n4sim <- sort((colSums(pi$p1)^2L + colSums(pi$p2)^2L + colSums(pi$p3)^2L + colSums(pi$p4)^2L) / n )
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Evaluating Legendre's Polynomials of Degree 1, 2, 3, or 4 ####
.LegNorm <- function(x) {
if (isTRUE(!is.matrix(x))) { x <- as.matrix(x) }
x <- 2L * x - 1L
p0 <- matrix(1,nrow(x), ncol(x))
p1 <- x
p2 <- (3L * x * p1 - p0) / 2L
p3 <- (5L * x * p2 - 2L * p1) / 3L
p4 <- (7L * x * p3 - 3L * p2) / 4L
p1 <- sqrt(3L) * p1
p2 <- sqrt(5L) * p2
p3 <- sqrt(7L) * p3
p4 <- 3L * p4
return(list(p1 = p1, p2 = p2, p3 = p3, p4 = p4))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## K-Sample Anderson Darling Test ####
.AndersonDarling <- function(x, ni) {
if (isTRUE(length(ni) < 2L)) { stop("Not enough groups for the Anderson-Darling k-sample test.") }
k <- length(ni)
ni.z <- c(0L, cumsum(ni))
n <- length(x)
x.sort <- sort(x)[seq_len(n - 1L)]
ind <- which(duplicated(x.sort) == 0L)
hj <- (c(ind, length(x.sort) + 1L) - c(0L, ind))[2L:(length(ind) + 1L)]
hn <- cumsum(hj)
zj <- x.sort[ind]
adk <- 0L
adk.all <- matrix(0L, k, 1L)
for (i in seq_len(k)) {
ind <- (ni.z[i] + 1L):ni.z[i + 1L]
templist <- expand.grid(zj, x[ind])
b <- templist[, 1L] == templist[, 2L]
fij <- rowSums(matrix(b, length(zj)))
mij <- cumsum(fij)
num <- (n * mij - ni[i] * hn)^ 2L
dem <- hn*(n - hn)
adk.all[i] <- (1L / ni[i] * sum(hj * (num / dem)))
adk <- adk + adk.all[i]
}
adk <- (1L / n) * adk
adk.all <- adk.all / n
j <- sum(1L / ni)
i <- seq_len(n - 1)
h <- sum(1L / i)
g <- 0L
for (i in seq_len(n - 2L)) { g <- g + (1L / (n - i)) * sum(1L / seq((i + 1L), (n - 1L))) }
a <- (4L * g - 6L) * (k - 1L) + (10L - 6L * g) * j
b <- (2L * g - 4L) * k^2 + 8L * h * k + (2L * g - 14L * h - 4L) * j - 8L * h + 4L * g - 6L
c <- (6L * h + 2L * g - 2L) * k ^ 2L + (4L * h - 4L * g + 6L) * k + (2L * h - 6L) * j + 4L * h
d <- (2L * h + 6L) * k ^ 2L - 4L * h * k
var.adk <- ((a * n^3L) + (b * n^2L) + (c * n) + d) / ((n - 1L) * (n - 2L) * (n - 3L))
if (isTRUE(var.adk < 0L)) { var.adk <- 0L }
adk.s <- (adk - (k - 1L)) / sqrt(var.adk)
a0 <- c(0.25, 0.10, 0.05, 0.025, 0.01)
b0 <- c(0.675, 1.281, 1.645, 1.96, 2.326)
b1 <- c(-0.245, 0.25, 0.678, 1.149, 1.822)
b2 <- c(-0.105, -0.305, -0.362, -0.391, -0.396)
c0 <- log((1L - a0) / a0)
qnt <- b0 + b1 / sqrt(k - 1L) + b2 / (k - 1L)
if (isTRUE(adk.s <= qnt[3L])) {
ind <- 1L:4L
} else {
ind <- 2L:5L
}
return(list(pn = 1L / (1L + exp(stats::spline(qnt[ind], c0[ind], xout = adk.s)$y)), adk.all = adk.all, adk = adk, var.adk = var.adk))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the print.misty.object() function ---------------------
#
# - .round
# - .write.table
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .round ####
.round <- function(x, digits) {
#—————————————————————————————————————— #
### One Variable ####
if (isTRUE(is.null(dim(x)))) {
if (isTRUE(digits > 0)) {
formatC(sapply(x, function(y) ifelse(is.na(y), NA, ifelse(is.character(y) && misty::chr.trim(y) == "NA", "NA", as.numeric(y)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f", zero.print = paste0("0.", paste(rep(0L, times = digits), collapse = "")))
} else {
formatC(sapply(x, function(y) ifelse(is.na(y), NA, ifelse(is.character(y) && misty::chr.trim(y) == "NA", "NA", as.numeric(y)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f")
}
#—————————————————————————————————————— #
### More Than One Variable ####
} else {
object <- apply(x, 2L, function(y) {
if (isTRUE(digits > 0)) {
formatC(sapply(y, function(z) ifelse(is.na(z), NA, ifelse(is.character(z) && misty::chr.trim(z) == "NA", "NA", as.numeric(z)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f", zero.print = paste0("0.", paste(rep(0L, times = digits), collapse = "")))
} else {
formatC(sapply(y, function(z) ifelse(is.na(z), NA, ifelse(is.character(z) && misty::chr.trim(z) == "NA", "NA", as.numeric(z)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f")
}
}, simplify = ifelse(is.data.frame(x), FALSE, TRUE)) |> (\(p) if (isTRUE(is.data.frame(x))) { as.data.frame(p) } else { p })()
if (isTRUE(!is.null(row.names(x)))) { row.names(object) <- row.names(x) }
return(object)
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .write.table ####
.write.table <- function(print.object, left = 1L, right = 3L, line = 1L, group = FALSE, result = NULL, horiz = TRUE) {
# Data frame
print.object <- as.data.frame(print.object)
#—————————————————————————————————————— #
### Markdown knitr Engine Not in Progress ####
if (isTRUE(is.null(getOption("knitr.in.progress")) && horiz)) {
# Header
write.table(print.object[seq_len(line), , drop = FALSE], quote = FALSE, row.names = FALSE, col.names = FALSE)
#···················
#### Grouping Variable ####
if (isTRUE(group)) {
split(print.object[-1L, ], f = result$group) |>
(\(p) for (i in seq_along(p)) {
# Horizontal line
cat(paste(rep(" ", times = left), collapse = ""), paste(rep("\u2500", times = sum(nchar(print.object[1L, ])) + length(print.object[1L, ]) - right), collapse = ""), "\n")
write.table(p[[i]], quote = FALSE, row.names = FALSE, col.names = FALSE)
})()
#···················
#### No Grouping Variable ####
} else {
# Horizontal line
cat(paste(rep(" ", times = left), collapse = ""), paste(rep("\u2500", times = sum(nchar(print.object[max(seq_len(line)), ])) + length(print.object[max(seq_len(line)), ]) - right), collapse = ""), "\n")
# Output not including 'Total'
if (isTRUE(all(misty::chr.trim(print.object[, 1L]) != "Total") && (if (isTRUE(misty::chr.trim(print.object[1L, 2L]) == "Source")) { all(misty::chr.trim(print.object[, 2L]) != "Total") } else { TRUE }))) {
write.table(print.object[-seq_len(line), ], quote = FALSE, row.names = FALSE, col.names = FALSE)
# Output including 'Total', e.g, crosstab(), dominance.manual(), and dominance() functions
} else {
(which(misty::chr.trim(print.object[, ifelse(isTRUE(misty::chr.trim(print.object[1L, 2L]) != "Source"), 1L, 2L)]) == "Total") - 1L) |>
(\(p) {
write.table(print.object[(max(seq_len(line)) + 1L):p, ], quote = FALSE, row.names = FALSE, col.names = FALSE)
# Horizontal line
cat(paste(rep(" ", times = left), collapse = ""), paste(rep("\u2500", times = sum(nchar(print.object[max(seq_len(line)), ])) + length(print.object[max(seq_len(line)), ]) - right), collapse = ""), "\n")
write.table(print.object[-seq_len(p), ], quote = FALSE, row.names = FALSE, col.names = FALSE)
})()
}
}
#—————————————————————————————————————— #
### Markdown knitr Engine in Progress ####
} else {
write.table(print.object, quote = FALSE, row.names = FALSE, col.names = FALSE)
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the robust.coef() function ----------------------------
#
# - .sandw
# - .coeftest
# - .waldtest
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Making Sandwiches with Bread and Meat ####
.sandw <- function(x, type = c("HC0", "HC1", "HC2", "HC3", "HC4", "HC4m", "HC5")) {
# Hat values
diaghat <- try(hatvalues(x), silent = TRUE)
# Specify omega function
switch(type,
const = { omega <- function(residuals, diaghat, df) rep(1, length(residuals)) * sum(residuals^2L) / df },
HC0 = { omega <- function(residuals, diaghat, df) residuals^2L },
HC1 = { omega <- function(residuals, diaghat, df) residuals^2L * length(residuals)/df },
HC2 = { omega <- function(residuals, diaghat, df) residuals^2L / (1L - diaghat) },
HC3 = { omega <- function(residuals, diaghat, df) residuals^2L / (1L - diaghat)^2L },
HC4 = { omega <- function(residuals, diaghat, df) {
n <- length(residuals)
p <- as.integer(round(sum(diaghat), digits = 0L))
delta <- pmin(4L, n * diaghat/p)
residuals^2L / (1L - diaghat)^delta
}},
HC4m = { omega <- function(residuals, diaghat, df) {
gamma <- c(1.0, 1.5) ## as recommended by Cribari-Neto & Da Silva
n <- length(residuals)
p <- as.integer(round(sum(diaghat)))
delta <- pmin(gamma[1L], n * diaghat/p) + pmin(gamma[2L], n * diaghat/p)
residuals^2L / (1L - diaghat)^delta
}},
HC5 = { omega <- function(residuals, diaghat, df) {
k <- 0.7 ## as recommended by Cribari-Neto et al.
n <- length(residuals)
p <- as.integer(round(sum(diaghat)))
delta <- pmin(n * diaghat / p, pmax(4L, n * k * max(diaghat) / p))
residuals^2L / sqrt((1L - diaghat)^delta)
}})
if (isTRUE(type %in% c("HC2", "HC3", "HC4", "HC4m", "HC5"))) {
if (isTRUE(inherits(diaghat, "try-error"))) stop(sprintf("hatvalues() could not be extracted successfully but are needed for %s", type), call. = FALSE)
id <- which(diaghat > 1L - sqrt(.Machine$double.eps))
if(length(id) > 0L) {
id <- if (isTRUE(is.null(rownames(X)))) { as.character(id) } else { rownames(X)[id] }
if(length(id) > 10L) id <- c(id[1L:10L], "...")
warning(sprintf("%s covariances become numerically unstable if hat values are close to 1 as for observations %s", type, paste(id, collapse = ", ")), call. = FALSE)
}
}
# Ensure that NAs are omitted
if(is.list(x) && !is.null(x$na.action)) class(x$na.action) <- "omit"
# Extract design matrix
X <- model.matrix(x)
if (isTRUE(any(alias <- is.na(coef(x))))) X <- X[, !alias, drop = FALSE]
# Number of observations
n <- NROW(X)
# Generalized Linear Model
if (isTRUE(inherits(x, "glm"))) {
wres <- as.vector(residuals(x, "working")) * weights(x, "working")
dispersion <- if (isTRUE(substr(x$family$family, 1L, 17L) %in% c("poisson", "binomial", "Negative Binomial"))) { 1L } else { sum(wres^2L, na.rm = TRUE) / sum(weights(x, "working"), na.rm = TRUE) }
ef <- wres * X / dispersion
# Linear Model
} else {
# Weights
wts <- if (isTRUE(is.null(weights(x)))) { 1L } else { weights(x) }
ef <- as.vector(residuals(x)) * wts * X
}
# Meat
meat <- crossprod(sqrt(omega(rowMeans(ef / X, na.rm = TRUE), diaghat, n - NCOL(X))) * X) / n
# Bread
sx <- summary.lm(x)
bread <- sx$cov.unscaled * as.vector(sum(sx$df[1L:2L]))
# Sandwich
sandw <- 1L / n * (bread %*% meat %*% bread)
return(invisible(sandw))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Inference for Estimated Coefficients ####
.coeftest <- function(x, vcov = NULL) {
# Extract coefficients and standard errors
est <- coef(x)
se <- sqrt(diag(vcov))
## match using names and compute t/z statistics
if (isTRUE(!is.null(names(est)) && !is.null(names(se)))) {
if (length(unique(names(est))) == length(names(est)) && length(unique(names(se))) == length(names(se))) {
anames <- names(est)[names(est) %in% names(se)]
est <- est[anames]
se <- se[anames]
}
}
# Test statistic
stat <- as.vector(est) / se
df <- try(df.residual(x), silent = TRUE)
# Generalized Linear Model
if (isTRUE(inherits(x, "glm"))) {
pval <- 2L * pnorm(abs(stat), lower.tail = FALSE)
cnames <- c("Estimate", "SE", "z", "p")
mthd <- "z"
# Linear Model
} else {
pval <- 2L * pt(abs(stat), df = df, lower.tail = FALSE)
cnames <- c("Estimate", "SE", "t", "p")
mthd <- "t"
}
object <- cbind(est, se, stat, pval)
colnames(object) <- cnames
return(invisible(object))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Wald Test of Nested Models ####
.waldtest <- function(object, ..., vcov = NULL, name = NULL) {
coef0 <- function(x, ...) { na.omit(coef(x, ...)) }
nobs0 <- function(x, ...) {
nobs1 <- nobs
nobs2 <- function(x, ...) { NROW(residuals(x, ...)) }
object <- try(nobs1(x, ...), silent = TRUE)
if (isTRUE(inherits(object, "try-error") | is.null(object))) object <- nobs2(x, ...)
return(object)
}
df.residual0 <- function(x) {
df <- try(df.residual(x), silent = TRUE)
if (isTRUE(inherits(df, "try-error") | is.null(df))) { df <- try(nobs0(x) - attr(logLik(x), "df"), silent = TRUE) }
if (isTRUE(inherits(df, "try-error") | is.null(df))) { df <- try(nobs0(x) - length(as.vector(coef0(x))), silent = TRUE) }
if (isTRUE(inherits(df, "try-error"))) df <- NULL
return(df)
}
cls <- class(object)[1L]
# 1. Extracts term labels
tlab <- function(x) {
tt <- try(terms(x), silent = TRUE)
if (isTRUE(inherits(tt, "try-error"))) "" else attr(tt, "term.labels")
}
# 2. Extracts model name
if (isTRUE(is.null(name))) name <- function(x) {
object <- try(formula(x), silent = TRUE)
if (isTRUE(inherits(object, "try-error") | is.null(object))) { object <- try(x$call, silent = TRUE) }
if (isTRUE(inherits(object, "try-error") | is.null(object))) { return(NULL) } else { return(paste(deparse(object), collapse="\n")) }
}
# 3. Compute an updated model object
modelUpdate <- function(fm, update) {
if (isTRUE(is.numeric(update))) {
if (isTRUE(any(update < 1L))) {
warning("For numeric model specifications all values have to be >= 1", call. = FALSE)
update <- abs(update)[abs(update) > 0L]
}
if (isTRUE(any(update > length(tlab(fm))))) {
warning(paste("More terms specified than existent in the model:", paste(as.character(update[update > length(tlab(fm))]), collapse = ", ")), call. = FALSE)
update <- update[update <= length(tlab(fm))]
}
update <- tlab(fm)[update]
}
if (isTRUE(is.character(update))) {
if (isTRUE(!all(update %in% tlab(fm)))) {
warning(paste("Terms specified that are not in the model:", paste(dQuote(update[!(update %in% tlab(fm))]), collapse = ", ")), call. = FALSE)
update <- update[update %in% tlab(fm)]
}
if (isTRUE(length(update) < 1L)) { stop("Empty model specification", call. = FALSE) }
update <- as.formula(paste(". ~ . -", paste(update, collapse = " - ")))
}
if (isTRUE(inherits(update, "formula"))) {
update <- update(fm, update, evaluate = FALSE)
update <- eval(update, parent.frame(3))
}
if (isTRUE(!inherits(update, cls))) { stop(paste("Original model was of class \"", cls, "\", updated model is of class \"", class(update)[1], "\"", sep = ""), call. = FALSE) }
return(update)
}
# 4. Compare two fitted model objects
modelCompare <- function(fm, fm.up, vfun = NULL) {
q <- length(coef0(fm)) - length(coef0(fm.up))
if (isTRUE(q > 0L)) {
fm0 <- fm.up
fm1 <- fm
} else {
fm0 <- fm
fm1 <- fm.up
}
k <- length(coef0(fm1))
n <- nobs0(fm1)
# Determine omitted variables
if (isTRUE(!all(tlab(fm0) %in% tlab(fm1)))) { stop("Nesting of models cannot be determined", call. = FALSE) }
ovar <- which(!(names(coef0(fm1)) %in% names(coef0(fm0))))
if (isTRUE(abs(q) != length(ovar))) { stop("Nesting of models cannot be determined", call. = FALSE) }
# Get covariance matrix estimate
vc <- if (isTRUE(is.null(vfun))) { vcov(fm1) } else if (isTRUE(is.function(vfun))) { vfun(fm1) } else { vfun }
## Compute Chisq statistic
stat <- t(coef0(fm1)[ovar]) %*% solve(vc[ovar,ovar]) %*% coef0(fm1)[ovar]
return(c(-q, stat))
}
# Recursively fit all objects
objects <- list(object, ...)
nmodels <- length(objects)
if (isTRUE(nmodels < 2L)) {
objects <- c(objects, . ~ 1)
nmodels <- 2L
}
# Remember which models are already fitted
no.update <- sapply(objects, function(obj) inherits(obj, cls))
# Updating
for(i in 2L:nmodels) objects[[i]] <- modelUpdate(objects[[i - 1L]], objects[[i]])
# Check responses
getresponse <- function(x) {
tt <- try(terms(x), silent = TRUE)
if (isTRUE(inherits(tt, "try-error"))) { "" } else { deparse(tt[[2L]]) }
}
responses <- as.character(lapply(objects, getresponse))
sameresp <- responses == responses[1L]
if (isTRUE(!all(sameresp))) {
objects <- objects[sameresp]
warning("Models with response ", deparse(responses[!sameresp]), " removed because response differs from ", "model 1", call. = FALSE)
}
# Check sample sizes
ns <- sapply(objects, nobs0)
if (isTRUE(any(ns != ns[1L]))) {
for(i in 2L:nmodels) {
if (isTRUE(ns[1L] != ns[i])) {
if (isTRUE(no.update[i])) { stop("Models were not all fitted to the same size of dataset")
} else {
commonobs <- row.names(model.frame(objects[[i]])) %in% row.names(model.frame(objects[[i - 1L]]))
objects[[i]] <- eval(substitute(update(objects[[i]], subset = commonobs), list(commonobs = commonobs)))
if (isTRUE(nobs0(objects[[i]]) != ns[1L])) { stop("Models could not be fitted to the same size of dataset", call. = FALSE) }
}
}
}
}
# ANOVA matrix
object <- matrix(rep(NA, 4L * nmodels), ncol = 4L)
colnames(object) <- c("res.df", "df", "F", "p")
rownames(object) <- 1L:nmodels
object[, 1L] <- as.numeric(sapply(objects, df.residual0))
for(i in 2L:nmodels) object[i, 2L:3L] <- modelCompare(objects[[i - 1L]], objects[[i]], vfun = vcov)
df <- object[, 1L]
for(i in 2L:nmodels) if (isTRUE(object[i, 2L] < 0L)) { df[i] <- object[i - 1L, 1L] }
object[, 3L] <- object[, 3L] / abs(object[, 2L])
object[, 4L] <- pf(object[, 3L], abs(object[, 2L]), df, lower.tail = FALSE)
variables <- lapply(objects, name)
if (isTRUE(any(sapply(variables, is.null)))) { variables <- lapply(match.call()[-1L], deparse)[1L:nmodels] }
return(invisible(object))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the sim.lavaan() function -----------------------------
#
# https://github.com/wjschne/simstandard/blob/main/R/main.R
#
# .sim.standardized.matrices
# .str.affix
# .fixed2free
#
# https://github.com/cran/mvtnorm/blob/master/R/mvnorm.R
#
# .rmvnorm
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Returning Model Characteristics ####
.sim.standardized.matrices <- function(model, max.iter = max.iter, check = check) {
#—————————————————————————————————————— #
### Parameter Table ####
pt <- lavaan::lavParTable(model, fixed.x = FALSE)
#—————————————————————————————————————— #
### Checks ####
if (isTRUE(check)) {
# Check for formative variables
if (isTRUE(any(pt$op == "<~"))) { stop("Formative variables (defined with <~) are not allowed for this function.", call. = FALSE) }
# Check for user-set variances
if (isTRUE(any((pt$user != 0L) & (pt$lhs == pt$rhs) & (pt$op == "~~")))) {
pt_manual_var <- pt[(pt$user != 0L) & (pt$lhs == pt$rhs) & (pt$op == "~~"), ]
pt_manual_rows <- paste0(pt_manual_var$lhs, " ", pt_manual_var$op, " ", ifelse(is.na(pt_manual_var$ustart), "", paste0(pt_manual_var$ustart, " * ")), pt_manual_var$rhs, collapse = "\n")
stop(paste0("All variances are set automatically to create standardized data.", " You may not set variances manually. ", ifelse(nrow(pt_manual_var) > 1L, "Remove the following parameters:\n", "Remove the following parameter:\n"), pt_manual_rows), call. = FALSE)
}
# Check for unset paths and covariances
if (isTRUE(any(pt$free == 1L, na.rm = TRUE))) {
pt_unset <- pt[pt$free == 1L, ]
pt_unset_rows <- paste0(pt_unset$lhs, " ", pt_unset$op, " ", pt_unset$rhs, collapse = "\n")
warning(paste0(ifelse(nrow(pt_unset) > 1L, paste0("Because the following relations were not set, ", "they are assumed to be 0:\n"), paste0("Because the following relationship was not set, ", "it is assumed to be 0:\n")), pt_unset_rows), call. = FALSE)
}
# Check for paths greater than 1
if (isTRUE(any(abs(pt$ustart) > 1L, na.rm = TRUE))) {
pt_greater <- pt[abs(pt$ustart) > 1L, ]
pt_greater_rows <- paste0(pt_greater$lhs, " ", pt_greater$op, " ", pt_greater$ustart, " * ", pt_greater$rhs, collapse = "\n" )
warning(paste0("It is possible to set standardized parameters ",
"greater than 1 or less than -1, but this may causes model convergence problems. ",
"Check to make sure you set such a value on purpose. ",
ifelse(nrow(pt_greater) > 1L, "The following paths were set to values outside the range of -1 to 1:\n", "The following path was set to a value outside the range of -1 to 1:\n"), pt_greater_rows), call. = FALSE)
}
}
#—————————————————————————————————————— #
### Variable Names ####
v_all <- unique(c(pt$lhs, pt$rhs))
v_latent <- unique(pt$lhs[pt$op == "=~"])
v_observed <- v_all[!(v_all %in% v_latent)]
v_indicator <- unique(pt$rhs[pt$op == "=~"])
v_y <- unique(pt$lhs[pt$op == "~"])
v_latent_endogenous <- v_latent[(v_latent %in% v_y) | (v_latent %in% v_indicator)]
v_latent_exogenous <- v_latent[!(v_latent %in% v_latent_endogenous)]
v_observed_endogenous <- v_observed[v_observed %in% v_y | v_observed %in% v_indicator]
v_observed_exogenous <- v_observed[!v_observed %in% v_observed_endogenous]
v_observed_indicator <- v_observed[v_observed %in% v_indicator]
v_latent_indicator <- v_latent[v_latent %in% v_indicator]
v_observed_y <- v_observed_endogenous[!(v_observed_endogenous %in% v_observed_indicator)]
v_order <- c(v_observed, v_latent)
v_error_y <- .str.affix(v_observed_y, prefix = "e_")
v_disturbance <- .str.affix(v_latent_endogenous, prefix = "d_")
v_error <- .str.affix(v_observed_endogenous, prefix = "e_")
v_exogenous <- c(v_latent_exogenous, v_observed_exogenous)
v_endogenous <- c(v_latent_endogenous, v_observed_endogenous)
v_residual <- c(v_disturbance, v_error)
v_ellipse <- c(v_latent, v_residual)
v_source <- c(v_exogenous, v_residual)
v_factor_score <- v_ellipse[!(v_ellipse %in% v_error_y)]
v_FS <- .str.affix(v_factor_score, suffix = "_FS")
# Set unspecified parameters to 0
pt[is.na(pt[, "ustart"]), "ustart"] <- 0L
#—————————————————————————————————————— #
### Make RAM Matrices ####
# Names for A, S and new S matrices
vS <- vA <- c(v_endogenous, v_exogenous)
# Number of Variables
k <- length(vA)
# Initialize A matrix and exogenous correlation matrix
exo_cor <- A <- matrix(0L, k, k, dimnames = list(vA, vA))
# Assign loadings to A
for (i in pt[pt[, "op"] == "=~", "id"]) { A[pt$rhs[i], pt$lhs[i]] <- pt$ustart[i] }
# Assign regressions to A
for (i in pt[pt[, "op"] == "~", "id"]) { A[pt$lhs[i], pt$rhs[i]] <- pt$ustart[i] }
# Assign correlations to exo_cor
diag(exo_cor) <- 1L
for (i in pt[(pt[, "op"] == "~~") & pt$lhs != pt$rhs, "id"]) {
exo_cor[pt$lhs[i], pt$rhs[i]] <- pt$ustart[i]
exo_cor[pt$rhs[i], pt$lhs[i]] <- pt$ustart[i]
}
#—————————————————————————————————————— #
### Solving for Error Variances and Correlation Matrix ####
# Column of k ones
v1 <- matrix(1L, k)
# Initial estimate of error variances
varS <- as.vector(v1 - (A * A) %*% v1)
S <- diag(varS) %*% exo_cor %*% diag(varS)
# Initial estimate of the correlation matrix
iA <- solve(diag(k) - A)
R <- iA %*% S %*% t(iA)
# Set interaction count at 0
iterations <- 0L
# Find values for S matrix
while ((round(sum(diag(R)), digits = 10) != k) * (iterations < max.iter)) {
R <- iA %*% S %*% t(iA)
sdS <- diag(diag(S) ^ 0.5)
S <- diag(diag(diag(k) - R)) + (sdS %*% exo_cor %*% sdS)
diag(S)[diag(S) < 0] <- 0.00000001
iterations <- iterations + 1L
}
if (iterations >= max.iter) { stop(paste0("Model did not converge after ", max.iter, " iterations because at least one variable had a negative variance: ", paste0(colnames(A)[(diag(S) == 0.00000001)], collapse = ", ")), call. = FALSE) }
dimnames(S) <- dimnames(A)
# Filter Matrix
filter_matrix <- diag((vA %in% v_observed) * 1L)
dimnames(filter_matrix) <- dimnames(A)
# Big Matrices----
A_residual_diag <- sqrt(diag(S[v_endogenous, v_endogenous, drop = FALSE]))
if (isTRUE(length(A_residual_diag) > 1L)) {
A_residual <- diag(A_residual_diag)
} else {
if (length(A_residual_diag) == 1) {
A_residual <- matrix(A_residual_diag, nrow = 1L, ncol = 1L)
} else {
A_residual <- matrix(nrow = 0L, ncol = 0L)
}
}
A_big <- rbind(cbind(A[v_endogenous, , drop = FALSE], A_residual), matrix(0L, nrow = nrow(A), ncol = nrow(A) + length(v_residual)))
v_big <- c(vA, v_residual)
dimnames(A_big) <- list(v_big, v_big)
# Initialize S_big
S_big <- matrix(0L, nrow = length(v_big), ncol = length(v_big), dimnames = dimnames(A_big) )
# Insert off-diagonal values of S into S_big
S_big[v_source, v_source] <- exo_cor[c(v_exogenous, v_endogenous), c(v_exogenous, v_endogenous), drop = FALSE]
# Insert diagonal values of S_big
diag(S_big) <- c(rep(0L, length(v_endogenous)), rep(1L, length(v_exogenous) + length(v_residual)))
# Compute big correlation matrix of all variables
iA_big <- solve(diag(nrow(A_big)) - A_big)
R_big <- iA_big %*% S_big %*% t(iA_big)
R_xx <- R_big[v_observed_indicator, v_observed_indicator, drop = FALSE]
R_xy <- R_big[v_observed_indicator, v_factor_score, drop = FALSE]
#—————————————————————————————————————— #
### Factor and Composite Scores ####
if (isTRUE(length(v_observed_indicator) > 0L)) {
i_Rxx <- solve(R_xx)
A_factor_score <- i_Rxx %*% R_xy
colnames(A_factor_score) <- v_factor_score
if (isTRUE(length(v_latent) > 0L)) {
v_composite_score <- paste0(v_latent, "_Composite")
} else {
v_composite_score <- character(0L)
}
# Matrix of which observed variables are summed to create composite scores for each latent variable
A_composite <- matrix(0L, nrow = length(v_observed_indicator), ncol = length(v_latent), dimnames = list(v_observed_indicator, v_latent))
find_observed_indicators <- function(v) {
indicators <- pt[pt[,"op"] == "=~" & pt[,"lhs"] == v, "rhs"]
observed_indicators <- indicators[indicators %in% v_observed_indicator]
latent_indicators <- indicators[indicators %in% v_latent]
if (length(latent_indicators > 0)) {
for (li in latent_indicators) {
observed_indicators <- c(observed_indicators,find_observed_indicators(li))
}
}
unique(observed_indicators)
}
for (v in v_latent) {
which_indicators <- find_observed_indicators(v)
A_composite[which_indicators, v] <- sign(R_big[which_indicators, v])
}
CM_composite <- t(A_composite) %*% R[v_observed_indicator, v_observed_indicator, drop = FALSE] %*% A_composite
A_composite_w <- A_composite %*% diag(diag(CM_composite) ^ -0.5, nrow = nrow(CM_composite))
colnames(A_composite_w) <- v_composite_score
colnames(A_factor_score) <- v_FS
# Factor weights
fw <- cbind(A_factor_score, A_composite_w)
W <- matrix(0L, nrow = nrow(A_big), ncol = nrow(A_big) + ncol(fw), dimnames = list(rownames(A_big), c(rownames(A_big), colnames(fw))))
diag(W) <- 1L
W[rownames(fw), colnames(fw)] <- fw
# Grand correlation matrix of all variables
R_all <- stats::cov2cor(t(W) %*% R_big %*% W)
v_order_all <- c(v_order, v_residual, v_FS, v_composite_score)
R_all <- R_all[v_order_all, v_order_all]
} else {
R_all <- R_big
A_factor_score <- NULL
A_composite_w <- NULL
v_FS <- character(0L)
v_composite_score <- character(0L)
}
# Make complete lavaan model syntax
lavaan_variances <- paste0(v_order, " ~~ ", diag(S[v_order, v_order]), " * ", v_order, collapse = "\n")
# Factor Score Validity
factor_score_validity <- diag(R_all[v_FS, v_factor_score, drop = FALSE])
names(factor_score_validity) <- v_FS
factor_score_se <- sqrt(1 - factor_score_validity^2L)
# Composite Score Validity
composite_score_validity <- diag(R_all[v_latent, v_composite_score, drop = FALSE])
names(composite_score_validity) <- v_composite_score
#—————————————————————————————————————— #
### Return Object ####
l_names <- list(v_observed = v_observed,
v_latent = v_latent,
v_latent_exogenous = v_latent_exogenous,
v_latent_endogenous = v_latent_endogenous,
v_observed_exogenous = v_observed_exogenous,
v_observed_endogenous = v_observed_endogenous,
v_observed_indicator = v_observed_indicator,
v_disturbance = v_disturbance,
v_error = v_error,
v_residual = v_residual,
v_factor_score = .str.affix(v_latent, suffix = "_FS"),
v_factor_score_disturbance = .str.affix(v_disturbance, suffix = "_FS"),
v_factor_score_error = .str.affix(v_error, suffix = "_FS"),
v_composite_score = v_composite_score)
object <- list(RAM_matrices = list(A = A[v_order, v_order], S = S[v_order, v_order], filter_matrix = filter_matrix[v_order, v_order], iA = iA[v_order, v_order]),
correlations = list(R = R[v_order, v_order], R_all = R_all),
coefficients = list(factor_score = A_factor_score,
factor_score_validity = factor_score_validity,
factor_score_se = factor_score_se,
composite_score = A_composite_w,
composite_score_validity = composite_score_validity),
lavaan_models = list(model_without_variances = model,
model_with_variances = paste0(model, "\n# Variances\n", lavaan_variances),
model_free = .fixed2free(model)),
v_names = l_names, iterations = iterations)
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Affix a Prefix and/or Suffix to a Vector ####
.str.affix <- function(x, prefix = "", suffix = "", ...) {
if (isTRUE(length(x) == 0L)) { return(character(0)) }
return(paste0(prefix, x, suffix, ...))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Removing Fixed Parameters from a lavaan Model ####
.fixed2free <- function(model) {
model <- sapply(lavaan::lavaanify(model, fixed.x = FALSE) |> (\(p) p[p$lhs != p$rhs, ])() |>
(\(q) data.frame(split = factor(paste(q$lhs, q$op), levels = unique(paste(q$lhs, q$op))), q))() |>
(\(r) split(r, f = (r$split)))(), function(y) { paste(y$rhs, collapse = " + ") }) |>
(\(s) paste(paste(names(s), s), collapse = "\n"))()
return(model)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Random Number Generator for the Multivariate Normal Distribution ####
.rmvnorm <- function(n, mean = rep(0L, nrow(sigma)), sigma = diag(length(mean)),
method = c("eigen", "svd", "chol"), pre0.9_9994 = FALSE, checkSymmetry = FALSE,
rnorm = stats::rnorm) {
if (isTRUE(checkSymmetry && !isSymmetric(sigma, tol = sqrt(.Machine$double.eps), check.attributes = FALSE))) { stop("Sigma must be a symmetric matrix", call. = FALSE) }
if (isTRUE(length(mean) != nrow(sigma))) { stop("Mean and sigma have non-conforming size", call. = FALSE) }
method <- match.arg(method)
R <- switch(method, "eigen" = {
ev <- eigen(sigma, symmetric = TRUE)
if (isTRUE(!all(ev$values >= -sqrt(.Machine$double.eps) * abs(ev$values[1L])))) { warning("sigma is numerically not positive semidefinite", call. = FALSE) }
t(ev$vectors %*% (t(ev$vectors) * sqrt(pmax(ev$values, 0L))))
}, "svd" = {
s. <- svd(sigma)
if (isTRUE(!all(s.$d >= -sqrt(.Machine$double.eps) * abs(s.$d[1L])))) { warning("sigma is numerically not positive semidefinite", call. = FALSE) }
t(s.$v %*% (t(s.$u) * sqrt(pmax(s.$d, 0L))))
}, "chol" = {
chol(sigma, pivot = TRUE) |> (\(p) p[, order(attr(p, "pivot"))])()
})
retval <- sweep(matrix(rnorm(n * ncol(sigma)), nrow = n, byrow = !pre0.9_9994) %*% R, 2L, mean, "+")
colnames(retval) <- names(mean)
return(retval)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Function for Writing Results ————————————————————————————————————————
.write.result <- function(object, write, append) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Text file ####
if (isTRUE(grepl("\\.txt", write))) {
# Send R output to text file
sink(file = write, append = ifelse(isTRUE(file.exists(write)), append, FALSE), type = "output", split = FALSE)
if (isTRUE(append && file.exists(write))) { write("", file = write, append = TRUE) }
# Print object
print(object, horiz = FALSE, check = FALSE)
# Close file connection
sink()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Excel file ####
} else {
misty::write.result(object, file = write)
}
}
#_______________________________________________________________________________
Try the misty package in your browser
Any scripts or data that you put into this service are public.
misty documentation built on Aug. 2, 2026, 9:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions .r2mlm .extract.section splitFilePath convert_to_filelist .detect.mplus os is.linux is.macos is.windows .extract.lca.result .section.ind.from.to .delta_var .delta_mean_item .expected_value .item_dmacs .dmacs_summary_single .dmacs_summary .chr.round .sim.fit .sim.data.categ .contord .ordsample .sim.data.likert .items.n.crossload .cross.load .misspec.multi .resid.cov .items.no.cor .misspec.one .n.factors .cot .csc .polar2r .r2polar .opdyke .opdyke.percentiles .icomp .sic .ibic .spbic .hbic .hqc .aicc .sabic .caic .cor.polyserial .it.cor .adt.cor .model.fit.param .conv.ident .p2 .refit .polycorLavaan .getThreshold .categ.omega .omega .alpha .qprodnormalMeeker .get_ncp_chi .fei .cohen.w .cont .tschuprow .cramer .phi .DA .combinations .domin .find.c2 .binBvn .cor.test.kendall.c .cor.test.kendall.b .cor.test.spearman .cor.test.pearson .internal.d.function .reverse.helmert .forward.helmert .contr.repeat .contr.sum .output_template .allocate_column .make_names .plot.boot .plot.ci .prop.diff.conf .m.diff.conf .boot.func.sd .sd.conf .boot.func.var .var.conf .prop.conf .boot.func.median .med.conf .boot.func.mean .m.conf .ci.boot .ci.boot.cor .boot.func.cor .norm.inter .write.result .rmvnorm .fixed2free .str.affix .sim.standardized.matrices .waldtest .coeftest .sandw .write.table .round .AndersonDarling .LegNorm .SimNey .TestUNey .Hawkins .MimputeS .Mimpute .Impute .Ddf .Sexpect .Mls .DelLessData .OrderMissing .TestMCARNormality .LittleMCAR .var.random .cohens.d.na.auxiliary .variable.section .sort_variables .get_interaction_vars .get_cwc .get_random_slope_vars .get_covs .add_interaction_vars_to_data .prepare_data .r2mlm_manual .r2mlm_nlme .r2mlm_lmer .ci.kendall.c .ci.kendall.c.estimate .ci.kendall.b .ci.spearman.cor.se .ci.pearson.cor.adjust .estskkufun .zciofrfun .smpmjkfun .smpmomvecfun .Tf2fun .VMparstomoms .sqerrVMintr .sqerrVMc .multsolvefun .worker .getMatches .filterOverlap .fastReplace .calc_ranef .resid.partial .fitBootSample .getBootSample .trans2 .trans1 .mcse .ess .autocovariance .zscale .split.chains .rhat .hdi .map .detect_blimp_windows .detect_blimp_linux .detect_blimp_macos .detect.blimp .blimp.source .as.na .exclude.non.numeric .var.group .var.names .check.input
#_______________________________________________________________________________
#
# Internal Functions
#
# Collection of internal functions used within functions of the misty package
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Check Argument Specification -------------------------------------------------
.check.input <- function(logical = NULL, numeric = NULL, character = NULL, m.character = NULL, s.character = NULL, args = NULL, package = NULL, envir = environment(), input.check = check) {
# Check input 'input.check'
if (isTRUE(!is.null(dim(input.check)) || length(input.check) != 1L || !is.logical(input.check) || is.na(input.check))) { stop("Please specify TRUE or FALSE for the argument 'check'.", call. = FALSE) }
# Check inputs
if (isTRUE(input.check)) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check TRUE/FALSE Input ####
if (isTRUE(!is.null(logical))) { invisible(sapply(logical, function(y) { eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!is.null(dim(p)) || length(p) != 1L || !is.logical(p) || is.na(p))) { stop(paste0("Please specify TRUE or FALSE for the argument '", y, "'."), call. = FALSE) })() })) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Numeric Input ####
if (isTRUE(!is.null(numeric))) {
invisible(sapply(names(numeric), function(y) {
eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!all(is.na(p)) && !is.null(p) && (!is.numeric(p) || length(p) != numeric[[y]]))) {
if (isTRUE(numeric[[y]] == 1L)) {
stop(paste0("Please specify a numeric value for the argument '", y, "'."), call. = FALSE)
} else {
stop(paste0("Please specify a numeric vector with ", switch(as.character(numeric[[y]]), "1" = "one", "2" = "two", "3" = "three", "4" = "four"), " elements for the argument '", y, "'."), call. = FALSE)
}
})()
}))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Character Input ####
if (isTRUE(!is.null(character))) {
invisible(sapply(names(character), function(y) {
eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!is.null(p) && (!is.character(p) || length(p) != character[[y]]))) {
if (isTRUE(character[[y]] == 1L)) {
stop(paste0("Please specify a character string for the argument '", y, "'."), call. = FALSE)
} else {
stop(paste0("Please specify a character vector with ", switch(as.character(character[[y]]), "1" = "one", "2" = "two", "3" = "three", "4" = "four", "5" = "five", "6" = "six"), " elements for the argument '", y, "'."), call. = FALSE)
}
})()
}))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Multiple Character Input ####
if (isTRUE(!is.null(m.character))) {
invisible(sapply(names(m.character), function(y) eval(parse(text = y), envir = envir) |> (\(p) {
if (isTRUE(!any(is.character(p)) || any(is.na(p)))) {
stop(paste0("Please specify a character string or character vector for the argument ", sQuote(y, q = FALSE)), call. = FALSE)
}
if (isTRUE(any(!p %in% m.character[[y]]))) {
if (isTRUE(length(p) == 1L)) {
stop(paste0("Character string specified in the argument '", y , "' does not match with ", paste0(paste(unlist(m.character[y]) |> (\(q) paste(sapply(q[-length(q)], dQuote, q = FALSE)))(), collapse = ", "), ", or ", dQuote(rev(unlist(m.character[y]))[1L], q = FALSE)), "."), call. = FALSE)
} else {
stop(paste0("Character strings specified in the argument '", y , "' do not all match with ", paste0(paste(unlist(m.character[y]) |> (\(q) paste(sapply(q[-length(q)], dQuote, q = FALSE)))(), collapse = ", "), ", or ", dQuote(rev(unlist(m.character[y]))[1L], q = FALSE)), "."), call. = FALSE)
}
}
})()))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Single Character Input ####
if (isTRUE(!is.null(s.character))) {
invisible(sapply(names(s.character), function(y) eval(parse(text = y), envir = envir) |> (\(p) if (isTRUE(!is.character(p) || any(!p %in% s.character[[y]]) || (!all(p %in% s.character[[y]]) && length(p) != 1L))) {
stop(paste0("Please specify ", paste0(paste(unlist(s.character[y]) |> (\(p) paste(sapply(p[-length(p)], dQuote, q = FALSE)))(), collapse = ", "), ", or ", dQuote(rev(unlist(s.character[y]))[1L], q = FALSE)), " for the argument ", sQuote(y, q = FALSE), "."), call. = FALSE)
})()))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Additional Arguments ####
if (isTRUE(!is.null(args))) {
# Check input 'alpha'
if (isTRUE("alpha" %in% args)) { eval(parse(text = "alpha"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'alpha'", call. = FALSE) })() }
# Check input 'alternative'
if (isTRUE("alternative" %in% args)) { eval(parse(text = "alternative"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("two.sided", "less", "greater") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("two.sided", "less", "greater"))))) { stop("Character string specified in the argument 'alternative' does not match with \"two.sided\", \"less\", or \"greater\".", call. = FALSE) })() }
# Check input 'conf.level'
if (isTRUE("conf.level" %in% args)) { eval(parse(text = "conf.level"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'start'", call. = FALSE) })() }
# Check input 'color'
if (isTRUE("color" %in% args)) { eval(parse(text = "color"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && all(y != "default") && (!is.character(y) || any(!y %in% c("black", "red", "green", "yellow", "blue", "violet", "cyan", "white", "gray1", "gray2", "gray3", "b.red", "b.green", "b.yellow", "b.blue", "b.violet", "b.cyan", "b.white"))))) { stop("Character string specified in the argument 'color' does not match with \"black\", \"red\", \"green\", \"yellow\", \"blue\", \"violet\", \"cyan\", \"white\", \"gray1\" etc.", call. = FALSE) })() }
# Check input 'digits'
if (isTRUE("digits" %in% args)) { eval(parse(text = "digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'digits'.", call. = FALSE) })() }
# Check input 'end'
if (isTRUE("end" %in% args)) { eval(parse(text = "end"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specifiy a numeric value between 0 and 1 for the argument 'end '.", call. = FALSE) })() }
# Check input 'ess.digits'
if (isTRUE("ess.digits" %in% args)) { eval(parse(text = "ess.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'ess.digits'.", call. = FALSE) })() }
# Check input 'facet.scales'
if (isTRUE("facet.scales" %in% args)) { eval(parse(text = "facet.scales"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("fixed", "free_x", "free_y", "free") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("fixed", "free_x", "free_y", "free"))))) { stop("Character string specified in the argument 'facet.scales' does not match with \"fixed\", \"free_x\", \"free_y\", or \"free\".", call. = FALSE) })() }
# Check input 'fit.digits'
if (isTRUE("fit.digits" %in% args)) { eval(parse(text = "fit.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'fit.digits'.", call. = FALSE) })() }
# Check input 'hist.alpha'
if (isTRUE("hist.alpha" %in% args)) { eval(parse(text = "hist.alpha"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specifiy a numeric value between 0 and 1 for the argument 'hist.alpha '.", call. = FALSE) })() }
# Check input 'ic.digits'
if (isTRUE("ic.digits" %in% args)) { eval(parse(text = "ic.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'ic.digits'.", call. = FALSE) })() }
# Check input 'icc.digits'
if (isTRUE("icc.digits" %in% args)) { eval(parse(text = "icc.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'icc.digits'.", call. = FALSE) })() }
# Check input 'legend.position'
if (isTRUE("legend.position" %in% args)) { eval(parse(text = "legend.position"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("right", "top", "left", "bottom", "none") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("right", "top", "left", "bottom", "none"))))) { stop("Character string specified in the argument 'legend.position' does not match with \"right\", \"top\", \"left\", \"bottom\", or \"none\".", call. = FALSE) })() }
# Check input 'linetype'
if (isTRUE("linetype" %in% args)) { eval(parse(text = "linetype"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.character(y) || any(!y %in% c("twodash", "solid", "longdash", "dotted", "dotdash", "dashed"))))) { stop("Character string specified in the argument 'linetype' does not match with \"twodash\", \"solid\", \"longdash\", \"dotted\", \"ldotdash\", or \"dashed\".", call. = FALSE) })() }
# Check input 'mcse.digits'
if (isTRUE("mcse.digits" %in% args)) { eval(parse(text = "mcse.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'mcse.digits'.", call. = FALSE) })() }
# Check input 'n'
if (isTRUE("n" %in% args)) { eval(parse(text = "n"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'n'.", call. = FALSE) })() }
# Check input 'nrep'
if (isTRUE("nrep" %in% args)) { eval(parse(text = "nrep"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'nrep'.", call. = FALSE) })() }
# Check input 'p.adj'
if (isTRUE("p.adj" %in% args)) { eval(parse(text = "p.adj"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("none", "holm", "bonferroni", "hochberg", "hommel", "BH", "BY", "fdr") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("none", "holm", "bonferroni", "hochberg", "hommel", "BH", "BY", "fdr"))))) { stop("Character string specified in the argument 'p.adj' does not match with \"none\", \"bonferroni\", \"holm\", \"hochberg\", \"hommel\", \"BH\", \"BY\", or \"fdr\".", call. = FALSE) })() }
# Check input 'p.digits'
if (isTRUE("p.digits" %in% args)) { eval(parse(text = "p.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'p.digits'.", call. = FALSE) })() }
# Check input 'res.cor'
if (isTRUE("res.cor" %in% args)) { eval(parse(text = "res.cor"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'res.cor'", call. = FALSE) })() }
# Check input 'r.digits'
if (isTRUE("r.digits" %in% args)) { eval(parse(text = "r.digits"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y %% 1L != 0L || y < 0L))) { stop("Please specify a positive integer number for the argument 'r.digits'.", call. = FALSE) })() }
# Check input 'seed'
if (isTRUE("seed" %in% args)) { eval(parse(text = "seed"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (length(y) != 1L || (mode(y) != "numeric")))) { stop("Please specify a numeric value for the argument 'seed'.", call. = FALSE) })() }
# Check input 'sensitiv'
if (isTRUE("sensitiv" %in% args)) { eval(parse(text = "sensitiv"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'sensitiv'", call. = FALSE) })() }
# Check input 'specific'
if (isTRUE("specific" %in% args)) { eval(parse(text = "specific"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specify a numeric value between 0 and 1 for the argument 'specific'", call. = FALSE) })() }
# Check input 'start'
if (isTRUE("start" %in% args)) { eval(parse(text = "start"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.numeric(y) || length(y) != 1L || y >= 1L || y <= 0L))) { stop("Please specifiy a numeric value between 0 and 1 for the argument 'start '.", call. = FALSE) })() }
# Check input 'units'
if (isTRUE("units" %in% args)) { eval(parse(text = "units"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && !all(c("in", "cm", "mm", "px") %in% y) && (length(y) != 1L || !is.character(y) || any(!y %in% c("in", "cm", "mm", "px"))))) { stop("Character string specified in the argument 'units' does not match with \"in\", \"cm\", \"mm\", or \"px\".", call. = FALSE) })() }
# Check input 'write' text file
if (isTRUE("write1" %in% args)) { eval(parse(text = "write"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.null(y) && (!is.character(y) || !grepl(".txt", y))))) { stop("Please specify a character string with file extenstion '.txt' for the argument 'write'.") })() }
# Check input 'write' text and Excel file
if (isTRUE("write2" %in% args)) { eval(parse(text = "write"), envir = envir) |> (\(y) if (isTRUE(!is.null(y) && (!is.null(y) && (!is.character(y) || all(!misty::chr.grepl(c(".txt", ".xlsx"), y)))))) { stop("Please specify a character string with file extenstion '.txt' or '.xlsx' for the argument 'write'.") })() }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check Packages ####
if (isTRUE(!is.null(package))) { invisible(sapply(package, function(y) { if (isTRUE(!requireNamespace(y, quietly = TRUE))) { stop(paste0("Package \"", y ,"\" is needed for this function to work, please install it."), call. = FALSE) } })) }
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Extract Variable Names Specified in the ... Argument ------------------------
.var.names <- function(data, ..., group = NULL, split = NULL, cluster = NULL, id = NULL, obs = NULL, day = NULL, time = NULL) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check if Input 'data' is a Data Frame ####
# Check if input 'data' is data frame
if (isTRUE(!is.data.frame(data))) { stop("Please specify a data frame for the argument 'data'.", call. = FALSE) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Convert Tibble into Data Frame ####
if (isTRUE("tbl" %in% substr(class(data), 1L, 3L))) { data <- as.data.frame(data) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Extract Elements in the '...' Argument ####
var.names <- sapply(substitute(list(...)), as.character)[-1L]
#—————————————————————————————————————— #
### Check for ! operators ####
var.names.excl <- sapply(var.names, function(y) any(y %in% "!"))
if (isTRUE(any(var.names.excl))) {
for (i in which(var.names.excl)) {
var.names.i <- unlist(strsplit(var.names[[i]], ""))
# Plus (+) Operator
if (isTRUE("+" %in% var.names.i)) {
var.names[[i]] <- unlist(strsplit(var.names[[i]], "(?=[/+])", perl = TRUE))
# Minus (-) Operator
} else if (isTRUE("-" %in% var.names.i)) {
var.names[[i]] <- unlist(strsplit(var.names[[i]], "(?=[/-])", perl = TRUE))
# Tilde (~) Operator
} else if (isTRUE("~" %in% var.names.i)) {
var.names[[i]] <- unlist(strsplit(var.names[[i]], "(?=[/~])", perl = TRUE))
# Colon (:) operator
} else if (isTRUE(sum(var.names.i %in% ":") == 1L)) {
var.names[[i]] <- c("!", ":", unlist(strsplit(var.names[[i]], ":"))[2L:3L])
# Double Colon (::) Operator
} else if (isTRUE(sum(var.names.i %in% ":") == 2L)) {
var.names[[i]] <- c("!", "::", unlist(strsplit(var.names[[i]], "::"))[2L:3L])
}
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Remove Variables ####
var.exclude <- NULL
#—————————————————————————————————————— #
### Starts with a Prefix: List Elements with + ####
var.plus <- sapply(var.names, function(y) any(y == "+"))
if (isTRUE(any(var.plus))) {
# List elements with +
for (i in which(var.plus)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "+", check = FALSE)
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- colnames(data)[which(substr(colnames(data), start = 1L, stop = nchar(var.i)) == var.i)]
# Complement !
} else {
var.i <- misty::chr.omit(var.i, omit = "!", check = FALSE)
var.exclude <- c(var.exclude, colnames(data)[which(substr(colnames(data), start = 1L, stop = nchar(var.i)) == var.i)])
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Ends with a Suffix: List Elements with - ####
var.minus <- sapply(var.names, function(y) any(y == "-"))
if (isTRUE(any(var.minus))) {
# List elements with -
for (i in which(var.minus)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "-", check = FALSE)
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- colnames(data)[which(substr(colnames(data), start = nchar(colnames(data)) - nchar(var.i) + 1L, stop = nchar(colnames(data))) == var.i)]
# Complement !
} else {
var.i <- misty::chr.omit(var.i, omit = "!", check = FALSE)
var.exclude <- c(var.exclude, colnames(data)[which(substr(colnames(data), start = nchar(colnames(data)) - nchar(var.i) + 1L, stop = nchar(colnames(data))) == var.i)])
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Contains a Literal String: List Elements with ~ ####
var.tilde <- sapply(var.names, function(y) any(y == "~"))
if (isTRUE(any(var.tilde))) {
# List elements with ~
for (i in which(var.tilde)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "~", check = FALSE)
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- grep(var.i, colnames(data), value = TRUE)
# Complement !
} else {
var.exclude <- c(var.exclude, misty::chr.grep(misty::chr.omit(var.i, omit = "!", check = FALSE), colnames(data), value = TRUE))
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Consecutive Variables: List Elements with : ####
var.colon <- sapply(var.names, function(y) any(y == ":"))
if (isTRUE(any(var.colon))) {
# List elements with :
for (i in which(var.colon)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = ":", check = FALSE)
setdiff(misty::chr.omit(var.i, omit = "!", check = FALSE), colnames(data)) |>
(\(y) if (isTRUE(length(y) != 0L)) {
stop(paste0(ifelse(length(y) == 1L, "Variable name involved in the : operator was not found in 'data': ", "Variable names involved in the : operator were not found in 'data': "), paste0(y, collapse = ", ")), call. = FALSE)
})()
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- colnames(data)[which(colnames(data) == var.i[1L]):which(colnames(data) == var.i[2L])]
# Complement !
} else {
var.exclude <- c(var.exclude, colnames(data)[which(colnames(data) == var.i[2L]):which(colnames(data) == var.i[3L])])
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### Numerical Range: List Elements with :: ####
var.dcolon <- sapply(var.names, function(y) any(y == "::"))
if (isTRUE(any(var.dcolon))) {
# List elements with ::
for (i in which(var.dcolon)) {
# Variable names
var.i <- misty::chr.omit(var.names[[i]], omit = "::", check = FALSE)
var.j <- misty::chr.omit(var.i, omit = "!", check = FALSE)
# Check if more than two variables were specified in the : operator
if (isTRUE(length(misty::chr.omit(unlist(strsplit(var.j, ":")), omit = "", check = FALSE)) > 2L)) { stop("More than two variables specified in the : operator.", call. = FALSE) }
# Split starting variable
var.i1.split <- unlist(strsplit(var.j[1L], "", fixed = TRUE))
# Split ending variable
var.i2.split <- unlist(strsplit(var.j[2L], "", fixed = TRUE))
# Numeric values starting variable
var.i1.log <- sapply(var.i1.split, function(y) y %in% as.character(0L:9L))
# Numeric values ending variable
var.i2.log <- sapply(var.i2.split, function(y) y %in% as.character(0L:9L))
# Variable name root starting variable
var.i1.root <- paste0(var.i1.split[-((max(which(var.i1.log == FALSE)) + 1L):length(var.i1.split))], collapse = "")
# Variable name root ending variable
var.i2.root <- paste0(var.i2.split[-((max(which(var.i2.log == FALSE)) + 1L):length(var.i2.split))], collapse = "")
# Check if variable names match
if (var.i1.root != var.i2.root) { stop(paste0("Variable names involvd in the :: operator do not match: ", paste(var.i1.root, "vs.", var.i2.root)), call. = FALSE) }
# No complement !
if (isTRUE(!"!" %in% var.i)) {
var.names[[i]] <- paste0(var.i1.root,
as.numeric(paste(var.i1.split[(max(which(var.i1.log == FALSE)) + 1L):length(var.i1.split)], collapse = "")):
as.numeric(paste(var.i2.split[(max(which(var.i2.log == FALSE)) + 1L):length(var.i2.split)], collapse = "")))
} else {
var.exclude <- c(var.exclude,
paste0(var.i1.root,
as.numeric(paste(var.i1.split[(max(which(var.i1.log == FALSE)) + 1L):length(var.i1.split)], collapse = "")):
as.numeric(paste(var.i2.split[(max(which(var.i2.log == FALSE)) + 1L):length(var.i2.split)], collapse = ""))))
var.names[[i]] <- ""
}
}
}
#—————————————————————————————————————— #
### List Elements with ! ####
var.exclude <- c(var.exclude, unlist(sapply(var.names, function(y) if (isTRUE(any(y == "!"))) { misty::chr.omit(y, omit = "!", check = FALSE) } )))
var.names <- var.names[which(sapply(var.names, function(y) !"!" %in% y))]
#—————————————————————————————————————— #
### Remove "" Elements ####
var.names <- misty::chr.omit(var.names, omit = "", check = FALSE)
#—————————————————————————————————————— #
### Unique Element ####
var.names <- unique(var.names)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Select All Variables ####
if (isTRUE(length(var.names) == 0L)) { var.names <- colnames(data) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Grouping, Split, Cluster and Other Variables ####
#—————————————————————————————————————— #
### Exclude Grouping Variable ####
if (isTRUE(!is.null(group))) {
if (isTRUE(!is.character(group) || length(group) != 1L)) { stop("Please specify a character string for the argument 'group'.", call. = FALSE) }
if (isTRUE(!group %in% colnames(data))) { stop("Grouping variable specifed in 'group' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, group)
}
#—————————————————————————————————————— #
### Exclude Split Variable ####
if (isTRUE(!is.null(split))) {
if (isTRUE(!is.character(split) || length(split) != 1L)) { stop("Please specify a character string for the argument 'split'.", call. = FALSE) }
if (isTRUE(!split %in% colnames(data))) { stop("Split variable specifed in 'split' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, split)
}
#—————————————————————————————————————— #
### Exclude Cluster Variable ####
if (isTRUE(!is.null(cluster))) {
if (isTRUE(!is.character(cluster) || !length(cluster) %in% c(1L, 2L))) { stop("Please specify a character vector for the argument 'cluster'.", call. = FALSE) }
#···················
#### One Cluster Variable ####
if (isTRUE(length(cluster) == 1L)) {
if (isTRUE(!cluster %in% colnames(data))) { stop("Cluster variable specifed in 'cluster' was not found in 'data'.", call. = FALSE) }
#···················
#### Two Cluster Variables ####
} else {
# Cluster variable in 'data'
(!cluster %in% colnames(data)) |>
(\(y) if (isTRUE(any(y))) {
if (isTRUE(sum(y) == 1L)) {
stop(paste0("Cluster variable specifed in 'cluster' was not found in 'data': ", cluster[which(y)]), call. = FALSE)
} else {
stop("Cluster variables specifed in 'cluster' were not found in 'data'.", call. = FALSE)
}
})()
# Order of cluster variables
suppressWarnings(tapply(data[, cluster[2L]], data[, cluster[1L]], var, na.rm = TRUE)) |>
(\(y) if (isTRUE(all(y == 0) || all(is.na(y)))) { stop("Please specify the Level 3 cluster variable first, e.g., cluster = c(\"level3\", \"level2\").", call. = FALSE) })()
}
var.names <- setdiff(var.names, cluster)
}
#—————————————————————————————————————— #
### Exclude 'id' Variable ####
if (isTRUE(!is.null(id))) {
if (isTRUE(!is.character(id) || length(id) != 1L)) { stop("Please specify a character string for the argument 'id'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Split variable specifed in 'id' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, id)
}
#—————————————————————————————————————— #
### Exclude 'obs' Variable ####
if (isTRUE(!is.null(obs))) {
if (isTRUE(!is.character(obs) || length(obs) != 1L)) { stop("Please specify a character string for the argument 'obs'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Observation number variable specifed in 'obs' was not found in 'data'.", call. = FALSE) }
if (isTRUE(any(sapply(split(obs, id), function(x) length(x) != length(unique(x)))))) { stop("There are duplicated observations specified in 'obs' within subjects specified in 'id'.", call. = FALSE) }
var.names <- setdiff(var.names, obs )
}
#—————————————————————————————————————— #
### Exclude 'day' Variable ####
if (isTRUE(!is.null(day))) {
if (isTRUE(!is.character(day) || length(day) != 1L)) { stop("Please specify a character string for the argument 'day'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Day variable specifed in 'day' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, day)
}
#—————————————————————————————————————— #
### Exclude 'time' Variable ####
if (isTRUE(!is.null(time))) {
if (isTRUE(!is.character(time) || length(time) != 1L)) { stop("Please specify a character string for the argument 'time'.", call. = FALSE) }
if (isTRUE(!id %in% colnames(data))) { stop("Date and time variable specifed in 'time' was not found in 'data'.", call. = FALSE) }
var.names <- setdiff(var.names, time)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Remove Variables ####
if (isTRUE(!is.null(var.exclude))) { var.names <- setdiff(var.names, var.exclude) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Check if Variables in '...' are Available in 'data' ####
if (isTRUE(!is.null(data))) { setdiff(var.names, colnames(data)) |> (\(y) if (isTRUE(length(y) != 0L)) { stop(paste0(ifelse(length(y) == 1L, "Variable specified in '...' was not found in 'data': ", "Variables specified in '...' were not found in 'data': "), paste(y, collapse = ", ")), call. = FALSE) })() }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Return Object ####
return(var.names)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Extract Grouping, Split, or Cluster Variable —————————————————————————————————
.var.group <- function(data, group = NULL, split = NULL, cluster = NULL, id = NULL,
obs = NULL, day = NULL, time = NULL, drop = TRUE) {
# Grouping, split, or cluster variable specified with the variable name
group.chr <- split.chr <- cluster.chr <- id.chr <- obs.chr <- day.chr <- time.chr <- FALSE
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Grouping Variable ####
if (isTRUE(!is.null(group))) {
#—————————————————————————————————————— #
### Tibble ####
# Convert 'group' as tibble into data frame
if (isTRUE("tbl" %in% substr(class(group), 1L, 3L))) { group <- unname(unlist(cluster)) }
#—————————————————————————————————————— #
### Grouping Variable Specified with the Variable Name ####
group.chr <- is.character(group)
if (isTRUE(group.chr && (length(group) < nrow(data)))) {
##### Check if one grouping variable ####
if (isTRUE(length(group) > 1L)) { stop("Please specify one grouping variable for the argument 'group'.", call. = FALSE) }
##### Check if grouping variable in 'data' ####
if (isTRUE(any(!group %in% colnames(data)))) { stop("Grouping variable specifed in 'group' was not found in '...'.", call. = FALSE) }
##### Extract 'data' and 'group' ####
# Index of grouping variable in 'data'
group.col <- which(colnames(data) == group)
# Replace variable name with grouping variable
group <- data[, group.col]
# Remove grouping variable from 'data'
data <- data[, -group.col, drop = drop]
#—————————————————————————————————————— #
### Grouping Variable Not Specified with the Variable Name ####
} else {
# Check if length of grouping variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(group)) != nrow(as.data.frame(data)))) { stop("Grouping variable specified in 'group' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if grouping variable is completely missing
if (isTRUE(all(is.na(group)))) { stop("The grouping variable specified in 'group' is completely missing.", call. = FALSE) }
# Check if only one group represented in the grouping variable
if (isTRUE(length(unique(na.omit(unlist(group)))) == 1L)) { stop("There is only one group represented in the grouping variable specified in 'group'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Split Variable ####
if (isTRUE(!is.null(split))) {
#—————————————————————————————————————— #
### Tibble ####
# Convert 'group' as tibble into data frame
if (isTRUE("tbl" %in% substr(class(split), 1L, 3L))) { split <- unname(unlist(split)) }
#—————————————————————————————————————— #
### Split Variable Specified with the Variable Name ####
split.chr <- is.character(split)
if (isTRUE(split.chr && (length(split) < nrow(data)))) {
# Check if one split variable
if (isTRUE(length(split) > 1L)) { stop("Please specify one split variable for the argument 'split'.", call. = FALSE) }
# Check if split variable in 'data'
if (isTRUE(any(!split %in% colnames(data)))) { stop("Split variable specifed in 'split' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'split' ####
# Index of split variable in 'data'
split.col <- which(colnames(data) == split)
# Replace variable name with split variable
split <- data[, split.col]
# Remove split variable from 'data'
data <- data[, -split.col, drop = drop]
#—————————————————————————————————————— #
### Split Variable Not Specified with the Variable Name ####
} else {
# Check if length of split variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(split)) != nrow(as.data.frame(data)))) { stop("Split variable specified in 'split' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if split variable is completely missing
if (isTRUE(all(is.na(split)))) { stop("The split variable specified in 'split' is completely missing.", call. = FALSE) }
# Check if only one group represented in the split variable
if (isTRUE(length(unique(na.omit(unlist(split)))) == 1L)) { stop("There is only one split represented in the grouping variable specified in 'split'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Cluster Variable ####
if (isTRUE(!is.null(cluster))) {
#—————————————————————————————————————— #
### Tibble ####
# Convert 'cluster' as tibble into data frame
if (isTRUE("tbl" %in% substr(class(cluster), 1L, 3L))) { if (isTRUE(ncol(as.data.frame(cluster)) == 1L)) { cluster <- unname(unlist(cluster)) } else { cluster <- as.data.frame(cluster) } }
#—————————————————————————————————————— #
### Cluster Variable Specified with the Variable Name ####
cluster.chr <- is.character(cluster)
if (isTRUE(cluster.chr && (length(cluster) < nrow(data)))) {
# Check if one or two cluster variables
if (isTRUE(length(cluster) > 2L)) { stop("Please specify one or two cluster variables for the argument 'cluster'.", call. = FALSE) }
# Check if cluster variable in 'data'
if (isTRUE(any(!cluster %in% colnames(data)))) {
# One cluster variable
if (isTRUE(length(cluster) == 1L)) {
stop("Cluster variable specifed in 'cluster' was not found in '...'.", call. = FALSE)
# Two cluster variables
} else {
# Cluster variable in 'data'
setdiff(cluster, colnames(data)) |>
(\(y) if (isTRUE(length(y) == 1L)) {
stop(paste0("Cluster variable \"", y, "\" specifed in 'cluster' was not found in '...'."), call. = FALSE)
} else {
stop("Cluster variables specifed in 'cluster' were not found in '...'.", call. = FALSE)
})()
# Order of cluster variables
if (isTRUE(length(unique(data[, cluster[, 2L]])) < length(unique(data[, cluster[, 1L]])))) { stop("Please specify the Level 3 cluster variable first, e.g., cluster = c(\"level3\", \"level2\").", call. = FALSE) }
}
}
#···················
#### Extract 'data' and 'cluster' ####
# One cluster variable
if (isTRUE(length(cluster) == 1L)) {
# Index of cluster variable in 'data'
cluster.col <- which(colnames(data) %in% cluster)
# Replace variable name with cluster variable
cluster <- data[, cluster.col]
# Remove cluster variable from 'data'
data <- data[, -cluster.col, drop = drop]
} else {
# Index of Level-3 cluster variable in 'data'
cluster3.col <- which(colnames(data) == cluster[1L])
# Index of Level-2 cluster variable in 'data'
cluster2.col <- which(colnames(data) == cluster[2L])
# Replace variable name with cluster variable
cluster <- data[, c(cluster3.col, cluster2.col)]
# Remove cluster variable from 'data'
data <- data[, -c(cluster3.col, cluster2.col), drop = drop]
}
#—————————————————————————————————————— #
### Cluster Variable Not Specified with the Variable Name ####
} else {
# Check if length of cluster variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(cluster)) != nrow(as.data.frame(data)))) {
stop("Cluster variables specified in 'cluster' do not match with the number of rows in '...'.", call. = FALSE)
}
}
#···················
#### Check if Cluster Variable is Completely Missing ####
# One cluster variable
if (isTRUE(ncol(as.data.frame(cluster)) == 1L)) {
if (isTRUE(all(is.na(cluster)))) { stop("The cluster variable specified in 'cluster' is completely missing.", call. = FALSE) }
# Two cluster variables
} else {
sapply(cluster, function(y) all(is.na(y))) |>
(\(y) if (isTRUE(any(y))) {
if (isTRUE(sum(y)) == 1L) {
stop(paste0("A cluster variable specified in 'cluster' is completely missing.: ", names(which(y))), call. = FALSE)
} else {
stop("Cluster variables specified in 'cluster' are completely missing.", call. = FALSE)
}
})()
}
##### Check if only one group represented in the cluster variable ####
# One cluster variable
if (isTRUE(ncol(as.data.frame(cluster)) == 1L)) {
if (isTRUE(length(unique(na.omit(unlist(cluster)))) == 1L)) { stop("There is only one group represented in the cluster variable 'cluster'.", call. = FALSE) }
# Two cluster variables
} else {
sapply(cluster, function(y) length(unique(na.omit(unlist(y)))) == 1L) |>
(\(y) if (isTRUE(any(y))) {
if (isTRUE(sum(y)) == 1L) {
stop(paste0("There is only one group represented in a cluster variable specified in 'cluster': ", names(which(y))), call. = FALSE)
} else {
stop("There is only one group represented in both cluster variables specified in 'cluster'.", call. = FALSE)
}
})()
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Subject ID Variable ####
if (isTRUE(!is.null(id))) {
#—————————————————————————————————————— #
### Subject ID Variable Specified with the Variable Name ####
id.chr <- is.character(id)
if (isTRUE(id.chr && (length(id) < nrow(data)))) {
# Check if one ID variable
if (isTRUE(length(id) > 1L)) { stop("Please specify one id variable for the argument 'id'.", call. = FALSE) }
# Check if ID variable in 'data'
if (isTRUE(any(!id %in% colnames(data)))) { stop("ID variable specifed in 'id' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'id' ####
# Index of ID variable in 'data'
id.col <- which(colnames(data) == id)
# Replace variable name with id variable
id <- data[, id.col]
# Remove id variable from 'data'
data <- data[, -id.col, drop = drop]
#—————————————————————————————————————— #
### ID Variable Not Specified with the Variable Name ####
} else {
# Check if length of id variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(id)) != nrow(as.data.frame(data)))) { stop("ID variable specified in 'id' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if ID variable is completely missing
if (isTRUE(all(is.na(id)))) { stop("The ID variable specified in 'id' is completely missing.", call. = FALSE) }
# Check if only one ID represented in the ID variable
if (isTRUE(length(unique(na.omit(id))) == 1L)) { stop("There is only one ID represented in the ID variable specified in 'id'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Observation Number Variable ####
if (isTRUE(!is.null(obs))) {
#—————————————————————————————————————— #
### Observation Number Variable Specified with the Variable Name ####
obs.chr <- is.character(obs)
if (isTRUE(obs.chr && (length(obs) < nrow(data)))) {
# Check if one observation number variable
if (isTRUE(length(obs) > 1L)) { stop("Please specify one observation number variable for the argument 'obs'.", call. = FALSE) }
# Check if observation number variable in 'data'
if (isTRUE(any(!obs %in% colnames(data)))) { stop("Observation number variable specifed in 'obs' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'obs' ####
# Index of observation number variable in 'data'
obs.col <- which(colnames(data) == obs)
# Replace variable name with observation number variable
obs <- data[, obs.col]
# Remove observation number variable from 'data'
data <- data[, -obs.col, drop = drop]
#—————————————————————————————————————— #
### Observation number variable not specified with the variable name ####
} else {
# Check if length of observation number variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(obs)) != nrow(as.data.frame(data)))) { stop("ObservationnNumber variable specified in 'obs' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if observation number variable is completely missing
if (isTRUE(all(is.na(obs)))) { stop("The observation number variable specified in 'obs' is completely missing.", call. = FALSE) }
# Check if duplicated obs within id
check.obs.dupli <- sapply(split(obs, id), function(x) length(x) != length(unique(x)))
if (isTRUE(any(check.obs.dupli))) { stop("There are duplicated observations specified in 'obs' within subjects specified in 'id'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Day Number Variable ####
if (isTRUE(!is.null(day))) {
#—————————————————————————————————————— #
### Day Number Variable Specified with the Variable Name ####
day.chr <- is.character(day)
if (isTRUE(day.chr && (length(day) < nrow(data)))) {
# Check if one day variable
if (isTRUE(length(day) > 1L)) { stop("Please specify one day number variable for the argument 'day'.", call. = FALSE) }
# Check if day number variable in 'data'
if (isTRUE(any(!day %in% colnames(data)))) { stop("Day number variable specifed in 'day' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'day' ####
# Index of day number variable in 'data'
day.col <- which(colnames(data) == day)
# Replace variable name with day number variable
day <- data[, day.col]
# Remove day number variable from 'data'
data <- data[, -day.col, drop = drop]
#—————————————————————————————————————— #
### Day Number Variable Not Specified with the Variable Name ####
} else {
# Check if length of day number variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(day)) != nrow(as.data.frame(data)))) { stop("Day number variable specified in 'day' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if day number variable is completely missing
if (isTRUE(all(is.na(day)))) { stop("The day variable specified in 'day' is completely missing.", call. = FALSE) }
# Check if only one group represented in the day number variable
if (isTRUE(length(unique(na.omit(day))) == 1L)) { stop("There is only one day number represented in the grouping variable specified in 'day'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Actual Date and Time Variable ####
if (isTRUE(!is.null(time))) {
#—————————————————————————————————————— #
### Actual Date and Time Variable Specified with the Variable Name ####
time.chr <- is.character(time)
if (isTRUE(time.chr && (length(time) < nrow(data)))) {
# Check if one actual date and time variable
if (isTRUE(length(time) > 1L)) { stop("Please specify one date and time variable for the argument 'time'.", call. = FALSE) }
# Check if actual date and time variable in 'data'
if (isTRUE(any(!time %in% colnames(data)))) { stop("Date and time variable specifed in 'time' was not found in '...'.", call. = FALSE) }
#···················
#### Extract 'data' and 'time' ####
# Index of actual date and time variable in 'data'
time.col <- which(colnames(data) == time)
# Replace variable name with actual date and time variable
time <- data[, time.col]
# Remove actual date and time variable from 'data'
data <- data[, -time.col, drop = drop]
#—————————————————————————————————————— #
### Actual Date and Time Variable Not Specified with the Variable Name ####
} else {
# Check if length of actual date and time variable matching with the number of rows in 'data'
if (isTRUE(nrow(as.data.frame(time)) != nrow(as.data.frame(data)))) { stop("Date and time variable specified in 'time' does not match with the number of rows in '...'.", call. = FALSE) }
}
# Check if actual date and time variable is completely missing
if (isTRUE(all(is.na(time)))) { stop("The date and time variable specified in 'time' is completely missing.", call. = FALSE) }
# Check if only one group represented in the actual date and time variable
if (isTRUE(length(unique(na.omit(time))) == 1L)) { stop("There is only one date and time represented in the grouping variable specified in 'time'.", call. = FALSE) }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Return Object ####
# Grouping, split, or cluster variable specified with the variable name
if (isTRUE(any(c(group.chr, split.chr, cluster.chr, id.chr, obs.chr, day.chr, time.chr)))) {
return(list(data = data, group = group, split = split, cluster = cluster, id = id, obs = obs, day = day, time = time))
# Grouping, split, or cluster variable not specified with the variable name
} else {
return(list(data = NULL, group = NULL, split = NULL, cluster = NULL, id = NULL, obs = NULL, day = NULL, time = NULL))
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Exclude Non-Numeric Variables ————————————————————————————————————————————————
.exclude.non.numeric <- function(x, func = NULL, ordered = FALSE) {
x <- (if (ordered) {
(!vapply(x, function(z) is.numeric(z) | is.ordered(z), FUN.VALUE = logical(1L)))
} else {
(!vapply(x, function(z) is.numeric(z), FUN.VALUE = logical(1L)))
}) |> (\(p) if (isTRUE(any(p))) {
if (isTRUE(sum(p) == 1L)) {
warning(paste0("Non-numeric variable was excluded from the analysis: ", paste(names(which(p)), collapse = ", ")), call. = FALSE)
} else {
warning(paste0("Non-numeric variables were excluded from the analysis: ", paste(names(which(p)), collapse = ", ")), call. = FALSE)
}
return(x[, -which(p), drop = FALSE])
} else {
return(x)
})()
# No variables left
if (isTRUE(ncol(x) == 0L)) { stop("No variables left for analysis after excluding non-numeric variables.", call. = FALSE) }
# At least two variables
if (isTRUE(func == "cor.matrix" && ncol(x) == 1L)) { stop("At least two variables after excluding non-numeric variables are needed to compute the correlation coefficient.", call. = FALSE) }
# At least two variables
if (isTRUE(func == "item.alpha" && ncol(x) == 1L)) { stop("At least two items after excluding non-numeric variables are needed to compute coefficient alpha.", call. = FALSE) }
# At least three variables
if (isTRUE(func == "item.omega" && ncol(x) == 2L)) { stop("At least three items after excluding non-numeric variables are needed to compute coefficient omega.", call. = FALSE) }
# At least two variables
if (isTRUE(func == "item.stats" && ncol(x) == 1L)) { stop("At least two items after excluding non-numeric variables are needed to compute item statistics.", call. = FALSE) }
# At least three variables
if (isTRUE(func == "multilevel.cor" && ncol(x) == 2L)) { stop("At least two variables after excluding non-numeric variables are needed to compute a correlation coefficient.", call. = FALSE) }
# Return object
return(x)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Convert user-missing values into NA ——————————————————————————————————————————
.as.na <- function(x, na) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Replace user-specified values with NAs ####
x <- misty::as.na(x, na = na, check = FALSE)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Vector or factor ####
if (isTRUE(is.null(dim(x)))) {
# Check for missing values only
if (isTRUE(all(is.na(x)))) { stop("After converting user-missing values into NA, 'x' is completely missing.", call. = FALSE) }
# Check for zero variance
if (isTRUE(length(na.omit(unique(x))) == 1L)) { stop("After converting user-missing values into NA, 'x' has zero variance.", call. = FALSE) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Matrix or Data Frame ####
} else {
# Check for variables with missing values only
x.na.all <- vapply(as.data.frame(x), function(y) all(is.na(y)), FUN.VALUE = logical(1L))
if (isTRUE(any(x.na.all))) {
if (isTRUE(sum(x.na.all) == 1L)) {
stop(paste0("After converting user-missing values into NA, following variable has zero variance: ", names(which(x.na.all))), call. = FALSE)
} else {
stop(paste0("After converting user-missing values into NA, following variables have zero variance: ", paste(names(which(x.na.all)), collapse = ", ")), call. = FALSE)
}
}
# Check for variables with zero variance
x.zero.var <- vapply(as.data.frame(x), function(y) length(na.omit(unique(y))) == 1L, FUN.VALUE = logical(1L))
if (isTRUE(any(x.zero.var))) {
if (isTRUE(sum(x.zero.var) == 1L)) {
stop(paste0("After converting user-missing values into NA, following variable has zero variance: ", names(which(x.zero.var))), call. = FALSE)
} else {
stop(paste0("After converting user-missing values into NA, following variables have zero variance: ", paste(names(which(x.zero.var)), collapse = ", ")), call. = FALSE)
}
}
}
return(x)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the blimp.run() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Run Blimp ####
.blimp.source <- function(target, Blimp, posterior, folder, format, clear) {
#—————————————————————————————————————— #
### File Name, Blimp Path, and Plot Folder ####
# File name
base <- sub("\\.imp", "", basename(target))
# Path name
dirnam <- dirname(target)
# Blimp path
blimp_path <- Blimp
# Preprocess path for non-UNIX platform
if (isTRUE(.Platform$OS.type != "unix")) { blimp_path <- paste0('"', blimp_path, '"') }
# Make Posterior folder
if (isTRUE(posterior)) { dir.create(file.path(dirnam, paste0(folder, base)), showWarnings = FALSE) }
#—————————————————————————————————————— #
### Modify Input ####
if (isTRUE(posterior)) {
target.read <- suppressWarnings(readLines(target))
suppressWarnings(writeLines(target.read |>
(\(x) c(x, paste("SAVE:\n",
if (isTRUE(any(grepl("BYGROUP:", x, ignore.case = TRUE)))) {
paste0("estimates = ", folder, base, "/estimates*.csv;\n")
} else {
paste0("estimates = ", folder, base, "/estimates.csv;\n")
},
paste0("iterations = ", folder, base, "/iter*.csv;\n"))))(), target))
}
#—————————————————————————————————————— #
### Make Command ####
if (isTRUE(posterior)) {
cmd <- paste(blimp_path, shQuote(target), "--traceplot", shQuote(file.path(paste0(folder, base))), "--truncate 100", "--output", shQuote(file.path(dirnam, paste0(base, ".blimp-out"))))
} else {
cmd <- paste(blimp_path, shQuote(target), "--truncate 100", "--output", shQuote(file.path(dirnam, paste0(base, ".blimp-out"))))
}
#—————————————————————————————————————— #
### Run Command ####
out <- tryCatch(system(cmd), error = function(y) { stop("Running Blimp failed.", call. = FALSE) })
# ERROR message
if (isTRUE(out != 0)) {
sink(file.path(dirnam, paste0(base, ".blimp-out")), append = TRUE)
cat("ERROR:\n\n",
suppressWarnings(system(cmd, intern = TRUE)) |> (\(y) paste("", sub("ERROR: ", "", y)))())
sink()
}
#—————————————————————————————————————— #
### Post-Process Posterior Data ####
if (isTRUE(posterior && file.exists(paste0(folder, base, "/labels.dat")))) {
if (isTRUE(all(!grepl("BYGROUP:", target.read, ignore.case = TRUE)))) {
param <- chain <- iter <- latent1 <- latent2 <- latent3 <- NULL
#···················
#### Message ####
cat("Saving posterior distribution for all parameters, this may take a while.\n")
#···················
#### Labels ####
labels <- read.table(paste0(folder, base, "/labels.dat"), header = TRUE) |>
setNames(object = _, nm = c("latent1", "latent2", "latent3", "param", "block")) |>
(\(z) within(z, param <- paste0("p", param)))()
#···················
#### Burn-In Data ####
# Data in long format
burnin <- lapply(list.files(paste0(folder, base), pattern = "burn", full.names = TRUE), function(y) {
read.csv(y, header = FALSE) |>
setNames(object = _, nm = c("iter", labels$param)) |>
(\(z) reshape(z, varying = list(colnames(z)[-1L]), v.names = "value", idvar = colnames(z)[1L], times = colnames(z)[-1], direction = "long"))()
})
# Add chain
for (i in seq_along(burnin)) { burnin[[i]] <- data.frame(chain = i, burnin[[i]]) }
# Row bind
burnin <- do.call(rbind, burnin)
#···················
#### Post-Burn-In Data ####
# Data in long format
postburn <- lapply(list.files(paste0(folder, base), pattern = "iter", full.names = TRUE), function(y) {
read.csv(y, header = FALSE) |>
setNames(object = _, nm = labels$param) |>
(\(z) data.frame(iter = max(burnin$iter) + 1L:nrow(z), z))() |>
(\(w) reshape(w, varying = list(colnames(w)[-1L]), v.names = "value", idvar = colnames(w)[1L], times = colnames(w)[-1], direction = "long"))()
})
# Add chain
for (i in seq_along(postburn)) { postburn[[i]] <- data.frame(chain = i, postburn[[i]]) }
# Row bind
postburn <- do.call(rbind, postburn)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Combine Burn-in Data and Post-Burn-In Data ####
# Row bind and merge with labels
posterior <- misty::df.rename(rbind(data.frame(postburn = 0L, burnin), data.frame(postburn = 1L, postburn)), from = "time", to = "param") |>
(\(z) misty::df.move(latent1, latent2, latent3, data = merge(x = z, labels, by = "param"), after = "param"))() |>
(\(w) misty::df.sort(w, param, chain, iter))() |>
(\(q) within(q, param <- as.numeric(sub("p", "", param))))()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Save Data ####
if (isTRUE("csv" %in% format)) { utils::write.csv(posterior, file.path(paste0(folder, base), "posterior.csv"), row.names = FALSE) }
if (isTRUE("csv2" %in% format)) { utils::write.csv2(posterior, file.path(paste0(folder, base), "posterior.csv"), row.names = FALSE) }
if (isTRUE("xlsx" %in% format)) { misty::write.xlsx(posterior, file.path(paste0(folder, base), "posterior.xlsx")) }
if (isTRUE("rds" %in% format)) { base::saveRDS(posterior, file = file.path(paste0(folder, base), "posterior.rds")) }
if (isTRUE("RData" %in% format)) { base::save(posterior, file = file.path(paste0(folder, base), "posterior.RData")) }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Save Parameter Table ####
labels[, c("param", "latent1", "latent2", "latent3")] |>
(\(z) within(z, param <- as.numeric(gsub("p", "", param))))() |>
(\(w) format(rbind(c("Param", "L1", "L2", "L3"), w), justify = "left"))() |>
write.table(x = _, file = paste0(folder, base, "/partable.txt"), quote = FALSE, row.names = FALSE, col.names = FALSE)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Post-Process Estimates ####
write.csv(read.csv(paste0(folder, base, "/estimates.csv"), check.names = FALSE) |>
(\(z) data.frame(param = as.numeric(sub("p", "", labels$param)), latent1 = labels$latent1, latent2 = labels$latent2, latent3 = labels$latent3, z, check.names = FALSE))(), paste0(folder, base, "/estimates.csv"), row.names = FALSE)
}
}
#—————————————————————————————————————— #
### Clear Console ####
if (isTRUE(clear && .Platform$GUI == "RStudio")) { misty::clear() }
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Detect Blimp Location ####
.detect.blimp <- function(exec = "blimp") {
env_r_blimp <- Sys.getenv("R_BLIMP", unset = NA)
if (isTRUE(!is.na(env_r_blimp))) { if (isTRUE(file.exists(env_r_blimp) & !dir.exists(env_r_blimp))) { return(env_r_blimp) } }
user_os <- tolower(R.Version()$os)
# Mac
if (isTRUE(grepl("darwin", user_os))) {
return(.detect_blimp_macos(exec))
# Linux
} else if (isTRUE(grepl("linux", user_os))) {
return(.detect_blimp_linux(exec))
# Windows
} else if (isTRUE(grepl("windows", user_os) || grepl("mingw32", user_os))) {
return(.detect_blimp_windows(paste0(exec, ".exe")))
}
stop("Unable to detect the operating system.", call. = FALSE)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Find Blimp on MacOS ####
.detect_blimp_macos <- function(exec) {
output <- suppressWarnings(system(paste("which", exec), intern = TRUE, ignore.stderr = TRUE)[1L])
if (isTRUE(length(output) != 0L)) { if (isTRUE(file.exists(output))) { return(output) } }
output <- paste0("/Applications/Blimp/", exec)
if (isTRUE(file.exists(output))) { return(output) }
output <- paste0("~", output)
if (isTRUE(file.exists(output))) { return(output) }
stop("Unable to find blimp executable, make sure Blimp is installed.", call. = FALSE)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Find Blimp on Linux ####
.detect_blimp_linux <- function(exec) {
output <- suppressWarnings(system(paste("which", exec), intern = TRUE, ignore.stderr = TRUE)[1L])
if (isTRUE(length(output) != 0L)) { if (isTRUE(file.exists(output))) { return(output) } }
stop("Unable to find blimp executable, ,ake sure Blimp is installed.", call. = FALSE)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Find Blimp on Windows ####
.detect_blimp_windows <- function(exec) {
output <- suppressWarnings(system(paste("where", exec), intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(output) != 0L)) { if (isTRUE(file.exists(output))) { return(output) } }
output <- paste0("C:\\Program Files\\Blimp\\", exec)
if (isTRUE(file.exists(output))) { return(output) }
output <- paste0("D:\\Program Files\\Blimp\\", exec)
if (isTRUE(file.exists(output))) { return(output) }
stop("Unable to find blimp executable, ,ake sure Blimp is installed.", call. = FALSE)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the blimp.bayes() function ----------------------------
# mplus.bayes() function ----------------------------
#
# - .map
# - .hdi
# - .rhat
# - .split.chains
# - .zscale
# - .autocovariance
# - .ess
# - .mcse
#
# rstan package
# https://github.com/stan-dev/rstan/blob/develop/rstan/rstan/R/monitor.R
#
# bayestestR package
# https://github.com/easystats/bayestestR/blob/main/R/map_estimate.R
# https://github.com/easystats/bayestestR/blob/main/R/hdi.R
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified map_estimate Function from the bayestestR Package ####
#
# Maximum A Posteriori probability estimate
.map <- function(x) {
x.density <- density(na.omit(x), n = 2L^10L, bw = "SJ", from = range(x)[1L], to = range(x)[2L])
x.density$x[which.max(x.density$y)]
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified hdi Function from the bayestestR Package ####
#
# Highest density interval
.hdi <- function(x, conf.level = NULL) {
x.sorted <- unname(sort.int(x, method = "quick"))
window.size <- ceiling(conf.level * length(x.sorted))
if (isTRUE(window.size < 2L)) { return(data.frame(low = NA, upp = NA)) }
nCIs <- length(x.sorted) - window.size
if (isTRUE(nCIs < 1L)) { return(data.frame(low = NA, upp = NA)) }
ci.width <- sapply(seq_len(nCIs), function(y) x.sorted[y + window.size] - x.sorted[y])
min.i <- which(ci.width == min(ci.width))
if (isTRUE(length(min.i) > 1L)) {
if (isTRUE(any(diff(sort(min.i)) != 1L))) {
min.i <- max(min.i)
} else {
min.i <- floor(mean(min.i))
}
}
c(low = x.sorted[min.i], upp = x.sorted[min.i + window.size])
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified rhat_rfun Function from the rstan Package ####
#
# Compute the Rhat convergence diagnostic for a single parameter
.rhat <- function(x, fold, split, rank) {
# One chain
if (isTRUE(is.vector(x))) { dim(x) <- c(length(x), 1L) }
# Fold
if (isTRUE(fold)) { x <- abs(x - median(x)) }
# Split chains
if (isTRUE(split)) { x <- .split.chains(x) }
# Rank-normalization
if (isTRUE(rank)) { x <- .zscale(x) }
# Number of iterations
n.iter <- nrow(x)
# Compute R hat
rhat <- sqrt((n.iter * var(colMeans(x)) / mean(apply(x, 2L, var)) + n.iter - 1L) / n.iter)
# Return value
return(rhat)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified split_chains Function from the rstan Package ####
#
# Split Markov Chains
.split.chains <- function(x) {
# One chain
if (isTRUE(is.vector(x))) { dim(x) <- c(length(x), 1L) }
# Number of iterations
n.iter <- nrow(x)
# Combine by columns
x <- cbind(x[1L:floor(n.iter / 2L), ], x[ceiling(n.iter / 2L + 1L):n.iter, ])
# Return value
return(x)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified z_scale Function from the rstan Package ####
#
# Compute rank normalization for a numeric array
.zscale <- function(x) {
z <- qnorm((rank(x, ties.method = "average") - 1L / 2L) / length(x))
z[is.na(x)] <- NA
if (!is.null(dim(x))) { z <- array(z, dim = dim(x), dimnames = dimnames(x)) }
return(z)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified autocovariance Function from the rstan Package ####
#
# Compute autocorrelation estimates for every lag for the specified input sequence
# using a fast Fourier transform approach
.autocovariance <- function(x) {
N <- length(x)
varx <- var(x)
if (isTRUE(varx == 0L)) { return(rep(0L, N)) }
ac <- Re(fft(abs(fft(c((x - mean(x)), rep.int(0L, (2L * nextn(N)) - N))))^2L, inverse = TRUE)[1L:N])
ac <- ac / ac[1L] * varx * (N - 1L) / N
return(ac)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified ess_rfun Function from the rstan Package ####
#
# Compute the effective sample size estimate for a sample of several chains for
# one parameter
.ess <- function(x, split, rank) {
# One chain
if (isTRUE(is.vector(x))) { dim(x) <- c(length(x), 1L) }
# Split chains
if (isTRUE(split)) { x <- .split.chains(x) }
# Rank-normalization
if (isTRUE(rank)) { x <- .zscale(x) }
chains <- ncol(x)
n_samples <- nrow(x)
if (isTRUE(n_samples < 3L)) { return(NA_real_) }
acov <- do.call(cbind, lapply(seq_len(chains), function(y) .autocovariance(x[, y])))
mean_var <- mean(acov[1L, ]) * n_samples / (n_samples - 1L)
var_plus <- mean_var * (n_samples - 1L) / n_samples
if (isTRUE(chains > 1L)) { var_plus <- var_plus + var(colMeans(x)) }
rho_hat_t <- rep.int(0L, n_samples)
t <- 0L
rho_hat_even <- 1L
rho_hat_t[t + 1L] <- rho_hat_even
rho_hat_odd <- 1L - (mean_var - mean(acov[t + 2L, ])) / var_plus
rho_hat_t[t + 2L] <- rho_hat_odd
while (isTRUE(t < nrow(acov) - 5L && !is.nan(rho_hat_even + rho_hat_odd) && (rho_hat_even + rho_hat_odd > 0L))) {
t <- t + 2L
rho_hat_even <- 1L - (mean_var - mean(acov[t + 1L, ])) / var_plus
rho_hat_odd <- 1L - (mean_var - mean(acov[t + 2L, ])) / var_plus
if (isTRUE((rho_hat_even + rho_hat_odd) >= 0L)) {
rho_hat_t[t + 1L] <- rho_hat_even
rho_hat_t[t + 2L] <- rho_hat_odd
}
}
max_t <- t
if (isTRUE(rho_hat_even > 0L)) { rho_hat_t[max_t + 1L] <- rho_hat_even }
t <- 0L
while (isTRUE(t <= max_t - 4L)) {
t <- t + 2L
if (isTRUE(rho_hat_t[t + 1L] + rho_hat_t[t + 2L] > rho_hat_t[t - 1L] + rho_hat_t[t])) {
rho_hat_t[t + 1L] = (rho_hat_t[t - 1L] + rho_hat_t[t]) / 2L
rho_hat_t[t + 2L] = rho_hat_t[t + 1L]
}
}
ess <- chains * n_samples
tau_hat <- -1L + 2L * sum(rho_hat_t[1L:max_t]) + rho_hat_t[max_t + 1L]
tau_hat <- max(tau_hat, 1L/log10(ess))
ess <- ess / tau_hat
return(ess)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified conv_quantile and mcse_mean Function from the rstan Package ####
#
# Compute Monte Carlo standard error for the mean and a quantile
.mcse <- function(x, quant = FALSE, prob = NULL, split = TRUE, rank = TRUE) {
# MCSE for a quantile
if (isTRUE(quant)) {
ess <- .ess(x <= quantile(x, prob), split = split, rank = rank)
a <- qbeta(c(0.1586553, 0.8413447), ess * prob + 1L, ess * (1L - prob) + 1L)
x.sort <- sort(x)
S <- length(x.sort)
mcse <- (x.sort[min(round(a[2L] * S), S)] - x.sort[max(round(a[1L] * S), 1L)] ) / 2L
# MCSE for the mean
} else {
mcse <- sd(x) / sqrt(.ess(x, split = split, rank = rank))
}
return(mcse)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the boot.bs() function --------------------------------
#
# https://github.com/simsem/semTools/blob/master/semTools/R/missingBootstrap.R
#
# .trans1
# .trans2
# .getBootSample
# .fitBootSample
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Execute Transformation 1 on a Single Missing-Data Pattern ####
.trans1 <- function(MDpattern, pattern, dat, sigma, mu) {
X <- apply(dat[which(pattern == MDpattern), ], 2, scale, scale = FALSE)
observed <- !is.na(X[1, ])
Xreduced <- X[ , observed]
Y <- replace(X, !is.na(X), t((t(chol(sigma[observed, observed])) %*% t(solve(chol(t(Xreduced) %*% Xreduced / nrow(X))))) %*% t(Xreduced) + as.numeric(mu[observed])))
return(Y)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Execute Transformation 2 on a Single Group ####
.trans2 <- function(dat, sigma, mu, em.cov) {
# Function of A (eq. 12)
eq12 <- function(A) {
ga <- rep(0L, pStar)
for (j in seq_len(J)) {
ga <- ga + Njs[j] * Dupinv %*% c(Mjs[[j]] %*% A %*% Hjs[[j]] %*% A %*% Mjs[[j]] - Mjs[[j]])
}
return(ga)
}
# Derivative of Function of A (eq. 13)
eq13 <- function(A) {
deriv12 <- matrix(0L, nrow = pStar, ncol = pStar)
for (j in seq_len(J)) {
deriv12 <- deriv12 + 2L*Njs[j]*Dupinv %*% kronecker((Mjs[[j]] %*% A %*% Hjs[[j]]), Mjs[[j]]) %*% Dup
}
return(deriv12)
}
# Missing data patterns
rowMissPatt <- apply(ifelse(is.na(dat), 1L, 0L), 1L, function(x) paste(x, collapse = ""))
MDpattern <- unique(rowMissPatt)
# Sample size within each MD pattern
Njs <- sapply(MDpattern, function(patt) sum(rowMissPatt == patt))
J <- length(MDpattern)
p <- ncol(dat)
pStar <- p*(p + 1L) / 2L
# Empty lists for each MD pattern
Xjs <- vector("list", J)
Hjs <- vector("list", J)
Mjs <- vector("list", J)
# Duplication Matrix and its inverse (Magnus & Neudecker, 1999)
Dup <- lavaan::lav_matrix_duplication(p)
Dupinv <- solve(t(Dup) %*% Dup) %*% t(Dup)
# Step through each MD pattern, populate Hjs and Mjs
for (j in seq_len(J)) {
Xjs[[j]] <- apply(dat[rowMissPatt == MDpattern[j], ], 2L, scale, scale = FALSE)
if (isTRUE(!is.matrix(Xjs[[j]]))) { Xjs[[j]] <- t(Xjs[[j]]) }
observed <- !is.na(Xjs[[j]][1L, ])
Sj <- t(Xjs[[j]]) %*% Xjs[[j]] / Njs[j]
Hjs[[j]] <- replace(Sj, is.na(Sj), 0L)
Mjs[[j]] <- replace(Sj, !is.na(Sj), solve(sigma[observed, observed]))
Mjs[[j]] <- replace(Mjs[[j]], is.na(Mjs[[j]]), 0L)
}
## Compute starting Values for A
if (isTRUE(is.null(em.cov))) {
A <- diag(p)
} else {
EMeig <- eigen(em.cov)
Sigeig <- eigen(sigma)
B <- (Sigeig$vectors %*% diag(sqrt(Sigeig$values)) %*% t(Sigeig$vectors)) %*% (EMeig$vectors %*% diag(1L / sqrt(EMeig$values)) %*% t(EMeig$vectors))
A <- 0.5*(B + t(B))
}
# Newton Algorithm for finding root (eq. 14)
crit <- 0.1
a <- c(A)
fA <- eq12(A)
while (isTRUE(crit > 1e-11)) {
dvecF <- eq13(A)
a <- a - Dup %*% solve(dvecF) %*% fA
A <- matrix(a, ncol = p)
fA <- eq12(A)
crit <- max(abs(fA))
}
# Transform dataset X to dataset Y
Yjs <- Xjs
for (j in seq_len(J)) {
Yjs[[j]] <- (!is.na(Xjs[[j]][1L, ])) |> (\(p) replace(Yjs[[j]], !is.na(Yjs[[j]]), (t((A[p, p, drop = FALSE]) %*% t((Xjs[[j]][ , p, drop = FALSE])) + as.numeric(mu[p])))))()
}
Y <- setNames(as.data.frame(do.call("rbind", Yjs)), nm = colnames(dat))
return(Y)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Draw a Single Bootstrap Sample from the Transformed Data ####
.getBootSample <- function(dat, group, group.label) {
bootSamp <- list()
for (i in seq_along(dat)) {
temp <- dat[[i]]
temp[ , group] <- group.label[i]
bootSamp[[i]] <- temp[sample(seq_len(nrow(temp)), nrow(temp), replace = TRUE), ]
}
return(do.call("rbind", bootSamp))
}
## fit the model to a single bootstrapped sample and return chi-squared
.fitBootSample <- function(dat, args) {
args$data <- dat
lavaanlavaan <- function(...) { lavaan::lavaan(...) }
fit <- do.call(lavaanlavaan, args)
if (isTRUE(!exists("fit"))) { return(c(chisq = NA)) }
if (isTRUE(lavaan::lavInspect(fit, what = "converged"))) {
chisq <- lavaan::lavInspect(fit, what = "fit")[c("chisq", "chisq.scaled")]
} else {
chisq <- NA
}
if (isTRUE(is.na(chisq[2L]))) { return(chisq[1L]) } else { return(chisq[2L]) }
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the check.resid() function ----------------------------
#
# - .resid.partial
# - .calc_ranef
#
# remef: Remove Partial Effects
# https://github.com/hohenstein/remef/
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Calculate Partial Effects ####
#
# Adapted function partial()
.resid.partial <- function(model, fix = NULL, ran = "all") {
#—————————————————————————————————————— #
### Part 1: Fixed Effects ####
is.na(match(fix, colnames(model.matrix(model)) |> (\(y) if (isTRUE(as.logical(attr(terms(model), "intercept")))) { y[-1L] } else { y })())) |> (\(y) if (isTRUE(any(y))) { stop("The following effects are not present in the model: ", paste(fix[y], collapse = ", "), call. = FALSE) })()
DV <- lme4::getME(model, "y") - as.vector(model.matrix(model)[ , fix, drop = FALSE] %*% lme4::fixef(model)[fix])
#—————————————————————————————————————— #
### Part 2: Random effects ####
DV <- DV - .calc_ranef(model, lapply(lapply(lme4::ranef(model), names), seq_along))
return(unname(DV))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Calculate Random Effects based on a Subset of Variance Terms ####
#
# Adapted function calc_ranef()
.calc_ranef <- function(model, ran) {
if (isTRUE(length(ran) == 0L)) { return(numeric(length = lme4::getME(model, "n"))) }
if (isTRUE(is.list(ran) && length(ran) > 0L)) {
stopifnot(is.numeric(unlist(ran)))
ran <- lapply(ran, unique)
ran <- ran[vapply(ran, length, 1L) > 0L]
}
ran_labs <- lapply(lme4::ranef(model), names)
if (isTRUE(is.null(names(ran)) || any( !names(ran) %in% names(ran_labs)) || any(duplicated(names(ran))))) { stop("The list 'ran' has invalid names.", call. = FALSE) }
num_re <- vapply(ran_labs, length, FUN.VALUE = 1L, USE.NAMES = FALSE)
num_re_previous <- c(0L, cumsum(head(num_re, -1L)))
rf_idx <- match(names(ran), names(ran_labs))
ran_model <- lme4::ranef(model)
ran_model_sub <- lapply(mapply(`[`, ran_model[rf_idx], ran, SIMPLIFY = FALSE), unlist)
re_list <- lapply(mapply(function(x, y) seq_len(x) + y, num_re, num_re_previous, SIMPLIFY = FALSE), function(x) lme4::getME(model, "Ztlist")[x])
re_list_sub <- mapply(`[`, re_list[rf_idx], ran, SIMPLIFY = FALSE)
ran_model_sub <- mapply(`[`, ran_model[rf_idx], ran, SIMPLIFY = FALSE)
ranef_sums <- rowSums(do.call(cbind, mapply(function(mats, vecs) mapply(function(v, m) as.vector(v %*% m), vecs, mats), re_list_sub, ran_model_sub, SIMPLIFY = FALSE)))
return(ranef_sums)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the chr.gsub() function -------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Fast escape replace ####
#
# Fast escape function for limited case where only one pattern
# provided actually matches anything
#
# Argument string: a character vector where replacements are sought
# Argument pattern: a character string to be matched in the given character vector
# Argument replacement: Character string equal in length to pattern or of length
# one which are a replacement for matched pattern.
# Argument ...: arguments to pass to gsub()
.fastReplace <- function(string, pattern, replacement, ...) {
for (i in seq_along(pattern)) {
string <- gsub(pattern[i], replacement[i], string, ...)
}
return(string)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Filter Overlaps from Matches ####
#
# Helper function used to identify which results from gregexpr()
# overlap other matches and filter out shorter, overlapped results
#
# Argument x: a matrix of gregexpr() results, 4 columns, index of column matched,
# start of match, length of match, end of match. Produced exclusively from
# a .worker function in chr.gsub
.filterOverlap <- function(x) {
for (i in nrow(x):2L) {
s <- x[i, 2L]
ps <- x[1L:(i - 1L), 2L]
e <- x[i, 4]
pe <- x[1L:(i - 1L), 4L]
if (any(ps <= s & pe >= s)){
x <- x[-i, ]
next
}
if (any(ps <= e & pe >= e)) {
x <- x[-i,]
next
}
}
return(matrix(x, ncol = 4L))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Get all Matches ####
#
# Helper function to be used in a loop to check each pattern
# provided for matches
#
# Argument string: a character vector where replacements are sought
# Argument pattern: a character string to be matched in the given character vector
# Argument i: an iterator provided by a looping function
# Argument ...: arguments to pass to gregexpr()
.getMatches <- function(string ,pattern, i, ...){
tmp <- gregexpr(pattern[i], string,...)
start <- tmp[[1L]]
length <- attr(tmp[[1L]], "match.length")
return(matrix(cbind(i, start, length, start + length - 1L), ncol = 4L))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## chr.gsub() .worker ####
#
# Argument string: a character vector where replacements are sought
# Argument pattern: a character string to be matched in the given character vector
# Argument replacement: a character string equal in length to pattern or of length
# one which are a replacement for matched pattern.
# Argument ...: arguments to pass to regexpr family
.worker <- function(string, pattern, replacement,...){
x0 <- do.call(rbind, lapply(seq_along(pattern), .getMatches, string = string, pattern = pattern, ...))
x0 <- matrix(x0[x0[, 2L] != -1L, ], ncol = 4L)
uid <- unique(x0[, 1L])
if (nrow(x0) == 0L) {
return(string)
}
if (length(unique(x0[, 1])) == 1L) {
return(.fastReplace(string, pattern[uid], replacement[uid], ...))
}
if (nrow(x0) > 1L) {
x <- x0[order(x0[, 3L], decreasing = TRUE), ]
x <- .filterOverlap(x)
uid <- unique(x[, 1L])
if (length(uid) == 1L) {
return(.fastReplace(string, pattern[uid], replacement[uid], ...))
}
x <- x[order(x[, 2L]), ]
}
for (i in nrow(x):1L){
s <- x[i, 2L]
e <- x[i, 4L]
p <- pattern[x[i, 1L]]
r <- replacement[x[i, 1L]]
pre <- if (s > 1L) { substr(string, 1L, s - 1L) } else { "" }
r0 <- sub(p,r,substr(string, s, e), ...)
end <- if (e < nchar(string)) { substr(string, e + 1, nchar(string)) } else { "" }
string <- paste0(pre, r0, end)
}
return(string)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.cor() function ---------------------------------
#
# - .multsolvefun
# - .sqerrVMc
# - .sqerrVMintr
# - .VMparstomoms
# - .Tf2fun
# - .smpmomvecfun
# - .smpmjkfun
# - .zciofrfun
# - .estskkufun
# - .ci.pearson.cor.adjust
# - .ci.spearman.cor.adjust
# - .ci.kendall.b
# - .ci.kendall.c
# - .ci.kendall.c.estimate
# - .norm.inter
# - .boot.func.cor
# - .ci.boot.cor
#
# Bishara et al. (2018) Supporting Information
# https://bpspsychub.onlinelibrary.wiley.com/action/downloadSupplement?doi=10.1111%2Fbmsp.12113&file=bmsp12113-sup-0002-DataS2.txt
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Multiple Attempts to find 3rd order Polynomial Parameters ####
.multsolvefun <- function(xskku, yskku, obsr, seed = NULL, maxtol = 0.0001, nudge = 0.01, tryrndpars = 5L) {
if (isTRUE(!is.null(seed))) { set.seed(seed) }
failsolve <- FALSE
failcountvec <- nudgesmadevec <- rep(0L, 3L)
xskku.small <- xskku
yskku.small <- yskku
obsr.small <- obsr
Xmod <- try(stats::optim(c(1L, 0L, 0L), .sqerrVMc, sk = xskku[1L], ku = xskku[2L], method = "N"))
if (isTRUE(Xmod$value > maxtol)) { failsolve <- TRUE }
while (isTRUE(failsolve)) {
failcountvec <- failcountvec + c(1L, 0L, 0L)
randpars <- (stats::runif(3L) - 0.5)*c(3L, 1L, 0.5)
if (isTRUE((failcountvec[1L] %% tryrndpars == 1L) & (failcountvec[1L] > 1L))) {
nudgesmadevec <- nudgesmadevec + c(1L, 0L, 0L)
nudgemult <- 1L - nudge*nudgesmadevec[1L]
xskku.small <- xskku*nudgemult
}
Xmod <- try(optim(randpars, .sqerrVMc, sk = xskku.small[1L], ku = xskku.small[2L], method = "N"))
if(isTRUE((Xmod$value < maxtol) | (nudgesmadevec[1L] >= 100L))) { failsolve <- FALSE }
}
Ymod <- try(optim(c(1L, 0L, 0L), .sqerrVMc, sk = yskku[1L], ku = yskku[2L], method = "N"))
if (isTRUE(Ymod$value > maxtol)) { failsolve <- TRUE }
while (isTRUE(failsolve)) {
failcountvec <- failcountvec + c(0L, 1L, 0L)
randpars <- (runif(3L) - 0.5)*c(3L, 1L, 0.5)
if (isTRUE((failcountvec[2] %% tryrndpars == 1) & (failcountvec[2] > 1))) {
nudgesmadevec <- nudgesmadevec + c(0L, 1L, 0L)
nudgemult <- 1L - nudge*nudgesmadevec[2L]
yskku.small <- yskku*nudgemult
}
Ymod <- try(optim(randpars, .sqerrVMc, sk = yskku.small[1L], ku = yskku.small[2L], method = "N"))
if (isTRUE((Ymod$value < maxtol) | (nudgesmadevec[2L] >= 100L))) { failsolve <- FALSE }
}
estconstvec <- c(Xmod$par,Ymod$par)
if (isTRUE(nudgesmadevec[1L] >= 100)) { estconstvec[1L:3L] <- c(1L, 0L, 0L) }
if (isTRUE(nudgesmadevec[2L] >= 100)) { estconstvec[4L:6L] <- c(1L, 0L, 0L) }
intrmod <- try(optimize(.sqerrVMintr, cpars = estconstvec, obsr = obsr, interval = c(-1L, 1L)))
if (isTRUE(intrmod$objective > maxtol)) { failsolve <- TRUE }
while (isTRUE(failsolve)) {
failcountvec <- failcountvec + c(0L, 0L, 1L)
nudgesmadevec <- nudgesmadevec + c(0L, 0L, 1L)
nudgemult <- 1L - nudge*nudgesmadevec[3L]
obsr.small <- obsr*nudgemult
intrmod <- try(optimize(.sqerrVMintr, cpars = estconstvec, obsr = obsr.small, interval = c(-1L, 1L)))
if (isTRUE((intrmod$objective < maxtol) | (nudgesmadevec[3L] >= 100L))) { failsolve <- FALSE }
}
if (isTRUE(nudgesmadevec[3L] < 100L)) {
intr <- intrmod$minimum
} else {
intr <- 0L
}
estconstmat <- rbind(estconstvec[1L:3L], estconstvec[4L:6L])
rownames(estconstmat) <- c("X","Y")
colnames(estconstmat) <- c("b","c","d")
return(list(estxyc = estconstmat, intr = intr, totsqerr = Xmod$value + Ymod$value + intrmod$objective, failed = failcountvec, nudgesmade = nudgesmadevec))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Squared Error of 3rd Order Polynomial Parameters ####
.sqerrVMc <- function(trypars, sk, ku) {
devvec <- rep(NA, 3L)
b <- trypars[1L]
c1 <- trypars[2L]
d <- trypars[3L]
devvec[1L] <- b^2L + 6L*b*d + 2L*c1^2L + 15L*d^2L - 1L
devvec[2L] <- 2L*c1*(b^2L + 24L*b*d + 105L*d^2L + 2L) - sk
devvec[3L] <- 24L*(b*d + c1^2L*(1 + b^2L + 28L*b*d) + d^2L*(12L + 48L*b*d + 141L*c1^2L + 225L*d^2L)) - ku
return(sum(devvec^2L))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Squared Error for Intermediate Correlation Parameter ####
.sqerrVMintr <- function(tryintr, cpars, obsr) {
b1 <- cpars[1L]
c1 <- cpars[2L]
d1 <- cpars[3L]
b2 <- cpars[4L]
c2 <- cpars[5L]
d2 <- cpars[6L]
return((((b1*b2 + 3L*b1*d2 + 3L*d1*b2 + 9L*d1*d2)*tryintr) + ((2L*c1*c2)*tryintr^2L) + ((6L*d1*d2)*tryintr^3L) - obsr)^2L)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Third Order Polynomial Parameters to Analytically Solve ####
.VMparstomoms <- function(consX, consY, intr) {
Power <- function(g, h) { g^h }
b1 <- consX[1L]
c1 <- consX[2L]
d1 <- consX[3L]
b2 <- consY[1L]
c2 <- consY[2L]
d2 <- consY[3L]
r <- intr
VMm22 <- Power(b1, 2L)*Power(b2, 2L) +
2L*Power(r, 2L)*Power(b1, 2L)*Power(b2, 2L) +
2L*Power(b2, 2L)*Power(c1, 2L) +
8L*Power(r, 2L)*Power(b2, 2L)*Power(c1, 2L) +
16L*r*b1*b2*c1*c2 +
24L*Power(r, 3L)*b1*b2*c1*c2 +
2L*Power(b1, 2L)*Power(c2, 2L) +
8L*Power(r, 2L)*Power(b1, 2L)*Power(c2, 2L) +
4L*Power(c1, 2L)*Power(c2, 2L) +
32L*Power(r, 2L)*Power(c1, 2L)*Power(c2, 2L) +
24L*Power(r, 4L)*Power(c1, 2L)*Power(c2, 2L) +
6L*b1*Power(b2, 2L)*d1 +
24L*Power(r, 2L)*b1*Power(b2, 2L)*d1 +
96L*r*b2*c1*c2*d1 +
216L*Power(r, 3L)*b2*c1*c2*d1 +
12L*b1*Power(c2, 2L)*d1 +
96L*Power(r, 2L)*b1*Power(c2, 2L)*d1 +
48L*Power(r, 4L)*b1*Power(c2, 2L)*d1 +
15L*Power(b2, 2L)*Power(d1, 2L) +
90L*Power(r, 2L)*Power(b2, 2L)*Power(d1, 2L) +
30L*Power(c2, 2L)*Power(d1, 2L) +
360L*Power(r, 2L)*Power(c2, 2L)*Power(d1, 2L) +
360L*Power(r, 4L)*Power(c2, 2L)*Power(d1, 2L) +
6L*Power(b1, 2L)*b2*d2 +
24L*Power(r, 2L)*Power(b1, 2L)*b2*d2 +
12L*b2*Power(c1, 2L)*d2 +
96L*Power(r, 2L)*b2*Power(c1, 2L)*d2 +
48L*Power(r, 4L)*b2*Power(c1, 2L)*d2 +
96L*r*b1*c1*c2*d2 +
216L*Power(r, 3L)*b1*c1*c2*d2 +
36L*b1*b2*d1*d2 +
288L*Power(r, 2L)*b1*b2*d1*d2 +
96L*Power(r, 4L)*b1*b2*d1*d2 +
576L*r*c1*c2*d1*d2 +
1944L*Power(r, 3L)*c1*c2*d1*d2 +
480L*Power(r, 5L)*c1*c2*d1*d2 +
90L*b2*Power(d1, 2L)*d2 +
1080L*Power(r, 2L)*b2*Power(d1, 2L)*d2 +
720L*Power(r, 4L)*b2*Power(d1, 2L)*d2 +
15L*Power(b1, 2L)*Power(d2, 2L) +
90L*Power(r, 2L)*Power(b1, 2L)*Power(d2, 2L) +
30L*Power(c1, 2L)*Power(d2, 2L) +
360L*Power(r, 2L)*Power(c1, 2L)*Power(d2, 2L) +
360L*Power(r, 4L)*Power(c1, 2L)*Power(d2, 2L) +
90L*b1*d1*Power(d2, 2L) +
1080L*Power(r, 2L)*b1*d1*Power(d2, 2L) +
720L*Power(r, 4L)*b1*d1*Power(d2, 2L) +
225L*Power(d1, 2L)*Power(d2, 2L) +
4050L*Power(r, 2L)*Power(d1, 2L)*Power(d2, 2L) +
5400L*Power(r, 4L)*Power(d1, 2L)*Power(d2, 2L) +
720L*Power(r, 6L)*Power(d1, 2L)*Power(d2, 2L)
VMm13 <- 3L*r*b1*Power(b2, 3L) +
30L*Power(r, 2L)*Power(b2, 2L)*c1*c2 +
30L*r*b1*b2*Power(c2, 2L) +
60L*Power(r, 2L)*c1*Power(c2, 3L) +
9L*r*Power(b2, 3L)*d1 +
6L*Power(r, 3L)*Power(b2, 3L)*d1 +
90L*r*b2*Power(c2, 2L)*d1 +
144L*Power(r, 3L)*b2*Power(c2, 2L)*d1 +
45L*r*b1*Power(b2, 2L)*d2 +
468L*Power(r, 2L)*b2*c1*c2*d2 +
234L*r*b1*Power(c2, 2L)*d2 +
135L*r*Power(b2, 2L)*d1*d2 +
180L*Power(r, 3L)*Power(b2, 2L)*d1*d2 +
702L*r*Power(c2, 2L)*d1*d2 +
1548L*Power(r, 3L)*Power(c2, 2L)*d1*d2 +
315L*r*b1*b2*Power(d2, 2L) +
2250L*Power(r, 2L)*c1*c2*Power(d2, 2L) +
945L*r*b2*d1*Power(d2, 2L) +
1890L*Power(r, 3L)*b2*d1*Power(d2, 2L) +
945L*r*b1*Power(d2, 3L) +
2835L*r*d1*Power(d2, 3L) +
7560L*Power(r, 3L)*d1*Power(d2, 3L)
VMm31 <- 3L*r*Power(b1, 3L)*b2 +
30L*r*b1*b2*Power(c1, 2L) +
30L*Power(r, 2L)*Power(b1, 2L)*c1*c2 +
60L*Power(r, 2L)*Power(c1, 3L)*c2 +
45L*r*Power(b1, 2L)*b2*d1 +
234L*r*b2*Power(c1, 2L)*d1 +
468L*Power(r, 2L)*b1*c1*c2*d1 +
315L*r*b1*b2*Power(d1, 2L) +
2250L*Power(r, 2L)*c1*c2*Power(d1, 2L) +
945L*r*b2*Power(d1, 3L) +
9L*r*Power(b1, 3L)*d2 +
6L*Power(r, 3L)*Power(b1, 3L)*d2 +
90L*r*b1*Power(c1, 2L)*d2 +
144L*Power(r, 3L)*b1*Power(c1, 2L)*d2 +
135L*r*Power(b1, 2L)*d1*d2 +
180L*Power(r, 3L)*Power(b1, 2L)*d1*d2 +
702L*r*Power(c1, 2L)*d1*d2 +
1548L*Power(r, 3L)*Power(c1, 2L)*d1*d2 +
945L*r*b1*Power(d1, 2L)*d2 +
1890L*Power(r, 3L)*b1*Power(d1, 2L)*d2 +
2835L*r*Power(d1, 3L)*d2 +
7560L*Power(r, 3L)*Power(d1, 3L)*d2
VMm40 <- 936L*b1*c1^2L*d1 + 60L*b1^2L*c1^2L + 60L*b1^3L*d1 + 630L*b1^2L*d1^2L + 3780L*b1*d1^3L + 3L*b1^4L + 4500L*c1^2L*d1^2L + 60L*c1^4L + 10395L*d1^4L
VMm04 <- 936L*b2*c2^2L*d2 + 60L*b2^2L*c2^2L + 60L*b2^3L*d2 + 630L*b2^2L*d2^2L + 3780L*b2*d2^3L + 3L*b2^4L + 4500L*c2^2L*d2^2L + 60L*c2^4L + 10395L*d2^4L
return(c(VMmu04 = VMm04, VMmu13 = VMm13, VMmu22 = VMm22, VMmu31 = VMm31, VMmu40 = VMm40))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Hawkins (1989) tau_f^2 term ####
.Tf2fun <- function(rho, mujkvec) {
m04 <- mujkvec[1L]
m13 <- mujkvec[2L]
m22 <- mujkvec[3L]
m31 <- mujkvec[4L]
m40 <- mujkvec[5L]
return(unname((((1L - rho^2L)^(-2L))*0.25)*((m40 + 2L*m22 + m04)*(rho^2L) - 4L*(m31 + m13)*rho + 4L*m22)))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Vector of Relevant Sample Joint Moments ####
.smpmomvecfun <- function(x, y) {
momvec <- rep(NA, 5L)
xcent <- x - mean(x)
ycent <- y - mean(y)
xstand <- scale(x)
ystand <- scale(y)
for (i in 0L:4L) {
momvec[i + 1L] <- .smpmjkfun(xstand, ystand, i, 4L - i)
names(momvec)[i + 1L] <- paste0("m", i, 4L - i)
}
return(momvec)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Sample Joint Moment ####
.smpmjkfun <- function(x, y, j, k) {
(1L / length(x))*sum((x^j)*(y^k))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## CI of Correlation using Mean and Standard Error of z ####
.zciofrfun <- function(z, zsd, alternative, conf.level) {
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
object <- tanh(z + c(qnorm(alphavec[1L]), qnorm(alphavec[2L]))*zsd)
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { object[1L] <- -1L }, greater = { object[2L] <- 1L }) }
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Skewness and Kurtosis in a Sample ####
.estskkufun <- function(x, sample = TRUE, center = TRUE) {
return(c(g1 = misty::skewness(x, sample = sample, check = FALSE), g2 = misty::kurtosis(x, sample = sample, center = center, check = FALSE)))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Main Function to Estimate Confidence Intervals for Pearson Correlation ####
.ci.pearson.cor.adjust <- function(x, y, adjust = c("none", "joint", "approx"), alternative = c("two.sided", "less", "greater"),
conf.level = 0.95, sample = TRUE, center = TRUE, seed = NULL, maxtol = 0.00001, nudge = 0.001) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
adjmethnames <- c("none", "joint", "approx")
boundsmat <- matrix(NA, nrow = 2L, ncol = 3L, dimnames = list(c("low", "upp"), adjmethnames))
sdzvec <- setNames(rep(NA, length(adjmethnames)), nm = adjmethnames)
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
r <- cor(x1, x2)
r.z <- atanh(r)
#···················
#### Unadjusted Standard Error ####
if (isTRUE("none" %in% adjust)) {
sdzvec[1L] <- 1L / sqrt(n - 3L)
} else {
sdzvec[1L] <- NA
}
#···················
#### Adjusted by Sample Joint Moments ####
if (isTRUE("joint" %in% adjust)) {
smpmomvec <- .smpmomvecfun(x1, x2)
jointmomTf2 <- .Tf2fun(rho = r, mujkvec = smpmomvec)
sdzvec[2L] <- sqrt(jointmomTf2 / (n - 3L))
} else {
smpmomvec <- jointmomTf2 <- NA
}
#···················
#### Adjusted by Approximate Distributing using Marginal Skewness and Kurtosis ####
XYg12mat <- matrix(c(.estskkufun(x1, sample = sample, center = center), .estskkufun(x2, sample = sample, center = center)),
nrow = 2L, ncol = 2L, byrow = TRUE, dimnames = list(c("X", "Y"), c("g1", "g2")))
if (isTRUE("approx" %in% adjust)) {
VMparlist <- .multsolvefun(xskku = XYg12mat[1L, ], yskku = XYg12mat[2L, ], obsr = r, maxtol = maxtol, nudge = nudge)
# Optimization succeeded
if (isTRUE(is.list(VMparlist))) {
VMmoms <- .VMparstomoms(VMparlist$estxyc[1, ], VMparlist$estxyc[2L, ], VMparlist$intr)
nudgedrho <- r*(1L - 0.01*VMparlist$nudgesmade[3L])
ApproxDistTf2 <- .Tf2fun(rho = nudgedrho, mujkvec = VMmoms)
sdzvec[3L] <- sqrt(ApproxDistTf2 / (n - 3L))
# Optimization failed
} else {
VMmoms <- setNames(rep(NA, 5L), nm = c("VMmu04", "VMmu13", "VMmu22", "VMmu31", "VMmu40"))
sdzvec[3L] <- ApproxDistTf2 <- NA
}
} else {
VMmoms <- setNames(rep(NA, 5L), nm = c("VMmu04", "VMmu13", "VMmu22", "VMmu31", "VMmu40"))
sdzvec[3L] <- ApproxDistTf2 <- NA
}
#···················
#### Confidence intervals ####
for (curadj in seq_len(length(adjmethnames))) {
boundsmat[, curadj] <- .zciofrfun(r.z, sdzvec[curadj], alternative = alternative, conf.level = conf.level)
}
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = XYg12mat[1L, "g1"], kurt1 = XYg12mat[1L, "g2"], skew2 = XYg12mat[2L, "g1"], kurt2 = XYg12mat[2L, "g2"],
cor = r, adjust = adjust, se = sdzvec, ci = boundsmat, skew.kurt = XYg12mat, joint.moments = smpmomvec, approx.moments = VMmoms, joint.tau2.f = jointmomTf2, approx.tau2.f = ApproxDistTf2)
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
cor = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(cor(x1, x2)) } else { NA }, adjust = adjust, se = sdzvec, ci = boundsmat, skew.kurt = NA, joint.moments = NA, approx.moments = NA, joint.tau2.f = NA, approx.tau2.f = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## CI for the Spearman Correlation with Fieller et al (1957), Bonett and Wright (2000), and RIN Standard Error ####
#
# Bishara and Hittner (2017) Supplementary Materials A
# https://static-content.springer.com/esm/art%3A10.3758%2Fs13428-016-0702-8/MediaObjects/13428_2016_702_MOESM1_ESM.pdf
#
# RIN transformation
# https://rpubs.com/seriousstats/616206
.ci.spearman.cor.se <- function(x, y, se = c("fisher", "fieller", "bonett", "rin"), sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
rs <- cor(x1, x2, method = "spearman")
if (isTRUE(se %in% c("fieller", "bonett"))) {
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
ci <- tanh(atanh(rs) + c(qnorm(alphavec[1L]), qnorm(alphavec[2L])) * switch(se, "fisher" = { sqrt(1 / (n - 3L)) }, "fieller" = { sqrt(1.06 / (n - 3L)) }, "bonett" = { sqrt((1L + (rs^2L) / 2L) / (n - 3L)) }))
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { ci[1L] <- -1L }, greater = { ci[2L] <- 1L }) }
} else {
RIN <- function(y) { qnorm((rank(y) - 0.5) / (length(rank(y)))) }
ci <- cor.test(RIN(x1), RIN(x2), alternative = alternative, conf.level = conf.level)$conf.int
}
object <- list(se = se, sample = sample, alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x1, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x1, sample = sample, check = FALSE), skew2 = misty::skewness(x2, sample = sample, check = FALSE), kurt2 = misty::kurtosis(x2, sample = sample, check = FALSE), cor = rs, ci = ci)
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
object <- list(se = se, sample = sample, alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA, cor = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(cor(x1, x2, method = "spearman")) } else { NA }, ci = c(NA, NA))
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .ci.kendall.b Function ####
.ci.kendall.b <- function(x, y, sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
#···················
#### Significance Testing ####
# Test for Association
test.tau.b <- cor.test(x1, x2, method = "kendall", alternative = alternative, exact = FALSE, continuity = FALSE)
# Kendall's tau b
tau <- unname(test.tau.b$estimate)
# Fieler et al. (1957) standard error
tau.se <- sqrt(0.437 / (length(x) - 4L))
#···················
#### Confidence Interval ####
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
if (isTRUE(!is.na(tau.se))) {
ci <- tanh(atanh(tau) + c(qnorm(alphavec[1L]), qnorm(alphavec[2L]))*tau.se)
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { ci[1L] <- -1L }, greater = { ci[2L] <- 1L }) }
} else {
ci <- c(NA, NA)
}
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x1, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x1, sample = sample, check = FALSE), skew2 = misty::skewness(x2, sample = sample, check = FALSE), kurt2 = misty::kurtosis(x2, sample = sample, check = FALSE),
stat = test.tau.b$statistic, tau = tau, se = tau.se, pval = test.tau.b$p.value, ci = ci)
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
stat = NA, tau = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(cor(x1, x2, method = "kendall")) } else { NA }, se = NA, pval = NA, ci = c(NA, NA))
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .ci.kendall.c.estimate Function ####
.ci.kendall.c.estimate <- function(x, y) {
# Contingency table
x.table <- table(x, y)
# Number of rows
x.nrow <- nrow(x.table)
# Number of columns
x.ncol <- ncol(x.table)
# Sample size
x.n <- sum(x.table)
# Minimum of number of rows/columns
x.m <- min(dim(x.table))
pi.c <- pi.d <- matrix(0L, nrow = x.nrow, ncol = x.ncol)
x.col <- col(x.table)
x.row <- row(x.table)
for (i in seq_len(x.nrow)) {
for (j in seq_len(x.ncol)) {
pi.c[i, j] <- sum(x.table[x.row < i & x.col < j]) + sum(x.table[x.row > i & x.col > j])
pi.d[i, j] <- sum(x.table[x.row < i & x.col > j]) + sum(x.table[x.row > i & x.col < j])
}
}
# Concordant
x.con <- sum(pi.c * x.table) / 2L
# Discordant
x.dis <- sum(pi.d * x.table) / 2L
#—————————————————————————————————————— #
### Kendall Tau-c ####
tau <- (x.m*2L * (x.con - x.dis)) / (x.n^2L * (x.m - 1L))
#—————————————————————————————————————— #
### Return Object ####
return(tau)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .ci.kendall.c Function ####
.ci.kendall.c <- function(x, y, sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95) {
xy <- na.omit(data.frame(x, y))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- length(x) - n
pNA <- (nNA / (n + nNA)) * 100
#—————————————————————————————————————— #
### At least n = 4 and Variance Unequal 0 ####
if (isTRUE(n >= 4L && var(x1) != 0L && var(x2) != 0L)) {
#···················
#### Kendall Tau-c ####
tau <- .ci.kendall.c.estimate(x1, x2)
# Fieler et al. (1957) standard error
tau.se <- sqrt(0.437 / (length(x) - 4L))
# Test statistic
z <- tau / tau.se
# p-value
switch(alternative, "two.sided" = {
pval <- pnorm(abs(z), lower.tail = FALSE)*2L
}, "less" = {
pval <- ifelse(z < 0L, pnorm(abs(z), lower.tail = FALSE), 1 - pnorm(abs(z), lower.tail = FALSE))
}, "greater" = {
pval <- ifelse(z > 0L, pnorm(abs(z), lower.tail = FALSE), 1 - pnorm(abs(z), lower.tail = FALSE))
})
#···················
#### Confidence Interval ####
if (isTRUE(alternative == "two.sided")) {
alphavec <- c((1L - conf.level) / 2L, (1L + conf.level) / 2L)
} else {
alphavec <- c((1L - conf.level), conf.level)
}
ci <- tanh(atanh(tau) + c(qnorm(alphavec[1L]), qnorm(alphavec[2L]))*tau.se)
if (isTRUE(alternative != "two.sided")) { switch(alternative, less = { ci[1L] <- -1L }, greater = { ci[2L] <- 1L }) }
#···················
#### Return Object ####
return(list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x, sample = sample, check = FALSE), skew2 = misty::skewness(y, sample = sample, check = FALSE), kurt2 = misty::kurtosis(y, sample = sample, check = FALSE),
tau = tau, se = tau.se, stat = z, pval = pval, ci = ci))
#—————————————————————————————————————— #
### Number of Cases n < 4 or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(alternative = alternative, conf.level = conf.level, n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
tau = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) { suppressWarnings(.ci.kendall.c.estimate(x1, x2)) } else { NA }, se = NA, stat = NA, pval = NA, ci = c(NA, NA))
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Interpolation on the Normal Quantile Scale ####
# Equation 5.8 of Davison and Hinkley (1997)
#
# .norm.inter from the R package 'boot'
# see: https://github.com/cran/boot/blob/master/R/bootfuns.q
.norm.inter <- function(t, alpha) {
t <- t[is.finite(t)]
R <- length(t)
rk <- (R + 1L)*alpha
k <- trunc(rk)
inds <- seq_along(k)
out <- inds
kvs <- k[k > 0L & k < R]
tstar <- sort(t, partial = sort(union(c(1L, R), c(kvs, kvs + 1L))))
ints <- (k == rk)
if (isTRUE(any(ints))) { out[inds[ints]] <- tstar[k[inds[ints]]] }
out[k == 0L] <- tstar[1L]
out[k == R] <- tstar[R]
not <- function(v) { xor(rep(TRUE,length(v)), v) }
temp <- inds[not(ints) & k != 0L & k != R]
temp1 <- qnorm(alpha[temp])
temp2 <- qnorm(k[temp] / (R + 1L))
temp3 <- qnorm((k[temp] + 1L)/(R + 1L))
tk <- tstar[k[temp]]
tk1 <- tstar[k[temp] + 1L]
out[temp] <- tk + (temp1 - temp2) / (temp3 - temp2)*(tk1 - tk)
return(out)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Correlation Coefficient ####
.boot.func.cor <- function(data, ind, method) {
data.boot <- data[ind, ]
if (isTRUE(method != "kendall-c")) { cor <- cor(data.boot[, 1L], data.boot[, 2L], method = method) } else { cor <- .ci.kendall.c.estimate(data.boot[, 1L], data.boot[, 2L]) }
return(cor = cor)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Nonparametric Bootstrap Confidence Intervals for the Correlation Coefficient ####
.ci.boot.cor <- function(data, x, y, method, statistic = .boot.func.cor, nrep = 1000, min.n = 10,
boot = c("norm", "basic", "perc", "bc", "bca"),
fisher = TRUE, sample = TRUE, alternative = c("two.sided", "less", "greater"),
conf.level = 0.95, seed = NULL) {
#—————————————————————————————————————— #
### Correlation Coefficient ####
method <- ifelse(isTRUE(method == "kendall-b"), "kendall", method)
#—————————————————————————————————————— #
### Fisher-z Transformation ####
if (isTRUE(fisher)) { h <- function(t) atanh(t); hinv <- function(t) tanh(t) } else { h <- function(t) t; hinv <- function(t) t }
#—————————————————————————————————————— #
### Adjust Confidence Level ####
if (isTRUE(alternative %in% c("less", "greater"))) { conf.level.alter <- conf.level - (1 - conf.level) } else { conf.level.alter <- conf.level }
#—————————————————————————————————————— #
### Data ####
xy <- na.omit(data.frame(x = data[, x], y = data[, y]))
x1 <- xy$x
x2 <- xy$y
n <- nrow(xy)
nNA <- nrow(data) - n
pNA <- (nNA / (n + nNA)) * 100L
#—————————————————————————————————————— #
### At least n = min.n Cases and Variance Unequal 0 ####
if (isTRUE(n >= min.n && var(x1) != 0L && var(x2) != 0L)) {
#···················
#### Bootstrap Replicates ####
if (isTRUE(!is.null(seed))) { set.seed(seed) }
boot.repli <- suppressWarnings(boot::boot(xy, statistic = statistic, method = method, R = nrep))
#···················
#### Bootstrap Confidence Interval ####
switch(boot, "norm" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "norm", conf = conf.level.alter, h = h, hinv = hinv)) |>
(\(y) data.frame(low = y$normal[2L], upp = y$normal[3L]))()
}, "basic" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "basic", conf = conf.level.alter, h = h, hinv = hinv)) |>
(\(y) data.frame(low = y$basic[4L], upp = y$basic[5L]))()
}, "perc" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "perc", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$perc[4L], upp = y$perc[5L]))()
}, "bc" = {
result <- qnorm(mean(boot.repli$t < boot.repli$t0, na.rm = TRUE)) |>
(\(y) suppressWarnings(.norm.inter(boot.repli$t[, 1L], pnorm(y + (y + qnorm((1L + c(-conf.level.alter, conf.level.alter)) / 2L))))))() |>
(\(z) data.frame(low = z[1L], upp = z[2L]))()
}, "bca" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "bca", method = method, conf = conf.level.alter)) |>
(\(y) data.frame(low = y$bca[4L], upp = y$bca[5L]))()
})
#···················
#### Adjust Lower or Upper Bound ####
switch(alternative, "less" = { result$low <- -1 }, "greater" = { result$upp <- 1 })
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, skew1 = misty::skewness(x1, sample = sample, check = FALSE), kurt1 = misty::kurtosis(x1, sample = sample, check = FALSE), skew2 = misty::skewness(x2, sample = sample, check = FALSE), kurt2 = misty::kurtosis(x2, sample = sample, check = FALSE),
cor = boot.repli$t0, t = as.vector(boot.repli$t), ci = result)
#—————————————————————————————————————— #
### Number of Cases n < min.n or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, skew1 = NA, kurt1 = NA, skew2 = NA, kurt2 = NA,
cor = if (isTRUE(nrow(xy) == 3L && var(x1) != 0L && var(x2) != 0L)) {
if (isTRUE(method != "kendall-c")) {
suppressWarnings(cor(x1, x2, method = ifelse(isTRUE(method == "kendall-b"), "kendall", method)))
} else {
suppressWarnings(.ci.kendall.c.estimate(x1, x2))
}
} else {
NA
}, t = rep(NA, times = nrep), ci = c(NA, NA))
}
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci._() functions ----------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Nonparametric Bootstrap Confidence Intervals ####
.ci.boot <- function(data, statistic, nrep = 1000, min.n = 10, boot = c("norm", "basic", "stud", "perc", "bc", "bca"),
sample = TRUE, alternative = c("two.sided", "less", "greater"), conf.level = 0.95, seed = NULL) {
#—————————————————————————————————————— #
### Adjust Confidence Level ####
if (isTRUE(alternative %in% c("less", "greater"))) { conf.level.alter <- conf.level - (1 - conf.level) } else { conf.level.alter <- conf.level }
#—————————————————————————————————————— #
### Data ####
x <- na.omit(data)
n <- length(x)
nNA <- length(data) - n
pNA <- (nNA / (n + nNA)) * 100L
#—————————————————————————————————————— #
### At least n = min.n Cases and Variance Unequal 0 ####
if (isTRUE(n >= min.n && var(x) != 0L)) {
#···················
#### Bootstrap Replicates ####
if (isTRUE(!is.null(seed))) { set.seed(seed) }
boot.repli <- suppressWarnings(boot::boot(x, statistic = statistic, R = nrep))
#···················
#### Bootstrap Confidence Interval ####
switch(boot, "norm" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "norm", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$normal[2L], upp = y$normal[3L]))()
}, "basic" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "basic", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$basic[4L], upp = y$basic[5L]))()
}, "stud" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "stud", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$student[4L], upp = y$student[5L]))()
}, "perc" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "perc", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$perc[4L], upp = y$perc[5L]))()
}, "bc" = {
result <- qnorm(mean(boot.repli$t[, 1L] < boot.repli$t0[1L], na.rm = TRUE)) |>
(\(y) suppressWarnings(.norm.inter(boot.repli$t[, 1L], pnorm(y + (y + qnorm((1L + c(-conf.level.alter, conf.level.alter)) / 2L))))))() |>
(\(z) data.frame(low = z[1L], upp = z[2L]))()
}, "bca" = {
result <- suppressWarnings(boot::boot.ci(boot.repli, type = "bca", conf = conf.level.alter)) |>
(\(y) data.frame(low = y$bca[4L], upp = y$bca[5L]))()
})
#···················
#### Adjust Lower or Upper Bound ####
switch(alternative, "less" = { result$low <- -1 }, "greater" = { result$upp <- 1 })
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, m = mean(x), sd = sd(x), iqr = IQR(x), freq = sum(x == 1), skew = suppressWarnings(misty::skewness(x, sample = sample, check = FALSE)), kurt = suppressWarnings(misty::kurtosis(x, sample = sample, check = FALSE)), t0 = boot.repli$t0[1L], t = as.vector(boot.repli$t[, 1L]), ci = result)
#—————————————————————————————————————— #
### Number of Cases n < min.n or Variance Equal 0 ####
} else {
#···················
#### Return Object ####
object <- list(n = n, nNA = nNA, pNA = pNA, m = if (isTRUE(length(x) >= 2L && var(x) != 0L)) { mean(x) } else { NA }, sd = if (isTRUE(length(x) >= 2L && var(x) != 0L)) { sd(x) } else { NA }, iqrt = if (isTRUE(length(x) >= 2L && var(x) != 0L)) { IQR(x) } else { NA }, freq = if (isTRUE(length(x) >= 1L)) { sum(x == 1, na.rm = TRUE) } else { NA },
skew = if (isTRUE(length(x) >= 3L && var(x) != 0L)) { suppressWarnings(misty::skewness(x, sample = sample, check = FALSE)) } else { NA }, kurt = if (isTRUE(length(x) >= 4L && var(x) != 0L)) { suppressWarnings(misty::kurtosis(x, sample = sample, check = FALSE))} else { NA }, t0 = NA, t = rep(NA, times = nrep), ci = c(NA, NA)) }
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.mean() function --------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the mean ####
.m.conf <- function(x, sigma, adjust, alternative, conf.level, side) {
# Data
x <- na.omit(x)
# Difference-adjustment factor
adjust.factor <- ifelse(isTRUE(adjust), sqrt(2L) / 2L, 1L)
# One observation or SD = 0
if (isTRUE(length(x) <= 1L || sd(x) == 0L)) {
ci <- c(NA, NA)
# More than one observation
} else {
x.m <- mean(x)
#—————————————————————————————————————— #
### Known Population Standard Deviation ####
if (isTRUE(!is.null(sigma))) {
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
se <- sigma / sqrt(length(na.omit(x)))
#—————————————————————————————————————— #
### Unknown Population Standard Deviation ####
} else {
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = length(x) - 1L)
se <- sd(x) / sqrt(length(x))
}
#—————————————————————————————————————— #
### Confidence Interval ####
ci <- switch(alternative,
two.sided = c(low = x.m - adjust.factor * crit * se,
upp = x.m + adjust.factor * crit * se),
less = c(low = -Inf,
upp = x.m + adjust.factor * crit * se),
greater = c(low = x.m - adjust.factor * crit * se,
upp = Inf))
}
#—————————————————————————————————————— #
### Return object ####
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Arithmetic Mean ####
.boot.func.mean <- function(data, ind) { return(c(mean(data[ind], na.rm = TRUE), var(data[ind], na.rm = TRUE) / length(na.omit(data[ind])))) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.median() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the median ####
.med.conf <- function(x, alternative, conf.level, side) {
# Data
x <- na.omit(x)
n <- length(x)
# Number of observations less than 6 observations
if (isTRUE(n < 6L)) {
ci <- c(NA, NA)
# At least six observations
} else {
#—————————————————————————————————————— #
### Confidence Interval ####
# Two-sided CI
switch(alternative, two.sided = {
k <- qbinom((1L - conf.level)/2L, size = n, prob = 0.5, lower.tail = TRUE)
ci <- sort(x)[c(k, n - k + 1L)]
# One-sided CI: less
}, less = {
k <- qbinom(1L - 2L * (1L - conf.level), size = n, prob = 0.5, lower.tail = TRUE)
ci <- c(-Inf, sort(x)[k])
# One-sided CI: greater
}, greater = {
k <- qbinom(1L - 2L * (1L - conf.level), size = n, prob = 0.5, lower.tail = FALSE)
ci <- c(sort(x)[k], Inf)
})
}
#—————————————————————————————————————— #
### Return Object ####
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Median ####
.boot.func.median <- function(data, ind) { return(c(median(data[ind], na.rm = TRUE), (pi / 2L) * var(data[ind], na.rm = TRUE) / length(na.omit(data[ind])))) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.prop() function --------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence Interval for the Proportion ####
.prop.conf <- function(x, method, alternative, conf.level, side) {
# Data
x <- na.omit(x)
n <- length(x)
# Number of observations
if (isTRUE(n <= 1L)) {
ci <- c(NA, NA)
} else {
s <- sum(x)
p <- s / n
q <- 1L - p
z <- switch(alternative,
two.sided = qnorm(1L - (1 - conf.level)/2L),
less = qnorm(1L - (1L - conf.level)),
greater = qnorm(1L - (1L - conf.level)))
#—————————————————————————————————————— #
### Wald Method ####
if (isTRUE(method == "wald")) {
term <- z * sqrt(p * q) / sqrt(n)
ci <- switch(alternative,
two.sided = c(low = max(0L, p - term), upp = min(1L, p + term)),
less = c(low = 0L, upp = min(1, p + term)),
greater = c(low = max(0L, p - term), upp = 1L))
#—————————————————————————————————————— #
### Wilson Method ####
} else if (isTRUE(method == "wilson")) {
term1 <- (s + z^2 / 2L) / (n + z^2L)
term2 <- z * sqrt(n) / (n + z^2L) * sqrt(p * q + z^2L / (4L * n))
ci <- switch(alternative,
two.sided = c(low = max(0L, term1 - term2), upp = min(1L, term1 + term2)),
less = c(0L, upp = min(1L, term1 + term2)),
greater = c(low = max(0L, term1 - term2), upp = 1L))
}
}
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.var() function ---------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the variance ####
.var.conf <- function(x, method, alternative, conf.level, side) {
# Data
x <- na.omit(x)
x.var <- var(x)
# Number of observations
if (isTRUE((length(x) < 2L && method == "chisq") || (length(x) < 4L && method == "bonett"))) {
ci <- c(NA, NA)
} else {
#—————————————————————————————————————— #
### Chi-Square Method ####
if (isTRUE(method == "chisq")) {
df <- length(x) - 1L
# Two-sided CI
switch(alternative, two.sided = {
crit.low <- qchisq((1L - conf.level)/2L, df = df, lower.tail = FALSE)
crit.upp <- qchisq((1L - conf.level)/2L, df = df, lower.tail = TRUE)
ci <- c(low = df*x.var / crit.low, upp = df*x.var / crit.upp)
# One-sided CI: less
}, less = {
crit.upp <- qchisq((1L - conf.level), df = df, lower.tail = TRUE)
ci <- c(low = 0L, upp = df*x.var / crit.upp)
# One-sided CI: greater
}, greater = {
crit.low <- qchisq((1L - conf.level), df = df, lower.tail = FALSE)
ci <- c(low = df*x.var / crit.low, upp = Inf)
})
#—————————————————————————————————————— #
### Bonett Method ####
} else if (isTRUE(method == "bonett")) {
n <- length(x)
z <- switch(alternative,
two.sided = qnorm(1L - (1L - conf.level)/2L),
less = qnorm(1L - (1L - conf.level)),
greater = qnorm(1L - (1L - conf.level)))
cc <- n/(n - z)
gam4 <- n * sum((x - mean(x, trim = 1L / (2L * (n - 4L)^0.5)))^4L) / (sum((x - mean(x))^2L))^2L
se <- cc * sqrt((gam4 - (n - 3L)/n) / (n - 1L))
ci <- switch(alternative,
two.sided = c(low = exp(log(cc * x.var) - z * se), upp = exp(log(cc * x.var) + z * se)),
less = c(low = 0L, upp = exp(log(cc * x.var) + z * se)),
greater = c(low = exp(log(cc * x.var) - z * se), upp = Inf))
}
}
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Variance ####
.boot.func.var <- function(data, ind) { return(var(data[ind], na.rm = TRUE)) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.sd() function ----------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the standard deviation ####
.sd.conf <- function(x, method, alternative, conf.level, side) {
# Data
x <- na.omit(x)
x.var <- var(x)
# Number of observations
if (isTRUE((length(x) < 2L && method == "chisq") || (length(x) < 4L && method == "bonett"))) {
ci <- c(NA, NA)
} else {
#—————————————————————————————————————— #
### Chi-Square Method ####
if (isTRUE(method == "chisq")) {
df <- length(x) - 1L
# Two-sided CI
switch(alternative, two.sided = {
crit.low <- qchisq((1L - conf.level)/2L, df = df, lower.tail = FALSE)
crit.upp <- qchisq((1L - conf.level)/2L, df = df, lower.tail = TRUE)
ci <- sqrt(c(low = df*x.var / crit.low, upp = df*x.var / crit.upp))
# One-sided CI: less
}, less = {
crit.upp <- qchisq((1L - conf.level), df = df, lower.tail = TRUE)
ci <- c(low = 0L, upp = sqrt(df*x.var / crit.upp))
# One-sided CI: greater
}, greater = {
crit.low <- qchisq((1L - conf.level), df = df, lower.tail = FALSE)
ci <- c(low = sqrt(df*x.var / crit.low), upp = Inf)
})
#—————————————————————————————————————— #
### Bonett Method ####
} else if (isTRUE(method == "bonett")) {
n <- length(x)
z <- switch(alternative,
two.sided = qnorm(1L - (1L - conf.level)/2L),
less = qnorm(1L - (1L - conf.level)),
greater = qnorm(1L - (1L - conf.level)))
cc <- n/(n - z)
gam4 <- n * sum((x - mean(x, trim = 1L / (2L * (n - 4L)^0.5)))^4L) / (sum((x - mean(x))^2))^2L
se <- cc * sqrt((gam4 - (n - 3L)/n) / (n - 1L))
ci <- switch(alternative,
two.sided = sqrt(c(low = exp(log(cc * x.var) - z * se), upp = exp(log(cc * x.var) + z * se))),
less = c(low = 0, upp = sqrt(exp(log(cc * x.var) + z * se))),
greater = c(low = sqrt(exp(log(cc * x.var) - z * se)), upp = Inf))
}
}
# Lower or upper limit
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bootstrap Function Standard Deviation ####
.boot.func.sd <- function(data, ind) { return(sd(data[ind], na.rm = TRUE)) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.mean.diff() function ---------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence interval for the difference of arithmetic means ####
.m.diff.conf <- function(x, y, sigma, var.equal, alternative, paired, conf.level, side) {
#—————————————————————————————————————— #
### Independent Samples ####
if (!isTRUE(paired)) {
#···················
#### Data ####
x <- na.omit(x)
y <- na.omit(y)
x.n <- length(x)
y.n <- length(y)
yx.mean <- mean(y) - mean(x)
x.var <- var(x)
y.var <- var(y)
# At least 2 observations for x and y
if (isTRUE(x.n >= 2L && y.n >= 2L & (x.var != 0L && y.var != 0L))) {
##### Known Population SD ####
if (isTRUE(!is.null(sigma))) {
se <- sqrt((sigma[1L]^2L / x.n) + (sigma[2L]^2L / y.n))
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
term <- crit*se
##### Unknown Population SD ####
} else {
###### Equal variance ####
if (isTRUE(var.equal)) {
se <- sqrt(((x.n - 1L)*x.var + (y.n - 1L)*y.var) / (x.n + y.n - 2L)) * sqrt(1 / x.n + 1L / y.n)
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = sum(x.n, y.n) - 2L)
term <- crit*se
###### Unequal variance ####
} else {
se <- sqrt(x.var / x.n + y.var / y.n)
df <- (x.var / x.n + y.var / y.n)^2L / (((x.var / x.n)^2L / (x.n - 1L)) + ((y.var / y.n)^2L / (y.n - 1L)))
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = df)
term <- crit*se
}
}
#···················
#### Confidence Interval ####
ci <- switch(alternative,
two.sided = c(low = yx.mean - term, upp = yx.mean + term),
less = c(low = -Inf, upp = yx.mean + term),
greater = c(low = yx.mean - term, upp = Inf))
# Less than 2 observations for x and y
} else {
ci <- c(NA, NA)
}
#—————————————————————————————————————— #
### Dependent Samples ####
} else {
xy.dat <- na.omit(data.frame(x = x, y = y, stringsAsFactors = FALSE))
xy.diff <- xy.dat$y - xy.dat$x
xy.diff.mean <- mean(xy.diff)
xy.diff.sd <- sd(xy.diff)
xy.diff.n <- nrow(xy.dat)
# At least 2 observations for x
if (isTRUE(xy.diff.n >= 2L && xy.diff.sd != 0L)) {
#···················
#### Known Population SD ####
if (isTRUE(!is.null(sigma))) {
se <- sigma / sqrt(xy.diff.n)
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
term <- crit*se
#···················
#### Unknown Population SD ####
} else {
se <- xy.diff.sd / sqrt(xy.diff.n)
crit <- qt(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level), df = xy.diff.n - 1L)
term <- crit*se
}
ci <- switch(alternative,
two.sided = c(low = xy.diff.mean - term, upp = xy.diff.mean + term),
less = c(low = -Inf, upp = xy.diff.mean + term),
greater = c(low = xy.diff.mean - term, upp = Inf))
# Less than 2 observations for x
} else {
ci <- c(NA, NA)
}
}
#—————————————————————————————————————— #
### Return Object ####
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the ci.prop.diff() function ---------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Confidence Interval for the Difference of Proportions ####
.prop.diff.conf <- function(x, y, method, alternative, paired, conf.level, side) {
crit <- qnorm(switch(alternative,
two.sided = 1L - (1L - conf.level) / 2L,
less = conf.level,
greater = conf.level))
#—————————————————————————————————————— #
### Independent Samples ####
if (!isTRUE(paired)) {
#···················
#### Data ####
x <- na.omit(x)
y <- na.omit(y)
x.n <- length(x)
y.n <- length(y)
p1 <- sum(x) / x.n
p2 <- sum(y) / y.n
p.diff <- p2 - p1
#···················
#### Wald Confidence Interval ####
if (isTRUE(method == "wald")) {
#......
# At least 2 observations for x or y
if (isTRUE((x.n >= 2L || y.n >= 2L) && (var(x) != 0L || var(y) != 0L))) {
term <- crit * sqrt(p1*(1 - p1) / x.n + p2*(1 - p2) / y.n)
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = max(-1L, p.diff - term), upp = min(1L, p.diff + term)),
less = c(low = -1, upp = min(1, p.diff + term)),
greater = c(low = max(-1L, p.diff - term), upp = 1L))
# Less than 2 observations for x or y
} else {
ci <- c(NA, NA)
}
#···················
#### Newcombes Hybrid Score Interval ####
} else if (isTRUE(method == "newcombe")) {
# At least 1 observations for x and y
if (isTRUE((x.n >= 1L && y.n >= 1L))) {
if (isTRUE(alternative == "two.sided")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "less")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "greater")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
}
# Confidence interval
ci <- switch(alternative,
two.sided = c(p.diff - crit * sqrt((x.ci.wilson$upp*(1 - x.ci.wilson$upp) / x.n) + (y.ci.wilson$low*(1 - y.ci.wilson$low) / y.n)),
p.diff + crit * sqrt((x.ci.wilson$low*(1 - x.ci.wilson$low) / x.n) + (y.ci.wilson$upp*(1 - y.ci.wilson$upp) / y.n))),
less = c(-1, p.diff + crit * sqrt((x.ci.wilson$low*(1 - x.ci.wilson$low) / x.n) + (y.ci.wilson$upp*(1 - y.ci.wilson$upp) / y.n))),
greater = c(p.diff - crit * sqrt((x.ci.wilson$upp*(1 - x.ci.wilson$upp) / x.n) + (y.ci.wilson$low*(1 - y.ci.wilson$low) / y.n)), 1))
# Less than 1 observations for x or y
} else {
ci <- c(NA, NA)
}
}
#—————————————————————————————————————— #
### Dependent Samples ####
} else {
xy.dat <- na.omit(data.frame(x = x, y = y, stringsAsFactors = FALSE))
x.p <- mean(xy.dat$x)
y.p <- mean(xy.dat$y)
xy.diff.mean <- y.p - x.p
xy.diff.n <- nrow(xy.dat)
a <- as.numeric(sum(xy.dat$x == 1 & xy.dat$y == 1))
b <- as.numeric(sum(xy.dat$x == 1 & xy.dat$y == 0))
c <- as.numeric(sum(xy.dat$x == 0 & xy.dat$y == 1))
d <- as.numeric(sum(xy.dat$x == 0 & xy.dat$y == 0))
#···················
#### Wald Confidence Interval ####
if (isTRUE(method == "wald")) {
#......
# At least 2 observations for x or y
if (isTRUE(xy.diff.n >= 2 && (var(xy.dat$x) != 0 || var(xy.dat$y) != 0))) {
term <- crit * sqrt((b + c) - (b - c)^2 / xy.diff.n) / xy.diff.n
#......
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = max(-1, xy.diff.mean - term), upp = min(1, xy.diff.mean + term)),
less = c(low = -1, upp = min(1, xy.diff.mean + term)),
greater = c(low = max(-1, xy.diff.mean - term), upp = 1))
} else {
ci <- c(NA, NA)
}
#···················
#### Newcombes Hybrid Score Interval ####
} else if (isTRUE(method == "newcombe")) {
# At least 1 observations for x and y
if (isTRUE(xy.diff.n >= 1L)) {
if (isTRUE(alternative == "two.sided")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "less")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
} else if (isTRUE(alternative == "greater")) {
x.ci.wilson <- misty::ci.prop(x, method = "wilson", alternative = "less", conf.level = conf.level, output = FALSE)$result
y.ci.wilson <- misty::ci.prop(y, method = "wilson", alternative = "greater", conf.level = conf.level, output = FALSE)$result
}
A <- (a + b) * (c + d) * (a + c) * (b + d)
as.numeric(a)
if (isTRUE(A == 0L)) {
phi <- 0L
} else {
phi <- (a * d - b * c) / sqrt(A)
}
ci <- switch(alternative,
two.sided = c(xy.diff.mean - sqrt((y.p - y.ci.wilson$low)^2 - 2L * phi * (y.p - y.ci.wilson$low) * (x.ci.wilson$upp - x.p) + (x.ci.wilson$upp - x.p)^2L),
xy.diff.mean + sqrt((x.p - x.ci.wilson$low)^2 - 2L * phi * (x.p - x.ci.wilson$low) * (y.ci.wilson$upp - y.p) + (y.ci.wilson$upp - y.p)^2L)),
less = c(-1L, xy.diff.mean + sqrt((x.p - x.ci.wilson$low)^2 - 2L * phi * (x.p - x.ci.wilson$low) * (y.ci.wilson$upp - y.p) + (y.ci.wilson$upp - y.p)^2L)),
greater = c(xy.diff.mean - sqrt((y.p - y.ci.wilson$low)^2 - 2L * phi * (y.p - y.ci.wilson$low) * (x.ci.wilson$upp - x.p) + (x.ci.wilson$upp - x.p)^2), 1L))
} else {
ci <- c(NA, NA)
}
}
}
#—————————————————————————————————————— #
### Return Object ####
object <- switch(side, both = ci, low = ci[1L], upp = ci[2L])
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for Plotting Confidence Intervals -------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Plot Function Confidence Interval ####
.plot.ci <- function(result, stat, group = NULL, split = NULL, point.size, point.shape, errorbar.width, dodge.width,
line, intercept, linetype, line.col, xlab, ylab, xlim , ylim, xbreaks, ybreaks,
axis.title.size, axis.text.size, strip.text.size, title, subtitle, group.col, plot.margin,
legend.title, legend.position, legend.box.margin, facet.ncol, facet.nrow, facet.scales) {
low <- upp <- x <- NULL
#—————————————————————————————————————— #
### No Grouping, No Split ####
if (isTRUE(is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(x = paste(result$var1, result$var2, sep = "\n"), y = result$cor, low = result$low, upp = result$upp)
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(x = factor(result$variable, levels = unique(result$variable)), y = result[, stat], low = result$low, upp = result$upp)
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p + ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width) +
ggplot2::geom_point(size = point.size, shape = point.shape) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#—————————————————————————————————————— #
### Grouping, No Split ####
} else if (isTRUE(!is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(group = result$group, x = paste(result$var1, result$var2, sep = "\n"), y = result$cor, low = result$low, upp = result$upp)
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(group = result$group, x = factor(result$variable, levels = unique(result$variable)), y = result[, stat], low = result$low, upp = result$upp)
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y, group = group, color = group))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p +
ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width,
position = ggplot2::position_dodge(dodge.width)) +
ggplot2::geom_point(size = point.size, shape = point.shape, position = ggplot2::position_dodge(dodge.width)) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.background = ggplot2::element_blank(),
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) }
#—————————————————————————————————————— #
### No Grouping, Split ####
} else if (isTRUE(is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()),
do.call("rbind", result)) |> (\(y) data.frame(split = y$split, x = paste(y$var1, y$var2, sep = "\n"), y = y$cor, low = y$low, upp = y$upp))()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()), do.call("rbind", result)) |>
(\(z) data.frame(split = z$split, x = factor(z$variable, levels = unique(z$variable)), y = z[, stat], low = z$low, upp = z$upp))()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p + ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width) +
ggplot2::geom_point(size = point.size, shape = point.shape) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::facet_wrap(~ split, ncol = facet.ncol, nrow = facet.nrow) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#—————————————————————————————————————— #
### Grouping, Split ####
} else if (isTRUE(!is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()),
do.call("rbind", result)) |> (\(y) data.frame(group = y$group, split = y$split, x = paste(y$var1, y$var2, sep = "\n"), y = y$cor, low = y$low, upp = y$upp))()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- data.frame(split = as.vector(sapply(result, nrow) |> (\(y) unlist(sapply(seq_len(length(result)), function(z) rep(names(y)[z], times = y[z]))))()), do.call("rbind", result)) |>
(\(z) data.frame(group = z$group, split = z$split, x = factor(z$variable, levels = unique(z$variable)), y = z[, stat], low = z$low, upp = z$upp))()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(x, y, group = group, color = group))
#...................
#### Horizontal Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_hline(yintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Error Bars ####
p <- p +
ggplot2::geom_errorbar(ggplot2::aes(ymin = low, ymax = upp), width = errorbar.width,
position = ggplot2::position_dodge(dodge.width)) +
ggplot2::geom_point(size = point.size, shape = point.shape, position = ggplot2::position_dodge(dodge.width)) +
ggplot2::scale_x_discrete(name = xlab) +
ggplot2::scale_y_continuous(name = ylab, limits = ylim, breaks = ybreaks) +
ggplot2::facet_wrap(~ split, ncol = facet.ncol, nrow = facet.nrow) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) }
}
return(list(p = p, plotdat = plotdat))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Plot Function Bootstrap Samples ####
.plot.boot <- function(result, boot.sample, stat, group = NULL, split = NULL, hist, binwidth, bins, alpha, fill,
density, density.col, density.linewidth, density.linetype, plot.point, point.col, point.linewidth, point.linetype,
plot.ci, ci.col, ci.linewidth, ci.linetype, line, intercept, linetype, line.col,
xlab, ylab, xlim, ylim, xbreaks, ybreaks, axis.title.size, axis.text.size, strip.text.size, title, subtitle, group.col,
plot.margin, legend.title, legend.position, legend.box.margin, facet.ncol, facet.nrow, facet.scales) {
point <- low <- upp <- NULL
#—————————————————————————————————————— #
### No Grouping, No Split ####
if (isTRUE(is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), y = boot.sample$cor),
data.frame(x = paste(result$var1, result$var2, sep = " - "), point = result$cor, low = result$low, upp = result$upp), by = "x")
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(x = factor(boot.sample$variable, levels = unique(result$variable)), y = boot.sample[, stat]),
data.frame(x = factor(result$variable, levels = unique(result$variable)), point = result[, stat], low = result$low, upp = result$upp), by = "x")
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y)) +
ggplot2::facet_wrap(~ x, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density)), binwidth = binwidth, bins = bins, color = "black", alpha = alpha, fill = fill) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- p + ggplot2::geom_density(color = density.col, linewidth = density.linewidth, linetype = density.linetype) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = point), color = point.col, linetype = point.linetype, linewidth = point.linewidth) }
#...................
### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low), color = ci.col, linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp), color = ci.col, linetype = ci.linetype , linewidth = ci.linewidth) }
#—————————————————————————————————————— #
### Grouping, No Split ####
} else if (isTRUE(!is.null(group) && is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$group, boot.sample$var1, boot.sample$var2, sep = " - ")), x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), group = factor(boot.sample$group, levels = unique(result$group)), y = boot.sample$cor),
data.frame(by = factor(paste(result$group, result$var1, result$var2, sep = " - ")), point = result$cor, low = result$low, upp = result$upp), by = "by") |> (\(y) y[, -grep("by", colnames(y))])()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$group, boot.sample$variable, sep = " - ")), x = factor(boot.sample$variable, levels = unique(result$variable)), group = factor(boot.sample$group, levels = unique(result$group)), y = boot.sample[, stat]),
data.frame(by = factor(paste(result$group, result$variable, sep = " - ")), point = result[, stat], low = result$low, upp = result$upp), by = "by") |> (\(y) y[, -grep("by", colnames(y))])()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y, group = group, color = group)) +
ggplot2::facet_wrap(~ x, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title, fill = legend.title) +
ggplot2::guides(color = "none") +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.background = ggplot2::element_blank(),
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density), fill = group), position = "identity", binwidth = binwidth, bins = bins, color = "black", alpha = alpha) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- suppressMessages(p + ggplot2::geom_density(alpha = alpha, linewidth = density.linewidth, linetype = density.linetype)) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = point, color = group), linetype = point.linetype, linewidth = point.linewidth) }
#...................
#### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low, color = group), linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp, color = group), linetype = ci.linetype, linewidth = ci.linewidth) }
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) + ggplot2::scale_fill_manual(values = group.col) }
#—————————————————————————————————————— #
### No Grouping, Split ####
} else if (isTRUE(is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$var1, boot.sample$var2, sep = " - ")), x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), split = factor(boot.sample$split, levels = names(result)), y = boot.sample$cor),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$var1, y$var2, sep = " - ")), point = y$cor, low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$variable, sep = " - ")), x = factor(boot.sample$variable, levels = unique(do.call("rbind", result)$variable)), split = factor(boot.sample$split, levels = names(result)), y = boot.sample[, stat]),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$variable, sep = " - ")), point = y[, stat], low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y)) +
ggplot2::facet_wrap(~ x + split, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle) +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density)), binwidth = binwidth, bins = bins, color = "black", alpha = alpha, fill = fill) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- p + ggplot2::geom_density(color = density.col, linewidth = density.linewidth, linetype = density.linetype) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = point), color = point.col, linetype = point.linetype, linewidth = point.linewidth) }
#...................
#### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low), color = ci.col, linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp), color = ci.col, linetype = ci.linetype, linewidth = ci.linewidth) }
#—————————————————————————————————————— #
### Grouping, Split ####
} else if (isTRUE(!is.null(group) && !is.null(split))) {
#...................
#### Plot Data ####
# Correlation coefficient
if (isTRUE(stat == "cor")) {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$group, boot.sample$var1, boot.sample$var2, sep = " - ")), x = paste(boot.sample$var1, boot.sample$var2, sep = " - "), split = factor(boot.sample$split, levels = names(result)), group = factor(boot.sample$group, levels = unique(do.call("rbind", result)$group)), y = boot.sample$cor),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$group, y$var1, y$var2, sep = " - ")), point = y$cor, low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
# Mean, Median, Proportion, SD, Variance
} else {
plotdat <- merge(data.frame(by = factor(paste(boot.sample$split, boot.sample$group, boot.sample$variable, sep = " - ")), x = factor(boot.sample$variable, levels = unique(do.call("rbind", result)$variable)), split = factor(boot.sample$split, levels = names(result)), group = factor(boot.sample$group, levels = unique(do.call("rbind", result)$group)), y = boot.sample[, stat]),
data.frame(split = rep(names(result), each = unique(sapply(result, nrow))), do.call("rbind", result)) |> (\(y) data.frame(by = factor(paste(y$split, y$group, y$variable, sep = " - ")), point = y[, stat], low = y$low, upp = y$upp))(), by = "by") |> (\(z) z[, -grep("by", names(z))])()
}
#...................
#### Create ggplot ####
p <- ggplot2::ggplot(plotdat, ggplot2::aes(y, group = group, color = group)) +
ggplot2::facet_wrap(~ x + split, scales = facet.scales) +
ggplot2::scale_x_continuous(name = xlab, expand = c(0.02, 0), limits = xlim, breaks = xbreaks) +
ggplot2::scale_y_continuous(name = ylab, expand = ggplot2::expansion(mult = c(0L, 0.05))) +
ggplot2::labs(title = title, subtitle = subtitle, color = legend.title, fill = legend.title) +
ggplot2::guides(color = "none") +
ggplot2::theme_bw() +
ggplot2::theme(plot.subtitle = ggplot2::element_text(hjust = 0.5),
strip.text = ggplot2::element_text(size = strip.text.size),
plot.title = ggplot2::element_text(hjust = 0.5),
plot.margin = ggplot2::unit(c(plot.margin[1L], plot.margin[2L], plot.margin[3L], plot.margin[4L]), "pt"),
axis.text = ggplot2::element_text(size = axis.text.size),
axis.title = ggplot2::element_text(size = axis.title.size),
legend.position = legend.position,
legend.box.background = ggplot2::element_blank(),
legend.box.margin = ggplot2::margin(legend.box.margin[1L], legend.box.margin[2L], legend.box.margin[3L], legend.box.margin[4L]))
#...................
#### Histogram ####
if (isTRUE(hist)) { p <- p + ggplot2::geom_histogram(ggplot2::aes(y = ggplot2::after_stat(density), fill = group), position = "identity", binwidth = binwidth, bins = bins, color = "black", alpha = alpha) }
#...................
#### Density Curve ####
if (isTRUE(density)) { p <- p + ggplot2::geom_density(alpha = alpha, linewidth = density.linewidth, linetype = density.linetype) }
#...................
#### Vertical Line ####
if (isTRUE(line)) { p <- p + ggplot2::geom_vline(xintercept = intercept, linetype = linetype, color = line.col) }
#...................
#### Point Estimate ####
if (isTRUE(plot.point)) { p <- p + ggplot2::geom_vline(plotdat, ggplot2::aes(xintercept = point, color = group), linetype = point.linetype, linewidth = point.linewidth) }
#...................
#### Confidence Interval ####
if (isTRUE(plot.ci)) { p <- p + ggplot2::geom_vline(ggplot2::aes(xintercept = low, color = group), linetype = ci.linetype, linewidth = ci.linewidth) + ggplot2::geom_vline(ggplot2::aes(xintercept = upp, color = group), linetype = ci.linetype, linewidth = ci.linewidth) }
#...................
#### Manual Colors ####
if (isTRUE(!is.null(group.col))) { p <- p + ggplot2::scale_color_manual(values = group.col) }
}
return(list(p = p, plotdat = plotdat))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the df.rbind() function -------------------------------
#
# - .make_names
# - .quickdf
# - .make_assignment_call
# - .allocate_column
# - .output_template
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .make_names ####
.make_names <- function(x, prefix = "X") {
nm <- names(x)
if (isTRUE(is.null(nm))) {
nm <- rep.int("", length(x))
}
n <- sum(nm == "", na.rm = TRUE)
nm[nm == ""] <- paste0(prefix, seq_len(n))
return(nm)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .quickdf ####
.quickdf <- function (list) {
rows <- unique(unlist(lapply(list, NROW)))
stopifnot(length(rows) == 1L)
names(list) <- .make_names(list, "X")
class(list) <- "data.frame"
attr(list, "row.names") <- c(NA_integer_, -rows)
return(list)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .make_assignment_call ####
.make_assignment_call <- function (ndims) {
assignment <- quote(column[rows] <<- what)
if (isTRUE(ndims >= 2L)) {
assignment[[2L]] <- as.call(c(as.list(assignment[[2]]), rep(list(quote(expr = )), ndims - 1L)))
}
return(assignment)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .allocate_column ####
.allocate_column <- function(example, nrows, dfs, var) {
a <- attributes(example)
type <- typeof(example)
class <- a$class
isList <- is.recursive(example)
a$names <- NULL
a$class <- NULL
if (isTRUE(is.data.frame(example))) {
stop("Data frame column '", var, "' not supported by the df.rbind() function.", call. = FALSE)
}
if (isTRUE(is.array(example))) {
if (isTRUE(length(dim(example)) > 1L)) {
if (isTRUE("dimnames" %in% names(a))) {
a$dimnames[1L] <- list(NULL)
if (isTRUE(!is.null(names(a$dimnames))))
names(a$dimnames)[1L] <- ""
}
# Check that all other args have consistent dims
df_has <- vapply(dfs, function(df) var %in% names(df), FALSE)
dims <- unique(lapply(dfs[df_has], function(df) dim(df[[var]])[-1]))
if (isTRUE(length(dims) > 1L))
stop("Array variable ", var, " has inconsistent dimensions.", call. = FALSE)
a$dim <- c(nrows, dim(example)[-1L])
length <- prod(a$dim)
} else {
a$dim <- NULL
a$dimnames <- NULL
length <- nrows
}
} else {
length <- nrows
}
if (isTRUE(is.factor(example))) {
df_has <- vapply(dfs, function(df) var %in% names(df), FALSE)
isfactor <- vapply(dfs[df_has], function(df) is.factor(df[[var]]), FALSE)
if (isTRUE(all(isfactor))) {
levels <- unique(unlist(lapply(dfs[df_has], function(df) levels(df[[var]]))))
a$levels <- levels
handler <- "factor"
} else {
type <- "character"
handler <- "character"
class <- NULL
a$levels <- NULL
}
} else if (isTRUE(inherits(example, "POSIXt"))) {
tzone <- attr(example, "tzone")
class <- c("POSIXct", "POSIXt")
type <- "double"
handler <- "time"
} else {
handler <- type
}
column <- vector(type, length)
if (isTRUE(!isList)) {
column[] <- NA
}
attributes(column) <- a
assignment <- .make_assignment_call(length(a$dim))
setter <- switch(
handler,
character = function(rows, what) {
what <- as.character(what)
eval(assignment)
},
factor = function(rows, what) {
#duplicate what `[<-.factor` does
what <- match(what, levels)
#no need to check since we already computed levels
eval(assignment)
},
time = function(rows, what) {
what <- as.POSIXct(what, tz = tzone)
eval(assignment)
},
function(rows, what) {
eval(assignment)
})
getter <- function() {
class(column) <<- class
column
}
list(set = setter, get = getter)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .output_template ####
.output_template <- function(dfs, nrows) {
vars <- unique(unlist(lapply(dfs, base::names)))
output <- vector("list", length(vars))
names(output) <- vars
seen <- rep(FALSE, length(output))
names(seen) <- vars
for (df in dfs) {
matching <- intersect(names(df), vars[!seen])
for (var in matching) {
output[[var]] <- .allocate_column(df[[var]], nrows, dfs, var)
}
seen[matching] <- TRUE
if (isTRUE(all(seen))) break
}
list(setters = lapply(output, `[[`, "set"), getters = lapply(output, `[[`, "get"))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the coding() function ---------------------------------
#
# - .contr.sum
# - .contr.wec
# - .contr.repeat
# - .forward.helmert
# - .reverse.helmert
#
# wec: wec: Weighted Effect Coding
# https://cran.r-project.org/web/packages/wec/index.html
#
# MASS: Support Functions and Datasets for Venables and Ripley's MASS
# https://cran.r-project.org/web/packages/MASS/index.html
#
# codingMatrices: Alternative Factor Coding Matrices for Linear Model Formulae
# https://cran.r-project.org/web/packages/codingMatrices/index.html
#
# faux: Simulation for Factorial Designs
# https://cran.r-project.org/web/packages/faux/index.html
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr.sum Function from the stats Package ####
.contr.sum <- function(n, omitted) {
cont <- structure(diag(1L, length(n), length(n)), dimnames = list(n, n))
cont <- cont[, -omitted, drop = FALSE]
cont[omitted, ] <- -1L
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr.wec Function from the wec Package ####
.contr.wec <- function (x, omitted) {
frequ <- table(x)
omitted <- which(names(frequ) == omitted)
cont <- contr.treatment(length(frequ), base = omitted)
cont[omitted, ] <- -1L * frequ[-omitted] / frequ[omitted]
colnames(cont) <- names(frequ[-omitted])
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr.sdif Function from the MASS Package ####
.contr.repeat <- function(n) {
n.length <- length(n)
cont <- col(matrix(nrow = n.length, ncol = n.length - 1L))
upper.tri <- !lower.tri(cont)
cont[upper.tri] <- cont[upper.tri] - n.length
cont <- structure(cont / n.length, dimnames = list(n, n[-1L]))
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified code_helmert_forward Function from the codingMatrices Package ####
.forward.helmert <- function(n) {
n.length <- length(n)
cont <- rbind(diag(n.length:2L - 1L), 0)
cont[lower.tri(cont)] <- -1L
cont <- cont / rep(n.length:2L, each = n.length)
dimnames(cont) <- list(n, n[1L:ncol(cont)])
return(cont)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified contr_code_helmert Function from the faux Package ####
.reverse.helmert <- function(n) {
n.length <- length(n)
cont <- contr.helmert(n.length)
for (i in 1L:(n.length - 1L)) {
cont[, i] <- cont[, i] / (i + 1L)
}
comparison <- lapply(1L:(n.length - 1L), function(y) {
paste(n[1L:y], collapse = ".")
})
dimnames(cont) <- list(n, n[-1L])
return(cont)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the cohens.d() function -------------------------------
.internal.d.function <- function(x, y, mu, paired, weighted, cor, ref, correct,
alternative, conf.level) {
#—————————————————————————————————————— #
### One-Sample ####
if (isTRUE(is.null(y))) {
# Unstandardized mean difference
yx.diff <- mean(x, na.rm = TRUE) - mu
# Standard deviation
sd.group <- x.sd <- sd(x, na.rm = TRUE)
# Sample size
x.n <- length(na.omit(x))
#···················
#### Cohen's d ####
d <- yx.diff / sd.group
#···················
#### Correction Factor ####
# Bias-corrected Cohen's d
if (isTRUE(correct)) {
v <- x.n - 1
# Correction factor based on gamma function
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2L)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation method
if (isTRUE(is.na(corr.factor) || is.nan(corr.factor) || is.infinite(corr.factor))) {
corr.factor <- (1L - (3L / (4L * v - 1L)))
}
d <- d*corr.factor
}
#···················
#### Confidence Interval ####
# Standard error
d.se <- sqrt((x.n / (x.n / 2L)^2L) + 0.5*(d^2L / x.n))
# Noncentrality parameter
t <- yx.diff / (x.sd / sqrt(x.n))
df <- x.n - 1
conf1 <- ifelse(alternative == "two.sided", (1L + conf.level) / 2L, conf.level)
conf2 <- ifelse(alternative == "two.sided", (1L - conf.level) / 2L, 1L - conf.level)
st <- max(0.1, abs(t))
###
end1 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end1)) < conf1) { end1 <- end1 - st }
ncp1 <- uniroot(function(x) conf1 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(end1, 2*t - end1))$root
###
end2 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end2)) > conf2) { end2 <- end2 + st }
ncp2 <- uniroot(function(x) conf2 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(2*t - end2, end2))$root
# Confidence interval around ncp
conf.int <- switch(alternative,
two.sided = c(low = ncp1 / sqrt(df), upp = ncp2 / sqrt(df)),
less = c(low = -Inf, upp = ncp2 / sqrt(df)),
greater = c(low = ncp1 / sqrt(df), upp = Inf))
# With correction factor
if(isTRUE(correct)) {
conf.int <- conf.int*corr.factor
}
#—————————————————————————————————————— #
### Two-Sample ####
} else if (!isTRUE(paired)) {
#···················
#### Data ####
# x and y
x <- na.omit(x)
y <- na.omit(y)
# Sample size for x and y
x.n <- length(x)
y.n <- length(y)
# Total sample size
xy.n <- sum(c(x.n, y.n))
# Unstandardized mean difference
yx.diff <- mean(y) - mean(x)
# Variance
x.var <- var(x)
y.var <- var(y)
# Standard deviation
x.sd <- sd(x)
y.sd <- sd(y)
# At least 2 observations for x/y and variance in x/y
if (isTRUE((x.n >= 2L && y.n >= 2L) && (x.var != 0L && y.var != 0L))) {
#···················
#### Standard Deviation ####
# Pooled standard deviation
if (isTRUE(is.null(ref))) {
# Weighted pooled standard deviation, Cohen's d.s
if (isTRUE(weighted)) {
sd.group <- sqrt(((x.n - 1L)*x.var + (y.n - 1L)*y.var) / (xy.n - 2L))
# Unweighted pooled standard deviation
} else {
sd.group <- sqrt(sum(c(x.var, y.var)) / 2L)
}
# Standard deviation from reference group x or y, Glass's delta
} else {
sd.group <- ifelse(ref == "x", x.sd, y.sd)
}
#···················
#### Cohen's d ####
d <- yx.diff / sd.group
#···················
#### Correction Factor ####
# Bias-corrected Cohen's d, i.e., Hedges' g
if (isTRUE(correct)) {
# Degrees of freedom
v <- xy.n - 2L
# Correction factor based on gamma function
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2L)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation method
if (isTRUE(is.na(corr.factor) || is.nan(corr.factor) || is.infinite(corr.factor))) {
corr.factor <- (1L - (3L / (4L * v - 1L)))
}
# Applying correction factor
d <- d*corr.factor
}
#···················
#### Confidence Interval ####
# No reference group
if (isTRUE(is.null(ref))) {
# Cohen's d.s
# Pooled standard deviation
if (isTRUE(weighted)) {
d.se <- sd.group * sqrt(1 / x.n + 1 / y.n)
df <- xy.n - 2
# Unpooled standard deviation
} else {
d.se <- sqrt(sqrt(x.sd^2 / x.n)^2 + sqrt(y.sd^2 / y.n)^2)
df <- d.se^4 / ( sqrt(x.sd^2 / x.n)^4 / (x.n - 1) + sqrt(y.sd^2 / y.n)^4 / (y.n - 1))
}
t <- yx.diff / d.se
hn <- sqrt(1 / x.n + 1 / y.n)
# Reference group
} else {
d.se <- sqrt(sd(c(x, y))^2*(1 / x.n + 1 / y.n))
df <- x.n + y.n - 2
t <- yx.diff / d.se
hn <- sqrt(1 / x.n + 1 / y.n)
}
conf1 <- ifelse(alternative == "two.sided", (1 + conf.level) / 2, conf.level)
conf2 <- ifelse(alternative == "two.sided", (1 - conf.level) / 2, 1 - conf.level)
# Noncentrality parameter
st <- max(0.1, abs(t))
###
end1 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end1)) < conf1) { end1 <- end1 - st }
ncp1 <- uniroot(function(x) conf1 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(end1, 2*t - end1))$root
###
end2 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end2)) > conf2) { end2 <- end2 + st }
ncp2 <- uniroot(function(x) conf2 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(2*t - end2, end2))$root
# Confidence interval around ncp
conf.int <- switch(alternative,
two.sided = c(low = ncp1 * hn, upp = ncp2 * hn),
less = c(low = -Inf, upp = ncp2 * hn),
greater = c(low = ncp1 * hn, upp = Inf))
# With correction factor
if(isTRUE(correct)) {
conf.int <- conf.int*corr.factor
}
# Not at least 2 observations for x/y and variance in x/y
} else {
d <- d.se <- sd.group <- NA
conf.int <- c(NA, NA)
}
#—————————————————————————————————————— #
### Paired-Sample ####
} else if (isTRUE(paired)) {
#···················
#### Data ####
xy.dat <- na.omit(data.frame(x = x, y = y, stringsAsFactors = FALSE))
x <- xy.dat$x
y <- xy.dat$y
# Standard deviation of x and y
x.sd <- sd(x)
y.sd <- sd(y)
# Unstandardized mean difference
yx.diff <- mean(y - x)
# Sample size
xy.n <- nrow(xy.dat)
#···················
#### Standard Deviation ####
# SD of difference score, Cohen's d.z
if (isTRUE(weighted)) {
sd.group <- sd(y - x)
} else {
# Controlling correlation, Cohen's d.rm
if (isTRUE(cor)) {
# Variance of x and y
x.var <- var(x)
y.var <- var(y)
# Sum of the variances
xy.var.sum <- sum(c(x.var, y.var))
# Correlation between x and y
xy.r <- cor(x, y)
sd.group <- sqrt(xy.var.sum - 2L * xy.r * prod(c(sqrt(x.var), sqrt(y.var))))
# Ignoring correlation, Cohen's d.av
} else {
sd.group <- (x.sd + y.sd) / 2
}
}
#···················
#### Cohen's d ####
# Cohen's d.rm
if (isTRUE(cor && !isTRUE(weighted))) {
d <- yx.diff / sd.group * sqrt(2L*(1L -xy.r))
# Cohen's d.z, d.av, and Glass's delta
} else {
d <- yx.diff / sd.group
}
#···················
#### Correction Factor ####
# Degrees of freedom
v <- xy.n - 1
# Correction factor based on gamma function
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2L)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation method
if (isTRUE(is.na(corr.factor) || is.nan(corr.factor) || is.infinite(corr.factor))) {
corr.factor <- 1L - 3L / (4L * v - 1L)
}
# Bias-corrected Cohen's d
if (isTRUE(correct)) {
d <- d*corr.factor
}
#···················
#### Confidence Interval ####
# Standard error
d.se <- sqrt((xy.n / (xy.n / 2)^2) + 0.5*(d^2 / xy.n))
# Noncentrality parameter
t <- yx.diff / (sd.group / sqrt(xy.n))
df <- xy.n - 1
conf1 <- ifelse(alternative == "two.sided", (1L + conf.level) / 2L, conf.level)
conf2 <- ifelse(alternative == "two.sided", (1L - conf.level) / 2L, 1L - conf.level)
st <- max(0.1, abs(t))
###
end1 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end1)) < conf1) { end1 <- end1 - st }
ncp1 <- uniroot(function(x) conf1 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(end1, 2*t - end1))$root
###
end2 <- t
while(suppressWarnings(pt(q = t, df = df, ncp = end2)) > conf2) { end2 <- end2 + st }
ncp2 <- uniroot(function(x) conf2 - suppressWarnings(pt(q = t, df = df, ncp = x)), c(2*t - end2, end2))$root
# Confidence interval around ncp
conf.int <- switch(alternative,
two.sided = c(low = ncp1 / sqrt(df), upp = ncp2 / sqrt(df)),
less = c(low = -Inf, upp = ncp2 / sqrt(df)),
greater = c(low = ncp1 / sqrt(df), upp = Inf))
# With correction factor
if(isTRUE(correct)) {
conf.int <- conf.int*corr.factor
}
}
# Return object
object <- data.frame(m.diff = yx.diff, sd = sd.group,
d = d, se = d.se,
low = conf.int[1L], upp = conf.int[2], row.names = NULL)
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the cor.matrix() function -----------------------------
#
# - .cor.test.pearson
# - .cor.test.spearman
# - .cor.test.kendall.b
# - .cor.test.kendall.c
# - .polychoric
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.pearson Function ####
.cor.test.pearson <- function(x, y) {
# At least three cases
object <- if (isTRUE(nrow(na.omit(data.frame(x = x, y = y))) >= 3L)) {
suppressWarnings(cor.test(x, y, method = "pearson")) |> (\(p) list(cor = p$estimate, stat = p$statistic, df = p$parameter, pval = p$p.value))()
# Less than three cases
} else {
list(cor = NA, stat = NA, df = NA, pval = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.spearman Function ####
.cor.test.spearman <- function(x, y, exact, continuity) {
# At least three cases
object <- if (isTRUE(nrow(na.omit(data.frame(x = x, y = y))) >= 3L)) {
# Complete data
xy <- na.omit(data.frame(x = x, y = y))
# Statistical test for the correlation coefficient
if (isTRUE(exact)) {
suppressWarnings(cor.test(xy$x, xy$y, method = "spearman", exact = TRUE, continuity = continuity)) |> (\(p) list(cor = p$estimate, stat = p$statistic, df = NA, pval = p$p.value))()
} else {
cor(xy$x, xy$y, method = "spearman", use = "pairwise.complete.obs") |> (\(p) list(cor = p, stat = p*sqrt((nrow(xy) - 2L) / (1L - p^2L)), df = nrow(xy) - 2L, pval = cor.test(xy$x, xy$y, method = "spearman", exact = FALSE, continuity = continuity)$p.value) )()
}
# Less than three cases
} else {
list(cor = NA, stat = NA, df = NA, pval = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .internal.cor.test.kendall.b Function ####
.cor.test.kendall.b <- function(x, y, exact, continuity) {
# At least three cases
if (isTRUE(nrow(na.omit(data.frame(x = x, y = y))) >= 3L)) {
# Statistical test for the correlation coefficient
object <- suppressWarnings(cor.test(x, y, method = "kendall", exact = exact, continuity = continuity)) |> (\(p) list(cor = p$estimate, stat = p$statistic, df = NA, pval = p$p.value))()
# Less than three cases
} else {
object <- list(stat = NA, df = NA, pval = NA)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.kendall.c Function ####
.cor.test.kendall.c <- function(x, y) {
# Contingency table
x.table <- table(x, y)
# Number of rows
x.nrow <- nrow(x.table)
# Number of columns
x.ncol <- ncol(x.table)
# Sample size
x.n <- sum(x.table)
# Minimum of number of rows/columns
x.m <- min(dim(x.table))
if (isTRUE(x.n > 1L && x.nrow > 1L && x.ncol > 1L)) {
pi.c <- pi.d <- matrix(0L, nrow = x.nrow, ncol = x.ncol)
x.col <- col(x.table)
x.row <- row(x.table)
for (i in 1L:x.nrow) {
for (j in 1L:x.ncol) {
pi.c[i, j] <- sum(x.table[x.row < i & x.col < j]) + sum(x.table[x.row > i & x.col > j])
pi.d[i, j] <- sum(x.table[x.row < i & x.col > j]) + sum(x.table[x.row > i & x.col < j])
}
}
# Concordant
x.con <- sum(pi.c * x.table)/2L
# Discordant
x.dis <- sum(pi.d * x.table)/2L
# Kendall-Stuart Tau-c
tau.c <- (x.m*2L * (x.con - x.dis)) / ((x.n^2L) * (x.m - 1L))
} else {
tau.c <- NA
}
#—————————————————————————————————————— #
### If n > 2 ####
if (isTRUE(x.n > 2L & x.nrow > 1L & x.ncol > 1L)) {
# Test statistic
z <- tau.c / sqrt(4L * x.m^2L / ((x.m - 1L)^2L * x.n^4L) * (sum(x.table * (pi.c - pi.d)^2L) - 4L * (x.con - x.dis)^2L / x.n))
# Two-tailed p-value
pval <- pnorm(abs(z), lower.tail = FALSE)*2L
} else {
z <- NA
pval <- NA
}
object <- list(result = list(cor = tau.c, n = x.n, stat = z, df = NA, pval = pval))
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cor.test.polychoric Function ####
#
# Modified function polychor() from the polycor package
# see: https://github.com/cran/polycor/blob/master/R/polychor.R
.cor.test.polychoric <- function (x, y, ml = FALSE, se = FALSE, maxcor = 0.9999) {
#—————————————————————————————————————— #
### Function ####
f <- function(pars) {
if (isTRUE(length(pars) == 1L)) {
rho <- pars
if (isTRUE(abs(rho) > maxcor)) { rho <- sign(rho)*maxcor }
row.cuts <- rc
col.cuts <- cc
} else {
rho <- pars[1L]
if (isTRUE(abs(rho) > maxcor)) { rho <- sign(rho)*maxcor }
row.cuts <- pars[2L:r]
col.cuts <- pars[(r + 1L):(r + c - 1L)]
if (isTRUE(any(diff(row.cuts) < 0L) || any(diff(col.cuts) < 0))) { return(Inf) }
}
P <- .binBvn(rho, row.cuts, col.cuts)
return(-sum(tab * log(P)))
}
#—————————————————————————————————————— #
valid <- complete.cases(x, y)
x <- x[valid]
y <- y[valid]
tab <- if (isTRUE(missing(y))) { x } else { table(x, y) }
zerorows <- apply(tab, 1L, function(x) all(x == 0))
zerocols <- apply(tab, 2L, function(x) all(x == 0))
zr <- sum(zerorows)
zc <- sum(zerocols)
tab <- tab[!zerorows, , drop = FALSE]
tab <- tab[, !zerocols, drop = FALSE]
r <- nrow(tab)
c <- ncol(tab)
if (isTRUE(r < 2 || c < 2)) { return(NA) }
n <- sum(tab)
rc <- qnorm(cumsum(rowSums(tab)) / n)[-r]
cc <- qnorm(cumsum(colSums(tab)) / n)[-c]
#—————————————————————————————————————— #
### Maximum-Likelihood Estimate ####
if (isTRUE(ml)) {
res.optim <- tryCatch(optim(c(stats::optimise(f, interval = c(-1L, 1L))$minimum, rc, cc), f, hessian = se),
error = function(y) {
return(list(par = NA, se = NA, hessian = NA))
})
if (isTRUE(res.optim$par[1L] > 1L)) { res.optim$par[1L] <- maxcor } else if (isTRUE(res.optim$par[1L] < -1L)) { res.optim$par[1L] <- -maxcor }
if (isTRUE(se)) {
result <- list(cor = res.optim$par[1L], se = ifelse(!is.na(res.optim$hessian), sqrt(solve(res.optim$hessian)[1L, 1L]), NA))
} else {
result <- list(cor = as.vector(res.optim$par[1L]), se = NA)
}
#—————————————————————————————————————— #
### Two-Step Approximation ####
} else if (isTRUE(se)) {
res.optim <- tryCatch(suppressWarnings(optim(0L, f, hessian = TRUE, method = "BFGS")),
error = function(y) {
return(list(par = NA, se = NA, hessian = NA))
})
if (isTRUE(res.optim$par > 1L)) { res.optim$par <- maxcor } else if (isTRUE(res.optim$par < -1L)) { res.optim$par <- -maxcor }
result <- list(cor = res.optim$par, se = ifelse(!is.na(res.optim$hessian), sqrt(1L / res.optim$hessian), NA))
} else {
result <- list(cor = stats::optimise(f, interval = c(-maxcor, maxcor))$minimum, se = NA)
}
#—————————————————————————————————————— #
### Return Object ####
return(list(result = list(cor = result$cor,
n = sum(valid),
stat = ifelse(!is.na(result$se), result$cor / result$se, NA),
df = NA,
pval = ifelse(!is.na(result$se), pnorm(abs(result$cor / result$se), lower.tail = FALSE) * 2L, NA))))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .binBvn Function from the polycor Package ####
.binBvn <- function(rho, row.cuts, col.cuts, bins = 4L){
row.cuts <- if (isTRUE(missing(row.cuts))) { c(-Inf, 1:(bins - 1L) / bins, Inf) } else { c(-Inf, row.cuts, Inf) }
col.cuts <- if (isTRUE(missing(col.cuts))) { c(-Inf, 1:(bins - 1L) / bins, Inf) } else { c(-Inf, col.cuts, Inf) }
r <- length(row.cuts) - 1L
c <- length(col.cuts) - 1L
P <- matrix(0L, r, c)
R <- matrix(c(1L, rho, rho, 1L), 2L, 2L)
for (i in seq_len(r)) {
for (j in seq_len(c)) {
P[i, j] <- mvtnorm::pmvnorm(lower=c(row.cuts[i], col.cuts[j]), upper = c(row.cuts[i + 1L], col.cuts[j + 1]), corr = R)
}
}
return(P)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the difftest.chibarsq() function ----------------------
.find.c2 <- function(weight, k, u, alpha) {
function(x) {
y <- numeric(1L)
p <- 0L
for (i in 1L:(k + 1L)) { p = p + weight[i] * (1L - pchisq(x, (u + i - 1L))) }
y <- p - alpha
return(y)
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the dominance() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Dominance analysis supporting formula-based modeling functions ####
.domin <- function(formula_overall, reg, fitstat, sets = NULL, all = NULL,
conditional = TRUE, complete = TRUE, consmodel = NULL, reverse = FALSE, ...) {
# Input check
if (isTRUE(!inherits(formula_overall, "formula"))) { stop(paste(formula_overall, "is not a 'formula' class object."), call. = FALSE) }
if (isTRUE(!is.null(attr(stats::terms(formula_overall), "offset")))) { stop("'offset()' terms not allowed in formula object.", call. = FALSE) }
if (isTRUE(!is.list(fitstat))) { stop("fitstat is not a list.", call. = FALSE) }
if (isTRUE(length(sets) > 0L & !is.list(sets))) { stop("sets is not a list.", call. = FALSE) }
if (isTRUE(is.list(all))) { stop("all is a list. Please submit it as a vector.", call. = FALSE) }
if (isTRUE(!attr(stats::terms(formula_overall), "response"))) { stop(paste(deparse(formula_overall), "missing a response."), call. = FALSE) }
if (isTRUE(any(attr(stats::terms(formula_overall), "order") > 1L))) { warning(paste(deparse(formula_overall), "contains second or higher order terms, fsunction may not handle them correctly."), call. = FALSE) }
if (isTRUE(length(fitstat) < 2L)) { stop("fitstat requires at least two elements.", call. = FALSE) }
# Process variable lists
Indep_Vars <- attr(stats::terms(formula_overall), "term.labels")
intercept <- as.logical(attr(stats::terms(formula_overall), "intercept"))
if (isTRUE(length(sets) > 0L)) {
set_aggregated <- sapply(sets, paste0, collapse = " + ")
Indep_Vars <- append(Indep_Vars, set_aggregated)
}
Dep_Var <- attr(stats::terms(formula_overall), "variables")[[2L]]
Total_Indep_Vars <- length(Indep_Vars)
# IV-based exit conditions
if (isTRUE(Total_Indep_Vars < 2L)) { stop(paste("Total of", Total_Indep_Vars, "independent variables or sets. At least 2 needed for useful dominance analysis."), call. = FALSE) }
# Create independent variable/set combination list
Combination_Matrix <- expand.grid(lapply(1:Total_Indep_Vars, function(x) c(FALSE, TRUE)), KEEP.OUT.ATTRS = FALSE)[-1L, ]
Total_Models_to_Estimate <- 2L**Total_Indep_Vars - 1L
# Define function to call regression models
doModel_Fit <- function(Indep_Var_Combin_lgl, Indep_Vars, Dep_Var, reg, fitstat, all = NULL, consmodel = NULL, intercept, ...) {
Indep_Var_Combination <- Indep_Vars[Indep_Var_Combin_lgl]
formula_to_use <- stats::reformulate(c(Indep_Var_Combination, all, consmodel), response = Dep_Var, intercept = intercept)
Model_Result <- list(do.call(reg, list(formula_to_use, ...)))
if (isTRUE(length(fitstat) > 2L)) { Model_Result <- append(Model_Result, fitstat[3L:length(fitstat)]) }
Fit_Value <- do.call(fitstat[[1L]], Model_Result)
return( Fit_Value[[ fitstat[[2L]]]])
}
# Constant model adjustments
Cons_Result <- NULL
FitStat_Adjustment <- 0L
if (isTRUE(length(consmodel) > 0L)) {
FitStat_Adjustment <- Cons_Result <- doModel_Fit(NULL, Indep_Vars, Dep_Var, reg, fitstat, consmodel = consmodel, intercept = intercept, ...)
}
# All subsets adjustment
All_Result <- NULL
if (isTRUE(length(all) > 0L)) {
FitStat_Adjustment <- All_Result <- doModel_Fit(NULL, Indep_Vars, Dep_Var, reg, fitstat, all = all, consmodel = consmodel, intercept = intercept, ...)
}
# Obtain all subsets regression results
Ensemble_of_Models <- sapply(1L:nrow(Combination_Matrix), function(x) { doModel_Fit(unlist(Combination_Matrix[x, ]), Indep_Vars, Dep_Var, reg, fitstat, all = all, consmodel = consmodel, intercept = intercept, ...) },
simplify = TRUE, USE.NAMES = FALSE)
# Conditional dominance statistics
Conditional_Dominance <- NULL
if (isTRUE(conditional)) {
Conditional_Dominance <- matrix(nrow = Total_Indep_Vars, ncol = Total_Indep_Vars)
Combination_Matrix_Anti <-!Combination_Matrix
IVs_per_Model <- rowSums(Combination_Matrix)
Combins_at_Order <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars, x), simplify = TRUE, USE.NAMES = FALSE)
Combins_at_Order_Prev <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars - 1L, x), simplify = TRUE, USE.NAMES = FALSE)
Weighted_Order_Ensemble <- ((Combination_Matrix*(Combins_at_Order - Combins_at_Order_Prev))**-1L)*Ensemble_of_Models
Weighted_Order_Ensemble <- replace(Weighted_Order_Ensemble, Weighted_Order_Ensemble == Inf, 0L)
Weighted_Order_Ensemble_Anti <- ((Combination_Matrix_Anti*Combins_at_Order_Prev)**-1L)*Ensemble_of_Models
Weighted_Order_Ensemble_Anti <- replace(Weighted_Order_Ensemble_Anti, Weighted_Order_Ensemble_Anti == Inf, 0L)
for (order in seq_len(Total_Indep_Vars)) {
Conditional_Dominance[, order] <- t(colSums(Weighted_Order_Ensemble[IVs_per_Model == order, ]) - colSums(Weighted_Order_Ensemble_Anti[IVs_per_Model == (order - 1L), ]))
}
Conditional_Dominance[, 1L] <- Conditional_Dominance[, 1L] - FitStat_Adjustment
}
# Complete dominance statistics
Complete_Dominance <- NULL
if (isTRUE(complete)) {
Complete_Dominance <- matrix(data = NA, nrow = Total_Indep_Vars, ncol = Total_Indep_Vars)
Complete_Combinations <- utils::combn(seq_len(Total_Indep_Vars), 2L)
for (pair in 1L:ncol(Complete_Combinations)) {
Focal_Cols <- Complete_Combinations[, pair]
NonFocal_Cols <- setdiff(1:Total_Indep_Vars, Focal_Cols)
Select_2IVs <- cbind(Combination_Matrix, 1L:nrow(Combination_Matrix))[rowSums(Combination_Matrix[, Focal_Cols]) == 1L, ]
Sorted_2IVs <- Select_2IVs[do.call("order", as.data.frame(Select_2IVs[,c(NonFocal_Cols, Focal_Cols)])), ]
Compare_2IVs <- cbind(Ensemble_of_Models[Sorted_2IVs[(1L:nrow(Sorted_2IVs) %% 2L) == 0L, ncol(Sorted_2IVs)]], Ensemble_of_Models[Sorted_2IVs[(1L:nrow(Sorted_2IVs) %% 2) == 1L, ncol(Sorted_2IVs)]])
Complete_Designation <- ifelse(all(Compare_2IVs[, 1L] > Compare_2IVs[, 2L]), FALSE, ifelse(all(Compare_2IVs[, 1L] < Compare_2IVs[, 2L]), TRUE, NA))
Complete_Dominance[Focal_Cols[[2L]], Focal_Cols[[1L]]] <- Complete_Designation
Complete_Dominance[Focal_Cols[[1L]], Focal_Cols[[2L]]] <- !Complete_Designation
}
}
if (isTRUE(reverse)) { Complete_Dominance <- !Complete_Dominance }
# General dominance statistics
General_Dominance <- rowMeans(Conditional_Dominance)
if (isTRUE(!conditional)) {
Combination_Matrix_Anti <-!Combination_Matrix
IVs_per_Model <- rowSums(Combination_Matrix)
Combins_at_Order <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars, x), simplify = TRUE, USE.NAMES = FALSE)
Combins_at_Order_Prev <- sapply(IVs_per_Model, function(x) choose(Total_Indep_Vars - 1L, x), simplify = TRUE, USE.NAMES = FALSE)
Indicator_Weight <- Combination_Matrix*(Combins_at_Order - Combins_at_Order_Prev)
Indicator_Weight_Anti <- (Combination_Matrix_Anti*Combins_at_Order_Prev)*-1L
Weight_Matrix <- ((Indicator_Weight + Indicator_Weight_Anti)*Total_Indep_Vars)^-1L
General_Dominance <- colSums(Ensemble_of_Models*Weight_Matrix)
General_Dominance <- General_Dominance - FitStat_Adjustment/Total_Indep_Vars
}
# Overall fit statistic and ranks
FitStat <- sum(General_Dominance) + FitStat_Adjustment
if (isTRUE(!reverse)) { General_Dominance_Ranks <- rank(-General_Dominance) } else { General_Dominance_Ranks <- rank(General_Dominance) }
# Return values and attributes
if (isTRUE(length(sets) == 0L)) { IV_Labels <- attr(stats::terms(formula_overall), "term.labels") } else { IV_Labels <- c( attr(stats::terms(formula_overall), "term.labels"), paste0("set", 1:length(sets))) }
names(General_Dominance) <- IV_Labels
names(General_Dominance_Ranks) <- IV_Labels
if (isTRUE(conditional)) { dimnames(Conditional_Dominance) <- list(IV_Labels, paste0("IVs_", seq_along(Indep_Vars))) }
if (isTRUE(complete)) { dimnames(Complete_Dominance) <- list(paste0("Dmnates_", IV_Labels), paste0("Dmnated_", IV_Labels)) }
if (isTRUE(!reverse)) { Standardized <- General_Dominance / (FitStat - ifelse(length(Cons_Result) > 0L, Cons_Result, 0L)) } else { Standardized <- -General_Dominance / -(FitStat - ifelse(length(Cons_Result) > 0L, Cons_Result, 0L)) }
# Return object
return_list <- list(General_Dominance = General_Dominance,
Standardized = Standardized,
Ranks = General_Dominance_Ranks,
Conditional_Dominance = Conditional_Dominance,
Complete_Dominance = Complete_Dominance,
Fit_Statistic_Overall = FitStat,
Fit_Statistic_All_Subsets = All_Result - ifelse(is.null(Cons_Result), 0, Cons_Result),
Fit_Statistic_Constant_Model = Cons_Result,
Call = match.call(),
Subset_Details = list(Full_Model = stats::reformulate(c(Indep_Vars, all, consmodel), response = Dep_Var, intercept = intercept),
Formula = attr(stats::terms(formula_overall), "term.labels"),
All = all, Sets = sets, Constant = consmodel))
class(return_list) <- c("domin", "list")
return(return_list)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the dominance.manual() function -----------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Enumerate the Combinations or Permutation of the ELements of a Vector ####
# combinations() from the gtools package
.combinations <- function(n, r, v = 1:n, set = TRUE, repeats.allowed = FALSE) {
if (isTRUE(mode(n) != "numeric" || length(n) != 1L || n < 1L || (n %% 1L) != 0L)) { stop("bad value of n") }
if (isTRUE(mode(r) != "numeric" || length(r) != 1L || r < 1L || (r %% 1L) != 0L)) { stop("bad value of r") }
if (isTRUE(!is.atomic(v) || length(v) < n)) { stop("v is either non-atomic or too short") }
if (isTRUE((r > n) & !repeats.allowed)) { stop("r > n and repeats.allowed = FALSE", call. = FALSE) }
if (isTRUE(set)) {
v <- unique(sort(v))
if (length(v) < n) stop("Too few different elements", call. = FALSE)
}
v0 <- vector(mode(v), 0L)
## Inner workhorse
if (repeats.allowed) {
sub <- function(n, r, v) {
if (isTRUE(r == 0L)) { v0 } else if (isTRUE(r == 1L)) { matrix(v, n, 1) } else if (isTRUE(n == 1L)) { matrix(v, 1L, r) } else { rbind(cbind(v[1L], Recall(n, r - 1L, v)), Recall(n - 1L, r, v[-1L])) }
}
} else {
sub <- function(n, r, v) {
if (isTRUE(r == 0L)) { v0 } else if (isTRUE(r == 1L)) { matrix(v, n, 1) } else if (isTRUE(r == n)) { matrix(v, 1L, n) } else { rbind(cbind(v[1], Recall(n - 1L, r - 1L, v[-1L])), Recall(n - 1L, r, v[-1L])) }
}
return(sub(n, r, v[1L:n]))
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Dominance analysis functions ####
.DA <- function(cormat, index = NULL) {
# Correlation matrix of the predictors
Px <- cormat[-1L, -1L]
# Correlation vector
rx <- cormat[-1L, 1L]
if (isTRUE(is.null(index))) { index = as.list(1:length(rx)) }
# Number of predictors or groups of predictors
J <- length(index)
# R2 for model with subset xi
R2 <- function(xi) {
xi <- unlist(index[xi])
R2 <- t(rx[xi])%*%solve(Px[xi, xi])%*%rx[xi]
}
# Average R2 change for a subset model with k size
# Possible subset models before adding a predictor
submodel <- function(k) {
temp0 <- lapply(1L:J, function(i) .combinations(J - 1L, k, (1L:J)[-i]))
# Possible subset models after adding a predictor
temp1 <- lapply(1:J, function(i) t(apply(temp0[[i]], 1L, function(x) c(x, i))))
# R2 before adding a predictor
R0 <- lapply(temp0, function(y) apply(y, 1L, R2))
# R2 after adding a predictor
R1 <- lapply(temp1, function(y) apply(y, 1L, R2))
# R2 change
deltaR2 <- mapply(function(x, y) x - y, R1, R0)
# Average R2 change
adeltaR2 <- apply(matrix(deltaR2, ncol = J), 2L, mean)
return(adeltaR2)
}
# Different model size k
R2matrix <- t(sapply(1L:(J - 1L), submodel))
R2matrix <- rbind(sapply(1L:J, R2), R2matrix)
# Overall average
DA <- apply(R2matrix, 2L, mean)
return(DA)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the effsize() function --------------------------------
#
# - .phi
# - .cramer
# - .tschuprow
# - .cont
# - .cohen.w
# - .fei
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .phi Function ####
.phi <- function(x, adjust, p = NULL, conf.level, alternative, fei = FALSE) {
# Cross tabulation
tab <- table(x)
# Vector of probabilities
if (isTRUE(is.null(p))) { p <- rep(1 / length(tab), times = length(tab)) }
# Chi-squared Test
model <- tryCatch(suppressWarnings(chisq.test(tab, correct = FALSE, p = p)), error = function(y) { list(statistic = NA, parameter = NA) })
# Table with at least two rows and two columns and chi-square statistic is not NA or NaN
if (isTRUE(((ncol(tab) >= 2L && nrow(tab) >= 2L) || fei) && !is.na(model$parameter) && !is.nan(model$statistic))) {
# Test statistic
chisq <- model$statistic
# Degrees of freedom
df <- model$parameter
# Sample size
n <- sum(tab)
# Noncentral parameter
chisqs <- vapply(chisq, .get_ncp_chi, FUN.VALUE = numeric(2L), df = df, conf.level = conf.level, alternative = alternative)
# Result table
result <- data.frame(phi = sqrt(chisq / n), low = sqrt(chisqs[1L, ] / n), upp = sqrt(chisqs[2L, ] / n), row.names = NULL)
# Adjusted phi coefficient
if (isTRUE(adjust)) { result <- result / min(c(sqrt((sum(tab[1L, ])*sum(tab[, 2L])) / (sum(tab[, 1L])*sum(tab[2L, ]))), sqrt((sum(tab[, 1L])*sum(tab[2L, ])) / (sum(tab[1L, ])*sum(tab[, 2L]))))) }
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size
result <- data.frame(n = n, result)
} else {
result <- data.frame(n = sum(tab), phi = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cramer Function ####
.cramer <- function(x, adjust, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Number of rows and columns
nrow <- nrow(tab)
ncol <- ncol(tab)
# Phi coefficient
result <- .phi(x, adjust = FALSE, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
#—————————————————————————————————————— #
### Finite Sample Bias-Correction ####
if (isTRUE(adjust)) {
# Sample size
n <- sum(tab)
# Correction
result <- lapply(result, function(y) { sqrt(pmax(0, y^2L - ((nrow - 1L)*(ncol - 1L)) / (n - 1L))) })
# Cramer's V
result <- data.frame(lapply(result, function(y) y / sqrt(pmin((nrow - ((nrow - 1L)^2L) / (n - 1L)) - 1L, (ncol - ((ncol - 1L)^2L) / (n - 1L)) - 1L))))
#—————————————————————————————————————— #
### No Finite Sample Bias-Correction ####
} else {
# Cramer's V
result <- data.frame(lapply(result, function(y) y / sqrt(pmin(nrow - 1L, ncol - 1L))))
}
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("v", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), v = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .tschuprow Function ####
.tschuprow <- function(x, adjust, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Number of rows and columns
nrow <- nrow(tab)
ncol <- ncol(tab)
# Sample size
n <- sum(tab)
# Phi coefficient
result <- .phi(x, adjust = FALSE, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
#—————————————————————————————————————— #
### Finite Sample Bias-Correction ####
if (isTRUE(adjust)) {
# Correction
result <- lapply(result, function(y) { sqrt(pmax(0, y^2L - ((nrow - 1L)*(ncol - 1L)) / (n - 1L))) })
# Tschuprow's T
result <- data.frame(lapply(result, function(y) y / sqrt(sqrt(((nrow - ((nrow - 1L)^2L) / (n - 1L)) - 1L) * ((ncol - ((ncol - 1L)^2L) / (n - 1L)) - 1L)))))
#—————————————————————————————————————— #
### No Finite Sample Bias-Correction ####
} else {
# Tschuprow's T
result <- data.frame(lapply(result, function(y) y / sqrt(sqrt((nrow - 1L) * (ncol - 1L)))))
}
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size and column names
result <- data.frame(n = n, setNames(result, nm = c("t", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), t = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cont Function ####
.cont <- function(x, adjust, p = NULL, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Phi coefficient
result <- .phi(x, adjust = FALSE, p = p, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
# Contingency coefficient
result <- data.frame(lapply(result, function(y) y / sqrt(y^2L + 1L)))
# Sakoda's adjustment
if (isTRUE(adjust)) {
k <- min(c(nrow(tab), ncol(tab)))
result <- result / sqrt((k - 1L) / k)
}
# One-sided confidence interval
switch(alternative, less = { result$low <- 0L }, greater = { result$upp <- 1L })
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("c", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), c = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .cohen.w Function ####
.cohen.w <- function(x, adjust, p = NULL, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Number of rows and columns
nrow <- nrow(tab)
ncol <- ifelse(isTRUE(is.na(ncol(tab))), 1L, ncol(tab))
# Phi coefficient
result <- .phi(x, adjust = FALSE, p = p, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
# Cohen's w
if (isTRUE(ncol == 1L || nrow == 1L)) {
if (isTRUE(is.null(p))) {
max.poss <- Inf
} else {
max.poss <- sqrt((1L / min(p / sum(p))) - 1L)
}
} else {
max.poss <- sqrt((pmin(ncol, nrow) - 1L))
}
# One-sided confidence interval
switch(alternative, less = { result$upp <- pmin(result$upp, max.poss) }, greater = { result$upp <- max.poss })
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("w", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), w = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .fei Function ####
.fei <- function(x, adjust, p = NULL, conf.level = conf.level, alternative = alternative) {
# Cross tabulation
tab <- table(x)
# Vector of probabilities
if (isTRUE(is.null(p))) { p <- rep(1L / length(tab), times = length(tab)) }
# Fei
result <- .phi(x, adjust = FALSE, fei = TRUE, p = p, conf.level = conf.level, alternative = alternative)[, -1L]
# Phi is not NA
if (isTRUE(!is.na(result$phi))) {
result <- data.frame(lapply(result, function(y) y / sqrt(1L / min(p) - 1L)))
# One-sided confidence interval
switch(alternative, less = { result$upp <- pmin(result$upp, 1L) }, greater = { result$upp <- 1L})
# Add sample size and column names
result <- data.frame(n = sum(tab), setNames(result, nm = c("fei", "low", "upp")))
} else {
result <- data.frame(n = sum(tab), fei = NA, low = NA, upp = NA)
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .get_ncp_chi Function ####
.get_ncp_chi <- function(chi, df, conf.level, alternative) {
alpha <- 1L - ifelse(alternative != "two.sided", 2L * conf.level - 1L, conf.level)
probs <- c(alpha / 2L, 1L - alpha / 2L)
ncp <- suppressWarnings(stats::optim(par = 1.1 * rep(chi, 2L), fn = function(y) {
p <- pchisq(q = chi, df, ncp = y)
abs(max(p) - probs[2L]) + abs(min(p) - probs[1L])
}, control = list(abstol = 1e-09)))
chi_ncp <- sort(ncp$par)
if (chi <= stats::qchisq(probs[1L], df)) { chi_ncp[2L] <- 0L }
if (chi <= stats::qchisq(probs[2L], df)) { chi_ncp[1L] <- 0L }
return(chi_ncp)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the indirect() function -------------------------------
#
# - .qprodnormalMeeker
.qprodnormalMeeker <- function(p, a, b, se.a, se.b, lower.tail = TRUE) {
max.iter <- 10000L
mu.a <- a / se.a
mu.b <- b / se.b
se.ab <- sqrt(1L + mu.a^2L + mu.b^2L)
if (isTRUE(lower.tail == FALSE)) {
u0 <- mu.a*mu.b + 6L*se.ab
l0 <- mu.a*mu.b - 6L*se.ab
alpha <- 1L - p
} else {
l0 <- mu.a*mu.b - 6L*se.ab
u0 <- mu.a*mu.b + 6L*se.ab
alpha <- p
}
gx <- function(x, z) {
mu.a.on.b <- mu.a
integ <- pnorm(sign(x)*(z / x - mu.a.on.b))*dnorm(x - mu.b)
return(integ)
}
fx <- function(z) {
return(integrate(gx, lower = -Inf, upper = Inf, z = z)$value - alpha)
}
p.l <- fx(l0)
p.u <- fx(u0)
iter <- 0L
while (p.l > 0L) {
iter <- iter + 1L
l0 <- l0 - 0.5*se.ab
p.l <- fx(l0)
if (iter > max.iter) {
return(list(q = NA, error = NA))
}
}
iter <- 0L
while (p.u < 0L) {
iter <- iter + 1L
u0 <- u0 + 0.5*se.ab
p.u <- fx(u0)
if (iter > max.iter) {
return(list(q = NA,error = NA))
}
}
new <- uniroot(fx, c(l0, u0))$root*se.a*se.b |> (\(p) if (isTRUE(is.list(p))) { NA } else { p })()
return(new)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.alpha() function -----------------------------
#
# - .alpha
.alpha <- function(y, ordered, rescov = NULL, std = std, estimator = estimator, missing = missing, check = TRUE) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Coefficient Alpha for Continuous Items ####
mod.fit <- NULL
if (isTRUE(!ordered)) {
#—————————————————————————————————————— #
### Formula-Based Coefficient Alpha ####
if (missing != "fiml" && estimator == "ULS" && is.null(rescov)) {
##### Correlation Matrix ####
if (isTRUE(std)) {
mat.sigma <- cor(y, use = ifelse(missing == "listwise", "complete.obs", "pairwise.complete.obs"), method = "pearson")
##### Covariance Matrix ####
} else {
mat.sigma <- cov(y, use = ifelse(missing == "listwise", "complete.obs", "pairwise.complete.obs"), method = "pearson")
}
##### Coefficient Alpha ####
alpha <- (ncol(mat.sigma) / (ncol(mat.sigma) - 1L)) * (1L - sum(diag(as.matrix(mat.sigma))) / sum(as.matrix(mat.sigma)))
#—————————————————————————————————————— #
### CFA-Based Coefficient Alpha ####
} else {
##### Model specification ####
# Measurement model
mod.factor <- paste("f =~", paste(paste0("L*", colnames(y)), collapse = " + "))
# Residual covariance
if (isTRUE(!is.null(rescov))) { mod.factor <- vapply(rescov, function(y) paste(y, collapse = " ~~ "), FUN.VALUE = character(1L)) |> (\(y) paste(mod.factor, "\n", paste(y, collapse = " \n ")))() }
##### Model Estimation ####
mod.fit <- tryCatch(suppressWarnings(lavaan::cfa(mod.factor, data = y, ordered = FALSE, se = "none", test = "none", std.lv = TRUE, estimator = estimator, missing = missing)),
error = function(y) {
stop(paste0("CFA model for computing coefficient coefficient alpha could not be estimated."), call. = FALSE)
})
##### Model Convergence ####
# Model convergence
if (isTRUE(check)) { if (!isTRUE(lavaan::lavInspect(mod.fit, "converged"))) { warning("CFA model did not converge, results are most likely unreliable.", call. = FALSE) } }
##### Parameter Estimates ####
# Unstandardized parameter estimates
if (isTRUE(!std)) {
param <- lavaan::parameterestimates(mod.fit)
# Standardized parameter estimates
} else {
param <- misty::df.rename(lavaan::standardizedSolution(mod.fit), from = "est.std", to = "est")
}
##### Factor Loadings ####
param.load <- param[which(param$op == "=~"), ]
##### Residual Covariance ####
param.rcov <- param[param$op == "~~" & param$lhs != param$rhs, ]
##### Residuals Variances ####
param.resid <- param[param$op == "~~" & param$lhs == param$rhs & param$lhs != "f" & param$rhs != "f", ]
##### Numerator ####
load.sum2 <- sum(param.load$est)^2L
##### Denominator ####
resid.sum <- sum(param.resid$est)
##### Residual Covariances ####
if (isTRUE(!is.null(rescov))) { resid.sum <- resid.sum + 2L*sum(param.rcov$est) }
##### Coefficient Alpha ####
alpha <- load.sum2 / (load.sum2 + resid.sum)
}
#—————————————————————————————————————— #
### Return Object ####
object <- list(mod.fit = mod.fit, alpha = alpha)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Coefficient Alpha for Ordered-Categorical Items ####
} else {
##### Correlation Matrix ####
mat.sigma <- misty::cor.matrix(y, na.omit = ifelse(missing == "listwise", TRUE, FALSE), method = "poly", check = check, output = FALSE)$result$cor
diag(mat.sigma) <- 1
#—————————————————————————————————————— #
### Ordinal Coefficient Alpha ####
alpha <- (ncol(mat.sigma) / (ncol(mat.sigma) - 1L)) * (1L - sum(diag(as.matrix(mat.sigma)), na.rm = TRUE) / sum(as.matrix(mat.sigma), na.rm = TRUE))
#—————————————————————————————————————— #
### Return Object ####
object <- list(mod.fit = NULL, alpha = alpha)
}
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.omega() function -----------------------------
#
# - .omega
# - .categ.alpha.omega
# - .getThreshold
# - .polycorLavaan
# - .refit
# - .p2
#
# MBESS: The MBESS R Package
# https://cran.r-project.org/web/packages/MBESS/index.html
.omega <- function(y, rescov = NULL, type = type, std = std, estimator = estimator, missing = missing, check = TRUE) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Omega for Continuous Items ####
if (isTRUE(type != "categ")) {
# Variable names
vnames <- colnames(y)
#—————————————————————————————————————— #
### Mode Specification ####
# Measurement model
mod.factor <- paste("f =~", paste(vnames, collapse = " + "))
# Residual covariance
if (isTRUE(!is.null(rescov))) { mod.factor <- vapply(rescov, function(y) paste(y, collapse = " ~~ "), FUN.VALUE = character(1L)) |> (\(y) paste(mod.factor, "\n", paste(y, collapse = " \n ")))() }
#—————————————————————————————————————— #
### Mode Estimation ####
mod.fit <- tryCatch(suppressWarnings(lavaan::cfa(mod.factor, data = y, ordered = FALSE, se = "none", test = "none", std.lv = TRUE, estimator = estimator, missing = missing)),
error = function(y) {
stop(paste0("CFA model for computing coefficient ", type, " could not be estimated."), call. = FALSE)
})
#—————————————————————————————————————— #
### Check for Convergence ####
# Model convergence
if (isTRUE(check)) { if (!isTRUE(lavaan::lavInspect(mod.fit, "converged"))) { warning("CFA model did not converge, results are most likely unreliable.", call. = FALSE) } }
#—————————————————————————————————————— #
### Parameter Estimates ####
# Unstandardized parameter estimates
if (isTRUE(!std)) {
param <- lavaan::parameterestimates(mod.fit)
# Standardized parameter estimates
} else {
param <- misty::df.rename(lavaan::standardizedSolution(mod.fit), from = "est.std", to = "est")
}
#—————————————————————————————————————— #
### Factor Loadings ####
param.load <- param[which(param$op == "=~"), ]
#—————————————————————————————————————— #
### Residual Covariance ####
param.rcov <- param[param$op == "~~" & param$lhs != param$rhs, ]
#—————————————————————————————————————— #
### Residuals ####
param.resid <- param[param$op == "~~" & param$lhs == param$rhs & param$lhs != "f" & param$rhs != "f", ]
#—————————————————————————————————————— #
### Omega ####
# Numerator
load.sum2 <- sum(param.load$est)^2L
# Total alpha
if (isTRUE(type != "hierarch")) {
resid.sum <- sum(param.resid$est)
# Residual covariances
if (isTRUE(!is.null(rescov))) { resid.sum <- resid.sum + 2L*sum(param.rcov$est) }
omega <- load.sum2 / (load.sum2 + resid.sum)
#—————————————————————————————————————— #
### Hierarchical Omega ####
} else {
mod.cov.fit <- paste(apply(combn(seq_len(length(vnames)), m = 2L), 2L, function(z) paste(vnames[z[1L]], "~~", vnames[z[2L]])), collapse = " \n ") |>
(\(z) suppressWarnings(lavaan::cfa(z, data = y, ordered = FALSE, se = "none", test = "none", estimator = estimator, missing = missing)))()
if (isTRUE(!std)) {
var.total <- lavaan::parameterEstimates(mod.cov.fit) |> (\(y) sum(y[y$lhs == y$rhs, "est"], 2*y[y$lhs != y$rhs & y$op == "~~", "est"]))()
} else {
var.total <- lavaan::standardizedSolution(mod.cov.fit) |> (\(y) sum(y[y$lhs == y$rhs, "est"], 2*y[y$lhs != y$rhs & y$op == "~~", "est"]))()
}
omega <- load.sum2 / var.total
}
#—————————————————————————————————————— #
### Return Object ####
object <- list(mod.fit = mod.fit, omega = omega)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Omega for Ordered-Categorical Items ####
} else {
object <- .categ.omega(dat = y, rescov = rescov, estimator = estimator, missing = missing, check = TRUE)
}
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .categ.alpha.omega Function ####
.categ.omega <- function(dat, rescov = NULL, estimator = estimator, missing = missing, check = TRUE) {
# Variable names
vnames <- colnames(dat)
# Sequence from 1 to the number of columns
q <- seq_len(ncol(dat))
# Convert to ordered factor
dat <- data.frame(lapply(dat, ordered))
# Measurement model
mod.factor <- paste("f =~", paste(vnames, collapse = " + "))
# Residual covariances
if (isTRUE(!is.null(rescov))) { mod.factor <- vapply(rescov, function(y) paste(y, collapse = " ~~ "), FUN.VALUE = character(1L)) |> (\(y) paste(mod.factor, "\n", paste(y, collapse = " \n ")))() }
# Estimate model
mod.fit <- tryCatch(suppressWarnings(lavaan::cfa(mod.factor, data = dat, estimator = estimator, missing = missing, std.lv = TRUE, se = "none", test = "none", ordered = TRUE)),
error = function(y) {
stop(paste0("CFA model for computing categorical coefficient omega could not be estimated."), call. = FALSE)
})
# Model convergence
if (isTRUE(check)) { if (!isTRUE(lavaan::lavInspect(mod.fit, "converged"))) { warning("CFA model did not converge, results are most likely unreliable.", call. = FALSE) } }
param <- lavaan::inspect(mod.fit, "coef")
ly <- param[["lambda"]]
ps <- param[["psi"]]
threshold <- .getThreshold(mod.fit)[[1L]]
denom <- .polycorLavaan(mod.fit, data = dat, estimator = estimator, missing = missing)[vnames, vnames]
invstdvar <- 1L / sqrt(diag(lavaan::lavInspect(mod.fit, "implied")$cov))
polyr <- diag(invstdvar) %*% ly%*%ps%*%t(ly) %*% diag(invstdvar)
sumnum <- 0L
addden <- 0L
for (j in q) {
for (jp in q) {
sumprobn2 <- 0L
addprobn2 <- 0L
t1 <- threshold[[j]]
t2 <- threshold[[jp]]
for(c in seq_along(t1)) {
for(cp in seq_along(t2)) {
sumprobn2 <- sumprobn2 + .p2(t1[c], t2[cp], polyr[j, jp])
addprobn2 <- addprobn2 + .p2(t1[c], t2[cp], denom[j, jp])
}
}
sumprobn1 <- sum(pnorm(t1))
sumprobn1p <- sum(pnorm(t2))
sumnum <- sumnum + (sumprobn2 - sumprobn1 * sumprobn1p)
addden <- addden + (addprobn2 - sumprobn1 * sumprobn1p)
}
}
return(list(mod.fit = mod.fit, omega = sumnum / addden))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .getThreshold Function ####
.getThreshold <- function(object) {
ngroups <- lavaan::inspect(object, "ngroups")
coef <- lavaan::inspect(object, "coef")
result <- NULL
if (isTRUE(ngroups == 1L)) {
targettaunames <- rownames(coef$tau)
barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|"))
varthres <- apply(data.frame(targettaunames, barpos - 1L, stringsAsFactors = FALSE), 1L, function(x) substr(x[1], 1L, x[2L]))
result <- list(split(coef$tau, varthres))
} else {
result <- list()
for (g in seq_len(ngroups)) {
targettaunames <- rownames(coef[[g]]$tau)
barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|"))
varthres <- apply(data.frame(targettaunames, barpos - 1L, stringsAsFactors = FALSE), 1L, function(x) substr(x[1L], 1L, x[2L]))
result[[g]] <- split(coef[[g]]$tau, varthres)
}
}
return(result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .polycorLavaan Function ####
.polycorLavaan <- function(object, data, estimator = estimator, missing = missing) {
ngroups <- lavaan::inspect(object, "ngroups")
coef <- lavaan::inspect(object, "coef")
targettaunames <- NULL
if (isTRUE(ngroups == 1L)) {
targettaunames <- rownames(coef$tau)
} else {
targettaunames <- rownames(coef[[1L]]$tau)
}
barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|"))
vnames <- unique(apply(data.frame(targettaunames, barpos - 1L, stringsAsFactors = FALSE), 1L, function(x) substr(x[1L], 1L, x[2L])))
script <- ""
for(i in 2L:length(vnames)) {
temp <- paste0(vnames[1L:(i - 1L)], collapse = " + ")
temp <- paste0(vnames[i], " ~~ ", temp, "\n")
script <- paste(script, temp)
}
suppressWarnings(newobject <- .refit(pt = script, data = data, vnames = vnames, object = object, estimator = estimator, missing = missing))
if (isTRUE(ngroups == 1L)) {
return(lavaan::inspect(newobject, "coef")$theta)
} else {
return(lapply(lavaan::inspect(newobject, "coef"), "[[", "theta"))
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .refit Function ####
.refit <- function(pt, data, vnames, object, estimator = estimator, missing = missing) {
args <- lavaan::lavInspect(object, "call")
args$model <- pt
args$data <- data
args$ordered <- vnames
tempfit <- do.call(eval(parse(text = paste0("lavaan::", "lavaan"))), args[-1])
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .p2 Function ####
.p2 <- function(t1, t2, r) { mnormt::pmnorm(c(t1, t2), c(0L, 0L), matrix(c(1L, r, r, 1L), 2L, 2L)) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.invar() function -----------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Convergence and Model Identification Checks ####
.conv.ident <- function(model.fit, invar, long) {
check.vcov <- check.theta <- check.cov.lv <- TRUE
switch(invar, config = {
invar.upp <- "Configural"
invar.low <- "configural"
}, thres = {
invar.upp <- "Threshold"
invar.low <- "threshold"
}, metric = {
invar.upp <- "Metric"
invar.low <- "metric"
}, scalar = {
invar.upp <- "Scalar"
invar.low <- "scalar"
}, strict = {
invar.upp <- "Strict"
invar.low <- "strict"
})
#—————————————————————————————————————— #
### Model Not Converged ####
if (isTRUE(!lavaan::lavInspect(model.fit, what = "converged"))) {
stop(paste0(invar.upp, " invariance model did not converge."), call. = FALSE)
#—————————————————————————————————————— #
### Model Converged ####
} else {
#···················
#### Degrees of Freedom ####
if (isTRUE(suppressWarnings(lavaan::lavInspect(model.fit, what = "fit")["df"] < 0L))) { stop(paste0(invar.upp, " invariance model has negative degrees of freedom, model is not identified."), call. = FALSE) }
#···················
#### Standard Error ####
if (isTRUE(any(is.na(unlist(lavaan::lavInspect(model.fit, what = "se")))))) { stop(paste0("Standard errors of the ", invar.low, " invariance model could not be computed."), call. = FALSE) }
#···················
#### Variance-Covariance Matrix of the Estimated Parameters ####
eigvals <- eigen(lavaan::lavInspect(model.fit, what = "vcov"), symmetric = TRUE, only.values = TRUE)$values
# Correct for equality constraints
if (isTRUE(any(lavaan::parTable(model.fit)$op == "=="))) { eigvals <- rev(eigvals)[-seq_len(sum(lavaan::parTable(model.fit)$op == "=="))] }
if (isTRUE(min(eigvals) < .Machine$double.eps^(3L/4L))) {
warning(paste0("The variance-covariance matrix of the estimated parameters in the ", invar.low, " invariance model is not positive definite."), call. = FALSE)
check.vcov <- FALSE
}
#···················
#### Negative Variance of Observed Variables ####
if (isTRUE(!long)) {
cond.theta1 <- any(sapply(lavaan::lavInspect(model.fit, what = "theta"), diag) < 0)
cond.theta2 <- any(sapply(lavaan::lavTech(model.fit, what = "theta"), function(y) eigen(y, symmetric = TRUE, only.values = TRUE)$values) < (-1L * .Machine$double.eps^(3L/4L)))
} else {
cond.theta1 <- any(diag(lavaan::lavInspect(model.fit, what = "theta")) < 0L)
cond.theta2 <- any(eigen(lavaan::lavTech(model.fit, what = "theta")[[1L]], symmetric = TRUE, only.values = TRUE)$values < (-1L * .Machine$double.eps^(3L/4L)))
}
if (isTRUE(cond.theta1)) {
warning(paste0("Some estimated variances of the observed variables in the ", invar.low, " invariance model are negative."), call. = FALSE)
check.theta <- FALSE
} else if (isTRUE(cond.theta2)) {
warning(paste0("The model-implied variance-covariance matrix of the residuals of the observed variables in the ", invar.low, " invariance model is not positive definite."), call. = FALSE)
check.theta <- FALSE
}
#···················
#### Negative Variance of Latent Variables ####
if (isTRUE(!long)) {
cond.theta1 <- any(sapply(lavaan::lavTech(model.fit, what = "cov.lv"), diag) < 0L)
cond.theta1 <- any(sapply(lavaan::lavTech(model.fit, what = "cov.lv"), function(y) eigen(y, symmetric = TRUE, only.values = TRUE)$values) < (-1L * .Machine$double.eps^(3L/4L)))
} else {
cond.theta1 <- any(diag(lavaan::lavTech(model.fit, what = "cov.lv")[[1L]]) < 0L)
cond.theta2 <- any(eigen(lavaan::lavTech(model.fit, what = "cov.lv")[[1L]], symmetric = TRUE, only.values = TRUE)$values < (-1L * .Machine$double.eps^(3L/4L)))
}
if (isTRUE(cond.theta1)) {
warning(paste0("Some estimated variances of the latent variables in the ", invar.low, " invariance model are negative."), call. = FALSE)
check.cov.lv <- FALSE
# Model-implied variance-covariance matrix of the latent variables
} else if (isTRUE(cond.theta2)) {
warning("The model-implied variance-covariance matrix of the latent variables in the ", invar.low, " invariance model is not positive definite.", call. = FALSE)
check.cov.lv <- FALSE
}
}
# Return object
return(c(check.vcov = check.vcov, check.theta = check.theta, check.cov.lv = check.cov.lv))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Parameter Estimates ####
.model.fit.param <- function(model.param, long = long) {
group <- NULL
# Latent variables
print.latent <- model.param[which(model.param$op == "=~"), ]
# Latent variable covariances
print.lv.cov <- model.param[which(model.param$op == "~~" & (model.param$lhs != model.param$rhs) & (model.param$lhs %in% print.latent$lhs) & (model.param$rhs %in% print.latent$lhs)), ]
# Residual covariances
print.res.cov <- model.param[which(model.param$op == "~~" & (model.param$lhs != model.param$rhs) & (!model.param$lhs %in% print.latent$lhs) & (!model.param$rhs %in% print.latent$lhs)), ]
# Latent mean
print.mean <- model.param[which(model.param$op == "~1" & model.param$lhs %in% print.latent$lhs), ]
# Latent variance
print.var <- model.param[which(model.param$op == "~~" & (model.param$lhs %in% print.latent$lhs) & (model.param$lhs == model.param$rhs)), ]
# Intercepts
print.interc <- model.param[which(model.param$op == "~1" & !model.param$lhs %in% print.latent$lhs), ]
# Thresholds
print.thres <- model.param[which(model.param$op == "|"), ]
# Scales
print.scale <- model.param[which(model.param$op == "~*~"), ]
# Residual variance
print.resid <- model.param[which(model.param$op == "~~" & (model.param$lhs == model.param$rhs) & (!model.param$lhs %in% print.latent$lhs) & (!model.param$rhs %in% print.latent$lhs)), ]
# Model parameters
model.param <- rbind(data.frame(param = "latent variable", print.latent),
if (nrow(print.lv.cov) > 0L) { data.frame(param = "latent variable covariance", print.lv.cov) } else { NULL },
if (nrow(print.res.cov) > 0L) { data.frame(param = "residual covariance", print.res.cov) } else { NULL },
if (nrow(print.mean) > 0L) { data.frame(param = "latent mean", print.mean) } else { NULL },
if (nrow(print.var) > 0L) { data.frame(param = "latent variance", print.var) } else { NULL },
if (nrow(print.interc) > 0L) { data.frame(param = "intercept", print.interc) } else { NULL },
if (nrow(print.thres) > 0L) { data.frame(param = "threshold", print.thres) } else { NULL },
if (nrow(print.scale) > 0L) { data.frame(param = "scale", print.scale) } else { NULL },
if (nrow(print.resid) > 0L) { data.frame(param = "residual variance", print.resid) } else { NULL })
#—————————————————————————————————————— #
### Add Label ####
# Latent mean, intercept, and threshold
model.param[model.param$param %in% c("latent mean", "intercept"), "rhs"] <- model.param[model.param$param %in% c("latent mean", "intercept"), "lhs"]
if (isTRUE(any(model.param$param == "threshold"))) {
model.param[model.param$param == "threshold", "rhs"] <- apply(model.param[model.param$param == "threshold", c("lhs", "rhs")], 1L, paste, collapse = "|")
}
#—————————————————————————————————————— #
### Latent Variables ####
#···················
#### Between-Group Measurement Invariance ####
if (isTRUE(!long)) {
print.lv <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable"), "lhs"])) {
# Loop across groups
for (j in unique(model.param$group)) {
print.lv <- rbind(print.lv,
data.frame(param = "latent variable", group = j, lhs = i, op = "", rhs = paste(i, "=~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable" & model.param$lhs == i & model.param$group == j), ])
}
}
#···················
#### Longitudinal Measurement Invariance ####
} else {
print.lv <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable"), "lhs"])) {
print.lv <- rbind(print.lv,
data.frame(param = "latent variable", lhs = i, op = "", rhs = paste(i, "=~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable" & model.param$lhs == i), ])
}
}
#—————————————————————————————————————— #
### Latent Variable Covariances ####
#···················
#### Between-Group Measurement Invariance ####
if (isTRUE(!long)) {
print.lv.cov <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable covariance"), "lhs"])) {
# Loop across groups
for (j in unique(model.param$group)) {
print.lv.cov <- rbind(print.lv.cov,
data.frame(param = "latent variable covariance", group = j, lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable covariance" & model.param$lhs == i & model.param$group == j), ])
}
}
#···················
#### Longitudinal Measurement Invariance ####
} else {
print.lv.cov <- NULL
for (i in unique(model.param[which(model.param$param == "latent variable covariance"), "lhs"])) {
print.lv.cov <- rbind(print.lv.cov,
data.frame(param = "latent variable covariance", lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "latent variable covariance" & model.param$lhs == i), ])
}
}
#—————————————————————————————————————— #
### Residual Covariances ####
#···················
#### Between-Group Measurement Invariance ####
if (isTRUE(!long)) {
print.res.cov <- NULL
for (i in unique(model.param[which(model.param$param == "residual covariance"), "lhs"])) {
# Loop across groups
for (j in unique(model.param$group)) {
print.res.cov <- rbind(print.res.cov,
data.frame(param = "residual covariance", group = j, lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "residual covariance" & model.param$lhs == i & model.param$group == j), ])
}
}
#···················
#### Longitudinal Measurement Invariance ####
} else {
print.res.cov <- NULL
for (i in unique(model.param[which(model.param$param == "residual covariance"), "lhs"])) {
print.res.cov <- rbind(print.res.cov,
data.frame(param = "residual covariance", lhs = i, op = "", rhs = paste(i, "~~"), label = "", est = NA, se = NA, z = NA, pvalue = NA, stdyx = NA),
model.param[which(model.param$param == "residual covariance" & model.param$lhs == i), ])
}
}
#—————————————————————————————————————— #
### Merge Parameter Tables ####
model.param <- data.frame(rbind(print.lv, print.lv.cov, print.res.cov,
model.param[which(!model.param$param %in% c("latent variable", "latent variable covariance", "residual covariance")), ]), row.names = NULL)
# Sort by group
if (isTRUE(!long)) { model.param <- data.frame(misty::df.sort(model.param, group), row.names = NULL) }
#—————————————————————————————————————— #
### Labels in Parentheses ####
model.param$label <- sapply(model.param$label, function(y) ifelse(y != "", paste0("(", y, ")"), y))
#—————————————————————————————————————— #
### Return Object ####
return(model.param)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.distract() function --------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Attractor-Distractor-Total Correlation ####
.adt.cor <- function(x, y, method, ml = FALSE) {
#—————————————————————————————————————— #
### Point-Biserial Correlation ####
switch(method, "pbiser" = {
xy.cor <- suppressWarnings(cor(x, y, use = "complete.obs"))
#—————————————————————————————————————— #
### Biserial Correlation ####
}, "biser" = {
xy.cor <- suppressWarnings(.cor.polyserial(x, y, se = FALSE, ml = ml))
})
return(xy.cor)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.stats() function -----------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Item-Total Correlation with Confidence Intervals ####
.it.cor <- function(x, y, method, alternative = "two.sided", conf.level = 0.95) {
#—————————————————————————————————————— #
### Point-Biserial Correlation ####
switch(method, "pbiser" = {
# Point-biserial correlation
misty::descript(y, group = x, output = FALSE)$result |>
(\(p) {
# Sample size for each group
n1 <- p$n[2L]
n2 <- p$n[1L]
# Total sample size
n <- n1 + n2
# Proportion of members in category 1
pi <- n1 / n
# Degrees of freedom
df1 <- n1 - 1L
df2 <- n2 - 1L
# Quantile of the standard normal distribution
z <- qnorm(switch(alternative, two.sided = 1L - (1L - conf.level) / 2L, less = conf.level, greater = conf.level))
# Bonnett (2020) Formula (4)
d <- (p$m[2L] - p$m[1L]) / sqrt((df1*p$var[2L] + df2*p$var[1L]) / (df1 + df2))
# Bonnett (2020) Formula (21)
se <- sqrt((d^2L*(1L / df1 + 1L / df2) / 8L) + 1L / n1 + 1L / n2)
# Formula (25)
low.d <- d - z*se
upp.d <- d + z*se
b <- (n - 2L) / (n*pi*(1L - pi))
# Confidence interval, Bonnett (2020) Formula (26)
ci <- switch(alternative,
two.sided = c(low = low.d / sqrt(low.d^2L + b), upp = upp.d / sqrt(upp.d^2L + b)),
less = c(low = -Inf, upp = upp.d / sqrt(upp.d^2L + b)),
greater = c(low = low.d / sqrt(low.d^2L + b), upp = Inf))
return(c(r = d / sqrt(d^2 + b), ci))
})()
#—————————————————————————————————————— #
### Biserial Correlation ####
}, "biser" = {
# Compute biserial correlation coefficient and standard error
r.se <- .cor.polyserial(x, y)
# Quantile of the standard normal distribution
z <- qnorm(switch(alternative, two.sided = 1L - (1L - conf.level) / 2L, less = conf.level, greater = conf.level))
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
less = c(low = -Inf, upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
greater = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = Inf))
return(c(r = unname(r.se["cor"]), ci))
#—————————————————————————————————————— #
### Polyserial Correlation ####
}, "polyser" = {
# Compute polyserial correlation coefficient and standard error
r.se <- .cor.polyserial(x, y)
# Quantile of the standard normal distribution
z <- qnorm(switch(alternative, two.sided = 1L - (1L - conf.level) / 2L, less = conf.level, greater = conf.level))
# Confidence interval
ci <- switch(alternative,
two.sided = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
less = c(low = -Inf, upp = unname(tanh(atanh(r.se["cor"]) + (z * r.se["se"])))),
greater = c(low = unname(tanh(atanh(r.se["cor"]) - (z * r.se["se"]))), upp = Inf))
return(c(r = unname(r.se["cor"]), ci))
})
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Polyserial Correlation Coefficient with SE ####
#
# Function polyserial() from the polycor package
.cor.polyserial <- function(x, y, ml = TRUE, se = TRUE) {
#—————————————————————————————————————— #
### Function ####
f <- function(pars) {
rho <- pars[1L]
cts <- if (isTRUE(length(pars) == 1L)) {
c(-Inf, cuts, Inf)
} else {
c(-Inf, pars[-1L], Inf)
}
if (isTRUE(any(diff(cts) < 0L))) { return(Inf) }
tau <- (matrix(cts, n, s + 1L, byrow = TRUE) - matrix(rho * z, n, s + 1L)) / sqrt(1L - rho^2)
return(-sum(log(dnorm(z) * (pnorm(tau[cbind(indices, y + 1L)]) - pnorm(tau[cbind(indices, y)])))))
}
#—————————————————————————————————————— #
valid <- complete.cases(x, y)
x <- x[valid]
y <- y[valid]
z <- scale(x)
tab <- table(y)
n <- sum(tab)
s <- length(tab)
indices <- seq_len(n)
cuts <- qnorm(cumsum(tab) / n)[-length(tab)]
y <- as.numeric(as.factor(y))
rho <- sqrt((n - 1L) / n) * sd(y) * cor(x, y) / sum(dnorm(cuts))
#—————————————————————————————————————— #
### Maximum-Likelihood Estimate ####
if (isTRUE(ml)) {
#···················
#### With Standard Error ####
if (isTRUE(se)) {
tryCatch(optim(c(rho, cuts), f, hessian = TRUE) |> (\(p) c(cor = p$par[1L], se = sqrt(diag(solve(p$hessian)))[1L]))(),
error = function(y) {
return(cor = NA, se = NA)
})
#···················
#### Without Standard Error ####
} else {
tryCatch(c(cor = optim(c(rho, cuts), f, hessian = FALSE)$par[1L]),
error = function(y) {
return(cor = NA)
})
}
#—————————————————————————————————————— #
### Two-Step Approximation ####
} else {
return(rho)
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the modcomp() function --------------------------------
#
# .caic
# .sabic
#
# https://github.com/cran/semTools/blob/master/R/fitIndices.R
#
# .aicc
# .hqc
# .hbic
# .spbic
# .ibic
# .sic
# .icomp
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Consistent Akaike's Information Criterion ####
.caic <- function(x) {
caic <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(BIC(x) + unname(lavaan::fitmeasures(x)["npar"]), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(BIC(x) + attr(logLik(x), which = "df"), error = function(e) { return(NA) }))
}
return(caic)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Sample-Size Adjusted BIC ####
.sabic <- function(x) {
sabic <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(unname(lavaan::fitmeasures(x) |> (\(p) -2L*p["logl"] + p["npar"] * log((lavaan::nobs(x) + 2L) / 24L))()), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(as.numeric(-2L*logLik(x) + attr(logLik(x), which = "df") * log((nobs(x) + 2L) / 24L)), error = function(e) { return(NA) }))
}
return(sabic)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Corrected Akaike Information Criterion ####
.aicc <- function(x) {
aicc <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(unname(lavaan::fitmeasures(x)["npar"]) |> (\(p) AIC(x) + (2L * p * (p + 1L)) / (lavaan::nobs(x) - p - 1L))(), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(attr(lavaan::logLik(x), which = "df") |> (\(p) AIC(x) + (2L * p * (p + 1L)) / (nobs(x) - p - 1L))(), error = function(e) { return(NA) }))
}
return(unname(aicc))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Hannan-Quinn Information Criterion ####
.hqc <- function(x) {
hqc <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(lavaan::fitmeasures(x) |> (\(p) unname(-2L*p["logl"] + 2L*p["npar"]*log(log(lavaan::nobs(x)))))(), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(unname(-2L*as.numeric(logLik(x)) + 2L*attr(logLik(x), which = "df")*log(log(nobs(x)))), error = function(e) { return(NA) }))
}
return(unname(hqc))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Haughton’s BIC ####
.hbic <- function(x) {
hbic <- if (isTRUE(class(x) == "lavaan")) {
suppressWarnings(tryCatch(lavaan::fitmeasures(x) |> (\(p) unname(-2L*p["logl"] + p["npar"]*log(lavaan::nobs(x) / (2L * pi))))(), error = function(e) { return(NA) }))
} else {
suppressWarnings(tryCatch(-2L*as.numeric(logLik(x)) + attr(logLik(x), which = "df") * log(nobs(x) / (2L * pi)), error = function(e) { return(NA) }))
}
return(unname(hbic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Scaled Unit-Information Prior BIC ####
.spbic <- function(x) {
spbic <- suppressWarnings(tryCatch({
lavaan::coef(x) |> (\(p) t(p) %*% lavaan::lavInspect(x, "information.observed") %*% p)() |>
(\(q) if (lavaan::fitmeasures(x)["npar"] < q) {
return(as.vector(-2L*lavaan::fitmeasures(x)["logl"] + lavaan::fitmeasures(x)["npar"]*(1L - log(lavaan::fitmeasures(x)["npar"] / q))))
} else {
return(as.vector(-2L*lavaan::fitmeasures(x)["logl"] + q))
})()
}, error = function(e) { return(NA) })) |> (\(p) if (is.nan(p)) { return(NA) } else { return(p) } )()
return(unname(spbic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Information-Matrix-based BIC ####
.ibic <- function(x) {
ibic <- suppressWarnings(tryCatch({
det(lavaan::lavInspect(x, what = "vcov")) |> (\(p) if (isTRUE(p <= 0L)) {
return(NA)
} else {
return(-2L*lavaan::fitmeasures(x)["logl"] - lavaan::fitmeasures(x)["npar"]*log(2L*pi) - log(p))
})()
}, error = function(e) { return(NA) })) |> (\(p) if (isTRUE(is.nan(p))) { return(NA) } else { return(p) } )()
return(unname(ibic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Stochastic Information Criterion ####
.sic <- function(x) {
sic <- suppressWarnings(tryCatch({
det(lavaan::lavInspect(x, what = "vcov")) |> (\(p) if (isTRUE(p <= 0L)) {
return(NA)
} else {
return(-2L*lavaan::fitmeasures(x)["logl"] - log(p))
})()
}, error = function(e) { return(NA) })) |> (\(p) if (isTRUE(is.nan(p))) { return(NA) } else { return(p) } )()
return(unname(sic))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Bozdogan Information Complexity ####
.icomp <- function(x) {
icomp <- suppressWarnings(tryCatch({
suppressWarnings(unname(lavaan::lavInspect(x, "inverted.information.expected") |> (\(p) -2L*lavaan::fitmeasures(x)["logl"] + 2L*qr(p)$rank |> (\(q) (q / 2L)*log((sum(diag(p))) / q) - 0.5*log(det(p)))())()))
}, error = function(e) { return(NA) })) |> (\(p) if (isTRUE(is.nan(p))) { return(NA) } else { return(p) } )()
return(icomp)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.cfa() and multilevel.cfa function ------------
#
# https://github.com/dmcneish18/opdyke/tree/main/R
#
# .opdyke.percentiles
# .opdyke
# .r2polar
# .polar2r
# .csc
# .cot
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Calculating the Opdyke Percentile ####
# S = observed correlation matrix, P = predicted correlation matrix
.opdyke.percentiles <- function(S, P, prec = 1) {
# Matrix of percentiles
W <- matrix(NA, nrow = nrow(S), ncol = ncol(S), dimnames = list(colnames(S), colnames(S)))
# Opdyke distribution PDF
W[lower.tri(W)] <- .opdyke(S, prec = prec) |> (\(p) do.call("rbind", lapply(seq_along(p), function(k) p[[k]][which.min(abs(p[[k]]$r - P[p[[k]]$row, p[[k]]$column])), ])) |> (\(q) q[order(q$column, q$row), ]$cdf_exact |> (\(r) ifelse(is.nan(r), NA, r))() )())()
W[upper.tri(W)] <- t(W)[upper.tri(W)]
return(W)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Calculating tge Opdyke Distribution PDF ####
.opdyke <- function(A, prec) {
I <- seq_len(ncol(A))
I5 <- matrix(0L, ncol = length(I), nrow = 1L)
sapply(seq_len((length(I) - 1L)), function(r2) {
sapply(0L:(r2 - 1L), function(r1) {
I5 <<- rbind(I5, c(I[-c((length(I) - r2), length(I) - r1)], (length(I) - r2), length(I) - r1))
})
})
com3 <- matrix(I5[-1L, ], ncol = ncol(I5), dimnames = list(NULL, colnames(A)))
pdf <- list()
sapply(seq_len(nrow(com3)), function(c) {
X <- .r2polar(A[com3[c, ], com3[c, ]])
k <- ncol(X) - 1L
theta <- X[ncol(X), k]
ck <- gamma((0.5*k + 1L)) / (sqrt(pi)*gamma(0.5*k + 0.5))
d <- data.frame(matrix(NA, nrow = 314L*prec, ncol = 4L, dimnames = list(NULL, c("r", "cdf_exact", "row", "column"))))
cot.theta <- .cot(theta)
sapply(seq_len(314L*prec), function(r) {
z <- r / (100L*prec)
X2 <- X
X2[ncol(X), k] <- z
cot.z <- .cot(z)
d[r, 1L] <<- .polar2r(X2)[ncol(X), k]
d[r, 2L] <<- 1L - (0.5 + ck*(cot.theta - cot.z)*gsl::hyperg_2F1(a = 0.5, b = (1L + 0.5*k), c = 1.5, x = -1L*(cot.z - cot.theta)^2L))
})
d[, 3L] <- com3[c, ncol(com3)]
d[, 4L] <- com3[c, ncol(com3) - 1L]
pdf[[c]] <<- d
})
return(pdf)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Convert Correlation Matrix to Polar Angles ####
.r2polar<-function(S) {
A3 <- t(chol(S))
A4 <- matrix(0L, nrow = nrow(A3), ncol = ncol(A3))
A4[1L, 1L] <- 1L
for (i in 2L:ncol(A3)) {
A4[i, 1] <- acos(A3[i, 1])
for (j in 2L:ncol(A3)) {
if (isTRUE(j < i)) {
A4[i, j] <- acos(A3[i, j] / cumprod(sin(A4[i, ]))[j - 1L])
}
}
}
return(A4)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function to Convert Polar Angles to a Correlation Matrix ####
.polar2r <- function(polar) {
A5 <- matrix(0L, nrow = nrow(polar), ncol = ncol(polar))
A5[1L, 1L] <- 1L
for (i in 2L:ncol(A5)) {
A5[i, 1L] <- cos(polar[i, 1L])
p <- cumprod(sin(polar[i, ]))
A5[i, i] <- p[i - 1L]
for(j in 2L:ncol(A5)) {
if (isTRUE(j < i)) {
A5[i, j] <- cos(polar[i, j])*p[j - 1L]
}
}
}
return(A5%*%t(A5))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Inverse of sin and tan ####
.csc <- function(x) { 1L / sin(x) }
.cot <- function(x) { 1L / tan(x) }
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.dfi() function -------------------------------
#
# https://github.com/melissagwolf/dynamic/tree/master/R
# - .sim.fit
# - .n.factors
# - .misspec.one
# - .items.no.cor
# - .resid.cov
# - .misspec.multi
# - .cross.load
# - .items.n.crossload
# - .sim.data.likert
# - .ordsample
# - .ordsample
# - .contord
# - .sim.data.categ
# - .sim.fit
#
# https://stackoverflow.com/questions/19796736/changing-numbers-within-string-in-r
# - .chr.round
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Determine the Number of Factors ####
.n.factors <- function(model.syntax) {
return(lavaan::lavaanify(model.syntax, fixed.x = FALSE) |> (\(p) misty::uniq.n(p[p$op == "=~", "lhs"]))())
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Simulating Fit Indices for Misspecified and True Models in One-Factor CFA Model ####
#
# # Function DGM_one() in the dynamic package
.misspec.one <- function(model.syntax, res.cor) {
# Number of items without residual correlation
n.items <- nrow(.items.no.cor(model.syntax))
# Number of levels given number of items without residual correlation
if (isTRUE(n.items == 4L)) {
levels <- 1L
} else if (isTRUE(n.items == 5L)) {
levels <- rbind(1L, 2L)
} else {
levels <- floor(n.items / 2L) |> (\(p) rbind(floor(p / 3L), floor((2L*p) / 3L), as.numeric(p)))()
}
# Residual covariance misspecification
mod.resid.cov <- .resid.cov(model.syntax, res.cor)
# Model misspecification
mod.syntax.misspec <- setNames(lapply(levels, function(y) paste0(model.syntax, "\n", paste(mod.resid.cov[seq_len(y)], collapse = "\n"))), nm = paste0("Level ", levels))
return(mod.syntax.misspec)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Extracting Items Without Residual Correlations in One-Factor CFA Model ####
#
# Function one_num() in the dynamic package
.items.no.cor <- function(model.syntax){
# lavaan parameter table
model.lavaan <- lavaan::lavaanify(model.syntax, fixed.x = FALSE) |> (\(p) p[which(p$lhs != p$rhs), ])()
# Factor loadings
model.lavaan.load <- model.lavaan |> (\(p) p[which(p$op == "=~"), ] )()
model.lavaan.load <- model.lavaan |> (\(s) s[which(s$op == "=~"), ] )()
# Factor labels
factor.labels <- model.lavaan |> (\(p) unique(p[which(p$op == "=~"), "lhs"]))()
# Items without residual correlation
items.result <- model.lavaan |> (\(p) p[which(p$op == "~~"), ])() |>
(\(q) setdiff(unique(c(q$lhs, q$rhs)), factor.labels))() |>
(\(r) model.lavaan.load[which(!model.lavaan.load$rhs %in% r), ])()
return(items.result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Creating Residual Correlation Misspecification in One-Factor CFA Model ####
#
# Function one_add() in the dynamic package
.resid.cov <- function(model.syntax, res.cor){
# Items without residual correlation
items <- .items.no.cor(model.syntax) |> (\(p) p[order(p$ustart), ])()
# Number of items without residual correlation
n.items <- nrow(items)
# Select items for misspecification
if (isTRUE(n.items == 4L)) {
items.m <- items[1L:2L, ]
} else if (isTRUE(n.items == 5L)) {
items.m <- items[1L:4L, ]
} else {
items.m <- items[seq_len(floor(n.items / 2L)*2L), ]
}
# Residual correlation
resid.cor <- paste0(items.m[seq(1L, nrow(items.m), by = 2), "rhs"] , " ~~ ", res.cor, "*", items.m[seq(2L, nrow(items.m), by = 2), "rhs"])
return(resid.cor)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Simulating Fit Indices for Misspecified and True Models in Multi-Factor CFA Model ####
#
# Function DGM_Multi_HB() in the dynamic package
.misspec.multi <- function(model.syntax) {
# Cross loading misspecification
mod.cross.load <- .cross.load(model.syntax)
# Model misspecification
mod.syntax.misspec <- setNames(lapply(seq_len(length(mod.cross.load)), function(y) paste0(model.syntax, "\n", paste(mod.cross.load[seq_len(y)], collapse = "\n"))), nm = paste0("Level ", seq_len(length(mod.cross.load))))
return(mod.syntax.misspec)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Creating Cross-Loading Misspecification in Multi-Factor CFA Model ####
#
# Function multi_add_HB() in the dynamic package
.cross.load <- function(model.syntax) {
priority <- loading <- NULL
# lavaan model syntax
model.lavaan <- lavaan::lavaanify(model.syntax, fixed.x = FALSE) |>(\(p) p[p$lhs != p$rhs, ])()
# Number of factors
n.fact <- .n.factors(model.syntax)
# Viable items from each factor
itemoptions <- .items.n.crossload(model.syntax)
# Lowest loading from each factor
crosses <- do.call("rbind", lapply(split(itemoptions, itemoptions$lhs), function(y) y[which.min(abs(y$loading)), ])) |> (\(p) p[order(abs(p$loading)), ])() |> (\(q) q[seq_len(n.fact - 1L), ])()
# Factor names
factors <- data.frame(lhs = unique(model.lavaan[model.lavaan$op == "=~", "lhs"]))
# Coefficient H for each factor
coef.H <- suppressMessages(model.lavaan[model.lavaan$op == "=~", ] |> (\(p) data.frame(p, L_Sq = p$ustart^2L, E_Var = 1L - (p$ustart^2L), Div = (p$ustart^2L) / (1L - (p$ustart^2L))))() |>
(\(q) do.call("rbind", lapply(split(q, f = q$lhs), function(y) data.frame(sum = sum(y$Div), rand = runif(n = length(factors), 0L, 0.001)) |> (\(r) data.frame(H = ((1 + (r$sum^-1L))^-1L) + r$rand ))())))() |>
(\(s) data.frame(rhs = row.names(s), s, row.names = NULL))() |> (\(t) t[order(t$H, decreasing = TRUE), ])())
# Factors and factor correlations
fact.cor1 <- model.lavaan[model.lavaan$op == "~~", ] |> (\(p) data.frame(p[p$lhs %in% unlist(factors) & p$rhs %in% unlist(factors), c("lhs", "op", "rhs", "ustart")], type = "Factor"))()
# Factors and factor correlations reversed
fact.cor2 <- setNames(fact.cor1, nm = c("rhs", "op", "lhs", "ustart", "type"))[, c("lhs", "op", "rhs", "ustart", "type")]
# Isolate items
dup1 <- merge(merge(rbind(fact.cor1, fact.cor2), crosses, by = "lhs", all = TRUE), coef.H, by = "rhs")[, c("lhs", "op", "rhs", "ustart", "type", "item", "loading", "priority", "H")] |>
(\(p) p[which(!is.na(p$item)), ])() |>(\(q) q[order(abs(q$loading)), ])()
# Run twice for cleaning later
dup2 <- dup1
# Manipulate to create model statement
setup <- misty::df.unique(rbind(dup1, dup2) |> (\(p) data.frame(p, facts = paste(pmin(p$lhs, p$rhs), pmax(p$lhs, p$rhs), sep = "_")))())
# Rename for iteration
setup.copy <- setup
# Create empty data frame
cleaned <- setup[0L, ]
# Select the highest H for first item i for cross-loading
for (i in unique(setup.copy$item)){
cleaned[i, ] <- setup.copy[setup.copy$item == i, ] |> (\(p) p[which.max(p$H), ])()
setup.copy <- setup.copy[which(!setup.copy$facts %in%cleaned$facts), ]
}
# Data frame
modinfo <- data.frame(cleaned, operator = "=~") |> (\(p) misty::df.sort(p, priority, loading) |> (\(q) do.call("rbind", lapply(split(q, f = paste0(q$priority, q$loading)), function(y) y[order(y$H, decreasing = TRUE), ])))()) ()
# Compute maximum cross loading value
cross.loading <- data.frame(modinfo, F1 = modinfo$ustart, F1.sq = modinfo$ustart^2L, L1 = modinfo$loading, L1.sq = modinfo$loading^2, E = 1L - modinfo$loading^2L) |>
(\(p) data.frame(modinfo, loading.final = pmin(abs(p$loading), abs(round((sqrt(((p$L1.sq * p$F1.sq) + p$E)) - (abs(p$L1 * p$F1)))*0.95, digits = 4))), times = "*" )[, c("rhs", "operator", "loading.final", "times", "item")])() |>
(\(q) unname(apply(q, 1L, function(y) paste0(paste(y["rhs"], y["operator"], y["loading.final"], collapse = " "), y["times"], y["item"], collapse = ""))))()
return(cross.loading)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Extracting Items Without Residual Correlations and Cross Loadings in Multi-Factor CFA Model ####
#
# Function multi_num_HB() in the dynamic package
.items.n.crossload <- function(model.syntax){
# lavaan model syntax
model.lavaan <- lavaan::lavaanify(model.syntax, fixed.x = FALSE) |>(\(p) p[p$lhs != p$rhs, ])()
# Factor names
factors <- unique(model.lavaan[model.lavaan$op == "=~", "lhs"])
# Number of items per factor
n.items <- model.lavaan[model.lavaan$op == "=~", ] |> (\(p) sapply(split(p, f = p$lhs), nrow))() |> (\(q) data.frame(lhs = names(q), original = q))()
# Items that have an error covariance
item.covar <- intersect(model.lavaan[model.lavaan$op == "=~", "rhs"], unlist(model.lavaan[model.lavaan$op == "~~", c("lhs", "rhs")]))
# Items that have a cross loading
item.crossload <- model.lavaan[model.lavaan$op == "=~", ] |> (\(p) p[duplicated(p$rhs), "rhs"])()
# Items that do not already have an error covariance or cross-loading
solo.items <- model.lavaan[model.lavaan$op == "=~" & !model.lavaan$rhs %in% union(item.covar, item.crossload), ]
# Number of remaining and original items per factor
remaining <- merge(if (isTRUE(nrow(solo.items) != 0L)) { solo.items |> (\(p) sapply(split(p, f = p$lhs), nrow))() |> (\(q) data.frame(lhs = names(q), remaining = q))() } else { data.frame(lhs = factors, remaining = 0L) }, n.items, by = "lhs", all = TRUE)
# Add factor loadings, group by number of items per factor (>2 or 2), sort factor loadings within group
itemoptions <- merge(solo.items, remaining, by = "lhs", all = TRUE) |>
(\(p) data.frame(p, priority = ifelse(p$original > 2 & !is.na(p$remaining), "three", "two")))() |>
(\(q) data.frame(setNames(do.call("rbind", lapply(split(q, q$priority), function(y) y[order(abs(y$ustart)), ]))[, c("lhs", "rhs", "ustart", "priority")], nm = c("lhs","item","loading","priority")), row.names = NULL))()
return(itemoptions)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Converting Continuous Data into Likert-Type Item Data ####
#
# Function true_fit_one_likert() and one_fit_likert() from the dynamic package
.sim.data.likert <- function(model.syntax, data, n = n, nrep = nrep) {
# Number of factors
n.fac <- .n.factors(model.syntax)
# Model-implied covariance matrix
sigma <- .sim.standardized.matrices(model.syntax, max.iter = 100L, check = FALSE)$correlations$R |> (\(p) p[seq_len(nrow(p) - n.fac), seq_len(nrow(p) - n.fac)])()
diag(sigma) <- 1
# Remove cases with missing on all variables
data1 <- data[, colnames(sigma)] |> (\(p) p[rowSums(is.na(p)) != ncol(p), ])()
# Rescale so that minimum value is always 1
d2 <- matrix(sapply(data1, function(y) min(y, na.rm = TRUE) - 1L), nrow = 1L, ncol = ncol(data1))
d3 <- matrix(rep(d2, each = nrow(data1)), nrow = nrow(data1), ncol = ncol(data1), dimnames = list(NULL, colnames(data1)))
d4 <- matrix(rep(d2, each = nrow(data1)), nrow = nrep*nrow(data1), ncol = ncol(data1), dimnames = list(NULL, colnames(data1)))
data1 <- data1 - d3
# Create empty matrix for proportions in each category (g)
g <- matrix(nrow = (max(data1, na.rm = TRUE) - min(data1, na.rm = TRUE)), ncol = ncol(data1))
p <- list()
# Loop through all variables in the fitted model
for (i in seq_len(ncol(data1))) {
# Loop through all categories for each variable
for (h in min(data1[, i], na.rm = TRUE):(max(data1[, i], na.rm = TRUE) - 1L)) {
# Proportion of responses at or below each category, only count non-missing in the denominator
g[h, i] <- sum(table(data1[, i])[names(table(data1[, i])) <= h]) / sum(!is.na(data1[, i]))
p[[i]] <- g[, i]
}
}
# Handle different number of categories per item
marginal <- list()
for (i in seq_len(length(p))) {
marginal[[i]] <- p[[i]][!is.na(p[[i]])]
}
# Simulate ordinal data with same observed correlation matrix as observed data
return(setNames(as.data.frame(.ordsample(n = n*nrep, marginal = marginal, Sigma = sigma) + d4), nm = colnames(d4)))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Drawing a Sample of Discrete Data ####
#
# Function ordsample() from the GenOrd package
.ordsample <- function(n, marginal, Sigma, support = list(), df = Inf) {
# k = number of variables
k <- length(marginal)
# kj = number of categories for the k variables (vector of k integer numbers)
kj <- numeric(k)
len <- length(support)
for (i in seq_len(k)) {
kj[i] <- length(marginal[[i]]) + 1L
if (isTRUE(len == 0L)) { support[[i]] <- seq_len(kj[i]) }
}
Sigma <- .ordcont(marginal = marginal, Sigma = Sigma, support = support, df = df)[[1L]]
# Sample of size n from k-dimensional Student's t or normal with vector of zero means and correlation matrix Sigma
restab <- mvtnorm::rmvt(n, sigma = Sigma, delta = rep(0L, k), df = df, type = "shifted")
if (isTRUE(n == 1L)) { restab <- matrix(restab, nrow = 1L) }
# Discretization according to the marginal distributions
for(i in seq_len(k)) {
restab[,i] <- as.integer(cut(restab[, i], breaks = c(min(restab[, i]) - 1L, qt(marginal[[i]], df = df), max(restab[, i]) + 1L)))
restab[,i] <- support[[i]][restab[, i]]
}
return(restab)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing the "intermediate" Correlation mMtrix for the Multivariate Standard Normal ####
#
# Function ordcont() from the GenOrd package
.ordcont <- function (marginal, Sigma, support = list(), epsilon = 1e-06, maxit = 100, df = Inf) {
len <- length(support)
k <- length(marginal)
niter <- matrix(0L, k, k)
kj <- numeric(k)
for (i in seq_len(k)) {
kj[i] <- length(marginal[[i]]) + 1L
if (isTRUE(len == 0L)) {
support[[i]] <- seq_len(kj[i])
}
}
Sigmaold <- Sigma0 <- Sigma
Sigmaordold <- Sigmaord <- .contord(marginal, Sigma, support, df = df)
for (q in 1:(k - 1L)) {
for (r in (q + 1L):k) {
if (isTRUE(Sigma0[q, r] == 0L)) {
Sigma[q, r] <- 0L
} else {
it <- 0L
while (max(abs(Sigmaord[q, r] - Sigma0[q, r]) > epsilon) & it < maxit) {
if (Sigma0[q, r] * (Sigma0[q, r]/Sigmaordold[q, r]) >= 1L) {
Sigma[q, r] <- Sigmaold[q, r] * (1L + 0.1 * (1L - Sigmaold[q, r]) * sign(Sigma0[q, r] - Sigmaord[q, r]))
} else {
Sigma[q, r] <- Sigmaold[q, r] * (Sigma0[q, r] / Sigmaord[q, r])
}
Sigma[r, q] <- Sigma[q, r]
Sigmaord[r, q] <- .contord(list(marginal[[q]], marginal[[r]]), matrix(c(1L, Sigma[q, r],Sigma[q, r], 1L), 2L, 2L), list(support[[q]], support[[r]]), df = df)[2L]
Sigmaord[q, r] <- Sigmaord[r, q]
Sigmaold[q, r] <- Sigma[q, r]
Sigmaold[r, q] <- Sigmaold[q, r]
it <- it + 1L
}
niter[q, r] <- it
niter[r, q] <- it
}
}
}
if (eigen(Sigma)$values[k] <= 0) {
message("The Sigma matrix is not coherent with the given margins or
it is impossible to find a feasible correlation matrix for MVN
ensuring Sigma for the given margins")
Sigma <- matrix(NA, k, k)
diag(Sigma) <- 1L
}
emax <- max(abs(Sigmaord - Sigma0))
list(SigmaC = Sigma, SigmaO = Sigmaord, Sigma = Sigma0, niter = niter, maxerr = emax)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing the Correlations of Discretized Variables ####
#
# Function contord() from the GenOrd package
.contord <- function(marginal, Sigma, support = list(), df = Inf) {
len <- length(support)
k <- length(marginal)
kj <- numeric(k)
Sigmaord <- diag(k)
for (i in seq_len(k)) {
kj[i] <- length(marginal[[i]]) + 1L
if (isTRUE(len == 0L)) {
support[[i]] <- 1L:kj[i]
}
}
L <- vector("list", k)
for (i in seq_len(k)) {
L[[i]] <- qt(marginal[[i]], df = df)
L[[i]] <- c(-Inf, L[[i]], +Inf)
}
for (q in seq_len(k - 1L)) {
for (r in (q + 1L):k) {
pij <- matrix(0, kj[q], kj[r])
for (i in seq_len(kj[q])) {
for (j in seq_len(kj[r])) {
low <- rep(-Inf, k)
upp <- rep(Inf, k)
low[q] <- L[[q]][i]
low[r] <- L[[r]][j]
upp[q] <- L[[q]][i + 1L]
upp[r] <- L[[r]][j + 1L]
pij[i, j] <- mvtnorm::pmvt(low, upp, rep(0L, k), corr = Sigma, df = df)
low <- rep(-Inf, k)
upp <- rep(Inf, k)
}
}
my <- sum(apply(pij, 2L, sum) * support[[r]])
sigmay <- sqrt(sum(apply(pij, 2L, sum) * support[[r]]^2L) - my^2L)
mx <- sum(apply(pij, 1L, sum) * support[[q]])
sigmax <- sqrt(sum(apply(pij, 1L, sum) * support[[q]]^2L) - mx^2L)
mij <- support[[q]] %*% t(support[[r]])
muij <- sum(mij * pij)
covxy <- muij - mx * my
corxy <- covxy / (sigmax * sigmay)
Sigmaord[q, r] <- corxy
}
}
SO <- as.matrix(Matrix::forceSymmetric(Sigmaord))
return(SO)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Converting Continuous Data into Categorical Item Data ####
#
# Function true_fit_one_cat() from the dynamic package
.sim.data.categ <- function(model.syntax, model.syntax.thres, n = n, nrep = nrep) {
# Simulate standardized data
all_data_true <- sim.data <- misty::sim.lavaan(model.syntax, n = n*nrep, std = TRUE)
# Thresholds
a2 <- as.data.frame(t(unique(model.syntax.thres[model.syntax.thres$op == "|", "lhs"])))
a1 <- setNames(reshape(model.syntax.thres, idvar = "rhs", timevar = "lhs", direction = "wide", drop = "op")[, -1L], nm = a2)
for (i in seq_len(ncol(a1))) {
u <- as.numeric(sum(!is.na(a1[, i])))
# Column name to modify
colname <- a2[, i]
# Original and current values
res <- x <- sim.data[[colname]]
# Piecewise updates
res[which(!is.na(x) & x <= a1[1, i])] <- 100L
res[which(!is.na(x) & x > a1[u, i])] <- 100L * (u + 1L)
# Write back to data frame
sim.data[[colname]] <- res
if (isTRUE(sum(!is.na(a1[, i])) > 1L)) {
for (j in seq_len(sum(!is.na(a1[, i])))) {
colname <- a2[, i]
x <- sim.data[[colname]]
x[!is.na(x) & x >= a1[j, i] & x <= a1[j + 1L, i]] <- as.numeric(100L * (j + 1L))
sim.data[[colname]] <- x
}
}
}
#sim.data <- sim.data / 100
return(sim.data)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Simulating Fit Indices for Misspecified and True Models ####
#
# Function one_fit() from the dynamic package
.sim.fit <- function(model.syntax, model.syntax.thres, sim.model = sim.model, type, data, n, estimator, se, sim.fit.indices, nrep, seed = seed, progress) {
# Model without Parameter Estimates
model.syntax.free <- .fixed2free(model.syntax)
#—————————————————————————————————————— #
### Simulate Data ####
#...................
#### Normal Continuous Indicators ####
switch(type, "norm" = {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = split(misty::sim.lavaan(sim.model[[1L]], n = n*nrep, std = TRUE), f = rep(seq_len(nrep), times = n)))
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[2L]) }
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) misty::sim.lavaan(y, n = n*nrep, std = TRUE)) |> (\(p) lapply(p, function(z) split(z, f = rep(seq_len(nrep), times = n))))()
# Append lists
sim.data <- append(sim.data0, sim.data1)
#...................
#### Non-Normal Continuous Indicators ####
}, "nnorm" = {
# Number of factors
n.fac <- .n.factors(model.syntax)
# Model-implied covariance matrix
sigma <- .sim.standardized.matrices(sim.model[[1L]], max.iter = 100L, check = FALSE)$correlations$R |> (\(p) p[seq_len(nrow(p) - n.fac), seq_len(nrow(p) - n.fac)])() |> (\(q) q[order(rownames(q)), order(rownames(q))])()
# Remove cases with missing on all variables
data1 <- data[, colnames(sigma)] |> (\(p) p[rowSums(is.na(p)) != ncol(p), ])()
# Model-implied mean vector
mu <- colMeans(data1, na.rm = TRUE)
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = misty::boot.bs(sigma = sigma, mu = mu, data = data1, R = nrep, return = "bootsamp"))
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) misty::boot.bs(sigma = .sim.standardized.matrices(y, max.iter = 100L, check = FALSE)$correlations$R |> (\(p) p[seq_len(nrow(p) - n.fac), seq_len(nrow(p) - n.fac)])() |> (\(q) q[order(rownames(q)), order(rownames(q))])(), mu = mu, data = data1, R = nrep, return = "bootsamp", seed = seed[2]))
# Append lists
sim.data <- append(sim.data0, sim.data1)
#...................
#### Likert-Type Indicators ####
}, "likert" = {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = split(.sim.data.likert(sim.model[[1L]], data = data, n = n, nrep = nrep), f = rep(seq_len(nrep), times = n)))
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[2L]) }
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) .sim.data.likert(y, data = data, n = n, nrep = nrep)) |> (\(p) lapply(p, function(z) split(z, f = rep(seq_len(nrep), times = n))))()
# Append lists
sim.data <- append(sim.data0, sim.data1)
#...................
#### Categorical Indicators ####
}, "categ" = {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[1L]) }
# Simulate Level 0 Misspecification Data
sim.data0 <- list("Level 0" = split(.sim.data.categ(sim.model[[1L]], model.syntax.thres = model.syntax.thres, n = n, nrep = nrep), f = rep(seq_len(nrep), times = n)))
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed[2L]) }
# Simulate Level 1-3 Misspecification Data
sim.data1 <- lapply(sim.model[-1L], function(y) .sim.data.categ(y, model.syntax.thres = model.syntax.thres, n = n, nrep = nrep)) |> (\(p) lapply(p, function(z) split(z, f = rep(seq_len(nrep), times = n))))()
# Append lists
sim.data <- append(sim.data0, sim.data1)
})
#—————————————————————————————————————— #
### Estimate Models ####
#···················
#### With Progress Bar ####
fit.result <- vector(mode = "list", length = length(sim.data))
if (isTRUE(progress)) {
for (i in seq_along(sim.data)) {
message(paste0(" Simulating Misspecification ", names(sim.data)[i]))
# Open progress bar
progress.bar <- txtProgressBar(min = 1L, max = nrep, initial = 1L, char = "=", width = getOption("width") - 13L, style = 3, file = "")
for (j in seq_len(nrep)) {
fit.result[[i]][[j]] <- tryCatch(suppressWarnings(lavaan::fitmeasures(lavaan::cfa(model = model.syntax.free, estimator = estimator, data = sim.data[[i]][[j]],
std.lv = TRUE, ordered = ifelse(type == "categ", TRUE, FALSE),
se = se, warn = FALSE, check.lv.names = FALSE, check.gradient = FALSE,
check.start = FALSE, check.post = FALSE, check.vcov = FALSE, h1 = FALSE,
baseline = FALSE, store.vcov = FALSE, control = list(rel.tol = 0.001)), fit.measures = sim.fit.indices)),
error = function(y) { return(setNames(rep(NA, times = 4L), sim.fit.indices)) })
setTxtProgressBar(progress.bar, value = j)
}
# Close progress bar
close(progress.bar)
}
#···················
#### Without Progress Bar ####
} else {
# Model estimation
fit.result <- lapply(sim.data, function(y) lapply(y, function(z) tryCatch(suppressWarnings(lavaan::fitmeasures(lavaan::cfa(model = model.syntax.free, estimator = estimator, data = z, std.lv = TRUE,
se = se, warn = FALSE, check.lv.names = FALSE, check.gradient = FALSE,
check.start = FALSE, check.post = FALSE, check.vcov = FALSE, h1 = FALSE,
baseline = FALSE, store.vcov = FALSE, control = list(rel.tol = 0.001)), fit.measures = sim.fit.indices)),
error = function(y) { return(setNames(rep(NA, times = 4L), sim.fit.indices)) })))
}
# Combine Results
sim.result <- setNames(lapply(fit.result, function(y) setNames(as.data.frame(do.call("rbind", y)), nm = c("cfi", "tli", "rmsea", "srmr"))), nm = names(sim.data))
# Return object
return(sim.result)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Rounding Number Within a Character String ####
.chr.round <- function(x, digits) {
m <- gregexpr("(-)?[[:digit:]]+\\.[[:digit:]]*", x)
regmatches(x, m) <- lapply(regmatches(x, m), function(y) round(as.numeric(y), digits = digits))
return(x)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the item.nonequi() function ---------------------------
#
# https://github.com/ddueber/dmacs/blob/master/R/MeasEquiv_EffectSize_Wrappers.R
#
# .dmacs_summary
# .dmacs_summary_single
#
# https://github.com/ddueber/dmacs/blob/master/R/MeasEquiv_EffectSize_Base.R
#
# .item_dmacs
# .expected_value
# .delta_mean_item
# .delta_var
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Summary of Measurement Non-Equivalence ####
#
# Returns a list of dMACS measurement nonequivalence from Nye and Drasgow (2011)
.dmacs_summary <- function(LambdaList, NuList, MeanList, VarList, SDList, Groups = NULL, RefGroup = 1, ThreshList = NULL, ThetaList = NULL, signed = FALSE, ordered = FALSE) {
#—————————————————————————————————————— #
### Continuous Indicators ####
if (!ordered) {
#···················
#### Two Groups or Time Points ####
if (isTRUE(length(Groups) == 2L)) {
.dmacs_summary_single(LambdaF = LambdaList[-RefGroup][[1L]], LambdaR = LambdaList[[RefGroup]],
NuF = NuList[-RefGroup][[1L]], NuR = NuList[[RefGroup]],
MeanF = MeanList[-RefGroup][[1L]], VarF = VarList[-RefGroup][[1L]],
SD = SDList[-RefGroup][[1L]], signed = signed, ordered = ordered)
#···················
#### More than Two Groups or Time Points ####
} else {
mapply(.dmacs_summary_single, LambdaF = LambdaList[-RefGroup], NuF = NuList[-RefGroup], MeanF = MeanList[-RefGroup], VarF = VarList[-RefGroup], SD = SDList[-RefGroup],
MoreArgs = list(LambdaR = LambdaList[[RefGroup]], NuR = NuList[[RefGroup]], signed = signed, ordered = ordered), SIMPLIFY = FALSE)
}
#—————————————————————————————————————— #
### Ordered Categorical Indicators ####
} else {
#...................
#### Two Groups or Time Points ####
if (isTRUE(length(Groups) == 2L)) {
.dmacs_summary_single(LambdaF = LambdaList[-RefGroup][[1L]], LambdaR = LambdaList[[RefGroup]], NuF = NuList[-RefGroup][[1L]], NuR = NuList[[RefGroup]],
ThreshF = ThreshList[-RefGroup][[1L]], ThreshR = ThreshList[[RefGroup]], ThetaF = ThetaList[-RefGroup][[1L]], ThetaR = ThetaList[[RefGroup]],
MeanF = MeanList[-RefGroup][[1L]], VarF = VarList[-RefGroup][[1L]], SD = SDList[-RefGroup][[1L]], signed = signed, ordered = ordered)
#...................
#### More than Two Groups or Time Points ####
} else {
mapply(.dmacs_summary_single, LambdaF = LambdaList[-RefGroup], NuF = NuList[-RefGroup], ThreshF = ThreshList[-RefGroup], ThetaF = ThetaList[-RefGroup], MeanF = MeanList[-RefGroup], VarF = VarList[-RefGroup], SD = SDList[-RefGroup],
MoreArgs = list(LambdaR = LambdaList[[RefGroup]], NuR = NuList[[RefGroup]], ThreshR = ThreshList[[RefGroup]], ThetaR = ThetaList[[RefGroup]], signed = signed, ordered = ordered), SIMPLIFY = FALSE)
}
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Summary of Measurement Non-Equivalence for a Single Group ####
#
# A list of dMACS measurement nonequivalence effects from Nye and Drasgow (2011)
.dmacs_summary_single <- function(LambdaR, LambdaF, NuR, NuF, MeanF, VarF, SD, ThreshR = NULL, ThreshF = NULL, ThetaR = NULL, ThetaF = NULL, signed = FALSE, ordered = FALSE) {
#—————————————————————————————————————— #
### Continuous Indicators ####
if (!ordered) {
#...................
#### One Factor ####
if (isTRUE(ncol(LambdaR) == 1L)) {
dmacs <- setNames(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, signed = signed, ordered = FALSE), nm = rownames(LambdaR))
m.diff <- setNames(sum(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ordered = FALSE), na.rm = TRUE), nm = colnames(LambdaR))
v.diff <- setNames(.delta_var(LambdaR = LambdaR, LambdaF = LambdaF, VarF = VarF), nm = colnames(LambdaR))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = v.diff)
#...................
#### More than One Factor ####
} else {
MeanF <- matrix(rep(as.vector(MeanF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
VarF <- matrix(rep(as.vector(VarF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
dmacs <- setNames(as.data.frame(matrix(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, signed = signed, ordered = FALSE), nrow = nrow(LambdaR)), row.names = rownames(LambdaR)), nm = colnames(LambdaR))
m.diff <- as.data.frame(matrix(colSums(matrix(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ordered = FALSE), nrow = nrow(LambdaR)), na.rm = TRUE), ncol = ncol(LambdaR), dimnames = list(NULL, colnames(LambdaR))))
v.diff <- as.data.frame(matrix(sapply(seq_len(ncol(LambdaR)), function(y) { .delta_var(LambdaR[, y] |> (\(p) p[p != 0])(), LambdaF[, y] |> (\(p) p[p != 0])(), VarF[y]) }), ncol = ncol(LambdaR), dimnames = list(NULL, colnames(LambdaR))))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = v.diff)
}
#—————————————————————————————————————— #
### Ordered Categorical Indicators ####
} else {
#...................
#### One Factor ####
if (isTRUE(ncol(LambdaR) == 1L)) {
dmacs <- setNames(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, signed = signed, ordered = ordered), nm = rownames(LambdaR))
m.diff <- setNames(sum(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, ordered = ordered), na.rm = TRUE), nm = colnames(LambdaR))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = NULL)
#...................
#### More than One Factor ####
} else {
MeanF <- matrix(rep(as.vector(MeanF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
VarF <- matrix(rep(as.vector(VarF), nrow(LambdaR)), nrow = nrow(LambdaR), byrow = TRUE)
dmacs <- setNames(data.frame(matrix(mapply(.item_dmacs, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, SD = SD, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, signed = signed, ordered = ordered), nrow = nrow(LambdaR)), row.names = rownames(LambdaR)), nm = colnames(LambdaR))
m.diff <- as.data.frame(matrix(colSums(matrix(mapply(.delta_mean_item, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, MeanF = MeanF, VarF = VarF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, ordered = ordered), nrow = nrow(LambdaR)), na.rm = TRUE), ncol = ncol(LambdaR), dimnames = list(NULL, colnames(LambdaR))))
summary_single <- list(dmacs = dmacs, m.diff = m.diff, v.diff = NULL)
}
}
return(summary_single)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing dMACS Effect Size for Measurement Non-Equivalence ####
#
# Returns dMACS effect size, see equation 3 in Nye & Drasgow (2011).
.item_dmacs <- function(LambdaR, LambdaF, NuR, NuF, MeanF, VarF, SD, ThreshR = NULL, ThreshF = NULL, ThetaR = NULL, ThetaF = NULL, signed, ordered = FALSE) {
# Check the number of thresholds
if (isTRUE(ordered)) { if (isTRUE(length(ThreshR) != length(ThreshF))) { stop("Items must have the same number of thresholds in both reference and focal group.", call. = FALSE) } }
## Check if items load on the factor
if (isTRUE(LambdaR != 0L)) {
# Function for the integrand
integrand <- function(z, LambdaR, LambdaF, NuR, NuF, ThreshR, ThreshF, ThetaR, ThetaF, MeanF, VarF, signed, ordered) {
if (isTRUE(!signed)) {
(.expected_value(LambdaF, NuF, MeanF + z*sqrt(VarF), ThreshF, ThetaF, ordered) - .expected_value(LambdaR, NuR, MeanF + z*sqrt(VarF), ThreshR, ThetaR, ordered))^2L * dnorm(z)
} else {
(.expected_value(LambdaF, NuF, MeanF + z*sqrt(VarF), ThreshF, ThetaF, ordered) - .expected_value(LambdaR, NuR, MeanF + z*sqrt(VarF), ThreshR, ThetaR, ordered)) * dnorm(z)
}
}
# Compute dMACS
if (isTRUE(!signed)) {
dmacs <- tryCatch(suppressWarnings(sqrt(integrate(integrand, -Inf, Inf, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, MeanF = MeanF, VarF = VarF, signed = signed, ordered = ordered)$value) / SD),
error = function(y) {
stop("There was an estimation problem, dMACS could not be computed.", call. = FALSE)
})
} else {
# Compute Signed dMACS
dmacs <- tryCatch(suppressWarnings(integrate(integrand, -Inf, Inf, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, MeanF = MeanF, VarF = VarF, signed = signed, ordered = ordered)$value / SD),
error = function(y) {
stop("There was an estimation problem, signed dMACS could not be computed.", call. = FALSE)
})
}
} else {
dmacs <- NA
}
return(dmacs)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Expected Value of an Indicator ####
#
# Returns the expected value of an indicator given item parameters and factor value
.expected_value <- function(Lambda, Nu, Eta, Thresh = NULL, Theta = NULL, ordered = FALSE) {
#—————————————————————————————————————— #
### Continuous Indicators ####
if (isTRUE(!ordered)) {
expected <- Nu + Lambda*Eta
#—————————————————————————————————————— #
### Ordered Categorical Indicators ####
} else {
Mu <- Nu + Lambda*Eta
max <- length(Thresh)
Thresh[max + 1L] <- Inf
expected <- 0L
for (i in seq_len(max)) { expected <- expected + i*(pnorm(Mu - Thresh[i], sd = sqrt(Theta)) - pnorm(Mu - Thresh[i + 1L], sd = sqrt(Theta))) }
}
return(expected)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Expected Bias to the Item Mean ####
#
# Returns the expected bias in the item mean due to measurement non-equivalence
# in equation 4 of Nye & Drasgow (2011).
.delta_mean_item <- function(LambdaR, LambdaF, NuR, NuF, MeanF, VarF, ThreshR = NULL, ThreshF = NULL, ThetaR = NULL, ThetaF = NULL, ordered = FALSE) {
# Check the number of thresholds
if (isTRUE(ordered)) { if (isTRUE(length(ThreshR) != length(ThreshF))) { stop("Items must have the same number of thresholds in both reference and focal group.", call. = FALSE) } }
## Check if items load on the factor
if (isTRUE(LambdaR != 0L)) {
integrand <- function(z, LambdaR, LambdaF, NuR, NuF, ThreshR, ThreshF, ThetaR, ThetaF, MeanF, VarF, ordered) {
(.expected_value(LambdaF, NuF, MeanF + z*sqrt(VarF), ThreshF, ThetaF, ordered) - .expected_value(LambdaR, NuR, MeanF + z*sqrt(VarF), ThreshR, ThetaR, ordered)) * dnorm(z)
}
delta_mean_item <- integrate(integrand, -Inf, Inf, LambdaR = LambdaR, LambdaF = LambdaF, NuR = NuR, NuF = NuF, ThreshR = ThreshR, ThreshF = ThreshF, ThetaR = ThetaR, ThetaF = ThetaF, MeanF = MeanF, VarF = VarF, ordered = ordered)$value
} else {
delta_mean_item <- NA
}
return(delta_mean_item)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Function for Computing Expected Bias to the Total Score Variance ####
#
# Returns the expected bias in the total score variance due to measurement non-equivalence
# in equation 7, 8, and 9 of Nye & Drasgow (2011).
.delta_var <- function(LambdaR, LambdaF, VarF, ordered = FALSE) {
delta_cov_mat <- matrix(nrow = length(LambdaR), ncol = length(LambdaR))
for (i in seq_along(LambdaR)) {
for (j in seq_along(LambdaR)) {
(delta_cov_mat[i, j] <- LambdaR[[j]]*(LambdaF[[i]] - LambdaR[[i]])*VarF) + (LambdaR[[i]]*(LambdaF[[j]] - LambdaR[[j]])*VarF) + ((LambdaF[[i]] - LambdaR[[i]])*(LambdaF[[j]] - LambdaR[[j]])*VarF)
}
}
return(sum(delta_cov_mat))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.print() function ----------------------------
#
# - .section.ind.from.to
.section.ind.from.to <- function(x, cur.section, run, input = FALSE) {
# Input
if (isTRUE(input)) {
parse.text <- parse(text = paste0("min(unlist(sapply(x, function(z) if (isTRUE(any(grep(z, run)))) {
sapply(grep(z, run), function(q) if (isTRUE(q > max(", paste0(sapply(cur.section, function(w) paste0("grep(", paste0("\"", w, "\""), ", run")), collapse = " | "), ")))) { q } else { length(run) + 1L })
} )))"))
# Output
} else {
parse.text <- parse(text = paste0("min(unlist(sapply(x, function(z) if (isTRUE(any(run == z))) {
sapply(which(run == z), function(q) if (isTRUE(q > max(which(", paste0(sapply(cur.section, function(w) paste0("run == ", paste0("\"", w, "\""))), collapse = " | "), ")))) { q } else { length(run) + 1L })
})))"))
}
return(eval(parse.text) - 1L)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.lca.summa() function ------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Extracting Results ####
.extract.lca.result <- function(lca.out.extract, max.class, conf.level, return) {
# Return objects
model.summary <- model.class <- model.descript <- nclass <- NA
#—————————————————————————————————————— #
### Model Convergence ####
conv <- any(grep("THE MODEL ESTIMATION TERMINATED NORMALLY", lca.out.extract, useBytes = TRUE))
#—————————————————————————————————————— #
### Number of Classes ####
if (isTRUE(any(grepl("CLASSES ", lca.out.extract, ignore.case = TRUE, useBytes = TRUE)))) { nclass <- unlist(strsplit(grep("CLASSES ", lca.out.extract, value = TRUE, ignore.case = TRUE, useBytes = TRUE), "")) |> (\(p) as.numeric(misty::chr.trim(paste(p[(grep("\\(", p, useBytes = TRUE) + 1L):(grep("\\)", p, useBytes = TRUE) - 1L)], collapse = ""))))() }
#—————————————————————————————————————— #
### Model Converged ####
if (isTRUE(conv)) {
if (isTRUE(return == "model.summary")) {
#···················
#### Model Summary ####
model.summary <- data.frame(# Number of classes
nclass = nclass,
# Model converged
conv = conv,
# Number of parameters
nparam = as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Loglikelihood
LL = as.numeric(misty::chr.trim(sub("H0 Value", "", grep("H0 Value ", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Loglikelihood Scaling correction factor
LL.scale = ifelse(any(grepl("H0 Scaling Correction Factor", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("H0 Scaling Correction Factor", "", grep("H0 Scaling Correction Factor", lca.out.extract, value = TRUE, useBytes = TRUE)))), NA),
# Loglikelihood replicated
LL.rep = ifelse(any(grepl("THE BEST LOGLIKELIHOOD VALUE WAS NOT REPLICATED", lca.out.extract, useBytes = TRUE)), FALSE, TRUE),
# AIC, CAIC, BIC, SABIC
aic = as.numeric(misty::chr.trim(sub("Akaike \\(AIC\\)", "", grep("Akaike \\(AIC\\)", lca.out.extract, value = TRUE, useBytes = TRUE)))),
caic = as.numeric(misty::chr.trim(sub("Bayesian \\(BIC\\)", "", grep("Bayesian \\(BIC\\)", lca.out.extract, value = TRUE, useBytes = TRUE)))) + as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE)))),
bic = as.numeric(misty::chr.trim(sub("Bayesian \\(BIC\\)", "", grep("Bayesian \\(BIC\\)", lca.out.extract, value = TRUE, useBytes = TRUE)))),
sabic = as.numeric(misty::chr.trim(sub("Sample-Size Adjusted BIC", "", grep("Sample-Size Adjusted BIC", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Approximate weight of evidence criterion (AWE)
awe = -2*as.numeric(misty::chr.trim(sub("H0 Value", "", grep("H0 Value ", lca.out.extract, value = TRUE, useBytes = TRUE)))) + 2 * as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE))))*(log(as.numeric(misty::chr.trim(sub("Number of observations", "", grep("Number of observations ", lca.out.extract, value = TRUE, useBytes = TRUE))))) + 1.5),
# Pearson Chi-Square
chi.pear = ifelse(any(grepl("Chi-Square Test of Model Fit", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("Pearson Chi-Square", lca.out.extract, useBytes = TRUE)[1L] + 4L]))), NA),
# Likelihood Ratio Chi-Square
chi.lrt = ifelse(any(grepl("Chi-Square Test of Model Fit", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("Likelihood Ratio Chi-Square", lca.out.extract, useBytes = TRUE)[1L] + 4L]))), NA),
# LMR-LRT
lmr.lrt = ifelse(any(grepl("VUONG-LO-MENDELL-RUBIN LIKELIHOOD RATIO TEST", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("Standard Deviation", lca.out.extract, useBytes = TRUE) + 1L]))), NA),
# Adjusted LMR-LRT
almr.lrt = ifelse(any(grepl("LO-MENDELL-RUBIN ADJUSTED", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("P-Value", "", lca.out.extract[grep("LO-MENDELL-RUBIN ADJUSTED", lca.out.extract, useBytes = TRUE) + 3L]))), NA),
# Bootstrap LRT
blrt = ifelse(any(grepl("PARAMETRIC BOOTSTRAPPED LIKELIHOOD", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("Approximate P-Value", "", lca.out.extract[grep("Approximate P-Value", lca.out.extract, useBytes = TRUE)]))), NA),
# Entropy
entropy = ifelse(any(grepl("Entropy", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("Entropy", "", grep("Entropy", lca.out.extract, value = TRUE, useBytes = TRUE)))), NA),
# Minimum average posterior class probability (AvePP)
avemin = min(as.numeric(diag(matrix(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(misty::chr.trim(lca.out.extract[grep("Average Latent Class Probabilities", lca.out.extract, useBytes = TRUE) + z]), " "))[-1L])
}), ncol = nclass))), na.rm = TRUE),
# Minimum class size of most likely latent class membership
nmin = min(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z], " ")))[[2L]]
})), na.rm = TRUE),
# Minimum average posterior class probability (AvePP)
pmin = min(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(misty::chr.trim(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z]), " "))) |> (\(p) p[which(grepl("\\.", p, useBytes = TRUE))])()
})), na.rm = TRUE))
}
#···················
#### Classification Diagnostics ####
if (isTRUE(return == "model.class")) {
model.class <- data.frame(# Number of classes
nclass = nclass,
# Model converged
conv = conv,
# Number of parameters
nparam = as.numeric(misty::chr.trim(sub("Number of Free Parameters", "", grep("Number of Free Parameters", lca.out.extract, value = TRUE, useBytes = TRUE)))),
# Loglikelihood replicated
LL.rep = ifelse(any(grepl("THE BEST LOGLIKELIHOOD VALUE WAS NOT REPLICATED", lca.out.extract, useBytes = TRUE)), FALSE, TRUE),
# Model-estimated class counts
as.data.frame(matrix(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
misty::chr.omit(unlist(strsplit(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z], " ")))[[2L]]
})) |> (\(q) if (isTRUE(length(q) != max.class)) { c(q, rep(NA, times = max.class - length(q))) } else { return(q) })(), ncol = max.class, dimnames = list(NULL, paste0("n", seq_len(max.class))))),
# Model-estimated proportion (pi)
as.data.frame(matrix(as.numeric(sapply(5L:(5L + nclass - 1L), function(z) {
unlist(strsplit(lca.out.extract[grep("BASED ON THE ESTIMATED MODEL", lca.out.extract, useBytes = TRUE) + z], " ")) |> (\(p) p[which(grepl("\\.", p, useBytes = TRUE))][2L])()
})) |> (\(q) if (isTRUE(length(q) != max.class)) { c(q, rep(NA, times = max.class - length(q))) } else { return(q) })(), ncol = max.class, dimnames = list(NULL, paste0("p", seq_len(max.class))))),
# Entropy
entropy = ifelse(any(grepl("Entropy", lca.out.extract, useBytes = TRUE)), as.numeric(misty::chr.trim(sub("Entropy", "", grep("Entropy", lca.out.extract, value = TRUE, useBytes = TRUE)))), NA),
# Average posterior class probability (AvePP)
as.data.frame(matrix(diag(sapply(5L:(5L + nclass - 1), function(z) {
as.numeric(misty::chr.omit(unlist(strsplit(misty::chr.trim(lca.out.extract[grep("Average Latent Class Probabilities", lca.out.extract, useBytes = TRUE) + z]), " "))[-1L]))
})) |> (\(p) if (isTRUE(length(p) != max.class)) { c(p, rep(NA, times = max.class - length(p))) } else { return(p) })(), ncol = max.class, dimnames = list(NULL, paste0("ave.pp", seq_len(max.class)))))) |>
# Odds of correct classification ratio (OCC)
(\(p) data.frame(p, matrix(((misty::chr.omit(p[, grep("ave.pp", names(p))], na.omit = TRUE, check = FALSE) / (1 - misty::chr.omit(p[, grep("ave.pp", names(p))], na.omit = TRUE, check = FALSE))) / (misty::chr.omit(p[, substr(names(p), 1, 1) == "p"], na.omit = TRUE, check = FALSE) / (1 - misty::chr.omit(p[, substr(names(p), 1, 1) == "p"], na.omit = TRUE, check = FALSE)))) |> (\(q) ifelse(is.nan(q), NA, q))() |>
(\(r) if (isTRUE(length(r) != max.class)) { c(r, rep(NA, times = max.class - length(r))) } else { return(r) })(),
ncol = max.class, dimnames = list(NULL, paste0("occ", seq_len(max.class))))))()
}
#···················
#### Means and Variances ####
if (isTRUE(return == "model.descript")) {
# Number of indicators
n.ind <- as.numeric(misty::chr.trim(sub("Number of dependent variables", "", grep("Number of dependent variables", lca.out.extract, value = TRUE, useBytes = TRUE))))
##### Continuous Indicators ####
if (isTRUE(all(lca.out.extract != " Binary and ordered categorical (ordinal)") && all(lca.out.extract != " Unordered categorical (nominal)"))) {
# Split CONFIDEN INTERVALS section
lca.out.extract.ci <- NULL
if (any(grep("CONFIDENCE INTERVALS OF MODEL RESULTS", lca.out.extract))) {
# Output CONFIDENCE INTERVALS OF MODEL RESULTS
lca.out.extract.ci <- lca.out.extract[c(grep("CONFIDENCE INTERVALS OF MODEL RESULTS", lca.out.extract):length(lca.out.extract))]
# Output without CONFIDENCE INTERVALS OF MODEL RESULTS
lca.out.extract <- lca.out.extract[-c(grep("CONFIDENCE INTERVALS OF MODEL RESULTS", lca.out.extract):length(lca.out.extract))]
}
# Extract means
out.means <- lapply(data.frame(sapply(if (isTRUE(nclass == 1L)) { grep("Means", lca.out.extract) } else { head(grep("Means", lca.out.extract), n = -1L) }, function(y) misty::chr.trim(misty::chr.omit(strsplit(lca.out.extract[(y + 1L):(y + n.ind)], " "), omit = "")))),
function(z) data.frame(param = "Mean", matrix(z, ncol = 5L, byrow = TRUE, dimnames = list(NULL, c("ind", "est", "se", "z", "pval"))))) |>
(\(p) do.call(rbind, lapply(seq_along(p), function(y) data.frame(class = y, p[y][[1L]]))))()
# Extract variances
out.var <- lapply(data.frame(sapply(grep("Variances", lca.out.extract), function(y) misty::chr.trim(misty::chr.omit(strsplit(lca.out.extract[(y + 1L):(y + n.ind)], " "), omit = "")))),
function(z) data.frame(param = "Variance", matrix(z, ncol = 5L, byrow = TRUE, dimnames = list(NULL, c("ind", "est", "se", "z", "pval"))))) |>
(\(p) do.call(rbind, lapply(seq_along(p), function(y) data.frame(class = y, p[y][[1L]]))))()
# Class count based on the estimated model
class.count <- matrix(as.numeric(misty::chr.omit(strsplit(lca.out.extract[(grep("BASED ON THE ESTIMATED MODEL", lca.out.extract) + 5L):(grep("BASED ON ESTIMATED POSTERIOR PROBABILITIES", lca.out.extract) - 2L)], " "), "")), ncol = 3, byrow = TRUE)
# Merge means and variances
model.descript <- data.frame(nclass = nclass, n = class.count[match(out.means[, "class"], class.count[, 1L]), 2L], rbind(out.means, out.var))
# Numeric
model.descript[, c("class", "est", "se", "z", "pval")] <- sapply(model.descript[, c("class", "est", "se", "z", "pval")], function(y) as.numeric(gsub("*********", NA, y, fixed = TRUE)))
# Mplus CONFIDENCE INTERVALS section
if (isTRUE(!is.null(lca.out.extract.ci))) {
if (isTRUE(!conf.level %in% c(0.9, 0.95, 0.99))) { stop("Please specifiy 0.9, 0.95, or 0.99 for the argument 'conf.level' when extracting confidence intervals from Mplus outputs.", call. = FALSE) }
lapply(data.frame(sapply(if (isTRUE(nclass == 1L)) { grep("Means", lca.out.extract.ci) } else { head(grep("Means", lca.out.extract.ci), n = -1L) }, function(y) misty::chr.trim(misty::chr.omit(strsplit(lca.out.extract.ci[(y + 1L):(y + n.ind)], " "), omit = "")))),
function(z) data.frame(param = "Mean", matrix(z, ncol = 8L, byrow = TRUE, dimnames = list(NULL, c("ind", "low05", "low25", "low50", "est", "upp50", "upp25", "upp05"))))) |>
(\(p) do.call(rbind, lapply(seq_along(p), function(y) data.frame(class = y, p[y][[1L]]))))() |>
(\(q) switch(as.character(conf.level), "0.99" = {
model.descript[model.descript$param == "Mean", "low"] <<- as.numeric(q[, "low05"])
model.descript[model.descript$param == "Mean", "upp"] <<- as.numeric(q[, "upp05"])
}, "0.95" = {
model.descript[model.descript$param == "Mean", "low"] <<- as.numeric(q[, "low25"])
model.descript[model.descript$param == "Mean", "upp"] <<- as.numeric(q[, "upp25"])
}, "0.9" = {
model.descript[model.descript$param == "Mean", "low"] <<- as.numeric(q[, "low50"])
model.descript[model.descript$param == "Mean", "upp"] <<- as.numeric(q[, "upp50"])
}))()
# No Mplus CONFIDENCE INTERVALS section
} else {
(model.descript$se * qnorm((1 - conf.level) / 2L, lower.tail = FALSE)) |>
(\(p) {
model.descript[model.descript$param == "Mean", "low"] <<- model.descript[model.descript$param == "Mean", "est"] - p[model.descript$param == "Mean"]
model.descript[model.descript$param == "Mean", "upp"] <<- model.descript[model.descript$param == "Mean", "est"] + p[model.descript$param == "Mean"]
})()
}
# Factor
model.descript$class <- factor(model.descript$class)
# Indicator names
model.descript$ind <- sapply(model.descript$ind, function(y) grep(y, unique(misty::chr.trim(gsub(";", "", misty::chr.omit(unlist(strsplit(lca.out.extract[grep("USEVARIABLES", lca.out.extract, ignore.case = TRUE):grep("CLASSES", lca.out.extract, ignore.case = TRUE)[1L]], " ")))))), ignore.case = TRUE, value = TRUE))
# Sort variables
model.descript <- model.descript[, c("nclass", "class", "n", "param", "ind", "est", "se", "z", "pval", "low", "upp")]
##### Ordered-Categorical or Nominal Indicators ####
} else if (isTRUE(any(lca.out.extract == " Binary and ordered categorical (ordinal)") || any(lca.out.extract == " Unordered categorical (nominal)"))) {
# Indicator names
ind.name <- misty::chr.omit(unlist(strsplit(lca.out.extract[which(lca.out.extract %in% c(" Binary and ordered categorical (ordinal)", " Unordered categorical (nominal)"))[1L] + 1L], " ")))
# Extract PROBABILITY SCALE section
lca.out.extract.prob <- lca.out.extract[(grep("RESULTS IN PROBABILITY SCALE", lca.out.extract) + 5L) |> (\(p) p:(which(diff(ifelse(lca.out.extract == "", 1, NA)) == 0L) |> (\(q) q[q > p][1L] )()))()]
# Extract probabilities
out.prob <- lapply(sapply(apply(matrix(which(lca.out.extract.prob == ""), ncol = 2L, byrow = TRUE), 1L, paste, collapse = ":"), function(y) list(lca.out.extract.prob[eval(parse(text = y))])) |>
(\(p) lapply(p, function(z) misty::chr.trim(misty::chr.omit(z))))(), function(w) {
matrix(t(sapply(misty::chr.omit(w, omit = ind.name), function(x) { as.numeric(misty::chr.trim(sub("Category", "", misty::chr.omit(strsplit(x, " "))))) })), ncol = 5L, dimnames = list(NULL, c("categ", "est", "se", "z", "pval"))) |>
(\(r) data.frame(ind = unlist(r[c(which(r[, "categ"] == 1L)[-1] - 1L, nrow(r)), "categ"] |> (\(s) sapply(seq_along(s), function(q) rep(ind.name[q], times = s[q])))()), r))()
}) |> (\(t) do.call(rbind, lapply(seq_along(t), function(y) data.frame(class = y, t[y][[1L]]))))()
# Class count based on the estimated model
class.count <- matrix(as.numeric(misty::chr.omit(strsplit(lca.out.extract[(grep("BASED ON THE ESTIMATED MODEL", lca.out.extract) + 5L):(grep("BASED ON ESTIMATED POSTERIOR PROBABILITIES", lca.out.extract) - 2L)], " "), "")), ncol = 3, byrow = TRUE)
# Merge class counts
model.descript <- data.frame(nclass = nclass, n = class.count[match(out.prob[, "class"], class.count[, 1L]), 2L], out.prob, row.names = NULL)
# Numeric
model.descript[, c("class", "est", "se", "z", "pval")] <- sapply(model.descript[, c("class", "est", "se", "z", "pval")], function(y) as.numeric(gsub("*********", NA, y, fixed = TRUE)))
# Factor
model.descript$class <- factor(model.descript$class)
# Indicator names
model.descript$ind <- sapply(model.descript$ind, function(y) grep(y, unique(misty::chr.trim(gsub(";", "", misty::chr.omit(unlist(strsplit(lca.out.extract[grep("USEVARIABLES", lca.out.extract, ignore.case = TRUE):grep("CLASSES", lca.out.extract, ignore.case = TRUE)[1L]], " ")))))), ignore.case = TRUE, value = TRUE))
# Sort variables
model.descript <- model.descript[, c("nclass", "class", "n", "ind", "categ", "est", "se", "z", "pval")]
}
}
#—————————————————————————————————————— #
### Model Not Converged ####
} else {
model.summary <- data.frame(nclass = nclass, conv = conv, nparam = NA, LL = NA, LL.scale = NA, LL.rep = NA,
aic = NA, caic = NA, bic = NA, sabic = NA, awe = NA, chi.pear = NA, chi.lrt = NA, lmr.lrt = NA, almr.lrt = NA, blrt = NA, entropy = NA)
model.class <- data.frame(nclass = nclass, conv = conv, nparam = NA, entropy = NA)
model.descript <- data.frame(matrix(nrow = 0L, ncol = 9L, dimnames = list(NULL, c("nclass", "n", "class", "param", "ind", "est", "se", "z", "pval"))))
}
return(list(model.summary = model.summary, model.class = model.class, model.descript = model.descript))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.run() function ------------------------------
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions to Identify the Operating System ####
is.windows <- function() {
if (isTRUE(exists("Sys.info"))) {
os <- Sys.info()[["sysname"]]
} else {
os <- .Platform$OS.type
}
os <- tolower(os)
if (isTRUE(grepl("windows", os))) {
return(TRUE)
} else {
return(FALSE)
}
}
is.macos <- function() {
if (isTRUE(exists("Sys.info"))) {
os <- Sys.info()[["sysname"]]
} else {
os <- R.version$os
}
os <- tolower(os)
if (isTRUE(grepl("darwin", os))) {
return(TRUE)
} else {
return(FALSE)
}
}
is.linux <- function() {
if (isTRUE(exists("Sys.info"))) {
os <- Sys.info()[["sysname"]]
} else {
os <- R.version$os
}
os <- tolower(os)
if (isTRUE(grepl("linux", os))) {
return(TRUE)
} else {
return(FALSE)
}
}
os <- function() {
windows <- is.windows()
macos <- is.macos()
linux <- is.linux()
count <- windows + macos + linux
if (isTRUE(count > 1L) || isTRUE(count == 0L)) {
return("unknown")
} else if (windows) {
return("windows")
} else if (macos) {
return("macos")
} else if (linux) {
return("linux")
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Detect the Location/Name of the Mplus Command ####
.detect.mplus <- function() {
ostype <- os()
if (identical(ostype, "windows")) {
suppressWarnings(mplus <- system("where Mplus", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0) && isTRUE(file.exists(mplus))) {
mplus <- "Mplus"
} else {
if (isTRUE(file.exists("C:\\Program Files\\Mplus\\Mplus.exe"))) {
mplus <- "C:\\Program Files\\Mplus\\Mplus.exe"
} else {
suppressWarnings(mplus <- system("where Mpdemo8", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0 && file.exists(mplus))) {
mplus <- "Mpdemo8"
} else {
if (isTRUE(file.exists("C:\\Program Files\\Mplus Demo\\Mpdemo8.exe"))) {
mplus <- "C:\\Program Files\\Mplus Demo\\Mpdemo8.exe"
} else {
note <- paste0(
"Mplus and Mpdemo8 are either not installed or could not be found\n",
"Try installing Mplus or Mplus Demo. If Mplus or Mplus Demo are already installed, \n",
"make sure one can be found on your PATH. The following may help\n\n",
"Windows 10:\n",
" (1) In Search, search for and then select: System (Control Panel)\n",
" (2) Click the Advanced system settings link.\n",
" (3) Click Environment Variables ...\n",
" (4) In the Edit System Variable (or New System Variable ) window,\n",
" (5) specify the value of the PATH environment variable...\n",
" (6) Close and reopen R and run:\n\n",
"mplusAvailable(silent=FALSE)",
"\n")
stop(note)
}
}
}
}
}
if (isTRUE(identical(ostype, "macos"))) {
suppressWarnings(mplus <- system("which mplus", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0 && file.exists(mplus))) {
mplus <- "mplus"
} else {
if (isTRUE(file.exists("/Applications/Mplus/mplus"))) {
mplus <- "/Applications/Mplus/mplus"
} else {
suppressWarnings(mplus <- system("which mpdemo", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0 && file.exists(mplus))) {
mplus <- "mpdemo"
} else {
if (isTRUE(file.exists("/Applications/MplusDemo/mpdemo"))) {
mplus <- "/Applications/MplusDemo/mpdemo"
} else {
stop("mplus and mpdemo not found on the system path or in the 'usual' /Applications/Mplus location. Ensure Mplus or the Mplus Demo are installed and that the location of the command is on your system path.")
}
}
}
}
}
if (isTRUE(identical(ostype, "linux"))) {
failure_note <- paste0(
"Mplus is either not installed or could not be found\n",
"Try installing Mplus or if it already is installed,\n",
"making sure it can be found by adding it to your PATH or adding a symlink\n\n",
"To see directories on your PATH, From a terminal, run:\n\n",
" echo $PATH",
"\n\nthen try something along these lines:\n\n",
" sudo ln -s /path/to/mplus/on/your/system /directory/on/your/PATH",
"\n")
mplus_found <- FALSE
suppressWarnings(mplus <- system("which mplus", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0L && file.exists(mplus))) {
mplus <- "mplus"
mplus_found <- TRUE
} else {
if (isTRUE(dir.exists("/opt/mplus"))) {
test <- file.path(list.dirs("/opt/mplus", recursive = FALSE)[1], "mplus")
if (isTRUE(file.exists(test))) {
mplus <- test
mplus_found <- TRUE
}
} else {
suppressWarnings(mplus <- system("which mpdemo", intern = TRUE, ignore.stderr = TRUE))
if (isTRUE(length(mplus) > 0L && file.exists(mplus))) {
mplus <- "mpdemo"
mplus_found <- TRUE
}
}
}
if (isTRUE(!mplus_found)) { stop(failure_note) }
}
if (isTRUE(identical(ostype, "unknown"))) { stop("OS Type not known. Cannot auto detect Mplus command name. You must specify it.") }
return(mplus)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## convert_to_filelist() ####
convert_to_filelist <- function(target, filefilter = NULL, recursive = FALSE) {
filelist <- c()
for (tt in target) {
fi <- file.info(tt)
if (isTRUE(is.na(fi$size))) { stop("Cannot find target: ", tt) }
if (isTRUE(fi$isdir)) {
directory <- sub("(\\\\|/)?$", "", tt, perl = TRUE)
if (is.windows() && isTRUE(grepl("^[a-zA-Z]:$", directory))) {directory <- paste0(directory, "/") }
if (isTRUE(!file.exists(directory))) stop("Cannot find directory: ", directory)
this_set <- list.files(path = directory, recursive = recursive, pattern = ".*\\.inp?$", full.names = TRUE)
filelist <- c(filelist, this_set)
} else {
if (isTRUE(!grepl(".*\\.inp?$", tt, perl = TRUE))) {
warning("Target: ", tt, "does not appear to be an .inp file. Ignoring it.")
next
} else {
if (isTRUE(!file.exists(tt))) { stop("Cannot find input file: ", tt) }
filelist <- c(filelist, tt)
}
}
}
if (isTRUE(!is.null(filefilter))) filelist <- grep(filefilter, filelist, perl = TRUE, value = TRUE)
filelist <- normalizePath(filelist)
return(filelist)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## splitFilePath() ####
splitFilePath <- function(filepath, normalize = FALSE) {
if (isTRUE(!is.character(filepath))) stop("Path not a character string")
if (isTRUE(nchar(filepath) < 1L || is.na(filepath))) stop("Path is missing or of zero length")
filepath <- sub("(\\\\|/)?$", "", filepath, perl = TRUE)
components <- strsplit(filepath, split="[\\/]")[[1L]]
lcom <- length(components)
stopifnot(lcom > 0L)
relFilename <- components[lcom]
absolute <- FALSE
if (isTRUE(lcom == 1L)) {
dirpart <- NA_character_
} else if (isTRUE(lcom > 1L)) {
components <- components[-lcom]
dirpart <- do.call("file.path", as.list(components))
if (grepl("^([A-Z]{1}:|~/|/|//|\\\\)+.*$", dirpart, perl=TRUE)) absolute <- TRUE
if (normalize) { #convert to absolute path
dirpart <- normalizePath(dirpart)
absolute <- TRUE
}
}
return(list(directory = dirpart, filename = relFilename, absolute = absolute))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus() and mplus.update() function ---------------
# the blimp() and blimp.update() function ---------------
#
# - .extract.section
# Function for Extracting Input Command Sections ####
.extract.section <- function(section, x, section.pos) {
# Sort section position
section.pos <- sort(section.pos)
# Split input
split.x <- strsplit(x, "")[[1L]]
# Start position of the section
start <- setdiff(as.numeric(gregexec(section, toupper(x))[[1L]]),
c(as.numeric(gregexec(paste0("\\.", section), toupper(x))[[1L]]) + 1L, as.numeric(gregexec(paste0("\\_", section), toupper(x))[[1L]]) + 1L, as.numeric(gregexec("SAVEDATA:", toupper(x))[[1L]]) + 4L))
# Multiple sections
if (isTRUE(length(start) > 1L && section != "TEST:")) {
stop(paste0("There are more than one ", dQuote(section), " sections in the input text."), call. = FALSE)
# One section
} else if (isTRUE(length(start) == 1L)) {
# End position of the section
end <- if (isTRUE(any(section.pos > start))) { section.pos[which(section.pos > start)][1L] - 1L } else { length(split.x) }
# Extract section
object <- misty::chr.trim(strsplit(paste(split.x[start:end], collapse = ""), "\n")[1L], side = "right", check = FALSE)
# Remove last "\n"
object[length(object)] <- gsub("\n", "", object[length(object)])
# Collapse with "\n" and return object
object <- paste(object, collapse = "\n")
# Multiple TEST: sections in Blimp
} else if (isTRUE(length(start) > 1L)) {
# End position of the section
end <- sapply(start, function(y) {
if (isTRUE(any(section.pos > y))) { section.pos[which(section.pos > y)][1L] - 1L } else { length(split.x) }
})
# Extract section
object <- sapply(seq_along(start), function(y) {
misty::chr.trim(strsplit(paste(split.x[start[y]:end[y]], collapse = ""), "\n")[1L], side = "right", check = FALSE)
})
# Paste sections
object <- paste(object, collapse = "\n")
}
return(object)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the multilevel.r2() Function —-------------------------
#
# - .variable.section
# - .r2mlm
# - .r2mlm_lmer
# - .r2mlm_nlme
# - .r2mlm_manual
# - .prepare_data
# - .add_interaction_vars_to_data
# - .get_random_slope_vars
# - .get_cwc
# - .get_interaction_vars
# - .sort_variables
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Internal Functions from the r2mlm package ####
#—————————————————————————————————————— #
### .r2mlm() Function ####
.r2mlm <- function(model) {
temp_formula <- formula(model)
grepl_array <- grepl("I(", temp_formula, fixed = TRUE)
for (bool in grepl_array) {
if (isTRUE(bool)) { stop("Error: r2mlm does not allow for models fit using the I() function; user must thus manually include any desired transformed predictor variables such as x^2 or x^3 as separate columns in dataset.") }
}
# call appropriate .r2mlm helper function
if (isTRUE(typeof(model) == "list")) {
.r2mlm_nlme(model)
} else if (isTRUE(typeof(model) == "S4")) {
.r2mlm_lmer(model)
} else {
stop("You must input a model generated using either the lme4 or nlme package.")
}
}
#—————————————————————————————————————— #
### .r2mlm_lmer() Function ####
.r2mlm_lmer <- function(model) {
# R-Squared for more than one cluster variable only available for "NS" using lme4
if (isTRUE(length(names(lme4::getME(model, "flist"))) > 1L)) { stop("This function can only deal with models with a single cluster variable.", call. = FALSE) }
# Visible global function definition
is <- fixef <- getME <- NULL
# Step 1) check if model has_intercept
if (isTRUE(attr(terms(model), which = "intercept") == 1L)) {
has_intercept <- TRUE
} else {
has_intercept <- FALSE
}
# Step 2) Pull all variable names from the formula
all_variables <- all.vars(formula(model))
cluster_variable <- all_variables[length(all_variables)]
# Step 3a) Pull and prepare data
data <- .prepare_data(model, "lme4", cluster_variable)
# Step 3b) Determine whether data is appropriate format
# a) Pull all variables except for cluster
outcome_and_predictors <- all_variables[1L:(length(all_variables) - 1L)]
# b) If any of those variables is non-numeric, then throw an error
for (variable in outcome_and_predictors) {
if (isTRUE(!is(data[[variable]], "integer") && !is(data[[variable]], "numeric"))) {
stop("Your data must be numeric. Only the cluster variable can be a factor.")
}
}
# Step 4a) Define variables you'll be sorting
if (isTRUE(length(outcome_and_predictors) == 1L)) {
predictors <- .get_interaction_vars(model)
} else {
predictors <- append(outcome_and_predictors[2L:length(outcome_and_predictors)], .get_interaction_vars(model))
}
# Step 4b) Create and fill vectors
l1_vars <- .sort_variables(data, predictors, cluster_variable)$l1_vars
l2_vars <- .sort_variables(data, predictors, cluster_variable)$l2_vars
# Step 5) Pull variable names for L1 predictors with random slopes into a variable called random_slope_vars
random_slope_vars <- .get_random_slope_vars(model, has_intercept, "lme4")
# Step 6) Determine value of centered within cluster
if (is.null(l1_vars)) {
centeredwithincluster <- TRUE
} else {
centeredwithincluster <- .get_cwc(l1_vars, cluster_variable, data)
}
# 7a) within_covs (l1 variables)
within <- .get_covs(l1_vars, data)
# 7b) pull column numbers for between_covs (l2 variables)
between <- .get_covs(l2_vars, data)
# 7c) pull column numbers for random_covs (l1 variables with random slopes)
random <- .get_covs(random_slope_vars, data)
# 8a) gamma_w, fixed slopes for L1 variables (from l1_vars list)
gammaw <- c()
i <- 1L
for (variable in l1_vars) {
gammaw[i] <- fixef(model)[variable]
i <- i + 1L
}
# 8b) gamma_b, intercept value if hasintercept = TRUE, and fixed slopes for L2 variables (from between list)
gammab <- c()
if (isTRUE(has_intercept)) {
gammab[1L] <- fixef(model)[1L]
i <- 2L
} else {
i <- 1L
}
for (var in l2_vars) {
gammab[i] <- fixef(model)[var]
i = i + 1L
}
# Step 9) Tau matrix, results from VarCorr(model)
vcov <- VarCorr(model)
tau <- as.matrix(Matrix::bdiag(vcov))
# Step 10) Sigma^2 value, Rij
sigma2 <- getME(model, "sigma")^2L
# Step 11) Input everything into r2mlm_manual
.r2mlm_manual(as.data.frame(data), within_covs = within, between_covs = between, random_covs = random,
gamma_w = gammaw, gamma_b = gammab, Tau = tau, sigma2 = sigma2, has_intercept = has_intercept, clustermeancentered = centeredwithincluster)
}
#—————————————————————————————————————— #
### .r2mlm_nlme() Function ####
.r2mlm_nlme <- function(model) {
# R-Squared for more than one cluster variable only available for "NS" using lme4
if (isTRUE(length(nlme::getGroupsFormula(model, asList = TRUE)) > 1L)) { stop("This function can only deal with models with a single cluster variable.", call. = FALSE) }
# Visible global function definition
is <- getME <- NULL
# Step 1) check if model has_intercept
if (isTRUE(attr(terms(model), which = "intercept") == 1L)) {
has_intercept = TRUE
} else {
has_intercept = FALSE
}
# Step 2) Pull all variable names from the formula
all_variables <- all.vars(formula(model))
cluster_variable <- attr(nlme::getGroups(model), which = "label")
# Add the grouping var to list of all variables, and calculate formula length (for later use, to iterate)
all_variables[length(all_variables) + 1L] <- cluster_variable
formula_length <- length(all_variables) # this returns the number of elements in the all_vars list TODO remove this
# Step 3a) Pull and prepare data
data <- .prepare_data(model, "nlme", cluster_variable)
# Step 3b) Determine whether data is appropriate format. Only the cluster variable can be a factor, for now
outcome_and_predictors <- all_variables[1L:length(all_variables) - 1L]
for (variable in outcome_and_predictors) {
if (isTRUE(!is(data[[variable]], "integer") && !is(data[[variable]], "numeric"))) {
stop("Your data must be numeric. Only the cluster variable can be a factor.")
}
}
# Step 4a) Define variables you'll be sorting
if (isTRUE(length(outcome_and_predictors) == 1L)) {
predictors <- .get_interaction_vars(model)
} else {
predictors <- append(outcome_and_predictors[2:length(outcome_and_predictors)], .get_interaction_vars(model))
}
# Step 4b) Create and fill vectors
l1_vars <- .sort_variables(data, predictors, cluster_variable)$l1_vars
l2_vars <- .sort_variables(data, predictors, cluster_variable)$l2_vars
# Step 5) pull variable names for L1 predictors with random slopes into a variable called random_slope_vars
random_slope_vars <- .get_random_slope_vars(model, has_intercept, "nlme")
# Step 6) determine value of centeredwithincluster
if (isTRUE(is.null(l1_vars))) {
centeredwithincluster <- TRUE
} else {
centeredwithincluster <- .get_cwc(l1_vars, cluster_variable, data)
}
# 7a) within_covs (l1 variables)
within <- .get_covs(l1_vars, data)
# 7b) Pull column numbers for between_covs (l2 variables)
between <- .get_covs(l2_vars, data)
# 7c) Pull column numbers for random_covs (l1 variables with random slopes)
random <- .get_covs(random_slope_vars, data)
# 8a) gamma_w, fixed slopes for L1 variables (from l1_vars list)
gammaw <- c()
i = 1L
for (variable in l1_vars) {
gammaw[i] <- nlme::fixef(model)[variable]
i = i + 1L
}
# 8b) gamma_b, intercept value if hasintercept = TRUE, and fixed slopes for L2 variables (from between list)
gammab <- c()
if (isTRUE(has_intercept)) {
gammab[1L] <- nlme::fixef(model)[1L]
i = 2L
} else {
i = 1L
}
for (variable in l2_vars) {
gammab[i] <- nlme::fixef(model)[variable]
i = i + 1L
}
# Step 9) Tau matrix
tau <- nlme::getVarCov(model)
# Step 10) sigma^2 value, Rij
sigma2 <- model$sigma^2
# Step 11) Input everything into r2mlm_manual
.r2mlm_manual(as.data.frame(data), within_covs = within, between_covs = between, random_covs = random,
gamma_w = gammaw, gamma_b = gammab, Tau = tau, sigma2 = sigma2, has_intercept = has_intercept, clustermeancentered = centeredwithincluster)
}
#—————————————————————————————————————— #
### .r2mlm_manual() Function ####
.r2mlm_manual <- function(data, within_covs, between_covs, random_covs,
gamma_w, gamma_b, Tau, sigma2, has_intercept = TRUE, clustermeancentered = TRUE) {
if (isTRUE(has_intercept)) {
if (isTRUE(length(gamma_b) > 1L)) gamma <- c(1L, gamma_w, gamma_b[2:length(gamma_b)])
if (isTRUE(length(gamma_b) == 1L)) gamma <- c(1L, gamma_w)
if (isTRUE(is.null(within_covs))) gamma_w <- 0L
}
if (isTRUE(!has_intercept)) {
gamma <- c(gamma_w, gamma_b)
if (isTRUE(is.null(within_covs))) gamma_w <- 0L
if (isTRUE(is.null(between_covs))) gamma_b <- 0L
}
if (isTRUE(is.null(gamma))) gamma <- 0L
# Compute phi
phi <- var(cbind(1L, data[, c(within_covs)], data[, c(between_covs)]), na.rm = TRUE)
if (isTRUE(!has_intercept)) phi <- var(cbind(data[, c(within_covs)], data[, c(between_covs)]), na.rm = TRUE)
if (isTRUE(is.null(within_covs) && is.null(within_covs) && !has_intercept)) phi <- 0L
phi_w <- var(data[, within_covs], na.rm = TRUE)
if (isTRUE(is.null(within_covs))) phi_w <- 0L
phi_b <- var(cbind(1L, data[, between_covs]), na.rm = TRUE)
if (isTRUE(is.null(between_covs))) phi_b <- 0L
# Compute psi and kappa
var_randomcovs <- var(cbind(1, data[, c(random_covs)]), na.rm = TRUE)
if (isTRUE(length(Tau) > 1L)) psi <- matrix(c(diag(Tau)), ncol = 1L)
if (isTRUE(length(Tau) == 1L)) psi <- Tau
if (isTRUE(length(Tau) > 1L)) kappa <- matrix(c(Tau[lower.tri(Tau) == TRUE]), ncol = 1)
if (isTRUE(length(Tau) == 1L)) kappa <- 0L
v <- matrix(c(diag(var_randomcovs)), ncol = 1L)
r <- matrix(c(var_randomcovs[lower.tri(var_randomcovs) == TRUE]), ncol = 1L)
if (isTRUE(is.null(random_covs))) {
v <- 0L
r <- 0L
m <- matrix(1L, ncol = 1L)
}
if (isTRUE(length(random_covs) > 0L)) m <- matrix(c(colMeans(cbind(1, data[, c(random_covs)]), na.rm = TRUE)), ncol = 1L)
# Total variance
totalvar_notdecomp <- t(v)%*%psi + 2L*(t(r)%*%kappa) + t(gamma)%*%phi%*%gamma + t(m)%*%Tau%*%m + sigma2
totalwithinvar <- (t(gamma_w)%*%phi_w%*%gamma_w) + (t(v)%*%psi + 2L*(t(r)%*%kappa)) + sigma2
totalbetweenvar <- (t(gamma_b)%*%phi_b%*%gamma_b) + Tau[1L]
totalvar <- totalwithinvar + totalbetweenvar
# Total decomp
decomp_fixed_notdecomp <- (t(gamma)%*%phi%*%gamma) / totalvar_notdecomp
decomp_varslopes_notdecomp <- (t(v)%*%psi + 2L*(t(r)%*%kappa)) / totalvar_notdecomp
decomp_varmeans_notdecomp <- (t(m)%*%Tau%*%m) / totalvar_notdecomp
decomp_sigma_notdecomp <- sigma2/totalvar_notdecomp
decomp_fixed_within <- (t(gamma_w)%*%phi_w%*%gamma_w) / totalvar
decomp_fixed_between <- (t(gamma_b)%*%phi_b%*%gamma_b) / totalvar
decomp_fixed <- decomp_fixed_within + decomp_fixed_between
decomp_varslopes <- (t(v)%*%psi + 2L*(t(r)%*%kappa)) / totalvar
decomp_varmeans <- (t(m)%*%Tau%*%m) / totalvar
decomp_sigma <- sigma2 / totalvar
# Within decomp
decomp_fixed_within_w <- (t(gamma_w)%*%phi_w%*%gamma_w) / totalwithinvar
decomp_varslopes_w <- (t(v)%*%psi + 2L*(t(r)%*%kappa)) / totalwithinvar
decomp_sigma_w <- sigma2 / totalwithinvar
# Between decomp
decomp_fixed_between_b <- (t(gamma_b)%*%phi_b%*%gamma_b) / totalbetweenvar
decomp_varmeans_b <- Tau[1L] / totalbetweenvar
# New measures
if (isTRUE(clustermeancentered)) {
R2_f <- decomp_fixed
R2_f1 <- decomp_fixed_within
R2_f2 <- decomp_fixed_between
R2_fv <- decomp_fixed + decomp_varslopes
R2_fvm <- decomp_fixed + decomp_varslopes + decomp_varmeans
R2_v <- decomp_varslopes
R2_m <- decomp_varmeans
R2_f_w <- decomp_fixed_within_w
R2_f_b <- decomp_fixed_between_b
R2_fv_w <- decomp_fixed_within_w + decomp_varslopes_w
R2_v_w <- decomp_varslopes_w
R2_m_b <- decomp_varmeans_b
}
if (isTRUE(!clustermeancentered)) {
R2_f <- decomp_fixed_notdecomp
R2_fv <- decomp_fixed_notdecomp + decomp_varslopes_notdecomp
R2_fvm <- decomp_fixed_notdecomp + decomp_varslopes_notdecomp + decomp_varmeans_notdecomp
R2_v <- decomp_varslopes_notdecomp
R2_m <- decomp_varmeans_notdecomp
}
if (isTRUE(clustermeancentered)) {
decomp_table <- matrix(c(decomp_fixed_within, decomp_fixed_between, decomp_varslopes, decomp_varmeans, decomp_sigma,
decomp_fixed_within_w, "NA", decomp_varslopes_w, "NA", decomp_sigma_w,
"NA", decomp_fixed_between_b, "NA", decomp_varmeans_b, "NA"), ncol = 3L)
decomp_table <- suppressWarnings(apply(decomp_table, 2, as.numeric))
rownames(decomp_table) <- c("fixed, within", "fixed, between", "slope variation", "mean variation", "sigma2")
colnames(decomp_table) <- c("total", "within", "between")
R2_table <- matrix(c(R2_f1, R2_f2, R2_v, R2_m, R2_f, R2_fv, R2_fvm,
R2_f_w, "NA", R2_v_w, "NA", "NA", R2_fv_w, "NA",
"NA", R2_f_b, "NA", R2_m_b, "NA", "NA", "NA"), ncol = 3L)
R2_table <- suppressWarnings(apply(R2_table, 2, as.numeric)) # make values numeric, not character
rownames(R2_table) <- c("f1", "f2", "v", "m", "f", "fv", "fvm")
colnames(R2_table) <- c("total", "within", "between")
}
if (isTRUE(!clustermeancentered)) {
decomp_table <- matrix(c(decomp_fixed_notdecomp, decomp_varslopes_notdecomp, decomp_varmeans_notdecomp, decomp_sigma_notdecomp), ncol = 1L)
decomp_table <- suppressWarnings(apply(decomp_table, 2L, as.numeric))
rownames(decomp_table) <- c("fixed", "slope variation", "mean variation", "sigma2")
colnames(decomp_table) <- c("total")
R2_table <- matrix(c(R2_f, R2_v, R2_m, R2_fv, R2_fvm), ncol = 1L)
R2_table <- suppressWarnings(apply(R2_table, 2L, as.numeric))
rownames(R2_table) <- c("f", "v", "m", "fv", "fvm")
colnames(R2_table) <- c("total")
}
Output <- list(noquote(decomp_table), noquote(R2_table))
names(Output) <- c("Decompositions", "R2s")
return(Output)
}
#—————————————————————————————————————— #
### .prepare_data() Function ####
.prepare_data <- function(model, calling_function, cluster_variable, second_model = NULL) {
# Step 1a: Pull data frame associated with model
if (isTRUE(calling_function == "lme4")) {
data <- model@frame
} else {
data <- model[["data"]]
}
# Step 2a) pull interaction terms into list
interaction_vars <- .get_interaction_vars(model)
if (isTRUE(!is.null(second_model))) {
interaction_vars_2 <- .get_interaction_vars(second_model)
interaction_vars <- unique(append(interaction_vars, interaction_vars_2))
}
# Step 2b) split interaction terms into halves, multiply halves to create new columns in dataframe
data <- .add_interaction_vars_to_data(data, interaction_vars)
return(data)
}
#—————————————————————————————————————— #
### .add_interaction_vars_to_data() Function ####
.add_interaction_vars_to_data <- function(data, interaction_vars) {
for (whole in interaction_vars) {
half1 <- unlist(strsplit(whole, ":"))[1L]
half2 <- unlist(strsplit(whole, ":"))[2L]
newcol <- data[[half1]] * data[[half2]]
data <- within(data, assign(whole, newcol))
}
return(data)
}
#—————————————————————————————————————— #
### .get_covs() Function ####
.get_covs <- function(variable_list, data) {
cov_list <- c()
i <- 1L
for (variable in variable_list) {
tmp <- match(variable, names(data))
cov_list[i] <- tmp
i <- i + 1L
}
return(cov_list)
}
#—————————————————————————————————————— #
### .get_random_slope_vars() Function ####
.get_random_slope_vars <- function(model, has_intercept, calling_function) {
# Visible global function defnition
ranef <- NULL
if (isTRUE(calling_function == "lme4")) {
temp_cov_list <- ranef(model)[[1L]]
} else if (calling_function == "nlme") {
temp_cov_list <- nlme::ranef(model)
}
if (isTRUE(has_intercept == 1L)) {
running_count <- 2L
} else {
running_count <- 1L
}
random_slope_vars <- c()
x <- 1L
while (running_count <= length(temp_cov_list)) {
random_slope_vars[x] <- names(temp_cov_list[running_count])
x <- x + 1L
running_count <- running_count + 1L
}
return(random_slope_vars)
}
#—————————————————————————————————————— #
### .get_cwc() Function ####
.get_cwc <- function(l1_vars, cluster_variable, data) {
for (variable in l1_vars) {
t <- tapply(data[, variable], data[, cluster_variable], sum, na.rm = TRUE)
temp_tracker <- 0L
# sum all of the sums
for (i in t) { temp_tracker <- temp_tracker + i }
if (abs(temp_tracker) < 0.0000001) {
centeredwithincluster <- TRUE
} else {
centeredwithincluster <- FALSE
break
}
}
return(centeredwithincluster)
}
#—————————————————————————————————————— #
### .get_interaction_vars() Function ####
.get_interaction_vars <- function(model) {
interaction_vars <- c()
x <- 1L
for (term in attr(terms(model), "term.labels")) {
if (isTRUE(grepl(":", term))) {
interaction_vars[x] <- term
x <- x + 1L
}
}
return(interaction_vars)
}
#—————————————————————————————————————— #
### .sort_variables() Function ####
.sort_variables <- function(data, predictors, cluster_variable) {
l1_vars <- c()
l2_vars <- c()
l1_counter <- 1L
l2_counter <- 1L
for (variable in predictors) {
t <- tapply(data[, variable], data[, cluster_variable], var, na.rm = TRUE)
counter <- 1L
while (counter <= length(t)) {
if (is.na(t[[counter]])) { t[[counter]] <- 0L }
counter <- counter + 1L
}
variance_tracker <- 0L
for (i in t) { variance_tracker <- variance_tracker + i }
if (isTRUE(variance_tracker == 0L)) {
l2_vars[l2_counter] <- variable
l2_counter <- l2_counter + 1L
} else {
l1_vars[l1_counter] <- variable
l1_counter <- l1_counter + 1L
}
}
return(list("l1_vars" = l1_vars, "l2_vars" = l2_vars))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the mplus.update() function ---------------------------
#
# - .variable.section
.variable.section <- function(section, input, update) {
# Colon or semicolon position
input.semicol <- misty::chr.grep(c(":", ";"), unlist(strsplit(input, "")))
update.semicol <- misty::chr.grep(c(":", ";"), unlist(strsplit(update, "")))
# Section in update input
if (isTRUE(grepl(section, toupper(update)))) {
# Start and end position of the updated section
start.update <- rev(update.semicol[which(update.semicol < rev(unlist(gregexec(section, toupper(update))))[1L])])[1L] + 1L
end.update <- update.semicol[which(update.semicol > unlist(gregexec(section, toupper(update)))[1L])][1L]
## Subsection is in Input Object
if (isTRUE(grepl(section, toupper(input)))) {
### Start/End Position of the Removal Section
start.inp <- rev(input.semicol[which(input.semicol < rev(unlist(gregexec(section, toupper(input))))[1L])])[1L] + 1L
end.inp <- input.semicol[which(input.semicol > unlist(gregexec(section, toupper(input)))[1L])][1L]
### Insert Updated Sub-Section
input <- sub("...", "",
paste(c(unlist(strsplit(input, ""))[seq_len(start.inp - 1L)], "\n",
unlist(strsplit(update, ""))[start.update:end.update],
if (isTRUE(end.inp != nchar(input))) { unlist(strsplit(input, ""))[((end.inp + 1L):nchar(input))] }),
collapse = ""), fixed = TRUE)
## Subsection is not in Input Object
} else {
input <- sub("...", "", paste(c(input, "\n\n", unlist(strsplit(update, ""))[start.update:end.update]), collapse = ""), fixed = TRUE)
}
}
return(invisible(input))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the na.auxiliary() function ———————————————————————————
.cohens.d.na.auxiliary <- function(formula, data, weighted = TRUE, correct = FALSE) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Formula ####
# Variables
var.formula <- all.vars(as.formula(formula))
# Outcome(s)
y.var <- var.formula[-length(var.formula)]
# Grouping variable
group.var <- var.formula[length(var.formula)]
# Data
data <- as.data.frame(data[, var.formula], stringsAsFactors = FALSE)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Data and Arguments ####
# Outcome
x.dat <- data[, y.var]
# Grouping
group.dat <- data[, group.var]
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Descriptives ####
# Mean difference
x.diff <- diff(tapply(x.dat, group.dat, mean, na.rm = TRUE))
# Sample size by group
n.group <- tapply(x.dat, group.dat, function(y) length(na.omit(y)))
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Standard Deviation ####
# Variance by group
var.group <- tapply(x.dat, group.dat, var, na.rm = TRUE)
# Weighted pooled standard deviation
if (isTRUE(weighted)) {
sd.group <- sqrt(((n.group[1L] - 1L)*var.group[1] + (n.group[2L] - 1L)*var.group[2L]) / (sum(n.group) - 2L))
# Unweighted pooled standard deviation
} else {
sd.group <- sum(var.group) / 2L
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Cohen's d Estimate ####
estimate <- x.diff / sd.group
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Correction Factor ####
# Bias-corrected Cohen's d
if (isTRUE(correct && weighted)) {
v <- sum(n.group) - 2L
# Correction factor based on gamma function
if (isTRUE(sum(n.group) < 200L)) {
corr.factor <- gamma(0.5*v) / ((sqrt(v / 2)) * gamma(0.5 * (v - 1L)))
# Correction factor based on approximation
} else {
corr.factor <- (1L - (3L / (4L * v - 1L)))
}
estimate <- estimate*corr.factor
}
return(estimate)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the multilevel.omega() function ———————————————————————
#
# - .internal.mvrnorm
.internal.mvrnorm <- function (n = 1L, mu, Sigma, tol = 1e-06, empirical = FALSE, EISPACK = FALSE) {
p <- length(mu)
if (isTRUE(!all(dim(Sigma) == c(p, p)))) { stop("incompatible arguments") }
eS <- eigen(Sigma, symmetric = TRUE)
ev <- eS$values
if (isTRUE(!all(ev >= -tol * abs(ev[1L])))) { stop("'Sigma' is not positive definite") }
X <- matrix(rnorm(p * n), n)
X <- drop(mu) + eS$vectors %*% diag(sqrt(pmax(ev, 0L)), p) %*% t(X)
nm <- names(mu)
if (is.null(nm) && !is.null(dn <- dimnames(Sigma))) { nm <- dn[[1L]] }
dimnames(X) <- list(nm, NULL)
if (n == 1L) { drop(X) } else { t(X) }
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the multilevel.r2() function ——————————————————————————
# - .var.random
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Modified Function from the MuMIn Package ####
.var.random <- function(model) {
matmultdiag <- function(x, y, ty = t(y)) { return(rowSums(x * ty)) }
mmRE <- do.call("cbind", suppressWarnings(model.matrix(model, type = "randomListRaw"))) |> (\(p) p[, !duplicated(colnames(p)), drop = FALSE] )()
vc <- unclass(lme4::VarCorr(model))
if(isTRUE(!is.null(vc))) {
varRE <- sum(sapply(vc, function(y) {
mmRE[, rownames(y), drop = FALSE] |> (\(p) sum(matmultdiag(p %*% y, ty = p)) / nrow(mmRE))()
}))
} else {
varRE <- 0L
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the na.test() function ————————————————————————————————
#
# - .LittleMCAR
# - .TestMCARNormality
# - .OrderMissing
# - .DelLessData
# - .Mls
# - .Sexpect
# - .Impute
# - .Mimpute
# - .MimputeS
# - .Hawkins
# - .TestUNey
# - .SimNey
# - .AndersonDarling
#
# BaylorEdPsych:
# https://rdrr.io/cran/BaylorEdPsych/src/R/LittleMCAR.R
#
# MissMech
# https://github.com/cran/MissMech/tree/master/R
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Little's missing completely at random (MCAR) test ####
.LittleMCAR <- function(x) {
n.var <- ncol(x)
r <- 1L * is.na(x)
x.mp <- data.frame(cbind(x, ((r %*% (2L^((seq_len(n.var) - 1L)))) + 1L)))
colnames(x.mp) <- c(colnames(x), "MisPat")
n.mis.pat <- length(unique(x.mp$MisPat))
gmean <- suppressWarnings(mvnmle::mlest(x)$muhat)
gcov <- suppressWarnings(mvnmle::mlest(x)$sigmahat)
colnames(gcov) <- rownames(gcov) <- colnames(x)
x.mp$MisPat2 <- rep(NA, nrow(x))
for (i in seq_len(n.mis.pat)) { x.mp$MisPat2[x.mp$MisPat == sort(unique(x.mp$MisPat), partial = (i))[i]] <- i }
x.mp$MisPat <- x.mp$MisPat2
x.mp <- x.mp[, -which(names(x.mp) %in% "MisPat2")]
datasets <- list()
for (i in seq_len(n.mis.pat)) { datasets[[paste0("DataSet", i)]] <- x.mp[which(x.mp$MisPat == i), seq_len(n.var)] }
kj <- 0L
for (i in seq_len(n.mis.pat)) {
no.na <- as.matrix(1L * !is.na(colSums(datasets[[i]])))
kj <- kj + colSums(no.na)
}
df <- kj - n.var
d2 <- 0L
for (i in seq_len(n.mis.pat)) {
mean <- (colMeans(datasets[[i]]) - gmean)
mean <- mean[!is.na(mean)]
keep <- 1L * !is.na(colSums(datasets[[i]]))
keep <- keep[which(keep[seq_len(n.var)] != 0L)]
cov <- gcov
cov <- cov[which(rownames(cov) %in% names(keep)), which(colnames(cov) %in% names(keep))]
d2 <- as.numeric(d2 + (sum(x.mp$MisPat == i)*(t(mean) %*% solve(cov) %*% mean)))
}
return(list(chi.square = d2, df = df, p.value = 1L - pchisq(d2, df), missing.patterns = n.mis.pat))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Testing Homoscedasticity, Multivariate Normality, and MCAR ####
.TestMCARNormality <- function(data, delete = 6, m = 20, method = "npar", nrep = 10000,
n.min = 30, seed = NULL, pool = "med", impdat = NULL) {
#—————————————————————————————————————— #
### Imputation ####
if (isTRUE(is.null(impdat))) {
# Order missing data pattern
newdata <- .OrderMissing(data, delete)
#—————————————————————————————————————— #
### Imputed Data Provided ####
} else {
# Number of imputations
m <- impdat$m
# Order missing data pattern
newdata <- .OrderMissing(impdat$data[, colnames(data)], delete)
}
#—————————————————————————————————————— #
### Data Check ####
if(isTRUE(length(newdata$data) == 0L)) { stop("There are no cases left after deleting insufficient cases.", call. = FALSE) }
if (isTRUE(newdata$g == 1L)) { stop("There is only one missing data pattern present.", call. = FALSE) }
if (isTRUE(sum(newdata$patcnt == 1L) > 0L)) { stop("At least 2 cases needed in each missing data patterns.", call. = FALSE) }
#—————————————————————————————————————— #
### Extract Data ####
y <- newdata$data
patused <- newdata$patused
patcnt <- newdata$patcnt
spatcnt <- newdata$spatcnt
caseorder <- newdata$caseorder
removedcases <- newdata$removedcases
colnam <- colnames(patused)
n <- nrow(y)
p <- ncol(y)
g <- newdata$g
spatcntz <- c(0L, spatcnt)
pvalsn <- matrix(0L, m, g)
adistar <- matrix(0L, m, g)
pnormality <- c()
x <- vector("list", g)
n4sim <- vector("list", g)
#—————————————————————————————————————— #
### Imputation ####
if (isTRUE(is.null(impdat))) {
# Set seed
if (isTRUE(!is.null(seed))) { set.seed(seed) }
yimp <- y
#...................
#### Non-Parametric ####
if (isTRUE(method == "npar")) {
iscomp <- rowSums(patused, na.rm = TRUE) == p
cind <- which(iscomp)
ncomp <- patcnt[cind]
if (isTRUE(length(ncomp) == 0L)) { ncomp <- 0L }
use.normal <- FALSE
if (isTRUE(ncomp >= 10L && ncomp >= 2L*p)) {
compy <- y[seq(spatcntz[cind] + 1L, spatcntz[cind + 1L]), ]
ybar <- matrix(colMeans(compy))
sbar <- stats::cov(compy)
resid <- (ncomp / (ncomp - 1L))^0.5 * (compy - matrix(ybar, ncomp, p, byrow = TRUE))
} else {
warning("There are not sufficient number of complete cases for non-parametric imputation, imputation method \"normal\" will be used instead.", call. = FALSE)
use.normal <- TRUE
mu <- matrix(0L, p, 1L)
sig <- diag(1L, p)
emest <- .Mls(newdata, mu, sig, 1e-6)
}
#...................
#### Parametric Normal ####
} else {
mu <- matrix(0L, p, 1L)
sig <- diag(1L, p)
emest <- .Mls(newdata, mu, sig, 1e-6)
}
#...................
#### Impute and Analyze ####
for (k in seq_len(m)) {
##### Parametric Normal ####
if (isTRUE(method == "normal" || use.normal)) {
yimp <- .Impute(data = y, emest$mu, emest$sig, method = "normal")
yimp <- yimp$yimpOrdered
##### Non-Parametric ####
} else {
yimp <- .Impute(data = y, ybar, sbar, method = "npar", resid)$yimpOrdered
}
if (isTRUE(k == 1L)) { yimptemp <- yimp }
##### Hawkins Test ####
templist <- .Hawkins(yimp, spatcnt)
fij <- templist$fij
tail <- templist$a
ni <- templist$ni
for (i in seq_len(g)) {
if (isTRUE(ni[i] < n.min && k == 1L)) { n4sim[[i]] <- .SimNey(ni[i], nrep) }
templist <- .TestUNey(tail[[i]], nrep, sim = n4sim[[i]], n.min)
pn <- templist$pn
n4 <- templist$n4
pn <- pn + (pn == 0L) / nrep
pvalsn[k, i] <- pn
}
##### Anderson-Darling Non-Parametric Test ####
if (isTRUE(length(ni) < 2L)) { stop("Not enough groups for Anderson Darling test.", call. = FALSE) }
templist <- .AndersonDarling(fij, ni)
adistar[k, ] <- templist$adk.all
pnormality <- c(pnormality, templist$pn)
}
#—————————————————————————————————————— #
### Imputed Data Provided ####
} else {
for (k in seq_len(m)) {
#...................
#### Hawkins Test ####
templist <- .Hawkins(as.matrix(mice::complete(impdat, action = k)[newdata$caseorder, colnam]), spatcnt)
fij <- templist$fij
tail <- templist$a
ni <- templist$ni
for (i in seq_len(g)) {
if (isTRUE(ni[i] < n.min && k == 1L)) { n4sim[[i]] <- .SimNey(ni[i], nrep) }
templist <- .TestUNey(tail[[i]], nrep, sim = n4sim[[i]], n.min)
pn <- templist$pn
n4 <- templist$n4
pn <- pn + (pn == 0L) / nrep
pvalsn[k, i] <- pn
}
#...................
#### Anderson-Darling Non-Parametric Test ####
if (isTRUE(length(ni) < 2L)) { stop("Not enough groups for Anderson Darling test.", call. = FALSE) }
templist <- .AndersonDarling(fij, ni)
adistar[k, ] <- templist$adk.all
pnormality <- c(pnormality, templist$pn)
}
}
#—————————————————————————————————————— #
### Result Table ####
#### Test Statistics and p-Values ####
ts.hawkins <- -2L * rowSums(log(pvalsn))
p.hawkins <- stats::pchisq(-2L * rowSums(log(pvalsn)), 2L*g, lower.tail = FALSE)
ts.anderson <- rowSums(adistar)
p.anderson <- pnormality
switch(pool,
"m" = {
tsa.hawkins <- mean(ts.hawkins)
pa.hawkins <- mean(p.hawkins)
tsa.anderson <- mean(ts.anderson)
pa.anderson <- mean(p.anderson)
}, "med" = {
tsa.hawkins <- median(ts.hawkins)
pa.hawkins <- median(p.hawkins)
tsa.anderson <- median(ts.anderson)
pa.anderson <- median(p.anderson)
}, "min" = {
tsa.hawkins <- max(ts.hawkins)
pa.hawkins <- min(p.hawkins)
tsa.anderson <- max(ts.anderson)
pa.anderson <- min(p.anderson)
}, "max" = {
tsa.hawkins <- min(ts.hawkins)
pa.hawkins <- max(p.hawkins)
tsa.anderson <- min(ts.anderson)
pa.anderson <- max(p.anderson)
}, "random" = {
ind.hawkins <- sample(seq_along(ts.hawkins), size = 1L)
tsa.hawkins <- ts.hawkins[ind.hawkins]
pa.hawkins <- p.hawkins[ind.hawkins]
ind.anderson <- sample(seq_along(ts.anderson), size = 1L)
tsa.anderson <- ts.anderson[ind.anderson]
pa.anderson <- p.anderson[ind.anderson]
})
#—————————————————————————————————————— #
### Analysis Data ####
if (isTRUE(length(removedcases) == 0L)) {
dataused <- data
} else {
dataused <- data[-1L * removedcases, ]
}
#—————————————————————————————————————— #
### Return Object ####
restab <- list(dat.analysis = dataused, dat.ordered = y, case.order = caseorder, g = g, pattern = patused, n.pattern = patcnt,
t.hawkins = pvalsn, ts.hawkins = ts.hawkins, tsa.hawkins = tsa.hawkins, p.hawkins = p.hawkins, pa.hawkins = pa.hawkins,
t.anderson = adistar, ts.anderson = ts.anderson, tsa.anderson = tsa.anderson, p.anderson = p.anderson, pa.anderson = pa.anderson)
return(restab)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Order Missing Data Pattern ####
.OrderMissing <- function(y, del.lesscases = 0L) {
if (isTRUE(is.data.frame(y))) { y <- as.matrix(y) }
if (isTRUE(!is.matrix(y))) { stop("Data is not a matrix or data frame", call. = FALSE) }
if (isTRUE(length(y) == 0L)) { stop("Data is empty", call. = FALSE) }
names <- colnames(y)
pp <- ncol(y)
yfinal <- c()
patused <- c()
patcnt <- c()
caseorder <- c()
removedcases <- c()
ordertemp <- seq_len(nrow(y))
ntemp <- nrow(y)
ptemp <- ncol(y)
done <- FALSE
yatone <- FALSE
while (isTRUE(!done)) {
pattemp <- is.na(y[1L, ])
indin <- c()
indout <- c()
done <- TRUE
for (i in seq_len(ntemp)) {
if (isTRUE(all(is.na(y[i, ]) == pattemp))) {
indout <- c(indout, i)
} else {
indin <- c(indin, i)
done <- FALSE
}
}
if (isTRUE(length(indin) == 1L)) { yatone <- TRUE }
yfinal <- rbind(yfinal, y[indout, ])
y <- y[indin, ]
caseorder <- c(caseorder, ordertemp[indout])
ordertemp <- ordertemp[indin]
patcnt <- c(patcnt, length(indout))
patused <- rbind(patused, pattemp)
if (isTRUE(yatone)) {
pattemp <- is.na(y)
yfinal <- rbind(yfinal, matrix(y, ncol = pp))
y <- c()
indin <- c()
indout <- c(1L)
caseorder <- c(caseorder, ordertemp[indout])
ordertemp <- ordertemp[indin]
patcnt <- c(patcnt, length(indout))
patused <- rbind(patused, pattemp)
done <- TRUE
}
if (isTRUE(!done)) { ntemp <- nrow(y) }
}
caseorder <- c(caseorder, ordertemp)
patused <- ifelse(patused, NA, 1L)
rownames(patused) <- NULL
colnames(patused) <- names
dataorder <- list(data = yfinal, patused = patused, patcnt = patcnt,
spatcnt = cumsum(patcnt), g = length(patcnt),
caseorder = caseorder, removedcases = removedcases)
dataorder$call <- match.call()
class(dataorder) <- "orderpattern"
if (isTRUE(del.lesscases > 0L)) { dataorder <- .DelLessData(dataorder, del.lesscases) }
dataorder$patused <- matrix(dataorder$patused, ncol = pp)
colnames(dataorder$patused) <- names
return(dataorder)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Removes groups with identical missing data patterns ####
.DelLessData <- function(data, ncases = 0) {
if (isTRUE(length(data) == 0L)) { stop("Data is empty", call. = FALSE) }
if (isTRUE(is.matrix(data))) { data <- .OrderMissing(data) }
ind <- which(data$patcnt <= ncases)
spatcntz <- c(0L, data$spatcnt)
rm <- c()
removedcases <- c()
if (isTRUE(length(ind) != 0L)) {
for (i in seq_len(length(ind))) {
rm <- c(rm, seq(spatcntz[ind[i]] + 1L, spatcntz[ind[i] + 1L]));
}
y <- data$data[-1L * rm, ]
removedcases <- data$caseorder[rm]
patused <- data$patused[-1L * ind, ]
patcnt <- data$patcnt[-1L * ind]
caseorder <- data$caseorder[-1L * rm]
spatcnt <- cumsum(patcnt)
} else {
patused <- data$patused
patcnt <- data$patcnt
spatcnt <- data$spatcnt
caseorder <- data$caseorder
y <- data$data
}
newdata <- list(data = y, patused = patused, patcnt = patcnt,
spatcnt = spatcnt, g = length(patcnt), caseorder = caseorder,
removedcases = removedcases)
class(newdata) <- "orderpattern"
return(newdata)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## ML Estimates of Mean and Covariance Based on Incomplete Data ####
.Mls <- function(data, mu = NA, sig = NA, tol = 1e-6, Hessian = FALSE) {
if (isTRUE(!is.matrix(data) && !inherits(data, "orderpattern"))) { stop("Data must have the classes of matrix or orderpattern.", call. = FALSE) }
if (isTRUE(is.matrix(data))) {
allempty <- which(rowSums(!is.na(data)) == 0L)
if (isTRUE(length(allempty) != 0L)) { data <- data[rowSums(!is.na(data)) != 0L, ] }
data <- .OrderMissing(data)
}
if (isTRUE(inherits(data, "orderpattern"))) {
allempty <- which(rowSums(!is.na(data$data)) == 0L)
if (isTRUE(length(allempty) != 0L)) {
data <- data$data
data <- data[rowSums(!is.na(data)) != 0L, ]
data <- .OrderMissing(data)
}
}
if (isTRUE(length(data$data) == 0L)) { stop("Data is empty", call. = FALSE) }
if (isTRUE(ncol(data$data) < 2L)) { stop("More than one variable is required.", call. = FALSE) }
y <- data$data
patused <- data$patused
spatcnt <- data$spatcnt
if (isTRUE(is.na(mu[1L]))) {
mu <- matrix(0L, ncol(y), 1L)
sig <- diag(1L, ncol(y))
}
itcnt <- 0L
em <- 0L
repeat {
emtemp <- .Sexpect(y, mu, sig, patused, spatcnt)
ysbar <- emtemp$ysbar
sstar <- emtemp$sstar
em <- max(abs(sstar - mu %*% t(mu) - sig), abs(mu - ysbar))
mu <- ysbar
sig <- sstar - mu %*% t(mu)
itcnt <- itcnt + 1L
if (isTRUE(!(em > tol || itcnt < 2L))) break
}
rownames(mu) <- colnames(y)
colnames(sig) <- colnames(y)
if (isTRUE(Hessian)) {
templist <- .Ddf(y, mu, sig)
hessian <- templist$dd
stderror <- templist$se
return (list(mu = mu, sig = sig, hessian = hessian, stderror = stderror, iteration = itcnt))
}
return(list(mu = mu, sig = sig, iteration = itcnt))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.Sexpect <- function(y, mu, sig, patused, spatcnt) {
n <- nrow(y)
pp <- ncol(y)
sstar <- matrix(0L, pp, pp)
ysbar <- matrix(0L, nrow(mu), ncol(mu))
first <- 1L
for (i in seq_len(length(spatcnt))) {
ni <- spatcnt[i] - first + 1L
stemp <- matrix(0L, pp, pp)
indm <- which(is.na(patused[i, ]))
indo <- which(!is.na(patused[i, ]))
yo <- matrix(y[first:spatcnt[i], indo], ni, length(indo))
first <- spatcnt[i] + 1L
muo <- mu[indo]
mum <- mu[indm]
sigoo <- sig[indo, indo]
sigooi <- solve(sigoo)
soo <- t(yo) %*% yo
stemp[indo, indo] <- soo
ystemp <- matrix(0L, ni, pp)
ystemp[, indo] <- yo
if (isTRUE(length(indm)!= 0L)) {
sigmo <- matrix(sig[indm, indo], length(indm), length(indo))
sigmm <- sig[indm, indm]
temp1 <- matrix(mum, ni, length(indm), byrow = TRUE)
temp2 <- yo - matrix(muo, ni, length(indo), byrow = TRUE)
ym <- temp1 + temp2 %*% sigooi %*% t(sigmo)
som <- t(yo) %*% ym
smm <- ni * (sigmm - sigmo %*% sigooi %*% t(sigmo))+ t(ym)%*%ym
stemp[indo, indm] <- som
stemp[indm, indo] <- t(som)
stemp[indm, indm] <- smm
ystemp[, indm] <- ym
}
sstar <- sstar + stemp
if (isTRUE(ni == 1L)) {
ysbar <- t(ystemp) + ysbar
} else {
ysbar <- colSums(ystemp) + ysbar
}
}
ysbar <- (1L / n) * ysbar
sstar <- (1L / n) * sstar
sstar <- (sstar + t(sstar)) / 2L
return(list(ysbar = ysbar, sstar = sstar))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Hessian of the Observed Data ####
.Ddf <- function(data, mu, sig) {
y <- data
n <- nrow(y)
p <- ncol(y)
ns <- p * (p + 1L) / 2L
nparam <- ns + p
ddss <- matrix(0L, ns, ns)
ddmm <- matrix(0L, p, p)
ddsm <- matrix(0L, ns, p)
for (i in seq_len(n)) {
obs <- which(!is.na(y[i, ]))
lo <- length(obs)
tmp <- cbind(rep(obs, 1L, each = lo), rep(obs, lo))
tmp <- matrix(tmp[tmp[, 1L] >= tmp[, 2L], ], ncol = 2L)
lolo = lo*(lo + 1L) / 2L
subsig <- sig[obs, obs]
submu <- mu[obs, ]
temp <- matrix(y[i, obs] - submu, nrow = 1L)
a <- solve(subsig)
b <- a %*% (2L * t(temp) %*% temp - subsig) * a
d <- temp %*% a
ddimm <- 2L * a
ddmm[obs, obs] <- ddmm[obs, obs] + ddimm
rcnt <- 0L
ddism <- matrix(0L, lolo, lo)
for (k in seq_len(lo)) {
for (l in seq_len(k)) {
rcnt <- rcnt + 1L
ccnt <- 0L
for (kk in seq_len(lo)) {
ccnt <- ccnt + 1L
ddism[rcnt, ccnt] <- 2L * (1L - 0.5 * (k == l)) * (a[kk, l] %*% d[k] + a[kk, k] %*% d[l])
}
}
}
for (k in seq_len(lolo)) {
par1 <- tmp[k, 1L] * (tmp[k, 1L] -1L) / 2L + tmp[k, 2L]
for (j in seq_len(lo)) {
ddsm[par1, obs[j]] <- ddsm[par1, obs[j]] + ddism[k, j]
}
}
ssi <- matrix(0L, lolo, lolo)
for (m in seq_len(lolo)) {
u <- which(obs == tmp[m, 1L])
v <- which(obs == tmp[m, 2L])
for (q in seq_len(m)) {
k <- which(obs == tmp[q, 1L])
l <- which(obs == tmp[q, 2L])
ssi[m, q] <- (b[v, k] * a[l, u] + b[v, l] * a[k, u] + b[u, k] * a [l, v] + b[u, l] * a[k, v]) * (1L - 0.5 * (u == v)) * (1L - 0.5 * (k == l))
}
}
for (k in seq_len(lolo)) {
par1 <- tmp[k, 1L] * (tmp[k, 1L] - 1L) / 2L + tmp[k, 2L]
for (l in seq_len(k)) {
par2 <- tmp[l, 1L] * (tmp[l, 1L] - 1L) / 2L + tmp[l, 2L]
ddss[par1, par2] <- ddss[par1, par2] + ssi[k, l]
ddss[par2, par1] <- ddss[par1, par2]
}
}
}
dd <- -1L * rbind(cbind(ddmm, t(ddsm)), cbind(ddsm, ddss)) / 2L
se <- -solve(dd)
return(list(dd = dd, se = se))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Parametric and Non-Parameric Imputation ####
.Impute <- function(data, mu = NA, sig = NA, method = "normal", resid = NA) {
if (isTRUE(!is.matrix(data) && !inherits(data, "orderpattern"))) { stop("Data must have the classes of matrix or orderpattern.", call. = FALSE) }
if (isTRUE(is.matrix(data))) {
allempty <- which(rowSums(!is.na(data)) == 0L)
if (isTRUE(length(allempty) != 0L)) {
data <- data[rowSums(!is.na(data)) != 0L, ]
warning(length(allempty), " Cases with all variables missing have been removed from the data.", call. = FALSE)
}
data <- .OrderMissing(data)
}
if (isTRUE(inherits(data, "orderpattern"))) {
allempty <- which(rowSums(!is.na(data$data)) == 0L)
if (isTRUE(length(allempty) != 0L)) {
data <- data$data
data <- data[rowSums(!is.na(data)) != 0L, ]
warning(length(allempty), " Cases with all variables missing have been removed from the data.", call. = FALSE)
data <- .OrderMissing(data)
}
}
if(isTRUE(length(data$data) == 0L)) { stop("Data is empty", call. = FALSE) }
if (isTRUE(ncol(data$data) < 2L)) { stop("More than one variable is required.", call. = FALSE) }
y <- data$data
patused <- data$patused
spatcnt <- data$spatcnt
patcnt <- data$patcnt
g <- data$g
caseorder <- data$caseorder
spatcntz <- c(0L, spatcnt)
p <- ncol(y)
n <- nrow(y)
yimp <- y
use.normal <- TRUE
#—————————————————————————————————————— #
### Imputation Method: Distribution Free ####
if (isTRUE(method == "npar")) {
if (isTRUE(is.na(mu[1L]))) {
ybar <- matrix(0L, p, 1L)
sbar <- diag(1L, p)
cind <- which(rowSums(patused, na.rm = TRUE) == p)
ncomp <- patcnt[cind]
use.normal <- FALSE
if (isTRUE(ncomp >= 10L && ncomp >= 2L*p)) {
compy <- y[seq(spatcntz[cind] + 1L, spatcntz[cind + 1L]), ]
ybar <- matrix(colMeans(compy))
sbar <- stats::cov(compy)
if (isTRUE(is.na(resid[1L]))) {
resid <- (ncomp / (ncomp - 1)) ^ 0.5 * (compy - matrix(ybar, ncomp, p, byrow = TRUE))
}
} else {
stop("There is not sufficient number of complete cases.\n Dist.free imputation requires a least 10 complete cases\n or 2*number of variables, whichever is bigger.\n", call. = FALSE)
}
}
if (isTRUE(!is.na(mu[1L]))) {
ybar <- mu
sbar <- sig
cind <- which(rowSums(patused, na.rm = TRUE) == p)
ncomp <- patcnt[cind]
use.normal <- FALSE
compy <- y[seq(spatcntz[cind] + 1L, spatcntz[cind + 1L]), ]
if (isTRUE(is.na(resid[1L]))) {
resid <- (ncomp / (ncomp - 1L)) ^ 0.5 * (compy - matrix(ybar, ncomp, p, byrow = TRUE))
}
}
resstar <- resid[sample(ncomp, n - ncomp, replace = TRUE), ]
indres1 <- 1L
for (i in seq_len(g)) {
if (isTRUE(sum(patused[i, ], na.rm = TRUE) != p)) {
test <- y[(spatcntz[i] + 1L) : spatcntz[i + 1L], ]
indres2 <- indres1 + patcnt[i] - 1L
test <- .MimputeS(matrix(test, ncol = p), patused[i, ], ybar, sbar, matrix(resstar[indres1:indres2, ], ncol = p))
indres1 <- indres2 + 1L
yimp[(spatcntz[i] + 1L) : spatcntz[i + 1L], ] <- test
}
}
}
#—————————————————————————————————————— #
### Imputation Method: Norml ####
if (isTRUE(method == "normal" | use.normal)) {
if (isTRUE(is.na(mu[1L]))) {
emest <- .Mls(data, tol = 1e-6)
mu <- emest$mu
sig <- emest$sig
}
for (i in seq_len(g)) {
if (sum(patused[i, ], na.rm = TRUE) != p) {
test <- y[(spatcntz[i] + 1L) : spatcntz[i + 1L], ]
test <- .Mimpute(matrix(test, ncol = p), patused[i, ], mu, sig)
yimp[(spatcntz[i] + 1L) : spatcntz[i + 1L], ] <- test
}
}
}
imputed <- list(yimp = yimp[order(caseorder), ], yimpOrdered = yimp, caseorder = caseorder, patused = patused, patcnt = patcnt)
return(imputed)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.Mimpute <- function(data, patused, mu, sig) {
ni <- nrow(data)
indm <- which(is.na(patused))
indo <- which(!is.na(patused))
pm <- length(indm)
sigmo <- matrix(sig[indm, indo], pm, length(indo))
ss1 <- sigmo %*% solve(sig[indo, indo])
varymiss <- matrix(sig[indm, indm], pm, pm) - ss1 %*% t(sigmo)
if (isTRUE(pm == 1L)) {
a <- sqrt(varymiss)
} else {
svdvar <- svd(varymiss)
a <- diag(sqrt(svdvar$d)) %*% t(svdvar$u)
}
data[, indm] <- matrix(rnorm(ni * pm), ni, pm) %*% a + (matrix(mu[indm], ni, pm, byrow = TRUE) + (data[, indo] - matrix(mu[indo], ni, length(indo), byrow = TRUE)) %*% t(ss1))
return(data)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.MimputeS <- function(data, patused, y1, s1, e) {
ni <- nrow(data)
indm <- which(is.na(patused))
indo <- which(!is.na(patused))
pm <- length(indm)
po <- length(indo)
a <- matrix(s1[indm, indo], pm, po) %*% solve(s1[indo, indo])
zij <- (matrix(y1[indm], ni, pm, byrow = TRUE) + (data[, indo] - matrix(y1[indo], ni, po, byrow = TRUE)) %*% t(a)) + matrix(e[, indm], ni, pm) - matrix(e[, indo], ni, po) %*% t(a)
data[, indm] <- zij
return(data)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Test Statistic for the Hawkins Homoscedasticity Test ####
.Hawkins <- function(y, spatcnt) {
n <- nrow(y)
p <- ncol(y)
g <- length(spatcnt)
spool <- matrix(0L, p, p)
gind <- c(0L, spatcnt)
ygc <- matrix(0L, n, p)
ni <- matrix(0L, g, 1L)
for (i in seq_len(g)) {
yg <- y[seq(gind[i] + 1L, gind[i + 1L]), ]
ni[i] <- nrow(yg)
spool <- spool + (ni[i] - 1L) * stats::cov(yg)
ygmean <- colMeans(yg)
ygc[seq(gind[i] + 1L, gind[i + 1L]), ] <- yg - matrix(ygmean, ni[i], p, byrow = TRUE)
}
spool <- solve(spool / (n - g))
f <- matrix(0L, n, 1L)
nu <- n - g - 1L
a <- vector("list", g)
for (i in seq_len(g)) {
vij <- ygc [seq(gind[i] + 1L, gind[i + 1L]), ]
vij <- rowSums(vij %*% spool * vij)
vij <- vij*ni[i]
f[seq(gind[i] + 1L, gind[i + 1L])] <- ((n - g - p) * vij)/ (p * ((ni[i] - 1L ) * (n - g) - vij))
a[[i]] <- 1L - stats::pf(f[seq(gind[i] + 1L, gind[i + 1L])], p, (nu - p + 1L))
}
return(list(fij = f, a = a, ni = ni))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Test of Goodness of Fit (Uniformity) ####
.TestUNey <- function(x, nrep = 10000, sim = NA, n.min = 30) {
n <- length(x)
pi <- .LegNorm(x)
n4 <- (colSums(pi$p1)^2 + colSums(pi$p2)^2L + colSums(pi$p3)^2L + colSums(pi$p4)^2L) / n
if (isTRUE(n < n.min)) {
if (isTRUE(is.na(sim[1L]))) {
sim <- .SimNey(n, nrep)
}
pn <- length(which(sim > n4)) / nrep
} else {
pn <- stats::pchisq(n4, 4L, lower.tail = FALSE)
}
return(list(pn = pn, n4 = n4))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
.SimNey <- function(n, nrep) {
pi <- .LegNorm(matrix(stats::runif(nrep * n), ncol = nrep))
n4sim <- sort((colSums(pi$p1)^2L + colSums(pi$p2)^2L + colSums(pi$p3)^2L + colSums(pi$p4)^2L) / n )
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Evaluating Legendre's Polynomials of Degree 1, 2, 3, or 4 ####
.LegNorm <- function(x) {
if (isTRUE(!is.matrix(x))) { x <- as.matrix(x) }
x <- 2L * x - 1L
p0 <- matrix(1,nrow(x), ncol(x))
p1 <- x
p2 <- (3L * x * p1 - p0) / 2L
p3 <- (5L * x * p2 - 2L * p1) / 3L
p4 <- (7L * x * p3 - 3L * p2) / 4L
p1 <- sqrt(3L) * p1
p2 <- sqrt(5L) * p2
p3 <- sqrt(7L) * p3
p4 <- 3L * p4
return(list(p1 = p1, p2 = p2, p3 = p3, p4 = p4))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## K-Sample Anderson Darling Test ####
.AndersonDarling <- function(x, ni) {
if (isTRUE(length(ni) < 2L)) { stop("Not enough groups for the Anderson-Darling k-sample test.") }
k <- length(ni)
ni.z <- c(0L, cumsum(ni))
n <- length(x)
x.sort <- sort(x)[seq_len(n - 1L)]
ind <- which(duplicated(x.sort) == 0L)
hj <- (c(ind, length(x.sort) + 1L) - c(0L, ind))[2L:(length(ind) + 1L)]
hn <- cumsum(hj)
zj <- x.sort[ind]
adk <- 0L
adk.all <- matrix(0L, k, 1L)
for (i in seq_len(k)) {
ind <- (ni.z[i] + 1L):ni.z[i + 1L]
templist <- expand.grid(zj, x[ind])
b <- templist[, 1L] == templist[, 2L]
fij <- rowSums(matrix(b, length(zj)))
mij <- cumsum(fij)
num <- (n * mij - ni[i] * hn)^ 2L
dem <- hn*(n - hn)
adk.all[i] <- (1L / ni[i] * sum(hj * (num / dem)))
adk <- adk + adk.all[i]
}
adk <- (1L / n) * adk
adk.all <- adk.all / n
j <- sum(1L / ni)
i <- seq_len(n - 1)
h <- sum(1L / i)
g <- 0L
for (i in seq_len(n - 2L)) { g <- g + (1L / (n - i)) * sum(1L / seq((i + 1L), (n - 1L))) }
a <- (4L * g - 6L) * (k - 1L) + (10L - 6L * g) * j
b <- (2L * g - 4L) * k^2 + 8L * h * k + (2L * g - 14L * h - 4L) * j - 8L * h + 4L * g - 6L
c <- (6L * h + 2L * g - 2L) * k ^ 2L + (4L * h - 4L * g + 6L) * k + (2L * h - 6L) * j + 4L * h
d <- (2L * h + 6L) * k ^ 2L - 4L * h * k
var.adk <- ((a * n^3L) + (b * n^2L) + (c * n) + d) / ((n - 1L) * (n - 2L) * (n - 3L))
if (isTRUE(var.adk < 0L)) { var.adk <- 0L }
adk.s <- (adk - (k - 1L)) / sqrt(var.adk)
a0 <- c(0.25, 0.10, 0.05, 0.025, 0.01)
b0 <- c(0.675, 1.281, 1.645, 1.96, 2.326)
b1 <- c(-0.245, 0.25, 0.678, 1.149, 1.822)
b2 <- c(-0.105, -0.305, -0.362, -0.391, -0.396)
c0 <- log((1L - a0) / a0)
qnt <- b0 + b1 / sqrt(k - 1L) + b2 / (k - 1L)
if (isTRUE(adk.s <= qnt[3L])) {
ind <- 1L:4L
} else {
ind <- 2L:5L
}
return(list(pn = 1L / (1L + exp(stats::spline(qnt[ind], c0[ind], xout = adk.s)$y)), adk.all = adk.all, adk = adk, var.adk = var.adk))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the print.misty.object() function ---------------------
#
# - .round
# - .write.table
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .round ####
.round <- function(x, digits) {
#—————————————————————————————————————— #
### One Variable ####
if (isTRUE(is.null(dim(x)))) {
if (isTRUE(digits > 0)) {
formatC(sapply(x, function(y) ifelse(is.na(y), NA, ifelse(is.character(y) && misty::chr.trim(y) == "NA", "NA", as.numeric(y)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f", zero.print = paste0("0.", paste(rep(0L, times = digits), collapse = "")))
} else {
formatC(sapply(x, function(y) ifelse(is.na(y), NA, ifelse(is.character(y) && misty::chr.trim(y) == "NA", "NA", as.numeric(y)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f")
}
#—————————————————————————————————————— #
### More Than One Variable ####
} else {
object <- apply(x, 2L, function(y) {
if (isTRUE(digits > 0)) {
formatC(sapply(y, function(z) ifelse(is.na(z), NA, ifelse(is.character(z) && misty::chr.trim(z) == "NA", "NA", as.numeric(z)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f", zero.print = paste0("0.", paste(rep(0L, times = digits), collapse = "")))
} else {
formatC(sapply(y, function(z) ifelse(is.na(z), NA, ifelse(is.character(z) && misty::chr.trim(z) == "NA", "NA", as.numeric(z)))) |> (\(p) if (isTRUE(all(is.na(p)))) { rep("NA", times = length(p)) } else { p })(), digits = digits, format = "f")
}
}, simplify = ifelse(is.data.frame(x), FALSE, TRUE)) |> (\(p) if (isTRUE(is.data.frame(x))) { as.data.frame(p) } else { p })()
if (isTRUE(!is.null(row.names(x)))) { row.names(object) <- row.names(x) }
return(object)
}
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## .write.table ####
.write.table <- function(print.object, left = 1L, right = 3L, line = 1L, group = FALSE, result = NULL, horiz = TRUE) {
# Data frame
print.object <- as.data.frame(print.object)
#—————————————————————————————————————— #
### Markdown knitr Engine Not in Progress ####
if (isTRUE(is.null(getOption("knitr.in.progress")) && horiz)) {
# Header
write.table(print.object[seq_len(line), , drop = FALSE], quote = FALSE, row.names = FALSE, col.names = FALSE)
#···················
#### Grouping Variable ####
if (isTRUE(group)) {
split(print.object[-1L, ], f = result$group) |>
(\(p) for (i in seq_along(p)) {
# Horizontal line
cat(paste(rep(" ", times = left), collapse = ""), paste(rep("\u2500", times = sum(nchar(print.object[1L, ])) + length(print.object[1L, ]) - right), collapse = ""), "\n")
write.table(p[[i]], quote = FALSE, row.names = FALSE, col.names = FALSE)
})()
#···················
#### No Grouping Variable ####
} else {
# Horizontal line
cat(paste(rep(" ", times = left), collapse = ""), paste(rep("\u2500", times = sum(nchar(print.object[max(seq_len(line)), ])) + length(print.object[max(seq_len(line)), ]) - right), collapse = ""), "\n")
# Output not including 'Total'
if (isTRUE(all(misty::chr.trim(print.object[, 1L]) != "Total") && (if (isTRUE(misty::chr.trim(print.object[1L, 2L]) == "Source")) { all(misty::chr.trim(print.object[, 2L]) != "Total") } else { TRUE }))) {
write.table(print.object[-seq_len(line), ], quote = FALSE, row.names = FALSE, col.names = FALSE)
# Output including 'Total', e.g, crosstab(), dominance.manual(), and dominance() functions
} else {
(which(misty::chr.trim(print.object[, ifelse(isTRUE(misty::chr.trim(print.object[1L, 2L]) != "Source"), 1L, 2L)]) == "Total") - 1L) |>
(\(p) {
write.table(print.object[(max(seq_len(line)) + 1L):p, ], quote = FALSE, row.names = FALSE, col.names = FALSE)
# Horizontal line
cat(paste(rep(" ", times = left), collapse = ""), paste(rep("\u2500", times = sum(nchar(print.object[max(seq_len(line)), ])) + length(print.object[max(seq_len(line)), ]) - right), collapse = ""), "\n")
write.table(print.object[-seq_len(p), ], quote = FALSE, row.names = FALSE, col.names = FALSE)
})()
}
}
#—————————————————————————————————————— #
### Markdown knitr Engine in Progress ####
} else {
write.table(print.object, quote = FALSE, row.names = FALSE, col.names = FALSE)
}
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the robust.coef() function ----------------------------
#
# - .sandw
# - .coeftest
# - .waldtest
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Making Sandwiches with Bread and Meat ####
.sandw <- function(x, type = c("HC0", "HC1", "HC2", "HC3", "HC4", "HC4m", "HC5")) {
# Hat values
diaghat <- try(hatvalues(x), silent = TRUE)
# Specify omega function
switch(type,
const = { omega <- function(residuals, diaghat, df) rep(1, length(residuals)) * sum(residuals^2L) / df },
HC0 = { omega <- function(residuals, diaghat, df) residuals^2L },
HC1 = { omega <- function(residuals, diaghat, df) residuals^2L * length(residuals)/df },
HC2 = { omega <- function(residuals, diaghat, df) residuals^2L / (1L - diaghat) },
HC3 = { omega <- function(residuals, diaghat, df) residuals^2L / (1L - diaghat)^2L },
HC4 = { omega <- function(residuals, diaghat, df) {
n <- length(residuals)
p <- as.integer(round(sum(diaghat), digits = 0L))
delta <- pmin(4L, n * diaghat/p)
residuals^2L / (1L - diaghat)^delta
}},
HC4m = { omega <- function(residuals, diaghat, df) {
gamma <- c(1.0, 1.5) ## as recommended by Cribari-Neto & Da Silva
n <- length(residuals)
p <- as.integer(round(sum(diaghat)))
delta <- pmin(gamma[1L], n * diaghat/p) + pmin(gamma[2L], n * diaghat/p)
residuals^2L / (1L - diaghat)^delta
}},
HC5 = { omega <- function(residuals, diaghat, df) {
k <- 0.7 ## as recommended by Cribari-Neto et al.
n <- length(residuals)
p <- as.integer(round(sum(diaghat)))
delta <- pmin(n * diaghat / p, pmax(4L, n * k * max(diaghat) / p))
residuals^2L / sqrt((1L - diaghat)^delta)
}})
if (isTRUE(type %in% c("HC2", "HC3", "HC4", "HC4m", "HC5"))) {
if (isTRUE(inherits(diaghat, "try-error"))) stop(sprintf("hatvalues() could not be extracted successfully but are needed for %s", type), call. = FALSE)
id <- which(diaghat > 1L - sqrt(.Machine$double.eps))
if(length(id) > 0L) {
id <- if (isTRUE(is.null(rownames(X)))) { as.character(id) } else { rownames(X)[id] }
if(length(id) > 10L) id <- c(id[1L:10L], "...")
warning(sprintf("%s covariances become numerically unstable if hat values are close to 1 as for observations %s", type, paste(id, collapse = ", ")), call. = FALSE)
}
}
# Ensure that NAs are omitted
if(is.list(x) && !is.null(x$na.action)) class(x$na.action) <- "omit"
# Extract design matrix
X <- model.matrix(x)
if (isTRUE(any(alias <- is.na(coef(x))))) X <- X[, !alias, drop = FALSE]
# Number of observations
n <- NROW(X)
# Generalized Linear Model
if (isTRUE(inherits(x, "glm"))) {
wres <- as.vector(residuals(x, "working")) * weights(x, "working")
dispersion <- if (isTRUE(substr(x$family$family, 1L, 17L) %in% c("poisson", "binomial", "Negative Binomial"))) { 1L } else { sum(wres^2L, na.rm = TRUE) / sum(weights(x, "working"), na.rm = TRUE) }
ef <- wres * X / dispersion
# Linear Model
} else {
# Weights
wts <- if (isTRUE(is.null(weights(x)))) { 1L } else { weights(x) }
ef <- as.vector(residuals(x)) * wts * X
}
# Meat
meat <- crossprod(sqrt(omega(rowMeans(ef / X, na.rm = TRUE), diaghat, n - NCOL(X))) * X) / n
# Bread
sx <- summary.lm(x)
bread <- sx$cov.unscaled * as.vector(sum(sx$df[1L:2L]))
# Sandwich
sandw <- 1L / n * (bread %*% meat %*% bread)
return(invisible(sandw))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Inference for Estimated Coefficients ####
.coeftest <- function(x, vcov = NULL) {
# Extract coefficients and standard errors
est <- coef(x)
se <- sqrt(diag(vcov))
## match using names and compute t/z statistics
if (isTRUE(!is.null(names(est)) && !is.null(names(se)))) {
if (length(unique(names(est))) == length(names(est)) && length(unique(names(se))) == length(names(se))) {
anames <- names(est)[names(est) %in% names(se)]
est <- est[anames]
se <- se[anames]
}
}
# Test statistic
stat <- as.vector(est) / se
df <- try(df.residual(x), silent = TRUE)
# Generalized Linear Model
if (isTRUE(inherits(x, "glm"))) {
pval <- 2L * pnorm(abs(stat), lower.tail = FALSE)
cnames <- c("Estimate", "SE", "z", "p")
mthd <- "z"
# Linear Model
} else {
pval <- 2L * pt(abs(stat), df = df, lower.tail = FALSE)
cnames <- c("Estimate", "SE", "t", "p")
mthd <- "t"
}
object <- cbind(est, se, stat, pval)
colnames(object) <- cnames
return(invisible(object))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Wald Test of Nested Models ####
.waldtest <- function(object, ..., vcov = NULL, name = NULL) {
coef0 <- function(x, ...) { na.omit(coef(x, ...)) }
nobs0 <- function(x, ...) {
nobs1 <- nobs
nobs2 <- function(x, ...) { NROW(residuals(x, ...)) }
object <- try(nobs1(x, ...), silent = TRUE)
if (isTRUE(inherits(object, "try-error") | is.null(object))) object <- nobs2(x, ...)
return(object)
}
df.residual0 <- function(x) {
df <- try(df.residual(x), silent = TRUE)
if (isTRUE(inherits(df, "try-error") | is.null(df))) { df <- try(nobs0(x) - attr(logLik(x), "df"), silent = TRUE) }
if (isTRUE(inherits(df, "try-error") | is.null(df))) { df <- try(nobs0(x) - length(as.vector(coef0(x))), silent = TRUE) }
if (isTRUE(inherits(df, "try-error"))) df <- NULL
return(df)
}
cls <- class(object)[1L]
# 1. Extracts term labels
tlab <- function(x) {
tt <- try(terms(x), silent = TRUE)
if (isTRUE(inherits(tt, "try-error"))) "" else attr(tt, "term.labels")
}
# 2. Extracts model name
if (isTRUE(is.null(name))) name <- function(x) {
object <- try(formula(x), silent = TRUE)
if (isTRUE(inherits(object, "try-error") | is.null(object))) { object <- try(x$call, silent = TRUE) }
if (isTRUE(inherits(object, "try-error") | is.null(object))) { return(NULL) } else { return(paste(deparse(object), collapse="\n")) }
}
# 3. Compute an updated model object
modelUpdate <- function(fm, update) {
if (isTRUE(is.numeric(update))) {
if (isTRUE(any(update < 1L))) {
warning("For numeric model specifications all values have to be >= 1", call. = FALSE)
update <- abs(update)[abs(update) > 0L]
}
if (isTRUE(any(update > length(tlab(fm))))) {
warning(paste("More terms specified than existent in the model:", paste(as.character(update[update > length(tlab(fm))]), collapse = ", ")), call. = FALSE)
update <- update[update <= length(tlab(fm))]
}
update <- tlab(fm)[update]
}
if (isTRUE(is.character(update))) {
if (isTRUE(!all(update %in% tlab(fm)))) {
warning(paste("Terms specified that are not in the model:", paste(dQuote(update[!(update %in% tlab(fm))]), collapse = ", ")), call. = FALSE)
update <- update[update %in% tlab(fm)]
}
if (isTRUE(length(update) < 1L)) { stop("Empty model specification", call. = FALSE) }
update <- as.formula(paste(". ~ . -", paste(update, collapse = " - ")))
}
if (isTRUE(inherits(update, "formula"))) {
update <- update(fm, update, evaluate = FALSE)
update <- eval(update, parent.frame(3))
}
if (isTRUE(!inherits(update, cls))) { stop(paste("Original model was of class \"", cls, "\", updated model is of class \"", class(update)[1], "\"", sep = ""), call. = FALSE) }
return(update)
}
# 4. Compare two fitted model objects
modelCompare <- function(fm, fm.up, vfun = NULL) {
q <- length(coef0(fm)) - length(coef0(fm.up))
if (isTRUE(q > 0L)) {
fm0 <- fm.up
fm1 <- fm
} else {
fm0 <- fm
fm1 <- fm.up
}
k <- length(coef0(fm1))
n <- nobs0(fm1)
# Determine omitted variables
if (isTRUE(!all(tlab(fm0) %in% tlab(fm1)))) { stop("Nesting of models cannot be determined", call. = FALSE) }
ovar <- which(!(names(coef0(fm1)) %in% names(coef0(fm0))))
if (isTRUE(abs(q) != length(ovar))) { stop("Nesting of models cannot be determined", call. = FALSE) }
# Get covariance matrix estimate
vc <- if (isTRUE(is.null(vfun))) { vcov(fm1) } else if (isTRUE(is.function(vfun))) { vfun(fm1) } else { vfun }
## Compute Chisq statistic
stat <- t(coef0(fm1)[ovar]) %*% solve(vc[ovar,ovar]) %*% coef0(fm1)[ovar]
return(c(-q, stat))
}
# Recursively fit all objects
objects <- list(object, ...)
nmodels <- length(objects)
if (isTRUE(nmodels < 2L)) {
objects <- c(objects, . ~ 1)
nmodels <- 2L
}
# Remember which models are already fitted
no.update <- sapply(objects, function(obj) inherits(obj, cls))
# Updating
for(i in 2L:nmodels) objects[[i]] <- modelUpdate(objects[[i - 1L]], objects[[i]])
# Check responses
getresponse <- function(x) {
tt <- try(terms(x), silent = TRUE)
if (isTRUE(inherits(tt, "try-error"))) { "" } else { deparse(tt[[2L]]) }
}
responses <- as.character(lapply(objects, getresponse))
sameresp <- responses == responses[1L]
if (isTRUE(!all(sameresp))) {
objects <- objects[sameresp]
warning("Models with response ", deparse(responses[!sameresp]), " removed because response differs from ", "model 1", call. = FALSE)
}
# Check sample sizes
ns <- sapply(objects, nobs0)
if (isTRUE(any(ns != ns[1L]))) {
for(i in 2L:nmodels) {
if (isTRUE(ns[1L] != ns[i])) {
if (isTRUE(no.update[i])) { stop("Models were not all fitted to the same size of dataset")
} else {
commonobs <- row.names(model.frame(objects[[i]])) %in% row.names(model.frame(objects[[i - 1L]]))
objects[[i]] <- eval(substitute(update(objects[[i]], subset = commonobs), list(commonobs = commonobs)))
if (isTRUE(nobs0(objects[[i]]) != ns[1L])) { stop("Models could not be fitted to the same size of dataset", call. = FALSE) }
}
}
}
}
# ANOVA matrix
object <- matrix(rep(NA, 4L * nmodels), ncol = 4L)
colnames(object) <- c("res.df", "df", "F", "p")
rownames(object) <- 1L:nmodels
object[, 1L] <- as.numeric(sapply(objects, df.residual0))
for(i in 2L:nmodels) object[i, 2L:3L] <- modelCompare(objects[[i - 1L]], objects[[i]], vfun = vcov)
df <- object[, 1L]
for(i in 2L:nmodels) if (isTRUE(object[i, 2L] < 0L)) { df[i] <- object[i - 1L, 1L] }
object[, 3L] <- object[, 3L] / abs(object[, 2L])
object[, 4L] <- pf(object[, 3L], abs(object[, 2L]), df, lower.tail = FALSE)
variables <- lapply(objects, name)
if (isTRUE(any(sapply(variables, is.null)))) { variables <- lapply(match.call()[-1L], deparse)[1L:nmodels] }
return(invisible(object))
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Functions for the sim.lavaan() function -----------------------------
#
# https://github.com/wjschne/simstandard/blob/main/R/main.R
#
# .sim.standardized.matrices
# .str.affix
# .fixed2free
#
# https://github.com/cran/mvtnorm/blob/master/R/mvnorm.R
#
# .rmvnorm
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Returning Model Characteristics ####
.sim.standardized.matrices <- function(model, max.iter = max.iter, check = check) {
#—————————————————————————————————————— #
### Parameter Table ####
pt <- lavaan::lavParTable(model, fixed.x = FALSE)
#—————————————————————————————————————— #
### Checks ####
if (isTRUE(check)) {
# Check for formative variables
if (isTRUE(any(pt$op == "<~"))) { stop("Formative variables (defined with <~) are not allowed for this function.", call. = FALSE) }
# Check for user-set variances
if (isTRUE(any((pt$user != 0L) & (pt$lhs == pt$rhs) & (pt$op == "~~")))) {
pt_manual_var <- pt[(pt$user != 0L) & (pt$lhs == pt$rhs) & (pt$op == "~~"), ]
pt_manual_rows <- paste0(pt_manual_var$lhs, " ", pt_manual_var$op, " ", ifelse(is.na(pt_manual_var$ustart), "", paste0(pt_manual_var$ustart, " * ")), pt_manual_var$rhs, collapse = "\n")
stop(paste0("All variances are set automatically to create standardized data.", " You may not set variances manually. ", ifelse(nrow(pt_manual_var) > 1L, "Remove the following parameters:\n", "Remove the following parameter:\n"), pt_manual_rows), call. = FALSE)
}
# Check for unset paths and covariances
if (isTRUE(any(pt$free == 1L, na.rm = TRUE))) {
pt_unset <- pt[pt$free == 1L, ]
pt_unset_rows <- paste0(pt_unset$lhs, " ", pt_unset$op, " ", pt_unset$rhs, collapse = "\n")
warning(paste0(ifelse(nrow(pt_unset) > 1L, paste0("Because the following relations were not set, ", "they are assumed to be 0:\n"), paste0("Because the following relationship was not set, ", "it is assumed to be 0:\n")), pt_unset_rows), call. = FALSE)
}
# Check for paths greater than 1
if (isTRUE(any(abs(pt$ustart) > 1L, na.rm = TRUE))) {
pt_greater <- pt[abs(pt$ustart) > 1L, ]
pt_greater_rows <- paste0(pt_greater$lhs, " ", pt_greater$op, " ", pt_greater$ustart, " * ", pt_greater$rhs, collapse = "\n" )
warning(paste0("It is possible to set standardized parameters ",
"greater than 1 or less than -1, but this may causes model convergence problems. ",
"Check to make sure you set such a value on purpose. ",
ifelse(nrow(pt_greater) > 1L, "The following paths were set to values outside the range of -1 to 1:\n", "The following path was set to a value outside the range of -1 to 1:\n"), pt_greater_rows), call. = FALSE)
}
}
#—————————————————————————————————————— #
### Variable Names ####
v_all <- unique(c(pt$lhs, pt$rhs))
v_latent <- unique(pt$lhs[pt$op == "=~"])
v_observed <- v_all[!(v_all %in% v_latent)]
v_indicator <- unique(pt$rhs[pt$op == "=~"])
v_y <- unique(pt$lhs[pt$op == "~"])
v_latent_endogenous <- v_latent[(v_latent %in% v_y) | (v_latent %in% v_indicator)]
v_latent_exogenous <- v_latent[!(v_latent %in% v_latent_endogenous)]
v_observed_endogenous <- v_observed[v_observed %in% v_y | v_observed %in% v_indicator]
v_observed_exogenous <- v_observed[!v_observed %in% v_observed_endogenous]
v_observed_indicator <- v_observed[v_observed %in% v_indicator]
v_latent_indicator <- v_latent[v_latent %in% v_indicator]
v_observed_y <- v_observed_endogenous[!(v_observed_endogenous %in% v_observed_indicator)]
v_order <- c(v_observed, v_latent)
v_error_y <- .str.affix(v_observed_y, prefix = "e_")
v_disturbance <- .str.affix(v_latent_endogenous, prefix = "d_")
v_error <- .str.affix(v_observed_endogenous, prefix = "e_")
v_exogenous <- c(v_latent_exogenous, v_observed_exogenous)
v_endogenous <- c(v_latent_endogenous, v_observed_endogenous)
v_residual <- c(v_disturbance, v_error)
v_ellipse <- c(v_latent, v_residual)
v_source <- c(v_exogenous, v_residual)
v_factor_score <- v_ellipse[!(v_ellipse %in% v_error_y)]
v_FS <- .str.affix(v_factor_score, suffix = "_FS")
# Set unspecified parameters to 0
pt[is.na(pt[, "ustart"]), "ustart"] <- 0L
#—————————————————————————————————————— #
### Make RAM Matrices ####
# Names for A, S and new S matrices
vS <- vA <- c(v_endogenous, v_exogenous)
# Number of Variables
k <- length(vA)
# Initialize A matrix and exogenous correlation matrix
exo_cor <- A <- matrix(0L, k, k, dimnames = list(vA, vA))
# Assign loadings to A
for (i in pt[pt[, "op"] == "=~", "id"]) { A[pt$rhs[i], pt$lhs[i]] <- pt$ustart[i] }
# Assign regressions to A
for (i in pt[pt[, "op"] == "~", "id"]) { A[pt$lhs[i], pt$rhs[i]] <- pt$ustart[i] }
# Assign correlations to exo_cor
diag(exo_cor) <- 1L
for (i in pt[(pt[, "op"] == "~~") & pt$lhs != pt$rhs, "id"]) {
exo_cor[pt$lhs[i], pt$rhs[i]] <- pt$ustart[i]
exo_cor[pt$rhs[i], pt$lhs[i]] <- pt$ustart[i]
}
#—————————————————————————————————————— #
### Solving for Error Variances and Correlation Matrix ####
# Column of k ones
v1 <- matrix(1L, k)
# Initial estimate of error variances
varS <- as.vector(v1 - (A * A) %*% v1)
S <- diag(varS) %*% exo_cor %*% diag(varS)
# Initial estimate of the correlation matrix
iA <- solve(diag(k) - A)
R <- iA %*% S %*% t(iA)
# Set interaction count at 0
iterations <- 0L
# Find values for S matrix
while ((round(sum(diag(R)), digits = 10) != k) * (iterations < max.iter)) {
R <- iA %*% S %*% t(iA)
sdS <- diag(diag(S) ^ 0.5)
S <- diag(diag(diag(k) - R)) + (sdS %*% exo_cor %*% sdS)
diag(S)[diag(S) < 0] <- 0.00000001
iterations <- iterations + 1L
}
if (iterations >= max.iter) { stop(paste0("Model did not converge after ", max.iter, " iterations because at least one variable had a negative variance: ", paste0(colnames(A)[(diag(S) == 0.00000001)], collapse = ", ")), call. = FALSE) }
dimnames(S) <- dimnames(A)
# Filter Matrix
filter_matrix <- diag((vA %in% v_observed) * 1L)
dimnames(filter_matrix) <- dimnames(A)
# Big Matrices----
A_residual_diag <- sqrt(diag(S[v_endogenous, v_endogenous, drop = FALSE]))
if (isTRUE(length(A_residual_diag) > 1L)) {
A_residual <- diag(A_residual_diag)
} else {
if (length(A_residual_diag) == 1) {
A_residual <- matrix(A_residual_diag, nrow = 1L, ncol = 1L)
} else {
A_residual <- matrix(nrow = 0L, ncol = 0L)
}
}
A_big <- rbind(cbind(A[v_endogenous, , drop = FALSE], A_residual), matrix(0L, nrow = nrow(A), ncol = nrow(A) + length(v_residual)))
v_big <- c(vA, v_residual)
dimnames(A_big) <- list(v_big, v_big)
# Initialize S_big
S_big <- matrix(0L, nrow = length(v_big), ncol = length(v_big), dimnames = dimnames(A_big) )
# Insert off-diagonal values of S into S_big
S_big[v_source, v_source] <- exo_cor[c(v_exogenous, v_endogenous), c(v_exogenous, v_endogenous), drop = FALSE]
# Insert diagonal values of S_big
diag(S_big) <- c(rep(0L, length(v_endogenous)), rep(1L, length(v_exogenous) + length(v_residual)))
# Compute big correlation matrix of all variables
iA_big <- solve(diag(nrow(A_big)) - A_big)
R_big <- iA_big %*% S_big %*% t(iA_big)
R_xx <- R_big[v_observed_indicator, v_observed_indicator, drop = FALSE]
R_xy <- R_big[v_observed_indicator, v_factor_score, drop = FALSE]
#—————————————————————————————————————— #
### Factor and Composite Scores ####
if (isTRUE(length(v_observed_indicator) > 0L)) {
i_Rxx <- solve(R_xx)
A_factor_score <- i_Rxx %*% R_xy
colnames(A_factor_score) <- v_factor_score
if (isTRUE(length(v_latent) > 0L)) {
v_composite_score <- paste0(v_latent, "_Composite")
} else {
v_composite_score <- character(0L)
}
# Matrix of which observed variables are summed to create composite scores for each latent variable
A_composite <- matrix(0L, nrow = length(v_observed_indicator), ncol = length(v_latent), dimnames = list(v_observed_indicator, v_latent))
find_observed_indicators <- function(v) {
indicators <- pt[pt[,"op"] == "=~" & pt[,"lhs"] == v, "rhs"]
observed_indicators <- indicators[indicators %in% v_observed_indicator]
latent_indicators <- indicators[indicators %in% v_latent]
if (length(latent_indicators > 0)) {
for (li in latent_indicators) {
observed_indicators <- c(observed_indicators,find_observed_indicators(li))
}
}
unique(observed_indicators)
}
for (v in v_latent) {
which_indicators <- find_observed_indicators(v)
A_composite[which_indicators, v] <- sign(R_big[which_indicators, v])
}
CM_composite <- t(A_composite) %*% R[v_observed_indicator, v_observed_indicator, drop = FALSE] %*% A_composite
A_composite_w <- A_composite %*% diag(diag(CM_composite) ^ -0.5, nrow = nrow(CM_composite))
colnames(A_composite_w) <- v_composite_score
colnames(A_factor_score) <- v_FS
# Factor weights
fw <- cbind(A_factor_score, A_composite_w)
W <- matrix(0L, nrow = nrow(A_big), ncol = nrow(A_big) + ncol(fw), dimnames = list(rownames(A_big), c(rownames(A_big), colnames(fw))))
diag(W) <- 1L
W[rownames(fw), colnames(fw)] <- fw
# Grand correlation matrix of all variables
R_all <- stats::cov2cor(t(W) %*% R_big %*% W)
v_order_all <- c(v_order, v_residual, v_FS, v_composite_score)
R_all <- R_all[v_order_all, v_order_all]
} else {
R_all <- R_big
A_factor_score <- NULL
A_composite_w <- NULL
v_FS <- character(0L)
v_composite_score <- character(0L)
}
# Make complete lavaan model syntax
lavaan_variances <- paste0(v_order, " ~~ ", diag(S[v_order, v_order]), " * ", v_order, collapse = "\n")
# Factor Score Validity
factor_score_validity <- diag(R_all[v_FS, v_factor_score, drop = FALSE])
names(factor_score_validity) <- v_FS
factor_score_se <- sqrt(1 - factor_score_validity^2L)
# Composite Score Validity
composite_score_validity <- diag(R_all[v_latent, v_composite_score, drop = FALSE])
names(composite_score_validity) <- v_composite_score
#—————————————————————————————————————— #
### Return Object ####
l_names <- list(v_observed = v_observed,
v_latent = v_latent,
v_latent_exogenous = v_latent_exogenous,
v_latent_endogenous = v_latent_endogenous,
v_observed_exogenous = v_observed_exogenous,
v_observed_endogenous = v_observed_endogenous,
v_observed_indicator = v_observed_indicator,
v_disturbance = v_disturbance,
v_error = v_error,
v_residual = v_residual,
v_factor_score = .str.affix(v_latent, suffix = "_FS"),
v_factor_score_disturbance = .str.affix(v_disturbance, suffix = "_FS"),
v_factor_score_error = .str.affix(v_error, suffix = "_FS"),
v_composite_score = v_composite_score)
object <- list(RAM_matrices = list(A = A[v_order, v_order], S = S[v_order, v_order], filter_matrix = filter_matrix[v_order, v_order], iA = iA[v_order, v_order]),
correlations = list(R = R[v_order, v_order], R_all = R_all),
coefficients = list(factor_score = A_factor_score,
factor_score_validity = factor_score_validity,
factor_score_se = factor_score_se,
composite_score = A_composite_w,
composite_score_validity = composite_score_validity),
lavaan_models = list(model_without_variances = model,
model_with_variances = paste0(model, "\n# Variances\n", lavaan_variances),
model_free = .fixed2free(model)),
v_names = l_names, iterations = iterations)
return(object)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Affix a Prefix and/or Suffix to a Vector ####
.str.affix <- function(x, prefix = "", suffix = "", ...) {
if (isTRUE(length(x) == 0L)) { return(character(0)) }
return(paste0(prefix, x, suffix, ...))
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Removing Fixed Parameters from a lavaan Model ####
.fixed2free <- function(model) {
model <- sapply(lavaan::lavaanify(model, fixed.x = FALSE) |> (\(p) p[p$lhs != p$rhs, ])() |>
(\(q) data.frame(split = factor(paste(q$lhs, q$op), levels = unique(paste(q$lhs, q$op))), q))() |>
(\(r) split(r, f = (r$split)))(), function(y) { paste(y$rhs, collapse = " + ") }) |>
(\(s) paste(paste(names(s), s), collapse = "\n"))()
return(model)
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Functions for Random Number Generator for the Multivariate Normal Distribution ####
.rmvnorm <- function(n, mean = rep(0L, nrow(sigma)), sigma = diag(length(mean)),
method = c("eigen", "svd", "chol"), pre0.9_9994 = FALSE, checkSymmetry = FALSE,
rnorm = stats::rnorm) {
if (isTRUE(checkSymmetry && !isSymmetric(sigma, tol = sqrt(.Machine$double.eps), check.attributes = FALSE))) { stop("Sigma must be a symmetric matrix", call. = FALSE) }
if (isTRUE(length(mean) != nrow(sigma))) { stop("Mean and sigma have non-conforming size", call. = FALSE) }
method <- match.arg(method)
R <- switch(method, "eigen" = {
ev <- eigen(sigma, symmetric = TRUE)
if (isTRUE(!all(ev$values >= -sqrt(.Machine$double.eps) * abs(ev$values[1L])))) { warning("sigma is numerically not positive semidefinite", call. = FALSE) }
t(ev$vectors %*% (t(ev$vectors) * sqrt(pmax(ev$values, 0L))))
}, "svd" = {
s. <- svd(sigma)
if (isTRUE(!all(s.$d >= -sqrt(.Machine$double.eps) * abs(s.$d[1L])))) { warning("sigma is numerically not positive semidefinite", call. = FALSE) }
t(s.$v %*% (t(s.$u) * sqrt(pmax(s.$d, 0L))))
}, "chol" = {
chol(sigma, pivot = TRUE) |> (\(p) p[, order(attr(p, "pivot"))])()
})
retval <- sweep(matrix(rnorm(n * ncol(sigma)), nrow = n, byrow = !pre0.9_9994) %*% R, 2L, mean, "+")
colnames(retval) <- names(mean)
return(retval)
}
#_______________________________________________________________________________
#_______________________________________________________________________________
#
# Internal Function for Writing Results ————————————————————————————————————————
.write.result <- function(object, write, append) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Text file ####
if (isTRUE(grepl("\\.txt", write))) {
# Send R output to text file
sink(file = write, append = ifelse(isTRUE(file.exists(write)), append, FALSE), type = "output", split = FALSE)
if (isTRUE(append && file.exists(write))) { write("", file = write, append = TRUE) }
# Print object
print(object, horiz = FALSE, check = FALSE)
# Close file connection
sink()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Excel file ####
} else {
misty::write.result(object, file = write)
}
}
#_______________________________________________________________________________
Try the misty package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.