R/convert_ma.R

Defines functions .convert_metatab .identify_ma_cols convert_sdd_to_sdr convert_vard_to_varr convert_sdr_to_sdd convert_varr_to_vard convert_d_to_r .convert_r_to_d convert_r_to_d convert_pq_to_p .convert_ma convert_ma

Documented in convert_ma .convert_metatab convert_pq_to_p convert_sdd_to_sdr convert_sdr_to_sdd convert_vard_to_varr convert_varr_to_vard .identify_ma_cols

#' @title Function to convert meta-analysis of correlations to d values or vice-versa
#'
#' @description
#' \loadmathjax
#' Takes a meta-analysis class object of \emph{d} values or correlations (classes \code{r_as_r}, \code{d_as_d}, \code{r_as_d}, and \code{d_as_r}; second-order meta-analyses are currently not supported) as an input and uses conversion formulas and Taylor series approximations to convert effect sizes and variance estimates, respectively.
#'
#' @param ma_obj A meta-analysis object of class \code{r_as_r}, \code{d_as_d}, \code{r_as_d}, or \code{d_as_r}
#' @param ... Additional arguments.
#'
#' @return A meta-analysis converted to the \emph{d} value metric (if ma_obj was a meta-analysis in the correlation metric) or converted to the correlation metric (if ma_obj was a meta-analysis in the \emph{d} value metric).
#' @export
#'
#' @details
#' The formula used to convert correlations to \emph{d} values is:
#' \mjdeqn{d=\frac{r\sqrt{\frac{1}{p\left(1-p\right)}}}{\sqrt{1-r^{2}}}}{(sqrt(1 / (p * (1-p))) * r) / sqrt(1 - r^2)}
#'
#' The formula used to convert \emph{d} values to correlations is:
#' \mjdeqn{r=\frac{d}{\sqrt{d^{2}+\frac{1}{p\left(1-p\right)}}}}{d / sqrt(1 / (p * (1-p)) + d^2)}
#'
#' To approximate the variance of correlations from the variance of \emph{d} values, the function computes:
#' \mjdeqn{var_{r}\approx a_{d}^{2}var_{d}}{var_r ~= a_d^2 * var_d}
#' where \mjeqn{a_{d}}{a_d} is the first partial derivative of the \emph{d}-to-\emph{r} transformation with respect to \emph{d}:
#' \mjdeqn{a_{d}=-\frac{1}{\left[d^{2}p\left(1-p\right)-1\right]\sqrt{d^{2}+\frac{1}{p-p^{2}}}}}{a_d = -1 / ((d^2 * (p - 1) * p - 1) * sqrt(d^2 + 1 / (p - p^2)))}
#'
#' To approximate the variance of \emph{d} values from the variance of correlations, the function computes:
#' \mjdeqn{var_{d}\approx a_{r}^{2}var_{r}}{var_d ~= a_r^2 * var_r}
#' where \mjeqn{a_{r}}{a_r} is the first partial derivative of the \emph{r}-to-\emph{d} transformation with respect to \emph{r}:
#' \mjdeqn{a_{r}=\frac{\sqrt{\frac{1}{p-p^{2}}}}{\left(1-r^{2}\right)^{1.5}}}{a_r = sqrt(1 / (p - p^2)) / (1 - r^2)^1.5}
convert_ma <- function(ma_obj, ...){

     flag_summary <- "summary.ma_psychmeta" %in% class(ma_obj)
     if(flag_summary) ma_obj <- ma_obj$ma_obj

     additional_args <- list(...)
     .attributes <- attributes(ma_obj)

     if(is.null(additional_args$ma_metric)){
          ma_metric <- attributes(ma_obj)$ma_metric
     }else{
          ma_metric <- additional_args$ma_metric
     }

     if(is.null(additional_args$ma_methods)){
          ma_methods <- attributes(ma_obj)$ma_methods
     }else{
          ma_methods <- additional_args$ma_methods
     }

     if(!is.null(additional_args$record_call)){
          record_call <- additional_args$record_call
     }else{
          record_call <- TRUE
     }

     ma_obj <- ma_obj %>% group_by(.data$analysis_id) %>%
          do(.convert_ma(ma_obj_i = .data, ma_obj = ma_obj, ma_metric = ma_metric, ma_methods = ma_methods))

     if(ma_metric == "r_as_r") .ma_metric <- "r_as_d"
     if(ma_metric == "d_as_r") .ma_metric <- "d_as_d"

     if(ma_metric == "r_as_d") .ma_metric <- "r_as_r"
     if(ma_metric == "d_as_d") .ma_metric <- "d_as_r"

     if("construct_x" %in% colnames(ma_obj)){
          colnames(ma_obj)[colnames(ma_obj) == "construct_x"] <- "group_contrast"
     }else{
          if("group_contrast" %in% colnames(ma_obj))
               colnames(ma_obj)[colnames(ma_obj) == "group_contrast"] <- "construct_x"
     }

     ma_obj <- namelists.ma_psychmeta(ma_obj = ma_obj)
     .attributes$names <- attributes(ma_obj)$names
     attributes(ma_obj) <- .attributes
     attributes(ma_obj)$ma_metric <- .ma_metric
     if(record_call)
          attributes(ma_obj)$call_history <- append(attributes(ma_obj)$call_history,
                                                    list(match.call()))

     if(flag_summary) ma_obj <- summary(ma_obj)

     ma_obj
}

