R/statisticalDiagram.R
In cardiomoon/processR: Implementation of the 'PROCESS' Macro
Defines functions
myarrow2
adjustxpos
findName
findNames
adjustNodes
addArrows
addNodes
drawArrows
est2Nodes
est2Arrows
drawStatDiagram
addLatentNodes
extractLatentVar
extractLatentVarName
adjustPosNodes
changeLabelName
statisticalDiagram
fit2table
getArrows
getNodes
Documented in
addArrows
addLatentNodes
addNodes
adjustNodes
adjustPosNodes
adjustxpos
changeLabelName
drawArrows
drawStatDiagram
est2Arrows
est2Nodes
extractLatentVar
extractLatentVarName
findName
findNames
fit2table
getArrows
getNodes
myarrow2
statisticalDiagram
#' Get nodes data with model no
#' @param no model number
getNodes=function(no=25){
res=no
for( i in 1:4) {
res=c(res,moreModels$no1[moreModels$no %in% res])
res=unique(res)
}
res
nodes[nodes$no %in% res,]
}
#' Get arrows data with no
#' @param no model number
getArrows=function(no=25){
res=no
for( i in 1:4) {
res=c(res,moreModels$no1[moreModels$no %in% res])
res=unique(res)
}
res
parrows[parrows$no %in% res,]
}
#' Make estimatesTable with a list of lm object
#' @param fit A list of lm object
#' @param labels A list
#' @param digits integer indicating the number of decimal places
#' @export
#' @examples
#' labels=list(X="frame",M="justify",Y="donate",W="skeptic")
#' moderator=list(name="skeptic",site=list(c("a","c")))
#' eq=tripleEquation(labels=labels,moderator=moderator,data=disaster,mode=1)
#' fit=eq2fit(eq,data=disaster)
#' fit2table(fit=fit,labels=labels)
fit2table=function(fit,labels=labels,digits=3){
count=length(fit)
Y=c()
i=1
for(i in 1:count){
Y=c(Y,names(fit[[i]]$model)[1])
if(i==1) {
df=as.data.frame(summary(fit[[i]])$coef)
df=df[-1,]
df$Predictors=rownames(df)
} else{
temp=as.data.frame(summary(fit[[i]])$coef)
temp=temp[-1,]
temp$Predictors=rownames(temp)
df=rbind(df,temp)
}
}
Y
df
res=modelsSummary2(fit,labels=labels)
class(res)="data.frame"
res
if(count==1){
nrow1=nrow(res)-1
Variables=rep(Y[1],nrow1)
} else if(count>1) {
xcount=unlist(lapply(fit,function(x) {length(x$coef)-1}))
xcount
Variables=c()
for(i in 1:length(Y)){
Variables=c(Variables,rep(Y[i],xcount[i]))
}
}
df$Variables=Variables
res=res[res$name1!="Constant",]
res$label=str_replace(res$name,"'","")
df$label=res$label
colnames(df)[1:4]=c("B","SE","t","p")
df$B=round(df$B,digits=digits)
df$SE=round(df$SE,digits=digits)
df$t=round(df$t,digits=digits)
df
}
#'Draw statistical diagram
#'@param no process macro model number
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param xmargin horizontal margin of plot
#'@param arrowlabel logical whether or not draw arrowlabel
#'@param arrowslabels A character vector
#'@param arrowslty linetype of arrows
#'@param labels A list of character string
#'@param nodeslabels A list of character string
#'@param whatLabel What should the edge labels indicate in the path diagram? Choices are c("est","std","name","label")
#'@param fit A list of class lm or an object of class lavaan
#'@param estimatesTable A data.frame
#'@param digits Integer indicating the number of decimal places
#'@param covar Optional list of covariates
#'@param addCovar Logical. Whether or not include covariates
#'@param type An integer
#'@param includeLatentVars A logical
#'@param addprime logical. Whether or not add prime to label "c"
#'@param box.col fill color of the box
#' @param xlim the x limits (min,max) of the plot
#' @param ylim the y limits (min,max) of the plot
#'@importFrom dplyr left_join
#'@export
#'@examples
#'statisticalDiagram(no=1)
#'covar=list(name=c("posemot","ideology","sex"),site=list(c("Y"),c("Y"),c("Y")))
#'statisticalDiagram(no=1,covar=covar)
#'covar=list(name=c("posemot","ideology","sex"),site=list(c("M","Y"),c("Mi","Y"),c("Mi","Y")))
#'covar=list(name=c("C1","C2"),site=list(c("M","Y"),"Y"))
#'statisticalDiagram(no=4,covar=covar)
#'statisticalDiagram(no=8,covar=covar)
#'labels=list(X="wintense",Mi="cogapp",Y="emotion")
#'nodeslabels=list(X="Work\nIntensity",Mi="Cognitive\nAppraisal",Y="Emotional\nExhaustion")
#'statisticalDiagram(4,labels=labels)
#'statisticalDiagram(4,labels=nodeslabels)
#'statisticalDiagram(4,labels=labels,nodeslabels=nodeslabels)
#'labels=list(X="GDP\nper inhabitant",M="Illiteracy Rate",Y="Mean Life\nExpectation")
#'statisticalDiagram(4,labels=labels)
#'statisticalDiagram(4,labels=labels,arrowslabels=c("e","f","g"),whatLabel="label")
statisticalDiagram=function(no=1,radx=0.10,rady=0.04,xmargin=0.01,arrowlabel=TRUE,arrowslabels=NULL,
arrowslty=NULL,
labels=list(),nodeslabels=list(),whatLabel="name",fit=NULL,
estimatesTable=NULL,
digits=3,covar=list(),addCovar=TRUE,type=NULL,
includeLatentVars=FALSE,addprime=TRUE,box.col="white",xlim=c(0,1),ylim=NULL){
#
# no=4;radx=0.10;rady=0.04;xmargin=0.01;arrowlabel=TRUE;arrowslabels=NULL
# arrowslty=NULL
# labels=list();nodeslabels=list();whatLabel="name";fit=NULL;estimatesTable=NULL
# digits=3;covar=list();addCovar=TRUE;type=NULL
# includeLatentVars=FALSE;addprime=TRUE
# arrowslabels=c("e","f","g");whatLabel="label";ylim=NULL
# covar=list(name=c("C1","C2"),site=list(c("M","Y"),"Y"));xlim=c(0,1);ylim=c(0,1)
# labels=list(X="frame",M="justify",Y="donate",W="skeptic")
# moderator=list(name="skeptic",site=list(c("a","c")))
# covar=NULL
# model=tripleEquation(labels=labels,moderator=moderator,data=disaster,rangemode=2)
# semfit=sem(model,data=disaster)
# fit=semfit;whatLabel="est";no=8
#
#
if(!is.null(fit)) {
if(is.null(estimatesTable)) {
if(inherits(fit,"list")) {
estimatesTable<-fit2table(fit,labels=labels,digits=digits)
} else if(inherits(fit,"lavaan")){
estimatesTable<-estimatesTable(fit,digits=digits)
}
}
}
if(no==1.1) {
nodes=est2Nodes(estimatesTable)
} else {
nodes=getNodes(no)
}
if(no==1.1){
arrows1=est2Arrows(estimatesTable)
} else{
arrows1=getArrows(no)
}
nodes
arrows1
# Add covariates
if(addCovar){
if(no!=1.1) nodes=addNodes(nodes,covar,radx=radx,rady=rady,no=no)
}
# print(nodes)
arrows1
covar
if(no==1.1) {
arrows2=arrows1
} else {
if(addCovar){
arrows2=addArrows(arrows1,covar)
} else{
arrows2=arrows1
}
}
arrows2
# print(arrows)
if( !is.null(estimatesTable)) {
if(no==1.1){
arrows2$Predictors=arrows2$start
} else{
arrows2$Predictors=findNames(labels,names=arrows2$start)
}
arrows2$Variables=findNames(labels,names=arrows2$end)
labels
arrows2
estimatesTable
# temp=c()
# for(i in 1:nrow(estimatesTable)){
# temp=c(temp,names(labels)[str_detect(labels,estimatesTable$Variables[i])])
# }
# temp
# estimatesTable$start=temp
# estimatesTable
arrows2
if(includeLatentVars){
arrows3<-full_join(arrows2,estimatesTable,by=c("Predictors","Variables"))
arrows3
arrows3$no= arrows3$no[1]
arrows3$name[is.na(arrows3$name)]=""
arrows3$start[is.na(arrows3$start)]=arrows3$Predictors[is.na(arrows3$start)]
arrows3$end[is.na(arrows3$end)]=arrows3$Variables[is.na(arrows3$end)]
arrows3$labelpos=0.5
arrows3$arrpos=0.84
arrows3$end=changeLabelName(arrows3$end,labels)
} else{
arrows3<-left_join(arrows2,estimatesTable,by=c("Predictors","Variables"))
}
if(is.null(arrowslty)) {
arrows3$lty=ifelse(arrows3$p<0.05,1,3)
if(whatLabel=="name") arrows3$lty=1
} else{
arrows3$lty=arrowslty
}
# print(arrows3)
} else{
arrows2$lty=1
arrows3<-arrows2
if(!is.null(arrowslty)) arrows3$lty=arrowslty
}
if(arrowlabel){
if(whatLabel=="name") {
arrows3$label=arrows3$name
} else if(whatLabel=="est"){
arrows3$label=arrows3$B
} else if(whatLabel %in% c("label","label2")){
if((!is.null(arrowslabels))&(length(arrowslabels)==nrow(arrows3))){
arrows3$label=arrowslabels
} else{
arrows3$label=""
}
} else{
arrows3$label=arrows3[,ncol(arrows3)-1]
}
} else {
arrows3$label=""
}
if((!is.null(fit))&(includeLatentVars)){
nodes=addLatentNodes(nodes,fit,labels)
nodes=adjustPosNodes(nodes)
}
if(length(labels)>0){
nodes$name=str_replace(nodes$name,"i$","")
arrows3$name=str_replace(arrows3$name,"i$","")
arrows3$start=str_replace(arrows3$start,"i$","")
arrows3$end=str_replace(arrows3$end,"i$","")
arrows3$label=str_replace(arrows3$label,"i$","")
}
# print(nodes)
if(is.null(ylim)) ylim=c(min(nodes$ypos-rady-0.01),max(nodes$ypos+rady+0.01))
if(ylim[1]>0.2) ylim[1]=0.2
if(ylim[2]<0.8) ylim[2]=0.8
if(whatLabel %in% c("est","std","label2")) arrows3$label=as.numeric(arrows3$label)
drawStatDiagram(no=no,arrows=arrows3,nodes=nodes,labels=labels,nodeslabels=nodeslabels,
xmargin=xmargin,radx=radx,rady=rady,fit,addprime=addprime,box.col=box.col,
xlim=xlim,ylim=ylim)
# openplotmat()
#
# drawArrows(arrows3,nodes,xmargin=xmargin,rady=rady,radx=radx)
#
# for(i in 1:nrow(nodes)){
# xpos=nodes$xpos[i]
# xpos=adjustxpos(xpos,xmargin,radx)
# mid=c(xpos,nodes$ypos[i])
#
# # label=ifelse(is.null(labels[[nodes$name[i]]]),nodes$name[i],labels[[nodes$name[i]]])
# label=ifelse(no==1.1,nodes$name[i],findName(labels,nodes$name[i]))
#
# drawtext(mid,radx=radx,rady=rady,lab=label,latent=FALSE)
# if(no==1.1){
# if(i<=nrow(nodes)){
# label=findName(labels,nodes$name[i])
# if(label!=nodes$name[i]) textplain(mid+c(0,-0.07),radx=radx,rady=rady,lab=label,latent=FALSE)
# }
# }
# }
}
#'Change Label Names
#'@param x A character vector
#'@param labels A list
#'@param add A logical
#'@export
#'@examples
#'labels=list(X="frame:test",Mi="empathy",Y="intervention",W="frame",Z="test")
#'x=c("skeptic","test","empathy","skeptic:frame:test","D1:frame","frame:test")
#'changeLabelName(x,labels)
#'changeLabelName(x,labels,add=TRUE)
#'x=c("baby","milk","baby:milk")
#'labels=list(X="baby",M=c("wine","tent","sand"),Y="tile",W="milk")
#'changeLabelName(x,labels)
changeLabelName=function(x,labels,add=FALSE){
res=c()
unlist(labels)
# i=5;add=FALSE
for(i in 1:length(x)){
if(x[i] %in% unlist(labels)){
if(add){
temp=names(unlist(labels))[which(unlist(labels)==x[i])]
res=c(res,paste0(x[i],"(",temp,")"))
} else{
res=c(res,names(unlist(labels))[which(unlist(labels)==x[i])])
}
} else if(str_detect(x[i],":")){
temp=unlist(strsplit(x[i],":"))
temp
temp2=c()
for(j in 1:length(temp)){
temp3=names(unlist(labels))[which(unlist(labels)==temp[j])]
if(length(temp3)==0) temp3=temp[j]
temp2=c(temp2,temp3)
}
temp2
if(length(temp2)>1){
temp2=paste0(temp2,collapse=":")
if(add){
res=c(res,paste0(x[i],"(",temp2,")"))
} else{
res=c(res,temp2)
}
} else{
temp=x[i]
temp
for(j in 1:length(labels)){
if(add) {
temp=str_replace(x[i],labels[[j]],paste0(labels[[j]],"(",names(labels)[j],")"))
} else{
temp=str_replace(x[i],labels[[j]],names(labels)[j])
}
}
temp
res=c(res,temp)
}
} else {
res=c(res,x[i])
}
}
res
}
#'Adjust position of nodes
#'@param nodes A data.frame
adjustPosNodes=function(nodes){
if(min(nodes$xpos)<0){
nodes$xpos[(nodes$xpos<0.3)&(nodes$xpos>=0)]=nodes$xpos[(nodes$xpos<0.3)&(nodes$xpos>=0)]+0.2
nodes$xpos[nodes$xpos<0]=0
}
if(max(nodes$xpos)>1){
nodes$xpos[(nodes$xpos>0.7)&(nodes$xpos<=1)]=nodes$xpos[(nodes$xpos>0.7)&(nodes$xpos<=1)]-0.2
nodes$xpos[nodes$xpos>1]=1
}
nodes
}
#'Extract Latent Variables Names
#'@param fit An object of class lavaan. Result of lavaan::sem()
extractLatentVarName=function(fit){
res=parameterEstimates(fit)
res=res[res$op=="=~",]
unique(res$lhs)
}
#'Extract Latent Variables Data
#'@param fit An object of class lavaan. Result of lavaan::sem()
#'@param labels A list
extractLatentVar=function(fit,labels){
res=parameterEstimates(fit)
res=res[res$op=="=~",]
if(nrow(res)>0){
temp=c()
for(i in 1:nrow(res)){
temp=c(temp,names(labels)[str_detect(labels,res$lhs[i])])
}
temp
res$name=temp
}
res
}
#'Add latent nodes information to nodes
#'@param nodes A data.frame
#'@param fit An object of class lavaan. Result of lavaan::sem()
#'@param labels A list
addLatentNodes=function(nodes,fit,labels){
nodes
res=extractLatentVar(fit,labels)
no<-name<-xpos<-ypos<-c()
yinterval=0.12
count=length(res$name[res$name=="X"])
start=ifelse(count>4,0.1+yinterval*(count-1),nodes$ypos[nodes$name=="X"]+yinterval*(count-1)/2)
ypos=seq(start,by=-yinterval,length.out = count)
no=rep(nodes$no[1],count)
xpos=rep(-0.1,count)
name=res$rhs[res$name=="X"]
df=data.frame(no,name,xpos,ypos,stringsAsFactors = FALSE)
nodes<-rbind(nodes,df)
count=length(res$name[res$name=="Mi"])
start=ifelse(count>4,0.1,nodes$xpos[nodes$name=="Mi"]-0.1*(count-1)/2)
xpos=seq(start,by=0.1,length.out = count)
no=rep(nodes$no[1],count)
ypos=rep(nodes$ypos[nodes$name=="Mi"]+0.1,count)
name=res$rhs[res$name=="Mi"]
df=data.frame(no,name,xpos,ypos,stringsAsFactors = FALSE)
df
nodes<-rbind(nodes,df)
count=length(res$name[res$name=="Y"])
start=ifelse(count>4,0.1+yinterval*(count-1),nodes$ypos[nodes$name=="Y"]+yinterval*(count-1)/2)
ypos=seq(start,by=-yinterval,length.out = count)
no=rep(nodes$no[1],count)
xpos=rep(1.1,count)
name=res$rhs[res$name=="Y"]
df=data.frame(no,name,xpos,ypos,stringsAsFactors = FALSE)
df
nodes<-rbind(nodes,df)
nodes
}
#'draw StatDiagram
#'@param no process macro model number
#'@param arrows A data.frame
#'@param nodes A data.frame
#'@param labels A list
#'@param nodeslabels A list
#'@param xmargin horizontal margin of plot
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param fit An object of class lavaan. Result of lavaan::sem()
#'@param addprime logical Whether add prime to label "c"
#'@param box.col fill color of the box
#' @param xlim the x limits (min,max) of the plot
#' @param ylim the y limits (min,max) of the plot
#'@export
drawStatDiagram=function(no,arrows,nodes,labels,nodeslabels=list(),xmargin,radx,rady,fit=NULL,addprime=TRUE,box.col="white",xlim=c(0,1),ylim=c(0,1)){
# print(nodes)
# print(arrows)
openplotmat(xlim=xlim,ylim=ylim)
drawArrows(arrows,nodes,xmargin=xmargin,rady=rady,radx=radx,addprime=addprime)
LVnames=c()
if(!is.null(fit)) {
if(inherits(fit,"lavaan")) LVnames=extractLatentVarName(fit)
}
for(i in 1:nrow(nodes)){
xpos=nodes$xpos[i]
xpos=adjustxpos(xpos,xmargin,radx)
mid=c(xpos,nodes$ypos[i])
# label=ifelse(is.null(labels[[nodes$name[i]]]),nodes$name[i],labels[[nodes$name[i]]])
label=ifelse(no==1.1,nodes$name[i],findName(labels,nodeslabels=nodeslabels,name=nodes$name[i]))
# label=eval(parse(text=paste0("expression(italic(",label,"))")))
drawtext(mid,radx=radx,rady=rady,lab=label,latent=ifelse(label %in% LVnames,TRUE,FALSE),box.col=box.col)
if(no==1.1){
if(i<=nrow(nodes)){
label=findName(labels,nodeslabels=nodeslabels,name=nodes$name[i])
if(label!=nodes$name[i]) textplain(mid+c(0,-0.07),radx=radx,rady=rady,lab=label,latent=FALSE)
}
}
}
}
#' Make arrows from estimatesTable
#' @param res A data.frame, result of estimatesTable
est2Arrows=function(res){
no=rep(1.1,nrow(res))
name=paste0("b",1:nrow(res))
start=res$Predictors
end=res$Variables
labelpos=rep(0.5,nrow(res))
arrpos=rep(0.84,nrow(res))
data.frame(no,name,start,end,labelpos,arrpos,stringsAsFactors = FALSE)
}
#' Make nodes from estimatesTable
#' @param res A data.frame, result of estimatesTable
#' @param lastxno A numeric
est2Nodes=function(res,lastxno=2){
res
count=nrow(res)-1
count
yinterval=-0.8/(count-1)
start=0.9
y=seq(0.9,by=yinterval,length.out = count)
y
y=c(y,0.1,0.5)
x=c(rep(0,count-1),seq(from=0.05,by=0.1,length.out=2),1)
x
no=rep(1.1,nrow(res)+1)
name=c(res$Predictors,res$Variables[1])
data.frame(no=no,name=name,xpos=x,ypos=y,stringsAsFactors = FALSE)
}
#'Draw arrows
#'@param arrows A data.frame
#'@param nodes A data.frame
#'@param xmargin horizontal margin of plot
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param addprime logical Whether add prime to label "c"
drawArrows=function(arrows,nodes,xmargin=0.01,radx=0.10,rady=0.04,addprime=TRUE){
# print(arrows)
# nodes
for(i in 1:nrow(arrows)){
if(is.na(arrows$lty[i])){
myarrow2(nodes,from=arrows$start[i],to=arrows$end[i],
label=arrows$label[i],no=arrows$no[1],xmargin=xmargin,radx=radx,rady=rady,
label.pos=arrows$labelpos[i],arr.pos=arrows$arrpos[i],addprime=addprime)
} else{
myarrow2(nodes, from=arrows$start[i],to=arrows$end[i],
label=arrows$label[i],no=arrows$no[1],xmargin=xmargin,radx=radx,rady=rady,
label.pos=arrows$labelpos[i],arr.pos=arrows$arrpos[i],lty=arrows$lty[i],addprime=addprime)
}
}
}
#'Add covariates to nodes
#'@param nodes A data.frame
#'@param covar A list of covariates
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param no A numeric
#'@export
addNodes=function(nodes,covar,radx=0.10,rady=0.04,no=NULL){
if(length(covar$name)>0){
if(no==1.1){
}
number<-name<-xpos<-ypos<-c()
minypos=min(nodes$ypos)
maxxpos=min(nodes$xpos[nodes$ypos==minypos])
if(nodes$no[1]==4.2) {
maxxpos=-(radx/2)
minypos=0.4
}
for(i in 1:length(covar$name)){
number=c(number,nodes$no[1])
name=c(name,covar$name[i])
xpos=c(xpos,maxxpos+radx/2*i)
ypos=c(ypos,minypos-(rady*2+0.02)*i)
}
df=data.frame(no=number,name=name,xpos=xpos,ypos=ypos)
nodes=rbind(nodes,df)
nodes=adjustNodes(nodes)
}
nodes
}
#'Add covariates to arrows
#'@param arrows A data.frame
#'@param covar A list of covariates
#'@export
addArrows=function(arrows,covar){
if(length(covar$name)>0){
number<-name<-start<-end<-labelpos<-arrpos<-c()
fcount<-gcount<-1
for(i in 1:length(covar$name)){
for(j in 1:length(covar$site[[i]])){
start=c(start,covar$name[i])
end=c(end,covar$site[[i]][j])
number=c(number,arrows$no[1])
prefix=ifelse(covar$site[[i]][j]=="Y","g","f")
count=ifelse(covar$site[[i]][j]=="Y",gcount,fcount)
name=c(name,paste0(prefix,count))
labelpos=c(labelpos,0.5)
arrpos=c(arrpos,0.84)
if(covar$site[[i]][j]=="Y"){
gcount=gcount+1
} else{
fcount=fcount+1
}
}
}
number
name
start
end[end=="M"]="Mi"
labelpos
arrpos
df=data.frame(no=number,name=name,start=start,end=end,labelpos=labelpos,arrpos=arrpos)
arrows=rbind(arrows,df)
}
if(!("f2" %in% arrows$name)) {
arrows$name[arrows$name=="f1"]="f"
}
if(!("g2" %in% arrows$name)) {
arrows$name[arrows$name=="g1"]="g"
}
arrows
}
#'Adjust y position of nodes
#'@param nodes A data.frame
adjustNodes=function(nodes){
miny=min(nodes$ypos)
if(miny<0.05){
if(miny>=0) {
nodes$ypos=nodes$ypos+0.05
} else{
nodes$ypos=nodes$ypos+0.05-miny
}
}
if(max(nodes$ypos)>0.95) {
nodes$ypos=nodes$ypos*0.95/max(nodes$ypos)
}
nodes
}
#'convert a vector of names with list
#'@param labels A named list
#'@param nodeslabels A named list
#'@param names A character vector to look for
#'@param exact A logical
#'@export
#'@examples
#'labels=list(X="wt",Mi="am",Y="mpg");names=c("X","MiX","Y")
#'findNames(labels,names=names)
findNames=function(labels,nodeslabels=list(),names,exact=FALSE){
result=c()
for(i in 1:length(names)){
result=c(result,findName(labels,nodeslabels=nodeslabels,name=names[i],exact=exact))
}
result
}
#'convert name with list
#'@param labels A named list
#'@param nodeslabels A named list
#'@param name A name to look for
#'@param exact A logical
#'@export
#'@examples
#'labels=list(X="wt",M="am",Y="mpg");name="MiX"
#'nodeslabels=list(X="weight",M="automatic",Y="milepergallon")
#'findName(labels=labels,nodeslabels=nodeslabels,name="MiX")
#'findName(labels=labels,name="MiX")
#'findName(labels=labels,nodeslabels=nodeslabels,name="M")
#'labels=list(X="GDPpp",M="Illit",Y="LifeEx")
#'nodeslabels=list(X="GDP\nper inhabitant",M="Illiteracy Rate",Y="Mean Life\nExpectation")
#'findName(labels=labels,name="Mi")
#'findName(labels=labels,nodeslabels=nodeslabels,name="Mi")
#'labels=list(X="GDPpp",Mi="Illit",Y="LifeEx")
#'nodeslabels=list(X="GDP\nper inhabitant",Mi="Illiteracy Rate",Y="Mean Life\nExpectation")
#'findName(labels=labels,name="M")
#'findName(labels=labels,nodeslabels=nodeslabels,name="M")
#'labels=list(X="cond",M=c("import","pmi"),Y="reaction")
#'findName(labels=labels,name="M1")
findName=function(labels,nodeslabels=list(),name="MiX",exact=FALSE){
# labels=list(X="wt",M="am",Y="mpg")
# nodeslabels=list()
# name="Mi"
# exact=FALSE
#
result=NULL
if(length(labels)==0) {
result=name
} else if(length(nodeslabels)>0){
if(!is.null(nodeslabels[[name]])) {
result=nodeslabels[[name]]
}
if(is.null(result)){
if(name=="Mi"){
result=nodeslabels[["M"]]
} else if(name=="M"){
result=nodeslabels[["Mi"]]
} else if(name=="M1"){
result=nodeslabels[["M"]][1]
} else if(name=="M2"){
result=nodeslabels[["M"]][2]
} else if(name=="M3"){
result=nodeslabels[["M"]][3]
}
}
} else if(name %in% names(labels)) {
if(is.null(result)) result=labels[[name]]
}
if(is.null(result)){
if(name=="Mi"){
if("M" %in% names(labels)) result=labels$M
} else if(name=="M"){
if("Mi" %in% names(labels)) result=labels$Mi
} else if(name=="M1"){
result=labels[["M"]][1]
} else if(name=="M2"){
result=labels[["M"]][2]
} else if(name=="M3"){
result=labels[["M"]][3]
}
}
if(is.null(result)){
if(!exact){
temp=c()
for(i in seq_along(nodeslabels)){
grep(names(nodeslabels)[i],name)
if(length(grep(names(nodeslabels)[i],name))>0)
temp=c(temp,nodeslabels[[names(nodeslabels[i])]])
temp
}
if(length(temp)==0){
for(i in 1:length(labels)){
grep(names(labels)[i],name)
if(length(grep(names(labels)[i],name))>0)
temp=c(temp,labels[[names(labels[i])]])
temp
}
}
temp
if(length(temp)<1) {
result=name
} else{
result=paste0(temp,collapse=":")
}
} else{
result=name
}
}
result
}
#'Adjust x position
#'@param xpos x position
#'@param xmargin horizontal margin of plot
#'@param radx horizontal radius of the box
#'@param xspace numeric. horizontal interval
#'@param mode integer adjust mode
#'@export
adjustxpos=function(xpos,xmargin=0.01,radx=0.12,xspace=NULL,mode=1){
if(is.null(xspace)) xspace=xmargin+2*radx
if(mode==1){
result=ifelse(xpos==0.5,0.5,
ifelse(xpos>0.5,
1-xmargin-radx-(1.0-xpos)*10*xspace,
xmargin+radx+(xpos%/%0.1)*(xmargin+2*radx)+(xpos%%0.1)*10*xspace))
} else{
result=ifelse(((xpos>0.2)|(xpos<0.8)),xpos,
ifelse(xpos>0.5,
1-xmargin-radx-(1.0-xpos)*10*xspace,
xmargin+radx+(xpos%/%0.1)*(xmargin+2*radx)+(xpos%%0.1)*10*xspace))
}
result
}
#' Draw arrow with adjustment of a position
#' @param nodes A data.frame
#' @param from coordinates (x,y) of the point *from* which to draw arrow.
#' @param to coordinates (x,y) of the point *to* which to draw arrow.
#' @param label label to display
#' @param no process macro model number
#' @param radx horizontal radius of the box.
#' @param rady vertical radius of the box.
#' @param xmargin horizontal margin of plot
#' @param label.pos label position
#' @param arr.pos arrow position
#'@param addprime logical Whether add prime to label "c"
#'@param xspace numeric horizontal space between nodes
#'@param mode integer mode for adjustxpos
#' @param ... Further argument to be passed to straightarrow()
myarrow2=function(nodes,from,to,label="",no,radx=0.12,rady=0.04,xmargin=0.01,label.pos=0.5,arr.pos=NULL,addprime=TRUE,xspace=NULL,mode=1,...){
#nodes=nodes[nodes$no==no, ]
# from="X";no=1;to="Y";label="66"
xpos=nodes$xpos[nodes$name==from]
xpos=adjustxpos(xpos,xmargin,radx,xspace=xspace,mode=mode)
ypos=nodes$ypos[nodes$name==from]
start=c(xpos,ypos)
xpos=nodes$xpos[nodes$name==to]
xpos=adjustxpos(xpos,xmargin,radx,xspace=xspace,mode=mode)
ypos=nodes$ypos[nodes$name==to]
end=c(xpos,ypos)
if(!is.numeric(label)){
if(nchar(label)>1) {
if(addprime) {
prime=ifelse(substr(label,1,1)=="c","^minute","")
} else {
prime=""
}
# if(nchar(label==3)){
# temp1=paste0("expression(italic(",substr(label,1,1),")[",substr(label,2,2),"]","[",
# substr(label,3,nchar(label)),"]",prime,")")
#
# } else{
if(!str_detect(label,"\n")){
temp2=substr(label,2,nchar(label))
temp2
temp1=paste0("expression(italic(",substr(label,1,1),")[",temp2,"]",prime,")")
temp1
# }
temp=eval(parse(text=temp1))
label=temp
}
} else if(nchar(label)==1){
if(label=="c") {
if(addprime) {
label=expression(italic(c)^minute)
} else {
label=expression(italic(c))
}
} else {
temp=paste0("expression(italic(",label,"))")
label=eval(parse(text=temp))
}
}
}
myarrow(from=start,to=end,label=label,label.pos=label.pos,arr.pos=arr.pos,radx=radx,rady=rady,...)
# myarrow(from=start,to=end,label=label,label.pos=label.pos,radx=radx,rady=rady,...)
}
cardiomoon/processR documentation built on April 20, 2023, 3:38 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions myarrow2 adjustxpos findName findNames adjustNodes addArrows addNodes drawArrows est2Nodes est2Arrows drawStatDiagram addLatentNodes extractLatentVar extractLatentVarName adjustPosNodes changeLabelName statisticalDiagram fit2table getArrows getNodes
Documented in addArrows addLatentNodes addNodes adjustNodes adjustPosNodes adjustxpos changeLabelName drawArrows drawStatDiagram est2Arrows est2Nodes extractLatentVar extractLatentVarName findName findNames fit2table getArrows getNodes myarrow2 statisticalDiagram
#' Get nodes data with model no
#' @param no model number
getNodes=function(no=25){
res=no
for( i in 1:4) {
res=c(res,moreModels$no1[moreModels$no %in% res])
res=unique(res)
}
res
nodes[nodes$no %in% res,]
}
#' Get arrows data with no
#' @param no model number
getArrows=function(no=25){
res=no
for( i in 1:4) {
res=c(res,moreModels$no1[moreModels$no %in% res])
res=unique(res)
}
res
parrows[parrows$no %in% res,]
}
#' Make estimatesTable with a list of lm object
#' @param fit A list of lm object
#' @param labels A list
#' @param digits integer indicating the number of decimal places
#' @export
#' @examples
#' labels=list(X="frame",M="justify",Y="donate",W="skeptic")
#' moderator=list(name="skeptic",site=list(c("a","c")))
#' eq=tripleEquation(labels=labels,moderator=moderator,data=disaster,mode=1)
#' fit=eq2fit(eq,data=disaster)
#' fit2table(fit=fit,labels=labels)
fit2table=function(fit,labels=labels,digits=3){
count=length(fit)
Y=c()
i=1
for(i in 1:count){
Y=c(Y,names(fit[[i]]$model)[1])
if(i==1) {
df=as.data.frame(summary(fit[[i]])$coef)
df=df[-1,]
df$Predictors=rownames(df)
} else{
temp=as.data.frame(summary(fit[[i]])$coef)
temp=temp[-1,]
temp$Predictors=rownames(temp)
df=rbind(df,temp)
}
}
Y
df
res=modelsSummary2(fit,labels=labels)
class(res)="data.frame"
res
if(count==1){
nrow1=nrow(res)-1
Variables=rep(Y[1],nrow1)
} else if(count>1) {
xcount=unlist(lapply(fit,function(x) {length(x$coef)-1}))
xcount
Variables=c()
for(i in 1:length(Y)){
Variables=c(Variables,rep(Y[i],xcount[i]))
}
}
df$Variables=Variables
res=res[res$name1!="Constant",]
res$label=str_replace(res$name,"'","")
df$label=res$label
colnames(df)[1:4]=c("B","SE","t","p")
df$B=round(df$B,digits=digits)
df$SE=round(df$SE,digits=digits)
df$t=round(df$t,digits=digits)
df
}
#'Draw statistical diagram
#'@param no process macro model number
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param xmargin horizontal margin of plot
#'@param arrowlabel logical whether or not draw arrowlabel
#'@param arrowslabels A character vector
#'@param arrowslty linetype of arrows
#'@param labels A list of character string
#'@param nodeslabels A list of character string
#'@param whatLabel What should the edge labels indicate in the path diagram? Choices are c("est","std","name","label")
#'@param fit A list of class lm or an object of class lavaan
#'@param estimatesTable A data.frame
#'@param digits Integer indicating the number of decimal places
#'@param covar Optional list of covariates
#'@param addCovar Logical. Whether or not include covariates
#'@param type An integer
#'@param includeLatentVars A logical
#'@param addprime logical. Whether or not add prime to label "c"
#'@param box.col fill color of the box
#' @param xlim the x limits (min,max) of the plot
#' @param ylim the y limits (min,max) of the plot
#'@importFrom dplyr left_join
#'@export
#'@examples
#'statisticalDiagram(no=1)
#'covar=list(name=c("posemot","ideology","sex"),site=list(c("Y"),c("Y"),c("Y")))
#'statisticalDiagram(no=1,covar=covar)
#'covar=list(name=c("posemot","ideology","sex"),site=list(c("M","Y"),c("Mi","Y"),c("Mi","Y")))
#'covar=list(name=c("C1","C2"),site=list(c("M","Y"),"Y"))
#'statisticalDiagram(no=4,covar=covar)
#'statisticalDiagram(no=8,covar=covar)
#'labels=list(X="wintense",Mi="cogapp",Y="emotion")
#'nodeslabels=list(X="Work\nIntensity",Mi="Cognitive\nAppraisal",Y="Emotional\nExhaustion")
#'statisticalDiagram(4,labels=labels)
#'statisticalDiagram(4,labels=nodeslabels)
#'statisticalDiagram(4,labels=labels,nodeslabels=nodeslabels)
#'labels=list(X="GDP\nper inhabitant",M="Illiteracy Rate",Y="Mean Life\nExpectation")
#'statisticalDiagram(4,labels=labels)
#'statisticalDiagram(4,labels=labels,arrowslabels=c("e","f","g"),whatLabel="label")
statisticalDiagram=function(no=1,radx=0.10,rady=0.04,xmargin=0.01,arrowlabel=TRUE,arrowslabels=NULL,
arrowslty=NULL,
labels=list(),nodeslabels=list(),whatLabel="name",fit=NULL,
estimatesTable=NULL,
digits=3,covar=list(),addCovar=TRUE,type=NULL,
includeLatentVars=FALSE,addprime=TRUE,box.col="white",xlim=c(0,1),ylim=NULL){
#
# no=4;radx=0.10;rady=0.04;xmargin=0.01;arrowlabel=TRUE;arrowslabels=NULL
# arrowslty=NULL
# labels=list();nodeslabels=list();whatLabel="name";fit=NULL;estimatesTable=NULL
# digits=3;covar=list();addCovar=TRUE;type=NULL
# includeLatentVars=FALSE;addprime=TRUE
# arrowslabels=c("e","f","g");whatLabel="label";ylim=NULL
# covar=list(name=c("C1","C2"),site=list(c("M","Y"),"Y"));xlim=c(0,1);ylim=c(0,1)
# labels=list(X="frame",M="justify",Y="donate",W="skeptic")
# moderator=list(name="skeptic",site=list(c("a","c")))
# covar=NULL
# model=tripleEquation(labels=labels,moderator=moderator,data=disaster,rangemode=2)
# semfit=sem(model,data=disaster)
# fit=semfit;whatLabel="est";no=8
#
#
if(!is.null(fit)) {
if(is.null(estimatesTable)) {
if(inherits(fit,"list")) {
estimatesTable<-fit2table(fit,labels=labels,digits=digits)
} else if(inherits(fit,"lavaan")){
estimatesTable<-estimatesTable(fit,digits=digits)
}
}
}
if(no==1.1) {
nodes=est2Nodes(estimatesTable)
} else {
nodes=getNodes(no)
}
if(no==1.1){
arrows1=est2Arrows(estimatesTable)
} else{
arrows1=getArrows(no)
}
nodes
arrows1
# Add covariates
if(addCovar){
if(no!=1.1) nodes=addNodes(nodes,covar,radx=radx,rady=rady,no=no)
}
# print(nodes)
arrows1
covar
if(no==1.1) {
arrows2=arrows1
} else {
if(addCovar){
arrows2=addArrows(arrows1,covar)
} else{
arrows2=arrows1
}
}
arrows2
# print(arrows)
if( !is.null(estimatesTable)) {
if(no==1.1){
arrows2$Predictors=arrows2$start
} else{
arrows2$Predictors=findNames(labels,names=arrows2$start)
}
arrows2$Variables=findNames(labels,names=arrows2$end)
labels
arrows2
estimatesTable
# temp=c()
# for(i in 1:nrow(estimatesTable)){
# temp=c(temp,names(labels)[str_detect(labels,estimatesTable$Variables[i])])
# }
# temp
# estimatesTable$start=temp
# estimatesTable
arrows2
if(includeLatentVars){
arrows3<-full_join(arrows2,estimatesTable,by=c("Predictors","Variables"))
arrows3
arrows3$no= arrows3$no[1]
arrows3$name[is.na(arrows3$name)]=""
arrows3$start[is.na(arrows3$start)]=arrows3$Predictors[is.na(arrows3$start)]
arrows3$end[is.na(arrows3$end)]=arrows3$Variables[is.na(arrows3$end)]
arrows3$labelpos=0.5
arrows3$arrpos=0.84
arrows3$end=changeLabelName(arrows3$end,labels)
} else{
arrows3<-left_join(arrows2,estimatesTable,by=c("Predictors","Variables"))
}
if(is.null(arrowslty)) {
arrows3$lty=ifelse(arrows3$p<0.05,1,3)
if(whatLabel=="name") arrows3$lty=1
} else{
arrows3$lty=arrowslty
}
# print(arrows3)
} else{
arrows2$lty=1
arrows3<-arrows2
if(!is.null(arrowslty)) arrows3$lty=arrowslty
}
if(arrowlabel){
if(whatLabel=="name") {
arrows3$label=arrows3$name
} else if(whatLabel=="est"){
arrows3$label=arrows3$B
} else if(whatLabel %in% c("label","label2")){
if((!is.null(arrowslabels))&(length(arrowslabels)==nrow(arrows3))){
arrows3$label=arrowslabels
} else{
arrows3$label=""
}
} else{
arrows3$label=arrows3[,ncol(arrows3)-1]
}
} else {
arrows3$label=""
}
if((!is.null(fit))&(includeLatentVars)){
nodes=addLatentNodes(nodes,fit,labels)
nodes=adjustPosNodes(nodes)
}
if(length(labels)>0){
nodes$name=str_replace(nodes$name,"i$","")
arrows3$name=str_replace(arrows3$name,"i$","")
arrows3$start=str_replace(arrows3$start,"i$","")
arrows3$end=str_replace(arrows3$end,"i$","")
arrows3$label=str_replace(arrows3$label,"i$","")
}
# print(nodes)
if(is.null(ylim)) ylim=c(min(nodes$ypos-rady-0.01),max(nodes$ypos+rady+0.01))
if(ylim[1]>0.2) ylim[1]=0.2
if(ylim[2]<0.8) ylim[2]=0.8
if(whatLabel %in% c("est","std","label2")) arrows3$label=as.numeric(arrows3$label)
drawStatDiagram(no=no,arrows=arrows3,nodes=nodes,labels=labels,nodeslabels=nodeslabels,
xmargin=xmargin,radx=radx,rady=rady,fit,addprime=addprime,box.col=box.col,
xlim=xlim,ylim=ylim)
# openplotmat()
#
# drawArrows(arrows3,nodes,xmargin=xmargin,rady=rady,radx=radx)
#
# for(i in 1:nrow(nodes)){
# xpos=nodes$xpos[i]
# xpos=adjustxpos(xpos,xmargin,radx)
# mid=c(xpos,nodes$ypos[i])
#
# # label=ifelse(is.null(labels[[nodes$name[i]]]),nodes$name[i],labels[[nodes$name[i]]])
# label=ifelse(no==1.1,nodes$name[i],findName(labels,nodes$name[i]))
#
# drawtext(mid,radx=radx,rady=rady,lab=label,latent=FALSE)
# if(no==1.1){
# if(i<=nrow(nodes)){
# label=findName(labels,nodes$name[i])
# if(label!=nodes$name[i]) textplain(mid+c(0,-0.07),radx=radx,rady=rady,lab=label,latent=FALSE)
# }
# }
# }
}
#'Change Label Names
#'@param x A character vector
#'@param labels A list
#'@param add A logical
#'@export
#'@examples
#'labels=list(X="frame:test",Mi="empathy",Y="intervention",W="frame",Z="test")
#'x=c("skeptic","test","empathy","skeptic:frame:test","D1:frame","frame:test")
#'changeLabelName(x,labels)
#'changeLabelName(x,labels,add=TRUE)
#'x=c("baby","milk","baby:milk")
#'labels=list(X="baby",M=c("wine","tent","sand"),Y="tile",W="milk")
#'changeLabelName(x,labels)
changeLabelName=function(x,labels,add=FALSE){
res=c()
unlist(labels)
# i=5;add=FALSE
for(i in 1:length(x)){
if(x[i] %in% unlist(labels)){
if(add){
temp=names(unlist(labels))[which(unlist(labels)==x[i])]
res=c(res,paste0(x[i],"(",temp,")"))
} else{
res=c(res,names(unlist(labels))[which(unlist(labels)==x[i])])
}
} else if(str_detect(x[i],":")){
temp=unlist(strsplit(x[i],":"))
temp
temp2=c()
for(j in 1:length(temp)){
temp3=names(unlist(labels))[which(unlist(labels)==temp[j])]
if(length(temp3)==0) temp3=temp[j]
temp2=c(temp2,temp3)
}
temp2
if(length(temp2)>1){
temp2=paste0(temp2,collapse=":")
if(add){
res=c(res,paste0(x[i],"(",temp2,")"))
} else{
res=c(res,temp2)
}
} else{
temp=x[i]
temp
for(j in 1:length(labels)){
if(add) {
temp=str_replace(x[i],labels[[j]],paste0(labels[[j]],"(",names(labels)[j],")"))
} else{
temp=str_replace(x[i],labels[[j]],names(labels)[j])
}
}
temp
res=c(res,temp)
}
} else {
res=c(res,x[i])
}
}
res
}
#'Adjust position of nodes
#'@param nodes A data.frame
adjustPosNodes=function(nodes){
if(min(nodes$xpos)<0){
nodes$xpos[(nodes$xpos<0.3)&(nodes$xpos>=0)]=nodes$xpos[(nodes$xpos<0.3)&(nodes$xpos>=0)]+0.2
nodes$xpos[nodes$xpos<0]=0
}
if(max(nodes$xpos)>1){
nodes$xpos[(nodes$xpos>0.7)&(nodes$xpos<=1)]=nodes$xpos[(nodes$xpos>0.7)&(nodes$xpos<=1)]-0.2
nodes$xpos[nodes$xpos>1]=1
}
nodes
}
#'Extract Latent Variables Names
#'@param fit An object of class lavaan. Result of lavaan::sem()
extractLatentVarName=function(fit){
res=parameterEstimates(fit)
res=res[res$op=="=~",]
unique(res$lhs)
}
#'Extract Latent Variables Data
#'@param fit An object of class lavaan. Result of lavaan::sem()
#'@param labels A list
extractLatentVar=function(fit,labels){
res=parameterEstimates(fit)
res=res[res$op=="=~",]
if(nrow(res)>0){
temp=c()
for(i in 1:nrow(res)){
temp=c(temp,names(labels)[str_detect(labels,res$lhs[i])])
}
temp
res$name=temp
}
res
}
#'Add latent nodes information to nodes
#'@param nodes A data.frame
#'@param fit An object of class lavaan. Result of lavaan::sem()
#'@param labels A list
addLatentNodes=function(nodes,fit,labels){
nodes
res=extractLatentVar(fit,labels)
no<-name<-xpos<-ypos<-c()
yinterval=0.12
count=length(res$name[res$name=="X"])
start=ifelse(count>4,0.1+yinterval*(count-1),nodes$ypos[nodes$name=="X"]+yinterval*(count-1)/2)
ypos=seq(start,by=-yinterval,length.out = count)
no=rep(nodes$no[1],count)
xpos=rep(-0.1,count)
name=res$rhs[res$name=="X"]
df=data.frame(no,name,xpos,ypos,stringsAsFactors = FALSE)
nodes<-rbind(nodes,df)
count=length(res$name[res$name=="Mi"])
start=ifelse(count>4,0.1,nodes$xpos[nodes$name=="Mi"]-0.1*(count-1)/2)
xpos=seq(start,by=0.1,length.out = count)
no=rep(nodes$no[1],count)
ypos=rep(nodes$ypos[nodes$name=="Mi"]+0.1,count)
name=res$rhs[res$name=="Mi"]
df=data.frame(no,name,xpos,ypos,stringsAsFactors = FALSE)
df
nodes<-rbind(nodes,df)
count=length(res$name[res$name=="Y"])
start=ifelse(count>4,0.1+yinterval*(count-1),nodes$ypos[nodes$name=="Y"]+yinterval*(count-1)/2)
ypos=seq(start,by=-yinterval,length.out = count)
no=rep(nodes$no[1],count)
xpos=rep(1.1,count)
name=res$rhs[res$name=="Y"]
df=data.frame(no,name,xpos,ypos,stringsAsFactors = FALSE)
df
nodes<-rbind(nodes,df)
nodes
}
#'draw StatDiagram
#'@param no process macro model number
#'@param arrows A data.frame
#'@param nodes A data.frame
#'@param labels A list
#'@param nodeslabels A list
#'@param xmargin horizontal margin of plot
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param fit An object of class lavaan. Result of lavaan::sem()
#'@param addprime logical Whether add prime to label "c"
#'@param box.col fill color of the box
#' @param xlim the x limits (min,max) of the plot
#' @param ylim the y limits (min,max) of the plot
#'@export
drawStatDiagram=function(no,arrows,nodes,labels,nodeslabels=list(),xmargin,radx,rady,fit=NULL,addprime=TRUE,box.col="white",xlim=c(0,1),ylim=c(0,1)){
# print(nodes)
# print(arrows)
openplotmat(xlim=xlim,ylim=ylim)
drawArrows(arrows,nodes,xmargin=xmargin,rady=rady,radx=radx,addprime=addprime)
LVnames=c()
if(!is.null(fit)) {
if(inherits(fit,"lavaan")) LVnames=extractLatentVarName(fit)
}
for(i in 1:nrow(nodes)){
xpos=nodes$xpos[i]
xpos=adjustxpos(xpos,xmargin,radx)
mid=c(xpos,nodes$ypos[i])
# label=ifelse(is.null(labels[[nodes$name[i]]]),nodes$name[i],labels[[nodes$name[i]]])
label=ifelse(no==1.1,nodes$name[i],findName(labels,nodeslabels=nodeslabels,name=nodes$name[i]))
# label=eval(parse(text=paste0("expression(italic(",label,"))")))
drawtext(mid,radx=radx,rady=rady,lab=label,latent=ifelse(label %in% LVnames,TRUE,FALSE),box.col=box.col)
if(no==1.1){
if(i<=nrow(nodes)){
label=findName(labels,nodeslabels=nodeslabels,name=nodes$name[i])
if(label!=nodes$name[i]) textplain(mid+c(0,-0.07),radx=radx,rady=rady,lab=label,latent=FALSE)
}
}
}
}
#' Make arrows from estimatesTable
#' @param res A data.frame, result of estimatesTable
est2Arrows=function(res){
no=rep(1.1,nrow(res))
name=paste0("b",1:nrow(res))
start=res$Predictors
end=res$Variables
labelpos=rep(0.5,nrow(res))
arrpos=rep(0.84,nrow(res))
data.frame(no,name,start,end,labelpos,arrpos,stringsAsFactors = FALSE)
}
#' Make nodes from estimatesTable
#' @param res A data.frame, result of estimatesTable
#' @param lastxno A numeric
est2Nodes=function(res,lastxno=2){
res
count=nrow(res)-1
count
yinterval=-0.8/(count-1)
start=0.9
y=seq(0.9,by=yinterval,length.out = count)
y
y=c(y,0.1,0.5)
x=c(rep(0,count-1),seq(from=0.05,by=0.1,length.out=2),1)
x
no=rep(1.1,nrow(res)+1)
name=c(res$Predictors,res$Variables[1])
data.frame(no=no,name=name,xpos=x,ypos=y,stringsAsFactors = FALSE)
}
#'Draw arrows
#'@param arrows A data.frame
#'@param nodes A data.frame
#'@param xmargin horizontal margin of plot
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param addprime logical Whether add prime to label "c"
drawArrows=function(arrows,nodes,xmargin=0.01,radx=0.10,rady=0.04,addprime=TRUE){
# print(arrows)
# nodes
for(i in 1:nrow(arrows)){
if(is.na(arrows$lty[i])){
myarrow2(nodes,from=arrows$start[i],to=arrows$end[i],
label=arrows$label[i],no=arrows$no[1],xmargin=xmargin,radx=radx,rady=rady,
label.pos=arrows$labelpos[i],arr.pos=arrows$arrpos[i],addprime=addprime)
} else{
myarrow2(nodes, from=arrows$start[i],to=arrows$end[i],
label=arrows$label[i],no=arrows$no[1],xmargin=xmargin,radx=radx,rady=rady,
label.pos=arrows$labelpos[i],arr.pos=arrows$arrpos[i],lty=arrows$lty[i],addprime=addprime)
}
}
}
#'Add covariates to nodes
#'@param nodes A data.frame
#'@param covar A list of covariates
#'@param radx horizontal radius of the box.
#'@param rady vertical radius of the box.
#'@param no A numeric
#'@export
addNodes=function(nodes,covar,radx=0.10,rady=0.04,no=NULL){
if(length(covar$name)>0){
if(no==1.1){
}
number<-name<-xpos<-ypos<-c()
minypos=min(nodes$ypos)
maxxpos=min(nodes$xpos[nodes$ypos==minypos])
if(nodes$no[1]==4.2) {
maxxpos=-(radx/2)
minypos=0.4
}
for(i in 1:length(covar$name)){
number=c(number,nodes$no[1])
name=c(name,covar$name[i])
xpos=c(xpos,maxxpos+radx/2*i)
ypos=c(ypos,minypos-(rady*2+0.02)*i)
}
df=data.frame(no=number,name=name,xpos=xpos,ypos=ypos)
nodes=rbind(nodes,df)
nodes=adjustNodes(nodes)
}
nodes
}
#'Add covariates to arrows
#'@param arrows A data.frame
#'@param covar A list of covariates
#'@export
addArrows=function(arrows,covar){
if(length(covar$name)>0){
number<-name<-start<-end<-labelpos<-arrpos<-c()
fcount<-gcount<-1
for(i in 1:length(covar$name)){
for(j in 1:length(covar$site[[i]])){
start=c(start,covar$name[i])
end=c(end,covar$site[[i]][j])
number=c(number,arrows$no[1])
prefix=ifelse(covar$site[[i]][j]=="Y","g","f")
count=ifelse(covar$site[[i]][j]=="Y",gcount,fcount)
name=c(name,paste0(prefix,count))
labelpos=c(labelpos,0.5)
arrpos=c(arrpos,0.84)
if(covar$site[[i]][j]=="Y"){
gcount=gcount+1
} else{
fcount=fcount+1
}
}
}
number
name
start
end[end=="M"]="Mi"
labelpos
arrpos
df=data.frame(no=number,name=name,start=start,end=end,labelpos=labelpos,arrpos=arrpos)
arrows=rbind(arrows,df)
}
if(!("f2" %in% arrows$name)) {
arrows$name[arrows$name=="f1"]="f"
}
if(!("g2" %in% arrows$name)) {
arrows$name[arrows$name=="g1"]="g"
}
arrows
}
#'Adjust y position of nodes
#'@param nodes A data.frame
adjustNodes=function(nodes){
miny=min(nodes$ypos)
if(miny<0.05){
if(miny>=0) {
nodes$ypos=nodes$ypos+0.05
} else{
nodes$ypos=nodes$ypos+0.05-miny
}
}
if(max(nodes$ypos)>0.95) {
nodes$ypos=nodes$ypos*0.95/max(nodes$ypos)
}
nodes
}
#'convert a vector of names with list
#'@param labels A named list
#'@param nodeslabels A named list
#'@param names A character vector to look for
#'@param exact A logical
#'@export
#'@examples
#'labels=list(X="wt",Mi="am",Y="mpg");names=c("X","MiX","Y")
#'findNames(labels,names=names)
findNames=function(labels,nodeslabels=list(),names,exact=FALSE){
result=c()
for(i in 1:length(names)){
result=c(result,findName(labels,nodeslabels=nodeslabels,name=names[i],exact=exact))
}
result
}
#'convert name with list
#'@param labels A named list
#'@param nodeslabels A named list
#'@param name A name to look for
#'@param exact A logical
#'@export
#'@examples
#'labels=list(X="wt",M="am",Y="mpg");name="MiX"
#'nodeslabels=list(X="weight",M="automatic",Y="milepergallon")
#'findName(labels=labels,nodeslabels=nodeslabels,name="MiX")
#'findName(labels=labels,name="MiX")
#'findName(labels=labels,nodeslabels=nodeslabels,name="M")
#'labels=list(X="GDPpp",M="Illit",Y="LifeEx")
#'nodeslabels=list(X="GDP\nper inhabitant",M="Illiteracy Rate",Y="Mean Life\nExpectation")
#'findName(labels=labels,name="Mi")
#'findName(labels=labels,nodeslabels=nodeslabels,name="Mi")
#'labels=list(X="GDPpp",Mi="Illit",Y="LifeEx")
#'nodeslabels=list(X="GDP\nper inhabitant",Mi="Illiteracy Rate",Y="Mean Life\nExpectation")
#'findName(labels=labels,name="M")
#'findName(labels=labels,nodeslabels=nodeslabels,name="M")
#'labels=list(X="cond",M=c("import","pmi"),Y="reaction")
#'findName(labels=labels,name="M1")
findName=function(labels,nodeslabels=list(),name="MiX",exact=FALSE){
# labels=list(X="wt",M="am",Y="mpg")
# nodeslabels=list()
# name="Mi"
# exact=FALSE
#
result=NULL
if(length(labels)==0) {
result=name
} else if(length(nodeslabels)>0){
if(!is.null(nodeslabels[[name]])) {
result=nodeslabels[[name]]
}
if(is.null(result)){
if(name=="Mi"){
result=nodeslabels[["M"]]
} else if(name=="M"){
result=nodeslabels[["Mi"]]
} else if(name=="M1"){
result=nodeslabels[["M"]][1]
} else if(name=="M2"){
result=nodeslabels[["M"]][2]
} else if(name=="M3"){
result=nodeslabels[["M"]][3]
}
}
} else if(name %in% names(labels)) {
if(is.null(result)) result=labels[[name]]
}
if(is.null(result)){
if(name=="Mi"){
if("M" %in% names(labels)) result=labels$M
} else if(name=="M"){
if("Mi" %in% names(labels)) result=labels$Mi
} else if(name=="M1"){
result=labels[["M"]][1]
} else if(name=="M2"){
result=labels[["M"]][2]
} else if(name=="M3"){
result=labels[["M"]][3]
}
}
if(is.null(result)){
if(!exact){
temp=c()
for(i in seq_along(nodeslabels)){
grep(names(nodeslabels)[i],name)
if(length(grep(names(nodeslabels)[i],name))>0)
temp=c(temp,nodeslabels[[names(nodeslabels[i])]])
temp
}
if(length(temp)==0){
for(i in 1:length(labels)){
grep(names(labels)[i],name)
if(length(grep(names(labels)[i],name))>0)
temp=c(temp,labels[[names(labels[i])]])
temp
}
}
temp
if(length(temp)<1) {
result=name
} else{
result=paste0(temp,collapse=":")
}
} else{
result=name
}
}
result
}
#'Adjust x position
#'@param xpos x position
#'@param xmargin horizontal margin of plot
#'@param radx horizontal radius of the box
#'@param xspace numeric. horizontal interval
#'@param mode integer adjust mode
#'@export
adjustxpos=function(xpos,xmargin=0.01,radx=0.12,xspace=NULL,mode=1){
if(is.null(xspace)) xspace=xmargin+2*radx
if(mode==1){
result=ifelse(xpos==0.5,0.5,
ifelse(xpos>0.5,
1-xmargin-radx-(1.0-xpos)*10*xspace,
xmargin+radx+(xpos%/%0.1)*(xmargin+2*radx)+(xpos%%0.1)*10*xspace))
} else{
result=ifelse(((xpos>0.2)|(xpos<0.8)),xpos,
ifelse(xpos>0.5,
1-xmargin-radx-(1.0-xpos)*10*xspace,
xmargin+radx+(xpos%/%0.1)*(xmargin+2*radx)+(xpos%%0.1)*10*xspace))
}
result
}
#' Draw arrow with adjustment of a position
#' @param nodes A data.frame
#' @param from coordinates (x,y) of the point *from* which to draw arrow.
#' @param to coordinates (x,y) of the point *to* which to draw arrow.
#' @param label label to display
#' @param no process macro model number
#' @param radx horizontal radius of the box.
#' @param rady vertical radius of the box.
#' @param xmargin horizontal margin of plot
#' @param label.pos label position
#' @param arr.pos arrow position
#'@param addprime logical Whether add prime to label "c"
#'@param xspace numeric horizontal space between nodes
#'@param mode integer mode for adjustxpos
#' @param ... Further argument to be passed to straightarrow()
myarrow2=function(nodes,from,to,label="",no,radx=0.12,rady=0.04,xmargin=0.01,label.pos=0.5,arr.pos=NULL,addprime=TRUE,xspace=NULL,mode=1,...){
#nodes=nodes[nodes$no==no, ]
# from="X";no=1;to="Y";label="66"
xpos=nodes$xpos[nodes$name==from]
xpos=adjustxpos(xpos,xmargin,radx,xspace=xspace,mode=mode)
ypos=nodes$ypos[nodes$name==from]
start=c(xpos,ypos)
xpos=nodes$xpos[nodes$name==to]
xpos=adjustxpos(xpos,xmargin,radx,xspace=xspace,mode=mode)
ypos=nodes$ypos[nodes$name==to]
end=c(xpos,ypos)
if(!is.numeric(label)){
if(nchar(label)>1) {
if(addprime) {
prime=ifelse(substr(label,1,1)=="c","^minute","")
} else {
prime=""
}
# if(nchar(label==3)){
# temp1=paste0("expression(italic(",substr(label,1,1),")[",substr(label,2,2),"]","[",
# substr(label,3,nchar(label)),"]",prime,")")
#
# } else{
if(!str_detect(label,"\n")){
temp2=substr(label,2,nchar(label))
temp2
temp1=paste0("expression(italic(",substr(label,1,1),")[",temp2,"]",prime,")")
temp1
# }
temp=eval(parse(text=temp1))
label=temp
}
} else if(nchar(label)==1){
if(label=="c") {
if(addprime) {
label=expression(italic(c)^minute)
} else {
label=expression(italic(c))
}
} else {
temp=paste0("expression(italic(",label,"))")
label=eval(parse(text=temp))
}
}
}
myarrow(from=start,to=end,label=label,label.pos=label.pos,arr.pos=arr.pos,radx=radx,rady=rady,...)
# myarrow(from=start,to=end,label=label,label.pos=label.pos,radx=radx,rady=rady,...)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.