#' Summarize the moderated mediation
#' @param semfit An object of class lavaan
#' @param mod name of moderator
#' @param values Optional. Numeric vector
#' @param boot.ci.type Type of bootstrapping interval. Choices are c("norm","basic","perc",bca.simple")
#' @param add.range logical Whether or not add range
#' @importFrom lavaan parameterEstimates
#' @export
#' @return A data.frame and an object of class modmedSummary
#' @examples
#' require(lavaan)
#' labels=list(X="frame",M="justify",Y="donate",W="skeptic")
#' moderator=list(name="skeptic",site=list(c("a","c")))
#' model=tripleEquation(labels=labels,moderator=moderator)
#' cat(model)
#' \donttest{
#' semfit=sem(model,data=disaster,se="boot",bootstrap=100)
#' modmedSummary(semfit)
#' conditionalEffectPlot(semfit,data=disaster)
#' labels=list(X="dysfunc",M="negtone",Y="perform",W="negexp")
#' moderator=list(name="negexp",site=list("b"))
#' model=tripleEquation(labels=labels,moderator=moderator,data=teams,rangemode=2)
#' cat(model)
#' semfit=sem(model,data=teams,se="boot",bootstrap=100)
#' summary(semfit)
#' modmedSummary(semfit)
#' conditionalEffectPlot(semfit,data=teams)
#' }
modmedSummary=function(semfit,mod=NULL,values=NULL,boot.ci.type="perc",add.range=TRUE){
# boot.ci.type="perc";mod=NULL;values=NULL;add.range=TRUE
res=parameterEstimates(semfit,boot.ci.type = boot.ci.type,
level = .95, ci = TRUE,
standardized = FALSE)
res=res[res$label!="",]
res
if(is.null(mod)){
mod=res$lhs[str_detect(res$label,"mean")][1]
mod
}
if(is.null(values)){
# values1=res$est[res$label==paste0(mod,".mean")]+c(0,-1,1)*sqrt(res$est[res$label==paste0(mod,".var")])
values1=extractRange(res,mod=mod)
values1=unique(values1)
values1
} else{
values1=values
}
values1
# select=c("indirect","indirect.below","indirect.above")
selected=which(str_detect(res$lhs,"indirect"))
selected
if(length(values1)==2){
selected3=selected[str_detect(res$lhs[selected],"above|below")]
} else{
selected3=selected
}
selected3
indirect=res$est[selected3]
lower=res$ci.lower[selected3]
upper=res$ci.upper[selected3]
indirectp=res$pvalue[selected3]
selected1=which(str_detect(res$lhs,"direct"))
selected2=setdiff(selected1,selected)
selected2
if(length(values1)==2){
selected4=selected2[str_detect(res$lhs[selected2],"above|below")]
} else{
selected4=selected2
}
selected4
direct=res$est[selected4]
lowerd=res$ci.lower[selected4]
upperd=res$ci.upper[selected4]
#
# se=res$se[selected]
directp=res$p[selected4]
indirect
lower
direct
values=as.numeric(values1)
if(length(values)==2){
values=rep(values,length(indirect)/length(values))
}
df=data.frame(values=as.numeric(values1),indirect,lower,upper,indirectp,direct,lowerd,upperd,directp)
df
nrow(df)
if(nrow(df)%%3==0){
select=c(2,1,3)
count=nrow(df)/3
select2=c()
for(i in 1:count) {
select2=c(select2,select+(i-1)*3)
}
select2
df=df[select2,]
}
df[]=round(df,3)
attr(df,"mod")=mod
df
if(is.null(values1)) {
selected=which(str_detect(res$lhs,"indirect"))
selected1=selected[!str_detect(res$lhs[selected],"\\.a") & !str_detect(res$lhs[selected],"\\.b")]
indirect=res$rhs[selected1]
indirect=str_replace_all(indirect,paste0(mod,".mean"),"W")
selected1=which(str_detect(res$lhs,"direct"))
selected2=setdiff(selected1,selected)
selected3=selected2[!str_detect(res$lhs[selected2],"\\.a") & !str_detect(res$lhs[selected2],"\\.b")]
selected3
direct=res$rhs[selected3]
direct=str_replace_all(direct,paste0(mod,".mean"),"W")
} else{
selected=which(str_detect(res$lhs,"indirect"))
selected1=selected[!str_detect(res$lhs[selected],"\\.a") & !str_detect(res$lhs[selected],"\\.b")]
indirect=res$rhs[selected1]
indirect
if(str_detect(indirect,paste0(mod,".mean"))) {
indirect=str_replace_all(indirect,paste0(mod,".mean"),"W")
} else{
temp=as.character(values1[1])
indirect=str_replace_all(indirect,temp,"W")
}
selected1=which(str_detect(res$lhs,"direct"))
selected2=setdiff(selected1,selected)
selected3=selected2[!str_detect(res$lhs[selected2],"\\.a") & !str_detect(res$lhs[selected2],"\\.b")]
selected3
direct=res$rhs[selected3]
direct
if(str_detect(direct,paste0(mod,".mean"))) {
direct=str_replace_all(direct,paste0(mod,".mean"),"W")
} else{
temp=as.character(values1[1])
direct=str_replace_all(direct,temp,"W")
}
}
if(nrow(df)%%3==0){
if(count>1){
df$label=paste0("D",rep(1:count,each=3))
if(add.range==FALSE){
values=df$values[1:3]
df1=data.frame(W=values)
for(i in 1:count){
temp=df$indirect[((i-1)*3+1):((i-1)*3+3)]
df1=cbind(df1,temp)
}
for(i in 1:count){
temp=df$direct[((i-1)*3+1):((i-1)*3+3)]
df1=cbind(df1,temp)
}
colnames(df1)=c("W",paste0("indirectD",1:count),paste0("directD",1:count))
df=df1
}
}
} else{
count=nrow(df)/length(values1)
indirect=indirect[1:count]
direct=direct[1:count]
df$label=rep(paste0("M",1:count),each=length(values1))
}
attr(df,"indirect")=indirect
attr(df,"direct")=direct
attr(df,"boot.ci.type")=boot.ci.type
if((count>1) &(add.range==FALSE)){
class(df)=c("modmedSummary2","data.frame")
} else{
class(df)=c("modmedSummary","data.frame")
}
df
}
#'Extract range from a data.frame
#'@param res A data.frame
#'@param mod Name of moderator
#'@param what string
extractRange=function(res,mod,what="indirect"){
select=str_detect(res$lhs,what)
res1=res[select,c(1,3)]
temp=res1$rhs
temp
result=extractNumber(temp)
result
if(length(result)>0) {
values=result
} else{
values=res$est[res$label==paste0(mod,".mean")]+c(0,-1,1)*sqrt(res$est[res$label==paste0(mod,".var")])
}
values=unique(values)
values
}
#' extract number from string
#' @param x a string
#' @export
extractNumber=function(x){
result=c()
for(i in seq_along(x)){
temp=x[i]
# temp=str_replace_all(temp,"\\(|\\)","")
# temp=unlist(str_split(temp,"\\+|\\*|-"))
# temp
# select=which(str_detect(temp,"^[0-9|\\.].*"))
#
temp=str_replace_all(temp,"\\(|\\)","")
temp=unlist(str_split(temp,"\\+|\\*"))
select=which(str_detect(temp,"^[0-9|\\.|-].*"))
if(length(select)>0) {
result=c(result,temp[select])
}
}
result
}
#' Print a string in right alignment
#' @param string A string
#' @param width A numeric
#' @export
rightPrint=function(string,width){
str_pad(string,width,side="left")
}
#'S3 method print for an object of class modmedSummary
#'@param x An object of class modmedSummary
#'@param ... additional arguments to pass to print.modmedSummary
#'@export
print.modmedSummary=function(x,...){
count=nrow(x)
x[]=lapply(x,myformat)
x[[5]]=pformat(x[[5]])
x[[9]]=pformat(x[[9]])
mod=paste0(attr(x,"mod"),"(W)")
indirect=paste0(attr(x,"indirect"),collapse="/")
direct=paste0(attr(x,"direct"),collapse="/")
left=max(nchar(mod)+2,8)
addlabel=FALSE
if(nrow(x)>3) addlabel=TRUE
total=73+left+ifelse(addlabel,7,0)
cat("\nInference for the Conditional Direct and Indirect Effects - boot.ci.type:",attr(x,"boot.ci.type"),"\n")
cat(paste(rep("=",total),collapse = ""),"\n")
cat(centerPrint("",left),ifelse(addlabel," ",""),
centerPrint("Indirect Effect",35),centerPrint("Direct Effect",35),"\n")
cat(centerPrint("",left),ifelse(addlabel," ",""),
centerPrint(indirect,35),centerPrint(direct,35),"\n")
cat(centerPrint("",left),ifelse(addlabel," ",""),
paste(rep("-",35),collapse = ""),paste(rep("-",36),collapse = ""),"\n")
templabel=" X "
if(sum(str_detect(x$label,"M1"))>0) templabel=" M "
cat(centerPrint(mod,left),ifelse(addlabel,templabel,""),centerPrint("estimate",8),centerPrint("95% Bootstrap CI",18),centerPrint("p",8))
cat(centerPrint("estimate",11),centerPrint("95% Bootstrap CI",18),centerPrint("p",8),"\n")
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in 1:count){
cat(rightPrint(x[i,1],left-1),"")
if(addlabel) cat(rightPrint(x[i,"label"],6))
cat(rightPrint(x[i,2],8))
cat(paste0(rightPrint(x[i,3],8)," to ",rightPrint(x[i,4],6)))
cat(rightPrint(x[i,5],8))
cat(rightPrint(x[i,6],13))
cat(paste0(rightPrint(x[i,7],8)," to ",rightPrint(x[i,8],6)))
cat(rightPrint(x[i,9],8),"\n")
}
cat(paste(rep("=",total),collapse = ""),"\n")
}
#' Make a table summarizing the moderated mediation
#' @param x An object of class modmedSummary or class lavaan
#' @param vanilla A logical
#' @param showP logical
#' @param ... Further arguments to be passed to modmedSummary
#' @importFrom flextable bg vline add_footer_lines
#' @export
modmedSummaryTable=function(x,vanilla=TRUE,showP=FALSE,...){
if("lavaan" %in% class(x)){
x=modmedSummary(x,...)
}
count=nrow(x)
addlabel=FALSE
if(count>3) {
addlabel=TRUE
mode=1
if(sum(str_detect(x$label,"M1"))>0) mode<-2
}
x[]=lapply(x,myformat)
x[[5]]=pformat(x[[5]])
x[[9]]=pformat(x[[9]])
x1=x
if(vanilla){
x1$s=""
x1$ci=paste0("(",x1$lower," to ",x1$upper,")")
x1$ci2=paste0("(",x1$lowerd," to ",x1$upperd,")")
if(addlabel){
x1=x1[c(1,10,2,12,5,11,6,13,9)]
} else{
x1=x1[c(1:2,11,5,10,6,12,9)]
}
class(x1)="data.frame"
x1
if(!showP) {
if(addlabel) x1<-x1[-c(5,9)]
else x1<-x1[-c(4,8)]
}
ft=rrtable::df2flextable(x1,vanilla=TRUE,digits=3)
ft
if(showP){
if(addlabel){
temp=ifelse(mode==1,"X","M")
hlabel=c(paste0(attr(x,"mod"),"(W)"),temp,"estimate","95% Bootstrap CI","p","","estimate","95% Bootstrap CI","p")
} else{
hlabel=c(paste0(attr(x,"mod"),"(W)"),"estimate","95% Bootstrap CI","p","","estimate","95% Bootstrap CI","p")
}
} else{
if(addlabel){
temp=ifelse(mode==1,"X","M")
hlabel=c(paste0(attr(x,"mod"),"(W)"),temp,"estimate","95% Bootstrap CI","","estimate","95% Bootstrap CI")
} else{
hlabel=c(paste0(attr(x,"mod"),"(W)"),"estimate","95% Bootstrap CI","","estimate","95% Bootstrap CI")
}
}
hlabel
col_keys=colnames(x1)
hlabel<-setNames(hlabel,col_keys)
hlabel=as.list(hlabel)
hlabel
ft<-ft %>% set_header_labels(values=hlabel)
ft
if(showP){
if(addlabel){
ft<-ft %>% width(j=c(4,8),width=1.6) %>% width(j=6,width=0.1)
} else{
ft<-ft %>% width(j=c(3,7),width=1.6) %>% width(j=5,width=0.1)
}
} else{
if(addlabel){
ft<-ft %>% width(j=c(4,7),width=1.6) %>% width(j=5,width=0.1)
} else{
ft<-ft %>% width(j=c(3,6),width=1.6) %>% width(j=4,width=0.1)
}
}
big_border=fp_border(color="black",width=2)
noP=ifelse(showP,0,1)
if(addlabel){
temp=ifelse(mode==1,"D","M")
indirect= paste0(temp,1:length(attr(x,"indirect")),":",attr(x,"indirect"))
indirect=paste0(indirect,collapse="\n")
direct= paste0(temp,1:length(attr(x,"direct")),":",attr(x,"direct"))
direct=paste0(direct,collapse="\n")
hlabel=c("","",paste0("Indirect Effect\n",indirect),"",
paste0("Direct Effect\n",direct))
hlabel
ft
ft<- ft %>%
hline_top(part="header",border=fp_border(color="black",width=0)) %>%
add_header_row(top=TRUE,values=hlabel,colwidths=c(1,1,3-noP,1,3-noP)) %>%
hline_top(part="header",border=big_border) %>%
hline(i=1,j=3:(5-noP),part="header",border=fp_border(color="black",width=1))%>%
hline(i=1,j=(7-noP):(9-noP*2),part="header",border=fp_border(color="black",width=1)) %>%
merge_h_range (i=1,j1=3,j2=5-noP,part="header") %>%
merge_h_range (i=1,j1=(7-noP),j2=(9-noP*2),part="header") %>%
align(align="center",part="all") %>%
align(align="right",part="body") %>%
align(j=2,align="right",part="body") %>%
fontsize(size=12,part="header") %>%
bold(part="header") %>% width(j=1,width=1)
if(showP) ft<-ft %>%italic(i=2,j=c(5,9),italic=TRUE,part="header")
} else{
hlabel=list(values="",
indirect=paste0("Indirect Effect\n",attr(x,"indirect")),s="",
direct=paste0("Direct Effect\n",attr(x,"direct")))
ft<-ft %>%
hline_top(part="header",border=fp_border(color="black",width=0)) %>%
add_header_row(top=TRUE,values=hlabel,colwidths=c(1,3-noP,1,3-noP)) %>%
hline_top(part="header",border=big_border) %>%
hline(i=1,j=2:(4-noP),part="header",border=fp_border(color="black",width=1)) %>%
hline(i=1,j=(6-noP):(8-noP*2),part="header",border=fp_border(color="black",width=1)) %>%
merge_h_range (i=1,j1=2,j2=(4-noP),part="header") %>%
merge_h_range (i=1,j1=(6-noP),j2=(8-noP*2),part="header") %>%
align(align="center",part="all") %>%
align(align="right",part="body") %>%
fontsize(size=12,part="header") %>%
bold(part="header") %>%
width(j=1,width=1)
if(showP) ft<-ft %>% italic(i=2,j=c(4,8),italic=TRUE,part="header")
ft
}
} else{
x1$ci=paste0("(",x1$lower," to ",x1$upper,")")
x1$ci2=paste0("(",x1$lowerd," to ",x1$upperd,")")
if(addlabel){
x1=x1[c(1,10,2,11,5,6,12,9)]
} else{
x1=x1[c(1,2,10,5,6,11,9)]
}
ft=rrtable::df2flextable(x1,vanilla=FALSE,digits=3)
ft
if(addlabel){
temp=ifelse(mode==1,"X","M")
hlabel=c(paste0(attr(x,"mod"),"(W)"),temp,"estimate","95% Bootstrap CI","p","estimate","95% Bootstrap CI","p")
} else{
hlabel=c(paste0(attr(x,"mod"),"(W)"),"estimate","95% Bootstrap CI","p","estimate","95% Bootstrap CI","p")
}
hlabel
col_keys=colnames(x1)
hlabel<-setNames(hlabel,col_keys)
hlabel=as.list(hlabel)
hlabel
ft<-ft %>% set_header_labels(values=hlabel)
ft
if(addlabel){
ft<-ft %>% width(j=c(4,7),width=1.6) %>% width(j=6,width=0.1)
} else{
ft<-ft %>% width(j=c(3,6),width=1.6) %>% width(j=5,width=0.1)
}
big_border=fp_border(color="black",width=2)
if(addlabel){
indirect= paste0("D",1:length(attr(x,"indirect")),":",attr(x,"indirect"))
indirect=paste0(indirect,collapse="/")
direct= paste0("D",1:length(attr(x,"direct")),":",attr(x,"direct"))
direct=paste0(direct,collapse="/")
temp=ifelse(mode==1,"X","M")
hlabel=c(paste0(attr(x,"mod"),"(W)"),temp,paste0("Indirect Effect\n",indirect),
paste0("Direct Effect\n",direct))
hlabel
ft<- ft %>%
hline_top(part="header",border=fp_border(color="black",width=0)) %>%
add_header_row(top=TRUE,values=hlabel,colwidths=c(1,1,3,3)) %>%
hline_top(part="header",border=big_border) %>%
hline(i=1,j=3:5,part="header",border=fp_border(color="black",width=1))%>%
hline(i=1,j=6:8,part="header",border=fp_border(color="black",width=1))
ft<-ft %>%
merge_h_range (i=1,j1=3,j2=5,part="header") %>%
merge_h_range (i=1,j1=6,j2=8,part="header") %>%
align(align="center",part="all") %>%
align(align="right",part="body") %>%
fontsize(size=12,part="header") %>%
bold(part="header") %>%
italic(i=2,j=c(5,8),italic=TRUE,part="header")
ft<-ft %>% color(i=1,j=1:8,color="white",part="header") %>%
bg(i=1,j=1:8,bg="#5B7778",part="header") %>%
merge_at(i=1:2,j=1,part="header") %>%
merge_at(i=1:2,j=2,part="header")
ft<-ft %>% vline(i=1:2,border=fp_border(color="white"),part="header") %>%
hline(i=1:2,border=fp_border(color="white"),part="header") %>%
width(j=1,width=1)
} else{
hlabel=list(values=paste0(attr(x,"mod"),"(W)"),
indirect=paste0("Indirect Effect\n",attr(x,"indirect")),
direct=paste0("Direct Effect\n",attr(x,"direct")))
ft<- ft %>%
hline_top(part="header",border=fp_border(color="black",width=0)) %>%
add_header_row(top=TRUE,values=hlabel,colwidths=c(1,3,3)) %>%
hline_top(part="header",border=big_border) %>%
hline(i=1,j=2:4,part="header",border=fp_border(color="black",width=1))%>%
hline(i=1,j=5:7,part="header",border=fp_border(color="black",width=1))
ft<-ft %>%
merge_h_range (i=1,j1=2,j2=4,part="header") %>%
merge_h_range (i=1,j1=5,j2=7,part="header") %>%
align(align="center",part="all") %>%
align(align="right",part="body") %>%
fontsize(size=12,part="header") %>%
bold(part="header") %>%
italic(i=2,j=c(4,7),italic=TRUE,part="header")
ft<-ft %>% color(i=1,j=1:7,color="white",part="header") %>%
bg(i=1,j=1:7,bg="#5B7778",part="header") %>%
merge_at(i=1:2,j=1,part="header")
ft<-ft %>% vline(i=1:2,border=fp_border(color="white"),part="header") %>%
hline(i=1:2,border=fp_border(color="white"),part="header") %>%
width(j=1,width=1)
}
}
ft<-ft %>% add_footer_lines(paste0("boot.ci.type = ",attr(x,"boot.ci.type") )) %>%
align(align="right",part="footer")
ft
}
#' Summarize the mediation effects
#' @param semfit An object of class lavaan
#' @param boot.ci.type Type of bootstrapping interval. Choices are c("norm","basic","perc",bca.simple","all")
#' @param effects Names of effects to be summarized
#' @importFrom purrr map_df
#' @export
#' @return A data.frame and an object of class medSummary
#' @examples
#' library(lavaan)
#' labels=list(X="cond",M="pmi",Y="reaction")
#' model=tripleEquation(labels=labels)
#' \donttest{
#' semfit=sem(model=model,data=pmi, se="boot", bootstrap=100)
#' medSummary(semfit)
#' medSummary(semfit,boot.ci.type="all")
#' }
medSummary=function(semfit,boot.ci.type="perc",effects=c("indirect","direct")){
if(boot.ci.type!="all"){
res=parameterEstimates(semfit,boot.ci.type = boot.ci.type,
level = .95, ci = TRUE,
standardized = FALSE)
res
select=which(str_detect(res$label,"CE|direct|total|prop|ind|Contrast"))
res=res[select,c(1,3,5,9,10,8)]
names(res)[1:2]=c("Effect","equation")
attr(res,"boot.ci.type")=boot.ci.type
attr(res,"se")=semfit@Options$se
class(res)=c("medSummary","data.frame")
res
} else{
# effects=c("indirect","direct","total")
count=length(effects)
type=c("norm","basic","perc","bca.simple")
result=list()
for(i in 1:4){
res=parameterEstimates(semfit,boot.ci.type = type[i],
level = .95, ci = TRUE,
standardized = FALSE)
res=res[res$label %in% effects,c(1,3,5,9,10,8)]
res$type=type[i]
result[[i]]=res
}
df1=purrr::map_df(result,rbind)
df1
equation=df1$rhs[1:count]
equation
df=list()
for(i in seq_along(effects)){
df[[i]]=df1[df1$lhs==effects[i],]
}
df
df=lapply(1:count,function(i){
df[[i]][3:6]})
df
df2=purrr::reduce(df,cbind)
df2
temp=c("est","lower","upper","p")
colnames(df2)=paste0(rep(temp,count),".",rep(effects,each=4))
df2$type=type
df2 <- df2 %>% select(type,everything())
attr(df2,"effects")<-effects
attr(df2,"equations")<-equation
attr(df2,"se")=semfit@Options$se
class(df2)=c("medSummary2","data.frame")
#str(df2)
df2
}
}
#'S3 method print for an object of class medSummary
#'@param x An object of class medSummary
#'@param ... additional arguments to pass to print.medSummary
#'@export
print.medSummary=function(x,...){
count=nrow(x)
x[]=lapply(x,myformat)
x[[6]]=pformat(x[[6]])
tempnames=c("Effect","Equation","est","95% Bootstrap CI","p")
if(attr(x,"se")=="standard") tempnames[4]="95% CI"
widthEffect=max(nchar(x$Effect))+2
widthEq=max(nchar(x$equation))+2
width=c(widthEffect,widthEq,8,19,8)
total=sum(width)
cat(centerPrint("Summary of Mediation Effects",total),"\n")
cat(paste(rep("=",total),collapse = ""),"\n")
cat(" ")
for(i in seq_along(tempnames)){
cat(centerPrint(tempnames[i],width[i]))
}
cat("\n")
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in 1:nrow(x)){
cat(centerPrint(x[i,1],width[1]))
cat(centerPrint(x[i,2],width[2]))
cat(rightPrint(x[i,3],width[3]))
cat(rightPrint(paste0("(",x[i,4]," to ",x[i,5],")"),width[4]))
cat(rightPrint(x[i,6],width[5]))
cat("\n")
}
cat(paste(rep("=",total),collapse = ""),"\n")
if(attr(x,"se")!="standard") cat(rightPrint(paste0("boot.ci.type: ",attr(x,"boot.ci.type")),total))
cat("\n")
}
#'S3 method print for an object of class medSummary2
#'@param x An object of class medSummary
#'@param ... additional arguments to pass to print.medSummary
#'@export
print.medSummary2=function(x,...){
count=(ncol(x)-1)/4
count
df=x
df[]=lapply(df,myformat)
for(i in 1:count){
df[[1+i*4]]=pformat(df[[1+i*4]])
}
for(i in 1:count){
df[[paste0("ci",i)]]=paste0("(",df[[3+(i-1)*4]]," to ",df[[4+(i-1)*4]],")")
}
df
select=c(1)
for(i in 1:count){
select=c(select,2+(i-1)*4,count*4+1+i,5+(i-1)*4)
}
df=df[select]
df
if(attr(x,"se")=="standard") temp=rep(c("estimate","95% CI","p"),count)
else temp=rep(c("estimate","95% Bootstrap CI","p"),count)
colnames(df)=c("type",temp)
width=c(12,rep(c(8,22,8),count))
colwidth=38
total=sum(width)
cat(centerPrint("Summary of Mediation Effects",total),"\n")
cat(paste(rep("=",total),collapse = ""),"\n")
cat(centerPrint("",12))
for(i in 1:count){
cat(centerPrint(attr(x,"effects")[i],colwidth))
}
cat("\n")
cat(centerPrint("",11))
for(i in 1:count){
cat(centerPrint(attr(x,"equations")[i],colwidth))
}
cat("\n",centerPrint("",12))
for(i in 1:count) cat(paste(rep("-",colwidth),collapse = ""))
cat("\n ")
for(i in seq_along(colnames(df))){
cat(centerPrint(colnames(df)[i],width[i]))
}
cat("\n")
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in 1:nrow(df)){
for(j in 1:ncol(df)) {
cat(centerPrint(df[i,j],width[j]))
}
cat("\n")
}
cat(paste(rep("=",total),collapse = ""),"\n")
cat("\n")
}
#' Make a table summarizing the mediation effects
#' @param x An object of class medSummary or medSummary2 or lavaan
#' @param vanilla A logical
#' @param ... Further arguments to be passed to medSummary
#' @export
medSummaryTable=function(x,vanilla=TRUE,...){
if("lavaan" %in% class(x)){
x=medSummary(x,...)
}
if("medSummary2" %in% class(x)){
medSummaryTable2(x,vanilla=vanilla)
} else{
medSummaryTable1(x,vanilla=vanilla)
}
}
#' Make a table summarizing the mediation effects
#' @param x An object of class medSummary
#' @param vanilla A logical
#' @param showP A logical
#' @importFrom flextable autofit
#' @export
medSummaryTable1=function(x,vanilla=TRUE,showP=FALSE){
df=x
df[]=lapply(df,myformat)
df[[6]]=pformat(df[[6]])
df$ci=paste0("(",df$ci.lower," to ",df$ci.upper,")")
df<-df %>% select(c(1,2,3,7,6))
colnames(df)[2:5]=c("Equation","estimate","95% Bootstrap CI","p")
if(attr(x,"se")=="standard") colnames(df)[4]="95% CI"
if(!showP){
df=df[-5]
}
table=df2flextable(df,vanilla=vanilla)
table<-table %>% width(j=4,width=2) %>%
align(j=c(1,2,4),align="center",part="body") %>%
fontsize(size=12,part="header") %>%
bold(part="header")
if(showP) table<-table %>% italic(i=1,j=c(5),italic=TRUE,part="header")
if(attr(x,"se")!="standard") {
table <- table %>%
add_footer_lines(paste0("boot.ci.type = ",attr(x,"boot.ci.type") )) %>%
align(align="right",part="footer")
}
table %>%
autofit()
}
#' Make a table summarizing the mediation effects
#' @param x An object of class medSummary2
#' @param vanilla A logical
#' @importFrom flextable autofit
#' @export
medSummaryTable2=function(x,vanilla=TRUE){
count=(ncol(x)-1)/4
count
df=x
class(df)="data.frame"
df[]=lapply(df,myformat)
for(i in 1:count){
df[[1+i*4]]=pformat(df[[1+i*4]])
}
for(i in 1:count){
df[[paste0("ci",i)]]=paste0("(",df[[3+(i-1)*4]]," to ",df[[4+(i-1)*4]],")")
}
if(vanilla){
for(i in 1:count){ df[[paste0("s",i)]]=""}
select=c(1)
for(i in 1:count){
select=c(select,2+(i-1)*4,count*4+1+i,5+(i-1)*4)
if(i<count) select=c(select,which(colnames(df)==paste0("s",i)))
}
df=df[select]
df
if(attr(x,"se")=="standard") temp=rep(c("estimate","95% CI","p",""),count)
else temp=rep(c("estimate","95% Bootstrap CI","p",""),count)
temp=c("type",temp[-length(temp)])
temp
table=rrtable::df2flextable(df,vanilla=vanilla)
table
col_keys=colnames(df)
hlabel<-setNames(temp,col_keys)
hlabel=as.list(hlabel)
hlabel
table<-table %>% set_header_labels(values=hlabel)
hlabel=list(type="",
est.indirect=paste0("Indirect Effect\n",attr(x,"equations")[1]),
s1="",
est.direct=paste0("Direct Effect\n",attr(x,"equations")[2]))
big_border=fp_border(color="black",width=2)
table<-table %>%
hline_top(part="header",border=fp_border(color="black",width=0)) %>%
add_header_row(top=TRUE,values=hlabel,colwidths=c(1,3,1,3)) %>%
hline_top(part="header",border=big_border) %>%
hline(i=1,j=6,part="header",border=fp_border(color="black",width=1))%>%
hline(i=1,j=2,part="header",border=fp_border(color="black",width=1)) %>%
width(j=c(5),width=0.01)
table<-table %>%
align(j=c(1),align="center",part="body") %>%
align(align="center",part="header") %>%
fontsize(size=12,part="header") %>%
bold(part="header") %>%
italic(i=2,j=c(4,7),italic=TRUE,part="header") %>%
width(j=c(3,7),width=2) %>%
align(j=c(3,7),align="center",part="all")
} else{
# vanilla=FALSE
select=c(1)
for(i in 1:count){
select=c(select,2+(i-1)*4,count*4+1+i,5+(i-1)*4)
}
df=df[select]
df
temp=rep(c("estimate","95% Bootstrap CI","p"),count)
if(attr(x,"se")=="standard") temp[2]="95% CI"
temp =c("type",temp)
table=rrtable::df2flextable(df,vanilla=vanilla)
table
col_keys=colnames(df)
hlabel<-setNames(temp,col_keys)
hlabel=as.list(hlabel)
hlabel
table<-table %>% set_header_labels(values=hlabel)
table
hlabel=list(type="type",
est.indirect=paste0("Indirect Effect\n",attr(x,"equations")[1]),
est.direct=paste0("Direct Effect\n",attr(x,"equations")[2]))
big_border=fp_border(color="black",width=2)
table<-table %>%
add_header_row(top=TRUE,values=hlabel,colwidths=c(1,3,3))
table<-table %>%
align(j=c(1),align="center",part="body") %>%
align(align="center",part="header") %>%
fontsize(size=12,part="header") %>%
bold(part="header") %>%
italic(i=2,j=c(4,7),italic=TRUE,part="header") %>%
width(j=c(3,6),width=2)
table<-table %>% color(i=1,j=1:7,color="white",part="header") %>%
bg(i=1,j=1:7,bg="#5B7778",part="header") %>%
merge_at(i=1:2,j=1,part="header")
table
table<-table %>% vline(i=1:2,border=fp_border(color="white"),part="header") %>%
hline(i=1:2,border=fp_border(color="white"),part="header") %>%
width(j=1,width=1) %>%
align(j=c(3,6),align="center",part="all")
}
table
}
#'S3 method print for an object of class modmedSummary2
#'@param x An object of class modmedSummary2
#'@param ... additional arguments to pass to print.modmedSummary2
#'@export
print.modmedSummary2=function(x,...){
if("lavaan" %in% class(x)){
x=modmedSummary(x,add.range=FALSE,...)
}
count=ncol(x)
indirect=attr(x,"indirect")
direct=attr(x,"direct")
cnames=c(indirect,direct)
add=str_replace(unlist(strsplit(indirect[1],"\\)\\*\\("))[2],"\\)","")
add
cnames2=c(paste0("\u03B8","D",1:((count-1)/2),"->","Y"),
paste0("\u03B8","D",1:((count-1)/2),"->","M*(",add,")"))
width=max(nchar(cnames),nchar(cnames2))
total=5+(count-1)*(width+1)
cat(paste(rep("=",total),collapse = ""),"\n")
cat(centerPrint("",5),centerPrint("Indirect Effect",width*2),centerPrint("Direct Effect",width*2),"\n")
cat(" ",paste(rep("-",width*2),collapse = "")," ",paste(rep("-",width*2),collapse = ""),"\n")
cat(centerPrint("W",5),centerPrint(cnames2,width),"\n")
cat(" ",rep(paste(rep("-",width),collapse = ""),4),"\n")
cat(centerPrint("",5),centerPrint(cnames,width),"\n")
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in 1:nrow(x)){
cat(rightPrint(sprintf("%0.3f",x[i,1]),5))
for(j in 2:count){
cat(rightPrint(sprintf("%0.3f",x[i,j]),width))
}
cat("\n")
}
cat(paste(rep("-",total),collapse = ""),"\n")
}
#' make table summarizing moderated mediation effect
#' @param x An object of class lavaan or modmedSummary2
#' @param vanilla logical.
#' @param ... Further arguments to be passed to modmedSummary
modmedSummary2Table=function(x,vanilla=TRUE,...){
if("lavaan" %in% class(x)){
x=modmedSummary(x,add.range=FALSE,...)
}
count=ncol(x)
dcount=(count-1)/2
indirect=attr(x,"indirect")
direct=attr(x,"direct")
if(vanilla){
x$s=""
x=x[c(1:3,6,4:5)]
cnames=c("W",indirect,"",direct)
add=str_replace(unlist(strsplit(indirect[1],"\\)\\*\\("))[2],"\\)","")
cnames2=c("W",paste0("\u03B8","D",1:dcount,"->","Y"),"",
paste0("\u03B8","D",1:dcount,"->","M*(",add,")"))
cnames3=c("W","Indirect Effect","","Direct Effect")
} else{
cnames=c("W",indirect,direct)
add=str_replace(unlist(strsplit(indirect[1],"\\)\\*\\("))[2],"\\)","")
cnames2=c("W",paste0("\u03B8","D",1:dcount,"->","Y"),
paste0("\u03B8","D",1:dcount,"->","M*(",add,")"))
cnames3=c("W","Indirect Effect","Direct Effect")
}
ft=df2flextable(x,vanilla=vanilla,digits=3)
ft
col_keys=colnames(x)
hlabel=cnames2
hlabel
hlabel<-setNames(hlabel,col_keys)
hlabel=as.list(hlabel)
hlabel
ft<-ft %>% set_header_labels(values=hlabel)
ft
if(vanilla){
ft<- ft %>% hline_top(part="header",border=fp_border(color="black",width=0)) %>%
add_header_row(top=TRUE,values=cnames,colwidths = rep(1,(count+1))) %>%
add_header_row(top=TRUE,values=cnames3,colwidths = c(1,dcount,1,dcount)) %>%
width(j=c(2,3,5,6),width=1.3) %>%
width(j=4,width=0.01) %>%
align(align="center",part="header") %>%
merge_at(i=1:3,j=1,part="header") %>%
bold(part="header") %>%
fontsize(size=12,part="header") %>%
hline_top(part="header",border=fp_border(color="black",width=2)) %>%
hline(i=1,j=2:3,part="header",border=fp_border(color="black",width=1))%>%
hline(i=1,j=5:6,part="header",border=fp_border(color="black",width=1)) %>%
hline(i=2,j=2,part="header",border=fp_border(color="black",width=1))%>%
hline(i=2,j=3,part="header",border=fp_border(color="black",width=1))%>%
hline(i=2,j=5,part="header",border=fp_border(color="black",width=1))%>%
hline(i=2,j=6,part="header",border=fp_border(color="black",width=1))
} else{
ft<-ft %>%
add_header_row(top=TRUE,values=cnames,colwidths = rep(1,count)) %>%
add_header_row(top=TRUE,values=cnames3,colwidths = c(1,dcount,dcount)) %>%
width(j=c(2:5),width=1.3) %>%
align(align="center",part="header") %>%
merge_at(i=1:3,j=1,part="header") %>%
bold(part="header") %>%
fontsize(size=12,part="all") %>%
color(color="white",part="header") %>%
bg(bg="#5B7778",part="header") %>%
vline(border=fp_border(color="white"),part="header") %>%
hline(border=fp_border(color="white"),part="header")
}
ft
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.