The bodies of the following functions contain the R implementation of
the formulas in V2015. Although many models are covered, there are only
four patterns. See the package top page for further references. The code
seen here is compacted and lacks the comments. For more redable code,
please refer to the Github repo and search
for the function names without the preceding regmedint:::.
For the type-set mathematical expressions and LaTeX source, please see
the supplement.
These functions are only used in the setting where both the mediator model and the outcome model are linear regression.
## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6)
## fun_est <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## cde <- (theta1 + theta3 * m_cde + theta5_c) * (a1 - a0)
## pnde <- (theta1 + theta3 * (beta0 + beta1 * a0 + beta2_c +
## beta3_c * a0) + theta5_c) * (a1 - a0)
## tnie <- (theta2 + theta3 * a1 + theta6_c) * (beta1 +
## beta3_c) * (a1 - a0)
## tnde <- (theta1 + theta3 * (beta0 + beta1 * a1 + beta2_c +
## beta3_c * a1) + theta5_c) * (a1 - a0)
## pnie <- (theta2 + theta3 * a0 + theta6_c) * (beta1 +
## beta3_c) * (a1 - a0)
## te <- pnde + tnie
## pm <- tnie/te
## c(cde = unname(cde), pnde = unname(pnde), tnie = unname(tnie),
## tnde = unname(tnde), pnie = unname(pnie), te = unname(te),
## pm = unname(pm))
## }
## return(fun_est)
## }
## <bytecode: 0x7f7dea6426d0>
## <environment: namespace:regmedint>## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6, Sigma_beta, Sigma_theta)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6)
## validate_myreg_vcovs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6,
## Sigma_beta = Sigma_beta, Sigma_theta = Sigma_theta)
## Sigma <- Matrix::bdiag(Sigma_beta, Sigma_theta)
## fun_se <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## pd_cde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_cde_theta5 <- c_cond
## }
## Gamma_cde <- matrix(c(0, 0, rep(0, length(beta2)), rep(0,
## length(beta3)), 0, 1, 0, m_cde, rep(0, length(theta4)),
## pd_cde_theta5, rep(0, length(theta6))))
## if (is.null(beta3)) {
## pd_pnde_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_pnde_beta3 <- theta3 * c_cond
## }
## if (is.null(theta5)) {
## pd_pnde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_pnde_theta5 <- c_cond
## }
## Gamma_pnde <- matrix(c(theta3, theta3 * a0, theta3 *
## c_cond, pd_pnde_beta3, 0, 1, 0, beta0 + beta1 * a0 +
## beta2_c + beta3_c * a0, rep(0, length(theta4)), pd_pnde_theta5,
## rep(0, length(theta6))))
## if (is.null(beta3)) {
## pd_tnie_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_tnie_beta3 <- c_cond * (theta2 + theta3 * a1 +
## theta6_c)
## }
## if (is.null(theta6)) {
## pd_tnie_theta6 <- rep(0, length(theta6))
## }
## else {
## pd_tnie_theta6 <- c_cond * (beta1 + beta3_c)
## }
## Gamma_tnie <- matrix(c(0, theta2 + theta3 * a1 + theta6_c,
## rep(0, length(beta2)), pd_tnie_beta3, 0, 0, beta1 +
## beta3_c, a1 * (beta1 + beta3_c), rep(0, length(theta4)),
## rep(0, length(theta5)), pd_tnie_theta6))
## if (is.null(beta3)) {
## pd_tnde_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_tnde_beta3 <- theta3 * a1 * c_cond
## }
## if (is.null(theta5)) {
## pd_tnde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_tnde_theta5 <- c_cond
## }
## Gamma_tnde <- matrix(c(theta3, theta3 * a1, theta3 *
## c_cond, pd_tnde_beta3, 0, 1, 0, beta0 + beta1 * a1 +
## beta2_c + beta3_c * a1, rep(0, length(theta4)), pd_tnde_theta5,
## rep(0, length(theta6))))
## if (is.null(beta3)) {
## pd_pnie_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_pnie_beta3 <- c_cond * (theta2 + theta3 * a0 +
## theta6_c)
## }
## if (is.null(theta6)) {
## pd_pnie_theta6 <- rep(0, length(theta6))
## }
## else {
## pd_pnie_theta6 <- c_cond * (beta1 + beta3_c)
## }
## Gamma_pnie <- matrix(c(0, theta2 + theta3 * a0 + theta6_c,
## rep(0, length(beta2)), pd_pnie_beta3, 0, 0, beta1 +
## beta3_c, a0 * (beta1 + beta3_c), rep(0, length(theta4)),
## rep(0, length(theta5)), pd_pnie_theta6))
## Gamma_te <- Gamma_pnde + Gamma_tnie
## pnde <- (theta1 + theta3 * (beta0 + beta1 * a0 + beta2_c +
## beta3_c * a0) + theta5_c) * (a1 - a0)
## tnie <- (theta2 + theta3 * a1 + theta6_c) * (beta1 +
## beta3_c) * (a1 - a0)
## d_pm <- grad_prop_med_yreg_linear(pnde = unname(pnde),
## tnie = unname(tnie))
## Gamma_pm <- (d_pm[["pnde"]] * Gamma_pnde) + (d_pm[["tnie"]] *
## Gamma_tnie)
## a1_sub_a0 <- abs(a1 - a0)
## se_cde <- sqrt(as.numeric(t(Gamma_cde) %*% Sigma %*%
## Gamma_cde)) * a1_sub_a0
## se_pnde <- sqrt(as.numeric(t(Gamma_pnde) %*% Sigma %*%
## Gamma_pnde)) * a1_sub_a0
## se_tnie <- sqrt(as.numeric(t(Gamma_tnie) %*% Sigma %*%
## Gamma_tnie)) * a1_sub_a0
## se_tnde <- sqrt(as.numeric(t(Gamma_tnde) %*% Sigma %*%
## Gamma_tnde)) * a1_sub_a0
## se_pnie <- sqrt(as.numeric(t(Gamma_pnie) %*% Sigma %*%
## Gamma_pnie)) * a1_sub_a0
## se_te <- sqrt(as.numeric(t(Gamma_te) %*% Sigma %*% Gamma_te)) *
## a1_sub_a0
## se_pm <- sqrt(as.numeric(t(Gamma_pm) %*% Sigma %*% Gamma_pm)) *
## a1_sub_a0
## c(se_cde = unname(se_cde), se_pnde = unname(se_pnde),
## se_tnie = unname(se_tnie), se_tnde = unname(se_tnde),
## se_pnie = unname(se_pnie), se_te = unname(se_te),
## se_pm = unname(se_pm))
## }
## return(fun_se)
## }
## <bytecode: 0x7f7dea8bca28>
## <environment: namespace:regmedint>These functions are used in all cases where the mediator model is linear regression and the outcome model is any one of the non-linear models.
## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6, sigma_sq)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6,
## sigma_sq = sigma_sq)
## fun_est <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## cde <- (theta1 + theta3 * m_cde + theta5_c) * (a1 - a0)
## pnde <- ((theta1 + theta5_c + theta3 * (beta0 + beta1 *
## a0 + beta2_c + beta3_c * a0) + 1/2 * sigma_sq * theta3 *
## (2 * theta2 + theta3 * a1 + theta3 * a0 + 2 * theta6_c))) *
## (a1 - a0)
## tnie <- (theta2 + theta3 * a1 + theta6_c) * (beta1 +
## beta3_c) * (a1 - a0)
## tnde <- ((theta1 + theta5_c + theta3 * (beta0 + beta1 *
## a1 + beta2_c + beta3_c * a1) + 1/2 * sigma_sq * theta3 *
## (2 * theta2 + theta3 * a1 + theta3 * a0 + 2 * theta6_c))) *
## (a1 - a0)
## pnie <- (theta2 + theta3 * a0 + theta6_c) * (beta1 +
## beta3_c) * (a1 - a0)
## te <- pnde + tnie
## pm <- exp(pnde) * (exp(tnie) - 1)/(exp(te) - 1)
## c(cde = unname(cde), pnde = unname(pnde), tnie = unname(tnie),
## tnde = unname(tnde), pnie = unname(pnie), te = unname(te),
## pm = unname(pm))
## }
## return(fun_est)
## }
## <bytecode: 0x7f7deab85438>
## <environment: namespace:regmedint>## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6, sigma_sq, Sigma_beta, Sigma_theta,
## Sigma_sigma_sq)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6,
## sigma_sq = sigma_sq)
## validate_myreg_vcovs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6,
## sigma_sq = sigma_sq, Sigma_beta = Sigma_beta, Sigma_theta = Sigma_theta,
## Sigma_sigma_sq = Sigma_sigma_sq)
## Sigma <- Matrix::bdiag(Sigma_beta, Sigma_theta, Sigma_sigma_sq)
## fun_se <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## pd_cde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_cde_theta5 <- c_cond
## }
## Gamma_cde <- matrix(c(0, 0, rep(0, length(beta2)), rep(0,
## length(beta3)), 0, 1, 0, m_cde, rep(0, length(theta4)),
## pd_cde_theta5, rep(0, length(theta6)), 0))
## if (is.null(beta3)) {
## pd_pnde_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_pnde_beta3 <- theta3 * a1 * c_cond
## }
## if (is.null(theta5)) {
## pd_pnde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_pnde_theta5 <- c_cond
## }
## if (is.null(theta6)) {
## pd_pnde_theta6 <- rep(0, length(theta6))
## }
## else {
## pd_pnde_theta6 <- theta3 * sigma_sq * c_cond
## }
## Gamma_pnde <- matrix(c(theta3, theta3 * a0, theta3 *
## c_cond, pd_pnde_beta3, 0, 1, theta3 * sigma_sq, a0 *
## (beta1 + beta3_c) + beta0 + beta2_c + sigma_sq *
## ((theta2 + theta6_c) + theta3 * (a0 + a1)), rep(0,
## length(theta4)), pd_pnde_theta5, pd_pnde_theta6,
## 1/2 * theta3 * (2 * (theta2 + theta6_c) + theta3 *
## (a0 + a1))))
## if (is.null(beta3)) {
## pd_tnie_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_tnie_beta3 <- c_cond * (theta2 + theta3 * a1 +
## theta6_c)
## }
## if (is.null(theta6)) {
## pd_tnie_theta6 <- rep(0, length(theta6))
## }
## else {
## pd_tnie_theta6 <- c_cond * (beta1 + beta3_c)
## }
## Gamma_tnie <- matrix(c(0, theta2 + theta3 * a1 + theta6_c,
## rep(0, length(beta2)), pd_tnie_beta3, 0, 0, beta1 +
## beta3_c, a1 * (beta1 + beta3_c), rep(0, length(theta4)),
## rep(0, length(theta5)), pd_tnie_theta6, 0))
## if (is.null(beta3)) {
## pd_tnde_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_tnde_beta3 <- theta3 * a1 * c_cond
## }
## if (is.null(theta5)) {
## pd_tnde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_tnde_theta5 <- c_cond
## }
## if (is.null(theta6)) {
## pd_tnde_theta6 <- rep(0, length(theta6))
## }
## else {
## pd_tnde_theta6 <- theta3 * sigma_sq * c_cond
## }
## Gamma_tnde <- matrix(c(theta3, theta3 * a1, theta3 *
## c_cond, pd_tnde_beta3, 0, 1, theta3 * sigma_sq, a1 *
## (beta1 + beta3_c) + beta0 + beta2_c + sigma_sq *
## ((theta2 + theta6_c) + theta3 * (a0 + a1)), rep(0,
## length(theta4)), pd_tnde_theta5, pd_tnde_theta6,
## 1/2 * theta3 * (2 * (theta2 + theta6_c) + theta3 *
## (a0 + a1))))
## if (is.null(beta3)) {
## pd_pnie_beta3 <- rep(0, length(beta3))
## }
## else {
## pd_pnie_beta3 <- c_cond * (theta2 + theta3 * a0 +
## theta6_c)
## }
## if (is.null(theta6)) {
## pd_pnie_theta6 <- rep(0, length(theta6))
## }
## else {
## pd_pnie_theta6 <- c_cond * (beta1 + beta3_c)
## }
## Gamma_pnie <- matrix(c(0, theta2 + theta3 * a0 + theta6_c,
## rep(0, length(beta2)), pd_pnie_beta3, 0, 0, beta1 +
## beta3_c, a0 * (beta1 + beta3_c), rep(0, length(theta4)),
## rep(0, length(theta5)), pd_pnie_theta6, 0))
## Gamma_te <- Gamma_pnde + Gamma_tnie
## pnde <- ((theta1 + theta5_c + theta3 * (beta0 + beta1 *
## a0 + beta2_c + beta3_c * a0) + 1/2 * sigma_sq * theta3 *
## (2 * theta2 + theta3 * a1 + theta3 * a0 + 2 * theta6_c))) *
## (a1 - a0)
## tnie <- (theta2 + theta3 * a1 + theta6_c) * (beta1 +
## beta3_c) * (a1 - a0)
## d_pm <- grad_prop_med_yreg_logistic(pnde = unname(pnde),
## tnie = unname(tnie))
## Gamma_pm <- d_pm[["pnde"]] * Gamma_pnde + d_pm[["tnie"]] *
## Gamma_tnie
## a1_sub_a0 <- abs(a1 - a0)
## se_cde <- sqrt(as.numeric(t(Gamma_cde) %*% Sigma %*%
## Gamma_cde)) * a1_sub_a0
## se_pnde <- sqrt(as.numeric(t(Gamma_pnde) %*% Sigma %*%
## Gamma_pnde)) * a1_sub_a0
## se_tnie <- sqrt(as.numeric(t(Gamma_tnie) %*% Sigma %*%
## Gamma_tnie)) * a1_sub_a0
## se_tnde <- sqrt(as.numeric(t(Gamma_tnde) %*% Sigma %*%
## Gamma_tnde)) * a1_sub_a0
## se_pnie <- sqrt(as.numeric(t(Gamma_pnie) %*% Sigma %*%
## Gamma_pnie)) * a1_sub_a0
## se_te <- sqrt(as.numeric(t(Gamma_te) %*% Sigma %*% Gamma_te)) *
## a1_sub_a0
## se_pm <- sqrt(as.numeric(t(Gamma_pm) %*% Sigma %*% Gamma_pm)) *
## a1_sub_a0
## c(se_cde = unname(se_cde), se_pnde = unname(se_pnde),
## se_tnie = unname(se_tnie), se_tnde = unname(se_tnde),
## se_pnie = unname(se_pnie), se_te = unname(se_te),
## se_pm = unname(se_pm))
## }
## return(fun_se)
## }
## <bytecode: 0x7f7deaeb2720>
## <environment: namespace:regmedint>These functions are only used in the setting where the mediator model is logistic regression and the outcome model is non-linear regression.
## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6)
## fun_est <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## expit <- function(x) {
## exp(x)/(1 + exp(x))
## }
## cde <- (theta1 + theta3 * m_cde + theta5_c) * (a1 - a0)
## pnde <- (theta1 + theta3 * expit(beta0 + beta1 * a0 +
## beta2_c + beta3_c * a0) + theta5_c) * (a1 - a0)
## tnie <- (theta2 + theta3 * a1 + theta6_c) * (expit(beta0 +
## beta1 * a1 + beta2_c + beta3_c * a1) - expit(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0))
## tnde <- (theta1 + theta3 * expit(beta0 + beta1 * a1 +
## beta2_c + beta3_c * a1) + theta5_c) * (a1 - a0)
## pnie <- (theta2 + theta3 * a0 + theta6_c) * (expit(beta0 +
## beta1 * a1 + beta2_c + beta3_c * a1) - expit(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0))
## te <- pnde + tnie
## pm <- tnie/te
## c(cde = unname(cde), pnde = unname(pnde), tnie = unname(tnie),
## tnde = unname(tnde), pnie = unname(pnie), te = unname(te),
## pm = unname(pm))
## }
## return(fun_est)
## }
## <bytecode: 0x7f7debb31ea8>
## <environment: namespace:regmedint>## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6, Sigma_beta, Sigma_theta)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6)
## validate_myreg_vcovs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6,
## Sigma_beta = Sigma_beta, Sigma_theta = Sigma_theta)
## Sigma <- Matrix::bdiag(Sigma_beta, Sigma_theta)
## fun_se <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## expit <- function(x) {
## exp(x)/(1 + exp(x))
## }
## if (is.null(theta5)) {
## pd_cde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_cde_theta5 <- c_cond
## }
## Gamma_cde <- matrix(c(0, 0, rep(0, length(beta2)), rep(0,
## length(beta3)), 0, 1, 0, m_cde, rep(0, length(theta4)),
## pd_cde_theta5, rep(0, length(theta6))))
## .e3 <- a0 * (beta1 + beta3_c) + beta0 + beta2_c
## .e4 <- exp(.e3)
## .e5 <- 1 + .e4
## .e6 <- 1 - .e4/.e5
## pnde_d1 <- theta3 * .e6 * .e4/.e5
## pnde_d2 <- a0 * theta3 * .e6 * .e4/.e5
## pnde_d3 <- c_cond * theta3 * .e6 * .e4/.e5
## if (is.null(beta3)) {
## pnde_d4 <- rep(0, length(beta3))
## }
## else {
## pnde_d4 <- a0 * c_cond * theta3 * .e6 * .e4/.e5
## }
## pnde_d5 <- 0
## pnde_d6 <- 1
## pnde_d7 <- 0
## pnde_d8 <- expit(.e3)
## pnde_d9 <- rep(0, length(theta4))
## if (is.null(theta5)) {
## pnde_d10 <- rep(0, length(theta5))
## }
## else {
## pnde_d10 <- c_cond
## }
## pnde_d11 <- rep(0, length(theta6))
## Gamma_pnde <- matrix(c(pnde_d1, pnde_d2, pnde_d3, pnde_d4,
## pnde_d5, pnde_d6, pnde_d7, pnde_d8, pnde_d9, pnde_d10,
## pnde_d11))
## .e1 <- beta1 + beta3_c
## .e2 <- beta2_c
## .e5 <- a0 * .e1 + beta0 + .e2
## .e8 <- a1 * .e1 + beta0 + .e2
## .e9 <- exp(.e5)
## .e10 <- exp(.e8)
## .e11 <- 1 + .e9
## .e12 <- 1 + .e10
## .e13 <- 1 - .e9/.e11
## .e14 <- 1 - .e10/.e12
## .e17 <- a1 * theta3 + theta6_c + theta2
## .e20 <- expit(.e8) - expit(.e5)
## .e25 <- .e14 * .e10/.e12 - .e13 * .e9/.e11
## .e32 <- a1 * .e14 * .e10/.e12 - a0 * .e13 * .e9/.e11
## tnie_d1 <- .e25 * .e17
## tnie_d2 <- .e32 * .e17
## tnie_d3 <- c_cond * .e25 * .e17
## if (is.null(beta3)) {
## tnie_d4 <- rep(0, length(beta3))
## }
## else {
## tnie_d4 <- c_cond * .e32 * .e17
## }
## tnie_d5 <- 0
## tnie_d6 <- 0
## tnie_d7 <- .e20
## tnie_d8 <- a1 * .e20
## tnie_d9 <- rep(0, length(theta4))
## tnie_d10 <- rep(0, length(theta5))
## if (is.null(theta6)) {
## tnie_d11 <- rep(0, length(theta6))
## }
## else {
## tnie_d11 <- c_cond * .e20
## }
## Gamma_tnie <- matrix(c(tnie_d1, tnie_d2, tnie_d3, tnie_d4,
## tnie_d5, tnie_d6, tnie_d7, tnie_d8, tnie_d9, tnie_d10,
## tnie_d11))
## .e3 <- a1 * (beta1 + beta3_c) + beta0 + beta2_c
## .e4 <- exp(.e3)
## .e5 <- 1 + .e4
## .e6 <- 1 - .e4/.e5
## tnde_d1 <- theta3 * .e6 * .e4/.e5
## tnde_d2 <- a1 * theta3 * .e6 * .e4/.e5
## tnde_d3 <- c_cond * theta3 * .e6 * .e4/.e5
## if (is.null(beta3)) {
## tnde_d4 <- rep(0, length(beta3))
## }
## else {
## tnde_d4 <- a1 * c_cond * theta3 * .e6 * .e4/.e5
## }
## tnde_d5 <- 0
## tnde_d6 <- 1
## tnde_d7 <- 0
## tnde_d8 <- expit(.e3)
## tnde_d9 <- rep(0, length(theta4))
## if (is.null(theta5)) {
## tnde_d10 <- rep(0, length(theta5))
## }
## else {
## tnde_d10 <- c_cond
## }
## tnde_d11 <- rep(0, length(theta6))
## Gamma_tnde <- matrix(c(tnde_d1, tnde_d2, tnde_d3, tnde_d4,
## tnde_d5, tnde_d6, tnde_d7, tnde_d8, tnde_d9, tnde_d10,
## tnde_d11))
## .e1 <- beta1 + beta3_c
## .e2 <- beta2_c
## .e5 <- a0 * .e1 + beta0 + .e2
## .e8 <- a1 * .e1 + beta0 + .e2
## .e9 <- exp(.e5)
## .e10 <- exp(.e8)
## .e11 <- 1 + .e9
## .e12 <- 1 + .e10
## .e13 <- 1 - .e9/.e11
## .e14 <- 1 - .e10/.e12
## .e17 <- a0 * theta3 + theta6_c + theta2
## .e20 <- expit(.e8) - expit(.e5)
## .e25 <- .e14 * .e10/.e12 - .e13 * .e9/.e11
## .e32 <- a1 * .e14 * .e10/.e12 - a0 * .e13 * .e9/.e11
## pnie_d1 <- .e25 * .e17
## pnie_d2 <- .e32 * .e17
## pnie_d3 <- c_cond * .e25 * .e17
## if (is.null(beta3)) {
## pnie_d4 <- rep(0, length(beta3))
## }
## else {
## pnie_d4 <- c_cond * .e32 * .e17
## }
## pnie_d5 <- 0
## pnie_d6 <- 0
## pnie_d7 <- .e20
## pnie_d8 <- a0 * .e20
## pnie_d9 <- rep(0, length(theta4))
## pnie_d10 <- rep(0, length(theta5))
## if (is.null(theta6)) {
## pnie_d11 <- rep(0, length(theta6))
## }
## else {
## pnie_d11 <- c_cond * .e20
## }
## Gamma_pnie <- matrix(c(pnie_d1, pnie_d2, pnie_d3, pnie_d4,
## pnie_d5, pnie_d6, pnie_d7, pnie_d8, pnie_d9, pnie_d10,
## pnie_d11))
## Gamma_te <- ((a1 - a0) * Gamma_pnde) + Gamma_tnie
## pnde <- (theta1 + theta3 * expit(beta0 + beta1 * a0 +
## beta2_c + beta3_c * a0) + theta5_c) * (a1 - a0)
## tnie <- (theta2 + theta3 * a1 + theta6_c) * (expit(beta0 +
## beta1 * a1 + beta2_c + beta3_c * a1) - expit(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0))
## d_pm <- grad_prop_med_yreg_linear(pnde = unname(pnde),
## tnie = unname(tnie))
## Gamma_pm <- (d_pm[["pnde"]] * (a1 - a0) * Gamma_pnde) +
## (d_pm[["tnie"]] * Gamma_tnie)
## a1_sub_a0 <- abs(a1 - a0)
## se_cde <- sqrt(as.numeric(t(Gamma_cde) %*% Sigma %*%
## Gamma_cde)) * a1_sub_a0
## se_pnde <- sqrt(as.numeric(t(Gamma_pnde) %*% Sigma %*%
## Gamma_pnde)) * a1_sub_a0
## se_tnie <- sqrt(as.numeric(t(Gamma_tnie) %*% Sigma %*%
## Gamma_tnie))
## se_tnde <- sqrt(as.numeric(t(Gamma_tnde) %*% Sigma %*%
## Gamma_tnde)) * a1_sub_a0
## se_pnie <- sqrt(as.numeric(t(Gamma_pnie) %*% Sigma %*%
## Gamma_pnie))
## se_te <- sqrt(as.numeric(t(Gamma_te) %*% Sigma %*% Gamma_te))
## se_pm <- sqrt(as.numeric(t(Gamma_pm) %*% Sigma %*% Gamma_pm))
## c(se_cde = unname(se_cde), se_pnde = unname(se_pnde),
## se_tnie = unname(se_tnie), se_tnde = unname(se_tnde),
## se_pnie = unname(se_pnie), se_te = unname(se_te),
## se_pm = unname(se_pm))
## }
## return(fun_se)
## }
## <bytecode: 0x7f7debf4afa8>
## <environment: namespace:regmedint>These functions are used in all cases where the mediator model is logistic regression and the outcome model is any one of the non-linear models.
## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6)
## fun_est <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## expit <- function(x) {
## exp(x)/(1 + exp(x))
## }
## cde <- (theta1 + theta3 * m_cde + theta5_c) * (a1 - a0)
## pnde <- ((theta1 + theta5_c) * (a1 - a0)) + log(1 + exp(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0 + theta2 + theta3 *
## a1 + theta6_c)) - log(1 + exp(beta0 + beta1 * a0 +
## beta2_c + beta3_c * a0 + theta2 + theta3 * a0 + theta6_c))
## tnie <- log(1 + exp(beta0 + beta1 * a1 + beta2_c + beta3_c *
## a1 + theta2 + theta3 * a1 + theta6_c)) - log(1 +
## exp(beta0 + beta1 * a0 + beta2_c + beta3_c * a0 +
## theta2 + theta3 * a1 + theta6_c)) + log(1 + exp(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0)) - log(1 + exp(beta0 +
## beta1 * a1 + beta2_c + beta3_c * a1))
## tnde <- ((theta1 + theta5_c) * (a1 - a0)) + log(1 + exp(beta0 +
## beta1 * a1 + beta2_c + beta3_c * a1 + theta2 + theta3 *
## a1 + theta6_c)) - log(1 + exp(beta0 + beta1 * a1 +
## beta2_c + beta3_c * a1 + theta2 + theta3 * a0 + theta6_c))
## pnie <- log(1 + exp(beta0 + beta1 * a1 + beta2_c + beta3_c *
## a1 + theta2 + theta3 * a0 + theta6_c)) - log(1 +
## exp(beta0 + beta1 * a0 + beta2_c + beta3_c * a0 +
## theta2 + theta3 * a0 + theta6_c)) + log(1 + exp(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0)) - log(1 + exp(beta0 +
## beta1 * a1 + beta2_c + beta3_c * a1))
## te <- pnde + tnie
## pm <- (exp(pnde) * (exp(tnie) - 1))/(exp(te) - 1)
## c(cde = unname(cde), pnde = unname(pnde), tnie = unname(tnie),
## tnde = unname(tnde), pnie = unname(pnie), te = unname(te),
## pm = unname(pm))
## }
## return(fun_est)
## }
## <bytecode: 0x7f7debaffdc8>
## <environment: namespace:regmedint>## function (beta0, beta1, beta2, beta3, theta0, theta1, theta2,
## theta3, theta4, theta5, theta6, Sigma_beta, Sigma_theta)
## {
## validate_myreg_coefs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6)
## validate_myreg_vcovs(beta0 = beta0, beta1 = beta1, beta2 = beta2,
## beta3 = beta3, theta0 = theta0, theta1 = theta1, theta2 = theta2,
## theta3 = theta3, theta4 = theta4, theta5 = theta5, theta6 = theta6,
## Sigma_beta = Sigma_beta, Sigma_theta = Sigma_theta)
## Sigma <- Matrix::bdiag(Sigma_beta, Sigma_theta)
## fun_se <- function(a0, a1, m_cde, c_cond) {
## if (is.null(beta2)) {
## assertthat::assert_that(is.null(c_cond))
## beta2_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(beta2))
## beta2_c <- sum(t(matrix(beta2)) %*% matrix(c_cond))
## }
## if (is.null(beta3)) {
## beta3_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(beta3))
## beta3_c <- sum(t(matrix(beta3)) %*% matrix(c_cond))
## }
## if (is.null(theta4)) {
## assertthat::assert_that(is.null(c_cond))
## theta4_c <- 0
## }
## else {
## assertthat::assert_that(!is.null(c_cond))
## assertthat::assert_that(length(c_cond) == length(theta4))
## theta4_c <- sum(t(matrix(theta4)) %*% matrix(c_cond))
## }
## if (is.null(theta5)) {
## theta5_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta5))
## theta5_c <- sum(t(matrix(theta5)) %*% matrix(c_cond))
## }
## if (is.null(theta6)) {
## theta6_c <- 0
## }
## else {
## assertthat::assert_that(length(c_cond) == length(theta6))
## theta6_c <- sum(t(matrix(theta6)) %*% matrix(c_cond))
## }
## expit <- function(x) {
## exp(x)/(1 + exp(x))
## }
## if (is.null(theta5)) {
## pd_cde_theta5 <- rep(0, length(theta5))
## }
## else {
## pd_cde_theta5 <- c_cond
## }
## Gamma_cde <- matrix(c(0, 0, rep(0, length(beta2)), rep(0,
## length(beta3)), 0, (a1 - a0), 0, (a1 - a0) * m_cde,
## rep(0, length(theta4)), pd_cde_theta5, rep(0, length(theta6))))
## pnde_expit_a1 <- expit(a0 * (beta1 + beta3_c) + a1 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## pnde_expit_a0 <- expit(a0 * (beta1 + beta3_c) + a0 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## pnde_d1 <- pnde_expit_a1 - pnde_expit_a0
## pnde_d2 <- a0 * pnde_d1
## pnde_d3 <- c_cond * pnde_d1
## if (is.null(beta3)) {
## pnde_d4 <- rep(0, length(beta3))
## }
## else {
## pnde_d4 <- c_cond * a0 * pnde_d1
## }
## pnde_d5 <- 0
## pnde_d6 <- a1 - a0
## pnde_d7 <- pnde_d1
## pnde_d8 <- a1 * pnde_expit_a1 - a0 * pnde_expit_a0
## pnde_d9 <- rep(0, length(theta4))
## if (is.null(theta5)) {
## pnde_d10 <- rep(0, length(theta5))
## }
## else {
## pnde_d10 <- c_cond * (a1 - a0)
## }
## if (is.null(theta6)) {
## pnde_d11 <- rep(0, length(theta6))
## }
## else {
## pnde_d11 <- c_cond * pnde_d1
## }
## Gamma_pnde <- matrix(c(pnde_d1, pnde_d2, pnde_d3, pnde_d4,
## pnde_d5, pnde_d6, pnde_d7, pnde_d8, pnde_d9, pnde_d10,
## pnde_d11))
## tnie_expit_q1 <- expit(a0 * (beta1 + beta3_c) + beta0 +
## beta2_c)
## tnie_expit_q2 <- expit(a0 * (beta1 + beta3_c) + a1 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## tnie_expit_q3 <- expit(a1 * (beta1 + beta3_c) + beta0 +
## beta2_c)
## tnie_expit_q4 <- expit(a1 * (beta1 + beta3_c) + a1 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## tnie_d1 <- tnie_expit_q1 - tnie_expit_q2 - tnie_expit_q3 +
## tnie_expit_q4
## tnie_d2 <- a0 * (tnie_expit_q1 - tnie_expit_q2) + a1 *
## (-tnie_expit_q3 + tnie_expit_q4)
## tnie_d3 <- c_cond * tnie_d1
## if (is.null(beta3)) {
## tnie_d4 <- rep(0, length(beta3))
## }
## else {
## tnie_d4 <- c_cond * tnie_d2
## }
## tnie_d5 <- 0
## tnie_d6 <- 0
## tnie_d7 <- tnie_expit_q4 - tnie_expit_q2
## tnie_d8 <- a1 * tnie_d7
## tnie_d9 <- rep(0, length(theta4))
## tnie_d10 <- rep(0, length(theta5))
## if (is.null(theta6)) {
## tnie_d11 <- rep(0, length(theta6))
## }
## else {
## tnie_d11 <- c_cond * tnie_d7
## }
## Gamma_tnie <- matrix(c(tnie_d1, tnie_d2, tnie_d3, tnie_d4,
## tnie_d5, tnie_d6, tnie_d7, tnie_d8, tnie_d9, tnie_d10,
## tnie_d11))
## tnde_expit_a1 <- expit(a1 * (beta1 + beta3_c) + a1 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## tnde_expit_a0 <- expit(a1 * (beta1 + beta3_c) + a0 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## tnde_d1 <- tnde_expit_a1 - tnde_expit_a0
## tnde_d2 <- a1 * tnde_d1
## tnde_d3 <- c_cond * tnde_d1
## if (is.null(beta3)) {
## tnde_d4 <- rep(0, length(beta3))
## }
## else {
## tnde_d4 <- c_cond * a1 * tnde_d1
## }
## tnde_d5 <- 0
## tnde_d6 <- a1 - a0
## tnde_d7 <- tnde_d1
## tnde_d8 <- a1 * tnde_expit_a1 - a0 * tnde_expit_a0
## tnde_d9 <- rep(0, length(theta4))
## if (is.null(theta5)) {
## tnde_d10 <- rep(0, length(theta5))
## }
## else {
## tnde_d10 <- c_cond * (a1 - a0)
## }
## if (is.null(theta6)) {
## tnde_d11 <- rep(0, length(theta6))
## }
## else {
## tnde_d11 <- tnde_d3
## }
## Gamma_tnde <- matrix(c(tnde_d1, tnde_d2, tnde_d3, tnde_d4,
## tnde_d5, tnde_d6, tnde_d7, tnde_d8, tnde_d9, tnde_d10,
## tnde_d11))
## pnie_expit_q1 <- expit(a0 * (beta1 + beta3_c) + beta0 +
## beta2_c)
## pnie_expit_q2 <- expit(a0 * (beta1 + beta3_c) + a0 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## pnie_expit_q3 <- expit(a1 * (beta1 + beta3_c) + beta0 +
## beta2_c)
## pnie_expit_q4 <- expit(a1 * (beta1 + beta3_c) + a0 *
## theta3 + beta0 + beta2_c + theta6_c + theta2)
## pnie_d1 <- pnie_expit_q1 - pnie_expit_q2 - pnie_expit_q3 +
## pnie_expit_q4
## pnie_d2 <- a0 * (pnie_expit_q1 - pnie_expit_q2) + a1 *
## (-pnie_expit_q3 + pnie_expit_q4)
## pnie_d3 <- c_cond * pnie_d1
## if (is.null(beta3)) {
## pnie_d4 <- rep(0, length(beta3))
## }
## else {
## pnie_d4 <- c_cond * pnie_d2
## }
## pnie_d5 <- 0
## pnie_d6 <- 0
## pnie_d7 <- pnie_expit_q4 - pnie_expit_q2
## pnie_d8 <- a0 * pnie_d7
## pnie_d9 <- rep(0, length(theta4))
## pnie_d10 <- rep(0, length(theta5))
## if (is.null(theta6)) {
## pnie_d11 <- rep(0, length(theta6))
## }
## else {
## pnie_d11 <- c_cond * pnie_d7
## }
## Gamma_pnie <- matrix(c(pnie_d1, pnie_d2, pnie_d3, pnie_d4,
## pnie_d5, pnie_d6, pnie_d7, pnie_d8, pnie_d9, pnie_d10,
## pnie_d11))
## Gamma_te <- Gamma_pnde + Gamma_tnie
## pnde <- ((theta1 + theta5_c) * (a1 - a0)) + log(1 + exp(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0 + theta2 + theta3 *
## a1 + theta6_c)) - log(1 + exp(beta0 + beta1 * a0 +
## beta2_c + beta3_c * a0 + theta2 + theta3 * a0 + theta6_c))
## tnie <- log(1 + exp(beta0 + beta1 * a1 + beta2_c + beta3_c *
## a1 + theta2 + theta3 * a1 + theta6_c)) - log(1 +
## exp(beta0 + beta1 * a0 + beta2_c + beta3_c * a0 +
## theta2 + theta3 * a1 + theta6_c)) + log(1 + exp(beta0 +
## beta1 * a0 + beta2_c + beta3_c * a0)) - log(1 + exp(beta0 +
## beta1 * a1 + beta2_c + beta3_c * a1))
## d_pm <- grad_prop_med_yreg_logistic(pnde = unname(pnde),
## tnie = unname(tnie))
## Gamma_pm <- (d_pm[["pnde"]] * Gamma_pnde) + (d_pm[["tnie"]] *
## Gamma_tnie)
## se_cde <- sqrt(as.numeric(t(Gamma_cde) %*% Sigma %*%
## Gamma_cde))
## se_pnde <- sqrt(as.numeric(t(Gamma_pnde) %*% Sigma %*%
## Gamma_pnde))
## se_tnie <- sqrt(as.numeric(t(Gamma_tnie) %*% Sigma %*%
## Gamma_tnie))
## se_tnde <- sqrt(as.numeric(t(Gamma_tnde) %*% Sigma %*%
## Gamma_tnde))
## se_pnie <- sqrt(as.numeric(t(Gamma_pnie) %*% Sigma %*%
## Gamma_pnie))
## se_te <- sqrt(as.numeric(t(Gamma_te) %*% Sigma %*% Gamma_te))
## se_pm <- sqrt(as.numeric(t(Gamma_pm) %*% Sigma %*% Gamma_pm))
## c(se_cde = unname(se_cde), se_pnde = unname(se_pnde),
## se_tnie = unname(se_tnie), se_tnde = unname(se_tnde),
## se_pnie = unname(se_pnie), se_te = unname(se_te),
## se_pm = unname(se_pm))
## }
## return(fun_se)
## }
## <bytecode: 0x7f7debd045c0>
## <environment: namespace:regmedint>