#' @rdname convert_ma
#' @export
convert_meta <- convert_ma


.convert_ma <- function(ma_obj_i, ma_obj, ma_methods, ma_metric){

     k <- ma_obj_i$meta_tables[[1]]$barebones$k
     att <- attributes(ma_obj)
     conf_level <- att$inputs$conf_level
     cred_level <- att$inputs$cred_level
     conf_method <- att$inputs$conf_method
     cred_method <- att$inputs$cred_method
     error_type <- att$inputs$error_type

     if("pi" %in% colnames(ma_obj_i$escalc[[1]]$barebones)){
          pi_list <- ma_obj_i$escalc[[1]]$barebones$pi
          pi_vec <- wt_mean(x = ma_obj_i$escalc[[1]]$barebones$pi, wt = ma_obj_i$escalc[[1]]$barebones$weight)
     }else{
          pi_list <- rep(.5, nrow(ma_obj_i$escalc[[1]]$barebones))
          pi_vec <- rep(.5, length(k))
     }

     if("pa" %in% colnames(ma_obj_i$escalc[[1]]$barebones)){
          pa_list <- ma_obj_i$escalc[[1]]$barebones$pa
          pa_vec <- wt_mean(x = ma_obj_i$escalc[[1]]$barebones$pa, wt = ma_obj_i$escalc[[1]]$barebones$weight)
     }else{
          pa_list <- rep(.5, nrow(ma_obj_i$escalc[[1]]$barebones))
          pa_vec <- rep(.5, length(k))
     }

     if("pa_ad" %in% colnames(ma_obj_i$escalc[[1]]$barebones)){
          pa_ad_list <- ma_obj_i$escalc[[1]]$barebones$pa_ad
          pa_ad_vec <- wt_mean(x = ma_obj_i$escalc[[1]]$barebones$pa_ad, wt = ma_obj_i$escalc[[1]]$barebones$weight)
     }else{
          pa_ad_list <- rep(.5, nrow(ma_obj_i$escalc[[1]]$barebones))
          pa_ad_vec <- rep(.5, length(k))
     }

     correction_names_r <- c("true_score", "validity_generalization_x", "validity_generalization_y")
     correction_names_d <- c("latentGroup_latentY", "observedGroup_latentY", "latentGroup_observedY")

     if(any(ma_metric == "r_as_r") | any(ma_metric == "d_as_r")){
          if(any(ma_methods == "bb")){

               if(error_type == "mean"){
                    mean_r <- ma_obj_i$meta_tables[[1]]$barebones$mean_r

                    ma_obj_i$escalc[[1]]$barebones$vi <- convert_varr_to_vard(r = mean_r, var = ma_obj_i$escalc[[1]]$barebones$vi, p = pi_list)
                    ma_obj_i$escalc[[1]]$barebones$yi <- .convert_r_to_d(r =  ma_obj_i$escalc[[1]]$barebones$yi, p = pi_list)
               }else{
                    ma_obj_i$escalc[[1]]$barebones$vi <- convert_varr_to_vard(r = ma_obj_i$escalc[[1]]$barebones$yi,
                                                                              var = ma_obj_i$escalc[[1]]$barebones$vi, p = pi_list)
                    ma_obj_i$escalc[[1]]$barebones$yi <- .convert_r_to_d(r = ma_obj_i$escalc[[1]]$barebones$yi, p = pi_list)
               }

               ma_obj_i$meta_tables[[1]]$barebones <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$barebones,
                                                                       p_vec = pi_vec, conf_level = conf_level, cred_level = cred_level,
                                                                       conf_method = conf_method, cred_method = cred_method)
          }

          if(any(ma_methods == "ad")){
               ma_obj_i$meta_tables[[1]]$artifact_distribution$true_score <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$artifact_distribution$true_score,
                                                                                              p_vec = pa_ad_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$artifact_distribution$validity_generalization_x <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$artifact_distribution$validity_generalization_x,
                                                                                                             p_vec = pa_ad_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$artifact_distribution$validity_generalization_y <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$artifact_distribution$validity_generalization_y,
                                                                                                             p_vec = pa_ad_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
          }

          if(any(ma_methods == "ic")){
               mean_rtpa <- ma_obj_i$meta_tables[[1]]$individual_correction$true_score$mean_rho
               mean_rxpa <- ma_obj_i$meta_tables[[1]]$individual_correction$validity_generalization_x$mean_rho
               mean_rtya <- ma_obj_i$meta_tables[[1]]$individual_correction$validity_generalization_y$mean_rho

               if(error_type == "mean"){
                    ## Deal with true-score data
                    ma_obj_i$escalc[[1]]$individual_correction$true_score$vi <- convert_varr_to_vard(r = mean_rtpa, var = ma_obj_i$escalc[[1]]$individual_correction$true_score$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$true_score$yi <- .convert_r_to_d(r = ma_obj_i$escalc[[1]]$individual_correction$true_score$yi, p = pa_list)

                    ## Deal with vgx data
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$vi <- convert_varr_to_vard(r = mean_rtpa, var = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$yi <- .convert_r_to_d(r = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$yi, p = pa_list)

                    ## Deal with vgy data
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$vi <- convert_varr_to_vard(r = mean_rtpa, var = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$yi <- .convert_r_to_d(r = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$yi, p = pa_list)
               }else{
                    ## Deal with true-score data
                    ma_obj_i$escalc[[1]]$individual_correction$true_score$vi <- convert_varr_to_vard(r = ma_obj_i$escalc[[1]]$individual_correction$true_score$yi,
                                                                                                     var = ma_obj_i$escalc[[1]]$individual_correction$true_score$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$true_score$yi <- .convert_r_to_d(r = ma_obj_i$escalc[[1]]$individual_correction$true_score$yi, p = pa_list)

                    ## Deal with vgx data
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$vi <- convert_varr_to_vard(r = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$yi,
                                                                                                                    var = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$yi <- .convert_r_to_d(r = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_x$yi, p = pa_list)

                    ## Deal with vgy data
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$vi <- convert_varr_to_vard(r = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$yi,
                                                                                                                    var = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$yi <- .convert_r_to_d(r = ma_obj_i$escalc[[1]]$individual_correction$validity_generalization_y$yi, p = pa_list)
               }

               ## Convert meta-analytic tables
               ma_obj_i$meta_tables[[1]]$individual_correction$true_score <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$individual_correction$true_score,
                                                                                              p_vec = pa_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$individual_correction$validity_generalization_x <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$individual_correction$validity_generalization_x,
                                                                                                             p_vec = pa_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$individual_correction$validity_generalization_y <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$individual_correction$validity_generalization_y,
                                                                                                             p_vec = pa_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
          }
     }


     if(any(ma_metric == "d_as_d") | any(ma_metric == "r_as_d")){
          if(any(ma_methods == "bb")){

               if(error_type == "mean"){
                    mean_d <- ma_obj_i$meta_tables[[1]]$barebones$mean_d

                    ma_obj_i$escalc[[1]]$barebones$vi <- convert_vard_to_varr(d = mean_d, var = ma_obj_i$escalc[[1]]$barebones$vi, p = pi_list)
                    ma_obj_i$escalc[[1]]$barebones$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$barebones$yi, p = pi_list)
               }else{
                    ma_obj_i$escalc[[1]]$barebones$vi <- convert_vard_to_varr(d = ma_obj_i$escalc[[1]]$barebones$yi,
                                                                              var = ma_obj_i$escalc[[1]]$barebones$vi, p = pi_list)
                    ma_obj_i$escalc[[1]]$barebones$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$barebones$yi, p = pi_list)
               }
               ma_obj_i$meta_tables[[1]]$barebones <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$barebones, p_vec = pi_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
          }

          if(any(ma_methods == "ad")){
               ma_obj_i$meta_tables[[1]]$artifact_distribution$latentGroup_latentY <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$artifact_distribution$latentGroup_latentY,
                                                                                                       p_vec = pa_ad_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$artifact_distribution$observedGroup_latentY <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$artifact_distribution$observedGroup_latentY,
                                                                                                         p_vec = pa_ad_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$artifact_distribution$latentGroup_observedY <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$artifact_distribution$latentGroup_observedY,
                                                                                                         p_vec = pa_ad_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
          }

          if(any(ma_methods == "ic")){
               mean_dtpa <- ma_obj_i$meta_tables[[1]]$individual_correction$latentGroup_latentY$mean_delta
               mean_dxpa <- ma_obj_i$meta_tables[[1]]$individual_correction$observedGroup_latentY$mean_delta
               mean_dtya <- ma_obj_i$meta_tables[[1]]$individual_correction$latentGroup_observedY$mean_delta

               if(error_type == "mean"){
                    ## Deal with true-score data
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$vi <- convert_vard_to_varr(d = mean_dtpa, var = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$yi, p = pa_list)

                    ## Deal with vgx data
                    ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$vi <- convert_vard_to_varr(d = mean_dtpa, var = ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$yi, p = pa_list)

                    ## Deal with vgy data
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$vi <- convert_vard_to_varr(d = mean_dtpa, var = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$yi, p = pa_list)
               }else{
                    ## Deal with true-score data
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$vi <- convert_vard_to_varr(d = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$yi,
                                                                                                              var = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_latentY$yi, p = pa_list)

                    ## Deal with vgx data
                    ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$vi <- convert_vard_to_varr(d = ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$yi,
                                                                                                                var = ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$individual_correction$observedGroup_latentY$yi, p = pa_list)

                    ## Deal with vgy data
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$vi <- convert_vard_to_varr(d = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$yi,
                                                                                                                var = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$vi, p = pa_list)
                    ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$yi <- .convert_d_to_r(d = ma_obj_i$escalc[[1]]$individual_correction$latentGroup_observedY$yi, p = pa_list)
               }

               ## Convert meta-analytic tables
               ma_obj_i$meta_tables[[1]]$individual_correction$latentGroup_latentY <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$individual_correction$latentGroup_latentY,
                                                                                                       p_vec = pa_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$individual_correction$observedGroup_latentY <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$individual_correction$observedGroup_latentY,
                                                                                                   p_vec = pa_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
               ma_obj_i$meta_tables[[1]]$individual_correction$latentGroup_observedY <- .convert_metatab(ma_table = ma_obj_i$meta_tables[[1]]$individual_correction$latentGroup_observedY,
                                                                                                   p_vec = pa_vec, conf_level = conf_level, cred_level = cred_level, conf_method = conf_method, cred_method = cred_method)
          }

     }

     ## Re-define class of converted object
     if(any(ma_metric == "r_as_r") | any(ma_metric == "d_as_r")){

          names_ic <- names(ma_obj_i$meta_tables[[1]]$individual_correction)
          names_ad <- names(ma_obj_i$meta_tables[[1]]$artifact_distribution)

          if(!is.null(names_ic)){
               names(ma_obj_i$meta_tables[[1]]$individual_correction)[names_ic == correction_names_r[1]] <- correction_names_d[1]
               names(ma_obj_i$meta_tables[[1]]$individual_correction)[names_ic == correction_names_r[2]] <- correction_names_d[2]
               names(ma_obj_i$meta_tables[[1]]$individual_correction)[names_ic == correction_names_r[3]] <- correction_names_d[3]

               names(ma_obj_i$escalc[[1]]$individual_correction)[names_ic == correction_names_r[1]] <- correction_names_d[1]
               names(ma_obj_i$escalc[[1]]$individual_correction)[names_ic == correction_names_r[2]] <- correction_names_d[2]
               names(ma_obj_i$escalc[[1]]$individual_correction)[names_ic == correction_names_r[3]] <- correction_names_d[3]
          }

          if(!is.null(names_ad)){
               names(ma_obj_i$meta_tables[[1]]$artifact_distribution)[names_ad == correction_names_r[1]] <- correction_names_d[1]
               names(ma_obj_i$meta_tables[[1]]$artifact_distribution)[names_ad == correction_names_r[2]] <- correction_names_d[2]
               names(ma_obj_i$meta_tables[[1]]$artifact_distribution)[names_ad == correction_names_r[3]] <- correction_names_d[3]
          }

     }else{

          names_ic <- names(ma_obj_i$meta_tables[[1]]$individual_correction)
          names_ad <- names(ma_obj_i$meta_tables[[1]]$artifact_distribution)

          if(!is.null(names_ic)){
               names(ma_obj_i$meta_tables[[1]]$individual_correction)[names_ic == correction_names_d[1]] <- correction_names_r[1]
               names(ma_obj_i$meta_tables[[1]]$individual_correction)[names_ic == correction_names_d[2]] <- correction_names_r[2]
               names(ma_obj_i$meta_tables[[1]]$individual_correction)[names_ic == correction_names_d[3]] <- correction_names_r[3]

               names(ma_obj_i$escalc[[1]]$individual_correction)[names_ic == correction_names_d[1]] <- correction_names_r[1]
               names(ma_obj_i$escalc[[1]]$individual_correction)[names_ic == correction_names_d[2]] <- correction_names_r[2]
               names(ma_obj_i$escalc[[1]]$individual_correction)[names_ic == correction_names_d[3]] <- correction_names_r[3]
          }

          if(!is.null(names_ad)){
               names(ma_obj_i$meta_tables[[1]]$artifact_distribution)[names_ad == correction_names_d[1]] <- correction_names_r[1]
               names(ma_obj_i$meta_tables[[1]]$artifact_distribution)[names_ad == correction_names_d[2]] <- correction_names_r[2]
               names(ma_obj_i$meta_tables[[1]]$artifact_distribution)[names_ad == correction_names_d[3]] <- correction_names_r[3]
          }

     }

     ma_obj_i
}

#' Convert the dichotomous variable variance to a proportion
#'
#' \loadmathjax
#' Converts the variance of a dichotomous variable (i.e., \mjseqn{pq}) to the proportion of one of the categories in the variable (i.e., \mjseqn{p})
#'
#' @param pq The variance of a dichotomous variable.
#'
#' @return The proportion of cases in one of the dichotomous groups.
#'
#' @keywords internal
convert_pq_to_p <- function(pq){
     if(any(pq > .25)) stop("Supplied 'pq' value is not a valid dichotomous variance", call. = FALSE)
     .5 * (1 - sqrt(1 - 4 * pq))
}


convert_r_to_d <- function(r, p = .5){
     if(any(abs(r) > 1)) stop("Value supplied for r is not a correlation", call.=FALSE)
     (sqrt(1 / (p * (1-p))) * r) / sqrt(1 - r^2)
}

.convert_r_to_d <- function(r, p = .5){
     ## Ensure that d will be defined
     r[abs(r) > .99] <- sign(r[abs(r) > .99]) * .99
     (sqrt(1 / (p * (1-p))) * r) / sqrt(1 - r^2)
}

.convert_d_to_r <- convert_d_to_r <- function(d, p = .5){
     d / sqrt(1 / (p * (1-p)) + d^2)
}

#' Convert the variance of r to the variance of d via TSA
#'
#' @param r Correlation coefficient.
#' @param var Variance of the correlation.
#' @param p Proportion of the dichotomous variable involved in the correlation.
#'
#' @return An approximated variance in the d value metric.
#' @export
#'
#' @keywords internal
convert_varr_to_vard <- function(r, var, p){
     a_1 <- sqrt(1 / (p - p^2)) / (1 - r^2)^(3/2)
     a_1^2 * var
}


#' Convert the SD of r to the SD of d via TSA
#'
#' @param r Correlation coefficient.
#' @param sd Standard deviation of the correlation.
#' @param p Proportion of the dichotomous variable involved in the correlation.
#'
#' @return An approximated standard deviation in the d value metric.
#' @export
#'
#' @keywords internal
convert_sdr_to_sdd <- function(r, sd, p = .5){
     convert_varr_to_vard(r = r, var = sd^2, p = p)^.5
}


#' Convert the variance of d to the variance of r via TSA
#'
#' @param d Standardized mean difference in the d-value metric.
#' @param var Variance of the d value.
#' @param p Proportion of the dichotomous variable involved in the d value.
#'
#' @return An approximated variance in the correlation metric.
#'
#' @keywords internal
convert_vard_to_varr <- function(d, var, p){
     a_1 <- -1 / ((d^2 * (p - 1) * p - 1) * sqrt(d^2 + 1 / (p - p^2)))
     a_1^2 * var
}


#' Convert the SD of d to the SD of r via TSA
#'
#' @param d Standardized mean difference in the d-value metric.
#' @param sd Standard deviation of the d value.
#' @param p Proportion of the dichotomous variable involved in the d value.
#'
#' @return An approximated standard deviation in the correlation metric.
#'
#' @keywords internal
convert_sdd_to_sdr <- function(d, sd, p = .5){
     convert_vard_to_varr(d = d, var = sd^2, p = p)^.5
}


#' Identify meta-analysis type and provide new column names for a meta-analysis
#'
#' @param col_names Column names of a meta-analysis table.
#'
#' @return Meta-analysis type, old column names of table, column names of table after effect-size conversion, and a vector categorizing the types of entries supplied in the table.
#'
#' @keywords internal
.identify_ma_cols <- function(col_names){

     ## Column names from meta-analyses of correlations
     bb_names_r <- c("k", "N", "mean_r", "var_r", "var_e", "var_res", "sd_r", "se_r", "sd_e", "sd_res")
     ad_names_r <- c("k", "N",
                     "mean_r", "var_r", "var_e", "var_art", "var_pre", "var_res", "sd_r", "se_r", "sd_e", "sd_art", "sd_pre", "sd_res",
                     "mean_rho", "var_r_c", "var_e_c", "var_art_c", "var_pre_c", "var_rho", "sd_r_c", "se_r_c", "sd_e_c", "sd_art_c", "sd_pre_c", "sd_rho")
     ic_names_r <- c("k", "N",
                     "mean_r", "var_r", "var_e", "var_res", "sd_r", "se_r", "sd_e", "sd_res",
                     "mean_rho", "var_r_c", "var_e_c", "var_rho", "sd_r_c", "se_r_c", "sd_e_c", "sd_rho")

     ## Column names from meta-analyses of d values
     bb_names_d <- c("k", "N", "mean_d", "var_d", "var_e", "var_res", "sd_d", "se_d", "sd_e", "sd_res")
     ad_names_d <- c("k", "N",
                     "mean_d", "var_d", "var_e", "var_art", "var_pre", "var_res", "sd_d", "se_d", "sd_e", "sd_art", "sd_pre", "sd_res",
                     "mean_delta", "var_d_c", "var_e_c", "var_art_c", "var_pre_c", "var_delta", "sd_d_c", "se_d_c", "sd_e_c", "sd_art_c", "sd_pre_c", "sd_delta")
     ic_names_d <- c("k", "N",
                     "mean_d", "var_d", "var_e", "var_res", "sd_d", "se_d", "sd_e", "sd_res",
                     "mean_delta", "var_d_c", "var_e_c", "var_delta", "sd_d_c", "se_d_c", "sd_e_c", "sd_delta")

     ## Column swap for meta-analyses of correlations
     if(all(bb_names_r %in% col_names)){
          method <- "r_bb"
          old_cols <- bb_names_r
          new_cols <- bb_names_d
          col_type <- c("NA" ,"NA",
                        "es1", "var1", "var1", "var1", "sd1", "se1", "sd1", "sd1",
                        "es3", "es3", "es4", "es4")
     }
     if(all(ic_names_r %in% col_names)){
          method <- "r_ic"
          old_cols <- ic_names_r
          new_cols <- ic_names_d
          col_type <- c("NA", "NA", "es1", "var1", "var1", "var1", "sd1", "se1", "sd1", "sd1",
                        "es2", "var2", "var2", "var2", "sd2", "se2", "sd2", "sd2",
                        "es3", "es3", "es4", "es4")
     }
     if(all(ad_names_r %in% col_names)){
          method <- "r_ad"
          old_cols <- ad_names_r
          new_cols <- ad_names_d
          col_type <- c("NA", "NA",
                        "es1", "var1", "var1", "var1", "var1", "var1", "sd1", "se1", "sd1", "sd1", "sd1", "sd1",
                        "es2", "var2", "var2", "var2", "var2", "var2", "sd2", "se2", "sd2", "sd2", "sd2", "sd2",
                        "es3", "es3", "es4", "es4")
     }

     ## Column swap for meta-analyses of d values
     if(all(bb_names_d %in% col_names)){
          method <- "d_bb"
          old_cols <- bb_names_d
          new_cols <- bb_names_r
          col_type <- c("NA" ,"NA", "es1", "var1", "var1", "var1", "sd1", "se1", "sd1", "sd1",
                        "es3", "es3", "es4", "es4")
     }
     if(all(ic_names_d %in% col_names)){
          method <- "d_ic"
          old_cols <- ic_names_d
          new_cols <- ic_names_r
          col_type <- c("NA", "NA", "es1", "var1", "var1", "var1", "sd1", "se1", "sd1", "sd1",
                        "es2", "var2", "var2", "var2", "sd2", "se2", "sd2", "sd2",
                        "es3", "es3", "es4", "es4")
     }
     if(all(ad_names_d %in% col_names)){
          method <- "d_ad"
          old_cols <- ad_names_d
          new_cols <- ad_names_r
          col_type <- c("NA", "NA", "es1", "var1", "var1", "var1", "var1", "var1", "sd1", "se1", "sd1", "sd1", "sd1", "sd1",
                        "es2", "var2", "var2", "var2", "var2", "var2", "sd2", "se2", "sd2", "sd2", "sd2", "sd2",
                        "es3", "es3", "es4", "es4")
     }
     old_cols[col_type == "var2"]
     old_cols <- c(old_cols, col_names[(length(col_names)-3):length(col_names)])
     new_cols <- c(new_cols, col_names[(length(col_names)-3):length(col_names)])

     list(method = method, old_cols = old_cols, new_cols = new_cols, col_type = col_type)
}


#' Function to convert a meta-analysis of correlations to a meta-analysis of d values or vice-versa (does one table)
#'
#' @param ma_table Meta-analysis table.
#' @param p_vec Vector of proportions associated with the rows of \code{ma_table}.
#' @param conf_level Confidence level to define the width of the confidence interval (default = .95).
#' @param cred_level Credibility level to define the width of the credibility interval (default = .80).
#' @param conf_method Distribution to be used to compute the width of confidence intervals. Available options are "t" for t distribution or "norm" for normal distribution.
#' @param cred_method Distribution to be used to compute the width of credibility intervals. Available options are "t" for t distribution or "norm" for normal distribution.
#'
#' @return Meta-analysis table converted to a new metric
#'
#' @keywords internal
.convert_metatab <- function(ma_table, p_vec = rep(.5, nrow(ma_table)), conf_level = .95, cred_level = .8, conf_method = "t", cred_method = "t"){

     .attributes <- attributes(ma_table)
     .class <- class(ma_table)
     ma_table <- as.data.frame(ma_table, stringsAsFactors = FALSE)
     if(colnames(ma_table)[1] != "k"){
          col1 <- ma_table[,1]
          col1_name <- colnames(ma_table)[1]
          ma_table <- ma_table[,-1]
     }else{
          col1 <- NULL
     }

     col_ids <- .identify_ma_cols(col_names = colnames(ma_table))

     ma_table_subset <- ma_table[,col_ids$old_cols]
     k <- ma_table_subset$k

     es1_col <- which(col_ids$col_type == "es1")
     var1_col <- which(col_ids$col_type == "var1")
     sd1_col <- which(col_ids$col_type == "sd1")
     se1_col <- which(col_ids$col_type == "se1")

     es2_col <- which(col_ids$col_type == "es2")
     var2_col <- which(col_ids$col_type == "var2")
     sd2_col <- which(col_ids$col_type == "sd2")
     se2_col <- which(col_ids$col_type == "se2")

     es3_col <- which(col_ids$col_type == "es3")
     es4_col <- which(col_ids$col_type == "es4")

     if(any(col_ids$method == c("r_bb", "r_ad", "r_ic"))){
          ma_table_subset[,var1_col] <- convert_varr_to_vard(r = matrix(ma_table_subset[,es1_col], length(p_vec), length(var1_col)),
                                                             var = ma_table_subset[,var1_col],
                                                             p = matrix(p_vec, length(p_vec), length(var1_col)))
          ma_table_subset[,sd1_col] <- convert_sdr_to_sdd(r = matrix(ma_table_subset[,es1_col], length(p_vec), length(sd1_col)),
                                                          sd = ma_table_subset[,sd1_col],
                                                          p = matrix(p_vec, length(p_vec), length(sd1_col)))
          ma_table_subset[,es1_col] <- .convert_r_to_d(r = ma_table_subset[,es1_col],
                                                       p = matrix(p_vec, length(p_vec), length(es1_col)))

          ma_table_subset[,se1_col] <- convert_sdr_to_sdd(r = matrix(ma_table_subset[,se1_col], length(p_vec), length(se1_col)),
                                                          sd = ma_table_subset[,se1_col],
                                                          p = matrix(p_vec, length(p_vec), length(se1_col)))

          if(col_ids$method != "r_bb"){
               ma_table_subset[,se2_col] <- convert_sdr_to_sdd(r = matrix(ma_table_subset[,es2_col], length(p_vec), length(se2_col)),
                                                               sd = ma_table_subset[,se2_col],
                                                               p = matrix(p_vec, length(p_vec), length(se2_col)))
               ma_table_subset[,var2_col] <- convert_varr_to_vard(r = matrix(ma_table_subset[,es2_col], length(p_vec), length(var2_col)),
                                                                  var = ma_table_subset[,var2_col],
                                                                  p = matrix(p_vec, length(p_vec), length(var2_col)))
               ma_table_subset[,sd2_col] <- convert_sdr_to_sdd(r = matrix(ma_table_subset[,es2_col], length(p_vec), length(sd2_col)),
                                                               sd = ma_table_subset[,sd2_col],
                                                               p = matrix(p_vec, length(p_vec), length(sd2_col)))
               ma_table_subset[,es2_col] <- .convert_r_to_d(r = ma_table_subset[,es2_col],
                                                            p = matrix(p_vec, length(p_vec), length(es2_col)))
          }

          if(col_ids$method == "r_bb"){
               ma_table_subset[,es3_col] <- confidence(mean = ma_table_subset[,es1_col], se = ma_table_subset[,se1_col], k = k, conf_level = conf_level, conf_method = conf_method)
               ma_table_subset[,es4_col] <- credibility(mean = ma_table_subset[,es1_col], sd = ma_table_subset[,sd1_col[3]], k = k, cred_level = cred_level, cred_method = cred_method)
          }

          if(col_ids$method == "r_ad"){
               ma_table_subset[,es3_col] <- .convert_r_to_d(r = ma_table_subset[,es3_col], p = matrix(p_vec, length(p_vec), length(es3_col)))
               ma_table_subset[,es4_col] <- credibility(mean = ma_table_subset[,es2_col], sd = ma_table_subset[,"sd_rho"], k = k, cred_level = cred_level, cred_method = cred_method)
          }

          if(col_ids$method == "r_ic"){
               ma_table_subset[,es3_col] <- confidence(mean = ma_table_subset[,es2_col], se = ma_table_subset[,se2_col], k = k, conf_level = conf_level, conf_method = conf_method)
               ma_table_subset[,es4_col] <- credibility(mean = ma_table_subset[,es2_col], sd = ma_table_subset[,sd2_col[3]], k = k, cred_level = cred_level, cred_method = cred_method)
          }
     }

     if(any(col_ids$method == c("d_bb", "d_ad", "d_ic"))){
          ma_table_subset[,var1_col] <- convert_vard_to_varr(d = matrix(ma_table_subset[,es1_col], length(p_vec), length(var1_col)),
                                                             var = ma_table_subset[,var1_col],
                                                             p = matrix(p_vec, length(p_vec), length(var1_col)))
          ma_table_subset[,sd1_col] <- convert_sdd_to_sdr(d = matrix(ma_table_subset[,es1_col], length(p_vec), length(sd1_col)),
                                                          sd = ma_table_subset[,sd1_col],
                                                          p = matrix(p_vec, length(p_vec), length(sd1_col)))
          ma_table_subset[,es1_col] <- .convert_d_to_r(d = ma_table_subset[,es1_col],
                                                       p = matrix(p_vec, length(p_vec), length(es1_col)))

          ma_table_subset[,se1_col] <- convert_sdd_to_sdr(d = matrix(ma_table_subset[,se1_col], length(p_vec), length(se1_col)),
                                                          sd = ma_table_subset[,se1_col],
                                                          p = matrix(p_vec, length(p_vec), length(se1_col)))

          if(col_ids$method != "d_bb"){
               ma_table_subset[,se2_col] <- convert_sdd_to_sdr(d = matrix(ma_table_subset[,es2_col], length(p_vec), length(se2_col)),
                                                               sd = ma_table_subset[,se2_col],
                                                               p = matrix(p_vec, length(p_vec), length(se2_col)))
               ma_table_subset[,var2_col] <- convert_vard_to_varr(d = matrix(ma_table_subset[,es2_col], length(p_vec), length(var2_col)),
                                                                  var = ma_table_subset[,var2_col],
                                                                  p = matrix(p_vec, length(p_vec), length(var2_col)))
               ma_table_subset[,sd2_col] <- convert_sdd_to_sdr(d = matrix(ma_table_subset[,es2_col], length(p_vec), length(sd2_col)),
                                                               sd = ma_table_subset[,sd2_col],
                                                               p = matrix(p_vec, length(p_vec), length(sd2_col)))
               ma_table_subset[,es2_col] <- .convert_d_to_r(d = ma_table_subset[,es2_col],
                                                            p = matrix(p_vec, length(p_vec), length(es2_col)))
          }

          if(col_ids$method == "d_bb"){
               ma_table_subset[,es3_col] <- confidence(mean = ma_table_subset[,es1_col], se = ma_table_subset[,se1_col], k = k, conf_level = conf_level, conf_method = conf_method)
               ma_table_subset[,es4_col] <- credibility(mean = ma_table_subset[,es1_col], sd = ma_table_subset[,sd1_col[3]], k = k, cred_level = cred_level, cred_method = cred_method)
          }

          if(col_ids$method == "d_ad"){
               ma_table_subset[,es3_col] <- .convert_d_to_r(d = ma_table_subset[,es3_col], p = matrix(p_vec, length(p_vec), length(es3_col)))
               ma_table_subset[,es4_col] <- credibility(mean = ma_table_subset[,es2_col], sd = ma_table_subset[,"sd_delta"], k = k, cred_level = cred_level, cred_method = cred_method)
          }

          if(col_ids$method == "d_ic"){
               ma_table_subset[,es3_col] <- confidence(mean = ma_table_subset[,es2_col], se = ma_table_subset[,se2_col], k = k, conf_level = conf_level, conf_method = conf_method)
               ma_table_subset[,es4_col] <- credibility(mean = ma_table_subset[,es2_col], sd = ma_table_subset[,sd2_col[3]], k = k, cred_level = cred_level, cred_method = cred_method)
          }
     }

     ma_table[,col_ids$old_cols] <- ma_table_subset
     colnames(ma_table)[colnames(ma_table) %in% col_ids$old_cols] <- col_ids$new_cols
     .attributes$names <- col_ids$new_cols

     if(any(col_ids$method == c("r_bb", "r_ad", "r_ic"))){
          .attributes$ma_type <- gsub(x = col_ids$method, pattern = "r_", replacement = "d_")
     }else if(any(col_ids$method == c("d_bb", "d_ad", "d_ic"))){
          .attributes$ma_type <- gsub(x = col_ids$method, pattern = "d_", replacement = "r_")
     }

     if(!is.null(col1)){
          .colnames <- c(col1_name, colnames(ma_table))
          ma_table <- cbind(col1, ma_table)
          .attributes$names <- .colnames
     }

     ma_table <- fix_df(ma_table)
     attributes(ma_table) <- .attributes
     class(ma_table) <- .class

     ma_table
}

Try the psychmeta package in your browser

Any scripts or data that you put into this service are public.

psychmeta documentation built on Jan. 18, 2022, 9:06 a.m.