R/metameandiff.b.R

In kylehamilton/JamoviMeta: Meta-Analysis for JAMOVI

# This file is a generated template, your changes will not be overwritten

metaMeanDiffClass <- if (requireNamespace('jmvcore')) R6::R6Class(
    "metaMeanDiffClass",
    inherit = metaMeanDiffBase,
    private = list(
        .run = function() {
          n1i <- self$options$n1i
          m1i <- self$options$m1i
          sd1i <- self$options$sd1i
          n2i <- self$options$n2i
          m2i <- self$options$m2i
          sd2i <- self$options$sd2i
          mods <- self$options$moderatorcor
          slab <- self$options$slab
          includemods <- self$options$includemods
          addcred <- self$options$addcred
          addfit <- self$options$addfit
          showweights <- self$options$showweights
          level <- self$options$level
          fsntype <- self$options$fsntype
          method2 <- self$options$methodmetacor
          mdmseasure <- self$options$cormeasure
          yaxis <- self$options$yaxis
          table <- self$results$textRICH
          
          
          ready <- TRUE
          if (is.null(self$options$n1i) || is.null(self$options$m1i) || is.null(self$options$sd1i) || is.null(self$options$n2i) || is.null(self$options$m2i) || is.null(self$options$sd2i) == TRUE){
            
            ready <- FALSE
            # I really need to think of a better error message this is a place holder until I figure something out
            jmvcore::reject("Sample Size, Mean, Standard Deviation and Study Label fields must be populated to run analysis", code='')
          }
          if (ready == TRUE) {
            
            if (self$options$includemods == TRUE) {
              data <- data.frame(n1i = self$data[[self$options$n1i]], m1i = self$data[[self$options$m1i]], sd1i = self$data[[self$options$sd1i]], n2i = self$data[[self$options$n2i]],  m2i = self$data[[self$options$m2i]], sd2i = self$data[[self$options$sd2i]], mods = self$data[[self$options$moderatorcor]], slab = self$data[[self$options$slab]])
              data[[n1i]] <- jmvcore::toNumeric(data[[n1i]])
              data[[m1i]] <- jmvcore::toNumeric(data[[m1i]])
              data[[sd1i]] <- jmvcore::toNumeric(data[[sd1i]])
              data[[n2i]] <- jmvcore::toNumeric(data[[n2i]])
              data[[m2i]] <- jmvcore::toNumeric(data[[m2i]])
              data[[sd2i]] <- jmvcore::toNumeric(data[[sd2i]])
              data[[mods]] <- jmvcore::toNumeric(data[[mods]])
            } else {
              data <- data.frame(n1i = self$data[[self$options$n1i]], m1i = self$data[[self$options$m1i]], sd1i = self$data[[self$options$sd1i]], n2i = self$data[[self$options$n2i]], m2i = self$data[[self$options$m2i]], sd2i = self$data[[self$options$sd2i]], slab = self$data[[self$options$slab]])
              data[[n1i]] <- jmvcore::toNumeric(data[[n1i]])
              data[[m1i]] <- jmvcore::toNumeric(data[[m1i]])
              data[[sd1i]] <- jmvcore::toNumeric(data[[sd1i]])
              data[[n2i]] <- jmvcore::toNumeric(data[[n2i]])
              data[[m2i]] <- jmvcore::toNumeric(data[[m2i]])
              data[[sd2i]] <- jmvcore::toNumeric(data[[sd2i]])
            }
            
            if (self$options$includemods == TRUE) {
              res <- metafor::rma(n1i=n1i, n2i=n2i, m1i=m1i, m2i=m2i, sd1i=sd1i, sd2i=sd2i, mods=mods, method=method2, measure=mdmseasure, data=data, slab=slab, level=level)
            } else {
              res <- metafor::rma(n1i=n1i, n2i=n2i, m1i=m1i, m2i=m2i, sd1i=sd1i, sd2i=sd2i, method=method2, measure=mdmseasure, data=data, slab=slab, level=level)
            }
            
            
            #Pub Bias
            failsafePB <- metafor::fsn(yi=res$yi, vi=res$vi, type=fsntype)
            ranktestPB <- metafor::ranktest(res)
            regtestPB <- metafor::regtest(res)
            
            
            fsnRICH <- self$results$pubBias$fsnRICH
            
            fsnRICH$setRow(rowNo=1, values=list(
              failSafeNumber=failsafePB$fsnum[1],
              p=failsafePB$pval[1]
            ))
            fsnTitle <- paste("Fail-Safe N Analysis (File Drawer Analysis)")
            fsnNote <- paste("Fail-safe N Calculation Using the ",fsntype," Approach", sep="")
            fsnRICH$setTitle(title=fsnTitle)
            fsnRICH$setNote("fsnNoteTable",fsnNote)
            
            rankRICH <- self$results$pubBias$rankRICH
            rankRICH$setRow(rowNo=1, values=list(
              rankTau=ranktestPB$tau[1],
              p=ranktestPB$pval[1]
            ))
            
            regRICH <- self$results$pubBias$regRICH
            regRICH$setRow(rowNo=1, values=list(
              Z=regtestPB$zval[1],
              p=regtestPB$pval[1]
            ))
            
            #Model Fit 
            modelFitRICH <- self$results$modelFitRICH
            modelFitRICH$setRow(rowNo=1, values=list(
              label="Maximum-Likelihood",
              loglikelihood=res$fit.stats[1,1],
              deviance=res$fit.stats[2,1],
              AIC=res$fit.stats[3,1],
              BIC=res$fit.stats[4,1],
              AICc=res$fit.stats[5,1]
            ))        
            
            
            modelFitRICH$setRow(rowNo=2, values=list(
              label="Restricted Maximum-Likelihood",
              loglikelihood=res$fit.stats[1,2],
              deviance=res$fit.stats[2,2],
              AIC=res$fit.stats[3,2],
              BIC=res$fit.stats[4,2],
              AICc=res$fit.stats[5,2]
            ))
            
            #fit statistics and information criteria
            #Show if checked, hide if unchecked
            if (self$options$showModelFit == TRUE) {
              modelFitRICH$setVisible(visible=TRUE)
            } else {
              modelFitRICH$setVisible(visible=FALSE)
            }
            
            #Pub Bias Connections
            #self$results$pubBias$fsn$setContent(failsafePB)
            #self$results$pubBias$rank$setContent(ranktestPB)
            #self$results$pubBias$reg$setContent(regtestPB)
            
            #Data Prep: Results Table
            CILB <- round(res$ci.lb[1], 3)
            CIUB <- round(res$ci.ub[1], 3)
            ciLBUB <- paste(CILB,"-",CIUB)
      
            
            table$setRow(rowNo=1, values=list(
              Intercept="Intercept",
              Estimate=as.numeric(res$b[1]),
              se=res$se[1],
              CILow=res$ci.lb[1],
              CIHigh=res$ci.ub[1],
              p=res$pval[1],
              Z=res$zval[1],
              k=res$k
            ))
            
            if (self$options$methodmetacor == "DL"){
              tau2EstimatorName = "DerSimonian-Laird"
            } else if (self$options$methodmetacor == "HE"){
              tau2EstimatorName = "Hedges"
            } else if (self$options$methodmetacor == "HS"){
              tau2EstimatorName = "Hunter-Schmidt"
            } else if (self$options$methodmetacor == "SJ"){
              tau2EstimatorName = "Sidik-Jonkman"
            } else if (self$options$methodmetacor == "ML"){
              tau2EstimatorName = "Maximum-Likelihood"
            } else if (self$options$methodmetacor == "REML"){
              tau2EstimatorName = "Restricted Maximum-Likelihood"
            } else if (self$options$methodmetacor == "EB"){
              tau2EstimatorName = "Empirical Bayes"
            } else if (self$options$methodmetacor == "PM"){
              tau2EstimatorName = "Paule-Mandel"
            }
            
            if (self$options$includemods == TRUE){
              titleMix <- paste("Mixed-Effects Model (k = ",res$k,")",sep="")
              titleMixNote <- paste("Tau\u00B2 Estimator: ",tau2EstimatorName, sep="")
              table$setTitle(title=titleMix)
              table$setNote("mixnote",titleMixNote)
            } else if (self$options$methodmetacor == "FE"){
              titleFix <- paste("Fixed-Effects Model (k = ",res$k,")",sep="")
              table$setTitle(title=titleFix)
              
            } else {
              titleRan <- paste("Random-Effects Model (k = ",res$k,")",sep="")
              titleRanNote <- paste("Tau\u00B2 Estimator: ",tau2EstimatorName, sep="")
              table$setTitle(title=titleRan)
              table$setNote("rannote",titleRanNote)
            }
            
            if (self$options$includemods == TRUE) {
              
              modCILB <- round(res$ci.lb[2], 3)
              modCIUB <- round(res$ci.ub[2], 3)
              
              table$setRow(rowNo=2, values=list(
                Intercept="Moderator",
                Estimate=as.numeric(res$b[2]),
                se=res$se[2],
                CILow=res$ci.lb[2],
                CIHigh=res$ci.ub[2],
                p=res$pval[2],
                Z=res$zval[2],
                k=res$k
              ))
              
            } else {
              table$setRow(rowNo=2, values=list(
                Intercept=" ",
                Estimate=NULL,
                se=NULL,
                CILow=NULL,
                CIHigh=NULL,
                p=NULL,
                Z=NULL,
                k=NULL   
              ))
            }
            
            #Data Prep: Heterogeneity Stats
            tauSquared <- round(res$tau2, 4)
            tauSquaredSE <- round(res$se.tau2, 4)
            tauSqCombind <- paste(tauSquared,"(SE=",tauSquaredSE,")")
            tauOnly <- round(sqrt(res$tau2), 4)
            ISquStat <- paste(round(res$I2, 2),"%",sep="")
            HSquStat <- round(res$H2, 4)
            
            if (self$options$includemods == TRUE) {
              RSquStat <- paste(round(res$R2, 2),"%",sep="")
            } else {
              RSquStat <- NULL
            }
            
            #Data Prep: Heterogeneity Test
            QTestStatDF <- round(res$k - 1, 4)
            
            #Heterogeneity Stats annd Test Table
            tableTauSqaured <- self$results$tableTauSqaured
            tableTauSqaured$setRow(rowNo=1, values=list(
              tauSqComb=tauSqCombind,
              tauSQRT=tauOnly,
              ISqu=ISquStat,
              HSqu=HSquStat,
              RSqu=RSquStat,
              QallDF=QTestStatDF,
              Qall=res$QE,
              QallPval=res$QEp
            )) 
            
            
            
            # `self$data` contains the data
            # `self$options` contains the options
            # `self$results` contains the results object (to populate)
            image <- self$results$plot
            imageFUN <- self$results$funplot
            
            image$setState(res)
            imageFUN$setState(res)
            
            # }}))
          }},
        #Forest Plot Function
        .plot=function(image, ...) {  # <-- the plot function
          plotData <- image$state
          #StudyID <- self$options$studylabels
          #yi <- self$options$yi
          #vi <- self$options$vi
          #res <- metafor::rma(yi=yi, vi=vi, data=self$data)
          addcred <- self$options$addcred
          addfit <- self$options$addfit
          level <- self$options$level
          showweights <- self$options$showweights
          xlab <- self$options$xAxisTitle
          order <- self$options$forestOrder
          ready <- TRUE
          if (is.null(self$options$n1i) || is.null(self$options$m1i) || is.null(self$options$sd1i) || is.null(self$options$n2i) || is.null(self$options$m2i) || is.null(self$options$sd2i) == TRUE){
            #if (is.null(self$options$rcor) == TRUE){
            
            ready <- FALSE
          }
          if (ready == TRUE) {
            
            #plot <- metafor::forest(plotData$yi, plotData$vi, addcred=addcred, addfit=addfit)
            plot <- metafor::forest(plotData, addcred=addcred, addfit=addfit, level=level, showweights=showweights, xlab=xlab, order=order)
            print(plot)
            TRUE}
        },
        #Funnel Plot Function
        .funplot=function(imageFUN, ...) {  # <-- the plot function
          plotDataFUN <- imageFUN$state
          yaxis <- self$options$yaxis
          yaxisInv <- self$options$yaxisInv
          enhancePlot <- self$options$enhanceFunnel
          ready <- TRUE
          if (is.null(self$options$n1i) || is.null(self$options$m1i) || is.null(self$options$sd1i) || is.null(self$options$n2i) || is.null(self$options$m2i) || is.null(self$options$sd2i) == TRUE){
            #if (is.null(self$options$rcor) == TRUE){
            
            ready <- FALSE
          }
          if (ready == TRUE) {
            
            if (self$options$yaxisInv == TRUE) {
              if (self$options$enhanceFunnel == TRUE) {
                yaxisTrans <- paste(yaxis,"nv",sep="")
                plotFUN <- metafor::funnel(plotDataFUN,yaxis=yaxisTrans,level=c(90, 95, 99), shade=c("white", "gray", "darkgray"))
              } else {
                yaxisTrans <- paste(yaxis,"nv",sep="")
                plotFUN <- metafor::funnel(plotDataFUN,yaxis=yaxisTrans)
              }
              
            } else {
              if (self$options$enhanceFunnel == TRUE) {
                plotFUN <- metafor::funnel(plotDataFUN,yaxis=yaxis,level=c(90, 95, 99), shade=c("white", "gray", "darkgray"))
              } else {
                plotFUN <- metafor::funnel(plotDataFUN,yaxis=yaxis)
              }
            }
            print(plotFUN)
            TRUE}
        })
)