Nothing
#' Make a table with correlation
#'
#' @param fit An object of class lavaan. Result of sem function of package lavaan
#' @export
corTable=function(fit){
data=fit@Data@X[[1]]
colnames(data)=fit@Data@ov$name
data=data.frame(data)
data
result=mycor(data)
result
resp=p2asterisk(result$p)
res=paste0(sprintf("%.2f",result$r),resp)
res=matrix(res,ncol(result$r))
res[upper.tri(res)]=""
res[row(res)==col(res)]<-"1"
rownames(res)=colnames(data)
colnames(res)=colnames(data)
res=as.data.frame(res)
# str(res)
res
values=unique(as.vector(resp))
temp=""
if("***" %in% values) temp=pastecolon(temp,"***p<0.001")
if("**" %in% values) temp=pastecolon(temp,"**p<0.01")
if("*" %in% values) temp=pastecolon(temp,"*p<0.05")
attr(res,"footer")=temp
res
}
#' Make a table with correlation
#'
#' @param fit An object of class lavaan. Result of sem function of package lavaan
#' @param vanilla Logical. If true, vanilla.table is returned
#' @param addFooter Logical. If true, footer added
#' @param seek string to look for
#' @param replace A string of replacement
#' @importFrom rrtable df2flextable
#' @importFrom flextable align color add_footer merge_at
#' @export
corTable2=function(fit,vanilla=TRUE,addFooter=FALSE,seek=NULL,replace=NULL){
res=corTable(fit)
if(!is.null(seek)){
for(i in seq_along(seek)) {
colnames(res)[colnames(res)==seek[i]]=replace[i]
rownames(res)[rownames(res)==seek[i]]=replace[i]
}
}
Table=rrtable::df2flextable(res,vanilla=vanilla,add.rownames=TRUE)
Table=flextable::align(Table,align="center",part="all")
Table=flextable::color(Table,i=1,j=1,color=ifelse(vanilla,"white","#5B7778"),part="header")
if(addFooter){
Table<-flextable::add_footer(Table,rowname=attr(res,"footer"))
Table<-flextable::merge_at(Table,j=1:(ncol(res)+1),part="footer")
Table=flextable::align(Table,align="right",part="footer")
}
Table
}
#' paste two character with colon
#' @param temp a character
#' @param x a character
pastecolon=function(temp,x){
if(temp=="") res=x
else res=paste0(temp," ; ",x)
res
}
#' Convert p values to asterisk
#' @param x a numeric vector or matrix
p2asterisk=function(x){
ifelse(x<0.001,"***",ifelse(x<0.01,"**",ifelse(x<0.05,"*","")))
}
#'Extract model fit measures to data.frame
#'
#' @param fit An object of class lavaan. Result of sem function of package lavaan
#' @param digits integer indicating the number of decimal places to be used.
#' @param names names of statistic to be extracted
#'
#' @importFrom lavaan fitMeasures
#' @export
#' @return A data.frame
modelFitTable=function(fit,digits=2,names=NULL){
# digits=2;names=NULL
if(is.null(names)) {
names=c("chisq","df","pvalue","cfi","gfi","agfi","tli","rmr","srmr","rmsea","rmsea.ci.lower","rmsea.ci.upper","aic","bic")
newnames=c("chisq","df","p","CFI","GFI","AGFI","TLI","RMR","SRMR","RMSEA","lower","upper","AIC","BIC")
}
names
value=fitMeasures(fit)[names]
value
res=data.frame(rbind(value))
if(!is.null(newnames)) colnames(res)=newnames
rownames(res)="statistic"
res$x2df=res$chisq/res$df
res=round(res,digits)
res$RMSEA=paste0(res$RMSEA,"(",res$lower,"-",res$upper,")")
colnames(res)[10]="RMSEA(95% CI)"
res=res[c(1,2,15,3:10,13,14)]
res
}
#'Extract model fit measures to flextable
#'@param fit An object of class lavaan. Result of sem function of package lavaan
#'@param vanilla Logical
#'@param ... Further arguments to be passed to modelFitTable()
#'@export
modelFitTable2=function(fit,vanilla=FALSE,...){
result=modelFitTable(fit,...)
df2flextable(result,vanilla=vanilla)
}
#'convert parameterEstimates to data.frame
#'
#' @param fit An object of class lavaan. Result of sem function of package lavaan
#' @param latent whether the latent variables be included in result
#' @param regression whether the regressions be included in result
#' @param mediation whether the mediation effects be included in result
#' @param covar whether the covariances be included in result
#' @param ci If TRUE, confidence intervals are added to the output
#' @param standardized Logical. If TRUE, standardized estimates are added to the output
#' @param digits integer indicating the number of decimal places to be used.
#'
#' @export
estimatesTable=function(fit,latent=TRUE,regression=TRUE,mediation=FALSE,covar=FALSE,ci=FALSE,standardized=TRUE,digits=2){
# latent=TRUE;regression=TRUE;mediation=FALSE;covar=FALSE;ci=TRUE;standardized=TRUE;digits=2
# cat("digits=",digits,"\n")
result=parameterEstimates(fit,ci=ci,standardized=standardized)
result
if(mediation){
result=result[result$label!="",]
result=result[-c(2)]
} else{
include=c()
if(latent) include=c(include,"=~")
if(regression) include=c(include,"~")
if(covar) include=c(include,"~~")
result=result[result$op %in% include,]
#result=result[-c(2,4)]
result=result[-c(2)]
}
no=ncol(result)
result=result[-c(no-2,no)]
result
if(ci){
result$est=paste0(round(result$est,digits),"(",round(result$ci.lower,digits),"-",round(result$ci.upper,digits),")")
no=ncol(result)
result=result[-c(no-1,no-2)]
} else{
result$est=round(result$est,digits)
}
result
result$se=round(result$se,digits)
result$z=round(result$z,digits)
result$std.all=round(result$std.all,digits)
result$pvalue=convertPvalue(result$pvalue)
result
if(mediation){
result$lhs[substr(result$lhs,1,3)=="ind"]="indirect effect"
result$lhs[substr(result$lhs,1,5)=="total"]="total effect"
colnames(result)=c("Variables","Predictors","label","B","SE","z","p","\u03B2")
} else{
colnames(result)=c("Variables","Predictors","label","B","SE","z","p","\u03B2")
}
result[is.na(result)]=""
result
}
#'convert parameterEstimates to flextable
#'@param fit An object of class lavaan. Result of sem function of package lavaan
#'@param vanilla Logical
#'@param digits integer indicating the number of decimal places to be used.
#' @param seek string to look for
#' @param replace A string of replacement
#'@param ... Further arguments to be passed to estimatesTable()
#'@export
estimatesTable2=function(fit,vanilla=TRUE,digits=3,seek=NULL,replace=NULL,...){
result=estimatesTable(fit,digits=digits,...)
if(!is.null(seek)){
for(i in seq_along(seek)){
result$Predictors[result$Predictors==seek[i]]=replace[i]
}
}
df2flextable(result,vanilla=vanilla,digits=digits)
}
#' convert vector of p values to string
#'
#' @param x vector of p values
convertPvalue=function(x){
x=sprintf("%0.3f",x)
x[x=="NA"]=""
x[x=="0.000"]="< 0.001"
x
}
#' Draw correlation plot
#'
#' @param fit An object of class lavaan. Result of sem function of package lavaan
#' @param label if 0, no label(default), if 1, use r value as label, if 2, use r value with significant mark as label
#' @param yreverse Logical. if true, reverse the order of y axis.
#' @param xangle axis.x.text.angle
#' @param seek string to look for
#' @param replace A string of replacement
#' @param ... Further arguments to be passed on to geom_text
#'
#' @export
#'
#' @return A ggplot
corPlot=function(fit,label=2,yreverse=TRUE,xangle=45,seek=NULL,replace=NULL,...){
data=fit@Data@X[[1]]
colnames(data)=fit@Data@ov$name
data=data.frame(data)
data
if(!is.null(seek)) {
for(i in seq_along(seek)) {
colnames(data)[colnames(data)==seek[i]]=replace[i]
}
}
ggCor(data=data,label=label,yreverse=yreverse,xangle=xangle)
}
#' Make a Cronbach alpha table
#' @param fit An object of class lavaan. Result of sem function of package lavaan
#' @param digits integer indicating the number of decimal places to be used.
#'
#' @importFrom psych alpha
#' @importFrom stringr str_flatten
#' @export
fit2alpha=function(fit,digits=3){
df=as.data.frame(fit@ParTable,stringsAsFactors = FALSE)
df=df[df$op=="=~",c("lhs","rhs")]
latentVars=unique(df$lhs)
indicators=c()
data=fit@Data@X[[1]]
fit@Data@X[[1]]
colnames(data)=fit@Data@ov$name
data=data.frame(data)
data
alpha<-lambda6<-c()
for(i in seq_along(latentVars)){
vars=df$rhs[df$lhs==latentVars[i]]
indicators=c(indicators,stringr::str_flatten(vars,"+"))
data[vars]
result=psych::alpha(data[vars],warnings=FALSE)
alpha=c(alpha,result$total$raw_alpha)
lambda6=c(lambda6,result$total$`G6(smc)`)
}
alpha=round(alpha,digits)
lambda6=round(lambda6,digits)
data.frame(latentVars,indicators,alpha,lambda6,stringsAsFactors = FALSE)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.