#' @name estimate_var_tsa
#' @rdname estimate_var_tsa
#'
#' @title Taylor Series Approximation of effect-size variances corrected for psychometric artifacts
#'
#' @description
#' Functions to estimate the variances corrected for psychometric artifacts.
#' These functions use Taylor series approximations (i.e., the delta method) to estimate the corrected variance of an effect-size distribution.
#'
#' The available Taylor-series functions include:
#' \itemize{
#' \item{\code{estimate_var_tsa_meas}}{\cr Variance of \eqn{\rho} corrected for measurement error only}
#' \item{\code{estimate_var_tsa_uvdrr}}{\cr Variance of \eqn{\rho} corrected for univariate direct range restriction (i.e., Case II) and measurement error}
#' \item{\code{estimate_var_tsa_bvdrr}}{\cr Variance of \eqn{\rho} corrected for bivariate direct range restriction and measurement error}
#' \item{\code{estimate_var_tsa_uvirr}}{\cr Variance of \eqn{\rho} corrected for univariate indirect range restriction (i.e., Case IV) and measurement error}
#' \item{\code{estimate_var_tsa_bvirr}}{\cr Variance of \eqn{\rho} corrected for bivariate indirect range restriction (i.e., Case V) and measurement error}
#' \item{\code{estimate_var_tsa_rb1}}{\cr Variance of \eqn{\rho} corrected using Raju and Burke's TSA1 correction for direct range restriction and measurement error}
#' \item{\code{estimate_var_tsa_rb2}}{\cr Variance of \eqn{\rho} corrected using Raju and Burke's TSA2 correction for direct range restriction and measurement error. Note that a typographical error in Raju and Burke's article has been corrected in this function so as to compute appropriate partial derivatives.}
#' }
#'
#'
#' @param mean_rtp Mean corrected correlation.
#' @param mean_rtpa Mean corrected correlation.
#' @param var Variance to be corrected for artifacts.
#' @param mean_qx Mean square root of reliability for X.
#' @param mean_qxa Mean square root of unrestricted reliability for X.
#' @param mean_qy Mean square root of reliability for Y.
#' @param mean_qya Mean square root of unrestricted reliability for Y.
#' @param mean_qyi Mean square root of restricted reliability for Y.
#' @param mean_ux Mean observed-score u ratio for X.
#' @param mean_ut Mean true-score u ratio for X.
#' @param mean_uy Mean observed-score u ratio for Y.
#' @param sign_rxz Sign of the relationship between X and the selection mechanism.
#' @param sign_ryz Sign of the relationship between Y and the selection mechanism.
#' @param mean_rxx Mean reliability for X.
#' @param mean_ryy Mean reliability for Y.
#' @param ... Additional arguments.
#'
#' @return Vector of variances corrected for mean artifacts via Taylor series approximation.
#'
#' @section Notes:
#' A typographical error in Raju and Burke's article has been corrected in [estimate_var_tsa_rb2()] so as to compute appropriate partial derivatives.
#'
#' @md
#' @references
#' Dahlke, J. A., & Wiernik, B. M. (2020). Not restricted to selection research:
#' Accounting for indirect range restriction in organizational research.
#' *Organizational Research Methods, 23*(4), 717–749. \doi{10.1177/1094428119859398}
#'
#' Hunter, J. E., Schmidt, F. L., & Le, H. (2006).
#' Implications of direct and indirect range restriction for meta-analysis methods and findings.
#' *Journal of Applied Psychology, 91*(3), 594–612. \doi{10.1037/0021-9010.91.3.594}
#'
#' Raju, N. S., & Burke, M. J. (1983). Two new procedures for studying validity generalization.
#' *Journal of Applied Psychology, 68*(3), 382–395. \doi{10.1037/0021-9010.68.3.382}
NULL
#' @rdname estimate_var_tsa
#' @export
#' @examples
#' estimate_var_tsa_meas(mean_rtp = .5, var = .02,
#' mean_qx = .8,
#' mean_qy = .8)
estimate_var_tsa_meas <- function(mean_rtp, var = 0,
mean_qx = 1,
mean_qy = 1, ...){
b_rtp <- mean_qx * mean_qy
var / (mean_qx * mean_qy)^2
}
#' @rdname estimate_var_tsa
#' @export
#' @examples
#' estimate_var_tsa_uvdrr(mean_rtpa = .5, var = .02,
#' mean_ux = .8,
#' mean_qxa = .8,
#' mean_qyi = .8)
estimate_var_tsa_uvdrr <- function(mean_rtpa, var = 0,
mean_ux = 1,
mean_qxa = 1,
mean_qyi = 1, ...){
A <- 1 / sqrt(mean_rtpa^2 * mean_qxa^2* (mean_ux^2 - 1) + 1)
## Partial derivative with respect to rtpa
b_rtpa <- (mean_qyi * mean_qxa * mean_ux) * A^3
var / b_rtpa^2
}
#' @rdname estimate_var_tsa
#' @export
#' @examples
#' estimate_var_tsa_bvdrr(mean_rtpa = .5, var = .02,
#' mean_ux = .8,
#' mean_uy = .8,
#' mean_qxa = .8,
#' mean_qya = .8)
estimate_var_tsa_bvdrr <- function(mean_rtpa, var = 0,
mean_ux = 1,
mean_uy = 1,
mean_qxa = 1,
mean_qya = 1, ...){
A <- sqrt((1/(mean_qya * mean_qxa) - mean_qya * mean_rtpa^2 * mean_qxa)^2 + 4 * mean_rtpa^2 * mean_ux^2 * mean_uy^2)
B <- (mean_qya^2 * mean_rtpa^2 * mean_qxa^2 + mean_qya * mean_qxa * A - 1)
C <- 2 * mean_qya^2 * mean_rtpa * mean_qxa^2 * mean_ux * mean_uy *
sqrt((1/(mean_qya * mean_qxa) - mean_qya * mean_rtpa^2 * mean_qxa)^2 + 4 * mean_rtpa^2 * mean_ux^2 * mean_uy^2)
## Compute partial derivative with respect to rtpa
b_rtpa <- ((mean_rtpa^2 * mean_qxa^2 * mean_qya^2 + 1) * B) / (mean_rtpa * C)
var / b_rtpa^2
}
#' @rdname estimate_var_tsa
#' @export
#' @examples
#' estimate_var_tsa_uvirr(mean_rtpa = .5, var = .02,
#' mean_ut = .8,
#' mean_qxa = .8,
#' mean_qyi = .8)
estimate_var_tsa_uvirr <- function(mean_rtpa, var = 0,
mean_ut = 1,
mean_qxa = 1,
mean_qyi = 1, ...){
A <- 1 / sqrt(mean_ut^2 * mean_rtpa^2 - mean_rtpa^2 + 1)
B <- 1 / sqrt(mean_ut^2 * mean_qxa^2 - mean_qxa^2 + 1)
mean_rxyi <- mean_qxa * mean_qyi * mean_rtpa * mean_ut^2 * A * B
## Partial derivative with respect to rtpa
r_ratio <- mean_rxyi / mean_rtpa
r_ratio[is.na(r_ratio)] <- 1
b_rtpa <- r_ratio - mean_rxyi * mean_rtpa * A^2 * (mean_ut^2 - 1)
var / b_rtpa^2
}
#' @rdname estimate_var_tsa
#' @export
#' @examples
#' estimate_var_tsa_bvirr(mean_rtpa = .5, var = .02,
#' mean_ux = .8,
#' mean_uy = .8,
#' mean_qxa = .8,
#' mean_qya = .8,
#' sign_rxz = 1, sign_ryz = 1)
estimate_var_tsa_bvirr <- function(mean_rtpa, var = 0,
mean_ux = 1,
mean_uy = 1,
mean_qxa = 1,
mean_qya = 1,
sign_rxz = 1, sign_ryz = 1, ...){
## Estimate lambda
lambda <- .lambda_bvirr(ux = mean_ux, uy = mean_uy, sign_rxz = sign_rxz, sign_ryz = sign_ryz)
mean_rxyi <- (mean_rtpa * mean_qxa * mean_qya - lambda * sqrt(abs(1 - mean_ux^2) * abs(1 - mean_uy^2))) / (mean_uy * mean_ux)
## Partial derivative with respect to rtpa
b_rtpa <- (mean_qxa * mean_qya) / (mean_ux * mean_uy)
var / b_rtpa^2
}
#' @rdname estimate_var_tsa
#' @export
#' @examples
#' estimate_var_tsa_rb1(mean_rtpa = .5, var = .02,
#' mean_ux = .8,
#' mean_rxx = .8,
#' mean_ryy = .8)
estimate_var_tsa_rb1 <- function(mean_rtpa, var = 0,
mean_ux = 1,
mean_rxx = 1,
mean_ryy = 1, ...){
## Compute the mean observed correlation
mean_rxyi <- .attenuate_r_rb(rtpa = mean_rtpa, qx = mean_rxx^.5, qy = mean_ryy^.5, ux = mean_ux)
## Compute partial derivative with respect to rtpa
b_rtpa <- mean_rxyi / mean_rtpa + (mean_rxyi^3 * (1 - mean_ux^2)) / (mean_rtpa * mean_ux^2)
var / b_rtpa^2
}
#' @rdname estimate_var_tsa
#' @export
#' @examples
#' estimate_var_tsa_rb2(mean_rtpa = .5, var = .02,
#' mean_ux = .8,
#' mean_qx = .8,
#' mean_qy = .8)
estimate_var_tsa_rb2 <- function(mean_rtpa, var = 0,
mean_ux = 1,
mean_qx = 1,
mean_qy = 1, ...){
## Compute the mean observed correlation
mean_rxyi <- .attenuate_r_rb(rtpa = mean_rtpa, qx = mean_qx, qy = mean_qy, ux = mean_ux)
## Compute partial derivative with respect to rtpa
b_rtpa <- mean_rxyi / mean_rtpa + (mean_rxyi^3 * (1 - mean_ux^2)) / (mean_rtpa * mean_ux^2)
var / b_rtpa^2
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.