insight/0000755000176200001440000000000013615601156011723 5ustar liggesusersinsight/NAMESPACE0000644000176200001440000005456513615562325013165 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(clean_names,character) S3method(clean_names,default) S3method(clean_parameters,BFBayesFactor) S3method(clean_parameters,blavaan) S3method(clean_parameters,brmsfit) S3method(clean_parameters,default) S3method(clean_parameters,lavaan) S3method(clean_parameters,stanmvreg) S3method(clean_parameters,stanreg) S3method(clean_parameters,wbgee) S3method(clean_parameters,wbm) S3method(find_algorithm,BBmm) S3method(find_algorithm,BBreg) S3method(find_algorithm,Gam) S3method(find_algorithm,LORgee) S3method(find_algorithm,MixMod) S3method(find_algorithm,bayesx) S3method(find_algorithm,bigglm) S3method(find_algorithm,biglm) S3method(find_algorithm,blavaan) S3method(find_algorithm,brmsfit) S3method(find_algorithm,crq) S3method(find_algorithm,default) S3method(find_algorithm,gam) S3method(find_algorithm,gamlss) S3method(find_algorithm,glimML) S3method(find_algorithm,glm) S3method(find_algorithm,glmmTMB) S3method(find_algorithm,glmrob) S3method(find_algorithm,lm) S3method(find_algorithm,lmRob) S3method(find_algorithm,lme) S3method(find_algorithm,lmrob) S3method(find_algorithm,logistf) S3method(find_algorithm,merMod) S3method(find_algorithm,mixed) S3method(find_algorithm,rlmerMod) S3method(find_algorithm,rq) S3method(find_algorithm,rqss) S3method(find_algorithm,speedglm) S3method(find_algorithm,speedlm) S3method(find_algorithm,stanreg) S3method(find_formula,BBmm) S3method(find_formula,BFBayesFactor) S3method(find_formula,DirichletRegModel) S3method(find_formula,LORgee) S3method(find_formula,MANOVA) S3method(find_formula,MCMCglmm) S3method(find_formula,MixMod) S3method(find_formula,RM) S3method(find_formula,aovlist) S3method(find_formula,bamlss) S3method(find_formula,brmsfit) S3method(find_formula,cgamm) S3method(find_formula,cglm) S3method(find_formula,clm2) S3method(find_formula,clmm) S3method(find_formula,clmm2) S3method(find_formula,coxme) S3method(find_formula,cpglmm) S3method(find_formula,data.frame) S3method(find_formula,default) S3method(find_formula,feglm) S3method(find_formula,feis) S3method(find_formula,felm) S3method(find_formula,fixest) S3method(find_formula,gam) S3method(find_formula,gamlss) S3method(find_formula,gamm) S3method(find_formula,gee) S3method(find_formula,glimML) S3method(find_formula,glmmTMB) S3method(find_formula,glmmadmb) S3method(find_formula,gls) S3method(find_formula,hurdle) S3method(find_formula,iv_robust) S3method(find_formula,ivreg) S3method(find_formula,lme) S3method(find_formula,merMod) S3method(find_formula,mixed) S3method(find_formula,mixor) S3method(find_formula,mmclogit) S3method(find_formula,nlmerMod) S3method(find_formula,plm) S3method(find_formula,rlmerMod) S3method(find_formula,stanmvreg) S3method(find_formula,stanreg) S3method(find_formula,tobit) S3method(find_formula,wbgee) S3method(find_formula,wbm) S3method(find_formula,zeroinfl) S3method(find_formula,zerotrunc) S3method(find_parameters,BBmm) S3method(find_parameters,BBreg) S3method(find_parameters,BFBayesFactor) S3method(find_parameters,DirichletRegModel) S3method(find_parameters,Gam) S3method(find_parameters,MCMCglmm) S3method(find_parameters,MixMod) S3method(find_parameters,aareg) S3method(find_parameters,aovlist) S3method(find_parameters,bayesx) S3method(find_parameters,betareg) S3method(find_parameters,blavaan) S3method(find_parameters,bracl) S3method(find_parameters,brmsfit) S3method(find_parameters,brmultinom) S3method(find_parameters,cgam) S3method(find_parameters,clm2) S3method(find_parameters,clmm2) S3method(find_parameters,coxme) S3method(find_parameters,cpglmm) S3method(find_parameters,crq) S3method(find_parameters,crqs) S3method(find_parameters,data.frame) S3method(find_parameters,default) S3method(find_parameters,flexsurvreg) S3method(find_parameters,gam) S3method(find_parameters,gamlss) S3method(find_parameters,gamm) S3method(find_parameters,gbm) S3method(find_parameters,glimML) S3method(find_parameters,glmmTMB) S3method(find_parameters,glmmadmb) S3method(find_parameters,glmx) S3method(find_parameters,hurdle) S3method(find_parameters,lavaan) S3method(find_parameters,lme) S3method(find_parameters,lrm) S3method(find_parameters,mcmc) S3method(find_parameters,merMod) S3method(find_parameters,mixed) S3method(find_parameters,mixor) S3method(find_parameters,mlm) S3method(find_parameters,multinom) S3method(find_parameters,nlmerMod) S3method(find_parameters,polr) S3method(find_parameters,rlmerMod) S3method(find_parameters,rma) S3method(find_parameters,rqss) S3method(find_parameters,sim) S3method(find_parameters,sim.merMod) S3method(find_parameters,stanmvreg) S3method(find_parameters,stanreg) S3method(find_parameters,vgam) S3method(find_parameters,wbgee) S3method(find_parameters,wbm) S3method(find_parameters,zeroinfl) S3method(find_parameters,zerotrunc) S3method(find_weights,brmsfit) S3method(find_weights,default) S3method(format_value,character) S3method(format_value,data.frame) S3method(format_value,double) S3method(format_value,factor) S3method(format_value,logical) S3method(format_value,numeric) S3method(get_data,BBmm) S3method(get_data,BFBayesFactor) S3method(get_data,DirichletRegModel) S3method(get_data,LORgee) S3method(get_data,MANOVA) S3method(get_data,MCMCglmm) S3method(get_data,MixMod) S3method(get_data,RM) S3method(get_data,aareg) S3method(get_data,bigglm) S3method(get_data,biglm) S3method(get_data,blavaan) S3method(get_data,bracl) S3method(get_data,brmsfit) S3method(get_data,clm2) S3method(get_data,clmm) S3method(get_data,clmm2) S3method(get_data,complmrob) S3method(get_data,cpglmm) S3method(get_data,data.frame) S3method(get_data,default) S3method(get_data,feglm) S3method(get_data,feis) S3method(get_data,felm) S3method(get_data,fixest) S3method(get_data,gamlss) S3method(get_data,gamm) S3method(get_data,gbm) S3method(get_data,gee) S3method(get_data,glimML) S3method(get_data,glmmTMB) S3method(get_data,glmmadmb) S3method(get_data,gls) S3method(get_data,gmnl) S3method(get_data,hurdle) S3method(get_data,iv_robust) S3method(get_data,ivreg) S3method(get_data,lavaan) S3method(get_data,lme) S3method(get_data,merMod) S3method(get_data,mixed) S3method(get_data,mixor) S3method(get_data,nlrq) S3method(get_data,plm) S3method(get_data,rlmerMod) S3method(get_data,rma) S3method(get_data,rqss) S3method(get_data,stanmvreg) S3method(get_data,stanreg) S3method(get_data,survfit) S3method(get_data,tobit) S3method(get_data,vgam) S3method(get_data,vglm) S3method(get_data,wbgee) S3method(get_data,wbm) S3method(get_data,zeroinfl) S3method(get_data,zerotrunc) S3method(get_parameters,BBmm) S3method(get_parameters,BBreg) S3method(get_parameters,BFBayesFactor) S3method(get_parameters,DirichletRegModel) S3method(get_parameters,Gam) S3method(get_parameters,MCMCglmm) S3method(get_parameters,MixMod) S3method(get_parameters,aareg) S3method(get_parameters,aov) S3method(get_parameters,aovlist) S3method(get_parameters,bayesx) S3method(get_parameters,betareg) S3method(get_parameters,blavaan) S3method(get_parameters,bracl) S3method(get_parameters,brmsfit) S3method(get_parameters,brmultinom) S3method(get_parameters,cgam) S3method(get_parameters,clm2) S3method(get_parameters,clmm2) S3method(get_parameters,coxme) S3method(get_parameters,cpglmm) S3method(get_parameters,crq) S3method(get_parameters,crqs) S3method(get_parameters,data.frame) S3method(get_parameters,default) S3method(get_parameters,flexsurvreg) S3method(get_parameters,gam) S3method(get_parameters,gamlss) S3method(get_parameters,gamm) S3method(get_parameters,gbm) S3method(get_parameters,glimML) S3method(get_parameters,glmmTMB) S3method(get_parameters,glmmadmb) S3method(get_parameters,glmx) S3method(get_parameters,hurdle) S3method(get_parameters,lavaan) S3method(get_parameters,lme) S3method(get_parameters,lrm) S3method(get_parameters,mcmc) S3method(get_parameters,merMod) S3method(get_parameters,mixed) S3method(get_parameters,mixor) S3method(get_parameters,mlm) S3method(get_parameters,multinom) S3method(get_parameters,nlmerMod) S3method(get_parameters,polr) S3method(get_parameters,rlmerMod) S3method(get_parameters,rma) S3method(get_parameters,rqss) S3method(get_parameters,sim) S3method(get_parameters,sim.merMod) S3method(get_parameters,stanmvreg) S3method(get_parameters,stanreg) S3method(get_parameters,vgam) S3method(get_parameters,wbgee) S3method(get_parameters,wbm) S3method(get_parameters,zeroinfl) S3method(get_parameters,zerotrunc) S3method(get_priors,BFBayesFactor) S3method(get_priors,blavaan) S3method(get_priors,brmsfit) S3method(get_priors,stanmvreg) S3method(get_priors,stanreg) S3method(get_statistic,DirichletRegModel) S3method(get_statistic,Gam) S3method(get_statistic,LORgee) S3method(get_statistic,MANOVA) S3method(get_statistic,MixMod) S3method(get_statistic,RM) S3method(get_statistic,aareg) S3method(get_statistic,betareg) S3method(get_statistic,bigglm) S3method(get_statistic,biglm) S3method(get_statistic,bracl) S3method(get_statistic,brmultinom) S3method(get_statistic,censReg) S3method(get_statistic,cgam) S3method(get_statistic,clm2) S3method(get_statistic,clmm2) S3method(get_statistic,complmrob) S3method(get_statistic,coxme) S3method(get_statistic,coxph) S3method(get_statistic,cpglm) S3method(get_statistic,cpglmm) S3method(get_statistic,crch) S3method(get_statistic,crq) S3method(get_statistic,default) S3method(get_statistic,feis) S3method(get_statistic,fixest) S3method(get_statistic,flexsurvreg) S3method(get_statistic,gam) S3method(get_statistic,gamlss) S3method(get_statistic,gamm) S3method(get_statistic,gee) S3method(get_statistic,geeglm) S3method(get_statistic,glimML) S3method(get_statistic,glmmTMB) S3method(get_statistic,glmmadmb) S3method(get_statistic,glmx) S3method(get_statistic,hurdle) S3method(get_statistic,list) S3method(get_statistic,lm_robust) S3method(get_statistic,lme) S3method(get_statistic,logistf) S3method(get_statistic,lrm) S3method(get_statistic,maxLik) S3method(get_statistic,mixor) S3method(get_statistic,mlm) S3method(get_statistic,multinom) S3method(get_statistic,negbin) S3method(get_statistic,nlrq) S3method(get_statistic,ols) S3method(get_statistic,plm) S3method(get_statistic,psm) S3method(get_statistic,rma) S3method(get_statistic,rms) S3method(get_statistic,rq) S3method(get_statistic,rqss) S3method(get_statistic,survreg) S3method(get_statistic,svyglm.nb) S3method(get_statistic,svyglm.zip) S3method(get_statistic,tobit) S3method(get_statistic,truncreg) S3method(get_statistic,vgam) S3method(get_statistic,vglm) S3method(get_statistic,wbgee) S3method(get_statistic,wbm) S3method(get_statistic,zerocount) S3method(get_statistic,zeroinfl) S3method(get_varcov,BBmm) S3method(get_varcov,BBreg) S3method(get_varcov,DirichletRegModel) S3method(get_varcov,LORgee) S3method(get_varcov,MixMod) S3method(get_varcov,betareg) S3method(get_varcov,brmsfit) S3method(get_varcov,cglm) S3method(get_varcov,clm2) S3method(get_varcov,clmm2) S3method(get_varcov,cpglm) S3method(get_varcov,cpglmm) S3method(get_varcov,crq) S3method(get_varcov,default) S3method(get_varcov,feis) S3method(get_varcov,flexsurvreg) S3method(get_varcov,gamlss) S3method(get_varcov,gamm) S3method(get_varcov,gee) S3method(get_varcov,geeglm) S3method(get_varcov,glimML) S3method(get_varcov,glmRob) S3method(get_varcov,glmmTMB) S3method(get_varcov,glmx) S3method(get_varcov,hurdle) S3method(get_varcov,list) S3method(get_varcov,lmRob) S3method(get_varcov,maxLik) S3method(get_varcov,mixed) S3method(get_varcov,mixor) S3method(get_varcov,nlrq) S3method(get_varcov,rq) S3method(get_varcov,tobit) S3method(get_varcov,truncreg) S3method(get_varcov,vgam) S3method(get_varcov,vglm) S3method(get_varcov,zerocount) S3method(get_varcov,zeroinfl) S3method(get_variance,MixMod) S3method(get_variance,clmm) S3method(get_variance,cpglmm) S3method(get_variance,default) S3method(get_variance,glmmTMB) S3method(get_variance,glmmadmb) S3method(get_variance,lme) S3method(get_variance,merMod) S3method(get_variance,mixed) S3method(get_variance,rlmerMod) S3method(get_variance,stanreg) S3method(get_variance,wblm) S3method(get_variance,wbm) S3method(get_weights,brmsfit) S3method(get_weights,default) S3method(link_function,BBmm) S3method(link_function,BBreg) S3method(link_function,DirichletRegModel) S3method(link_function,LORgee) S3method(link_function,MANOVA) S3method(link_function,RM) S3method(link_function,aovlist) S3method(link_function,bamlss) S3method(link_function,bayesx) S3method(link_function,betareg) S3method(link_function,bigglm) S3method(link_function,biglm) S3method(link_function,brglm) S3method(link_function,brmsfit) S3method(link_function,censReg) S3method(link_function,cgam) S3method(link_function,cglm) S3method(link_function,clm) S3method(link_function,clm2) S3method(link_function,clmm) S3method(link_function,complmRob) S3method(link_function,coxme) S3method(link_function,coxph) S3method(link_function,cpglm) S3method(link_function,cpglmm) S3method(link_function,crch) S3method(link_function,crq) S3method(link_function,crqs) S3method(link_function,default) S3method(link_function,feglm) S3method(link_function,feis) S3method(link_function,felm) S3method(link_function,fixest) S3method(link_function,flexsurvreg) S3method(link_function,gam) S3method(link_function,gamlss) S3method(link_function,gamm) S3method(link_function,gbm) S3method(link_function,glimML) S3method(link_function,glm) S3method(link_function,glmmadmb) S3method(link_function,glmx) S3method(link_function,gls) S3method(link_function,gmnl) S3method(link_function,hurdle) S3method(link_function,iv_robust) S3method(link_function,ivreg) S3method(link_function,lm) S3method(link_function,lmRob) S3method(link_function,lm_robust) S3method(link_function,lme) S3method(link_function,lmrob) S3method(link_function,logistf) S3method(link_function,lrm) S3method(link_function,mixed) S3method(link_function,mixor) S3method(link_function,mlogit) S3method(link_function,multinom) S3method(link_function,plm) S3method(link_function,polr) S3method(link_function,psm) S3method(link_function,rq) S3method(link_function,rqss) S3method(link_function,speedglm) S3method(link_function,speedlm) S3method(link_function,stanmvreg) S3method(link_function,survfit) S3method(link_function,survreg) S3method(link_function,svyolr) S3method(link_function,tobit) S3method(link_function,truncreg) S3method(link_function,vgam) S3method(link_function,vglm) S3method(link_function,zeroinfl) S3method(link_function,zerotrunc) S3method(link_inverse,BBmm) S3method(link_inverse,BBreg) S3method(link_inverse,DirichletRegModel) S3method(link_inverse,LORgee) S3method(link_inverse,MANOVA) S3method(link_inverse,MCMCglmm) S3method(link_inverse,MixMod) S3method(link_inverse,RM) S3method(link_inverse,aovlist) S3method(link_inverse,bamlss) S3method(link_inverse,bayesx) S3method(link_inverse,betareg) S3method(link_inverse,bigglm) S3method(link_inverse,biglm) S3method(link_inverse,brmsfit) S3method(link_inverse,censReg) S3method(link_inverse,cgam) S3method(link_inverse,clm) S3method(link_inverse,clm2) S3method(link_inverse,clmm) S3method(link_inverse,complmrob) S3method(link_inverse,coxme) S3method(link_inverse,coxph) S3method(link_inverse,cpglm) S3method(link_inverse,cpglmm) S3method(link_inverse,crch) S3method(link_inverse,crq) S3method(link_inverse,crqs) S3method(link_inverse,default) S3method(link_inverse,feglm) S3method(link_inverse,feis) S3method(link_inverse,felm) S3method(link_inverse,fixest) S3method(link_inverse,flexsurvreg) S3method(link_inverse,gam) S3method(link_inverse,gamlss) S3method(link_inverse,gamm) S3method(link_inverse,gbm) S3method(link_inverse,glimML) S3method(link_inverse,glm) S3method(link_inverse,glmmPQL) S3method(link_inverse,glmmTMB) S3method(link_inverse,glmmadmb) S3method(link_inverse,glmx) S3method(link_inverse,gls) S3method(link_inverse,gmnl) S3method(link_inverse,hurdle) S3method(link_inverse,iv_robust) S3method(link_inverse,ivreg) S3method(link_inverse,lm) S3method(link_inverse,lmRob) S3method(link_inverse,lm_robust) S3method(link_inverse,lme) S3method(link_inverse,lmrob) S3method(link_inverse,logistf) S3method(link_inverse,lrm) S3method(link_inverse,mixed) S3method(link_inverse,mixor) S3method(link_inverse,mlogit) S3method(link_inverse,multinom) S3method(link_inverse,plm) S3method(link_inverse,polr) S3method(link_inverse,psm) S3method(link_inverse,rq) S3method(link_inverse,rqss) S3method(link_inverse,speedglm) S3method(link_inverse,speedlm) S3method(link_inverse,stanmvreg) S3method(link_inverse,survfit) S3method(link_inverse,survreg) S3method(link_inverse,svyolr) S3method(link_inverse,tobit) S3method(link_inverse,truncreg) S3method(link_inverse,vgam) S3method(link_inverse,vglm) S3method(link_inverse,zeroinfl) S3method(link_inverse,zerotrunc) S3method(model_info,BBmm) S3method(model_info,BBreg) S3method(model_info,BFBayesFactor) S3method(model_info,DirichletRegModel) S3method(model_info,LORgee) S3method(model_info,MANOVA) S3method(model_info,MCMCglmm) S3method(model_info,MixMod) S3method(model_info,RM) S3method(model_info,aareg) S3method(model_info,aovlist) S3method(model_info,bamlss) S3method(model_info,bayesx) S3method(model_info,betareg) S3method(model_info,brmsfit) S3method(model_info,brmultinom) S3method(model_info,censReg) S3method(model_info,cgam) S3method(model_info,cglm) S3method(model_info,clm) S3method(model_info,clm2) S3method(model_info,clmm) S3method(model_info,complmrob) S3method(model_info,coxme) S3method(model_info,coxph) S3method(model_info,cpglm) S3method(model_info,cpglmm) S3method(model_info,crch) S3method(model_info,crq) S3method(model_info,crqs) S3method(model_info,data.frame) S3method(model_info,default) S3method(model_info,feglm) S3method(model_info,feis) S3method(model_info,felm) S3method(model_info,fixest) S3method(model_info,flexsurvreg) S3method(model_info,gam) S3method(model_info,gamlss) S3method(model_info,gamm) S3method(model_info,gbm) S3method(model_info,glimML) S3method(model_info,glmmPQL) S3method(model_info,glmmTMB) S3method(model_info,glmmadmb) S3method(model_info,glmx) S3method(model_info,gls) S3method(model_info,gmnl) S3method(model_info,htest) S3method(model_info,hurdle) S3method(model_info,iv_robust) S3method(model_info,ivreg) S3method(model_info,lmRob) S3method(model_info,lm_robust) S3method(model_info,lme) S3method(model_info,lmrob) S3method(model_info,logistf) S3method(model_info,lrm) S3method(model_info,maxLik) S3method(model_info,mcmc) S3method(model_info,mixed) S3method(model_info,mixor) S3method(model_info,mlm) S3method(model_info,mlogit) S3method(model_info,mmclogit) S3method(model_info,multinom) S3method(model_info,nlrq) S3method(model_info,nls) S3method(model_info,plm) S3method(model_info,polr) S3method(model_info,rma) S3method(model_info,rq) S3method(model_info,rqss) S3method(model_info,speedglm) S3method(model_info,speedlm) S3method(model_info,stanmvreg) S3method(model_info,survfit) S3method(model_info,survreg) S3method(model_info,svyolr) S3method(model_info,tobit) S3method(model_info,truncreg) S3method(model_info,vgam) S3method(model_info,vglm) S3method(model_info,zeroinfl) S3method(model_info,zerotrunc) S3method(n_obs,BBmm) S3method(n_obs,BBreg) S3method(n_obs,LORgee) S3method(n_obs,MANOVA) S3method(n_obs,RM) S3method(n_obs,aareg) S3method(n_obs,aovlist) S3method(n_obs,bamlss) S3method(n_obs,bayesx) S3method(n_obs,bigglm) S3method(n_obs,biglm) S3method(n_obs,censReg) S3method(n_obs,cgam) S3method(n_obs,cglm) S3method(n_obs,complmrob) S3method(n_obs,coxme) S3method(n_obs,coxph) S3method(n_obs,cpglm) S3method(n_obs,cpglmm) S3method(n_obs,crq) S3method(n_obs,crqs) S3method(n_obs,default) S3method(n_obs,feglm) S3method(n_obs,feis) S3method(n_obs,felm) S3method(n_obs,fixest) S3method(n_obs,flexsurvreg) S3method(n_obs,gamm) S3method(n_obs,gbm) S3method(n_obs,glimML) S3method(n_obs,glmRob) S3method(n_obs,gmnl) S3method(n_obs,hurdle) S3method(n_obs,lmRob) S3method(n_obs,maxLik) S3method(n_obs,mcmc) S3method(n_obs,mlogit) S3method(n_obs,multinom) S3method(n_obs,nlrq) S3method(n_obs,rq) S3method(n_obs,rqss) S3method(n_obs,stanmvreg) S3method(n_obs,survfit) S3method(n_obs,survreg) S3method(n_obs,svyolr) S3method(n_obs,wbgee) S3method(n_obs,wbm) S3method(n_obs,zeroinfl) S3method(n_obs,zerotrunc) S3method(print,easystats_check) export(all_models_equal) export(all_models_same_class) export(clean_names) export(clean_parameters) export(color_if) export(colour_if) export(download_model) export(find_algorithm) export(find_formula) export(find_interactions) export(find_parameters) export(find_predictors) export(find_random) export(find_random_slopes) export(find_response) export(find_statistic) export(find_terms) export(find_variables) export(find_weights) export(format_ci) export(format_table) export(format_value) export(get_correlation_slope_intercept) export(get_data) export(get_parameters) export(get_predictors) export(get_priors) export(get_random) export(get_response) export(get_statistic) export(get_varcov) export(get_variance) export(get_variance_dispersion) export(get_variance_distribution) export(get_variance_fixed) export(get_variance_intercept) export(get_variance_random) export(get_variance_residual) export(get_variance_slope) export(get_weights) export(has_intercept) export(is_model) export(is_model_supported) export(is_multivariate) export(is_nullmodel) export(link_function) export(link_inverse) export(model_info) export(n_obs) export(print_color) export(print_colour) export(print_parameters) export(supported_models) importFrom(methods,.hasSlot) importFrom(methods,slot) importFrom(methods,slotNames) importFrom(stats,Gamma) importFrom(stats,as.formula) importFrom(stats,binomial) importFrom(stats,coef) importFrom(stats,drop.terms) importFrom(stats,family) importFrom(stats,fitted) importFrom(stats,formula) importFrom(stats,gaussian) importFrom(stats,getCall) importFrom(stats,make.link) importFrom(stats,model.frame) importFrom(stats,model.matrix) importFrom(stats,na.omit) importFrom(stats,nobs) importFrom(stats,plogis) importFrom(stats,poisson) importFrom(stats,predict) importFrom(stats,qchisq) importFrom(stats,reformulate) importFrom(stats,reshape) importFrom(stats,setNames) importFrom(stats,terms) importFrom(stats,update) importFrom(stats,var) importFrom(stats,vcov) importFrom(utils,capture.output) importFrom(utils,tail) insight/README.md0000644000176200001440000003451513615555663013225 0ustar liggesusers # insight [![DOI](http://joss.theoj.org/papers/10.21105/joss.01412/status.svg)](https://doi.org/10.21105/joss.01412) [![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/insight)](https://cran.r-project.org/package=insight) [![Documentation](https://img.shields.io/badge/documentation-insight-orange.svg?colorB=E91E63)](https://easystats.github.io/insight/) [![Build Status](https://travis-ci.org/easystats/insight.svg?branch=master)](https://travis-ci.org/easystats/insight) [![downloads](http://cranlogs.r-pkg.org/badges/insight)](http://cranlogs.r-pkg.org/) [![total](http://cranlogs.r-pkg.org/badges/grand-total/insight)](http://cranlogs.r-pkg.org/) **Gain insight into your models\!** When fitting any statistical model, there are many useful pieces of information that are simultaneously calculated and stored beyond coefficient estimates and general model fit statistics. Although there exist some generic functions to obtain model information and data, many package-specific modeling functions do not provide such methods to allow users to access such valuable information. **insight** is an R-package that fills this important gap by providing a suite of functions to support almost any model (see a list of the many models supported below in the **List of Supported Packages and Models** section). The goal of **insight**, then, is to provide tools to provide *easy*, *intuitive*, and *consistent* access to information contained in model objects. These tools aid applied research in virtually any field who fit, diagnose, and present statistical models by streamlining access to every aspect of many model objects via consistent syntax and output. Built with non-programmers in mind, **insight** offers a broad toolbox for making model and data information easily accessible. While **insight** offers many useful functions for working with and understanding model objects (discussed below), we suggest users start with `model_info()`, as this function provides a clean and consistent overview of model objects (e.g., functional form of the model, the model family, link function, number of observations, variables included in the specification, etc.). With a clear understanding of the model introduced, users are able to adapt other functions for more nuanced exploration of and interaction with virtually any model object. ## Definition of Model Components The functions from **insight** address different components of a model. In an effort to avoid confusion about specific “targets” of each function, in this section we provide a short explanation of **insight**’s definitions of regression model components. #### Data The dataset used to fit the model. #### Parameters Values estimated or learned from data that capture the relationship between variables. In regression models, these are usually referred to as *coefficients*. #### Response and Predictors - **response**: the outcome or response variable (dependent variable) of a regression model. - **predictor**: independent variables of (the *fixed* part of) a regression model. For mixed models, variables that are only in the *random effects* part (i.e. grouping factors) of the model are not returned as predictors by default. However, these can be included using additional arguments in the function call, treating predictors are “unique”. As such, if a variable appears as a fixed effect and a random slope, it is treated as one (the same) predictor. #### Variables Any unique variable names that appear in a regression model, e.g., response variable, predictors or random effects. A “variable” only relates to the unique occurence of a term, or the term name. For instance, the expression `x + poly(x, 2)` has only the variable `x`. #### Terms Terms themselves consist of variable and factor names separated by operators, or involve arithmetic expressions. For instance, the expression `x + poly(x, 2)` has *one* variable `x`, but *two* terms `x` and `poly(x, 2)`. #### Random Effects - **random slopes**: variables that are specified as random slopes in a mixed effects model. - **random or grouping factors**: variables that are specified as grouping variables in a mixed effects model. *Aren’t the predictors, terms and parameters the same thing?* In some cases, yes. But not in all cases. Find out more by [**clicking here to access the documentation**](https://easystats.github.io/insight/articles/insight.html). ## Functions The package revolves around two key prefixes: `get_*` and `find_*`. The `get_*` prefix extracts *values* (or *data*) associated with model-specific objects (e.g., parameters or variables), while the `find_*` prefix *lists* model-specific objects (e.g., priors or predictors). These are powerful families of functions allowing for great flexibility in use, whether at a high, descriptive level (`find_*`) or narrower level of statistical inspection and reporting (`get_*`). ![](https://raw.githubusercontent.com/easystats/insight/master/paper/figure1_small.png) In total, the **insight** package includes 16 core functions: [get\_data()](https://easystats.github.io/insight/reference/get_data.html), [get\_priors()](https://easystats.github.io/insight/reference/get_priors.html), [get\_variance()](https://easystats.github.io/insight/reference/get_variance.html), [get\_parameters()](https://easystats.github.io/insight/reference/get_parameters.html), [get\_predictors()](https://easystats.github.io/insight/reference/get_predictors.html), [get\_random()](https://easystats.github.io/insight/reference/get_random.html), [get\_response()](https://easystats.github.io/insight/reference/get_response.html), [find\_algorithm()](https://easystats.github.io/insight/reference/find_algorithm.html), [find\_formula()](https://easystats.github.io/insight/reference/find_formula.html), [find\_variables()](https://easystats.github.io/insight/reference/find_variables.html), [find\_terms()](https://easystats.github.io/insight/reference/find_terms.html), [find\_parameters()](https://easystats.github.io/insight/reference/find_parameters.html), [find\_predictors()](https://easystats.github.io/insight/reference/find_predictors.html), [find\_random()](https://easystats.github.io/insight/reference/find_random.html), [find\_response()](https://easystats.github.io/insight/reference/find_response.html), and [model\_info()](https://easystats.github.io/insight/reference/model_info.html). In all cases, users must supply at a minimum, the name of the model fit object. In several functions, there are additional arguments that allow for more targeted returns of model information. For example, the `find_terms()` function’s `effects` argument allows for the extraction of “fixed effects” terms, “random effects” terms, or by default, “all” terms in the model object. We point users to the package documentation or the complementary package website, , for a detailed list of the arguments associated with each function as well as the returned values from each function. ## Examples of Use Cases in R We now would like to provide examples of use cases of the **insight** package. These examples probably do not cover typical real-world problems, but serve as illustration of the core idea of this package: The unified interface to access model information. **insight** should help both users and package developers in order to reduce the hassle with the many exceptions from various modelling packages when accessing model information. #### Making Predictions at Specific Values of a Term of Interest Say, the goal is to make predictions for a certain term, holding remaining co-variates constant. This is achieved by calling `predict()` and feeding the `newdata`-argument with the values of the term of interest as well as the “constant” values for remaining co-variates. The functions `get_data()` and `find_predictors()` are used to get this information, which then can be used in the call to `predict()`. In this example, we fit a simple linear model, but it could be replaced by (m)any other models, so this approach is “universal” and applies to many different model objects. ``` r library(insight) m <- lm(Sepal.Length ~ Species + Petal.Width + Sepal.Width, data = iris) dat <- get_data(m) pred <- find_predictors(m, flatten = TRUE) l <- lapply(pred, function(x) { if (is.numeric(dat[[x]])) mean(dat[[x]]) else unique(dat[[x]]) }) names(l) <- pred l <- as.data.frame(l) cbind(l, predictions = predict(m, newdata = l)) #> Species Petal.Width Sepal.Width predictions #> 1 setosa 1.2 3.1 5.1 #> 2 versicolor 1.2 3.1 6.1 #> 3 virginica 1.2 3.1 6.3 ``` #### Printing Model Coefficients The next example should emphasize the possibilities to generalize functions to many different model objects using **insight**. The aim is simply to print coefficients in a complete, human readable sentence. The first approach uses the functions that are available for some, but obviously not for all models, to access the information about model coefficients. ``` r print_params <- function(model) { paste0("My parameters are ", paste0(row.names(summary(model)$coefficients), collapse = ", "), ", thank you for your attention!") } m1 <- lm(Sepal.Length ~ Petal.Width, data = iris) print_params(m1) #> [1] "My parameters are (Intercept), Petal.Width, thank you for your attention!" # obviously, something is missing in the output m2 <- mgcv::gam(Sepal.Length ~ Petal.Width + s(Petal.Length), data = iris) print_params(m2) #> [1] "My parameters are , thank you for your attention!" ``` As we can see, the function fails for *gam*-models. As the access to models depends on the type of the model in the R ecosystem, we would need to create specific functions for all models types. With **insight**, users can write a function without having to worry about the model type. ``` r print_params <- function(model) { paste0("My parameters are ", paste0(insight::find_parameters(model, flatten = TRUE), collapse = ", "), ", thank you for your attention!") } m1 <- lm(Sepal.Length ~ Petal.Width, data = iris) print_params(m1) #> [1] "My parameters are (Intercept), Petal.Width, thank you for your attention!" m2 <- mgcv::gam(Sepal.Length ~ Petal.Width + s(Petal.Length), data = iris) print_params(m2) #> [1] "My parameters are (Intercept), Petal.Width, s(Petal.Length), thank you for your attention!" ``` ## Installation Run the following to install the latest GitHub-version of **insight**: ``` r install.packages("devtools") devtools::install_github("easystats/insight") ``` Or install the latest stable release from CRAN: ``` r install.packages("insight") ``` ## Documentation Please visit for documentation. ## Contributing and Support In case you want to file an issue or contribute in another way to the package, please follow [this guide](https://github.com/easystats/insight/blob/master/.github/CONTRIBUTING.md). For questions about the functionality, you may either contact us via email or also file an issue. ## List of Supported Models by Class ``` r supported_models() #> [1] "aareg" "aov" "aovlist" #> [4] "bamlss" "bamlss.frame" "bayesx" #> [7] "BBmm" "BBreg" "betareg" #> [10] "BFBayesFactor" "bigglm" "biglm" #> [13] "blavaan" "bracl" "brglm" #> [16] "brmsfit" "brmultinom" "censReg" #> [19] "cgam" "cgamm" "cglm" #> [22] "clm" "clm2" "clmm" #> [25] "clmm2" "complmrob" "coxme" #> [28] "coxph" "cpglm" "cpglmm" #> [31] "crch" "crq" "crqs" #> [34] "DirichletRegModel" "feglm" "feis" #> [37] "felm" "fixest" "flexsurvreg" #> [40] "gam" "Gam" "gamlss" #> [43] "gamm" "gamm4" "gbm" #> [46] "gee" "geeglm" "glimML" #> [49] "glm" "glmmadmb" "glmmPQL" #> [52] "glmmTMB" "glmrob" "glmRob" #> [55] "glmx" "gls" "gmnl" #> [58] "htest" "hurdle" "iv_robust" #> [61] "ivreg" "lavaan" "lm" #> [64] "lm_robust" "lme" "lmrob" #> [67] "lmRob" "logistf" "LORgee" #> [70] "lrm" "MANOVA" "maxLik" #> [73] "mclogit" "mcmc" "MCMCglmm" #> [76] "merMod" "mixed" "MixMod" #> [79] "mixor" "mlm" "mlogit" #> [82] "mmlogit" "multinom" "ols" #> [85] "plm" "polr" "psm" #> [88] "rlm" "rlmerMod" "RM" #> [91] "rma" "rma.uni" "rq" #> [94] "rqss" "speedglm" "speedlm" #> [97] "stanmvreg" "stanreg" "survfit" #> [100] "survreg" "svyglm" "svyolr" #> [103] "tobit" "truncreg" "vgam" #> [106] "vglm" "wbgee" "wblm" #> [109] "wbm" "zeroinfl" "zerotrunc" ``` - **Didn’t find a model?** [File an issue](https://github.com/easystats/insight/issues) and request additional model-support in *insight*\! ## Credits If this package helped you, please consider citing as follows: Lüdecke D, Waggoner P, Makowski D. insight: A Unified Interface to Access Information from Model Objects in R. Journal of Open Source Software 2019;4:1412. doi: [10.21105/joss.01412](https://doi.org/10.21105/joss.01412) insight/man/0000755000176200001440000000000013602213235012467 5ustar liggesusersinsight/man/clean_names.Rd0000644000176200001440000000307713566471215015247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clean_names.R \name{clean_names} \alias{clean_names} \title{Get clean names of model terms} \usage{ clean_names(x) } \arguments{ \item{x}{A fitted model, or a character vector.} } \value{ The "cleaned" variable names as character vector, i.e. pattern like \code{s()} for splines or \code{log()} are removed from the model terms. } \description{ This function "cleans" names of model terms (or a character vector with such names) by removing patterns like \code{log()} or \code{as.factor()} etc. } \note{ Typically, this method is intended to work on character vectors, in order to remove patterns that obscure the variable names. For convenience reasons it is also possible to call \code{clean_names()} also on a model object. If \code{x} is a regression model, this function is (almost) equal to calling \code{find_variables()}. The main difference is that \code{clean_names()} always returns a character vector, while \code{find_variables()} returns a list of character vectors, unless \code{flatten = TRUE}. See 'Examples'. } \examples{ # example from ?stats::glm counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) outcome <- c(gl(3, 1, 9)) treatment <- gl(3, 3) m <- glm(counts ~ log(outcome) + as.factor(treatment), family = poisson()) clean_names(m) # difference "clean_names()" and "find_variables()" library(lme4) m <- glmer( cbind(incidence, size - incidence) ~ period + (1 | herd), data = cbpp, family = binomial ) clean_names(m) find_variables(m) find_variables(m, flatten = TRUE) } insight/man/find_random.Rd0000644000176200001440000000272513566471215015261 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_random.R \name{find_random} \alias{find_random} \title{Find names of random effects} \usage{ find_random(x, split_nested = FALSE, flatten = FALSE) } \arguments{ \item{x}{A fitted mixed model.} \item{split_nested}{Logical, if \code{TRUE}, terms from nested random effects will be returned as separated elements, not as single string with colon. See 'Examples'.} \item{flatten}{Logical, if \code{TRUE}, the values are returned as character vector, not as list. Duplicated values are removed.} } \value{ A list of character vectors that represent the name(s) of the random effects (grouping factors). Depending on the model, the returned list has following elements: \itemize{ \item \code{random}, the "random effects" terms from the conditional part of model \item \code{zero_inflated_random}, the "random effects" terms from the zero-inflation component of the model } } \description{ Return the name of the grouping factors from mixed effects models. } \examples{ library(lme4) data(sleepstudy) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } m <- lmer( Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy ) find_random(m) find_random(m, split_nested = TRUE) } insight/man/find_parameters.Rd0000644000176200001440000001037113600225174016126 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_parameters.R, R/get_parameters.R \name{find_parameters} \alias{find_parameters} \alias{find_parameters.gam} \alias{find_parameters.merMod} \alias{find_parameters.zeroinfl} \alias{find_parameters.hurdle} \alias{find_parameters.BFBayesFactor} \alias{find_parameters.brmsfit} \alias{find_parameters.bayesx} \alias{find_parameters.stanreg} \alias{find_parameters.sim.merMod} \alias{get_parameters.bayesx} \title{Find names of model parameters} \usage{ find_parameters(x, ...) \method{find_parameters}{gam}( x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, ... ) \method{find_parameters}{merMod}(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) \method{find_parameters}{zeroinfl}( x, component = c("all", "conditional", "zi", "zero_inflated"), flatten = FALSE, ... ) \method{find_parameters}{hurdle}( x, component = c("all", "conditional", "zi", "zero_inflated"), flatten = FALSE, ... ) \method{find_parameters}{BFBayesFactor}( x, effects = c("all", "fixed", "random"), component = c("all", "extra"), flatten = FALSE, ... ) \method{find_parameters}{brmsfit}( x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "simplex", "sigma", "smooth_terms"), flatten = FALSE, parameters = NULL, ... ) \method{find_parameters}{bayesx}( x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, parameters = NULL, ... ) \method{find_parameters}{stanreg}( x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "smooth_terms"), flatten = FALSE, parameters = NULL, ... ) \method{find_parameters}{sim.merMod}( x, effects = c("all", "fixed", "random"), flatten = FALSE, parameters = NULL, ... ) \method{get_parameters}{bayesx}( x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, parameters = NULL, ... ) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} \item{component}{Should all parameters, parameters for the conditional model, the zero-inflated part of the model, the dispersion term or the instrumental variables be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variable (so called fixed-effects regressions). May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{flatten}{Logical, if \code{TRUE}, the values are returned as character vector, not as list. Duplicated values are removed.} \item{effects}{Should parameters for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned.} } \value{ A list of parameter names. For simple models, only one list-element, \code{conditional}, is returned. For more complex models, the returned list may have following elements: \itemize{ \item \code{conditional}, the "fixed effects" part from the model \item \code{random}, the "random effects" part from the model \item \code{zero_inflated}, the "fixed effects" part from the zero-inflation component of the model \item \code{zero_inflated_random}, the "random effects" part from the zero-inflation component of the model \item \code{dispersion}, the dispersion parameters \item \code{simplex}, simplex parameters of monotonic effects (\pkg{brms} only) \item \code{smooth_terms}, the smooth parameters } } \description{ Returns the names of model parameters, like they typically appear in the \code{summary()} output. For Bayesian models, the parameter names equal the column names of the posterior samples after coercion from \code{as.data.frame()}. } \details{ In most cases when models either return different "effects" (fixed, random) or "components" (conditional, zero-inflated, ...), the arguments \code{effects} and \code{component} can be used. Not all model classes that support these arguments are listed here in the 'Usage' section. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) find_parameters(m) } insight/man/find_statistic.Rd0000644000176200001440000000134613566471215016006 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_statistic.R \name{find_statistic} \alias{find_statistic} \title{Find statistic for model} \usage{ find_statistic(x, ...) } \arguments{ \item{x}{An object.} \item{...}{Currently not used.} } \value{ A character describing the type of statistic. If there is no statistic available with a distribution, \code{NULL} will be returned. } \description{ Returns the statistic for a regression model (\emph{t}-statistic, \emph{z}-statistic, etc.). Small helper that checks if a model is a regression model object and return the statistic used. } \examples{ # regression model object data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) find_statistic(m) } insight/man/is_model_supported.Rd0000644000176200001440000000167013566471215016677 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/is_model_supported.R \name{is_model_supported} \alias{is_model_supported} \alias{supported_models} \title{Checks if an object is a regression model object supported in \pkg{insight} package.} \usage{ is_model_supported(x) supported_models() } \arguments{ \item{x}{An object.} } \value{ A logical, \code{TRUE} if \code{x} is a (supported) model object. } \description{ Small helper that checks if a model is a \emph{supported} (regression) model object. \code{supported_models()} prints a list of currently supported model classes. } \details{ This function returns \code{TRUE} if \code{x} is a model object that works with the package's functions. A list of supported models can also be found here: \url{https://github.com/easystats/insight}. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) is_model_supported(m) is_model_supported(mtcars) } insight/man/print_color.Rd0000644000176200001440000000157213566471215015332 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print_color.R \name{print_color} \alias{print_color} \alias{print_colour} \title{Coloured console output} \usage{ print_color(text, color) print_colour(text, colour) } \arguments{ \item{text}{The text to print.} \item{color, colour}{Character vector, indicating the colour for printing. May be one of \code{"red"}, \code{"yellow"}, \code{"green"}, \code{"blue"}, \code{"violet"}, \code{"cyan"} or \code{"grey"}. Formatting is also possible with \code{"bold"} or \code{"italic"}.} } \value{ Nothing. } \description{ Convenient function that allows coloured output in the console. Mainly implemented to reduce package dependencies. } \details{ This function prints \code{text} directly to the console using \code{cat()}, so no string is returned. } \examples{ print_color("I'm blue dabedi dabedei", "blue") } insight/man/all_models_equal.Rd0000644000176200001440000000206613566471215016301 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/all_equal_models.R \name{all_models_equal} \alias{all_models_equal} \alias{all_models_same_class} \title{Checks if all objects are models of same class} \usage{ all_models_equal(..., verbose = FALSE) all_models_same_class(..., verbose = FALSE) } \arguments{ \item{...}{A list of objects.} \item{verbose}{Toggle off warnings.} } \value{ A logical, \code{TRUE} if \code{x} are all supported model objects of same class. } \description{ Small helper that checks if all objects are \emph{supported} (regression) model objects and of same class. } \examples{ library(lme4) data(mtcars) data(sleepstudy) m1 <- lm(mpg ~ wt + cyl + vs, data = mtcars) m2 <- lm(mpg ~ wt + cyl, data = mtcars) m3 <- lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy) m4 <- glm(formula = vs ~ wt, family = binomial(), data = mtcars) all_models_same_class(m1, m2) all_models_same_class(m1, m2, m3) all_models_same_class(m1, m4, m2, m3, verbose = TRUE) all_models_same_class(m1, m4, mtcars, m2, m3, verbose = TRUE) } insight/man/find_variables.Rd0000644000176200001440000000560113602442163015734 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_variables.R \name{find_variables} \alias{find_variables} \title{Find names of all variables} \usage{ find_variables( x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "instruments", "smooth_terms"), flatten = FALSE ) } \arguments{ \item{x}{A fitted model.} \item{effects}{Should variables for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should all predictor variables, predictor variables for the conditional model, the zero-inflated part of the model, the dispersion term or the instrumental variables be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variable (so called fixed-effects regressions). May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{flatten}{Logical, if \code{TRUE}, the values are returned as character vector, not as list. Duplicated values are removed.} } \value{ A list with (depending on the model) following elements (character vectors): \itemize{ \item \code{response}, the name of the response variable \item \code{conditional}, the names of the predictor variables from the \emph{conditional} model (as opposed to the zero-inflated part of a model) \item \code{random}, the names of the random effects (grouping factors) \item \code{zero_inflated}, the names of the predictor variables from the \emph{zero-inflated} part of the model \item \code{zero_inflated_random}, the names of the random effects (grouping factors) \item \code{dispersion}, the name of the dispersion terms \item \code{instruments}, the names of instrumental variables } } \description{ Returns a list with the names of all variables, including response value and random effects. } \note{ The difference to \code{\link{find_terms}} is that \code{find_variables()} returns each variable name only once, while \code{find_terms()} may return a variable multiple times in case of transformations or when arithmetic expressions were used in the formula. } \examples{ library(lme4) data(cbpp) data(sleepstudy) # some data preparation... cbpp$trials <- cbpp$size - cbpp$incidence sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } m1 <- glmer( cbind(incidence, size - incidence) ~ period + (1 | herd), data = cbpp, family = binomial ) find_variables(m1) m2 <- lmer( Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy ) find_variables(m2) find_variables(m2, flatten = TRUE) } insight/man/model_info.Rd0000644000176200001440000000637013615526401015105 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_info.R \name{model_info} \alias{model_info} \title{Access information from model objects} \usage{ model_info(x, ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} } \value{ A list with information about the model, like family, link-function etc. (see 'Details'). } \description{ Retrieve information from model objects. } \details{ \code{model_info()} returns a list with information about the model for many different model objects. Following information is returned, where all values starting with \code{is_} are logicals. \itemize{ \item \code{is_binomial}: family is binomial (but not negative binomial) \item \code{is_poisson}: family is poisson \item \code{is_negbin}: family is negative binomial \item \code{is_count}: model is a count model (i.e. family is either poisson or negative binomial) \item \code{is_beta}: family is beta \item \code{is_betabinomial}: family is beta-binomial \item \code{is_dirichlet}: family is dirichlet \item \code{is_exponential}: family is exponential (e.g. Gamma or Weibull) \item \code{is_logit}: model has logit link \item \code{is_progit}: model has probit link \item \code{is_linear}: family is gaussian \item \code{is_tweedie}: family is tweedie \item \code{is_ordinal}: family is ordinal, multinomial, or cumulative link \item \code{is_cumulative}: family is ordinal, multinomial, or cumulative link \item \code{is_multinomial}: family is multinomial or categorical link \item \code{is_categorical}: family is categorical link \item \code{is_censored}: model is a censored model (has a censored response, including survival models) \item \code{is_truncated}: model is a truncated model (has a truncated response) \item \code{is_survival}: model is a survival model \item \code{is_zero_inflated}: model has zero-inflation component \item \code{is_hurdle}: model has zero-inflation component and is a hurdle-model (truncated family distribution) \item \code{is_mixed}: model is a mixed effects model (with random effects) \item \code{is_multivariate}: model is a multivariate response model (currently only works for \emph{brmsfit} objects) \item \code{is_trial}: model response contains additional information about the trials \item \code{is_bayesian}: model is a Bayesian model \item \code{is_anova}: model is an Anova object \item \code{link_function}: the link-function \item \code{family}: the family-object \item \code{n_obs}: number of observations \item \code{model_terms}: a list with all model terms, including terms such as random effects or from zero-inflated model parts. } } \examples{ ldose <- rep(0:5, 2) numdead <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16) sex <- factor(rep(c("M", "F"), c(6, 6))) SF <- cbind(numdead, numalive = 20 - numdead) dat <- data.frame(ldose, sex, SF, stringsAsFactors = FALSE) m <- glm(SF ~ sex * ldose, family = binomial) model_info(m) \dontrun{ library(glmmTMB) data("Salamanders") m <- glmmTMB( count ~ spp + cover + mined + (1 | site), ziformula = ~ spp + mined, dispformula = ~DOY, data = Salamanders, family = nbinom2 ) } model_info(m) } insight/man/get_statistic.Rd0000644000176200001440000000435613613304134015635 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_statistic.R \name{get_statistic} \alias{get_statistic} \alias{get_statistic.default} \alias{get_statistic.glmmTMB} \alias{get_statistic.clm2} \alias{get_statistic.gee} \alias{get_statistic.betareg} \alias{get_statistic.DirichletRegModel} \title{Get statistic associated with estimates} \usage{ get_statistic(x, ...) \method{get_statistic}{default}(x, column_index = 3, ...) \method{get_statistic}{glmmTMB}( x, component = c("all", "conditional", "zi", "zero_inflated"), ... ) \method{get_statistic}{clm2}(x, component = c("all", "conditional", "scale"), ...) \method{get_statistic}{gee}(x, robust = FALSE, ...) \method{get_statistic}{betareg}(x, component = c("all", "conditional", "precision"), ...) \method{get_statistic}{DirichletRegModel}(x, component = c("all", "conditional", "precision"), ...) } \arguments{ \item{x}{A model.} \item{...}{Currently not used.} \item{column_index}{For model objects that have no defined \code{get_statistic()} method yet, the default method is called. This method tries to extract the statistic column from \code{coef(summary())}, where the index of the column that is being pulled is \code{column_index}. Defaults to 3, which is the default statistic column for most models' summary-output.} \item{component}{Should all parameters, parameters for the conditional model, or for the zero-inflated part of the model be returned? Applies to models with zero-inflated component. \code{component} may be one of \code{"conditional"}, \code{"zi"}, \code{"zero-inflated"} or \code{"all"} (default). For models with smooth terms, \code{component = "smooth_terms"} is also possible. May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{robust}{Logical, if \code{TRUE}, test statistic based on robust standard errors is returned.} } \value{ A data frame with the model's parameter names and the related test statistic. } \description{ Returns the statistic (\emph{t}, \code{z}, ...) for model estimates. In most cases, this is the related column from \code{coef(summary())}. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) get_statistic(m) } insight/man/find_predictors.Rd0000644000176200001440000000476313602442163016152 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_predictors.R \name{find_predictors} \alias{find_predictors} \title{Find names of model predictors} \usage{ find_predictors( x, effects = c("fixed", "random", "all"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "instruments", "correlation", "smooth_terms"), flatten = FALSE ) } \arguments{ \item{x}{A fitted model.} \item{effects}{Should variables for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{component}{Should all predictor variables, predictor variables for the conditional model, the zero-inflated part of the model, the dispersion term or the instrumental variables be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variable (so called fixed-effects regressions). May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{flatten}{Logical, if \code{TRUE}, the values are returned as character vector, not as list. Duplicated values are removed.} } \value{ A list of character vectors that represent the name(s) of the predictor variables. Depending on the combination of the arguments \code{effects} and \code{component}, the returned list has following elements: \itemize{ \item \code{conditional}, the "fixed effects" terms from the model \item \code{random}, the "random effects" terms from the model \item \code{zero_inflated}, the "fixed effects" terms from the zero-inflation component of the model \item \code{zero_inflated_random}, the "random effects" terms from the zero-inflation component of the model \item \code{dispersion}, the dispersion terms \item \code{instruments}, for fixed-effects regressions like \code{ivreg}, \code{felm} or \code{plm}, the instrumental variables \item \code{correlation}, for models with correlation-component like \code{gls}, the variables used to describe the correlation structure } } \description{ Returns the names of the predictor variables for the different parts of a model (like fixed or random effects, zero-inflated component, ...). Unlike \code{\link{find_parameters}}, the names from \code{find_predictors()} match the original variable names from the data that was used to fit the model. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) find_predictors(m) } insight/man/find_algorithm.Rd0000644000176200001440000000262313566471215015764 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_algorithm.R \name{find_algorithm} \alias{find_algorithm} \title{Find sampling algorithm and optimizers} \usage{ find_algorithm(x, ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} } \value{ A list with elements depending on the model. \cr For frequentist models: \itemize{ \item \code{algorithm}, for instance \code{"OLS"} or \code{"ML"} \item \code{optimizer}, name of optimizing function, only applies to specific models (like \code{gam}) } For frequentist mixed models: \itemize{ \item \code{algorithm}, for instance \code{"REML"} or \code{"ML"} \item \code{optimizer}, name of optimizing function } For Bayesian models: \itemize{ \item \code{algorithm}, the algorithm \item \code{chains}, number of chains \item \code{iterations}, number of iterations per chain \item \code{warmup}, number of warmups per chain } } \description{ Returns information on the sampling or estimation algorithm as well as optimization functions, or for Bayesian model information on chains, iterations and warmup-samples. } \examples{ library(lme4) data(sleepstudy) m <- lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy) find_algorithm(m) \dontrun{ library(rstanarm) m <- stan_lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy) find_algorithm(m) } } insight/man/find_interactions.Rd0000644000176200001440000000353013571265241016472 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_interactions.R \name{find_interactions} \alias{find_interactions} \title{Find interaction terms from models} \usage{ find_interactions( x, component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "instruments"), flatten = FALSE ) } \arguments{ \item{x}{A fitted model.} \item{component}{Should all predictor variables, predictor variables for the conditional model, the zero-inflated part of the model, the dispersion term or the instrumental variables be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variable (so called fixed-effects regressions). May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{flatten}{Logical, if \code{TRUE}, the values are returned as character vector, not as list. Duplicated values are removed.} } \value{ A list of character vectors that represent the interaction terms. Depending on \code{component}, the returned list has following elements (or \code{NULL}, if model has no interaction term): \itemize{ \item \code{conditional}, interaction terms that belong to the "fixed effects" terms from the model \item \code{zero_inflated}, interaction terms that belong to the "fixed effects" terms from the zero-inflation component of the model \item \code{instruments}, for fixed-effects regressions like \code{ivreg}, \code{felm} or \code{plm}, interaction terms that belong to the instrumental variables } } \description{ Returns all lowest to highest order interaction terms from a model. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) find_interactions(m) m <- lm(mpg ~ wt * cyl + vs * hp * gear + carb, data = mtcars) find_interactions(m) } insight/man/find_response.Rd0000644000176200001440000000166713566471215015643 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_response.R \name{find_response} \alias{find_response} \title{Find name of the response variable} \usage{ find_response(x, combine = TRUE) } \arguments{ \item{x}{A fitted model.} \item{combine}{Logical, if \code{TRUE} and the response is a matrix-column, the name of the response matches the notation in formula, and would for instance also contain patterns like \code{"cbind(...)"}. Else, the original variable names from the matrix-column are returned. See 'Examples'.} } \value{ The name(s) of the response variable(s) from \code{x} as character vector. } \description{ Returns the name(s) of the response variable(s) from a model object. } \examples{ library(lme4) data(cbpp) cbpp$trials <- cbpp$size - cbpp$incidence m <- glm(cbind(incidence, trials) ~ period, data = cbpp, family = binomial) find_response(m, combine = TRUE) find_response(m, combine = FALSE) } insight/man/is_model.Rd0000644000176200001440000000107513566471215014571 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/is_model.R \name{is_model} \alias{is_model} \title{Checks if an object is a regression model object} \usage{ is_model(x) } \arguments{ \item{x}{An object.} } \value{ A logical, \code{TRUE} if \code{x} is a (supported) model object. } \description{ Small helper that checks if a model is a regression model object. } \details{ This function returns \code{TRUE} if \code{x} is a model object. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) is_model(m) is_model(mtcars) } insight/man/get_variance.Rd0000644000176200001440000001575013602214466015424 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_variances.R \name{get_variance} \alias{get_variance} \alias{get_variance_residual} \alias{get_variance_fixed} \alias{get_variance_random} \alias{get_variance_distribution} \alias{get_variance_dispersion} \alias{get_variance_intercept} \alias{get_variance_slope} \alias{get_correlation_slope_intercept} \title{Get variance components from random effects models} \usage{ get_variance( x, component = c("all", "fixed", "random", "residual", "distribution", "dispersion", "intercept", "slope", "rho01"), verbose = TRUE, ... ) get_variance_residual(x, ...) get_variance_fixed(x, ...) get_variance_random(x, ...) get_variance_distribution(x, ...) get_variance_dispersion(x, ...) get_variance_intercept(x, ...) get_variance_slope(x, ...) get_correlation_slope_intercept(x, ...) } \arguments{ \item{x}{A mixed effects model.} \item{component}{Character value, indicating the variance component that should be returned. By default, all variance components are returned. The distribution-specific (\code{"distribution"}) and residual (\code{"residual"}) variance are the most computational intensive components, and hence may take a few seconds to calculate.} \item{verbose}{Toggle off warnings.} \item{...}{Currently not used.} } \value{ A list with following elements: \itemize{ \item \code{var.fixed}, variance attributable to the fixed effects \item \code{var.random}, (mean) variance of random effects \item \code{var.residual}, residual variance (sum of dispersion and distribution) \item \code{var.distribution}, distribution-specific variance \item \code{var.dispersion}, variance due to additive dispersion \item \code{var.intercept}, the random-intercept-variance, or between-subject-variance (\ifelse{html}{\out{τ00}}{\eqn{\tau_{00}}}) \item \code{var.slope}, the random-slope-variance (\ifelse{html}{\out{τ11}}{\eqn{\tau_{11}}}) \item \code{cor.slope_intercept}, the random-slope-intercept-correlation (\ifelse{html}{\out{ρ01}}{\eqn{\rho_{01}}}) } } \description{ This function extracts the different variance components of a mixed model and returns the result as list. Functions like \code{get_variance_residual(x)} or \code{get_variance_fixed(x)} are shortcuts for \code{get_variance(x, component = "residual")} etc. } \details{ This function returns different variance components from mixed models, which are needed, for instance, to calculate r-squared measures or the intraclass-correlation coefficient (ICC). \subsection{Fixed effects variance}{ The fixed effects variance, \ifelse{html}{\out{σ2f}}{\eqn{\sigma^2_f}}, is the variance of the matrix-multiplication \ifelse{html}{\out{β∗X}}{\eqn{\beta*X}} (parameter vector by model matrix). } \subsection{Random effects variance}{ The random effect variance, \ifelse{html}{\out{σ2i}}{\eqn{\sigma^2_i}}, represents the \emph{mean} random effect variance of the model. Since this variance reflect the "average" random effects variance for mixed models, it is also appropriate for models with more complex random effects structures, like random slopes or nested random effects. Details can be found in \cite{Johnson 2014}, in particular equation 10. For simple random-intercept models, the random effects variance equals the random-intercept variance. } \subsection{Distribution-specific variance}{ The distribution-specific variance, \ifelse{html}{\out{σ2d}}{\eqn{\sigma^2_d}}, depends on the model family. For Gaussian models, it is \ifelse{html}{\out{σ2}}{\eqn{\sigma^2}} (i.e. \code{sigma(model)^2}). For models with binary outcome, it is \eqn{\pi^2 / 3} for logit-link and \code{1} for probit-link. For all other models, the distribution-specific variance is based on lognormal approximation, \eqn{log(1 + var(x) / \mu^2)} (see \cite{Nakagawa et al. 2017}). The expected variance of a zero-inflated model is computed according to \cite{Zuur et al. 2012, p277}. } \subsection{Variance for the additive overdispersion term}{ The variance for the additive overdispersion term, \ifelse{html}{\out{σ2e}}{\eqn{\sigma^2_e}}, represents \dQuote{the excess variation relative to what is expected from a certain distribution} (Nakagawa et al. 2017). In (most? many?) cases, this will be \code{0}. } \subsection{Residual variance}{ The residual variance, \ifelse{html}{\out{σ2ε}}{\eqn{\sigma^2_\epsilon}}, is simply \ifelse{html}{\out{σ2d + σ2e}}{\eqn{\sigma^2_d + \sigma^2_e}}. } \subsection{Random intercept variance}{ The random intercept variance, or \emph{between-subject} variance (\ifelse{html}{\out{τ00}}{\eqn{\tau_{00}}}), is obtained from \code{VarCorr()}. It indicates how much groups or subjects differ from each other, while the residual variance \ifelse{html}{\out{σ2ε}}{\eqn{\sigma^2_\epsilon}} indicates the \emph{within-subject variance}. } \subsection{Random slope variance}{ The random slope variance (\ifelse{html}{\out{τ11}}{\eqn{\tau_{11}}}) is obtained from \code{VarCorr()}. This measure is only available for mixed models with random slopes. } \subsection{Random slope-intercept correlation}{ The random slope-intercept correlation (\ifelse{html}{\out{ρ01}}{\eqn{\rho_{01}}}) is obtained from \code{VarCorr()}. This measure is only available for mixed models with random intercepts and slopes. } } \note{ This function supports models of class \code{merMod} (including models from \pkg{blme}), \code{clmm}, \code{cpglmm}, \code{glmmadmb}, \code{glmmTMB}, \code{MixMod}, \code{lme}, \code{mixed}, \code{rlmerMod}, \code{stanreg} or \code{wbm}. Support for objects of class \code{MixMod} (\pkg{GLMMadaptiv}) or \code{lme} (\pkg{nlme}) is experimental and may not work for all models. } \examples{ \dontrun{ library(lme4) data(sleepstudy) m <- lmer(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy) get_variance(m) get_variance_fixed(m) get_variance_residual(m) } } \references{ \itemize{ \item Johnson, P. C. D. (2014). Extension of Nakagawa & Schielzeth’s R2 GLMM to random slopes models. Methods in Ecology and Evolution, 5(9), 944–946. \doi{10.1111/2041-210X.12225} \item Nakagawa, S., Johnson, P. C. D., & Schielzeth, H. (2017). The coefficient of determination R2 and intra-class correlation coefficient from generalized linear mixed-effects models revisited and expanded. Journal of The Royal Society Interface, 14(134), 20170213. \doi{10.1098/rsif.2017.0213} \item Zuur, A. F., Savel'ev, A. A., & Ieno, E. N. (2012). Zero inflated models and generalized linear mixed models with R. Newburgh, United Kingdom: Highland Statistics. } } insight/man/get_weights.Rd0000644000176200001440000000105513566471215015305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_weights.R \name{get_weights} \alias{get_weights} \title{Get the values from model weights} \usage{ get_weights(x, ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} } \value{ The weighting variable, or \code{NULL} if no weights were specified. } \description{ Returns weighting variable of a model. } \examples{ data(mtcars) mtcars$weight <- rnorm(nrow(mtcars), 1, .3) m <- lm(mpg ~ wt + cyl + vs, data = mtcars, weights = weight) get_weights(m) } insight/man/format_table.Rd0000644000176200001440000000206213566471215015432 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/format_table.R \name{format_table} \alias{format_table} \title{Dataframe and Tables Pretty Formatting} \usage{ format_table( x, sep = " | ", header = "-", digits = 2, protect_integers = TRUE, missing = "", width = NULL ) } \arguments{ \item{x}{A data frame.} \item{sep}{Column separator.} \item{header}{Header separator. Can be \code{NULL}.} \item{digits}{Number of significant digits.} \item{protect_integers}{Should integers be kept as integers (i.e., without decimals)?} \item{missing}{Value by which \code{NA} values are replaced. By default, an empty string (i.e. \code{""}) is returned for \code{NA}.} \item{width}{Minimum width of the returned string. If not \code{NULL} and \code{width} is larger than the string's length, leading whitespaces are added to the string.} } \value{ A data frame in character format. } \description{ Dataframe and Tables Pretty Formatting } \examples{ cat(format_table(iris)) cat(format_table(iris, sep = " ", header = "*", digits = 1)) } insight/man/has_intercept.Rd0000644000176200001440000000130513566471215015622 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/has_intercept.R \name{has_intercept} \alias{has_intercept} \title{Checks if model has an intercept} \usage{ has_intercept(x) } \arguments{ \item{x}{A model object.} } \value{ \code{TRUE} if \code{x} has an intercept, \code{FALSE} otherwise. } \description{ Checks if model has an intercept. } \examples{ model <- lm(mpg ~ 0 + gear, data = mtcars) has_intercept(model) model <- lm(mpg ~ gear, data = mtcars) has_intercept(model) library(lme4) model <- lmer(Reaction ~ 0 + Days + (Days | Subject), data = sleepstudy) has_intercept(model) model <- lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy) has_intercept(model) } insight/man/download_model.Rd0000644000176200001440000000165313566471215015767 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/download_model.R \name{download_model} \alias{download_model} \title{Download circus models} \usage{ download_model(name, url = NULL) } \arguments{ \item{name}{Model name.} \item{url}{String with the URL from where to download the model data. Optional, and should only be used in case the repository-URL is changing. By default, models are downloaded from \code{https://raw.github.com/easystats/circus/master/data/}.} } \value{ A model from the \emph{circus}-repository. } \description{ Downloads pre-compiled models from the \emph{circus}-repository. The \emph{circus}-repository contains a variety of fitted models to help the systematic testing of other packages } \details{ The code that generated the model is available at the \url{https://easystats.github.io/circus/reference/index.html}. } \references{ \url{https://easystats.github.io/circus/} } insight/man/is_multivariate.Rd0000644000176200001440000000174013566471215016176 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/is_multivariate.R \name{is_multivariate} \alias{is_multivariate} \title{Checks if an object stems from a multivariate response model} \usage{ is_multivariate(x) } \arguments{ \item{x}{A model object, or an object returned by a function from this package.} } \value{ A logical, \code{TRUE} if either \code{x} is a model object and is a multivariate response model, or \code{TRUE} if a return value from a function of \pkg{insight} is from a multivariate response model. } \description{ Small helper that checks if a model is a multivariate response model, i.e. a model with multiple outcomes. } \examples{ \dontrun{ library(rstanarm) data("pbcLong") model <- stan_mvmer( formula = list( logBili ~ year + (1 | id), albumin ~ sex + year + (year | id) ), data = pbcLong, chains = 1, cores = 1, seed = 12345, iter = 1000 ) f <- find_formula(model) is_multivariate(model) is_multivariate(f) } } insight/man/is_nullmodel.Rd0000644000176200001440000000141513566471215015462 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/is_nullmodel.R \name{is_nullmodel} \alias{is_nullmodel} \title{Checks if model is a null-model (intercept-only)} \usage{ is_nullmodel(x) } \arguments{ \item{x}{A model object.} } \value{ \code{TRUE} if \code{x} is a null-model, \code{FALSE} otherwise. } \description{ Checks if model is a null-model (intercept-only), i.e. if the conditional part of the model has no predictors. } \examples{ model <- lm(mpg ~ 1, data = mtcars) is_nullmodel(model) model <- lm(mpg ~ gear, data = mtcars) is_nullmodel(model) library(lme4) model <- lmer(Reaction ~ 1 + (Days | Subject), data = sleepstudy) is_nullmodel(model) model <- lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy) is_nullmodel(model) } insight/man/get_varcov.Rd0000644000176200001440000000511013613301122015105 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_varcov.R \name{get_varcov} \alias{get_varcov} \alias{get_varcov.betareg} \alias{get_varcov.DirichletRegModel} \alias{get_varcov.clm2} \alias{get_varcov.truncreg} \alias{get_varcov.gamlss} \alias{get_varcov.hurdle} \alias{get_varcov.MixMod} \alias{get_varcov.glmmTMB} \alias{get_varcov.brmsfit} \alias{get_varcov.mixor} \title{Get variance-covariance matrix from models} \usage{ get_varcov(x, ...) \method{get_varcov}{betareg}(x, component = c("conditional", "precision", "all"), ...) \method{get_varcov}{DirichletRegModel}(x, component = c("conditional", "precision", "all"), ...) \method{get_varcov}{clm2}(x, component = c("all", "conditional", "scale"), ...) \method{get_varcov}{truncreg}(x, component = c("conditional", "all"), ...) \method{get_varcov}{gamlss}(x, component = c("conditional", "all"), ...) \method{get_varcov}{hurdle}(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) \method{get_varcov}{MixMod}(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) \method{get_varcov}{glmmTMB}(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) \method{get_varcov}{brmsfit}(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) \method{get_varcov}{mixor}(x, effects = c("all", "fixed", "random"), ...) } \arguments{ \item{x}{A model.} \item{...}{Currently not used.} \item{component}{Should the complete variance-covariance matrix of the model be returned, or only for specific model components only (like count or zero-inflated model parts)? Applies to models with zero-inflated component, or models with precision (e.g. \code{betareg}) component. \code{component} may be one of \code{"conditional"}, \code{"zi"}, \code{"zero-inflated"}, \code{"precision"}, or \code{"all"}. May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{effects}{Should the complete variance-covariance matrix of the model be returned, or only for specific model parameters only? Currently only applies to models of class \code{mixor}.} } \value{ The variance-covariance matrix, as \code{matrix}-object. } \description{ Returns the variance-covariance, as retrieved by \code{stats::vcov()}, but works for more model objects that probably don't provide a \code{vcov()}-method. } \note{ \code{get_varcov()} tries to return the nearest positive definite matrix in case of a negative variance-covariance matrix. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) get_varcov(m) } insight/man/format_ci.Rd0000644000176200001440000000313313602361463014730 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/format_ci.R \name{format_ci} \alias{format_ci} \title{Confidence/Credible Interval (CI) Formatting} \usage{ format_ci( CI_low, CI_high, ci = 0.95, digits = 2, brackets = TRUE, width = NULL, width_low = width, width_high = width ) } \arguments{ \item{CI_low}{Lower CI bound.} \item{CI_high}{Upper CI bound.} \item{ci}{CI level in percentage.} \item{digits}{Number of significant digits.} \item{brackets}{Logical, if \code{TRUE} (default), values are encompassed in square brackets.} \item{width}{Minimum width of the returned string. If not \code{NULL} and \code{width} is larger than the string's length, leading whitespaces are added to the string. If \code{width="auto"}, width will be set to the length of the longest string.} \item{width_low, width_high}{Like \code{width}, but only applies to the lower or higher confidence interval value. This can be used when the values for the lower and upper CI are of very different length.} } \value{ A formatted string. } \description{ Confidence/Credible Interval (CI) Formatting } \examples{ format_ci(1.20, 3.57, ci = 0.90) format_ci(1.20, 3.57, ci = NULL) format_ci(1.20, 3.57, ci = NULL, brackets = FALSE) format_ci(c(1.205645, 23.4), c(3.57, -1.35), ci = 0.90) format_ci(c(1.20, NA, NA), c(3.57, -1.35, NA), ci = 0.90) # automatic alignment of width, useful for printing multiple CIs in columns x <- format_ci(c(1.205, 23.4, 100.43), c(3.57, -13.35, 9.4)) cat(x, sep = "\n") x <- format_ci(c(1.205, 23.4, 100.43), c(3.57, -13.35, 9.4), width = "auto") cat(x, sep = "\n") } insight/man/clean_parameters.Rd0000644000176200001440000000414213566471215016301 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clean_parameters.R \name{clean_parameters} \alias{clean_parameters} \title{Get clean names of model parameters} \usage{ clean_parameters(x, ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} } \value{ A data frame with "cleaned" parameter names and information on effects, component and group where parameters belong to. To be consistent across different models, the returned data frame always has at least four columns \code{Parameter}, \code{Effects}, \code{Component} and \code{Cleaned_Parameter}. See 'Details'. } \description{ This function "cleans" names of model parameters by removing patterns like \code{"r_"} or \code{"b[]"} (mostly applicable to Stan models) and adding columns with information to which group or component parameters belong (i.e. fixed or random, count or zero-inflated...) \cr \cr The main purpose of this function is to easily filter and select model parameters, in particular of - but not limited to - posterior samples from Stan models, depending on certain characteristics. This might be useful when only selective results should be reported or results from all parameters should be filtered to return only certain results (see \code{\link{print_parameters}}). } \details{ The \code{Effects} column indicate if a parameter is a \emph{fixed} or \emph{random} effect. The \code{Component} can either be \emph{conditional} or \emph{zero_inflated}. For models with random effects, the \code{Group} column indicates the grouping factor of the random effects. For multivariate response models from \pkg{brms} or \pkg{rstanarm}, an additional \emph{Response} column is included, to indicate which parameters belong to which response formula. Furthermore, \emph{Cleaned_Parameter} column is returned that contains "human readable" parameter names (which are mostly identical to \code{Parameter}, except for for models from \pkg{brms} or \pkg{rstanarm}, or for specific terms like smooth- or spline-terms). } \examples{ \dontrun{ library(brms) model <- download_model("brms_zi_2") clean_parameters(model) } } insight/man/print_parameters.Rd0000644000176200001440000000745013566471215016360 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print_parameters.R \name{print_parameters} \alias{print_parameters} \title{Prepare summary statistics of model parameters for printing} \usage{ print_parameters( x, ..., split_by = c("Effects", "Component", "Group", "Response") ) } \arguments{ \item{x}{A fitted model, or a data frame returned by \code{\link{clean_parameters}}.} \item{...}{One or more objects (data frames), which contain information about the model parameters and related statistics (like confidence intervals, HDI, ROPE, ...).} \item{split_by}{\code{split_by} should be a character vector with one or more of the following elements: \code{"Effects"}, \code{"Component"}, \code{"Response"} and \code{"Group"}. These are the column names returned by \code{\link{clean_parameters}}, which is used to extract the information from which the group or component model parameters belong. If \code{NULL}, the merged data frame is returned. Else, the data frame is split into a list, split by the values from those columns defined in \code{split_by}.} } \value{ A data frame or a list of data frames (if \code{split_by} is not \code{NULL}). If a list is returned, the element names reflect the model components where the extracted information in the data frames belong to, e.g. \code{`random.zero_inflated.Intercept: persons`}. This is the data frame that contains the parameters for the random effects from group-level "persons" from the zero-inflated model component. } \description{ This function takes a data frame, typically a data frame with information on summaries of model parameters like \code{\link[bayestestR]{hdi}} or \code{\link[bayestestR]{equivalence_test}}, as input and splits this information into several parts, depending on the model. See details below. } \details{ This function prepares data frames that contain information about model parameters for clear printing. \cr \cr First, \code{x} is required, which should either be a model object or a prepared data frame as returned by \code{\link{clean_parameters}}. If \code{x} is a model, \code{clean_parameters()} is called on that model object to get information with which model components the parameters are associated. \cr \cr Then, \code{...} take one or more data frames that also contain information about parameters from the same model, but also have additional information provided by other methods. For instance, a data frame in \code{...} might be the result of \code{\link[bayestestR]{hdi}}, where we have a) a \code{Parameters} column and b) columns with the HDI values. \cr \cr Now we have a data frame with model parameters and information about the association to the different model components, a data frame with model parameters, and some summary statistics. \code{print_parameters()} then merges these data frames, so the statistic of interest (in our example: the HDI) is also associated with the different model components. The data frame is split into a list, so for a clear printing. Users can loop over this list and print each component for a better overview. Further, parameter names are "cleaned", if necessary, also for a cleaner print. See also 'Examples'. } \examples{ \dontrun{ library(bayestestR) model <- download_model("brms_zi_2") x <- hdi(model, effects = "all", component = "all") # hdi() returns a data frame; here we use only the informaton on # parameter names and HDI values tmp <- as.data.frame(x)[, 1:4] tmp # Based on the "split_by" argument, we get a list of data frames that # is split into several parts that reflect the model components. print_parameters(model, tmp) # This is the standard print()-method for "bayestestR::hdi"-objects. # For printing methods, it is easy to print complex summary statistics # in a clean way to the console by splitting the information into # different model components. x } } insight/man/link_function.Rd0000644000176200001440000000237513613301122015622 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/link_function.R \name{link_function} \alias{link_function} \alias{link_function.gamlss} \alias{link_function.betareg} \alias{link_function.DirichletRegModel} \title{Get link-function from model object} \usage{ link_function(x, ...) \method{link_function}{gamlss}(x, what = c("mu", "sigma", "nu", "tau"), ...) \method{link_function}{betareg}(x, what = c("mean", "precision"), ...) \method{link_function}{DirichletRegModel}(x, what = c("mean", "precision"), ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} \item{what}{For \code{gamlss} models, indicates for which distribution parameter the link (inverse) function should be returned; for \code{betareg} or \code{DirichletRegModel}, can be \code{"mean"} or \code{"precision"}.} } \value{ A function, describing the link-function from a model-object. For multivariate-response models, a list of functions is returned. } \description{ Returns the link-function from a model object. } \examples{ # example from ?stats::glm counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) outcome <- gl(3, 1, 9) treatment <- gl(3, 3) m <- glm(counts ~ outcome + treatment, family = poisson()) link_function(m)(.3) # same as log(.3) } insight/man/figures/0000755000176200001440000000000013446526427014153 5ustar liggesusersinsight/man/figures/logo.png0000644000176200001440000035720513446526427015635 0ustar liggesusersPNG  IHDR [u` pHYs\F\FCA IDATx U}dّb9&+ jȑ-U)IBt{7N^.3+&Sfv(h&Lb%js"9;Рs}|?U }ν{<ijjZcL1f;i'B*hbczgagMoVPe]TWʂ W J*ho5,_OcN^Z ZBƘ K8"aʮE"4`jF{L- Ǫ~"X(Bha#7nÃyحCD ز81̮hA^3+ 8JoA\ˎPmxF@Bk/# 4T\E˪~..S(qS*B@%kx@*ԙ%8nAh}lE@Sv }J 4D4N vh͵0#Qqea3  :v+(ae.^N@Lj!\ 0@~`D(;fD# !=C ARoAToyn67tׇ#7/}j{6+ #,˯7y$ԥfIwp/S(a{ Uo]r'̏Wnpoglx@ xSo`Trz7I9n^#4xﳿ؊z z/&=mYx\4䨂6eð|7~2~"4xFOr0 f,{><u>"4xhO_GnsﭾӇ̟EinYAaV^[П6&' Mכt}[GhZY @[ʦ- <)uPX#4t8JoluނR߁VMt|DB}݌ht tv(n@+ 3BhѨ83nF4JEh(-r^z~-PX9gĈFwmY"}P B(-PXsF(&-@w3}}PB(@Ѭ"mCE &Oe[)uP`'Ph{ d,@obMY8n5vc`@\kz PoAns9 Ymwθ &b9 BPr^c~-ʂ $Ϧ볕8s؆h%"4%5}60 ''9VT^{D:;pb%Ep,P:BX$;Bq7[CF(W҈F%wCh dG(IY~+͹l+#iD,lVq#` lo"\姭.9 PRIt?[k4w 4ynz'-rh qݘE1 fa{ ]-QCht ; @r^d;@Aw3};-c+B~-DQP- wƔ]iF3"#EME(4eL- "9XBUk4ڰ SoAns9A{ɬ6;pg܆,ʱ[-pCZY`r"l>[y@߁3mxBhRjf-: '#y@߁S(q(c!4P v(n@EP *Jt3@8Jo+͹l+#0iD#D@fP+"'d,C`9n1~,bEh :F[@o@}cnL٢ D(,Xëߺd n;Ъ҇y8cD@loAnh`bw3};4B[V[ʶ,ɈFw#4P*[g!'Pc7Oe[)wLJc{ Pt'9:1i;P B5kF(:]l:^2>F43n,Lr@Dh0v+‚[П6&'B?l ;p ز Qk4uh+B[y@߁S Qz ؔea#H}Zup4%BNPPѨ83nF4ȍ@.@!{9i+BlNB?X#,ĈFwmx@w!4pAaVL~2f&'B?γ}lYp Kjf7[mEK[y@߁Sp‚vulJƲ@ywUG-u7&c1 #4*̎P he#s4Q+;pF}݌h [e@ad,ChId} ۲D!4*hz'LOr!mYIw1^7lp0XB"j` y~뒓?EF4sü\n}h*-PX:\VrHoG}*K|٬s ;"FhDh+^4BQSٖ^; B@jf-`=,0⡾#飼nLھe@DloAnh`6z b;9} @VlO#[`r"C,г}lYGhhmw#sRo: PMڲ],B PFs]]@oluhtKυ#v(B 0v(n@+ KfG߁;;fD#B @zySo‚X(ؑtKmgmY"}@ >[S'9ViHwlp0"4It;`D#)BC@a^VsY!Wޗ%lVqN8nڊ%?mEz EQ߁VevL#}' On[EzY!@E#飜k7&mh 0[Pg8ص@ws#}@b"`+A~8lq;ؙ>ɈFw 5u]Ŝ#h#]HPZѮ.MX6w) G-FnL) b8 @ jZ[z vP /f`z}`"|Ehh]/9?h#҈Fm[awF @Ajf -ȩ[Г`+ xڲ0) r@O Qz X4.F(~\0/;fD#H\a{ 6pN[ie%PN#UYkqwFB '[{8i+V[h[k4w@hPk4z IfEJ}*JI=Ɣ]u0@h,-3B PFovNbD;,` E rd;A};'aw,@Fn ؊S{"kxFm[)uPXPk47F(:)˦"[@S[8snLھc1 PB`Fs -p@]l@'dV}3nÃXpj[&'B?l>[y@߁3ö  F-IhH#<) Ep,2BrhD;pF}݌h Pqv U?.4粭P34Q[^6x8nш"4@%mE; ?mEOvX@[@- c;@rjf]]@ovp/Svh ,*F(vmϩ`!F4sƆ =[`+v~8l`g$#9l'-w Z3z ؊z 4Ac@ʶ,yvcnY8 |ZֆPt@]lYmwθ &b9 c" [z D l ;p ز 4@G>[tHoAN-Pg |- <)[8 0(8Jo-PXE#hTxp4ш2v(n@a#@4Q}Ό( 5ct~ڊП2TБtHehD PZm-p7y$#3> Ɣ-J`B8g{ .9.D}Zu\0glx@"43E74Bq0NovO2ѝ6<N }lEO*9Ex*۲8}nLٕ 7Bb{ Pt'9*R߁Q^74N 4͵6dߵm,ydV}htgnYPB,݊0Do-Ov1SϦ@w- X0B,XѬ[z Y,'lA=cA  pMv(nlJƲ  [8knBɎP (,`"iD#1+B-r^N~ڊП2G-f ϖwpB\P ӓ`"@4q$a8nL٢DF4Bdlo‚5%'O}Zu\0gۍ36<Ug{ lpA#t4eqwPae{ z Tr1謧- wƔ}8DA5T-3Bэ`[(8IUqc%wP1Rk4ڔh`6z <Ӈθݲ0a~`"(,Zsz DPϦ볾y8l,D rFNo-Pg" Lڲ]s 48JoluS߁VMjnF4Ɖ 2v(n@+ h##Bh [eAU?.@ad,[g"@h;Bq7z'LOr- #3>Ɣ b8*#4-_5U?.KNd#*L#anS;Alo‚ U?.4粒Cz Ц%lVqN8nCh[{~.\Eh"0- 3ѝvL#} 4-3Bэ`[kQ߁QΕ`4loAnh`6z h;9}xnEPo֪ 4BQ&'?tԳ}lYjfv0B1'@[eA81eKT [@oI- #3>ƋƔ b8̎Pԛ}M 뒓?ExG#a^7ؾF4Р$@aJpVsY!TYkqwPBmED#[1@HwhtfHA Tk4mo#IfT8>kƤ;`|DhP[Pg8صDC};1ѝqwCv+z FsPvz -LdD;m[!4phmw#sRo: mYx*A߁StANFs]]@ol*ht vS ȎP w6w1d/f`z}`"*"-s z as2VS\A#mgmY"}@hF-I,;;pgCP Pԛj?l%'MiD@<>)sC}݌h6By!ҜJ,F4,e3qwp!),lo" "he;,8׎i*W5vu$Cz wđQάSvh  e{ PtC#[L};1ѝq[XChp@aV~i`Pm_>1q`g$#9lÃJty3tLTX0A`z z'p]\M*Ҡhn=q)˦"[JJ`^;ДNX  jZ[z vXj30wmx0]K%B;BQKJz=qMD`"B`Q4Q;pfD?1NZg@`_d׽@@tx{hW.9i]P~`dѨU8XG4F-\VrDB 7hTYf'Ӎ ф@KCxOKmK3;H}T7Av,}Qtn[@`9]_pb;tF(vms[pZch79^7Ƅ1sr#OT ;4 ӇθJ-PXՃ'x8lw[{s_1zN;*sp(vO2ѝ6< Рhmw2~F(~|690nŘFYRll=i(Sl}NLٮ͍v*#ؔeSޗoВۇs×T1\EhfY6eL) AC>45kmX@o-m6g0)cn(`B"P0-XBrjG4x* 4Bh*,EdOgeκ fRxru1wE1@\T/t w 7~Iú/tz=P\ŹhbLJ-ÿ? E݇~- Nm_t,45ݶ`O'O@,tfsYKVl,̱\ }Owб/C[z >\\o\xc|.i>E+M#DAiz jz 7Ƭ)ύF(~%y]?g~̼ZQvbIl~`\ O[>ԉ{>yW^R-$}!us\,*wN-} }NzBCZц{؊&?Ɂ.N[ךI <_S0щe>{w"~Z5CLDpCvMjRqnW`0nzf`z3TA[njԈƾ| 44K#؆'̓ɉn2$И\\ADwl w휠|Oka7v=h9iFh)ԍ^~kr<X >ZKpi5^t)3>n[>h˗lpt*Ϗx\{_|{"č^6,< vD .,7\#%8V`hcP|.@5cJ`P0@IlYpB:qQA춽{J=HiߎFlq䈞n,)csq c|.f;r^Mpb;^o@FSk G.9i^> ֋~sCƼ"N~IM}rm?5hjƘ5>hW7_p!W_EӓC~ 0|.P?>JS^ؾQW8YCPOpz6J$ނz_klNu4 @8\0};pB+45mX$}8M~(%fqNZ !P.>(t-Owp)45kkBjG3 ?6'>Q `!̧>Y N@^|.P8g~K]Bnm),E-Ab_7ɉgqn]Esk7δ1@\-->zpO2'J89=7>]s{Ƙ.;B 'iPp5cYzc(Wb"}lJVoS2b"K+6[f{ʦVY\;4@Xi0qs4RS}3 EJvɌe/Ѭ#1?-uٟl7s)ݯMolYXBEjm6'cAPU}8 .9i^J5Et?:aa A#9"E8Ny ._H~=AoEy}}s#4EOr0w?Ox7B4BDL>P/e䗲QwD~P?ҡF(~<'tOg|AeCMɘ9 E*hFk &t*T&4~l #HO꾲J} d׽fsۜmu7ϬCuIBV^EF(3uΘE4&_PoSQTFa|!l2SmDc4AOr0? jt?Rݟ"@#/?Moֵ|/d?}j #gX `r" 󁵭o|sò)cޘhNs1ߛ_z}߼k­k#|f}֛Y{[ƙYi55\kIA9PhDz335y;^L=9LCCMKRF7_nO=ڡ~-&Z϶rl+ gүY kaq>uCIq70>nJw}A A1!EE]\PFO/3?QۊKh{~._~^MҽC~=VfYh%9@[LDUIB/5[~hKOt"ܐ1s bʟϴ;6ϯϴv">ۊ>3߾~v=uc>'c)VL}}3L bB B`/}/VH3 -ԗ~r8 N>c.)V 6{AA7ʸZ3Ma.g~\m!CPߟ@tc髄@zYDal0K 盩hz+@@֦=Z26 un{?r5Qc~|0צ%[.Vl̤Zy&Wim훳/*4@>gUW?sk?@1f8~aݦŬĈn‚Mn^b m8z/3ކlU/߽@yg!}xqԓf=CveLA{Aܴ[7_y>n_ʹ%1m*P9 7zru'hys!Bg]퇾Z>h _1rmbo۫*E e3tq)'Z!P,F3R*OUV#" T ]1} 3{/^tzL21I!>Z]sQV,鳸jm B F-t.VĿ7=Ejo[Ͻ0VƼ,ws@ =B B,97º +x/#0+gUd:ba5B T8[*; x[(@CL 혝F2޴{/\f-U&T"E[-lMOkN%{s-'p) \_־xMۗSI$Ot;G^-^f4hU$06\taeU8&`i8nvm}\i“QDZ>]{}U_oiߴoFY{$+ B i+ĘNc{ B /}1j$VtȓӅ c~3N.yLOOg f3Wq*D͢u pof86˟#3gxn{>ИY]`V~>6Dh1|̥-#0 n}<=/|?=.tn nD+9;`!o۱qzFGǷ0ی ˻N c:{o̊RH"-7SL BW3; }<7اmwll]drc=d8>̽zªpzMKg}!IaiyC~sC_:IUu.WFhpK.{x9W EwvҼ{1SR_ŦVK]- q.Fh>X]_it‚N- nts]5!L>,V0~a{[7tZY̧[Nt<;(,m e)⽶X VP  .tֲ /O~X2n])i_zruxքtr7z|e?>uC_!MgV'{}x1+=wUf]8tzOmiWV&<W\M{@lMO's얩N? FqځU{;^w/ 1.үfꉋn;qʤu!F 4qNk97ܺI=O?g>Q {^wj>R+K%\>A IDAT*IKbg6%}FtS/:ʈ\BhH7!,=ƒ Eeږ@;31뽭e&8tSwoV"4bS6e_ [[|UJ[cU Epо{13 `N@LtS6]]T"Kb馠I%m Wʢ6_{̋E<>NQH(_?PO3!"LZ\Й11,-,yBժgJ.d$B /n´?Vy2k:$,Eߩ2'-1Lx6B7[ 4,~W/둔 m >.,rUEn)kW`]`nzR݅:;T6'xB d y1\1KO`(@D\eXGeeEWkǶWOZ[{EhTda|{/+lzZmp+ X-tSdob V j[mpBX{4ZmԛWgpUŇYYO< HQYeυ2 S}ڌKCEڠp# (@T.p򻫤)= j7V`ڠ4e rȲGViB DUxV*]EOj,SI?~@m[Ę7[eh>(c5Bh 58>a# BQ;8x}<̟m!,elO^!4PsC{^"4}Ϙg>mS 7Ob?  sdm=mWy"DBhx7Z-XuPU!Bͷ|pKeUyTHTxF+T5^!4++Z[B-JxF2W ea,5@hUa9 8(TM;<ŘS=ai$8(TٷG[c~Wq" (̋+~ N|1#?ꃛV >xp.W|c }r{QN7x- `}FQoLvAhXƱ~(+K5#5s( `၊;mAcB\ۍl_{sq3'tF×Aux7 h$VhTcٴn^̢؎( -mYШg>]~*  `h}"$b\8XfpI ,m/J40v PB@qTWvpbi%I=VJBh(V7+c+ w:@D M3%f) *׀&s#Ph5Ub̉P"B@yU/g7Uʑ2^G(̎(teSi~ w? }{8kbciO:^8u|L9UV@s{o lFh~Ҙ [U$5uAk{zz_#OَlZm@YT6l. @{b 4_̷5Zt_ڳA_)_O\J찠'aP ZSB}Z[P?CFZy{e^A 0+BB&,D;@KO.*idCaG'j79EV9c5  ,.IܺrC]Tܼ -mlV~r9ׅB{BK{vfEմUiO 8Xd2l5ߤ߅H"fGh> r\}ڡӓlT >S*|Pք+˵V\c}1mD`iBO_ǨU|P ( t[ ^zbV_UjE`^B(BN[քgϚ74g蟭7͙gfꅏ+} AO4CqL:"3K$.!4NZքIo~7OL}oOӗo~o|g!§Y,zjiS7fU_S@|[]KxB$Xt؞ٱ=:i[;_6ksyWm3w̯~s/T0@QdrlXưWЯ9@SLud[vڙ,=57}|{)@xg<XORWu*IThƼ>q|֓Iga{w̙3]w'?a`{SCYiC?>mx4;4gǯ7?7/SR347ӧOg}gma8=SfnЦ=úm !.tvg j |׮|f ^tVQ#4K]w?_b, <3;+-K/mSH@3uf]gAj~6jb;_/7w{W,?/ŋ7|kf)oWo v@OgpSh @u|?u?ܝ7wxx{/[/x_1e{مa)z<[L(.p VlҪw^Žg=U{ۜvXP'b,džs?R_?͟dQX>=Y_zY.Ȋ]o~bcu|?S\qC?uٯ~|d[.MGͿ}"0mVu?lYZ=M34|9zd>'?i/k:~yd,<(lAlaʧrR- e@{S" (Z=nI=s{/]gM%srקL7.\tW{bp +fުmWy FhR4`Ν * ͏sB>*7#;z+o]RЦ U_xͲj=5ӓ/]|wfc|o๷o6?.z࿾ٖ/|a\}r_mMoO8MZ={ZU׾\ 0(@2~B?]\kˁoOdx|n 7v} ?n︿f?7:a'^xrWF얪UU?P`)y䟽<Ѽ'uvvۍf;?0gW'6 gAoRkf]5{`0Ӻ.or3Zo9#Y80?ÿʆ5/|?=MW;vdOLObu"8nHPf $ p-A߳,-^<}bm>Z~=Y@a|6! `]o7#ql)ΰڋtgTcx~M,vG=(B40VC`x͢~PL `3$RU;{`DzlT 'بVjjuy#f;l,TSt[3wwXhoOB9v$@+6GBB!(PcU|׿0ƀƴƝ\  +{\ [ve<]b1TVkبx, ^@d,Jq¢h0L x<]Oidr 3UT ΧJyWYm ;6}$[~{RI/oLxk9A0lp`SaT RlZtCnOm7O:&x<c^ B<hI;<TAzB'^ifGbAXN勘aJ^a'AXh0*K.tP\~> 1if(xWZ|YύI} juKI{nʢ\k6QSL8w1ob"nO0 ,+Sh4>qp:A- N+cT"E40n0 ߮=Z0AǏZiُԂ:& (N FaX<B)g;_Cx MD5^n0)5>%*yLK\2 :C珄#W ^)LgOU0K3Nx}:P!7a"0L6T+ӣ%k-/I{+lwQee;ݺ^Vop4H3?>0+d3|>lnѩhcRcZci  DB㞛A UoƩ+G%}ɺ;IJV9p;UrNv0LNaz-Ow6^` IWs: P:=PK&YfcXrCPp F[d (@؆X^` : NKR )M+̐9:=0 3 5`ޕZ~LӫQ9ڢKɀ;1zjhY?Ij+*  $R(1w5kեe 3J,ig:g0 *k=ۊbixz%62v+K=~[$s0)_;c(@3QV-rUkR( D>W0LH4x[5~oimq}&$zvhV 4(FUQ{LNïC+;gg&@ 40Fq]1楉{jZ&ϲbV >'0dhtEf6eJ>A f6;o5SU|Ӆ@A81Mjz:pSmBQh,`UZ0 ,jN74J|+Nq9sU!{T? Zx IDATFG95LZ(ͬ=N!!=1;3  Z<-X+*b+M4T` t.=t.@aүm5"36X.|bᏮ}{<,Ω7y:5rb )JޚlH 8 %xH]~?Kr H# 3R;j~O /}^j3LoEaBE0}v1L;=ѵۍ,4=9>I(Whz[hZ}|NM+ ']Nƿ9/X1.3,^%c(60`kDpu$VJu}pҬpxi\0((J;]6FX4`&( = G`bnF ! ,`{zvH9r{6Jkw PWē&*A>9]ri^y"*ԧFV }ƝT o?j;.M{Ls.d ?Xq~asw4d=V h0!@( PLLpS¢k4gLm)?SbI&pvzieWR JDxrX0 '(K024bAɻqO`.kߌ1- 8d;=8}W|`@]Zp]\X4`FWܱq ZڕUP<ᓀ>V:S@;,OebhpJ`ZfB&RGX4`]@=(M"lMϱP^YȾfS]Cg#E"بCpI_n~Eh+` >,0 p9Y3/Z̞ 4]/uIE5 Ēbuʔr;]ڶKco:Ms{âS `jUwh``*6ߝi!J;<pl}^3 nGԧ3\EAAL\+j !u {N6UG 8 0Fxӳf hb]yk^84B= q?[b^MaG@ૣ6zgK;v]yOz&hhS-X3e Ե[RFgiƆxtBOP{mT0@](+%-+8@őmtN;:Tg&BZ010Z0G_gߕ`Bo@ܥw4I*1ܳ T\x.Pt/Pv㑂 ̿;y,[L0koca"4`/GG쒀!a ͺ֋1_duY1c0֏Sr\Dknkm;e6fm|w)[wS٤>(+ %xaŒU ;`}hdjH&A TBP%9îmXo8~I֞WIU\Ÿ5:sS}^_HvIӁvYp,+ .Z"uӴq%<|i2l`ζO-\al`(`qdvkûmT_knlz]- (oZ(ey`:B[f \ =xK֎I]c#ѝV ~lV%P?w0g L1C.$ wΦuW xe `!kJAv`]$B+I>`hE>0(+e|"8d kb `o٩pr'rf.B?yA'ғi(u[_( JAَYv)@wC&ik7YxZQK{V酗e\0 .K'a xjn/ GB0*'`jF`(wo0ŠۈA4Mޝ58' w 6 |(x]`b-: .vx! ,S<@hn%{^FkDODO)tC8jkq 3P:$דԸ25;N% pw0zNd. Q:@?j<-WD L0z7yG,e=x3`{p)B}BSnvޥY0LóEa|=l$eVj U0DKD+HC8A=Cm91Hi'V_&D()L26{- uo*]@$״-G97ouH1yiJҼIaҿOzBp &MPJjomgy{v>Eu D]( K8@<6]üo'noKH4;(kh஛Ÿ*MnXB88)" 8+Oa菧^] \.unW}C +g &z93UVV6{`qHODR,@׉/M]+ ?y+栢 D,0 7h8Z_s)ӗD r~&i!ɹnuNyUC>R = R[k]K-UQVB ;M@TO+H4䥘H›OHX/ X ,1 薀s3*ӻqbꖍH%НZ* ƽq=NQN`3`Q ^X4`& PˈIv;<W_-[ִkNG[>&b|*M&v paS@5RH@6fspp(92G Bgc AqO/,nusfUqx2@7Bx?!MhC҄@CDl 5-*r D_AscБ'Co43_ny6ݸpv"pH7=2  ElB&@X#7-!,̋:\y >1ć?W[pC혖p@|-XP8>ɖS[Iv&%&}L (FR& rzr?KFk,ịq}ta<0҅zҙz֕e;\6UҿOh(]-`JݟۻhSRƕwTu 9 Vi$  MfZjv`,V2p! 0z0aAE/-qĘvGh -,1.{EN(]pv|)]+7ai儺4!87,: AȞOj.Cd8Wd9Z.W`\n@*K<K c'[]h0L :f>3|.Q7NtJ(=(>9cnS x葍@ʷ=I' @$" JP(K$@0R!Ȕ"7G]С㠱N?jT]1~P+%k'㗯D, 8&0J蜥Bh1aEa" b~{;PQWp] oAʪIwvSKeMCwȅNKîx*ީK /q^:$QVt]*  .QUvP@g JkB^. a DZur]5qظU?Yxc\҉"z8zcN x Us6(KHTv[O+(Fs ṕ²:APXvEӎvz%zUs=~(`q^u42|>ތ&8rCn0 Dzա}SWoƩr*w‡?2pQRfVDŽIe>RvQ&G(rSMppEIpHJOZ2ȯEU6*R3:p+IAfK4#kďNY'P:Dpi,0Lâ0ԓ^Nb pZj(*wDafuHFV0jc|eW0ن2?h? wĂowZA RE(S.Z@x@ϮE 3 OĢǶ!v=gݣ`20]i ưh0LDg)ZPAiMg\(:To&},Լ*YQd8F:'!XxN+}ѿDth?Ý?dw-1ٗvȍR18J |b)4=|7;NCku#1N(W`&<`рa wփ]m;OvITN\Y.a+ w{\ @pUl)rP@?K5>@! 0a{ ſ:K=>u$PUسcZV،RpLR1#BjT?{L̝&<`рaLe? [Z`0ͻKSn5=?$;G7u(wn R=ä)mF[KA˸}Dh  7Bq];AhƫEsd  H*BW@-}诓HS8aڮ@a  Ä5`A?';kL`5"WL0蠝6[렏ev tmOivʶ:y}aa;gqEÎvD2.C9C~8,DVtO;s=vhd^"5Dc8ޞl\I 20â0aj`KBf٤>AW2w z#QQS¢ )aТ%\^t>@>_R>oӲBBaaрaU}$#4(LNP ˩? I"A0G;FW St6RSfA@hI6a;(QYm x\ܔ%,xw3MOf2+WaL!ۆƓ -4=C1s=c\[ْw<=,IDDx9ATugK|2] jX4`&lJ+NFgGiQC !,x :V0Q0HO nk33 2~*I4w=΄$+֓yyAH`pd5zȁZpo c!ąC(Lts,=aDEycK4uhRkuRzw̢vkm1M^,vo%-w;tg;۩|TrX~)= rX4`&,hlc݃9m<]ݢxzUOi.&JX0O M(pGgK<# ?KA縔 +VivSw>;*A{,tGОN6wŮRtKkڄ/ָ3ZfЀa@bhDrs9Xjd+UcBv -2P2u CM)H=L頊 vR;O PE d5,0 |S(=QNbIF(@&\BBt kۗG^:|m0og#!Kpoag{W6kwZ;J y:E^8:HKTRI2}sÔu|T2Ⱡ$` rGhP"umJa¢0!mVG5` ͔5}Dl3¢&Rj_A&Zg GsEu8 1x Znrt h$zlDzL *gJ}k*y9(Wh%Ý]Bo^gyҏկU?HO'!c$:4K6:9xa  _Ҧ=fzeH*yFDB 4oE.tr/SAQ9g1Ѻ(%HFzAWpE<2m΂AWA8JŃ?LA+ȫiwӣ3Ek|/ZWR}uЁ&|o4::-$"Yx ASG'wd;=8D~,Ųz艽zZ^ &LLs5N9vV 0Y@{$Te|*=_R15K U"m&Di~i,3UUPbkw4쒀5!X公 _m!~Wq *bi]k!yIU1-43o/|ibjP+z(0P)h#pWNWP-XA1acB 2Bhqޒ6ɞ v6D 8&Z46a[WvVoO޽g-֎Ik)9-]㠷P" l,R{oM?T6h*An0'0 c1*GzL5,X ާ1?d tL~^(תu-ڨhb,~ 'Cv§@ B ǿzt.T&uK#qn| +!z,vyO_|HjeF (/`kUҕ {YP<aWy mиb ˷u) Fmj~/J Xn2SlwvҮ6d[ ^`AA  s;ΥT "('9߀ tAx[MqG?pk(Jqg^laݛMc3Y7K7 _ѕ"= yh0 wpt7ݳ\m|R;,(pִ6zLL?eُTTAM=%";>@0fGbASA .MB.ә¿:6EuA!ʲwm:ܽVyyLQaDL7z#N3E@!0L¢0Cc;h|f$L7/dsm/] Lr6BtjoO]~[Sdөc'҉@(XO4YN~"p) Ïl0eJ@]mt $B$89?Dx%h0S0X</уnquG.V7QJ~rek!7AS7fP^rMH97DQb?T alDp*ӣ~?[]2X rAgDePSH`4n5иd$g0L/ V)2  LMMIplhSפy`ŃTZCtQ(ZI'睐L^')/8DSNpO*.'n:j\0R` ܵYSR,ju^o9`MKk7$9g*< _3D,0 LmQ =; Onʦ@o9]!t៟oo](p4vڅ֐{M>@+cLB7N@a$J9t0A63 -0v@0pU+4gրDqnp.3O^%a=!aDX4`&`]"%o\{p qb-o4x2V(Pw]ӪV|zQs|XV ח)665(N 'wJ^. 6plIn^S(@>~?QM'OV " v3 /Q)9#ۅWe@ZNT^Q!;₂[s=fleeӳ#=+0q=huv^b7kE񑙱XzF1CX*H7S~T%஡Z{Ep&a[L(q~~aрav`u0;:+N`׾7,`a 3\Mt/.DEF|ϞJHmD\D746ReeeHh/[NO< %R*}g+=W0+U~"翪A+kuRbJ i'Z.@ؾiaWOv+ϣ*%;/Pm$*I6D6i }q}hFyL(pPUO-x&aрaJm̥ Z @k"FڎKHb-iObk (:%q.R(,DCE4 MFoB~k@|ZIyt]h ,( ԕ_KJFk+pMg.9Dm筴|3g'Ѣg]qZ " dN tBVˌ ڽҵ0L&f3a/N9vV 0`-,w_f齯*gtML2 z}kw -W+UVvOşʹGtE\#KԋE})d #J^jf! `K8r(. 5F KrtKxzt @êv %Z, J嗧t`cyQŹq,K pRљn>O+; :$ňIKP6*isd ݃id\h ľs=}UrXf̈p;":~FуC³54Ct*jaqʄ1+czjsq<=^Y4REP. _w>rNsw4zF0D%;&f췶 BB1ۄV{iJ7N kGq h0LEޥdkC [;+7L(~`Ws=ܵ8I"Z3>BƧ$Z@$?"V* @0giNQ`e%566zx&x~|[-{@DG n;BiA̜2o=i[3)52fCUet b nŔ; ۨJ61i(J0;knp0qԢa0 D۬4og[8y &uuQ +iE;h]iۜFJk OFE';,?/#it,w+2.DA@tpy@AZz|ްدag$@8.\qsIȊN;%AպKk i幩D$;iNNء%ev+NTz# t0Q DةzHP,K!fء좍^ѫ'I(`nx IDATUm7EG&/W-Dx4=3ӲAlOzM =NA[[fGLG\:*Fj?} G8@h рKZ4 +{kwӚ}_V%h x񚴀 쨰h`ބ!)@9Dds#2L0]pD_0AbhVߦ*q@VaY+G%voQnjτjw.|՟{va,J1ǒANq_~ p\2nc{yHz,T }:4%IuyިIgpǢD%.YfR/lǵitߧMGqõl ^;Z>A/?Y]Eq %J4^cc7W$2 ==aD2\  .K5ڬbEل~>6Or;I~9qI垛VN蜠_doiwRc(+?wuBK:%~vETAjXWrZvH/,v_RC4f=Iq'wѭN//q$^/w4{,/_KpMFpDa,Ip;F]P#XXc Z 5v݊HP  ]XkRI^+7]n0ׂ]7ȥv.Iw4`}}xN.z R)y&Eэ7֭ 61-f)fN1tݤ؈*',m3!jszߧSjH눚sI}I L_K|83>IL =|ػ Cw­CtYR&\eH5w[NϏO/)?9 @TY=*I՞r՛qڽMaz;4`g`OSinV .JD`eE2l-3hBz'.-&dƆxШ8 }e3_rMZqN5я}> |gh`zom{؀EZ+x6shcJN6wN0잚_n_aG/v,r("I8 ":0!#Cc?]Rϩ'I̝&ۄ6aVyxF%lP x,66{E&2_=g.Wn_I/BOu8Ez~+ORCkdez[yc6{N6f Q:e`#Mc̔iqlsk_[z֡Iɡ ӛaрa݀Sp@9c)3/>-uoP$voNJjtÁmH30d A`ceØ>m<jvw>N&SV.9NEkeuNe_i}*[pxx1߽)ZkuhN~6(=hpy0~Z_%S=;=O * ]e5ͿzK*uD=knk } p ӀJpS !86;[({@y[@#ǯ:E.~tTQIx62 c ,0 x=Wu),N( PWU . 0IeB4$,Vro5OkQ?ߜ_ =?Λ-3r,BA>?=[MgHF־ ƍ^JM*D n̐M!*3{*O=a0~* E`#n->2lY(w xl+M2 mT}Q0:M Z1D[chF ,F<@K6[h}Y2`z/h.1R;5Dl8¡jQ<k 0_ Q- }-!?%sSL8r,~Q)*(=MI2cQyX=',x(|~ek An7?`BxT'A s r^Rjx)`Z,(S _&en {natpk:K Z@NBj1tv_wQn1U9 8wQ^llBݖnȒ6^p!WMm:!ԱJr .,^%jGcN,0L'0 c"41;.d ѨMEU楉xs Nӷ ^ĢㅔEDO$}kހE9_c^B* s(Bd*:٨sBuj#J '{?wdMd,JKgګތՖOӜ1(>o ..)pxm6U* (U'-m_JH' HES,1LoEagO`IQt+MP! $Zr]vO6aE )4A`c|z~?y?@?ٛD1[R(戟w'( gΑ-9"u^ F.~^»sqxPf XtGSP?ߥV.)p WB5MP=AZ1ն3vPlaN]L (F&ˎ/)(z0Ld>"at1j6Lނdv|[yAHΙѠӅ4NK}{o%-]@,[(2[ZnWO@,,=+Llv 0 V4z'c*SAX{i*7e7;gv8d/\*0rtհtYZ<]>:OmT}t^5OuDtyԏ[D#X<Jn]ՄoQ1b'cq?~0tWixLSݖ_х]jޯX j-/#(Qxzt?O٫|L؞큕hgaz+,0 &Lφdr*C&ob5اΟ]JK6IgUnPr:$D Vό҄&ZfᆾP{.p D S  y~mI< țَ|6tXm"c;Tt5X;&-,d v\| )~V43 -{":xOnt _Y-Xa։$Ӆ>?}m.d 6DKuf|vFlJ~ďjhƧgxlA.p5(2|evwЛKVigr\1< a`Z[O/۩TU7mĕ;t=qUhZu^ӝ 2Ao;:C^Ws& \dbmoXdRRr%+>qep_~rHS^1¢0H:9LN9APN+W ]ڻߨ7~aa Dw.s ]@8M7c93. p V#g|_7Z& K_p-LOؽa"MB;\-k{cSn.E5/bYbh5\0 ؾK=JѠՠ8 սΕ  ﻎ{`)AluﯻHW`s¼y=az*[X|dK nf}>Wh?R9K'֊(gQ [/Ӱe/,Y,˜a2 P*F:GH]_N"/m{Jzs>0,0 #A1Q]WD!Cl?}0Nk9J? ^iD# v#, %-B4`:,،MI¢9c9zv7i =2قW+Ξfabn k~G 2C<\_@_8x?foQAp2"Ĕ6i1M@P'P0Nº~qxJn^t9,/s"D,0 ~ ;;Dq\7Q^uu՜cBM4 뫛iV&wE»ܾ# `As-67]5uvw^op ^au[̕}!u*pO3 Zje6 R;AVQn[6\=&`рaS}k]B3+x3GpWUOӷ='/E,P9#s \qeJ9g&:}AɱFqOOEStwUn1% * y`A#mF E"p7-i4;+߻{B*r>zH]{߹0>h0GP_j1t4^E͓Z|E7g@,PaYP8 ^X=  ;BR-eA|1;ߑǂ}1qsCw9u_r(XrwwPLk_F0DWXi6u:uG#2ӷG]7@"\1}Pצs3k-sa,0Lt0^QYp| "3, D]t^ՎqŖnc kG<u~>cXa_5ɉ9{ߥs~ <vOߺAx5{@Jۨ;r8>Q2\kD*X/Yף\A 8  xZPwPAmphˆ „(RwC Y^-P6{5[+/u;Vn=gٿr@!PWiC >ۋuxZ?]/\Zs(ɽM3iwmdհ3YyI #?u+PW'a>0 c,0 5lO&N\@ ҲڠЯMP3" X t _ %PP@+X6-HB}_ϛL29s9rAN29sq\M X~>x!DJs9 ˜#ytdaCS# ._]kF1z]Praw[||H;F_ЬT+XCAEBgld]AΤ7gIO`pRZuyp|Ϗ>*1~춃b*U$G5 <}!­,ȏ tu ܳ8A_lk{Ck]'Oj@Xx<-j>-Mzha&\:G,pO!GBɍ'eĪc}:0נ-α1EP`WpŲYj m >ۨ2²x<}>vxOzs8|t7|{/l6 Bh) 6.oO D :q]mNEhPq-[a`+FЩPbs䜛yÈP_/FqڜgB7z[d1X-͒b_~a`a]l7"̗;'gUx.Q~nZޭ۶9tOߩU%   |Zvbh 9 f-?_᡾/yXܫmMP ˛ძ,b&˕hmfb%Wi8H2K ᥥ?X>z~.YɦmTlɄW?t'9 ~)˶2-nVCAX v`(lLVMk6Aŗ$ SҠt M~bMP\6 IDAT < 0 Nx=JǖK( xaPڰ c[>^o9R8k&I~u-{[~՗j9@ N Xn[΀F':R\å3 R~0>=$k?̘5ǑVS+s jJ Xn)8Q^7ņwC`I󤊌.b~o$ӎ@sV:p$a?8$Ta-*֤bB->N@v1$/&÷V:5bm": z 88)X Ts!hBz|'ŋmM'7~H #Ų;XC8K Y tU>(pVrۚXԒ1S!Q00&aU+0 ABLqVyE߽s1S47=AB7;!u'- RL)0 ZEc Ol(Q~ nuNO m>[ )Q݅ =`I8@g;#q` ;a^ƿt ]I  쁖dDr6) A2Xx?I]=!j!WgX;3Ļ}xAnZmd.`R2|P0p'>'-~+R;FGK;F쨀YfDtq 9\95]#!=E˞O},1,lCJvp EQZ]ܵ'O4A @A28uj(UQ"v? WCp֣`kiwCh@_CrCƜY^)Ii[ST/,HQ=YXn,%u0-_jl 'VtK\5‚fqO D :Q̏e Q35!%M'%@ǠeZJAUE5ܺ>l(O6I@c _bk]X )ta[Og"Hs?ea)\J757 =,*N;wbn-pit٭@8ꥣ%[߬lYYyƑaKV%1?5b @~q_h$+̌ q?i@MMZfq]ac@ȇ5AgB 0Q^$vh5`uX?m H^`8hcM:QdZDwUksӠX=0'y<'-Q;֚g]e/,l`b9t|Pg]蒐 MX;Eq>q ΁PA! IAA) -l5;xz Ct$runZDt)!EN';ل_7GC_cպMԱsgY|LX@j@O{p"u2V1ؤS fQ+`wlk y ^RUmw'!]dPve#.BFi3ѰJBAb's-h/APnqK\0@0h\ vmMgGwcuGk3w#@UT,O]|0Njb&SD?l#X>4lKԶ0;L@,C7'yCxIC,y]I7F-k1)&Hh@]E-=!忯</ngi!wNڒ-% U[SP;q۱NQiLqXˊі %%[ .@ l~a7+af% ML@v߅6 ns&+Cח ;«бwW{3'j4A8 S| r٠=t4ʄ識lܲx`9V,9TYk.0Oھ~b|lĆjhHng( 7u3B sk,Z%m2>+&5Dk\Gc5pB3n-l܍@w>\f?q=uͳuM w\'C\rfLѓڳL( >Q|8BMf GIgUv8i+,(SX>Ć%vƚz֪ў4{I W}ʴP0|e{Caga`hIቐh@YlsdlXbKdBJ"[2g%p%~æ*%hmhUi?x$E+ޠfh} %q0\調I9+Sf+F\F`m-8c ]g)/| _^wqi펲. '!@\Zg?N. ޙTB#ՕR6FuʤRY^@{TWQkYxLpSJֳle X&pblox6_uN[9lփ$B-ϔ;e9PS| 0>~yӲPpbmd‘6aRyvwh,EPs:k9 uщ aw84HtXr8Ѡv j2²%4 ApDD0G*u1k-e$uezN\TfK?Wޓ($Pķzqؕys6QJ[yUCXְ(u:hKuJhPu[(G<+eu`m| :fjð.r8T~H(+V~!&o[N*XA'!o㔻T  r+z%{0m1/F\ByS кҁof쐀GFJ0֟߱rlw':O1]#z%w&WՇm )͒[]Uvx"]AE1Q]]!P #>U]D[ .$!A^Vpb{*4ЖQ/8#I")VAtC/N21LC[?)T7:!+SHX o =zXד?52o>Gn8,0)mwOH[rkhoXXel>6g K20'2vt }ܺܕk 'avX rieYx!akxEq,9:* dj^QFՇ.0y_!7O:ر́[N/chY ޷|넺|>X>MpKaސ )Q9ZN{'pQ8YKasIˠ.ZՇH  Je>㞊$ ?~[(`]_P&BrQPCVm z|f0(k0` yF Z}W6maOq6L=WJ`Nq /aBj@Xo<ԻgݠHX`o~Er[7;-B ]`Pm߉nqULq[z*<-C ~̅a W~b2v>Ax"$9~r&*MH- 3E&,MuJyKI/ 6~.:_݂Λۋ2sN1 {2cu(Y7rhq+UO_nXDL*sehJAƀD0B<f=GOlCEH)6eYӗ}&XeܶplӶ9&`[N ᤼@)%$D;6Ny@w jc|?Gr*X9(1xNqî($c'G~yO&Uɬ0P Z,F>8Ű9bpdٿyeY:uP8U}^,Y9!R T|L-qhd<_'c-uv˲;,ъɐi$A ƒ@@\B씄ֺj%[HFU,|YBԏWHe{6-[tB F߲ m#X5i@k-200Vmg/Q@7g}6 &rX|FaW D *jU1Y\_r0bTH/Fg;k])hSmM<s{AJC_>Ӻ)a\wxb 8_IYBPK5俽Xy3qa–-C;\i8I֔U_*a$р Aȕ!p9+i5mxW'¨%,H۩2eӏEh \VAƀD`۫$!o\r "k(0/ܤ&hʹ_&(XN,tO ޜ.G0 *{#rIyHbs!3keI1o`B yOL5^7I4\[}H(yBCBiW É@pR<D;JAPI`%U_0vQwB鵂ɵ|>z_~K $8/v>OX`9 P"A`ʯHG+ , ;*$x![-ޘ UBȕ& enV\Fa@.H:18s3< O$xg+{ɎDK5y!9Q` %YTF,ig}P 0 bFO1KM'ە"X K?cή h"Dn|rg06$ |nKP(cb/$0ĺ?i4s.<͢%(]4A :VDZśa_ ƚ [/r )G ^6xא8O.6>?;9*z([1jzd_ǹ SrYjІ"(}NI4 cCAj:0.0D{@E2"lɩfW].ZQv4*: ]\|86e>u#ƫ&{.r`CL[Y #D/h۳ _8 3 eY9;Jh)+;SvX4!DAˎQ*C8+#x:}یD ul^T< #Nv}>̧wrG@-🱑YR^Ĝ<]!=$-_.~ cc 䛝Pۇ":4zx5`)B˄{շ,{;Z ^}Bn{7Y^In00aA8(:]) D~!р <T'@\0Vɵ NƕZ]j|R`%{9p5wC- ?l%h]`F>w8Mnq q,S Qg:^NjxiA !^3+X; tkX/!܈A*O BL\T BD%V+}"A4)zl$MqR>A;Zs谓_yo%촒,{7~ lҕ]b忯R3N\C#8tb{wW ʿ<_@߉LؒOl(ˑY'g":4 ns܈.“{r`4 AAu7OEm+ZZY!MI4p;f%7Am#fV@` SWàf@8+_t& mQ6| ɖsw*%w+a\٭ x+rAw^G.'gp;J٪y\=6yW1gLRquqOTPp(SqLwGÖL@3Fc!&|ɑ`WDpj y+( ‰^KG[a2BgTۋg.Ď#0q |<3ΑvF\̓^c>e14LÙBqp)vj?$s^GBh@*G&\>: ׫bzu,y>1pLP$h J:B!V#n%Xg&D jDV:a$&XYnpΪ'=ݗ'(>:dښ-7<tO A_l=뭲W8a[NYB:D%3.{3d2;最D^V|"FUlfm[y:'9c ڠ~h:^Jd95Fڅ[e72 ȇg!%ޝOh@ D+!5BK+|I'sU-_@c8!5\ %o=mvh07ń{jp铝Qd:nî^@o(8sIPkMOHg%H95r9z\y: P8gPu`T\|H.g  : !р < f,5ybr+YXZE_N0gu6X!Wu3@MϘ]'9;)$pV}Ux>}PGpOp^eX!ɠ_b|F;ESRqMOA?$)+. &pwk$^!р <5(R"Qsl޲EApGǶX▐bH0p?uJP{APs"oyo'8m :ռ ;.W {W@G~z#ggs 4}qf7ɝ@)|A\\K`ZXFr }I4 BAx(x&kYvL6PGeD֦q}r}o|/-uK  OМwsp%{7@uS퓵^} `S0짚v"AdV\ɿx_\98jgNՃ:gK~'f@KR; {XҮQ$485abO( -Uxnߊ8ϛD1$Bǵ't<]#N'>k,/, whűRYn:KU^. %h^d!{O0 ŁV^ p(MF'rx!? jޑ-p%x,1 vpEyPp,_xk ǁ: J\Ŧ2620OMym/;=FҔ } ƒA'EkVZ׷ B[:A߱009qڣ%,5nXy-z|l['~A 4nFOX8 ;j]9vl"& b32RAx$#գ #c-8`|.kAL_Uԉ e_&~a5;gcHOGޗX%n3ǬC;]X T$_*LŞ< LK(}{ӇE /bqu erN0#&ȱ/[c}K>$V!o&ux7;9L9ZԈ:0*cO.emd ˔^g0:F0v|>$Õ().O#nȉb-DA ) e.{=%WއnB`wu_` LLN6@T.$Kkq[OT"jUKEs݊qA>} %B$!)Q@"X& Ű5% Y/XEOtK]ZjAd|~sWb }5NI!9lln +Q G>f42 . :+8;yJdDqȁA͚ud]0mo&C% %#'JSw.wbi4.l/"Gi0  ;$щ\ 4@NmL'G[<'t/E!X~e4eaafAƼ .kߐsf;^$H&kLJy>A;$*aT|"|} ;BiKt?t#]xkM^ :GyR"A bpG] 7 &x*\BeSzC B8yv ;wL2v ; b}{q3=sJ^KB\\ۄnz$PTVJINfKb!vX ;$R+5]ce`yA{@@hCͧqژ'CA"n\ y r!Yٰ^ RSS! X;>g,p!rl+լM#C'9VTDCcG P'B΢p8#YQY (< 1PW:bj r р  ~ݓ;iHUh"M-(U(M@C͝bY?4#qblIy`;gkTo {fwc>K4'ZK0q. р  ~1uv#Dgsߴ +ΖJ &rҀ4{ 񩪞/('w@% ڂ :s sR`~M/.[,f /?r )X@ڦdjL%$mPwS36cQ3_KEX;hҀQ3Ү,':p \9BQne}֎/YNw7}bz| Bz'>~tP̐)YvL27sj/ 60$Őh@FD wRLdAȾ(D<8Yr;Z}Sy6a:p2DyU#HeYa-AN3| ]_CϺmBj^Jw A6(-4`N܊Zdų9 ׅ8+Ӟ0!.v1: ׁ7Y5a{ ?le+_ 6vkKǖ5@7ԚB![,ܼwc/bׄ%AAoa)N 8i!;tqk:"qOmwsVV?'ׁci3hϻj&eV?σOhig_AKՇ |naK |m(b|›`@ Hh@*d~\V$1HZ)OXʫU; :w~(&ù n]6?mf[o\vw0#2jc?W'»_Kڔ! u[qgK-n-|Ce$6wOJC_G a4H4 *muv iJ"jt@#]LAAdS۶9|JϟdXOw(=0n2vm}n^C(a~)iC#0#28zHa)0߬%{G@u(]xdۃP** lKA ק{Z@"p (޻NsC#& };0d.q4VylH&D [%.3B޹P 9 !fp!a vxrZ*JJnrpZoepmV IDAT~hjE{\QQiA r!`Zb ;OnSlt?[-\as6Mج+Y~sZV:j茠!VapaU~$ۛk~ަ!n ĂAKdzGe3Ǒ`@FD `_hao~MȲ:!"pnQ'vp? ~: ,ͥmog@۩wz0;#h{wcRp/ٱ|p &k39L1}h$ €PyAf?K?o]-!"=9L0LMiݡB[5(`fOLJ)?H ]ye46dnw@80ĎO\oU #bAÑ5́aZ~ű5>4z!,}#:AA7zd A 0{]U&.:Bn4~Xy5 >'Byn׿`;`=-‰P9rf{ 9*++UݯȉzlHA[3$w á $Ql+ﮤ Gݨ|5ռ<44{3T SՊe !NvpPzaA-!{았$\@(;*WL024 BFA7;fI*Zv-M&q{bL&VO8,`7'n"'8 8.4znܠjZ~jE0@k %M] $r!р Y"| uT#MgLJ7k`KGimv!8z' fD3P" {^ \i- J4 ]7A_lfg>q>u A(n;[f!g3_o$Qs߿c3DFw;m03Ě@i4܌\m$'z\ڣJ.dv]24у` 5\[AK@s5\۳^,i| h@"6XXsTQw w=+]4w/v!t8{dJ{+?mLz9ҵMd}WmXԍ ȽN[몙(4݃A{a^M𧍛UF"iƠfrIaX` M9>N&RUCVt c9jz4B^f7[nP7Plwٿ5U濼kor[G9\:{̻ .͆_f1`5JSL`K$('"V FH;%i ,H4 B5dRp/^/̋:mM~=̓GHXV;!c,S#e=^u! !$J0/h%,H uK τD Tv哤!At#~Q--4ݣ ;ZUn>D?yxo+YIU3<^!Cl[ºI14Zၐh@Uo/*Sp},(JC !ψ{jyn[@찮̂8tB. ~ERcܲ-UZ ӿ{F <  ,S^|vZP7߼h WonP8{+H{^y8\J^dbwr,](>ض٭n)͕?'ڢ h*s"D l{5cf>eG3L TH. C9A(`׈x7k!֣r<>}ۄPCHŗ x;DA'.ޟ H4 .0A}cC9<@8(<0(`a/,3 ^li7)mߕKX~Ah@`8)hK}*4I;8Vxsf#Y[pp4yx(MH2! @`Kl!ȺL q ^La9@c^_a)נ( BۖaO'z4]σ+˗,gφʶ+`o v%;ӿ'(dɆw;bnt=;(<~HCjJqZzl>S. 8 A82<4S\s.kDS'5 EtgN0@p_pz+vss\V02׮egi jQ<Ē <ڦqИ/t%AP.;HD'$X4.\-q5uPPgdրYVUzW9E<ΆΝ9-at|m/eǴѐ+M=Jw:(%0?ohԶϻ D )&W2po[3O\-1(-G,]^p}bn/G$3w2GY9>'0{{0r{ӵivBu?׾CAnu ݃$$hޚ$-Sxo%tԇ5^xǛ,[;LlR'^ty,wB%8зadž <#Wm_B) tJ@!JT5u$Ő`@D;$P3vs卧uʭWCNR/K4p6o%c$%x<صu='CUU; ǕKB_u`G g غM/0d9҄(V D 8H4 I6L8'+s9|P8@7#77~b49g|x. s ;>c\MuUW\̊Oq<9?ڸQb9k@ant eJJ fX+ DAx.$VLjdp w2}KNb= o$&>r ~]XXXa^:̓1;$`0e$ yeEArOW(qS&G-g@,cB0*M&%A.XfCN !р FDd6Iy܋7#ݯH% p4D8q~j:Y;<3۱,[*p?Lg&Kg!!69@m7 ߒpj&(~Ro ǟ??bgBvP~ua 4ܶO2 xI1(T֙: F)'sMurGra&z6ӪEqHG`xfwsP[h/_d!{nM-!ϣ8]?%>}֬:$1ZP4A1j?Tbބq1~z75"8-ì.!k@u2c "&j|MZu>PiT@ffA8j~I4 ??y_2L8X~E36صB.Cr^*vuMNו9 7^!%рp:Z&54Y(Q,M>#XC_ ˀZ?a;cFq$&㍿  \~٣?'e[!Xwyf'B ُÀ !$4ìQ _DAF܅^as>f+2BGO̓l1LJ&c/k~Ŏ,  Xߒ hKMإ?[$y 7 ($9*oa2 Brr,lha;'48,(ܐY54x\V3A|n*=gˊ+mgfh)'R~3NjG\&8yRDk(?VroSSe!  hk{ ljjHrr‚ژpŎAPugH9p):B'@*?&4zn0ek <0T!0-6(`9GY0W qƧA͐t╫w=/)gX# φD ܂pp?H8pM X / M1hɿ_B<::o|]@p*pT 'C;֋b'jӘY2Ilu`gF+b[/ nür!A OO("#A1ˌ*ҍ'aOBOAռ<<7w.jH\99Dzag ++Өq$ Hzy ў ? l#Af!р bN8"{*@ h np ʋf?Wa 3 q,8E.@6deg9{CPFBȹ n\OKw1A^oh,1> LU<ueWds$nG@L}A?6(. yp,8U.|s3ˉ1ed\}X2V;O  ~xda&f懟Ah\xn#<jB5I8pq3{]:0D1hiObUx"~g8>Ne'$;{PZߡT^+2 @`{R`e m!B4 -L^:RK?׳4Mr؏Ҋ!ta{.2M* +z PD瀵߮xX^<] ;Yɟ "A8 U܇ AUs YdݓM9kst$` băeݘ e:Wr d~¹'&Bנׯ΀ϋ  ΣZsHM9`f P A٣Z:_Ń5}4 hBT. ݮվhȟ'7'O zxq3GY^ .T@M1^q$rJ*O m Y*d f \-f\g*U-O?1A!쁚>X(}` 🺚D+PZI-曃-$ Yt&iK[]1s$B3( 1ёD{A1/ &䛝p-ah _9 Y:%`J BGӀ B"vҧ3OgBЉp̈́Ȋ"KHX( 0 ,(b~qTpRGip(u@G ֺj]" 1SʶN7as:m/: 4R[E p$vޟ()jYB{Tko~c= y'‰lF퇧 J:kto0[ZWAWKy6iCy;>$("An'.& :Nx",ù i! ~ǶlEv 9N"Tõ=,AWѻqP "vI G@A )?{E |w  |A8^d$> 0zDTFd'9ED訠"03Q3&|A <#!+z|XJNWQ˨~}xjxj u,& t,,iܺ*'"s>Gu[~1ɜ [:|L#_9"2 C"2 LSXBەmN)q7v/dpFj/7^Ʈgy|-=zz^_yw!3)f.Зz7*ЀLa7({(JJ}^:]8cO}Wm QLXzMmlFDl{T挟Vx*nc165%e}^O_0wO%C"2Vb?7n#tu*̓*Ppyȑn POoV; >"VfTSfra,X_0?;M c3Y ͏()-yBsM+^`PCہ ,CFZ ~^~e**Ix1v(;TxvќbFHE`: IDAT֐&eQ"14 "SBI&r (:-Hk,/(k IBU* nK0LH/~_@DЀL _n ňe6R怉M%6bûw]%MY'&m1-pGNK0`seys[J[J^^Q' hh a@gUP`lcGDɡ@Ӧ7?C9-\MH@ҥ򻓗]^i(F}a~>*c~1 Ă "J`} 4GVkPa9-DRMa-d޺ ?6"J$Dd F1b'1xTX{z8XdqQR1vpLD=MG/0o!Of V`Ba>!Q04 "_*SfWS9fz77tH`[%I>`71 5^Cr (,(b|djuȿ n!!҇2yX팿Z*T=Jk1У˅BV5En'"2 C"LT@97\h}|$_Ll?PͿa a ڻBz.J VLC1> Cn~"y}+ICDDЀ,HU`'uG>'lXo$rVxڧ3c>[gIksx w<.%'D9^PIzYRwk1~-HkfN(c֛_R۾;BBNlm/2QԠ} гh.rb>"=n.AX 0Q214 "[@p`,lѕS8>xgWvZQ5BE ̒"v` |eRs>;6D0䜖@DIЀlclfY6 qB|1TqV#(ο M,8Q.\` JEO (ju{ B_ U~::3Q*14 "[ 0Q!>QU7,߀" OWЈ4^3c;hE@KG)^ÖeZP'6>$`h@Di >=0ߚB0Ǿ:9P M&LA#RtJRWjPwt&"2DdyX_5HA۟|28;{q%${F X|?v4d00"_ͽ\rsfnI "S`h@Dig_%s׵P_S7M*+1aw̼1xodi` >-Aߗd--A_YCdDd| =R{%eȼ!8v( vxIī)^эA/x{ )Qt5 }BoAНKYkf!][MnխRڃKc7B6FDܺ#p0!%0=BooR!Y6)MJ` laZ7墺OB.PH#Ӻgp@v;,[ F-xD< <;lG6Aَ0Q%{E:.3zo[OCDo&2+krѯ4@`;]|^ z[Lu?a_04 "[rIa|~bƔ^3(%]€wԲ V; :ʍ[ D p_Gd6 5E`-33}KBъ-C7N$sOv"Dd آպu=}_ݧ=q_t;q89A  0I$}{tE`hI 5!vuw6!܎@DЀlcE%[ۈ#de"tpЁp8T`G!|Ͻ-CLJ㡢/v/8&.|)q)Z}ߢg~O"J5,]4RFB_[L)o{ݢ;)? st;Bn+nG "ah@D)V?'TX.d&Z`נ7JYn!8;Pc^X@64nG "kch@D 3 @q cfUXa^ap@ m0_.l -mM6Zzm%geFRd#" ‘Gw={<4dT^=+18D>C2R1G]Xbk3g``~̖K\ܯY 송.Э֮{/x 9O68ṃw!\`pGܠpϧlM8ڪ@>>gOy2#(p;C"-`o >nSH ̙?gJӸ+9`Śd (^qЈ =#wno lGpz l""C"-;4A848Q.ģZИ, Dz KJ]Ŝ^p l8xR;dO,13t0]Q\U=` Yu+04 "G4zcRv b.TpȱV1OQ82\Hxt9vlY4ROiv8!`S04 "JKXn]N{bL*JbА#E>~j%d cC*~H:X?Q 9 )7blhuXvݣC45J}5>cC\MG@U 5nG "ch@D774F˼j8kD,DBË2ŢWDL8g LbQ{7(9LQnwXgg~Ow$#_ͽ<ρ$30ϱZ=;96?lQD`;B泺HЀ 1  # D[ }h}Q‡ ~-!فA<˅Ywg0c:]3C >D|̿`}sh^ 0A2m"C܏7Hi6;$"Ѐ .8`p`A3Iz~cByy+#{bc|ǓUTE7'lz9 htF6;$" 9.SiYb)_DttQu-`ˤhht*0@c8_`п>F*QhnO6}_ޗ҆FDdfCD oL7ճmhr_.|>ަh4e칑q2O׊X`׺WJCV_ir쇝޶ O n2< rrxN4iktLg Q+|G?oJij^vJ~nQ"0ON6n*׼+wJdBU~ux"aVy_^JjgBd_؆0yVY BYӤtЯ>/y"<(,\w}KnnNӧ~WLy˕ :K^^R +(蜒֯`VkPRa q)9"QjX%4"RF*F`T()ZY3/Q.'QZ@,Ʉ:gLJpɴҰ՟r#bh@p{ʉ:FtR:9 ‡T$@ JzէXo*݁(P8GY#_q9J?D9uR8UGN?r;.}[YAIQ%.)`@ϟ^Xe'EC{^$^AC"C` 00 1Þ?JDC&#F\i@+ ĎN D1@D֕0}Pm]{;v 64Zcyشik2("[hB㧅ܦ@D>9 pQT10 .yIbQ ܸ念jra D@@$ QmhV'Ve*Uȓ 1Dah@@'Ѷ>Ħd{A>#PgP^Q]*++=؍ξ$H0} -@Z 0(<!]B/ ANS "ۓ=f?}y)m !,8v߰;)N Z iܶC߷zڈGF؊K`@F~mY;"zJB4D{%'=-cyf)9WeI-Ȕ78.$`ڌ?'B)5oS(^ω"AD⫎ 4mhqȬPne|{>7U!f ˃b"Bz"4({$p`fM݇Nϑ,qnF` ߅ Xe@fjQjm- WYQRz%~l? #_4Hԃ6%ʹ'<R7 W!}k 9C"hv SsUh#j|E9zg>pj" NU5<$ z1yA>n#r:Dք?c e<_EVg)Zi^p0eaû\Pe0=H@܅JsJ-88pKIɘ>AnQ "Ds81Lw_y5e2RQ }@$t / [ئpۄ{nDo P(m$c14 r.A h ,Oo'h@lC$PD2 \AD- ulQ"bh@ yw"Ey-h TW z\\G}6GB &44'r7藃我X*0"vDȃch@l4 rp ],R0/)l]Рkٓ lH\ C!@s4Wp2V8~ 2HG$#14 rt=e&i!>}OUOKrs7k-m 2"9)Ҟ)14 "3 "SCPҧX `@ DcG34 K:rB[G""bh@DD0z@evٸikpc>emRSL񇄆x>.5Q=Pһm^b C"""@F\_PYʳurۄ #F UBvTm]o+""DDD6`ӏtÇ *M>C%RСڨ-YnڴՔIDD DDD6zYH~|[~{2uꄤ6+]~,kR>-5\EQ$L>E,޽Ge$lxfc<"N X5y ,#""`h@DD5OԹyj{` Y#XVfKŻϷl*hhpnjPQx  ߵinqfIZJ@B0o$O6-!  (#=>"""J<DDdZ0yyRR˔@,p _X\{$dI>*$Q z3*DZzZC&3Qb04 ""A8J‚.@PWeG@O ¹zZPj """"k`h@DDmY")fϚܥ IDATלHz BAȊ"""ah@DD~V {SN,P+Wb90zȵl`HDDda 284J+*N6?*Ȏڱa]`m@#HLxЃxS9O{.>P,U' < dן&"$s%C"" ,B#ٞ7Hev9tT(jڀY!^]BLF&X7ynGipT򁈈Ѐ,= wMn6l]b0&-7- +_X;S%BM>d"""ah@DDj#2vhePtDŽ `(@DD, ,$ߎmX[aoȱADDDЀưa{:@htHDDDЀ_ں0>DDDƞDDDsνHN SNܜiR>M@ɒ>ŧ~ߵ|ӧXrs>?iz0C4H,- ^^_Nd[ RSBH%{ʆ)A ;U14 ""r,b XV!ZHP:W)n1:"쁡 @pls "" DDD2][%N8NCO/km /5ïeH .C͚t%`!GыsF2dʊ ߅=@k[&&J9 ,_])ocW\ߎɬ(@TVnCjߨ~LxE'E 0(XFLDJ:Q.\jr+Q04 ""r/xuՊD[p@+DDD<  wsr#"Z/\G)( 8c rm|+7mUڴikϓЀ(K_ҧXĮ]P]|c~iFQi%hƇFS8 {VhO+_kZ """sbh@DDKԩD ZxtI F1J Qm,~bc(1#h*-F ZBZUR>xs-+.!,6v@DDd1 V h@>Œ@&Lק {#zpAŒn'!_JNfЂC"&q DDDdMi|݈갷~i 8](^ gAن UlrHDDd]4 ""Cd۴S_ѻ<:[#'2x7g˕=#z)h:H۠__ёDDD< h Հ*)ۧB 2,̯~ W^>D;lvHDDd 0na(SV+9~a"V$""""{ch@DD0emEf'R ʧ#}0Қ񛇈-`|rw#2"""R"dgBDDd]  l}m|'[saɑ=ZV Li+8oDDD,ֵXbk 4R.8t }~/jHBM&9QjgکoA( Dw0s,pDDD^ UFxÂa+(8@X` 1}hiAUh \Q$0Bq)[-1/0F4HDD X .sν(]xelP@ *+s#gu߂Phxדʶ; ""B#x }%WotB Z߿OqžΧV ‚y\""d`""ch0hx,h~DDֆ0d-@@Ҫ 4{4e˕ED ~JADD X-bh@w%͔RiKDD'!+W#Y $M4U`$(26GDÕ+_qBDDCJ=߱#f:xC so""2/LJ=pfM 8&$C܅u&QDDTXa=uȹ=yc'kmNwm DVp/|#(6$L*ѯԃԫ`,A:W3 @d>k;ϫEϽk/_9,lC`߂p{B ,pDD&`zw{-uh}_һgп G`tG%zU猈([;q#{ޗi9$h%8b,|1P)Gbѿ>u"z# (0BqinC0Bݸΰވ2e#Rkڌ?_^y6s@va;x0) E*CVxDDDBlEXṓT~GJxc) 8(Э%b)ggjФp!|""J l/<̾yPDsy<' -58:_Ik&)"3Hn^nE<>om;__FdAlHVh7QXP=)TO)"H1E4DDDɆ Hnp!V _DD4XgauC  whIزp/zBYHdjk79S!  &&M[u[7E<BMllUE| ⣍hڽUgCDDdFXrLx! ~ (º +.0]S= BQ<'"XDJy_fJOt$aO"E^2bJSEuB@ьc((6i@fCJ=#QDyoC&@S~,# pEY"G4R14 ""P*.pNFL?  fԔ4yoX0BCՓǩ#7&0mnd{-G4R]|#9zL2A6{M#i8&Z!;ZryAGde->Ӹ 0Bq/DFبPDC>^T= B)ZZacI!w;:}ftg.gN/^.X) D4K:ko񥥄F(ɓl -S=)9#Ͱd UP ;z&TRCIOޭ[Dt|G#gM L\ "k Wqn#Q$KEa,`r#EfFg }kзS>SH" 'Ige<9*l4L3ۄ}r]KH1:[8BXGwú:JhOP~qD1u4KF "i&);ȟKOh{ s آ:-?]2"*W$" $(vh|ɖܚ@QcҴʺڷ`NO)n'Ɖw?["?=%6$"(,WA78f"Xo!d-T5Փ?}:q }(+#M#IF `p駋~g!Vn!o"@5:HqaLK? ɺ0BIoxSD0>3?IӷH =RD.C F;228\E_GtpGwDdm+_XeW 2%=# 01ú#˰5{` V4W~ZyiwZ"9Hȉ:=f Q9SFd[dûvxuurι%tE~E\1t LV&"!jSnCr- Lt,?voW9GՑZQSDtX^S܁D6kZg.^ D@f N```EEKbJojK󬬫/wbq:Mml:*n'yDv#UJz6m@B;]il 4>W͗$ʖ1%#~[X9V?B9䩍o1ӱNRhO#D`:VoǎYV`;BGD.x[ۈ#L=ÔꂽfFq8'.4-陼w`;(K)=ByN񿟯9ƞ&N]"–LWZEJJz)`wͷݽ/;Qde.97;00pR"[`jX]țmC:qcIeG4Q}6~*,Ӿua00p4-V;~*s8! - ߁1z}EU-s_؂pUircӤKVFLгVjn[8"4Ш#߁1`hh*Su䄼_w\omGaۑN?DDD0.AnzT67 S #gxb㼩nEh9*4Ш# 13uG4Tirm?Hf_^9ɷR 垇ej TaG(FˑFw,n׿x;xQ꠪ _w:W!з`N?FU[-ѡ;xOU׹^tm| Z&} S@;x#h~_v:r ?,}w١ora0Bq9h4Ƶ ,@eAz:2 ^SajX฾04hi=;,`<#ضI C&""J"l=OZ/qnwȭ@߂9ՓAj8X)W޲ϑ,i"4kSDDD$a8 :z0)E<6:tt߂PDhi}_5<`AYL)? C6J'(:$@o#δCJ=} Q >% C(-w`'- _Eb1i{ޓ=o=~Ӳ}4^nJTY_6s[gȓ/ElEXṓ'հ ;L204׈{ ~w=(qX%w<~ϙy|Bi>ϙsAdV?r*g7[OB= o!j4c}/ޮ!ĘZ;_]ȳ[W"si\@i7_)r\ u[_DA0zR8LD*,y&F.7zޑ1DdὛoeY-vǝ_X_*"2_< OKQ=Y!K`\㺘 ueXafI q I٨:P6xRv ? 5jm[_s. PBj)` IDATQo 4۴vK.USDv-u0)nX: 5<`J!;(s'׹^t9 2ڹ-Q gy]P2.ǹEϿ1{1SJd^$垇 8o$@"G4|&eKf;QJ8]n))dv(&-R|>ʏҥ+qnސgIvӰGNlG=N|}wT>zK? %Ӏ} P]EnCH TR5.{:sK &] r|ND0F(þ ɊU;0@y_fJO%^A߽gLJ.)_wgCйZx~:irW2@1&hgK3I Ξ;h/9-0U"} [ ްX Cx(=(<4;onKB>.;sĦ Y-|x5P8ﮱՠ/ļ}2,>ӫiwy\@mxY\~Wǣ>%J5,@C-0Dz#S #߁1`h$&q'FSm;Vi/f]cy,[-]@XSg  {7r*>.#{eDqH\lf칟8fbOyy@XM8!Py} #S#߁1`ADh$ w/i9 Wgs͠-y|I<ö@08S@I޴oz?Nƒ/(c~N#gfT[8B$Pqj,n׿sD#Qs׵y2|>53=hFȿ-#\3HTh %+?ePmhm R&_o]Uۥqָ C5z( WsO.z qx ɼ Wԅd*)7CbW"`KLz9RMC|@i [bqT,_Q2-TϤ7_cVo14sh hĤ; M|Y: RxCUf[Ohev(zn9VA:mȱ}5J89Vkh=hw2$hh g"x2Û(Ѕ ٠o&"pa0BqXC)ZZ,- ~D'xG|ˢ/*Y7={ Bo6JF#^K\yҢ]9tMP-ʖ'D  0SHOoBɽrw ,ȭU'"y<;4@|ua*dji펕[PY٭ox6R~:~hDN{&eVɸT?/i` [ **"H8"TuF5r[RR¶Kl3 a3h#~Ͳ|L9$9 z!V8xJ{7f~u11s,p8h?onSi(~bt*]=Խ25hT¾~oxV=|Z* LhH6T {$GЂ| !?vvP~%Pa S[`վh# lFAȍw}Y6#1Hþy~gˤWm>;wsVt3Ww4ܿcqmzA} 4]tɡc.=&IUZr?=$iGkld#W 8 Qj` [`jX6 6W~[ 0m)-oSq3jQ[>wMp'?G?<.Np8d8h(ACcz㬖>u凶L\Pi#y~ϓmZosv8uυu\zC޼xZh0w] hwyyĵ߿E*w5*dVc| (^$垇ٷ8 8B؂6"&"o:| yJvoUoVsm{ˤ[LsVd=U?c~n,^8^unX_00p^)9TOx(Ϥ`ee_]b? УkٻUs)Ύ~ 0$Hkָuݦm S.iJo)z m7.zWJ%ՓȽ>$reLO[G b~wF{0_s@wL^hxw1U2w{?"qto$Zl)p]<7qWJV=) ,rJPo'!LGhH {\ u(У1M һY 0Xe@Fup]ƭ:n bhpj4I@BqF^+;la6}%ʸF/t]xa>fmvٿt4xKU*il=SupFuX'o*Փ?}ba0e,]YP=D6][?RM‏U|j2sO6?J>?V?Zed\gz ]a0 x: 2"rIoEKcѭ []KnC="cƺ`/V)t~a[ z$;f+?r]?S~,5~B)(# +E3.JͦIs+Nۼ@>sPQS! Y⁾z&s1jsp0d,}dhi}~xH`!EKfc-Jqϛz`[=z] y\`ӇR #gpe'"P04K㊖?$"r VF/ &Jgꡐzpf[υj_wq; 4Wd؄2  fiҕcow RM Y:( vpqC?Wz\`=ҧd3K~Y"]yπ$C ojdϞ-EV6w쮩ݻCBL8QNZ'rT@'7|},0ݤד<^'4ru-d::DZj v=2* @Ţw-Roz(;y[ P14[:)s'׹^ LC?,@@PZZ*7 X.["J ?57'V&2HP:_trDb/n`|QXqMr9 }~leƔ=?TC_1T8XN{)??/AE1Ge`[r[`@ch@1)ZZUwp `ΗmR~&|{_ kna8qaeҢsj駞`'R,єzΌS2MLJ.i2JktYѡh8YqӔᖳ}+=moU|* rB"!ϕ } # H ط Ѐ ;x#_ޗS*p8;_S`;cDb~I-n޺Kr ve>aqPS̰ g35lRV2~>k}L@/m=#X`7*R 퇂!%Rq[@F#QAU=)F#](t{lj%CSli6c@~p\Pp} qIЀzR6 kF*u4;N˛[>ց[wx릧U( DoV:-~u ]l%TO'"(ht^&?6+lm[wЪL7ADb/~Mѡ'oIi8C}~ 'D@?i3IcYAconW $EUؒ-+K`I Ư:+naCC:2\W!% CJ*̈Uga`{{A._{ym_T 8H{1ʢߙWH>-  I+cCVo,=_:WMz]:]?WxRϿ 4UՔC-p]\o!p<^[wY'Pʨ#*į)#ou-$oGxӻҹ=;YA',r1ZW, g7$j>wyr?<I9 -7OhxgP'A*d'o={[pKcm Ά垇 8+ (UPʩ#kj|&eKflGwfNVF\3Z*+G{d7vGsf.9 e]+nHFXB֤0{;]MheFC1nYv̳yċt8Ur߷R%R5<inF.DhlCOx",=1=Y+%6] 'U{lM|E7^஀4Ǯv.__6=-fJ0oɍVw@ ԣ+פ\O .uE]8Oߖ|,USd8J#\6n~ܹ|rO$ %1+whyV''΢io`MWA 9}Q1LE#K}31!7s]*BNj؀kLCϟCeRӮoSMiҋ iίlSk/w* a+MI IDAT]dPTG E:AiE` =絡렿f߭#owQ{#J\ѕ˅tϮ//ʎ/W}[)Ԟ܎4jBt vK)N}МCAW뚵F|S|?u}9\Z $7ug: PU0!{xX^\H'RaftXJH؇O9(lJ8\Dܵbr;Ƥբo  kuԈTǒ} X^cGP ؗ_siOyRQ U]t VmګVP\ \is\U<[lv35t/3 ΋%C\3֨I_4 i͕ǾZG aV8esGCje,:zNJ-Ryy}v]>ᒶR* +G/#W#@=[P4V?wҖo;=1 .8-fɤ>Q{Rߞ`#jnC(ު`ۦ`mY<pCn{7Z5:yN;mf9ٷ+z0 D*n>ÒKCey Ŵz)j@~Dd^Y]h f7p"3x>UI~*Ԓ/q8P4 ,LEށ:8 ymLs{{ ˊ iÇk(!yW ,ᮄ01zd`#GPVVg?}28gyRx?.u6I KO[inFMis]U9}wC)u*j+UIg2r⭣cdzqf [B  P4"F4!xdw'iDi-|%}|gTfJ5`+[.JȅǀC)z =j+WL494$WcVH^]TirT8Bbyzkox<6x2–7ـRYc9|CcIoBۼwկW*pš͜.p˥6 T3E-8L]Te-E(O J+zPB;f k<>Z밥)' gƹ \tx>e/-N"Q wvKƏ4e|/ +O[Ǩ d jBm{S\Q,@n lYPE4VyWZ--pu?bxtK07TVqH.}Mhi=t#2 D,<{Ҭ~2:kEëClǖ^#M6qϰ[w[˷+/Ɣ">tքQ> B6CSet36C-f; , tFQa'܂UV~*R(-Vڧ/L;QvI?s=#[$u^Pvȵ :>1΃z?ӱe5\91r/4m@-Nu} {(O7^m+]m6"I{d; `aš.`jxb4r _h~Gd`D:Ь{MZlɶX, I4(*P vE37'%Xt7XyT^\HIܺgrv br h~+((##y<#wT5Uc5jD.'-\%6{΢iR`Ooq5=ufӘE7JaJ T嗑[ƚԧQ-jS"&\z:ϕϯYF_^)J-{Rv]ftGi 'PX' LCTu754p2F<޲9TbXQrJ|uԡ}c [BN38Z}{$i; x"F(POLcD%s;ஃ!_j3ݚ_\uo8٫$aaa4bȀVo?v޸xPV=w>adLG;f:Dn- Ty5f]|ZMyH4ɿ H\~O6ſj[;3F?="-.Od|8u2<{Iܪ=.6N6xQqfԩ5WP[ EV}nb;vp,-%v\Q,E P4;Hu+YyL ϞT0-:Ӕa+J]EWuri"WG( /޲&GCv÷!x}i0\(X4/N*t EKR[xq]\D'N|ŵa6 qb{{I 2+L6~{VKߗ4ċKZۃ [ 3{),ՃÂ֔ m`!{W>'-&˪@L ,#: ܅OK T:``;t8@d`D:xD#%ڛw`^LN}.F tUA;lJ\GIHվ'w$&% Y桴倷+_lCas@^ZײZiι"};81ιtI[֤Aubs)n_s޾A iɸƦ.:04xu#V;KS"8g+}8C1BQ5>p05jẌz0fkY1&k㐵aūJc-e"gK=9%5+`;rpo1]Lԡ1Y^L&8e{c'Ɏ+UhF4޿P8.T O5ءD"#>Euk̠(Lg[*&'xb`LZ̃ uv}@Y۾3sgO'^Tu`:rp#Pt݆,tsmi[Wڂ!90Ӿe(iQ4e}c[dXLߴg~F:hN5F+[RF.\$Pnïǰ0׻+ſbZE9?+W۵lDa='U20ŋqqRФ!ޮ2}YC.LɁG-Ne-:uͷ ۴Ǔ֡U?;xBΗl*YbxCȦv6ֻD:YUݖnBIIElf`vF-;T#F0*fذrnEފJ; gHX/ AĖ?8p$S4T <̺3M)`MJPMԦȈa5n rfs WpŖ;4*b"_~]dcOp?]z=dK{hѲL9,k܀nVnPLy^ƯKxP[Ljna1ϝc_HJiߖqf [Bq&[\E7#w;X@//ިh`)le4*f3vSUzJ}gcPf,[)r$Cʞ.G r[n© S+X+3pw !Q|\J> 7݀36n={υQߞtGvtO`j9}lڽ7Y.,1&ӵ+[-HECĈF;V:~gQZ#nK4lx@qWeke qhLTM b497boI @|#xBVҝ{BTb=_g?G~Wڴʮ qH4PUũ)~l,NWlցlFJ _/e_~^'j jڲ]Q~~yJP8#v+"`"hP ҊE[py*ڱJA]寤-e8},\Ym?4.n 1. bAR\*8s߯);)ɱ4xXt? Mr.ni *\P 2D `. .E㞓h^ݶIծ ~dzmHX* xv z0bfIg[8Y!s .{\z\J_fshѨ ߔãN/uT:(1=LymSLwH1:wqR;or,"k٘fs:-Wkhi8:kS3gIӸծ9\H=`⿯YJQU8}?A=s`{-?oS΢1lm\D_\MX]!K3BU15NdZ U(D_QA[!ꅢyhB:>{דڬk` /l7oXCSY-y#o{)-K]X,N\*#侾G۩l\PXJg 7ˆQ<0-qcH+UUWm 7ԬRpU+sjSV;z0]ھ`(ieMR1=C7-p >|ŸDIn5a^;PP آ=8`ZTx<ďawA^aJoܦ -wp1{@9=VT! -PNQ,+kP4AiECEy2NDkYQc t )0 e+ "QYFWlo9|uEN,E n<^sF,,~6FMa=㶸PN_J p Cq}{lQ]?Ԕ 'lp+7M_Ahޅ_-{8P&S1]ltTәrdDZz{d4un(x1Eӎ2Qآ}xt mY xuV'nVMY5AV7 ׬oUSU\x""bUWoZoS *w_ſp!_'T-TQ\@l˧$ĆӒ[pfg @BF(x  ј*e'й6P@]WSÇWB; IEؽЖ4g %[W tLྰɉ9cGGmocZp իm{epʸ+[WRA- d'tUBKNSr(^Ŀl#D33*vuy҂T*xŽɥ>Ӥ6W2B- m5i6Y,nhզp9Mn\edU)bLů嬒 'S̄X'G,h0SpܦcG(NLGnzrVPBg[/crPX.{㢞?[yHc_O;:ifჇh} X7\3JJv*BF/N>ά*y.VVd0šTcoեI_Z6})^"S˯ 8Օmr*~ߏ}p b w\6jbqݡFϞw2oUQR*}VRhD53mxgT-+V(.'E2{J7~.%ܭ|xa)ϜTėX`/U,pԆtӛڙyW} / ާ"x|\Kӆm XF3~@TZRshHnoN+ClK&IQ p4_ Y"48ܪÅ'"c[]Κ}[|gIUG ?Gyѭ6ܢҦIϥ졖䧐<ίw-NM!Qܘ'8z5%Ui j6٧xb4r |: |>6!g|H2+m T .]7sZꓥ[`銺a]FRg/˧ n-ىK}コ9†Tt'upk OFs4NN린Ewp*hǪ ?G-tXWC%E6 687_@`;oV0`<}C* –POMl >,(h7#޹ i HuKzsϿ̦FόfЃX/TCAV,wBs8tË.w>l(8K,s΃K/Hy "𢡄fǃoౌWlZ6"_^FϷ[i$=LFM.N0ѱu:z$QԻ7G@%b"BO AX_;.{Nbd깩/e[h\ҟ>KoUYIAu#Rg vem \? f=F]-r,TvLq'rH(?SHKWf-vɖj[-% mCv> ʏ?.Z[*jLMQ45z1c=L[u6S0.65b'0oij $TQ3P4AiEDA_8d0Cae0p xQb!e},SA /KK~]wCꊦEkѨfbWfm!U!W )jTH^_$Z[߼ u/q[.0؇cK)k÷ .^UG,uٞIx5V62H];Odࢢ8Vr0W77jxił}>} J?y! j>_U:pq ؚUoSsSyextGǛ Jސ_Ie*-vtCZc|ut߮mҶÂbRn 9+WeR[pNrlb/>p~Lh7c|,p8Tvy˝Ը^ٯ3-(QmfӍ)U{5汎'~DEFѲe8?]:Oh?LR' 0BP4Y"*a]\? hAR"wnom;vu B9?nq*ž`.܎My(+_3[()6Ww L˦r\Knq eVu 7zqR}Ey ݱxZ,j8mrZsw߇Z1rlDjcyM`EHpW.T87t;ux7A =_{u6eDMY>+DOSx"FU,PbK@A"coOiBLߴxbB}R'<Tp* ~d9Wyʈ3J,co;v__{]w"FnXbl(KFĆu0Ms AK zg_V<>;Ⴧ(>qtEķF AZ|-5{藣iU>[0}I~?,҈F; J8Ws'gy9:`¼%k?~=N16mW~.17j9PMϪ((GwO <#4XN;) YS8`M}̎[E+Y\Dxy4qgpR@"ӅJr*,Yl-D9RoWxyczztωfыE.Ez }Tw[ 7(<;r 7bXtÇf_#[S[6 86!$-F1y="mGP3~?!#&Sڏ;ڴZM#'̖WvmS wB>Z<ஃ~M aEi<kvTH0>G+ڗ6HslGxݡFC[ 6U @+dhK3ƿ(=vlb}&6䬃ab?WT8]~yn*]< Jä_$&0jN)p;X ml-1U^ l]|<}+UI=koQ>_ѾF~ayC3/aLKpVOPb|baL(*ĈF~c2ƛ(_E*\xĞw,}e~|/iw(7?JupE3l~5- צZz;e 8dSUOqghZ`"8 ~crlbh"zțjB&~B B+~q;us^?*o +۶xmֿ4oԑmC) z.‰]B+ܝݶ . pؙc S-Aoi̼tHc1 ޺T1~`/̿(Zi.Vo޲Pzt]4bׁ'GΠmx70>:FwHa}zSV7P<tߖ ط+2m?a[68m!b JymViexs9]*g,wx]h{nMгw/DCTzaHwsh2pg٬YkM xY68>Ep1zY欃;ŸV?ߨy:b'M-Xkd7۳dGmo׎| ~Ղ?qg@g~CI 3Ӎx”d,<'^MIUjxzgt4Cb^sz4^=:},Þ9k*t{vLD@\Npo>HƏy>ns;MjO{>ܼ<h7h8='vÙJ2 >LFԩeLZ,ӨaӔa8Tq/sQf]+zZNo;Zd}I "QhYdx?ٟm EbF g^G/L-lږn'Męx}?]PZT1i/y:1rt[>[qrvI?~gp0,$ԞnЎu}1iU,(T>g,LМ{3A>?kiప!rf(9=40rF`:MQ\@2 TzSEcr4^M]Σ/RNA;pځA&!#)Թ5Kx[Á#ilav`x\Gзg0ѩ-W-ě][,-3i\yׁiဧ?ȍr0D_&=xT=:="^|?tKV;ifrh( EV"Ӟ#QY\H%:\@MRxhPwzw`m_G~ݻr(k~B_m lDZ,4o֤Z r>'iƴ]X Ώf4<7x`X80 XI;&zMP ;s p$Z2.6χ]KW{QtzaştM'~⮻SlE@nT # y tOP{afj\m_h`6G?/ /^zR*(DE"^UfxL|iAq1&43yB},|ٿh{L'(_۪V"9ܷ7Az[tۺ޼m.p27|r*) %1>kX@(9ۮ SF?twϾڧ[L]>W@A?ˣGP~A+p!δ2NBT iE7gr< hR=˟rI]r[P4=r֦/ar:>\C _˱c)ybȯ_u]GsGRp;iֱ7h,CIXN IDAT}Bn7 )m>q#ǕQ('&E8"sV*=K*":~ۭg[7켘8ϓx1teR#6 5tU玼[Mc0{he4*fѿh{&(2tPq9S6)O*":+,rT[}%YO)8s^s gKSc ],,~:tus9cESU~2VGA<ј+yJ*B0+$ttJG̣ߎ+v&k+P"W,xlz4pKNE=P4=r C6/_&{4A-kWFTQc&JL hSb"x$ EX£PzdEWj@N6˦噛 f:evO)XϞyC/s2IqCdA!Cn;V>jVVct;p_/JjNqp5>a#Psb<{nT/zB@زYs"BT…T`0֠tG`j):hZE ,[p 㪵X~2㖶C^mzEߓ^Cw,0;.g'(8B 1fv,Z.$BK]oHm[4<7lc}E[wQ؊E*bD# GCOPv‪:NI^*&_voo%VhԖ4.Ņb\Qv#1bi25:x ޞP]t 9wGSf]?Nbr h^-(h;j3?N-j AUi!!3M0غ7MW&W&K# ݅xT_036e= @OK9GB߸E=mytL" DǣiDw&(.YPmmh(ufuz6.,IN6ZoX !l[G]SCԮӝQ4M?M˲&(DEFR ׌\.ыq2 t @|S [^ E" G4nCYԽx?y.kڋaaa4bԻOb" NPZ@LIQD-O%0D ;'LmTBa*}8  p`{mGuu~:H㢞R&g9{PFn   y~1՞Ьx jLTXʿ5(|^c7!!n=>pUz:tZa-q!鮻 KT<- (5kc}.]-3f(v|[6C( J+JcwFtѤ󚅊7/hMu'p =TCtz"2l*#sԲÝJ( 4 Q 2n A81uJZBmAd_POLpDw#6T uטw(:NԠ5h53pqfU mKA d?^z G4`y] pOɪ= Ewr gh~AhL@ށ:ziIjKvޚj͊@Z0s2&l(W< 8i\_UoX4rogm뱆2!W [~ EA`˂:,Tx>obDQhjG+y\Ա\q_v?}c݋VNsSz=yMp!,,;.n,/V78p$QeeMTvcXXkIǎbA( h`LpP85wfCP~Mzzּt*]*]K`j؄ZXFA/ҁytL!6 lG$u%=T:u;5Ykh !$0P*&]I`Sݹqy~lcyyV83 8N>|"2DAF4G4r޼C;BQ۶0("_.X2T`[m(}O:'*=# ܜp&1տo5e|"-0" #fhS5Qu\Hvj푥 `%jBv*+9tgTqO=\(PÀ.n/-P Ҋ0Q<3r}}zS-`7]dLځRv-o=muP('&T1x: l$8(q Ι8k6z\@mc74Ν"﫠9ʨ}3vhI'ȾβA]TvW8P#1jӕj"m9;h:Dn P4SPZQ7Q<@ށ 8`IG4B»TPx ܥ`՟ԎWw*'1T\(|U\8NB*;yZ .4f٬ըX_{XOa(8HhL@ށ:jK[;糏p[ 8  `;-ztECܭPYN @Rj0B(8AlYup8 'E( 5 RpE*)c%8 r f+,[ ĈF~s:ywD3bG"h1פXOK+ş`8G(rna3Mb+F(8 E\<yu^?Ĺ$pnA6>㡎\Q,Eh" [fդ48`a&λ: E*CED%>s<;ஃ'5kP}%u @5oC.&20Q<+Q[!jPib4r \ E7yѨ'4kqn >֎c|Q,@nhfAiE Ѩ޲xXcAb|b @J<A5PGF(vxHձZ"P4FAiEDy*༃3.ct)r1r ԳS x <јu,,`D# PpՑ/&"`"@5CC- Sw;ggp(W)؊P40bDcyK40T#kW @=VP (x(11r^?aD#8G(&js@LubF(x  <;HuҎDm2r 3E?%20Qw~i$jaB-p,$ @O`D:xD#oY vhI[0BQ5E!r @ J+&;Ph1r<2 1yNJgp!r TQ( h6#w;X6ӵ+["#* .bDcyKj`D 82)6CV-ڛeAkaDvGP(r 2DP4u0gyw'5kPv%j[y-ghNyu0gyw~iʂ?pnOE8L]=M @5" ##y҂/pnODEhZP4Ma;poY񌾖w-1؊BrEp wq#vhI[0BQ5or @u(KuyѨ_cEy^wQ0%V.E|hnV4Tw;Doز[łO|xhnV 4"I޶8)|x hn'F4g ξ8`fGhӵ+["#P4j#F4& @wFLh+ӑ[XP-P4jV-eAc5˥- ;ފJ;m܂ ?PP4 F4r\<"㼃xM[F4~Edg.Ev(Gyu0ҔWpnOE8L]`i.@nx  # hTG?@-΂ϵ=PFnx" Ma;pnDXMCy[J;#S(BS|hOpy2/x1yNކ >r<gP4&` I0EnF(B|ј;E#h>%((Zw/8+P4#,p\<&DvF(OA|VPZQw02&1P4'xGT+-"#Q" gA </B,ϛ(?A%w`G(_ J+*0L܂Opf_hpx 4" ?P4ҊEZt\@(#wWv`EAiEѢxߕ/~"h`زYsq|<] P4yCp&[Vh`wŃ7+-J+*0܂?3`?- oy4~|:`t8Id`DG-p*yXEn'~|TʂҊĘFO/ (@PZQ0V>~n uo((APZQш~ E7["ak#[E7#y;fVPp# Ń<rE޽F FQRr SBJ0LVN:A(a:%@ >iGBׄ,|gMXvtb\F݊:|iIyeQoChJyz 2Bشls+׬O+8Bܴl)J^=c~@h&A} *8'Иh;(4(# w :d#4eEcy)_Y|((t +Kx𮂳 Eh:N# kЉ+72?}_ŗЩƲB$4ΥW4^- `ӲY8{nBȴl)J~Hg 4MvW`, value = 0, color_if = "green", color_else = "red", digits = 2 ) colour_if( x, columns, predicate = `>`, value = 0, colour_if = "green", colour_else = "red", digits = 2 ) } \arguments{ \item{x}{A data frame} \item{columns}{Character vector with column names of \code{x} that should be formatted.} \item{predicate}{A function that takes \code{columns} and \code{value} as input and which should return \code{TRUE} or \code{FALSE}, based on if the condition (in comparison with \code{value}) is met.} \item{value}{The comparator. May be used in conjunction with \code{predicate} to quickly set up a function which compares elements in \code{colums} to \code{value}. May be ignored when \code{predicate} is a function that internally computes other comparisons. See 'Examples'.} \item{color_if, colour_if}{Character vector, indicating the color code used to format values in \code{x} that meet the condition of \code{predicate} and \code{value}. May be one of \code{"red"}, \code{"yellow"}, \code{"green"}, \code{"blue"}, \code{"violet"}, \code{"cyan"} or \code{"grey"}. Formatting is also possible with \code{"bold"} or \code{"italic"}.} \item{color_else, colour_else}{See \code{color_if}, but only for conditions that are \emph{not} met.} \item{digits}{Digits for rounded values.} } \value{ The . } \description{ Convenient function that formats columns in data frames with color codes, where the color is chosen based on certain conditions. Columns are then printed in color in the console. } \details{ The predicate-function simply works like this: \code{which(predicate(x[, columns], value))} } \examples{ # all values in Sepal.Length larger than 5 in green, all remaining in red x <- color_if(iris[1:10, ], columns = "Sepal.Length", predicate = `>`, value = 5) x cat(x$Sepal.Length) # all levels "setosa" in Species in green, all remaining in red x <- color_if(iris, columns = "Species", predicate = `==`, value = "setosa") cat(x$Species) # own function, argument "value" not needed here p <- function(x, y) { x >= 4.9 & x <= 5.1 } # all values in Sepal.Length between 4.9 and 5.1 in green, all remaining in red x <- color_if(iris[1:10, ], columns = "Sepal.Length", predicate = p) cat(x$Sepal.Length) } insight/man/link_inverse.Rd0000644000176200001440000000241213613301122015440 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/link_inverse.R \name{link_inverse} \alias{link_inverse} \alias{link_inverse.betareg} \alias{link_inverse.DirichletRegModel} \alias{link_inverse.gamlss} \title{Get link-inverse function from model object} \usage{ link_inverse(x, ...) \method{link_inverse}{betareg}(x, what = c("mean", "precision"), ...) \method{link_inverse}{DirichletRegModel}(x, what = c("mean", "precision"), ...) \method{link_inverse}{gamlss}(x, what = c("mu", "sigma", "nu", "tau"), ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} \item{what}{For \code{gamlss} models, indicates for which distribution parameter the link (inverse) function should be returned; for \code{betareg} or \code{DirichletRegModel}, can be \code{"mean"} or \code{"precision"}.} } \value{ A function, describing the inverse-link function from a model-object. For multivariate-response models, a list of functions is returned. } \description{ Returns the link-inverse function from a model object. } \examples{ # example from ?stats::glm counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) outcome <- gl(3, 1, 9) treatment <- gl(3, 3) m <- glm(counts ~ outcome + treatment, family = poisson()) link_inverse(m)(.3) # same as exp(.3) } insight/man/n_obs.Rd0000644000176200001440000000165713566471215014104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/n_obs.R \name{n_obs} \alias{n_obs} \alias{n_obs.svyolr} \alias{n_obs.stanmvreg} \title{Get number of observations from a model} \usage{ n_obs(x, ...) \method{n_obs}{svyolr}(x, weighted = FALSE, ...) \method{n_obs}{stanmvreg}(x, select = NULL, ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} \item{weighted}{For survey designs, returns the weighted sample size.} \item{select}{Optional name(s) of response variables for which to extract values. Can be used in case of regression models with multiple response variables.} } \value{ The number of observations used to fit the model, or \code{NULL} if this information is not available. } \description{ This method returns the number of observation that were used to fit the model, as numeric value. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) n_obs(m) } insight/man/get_response.Rd0000644000176200001440000000203013566471215015463 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_response.R \name{get_response} \alias{get_response} \title{Get the values from the response variable} \usage{ get_response(x, select = NULL) } \arguments{ \item{x}{A fitted model.} \item{select}{Optional name(s) of response variables for which to extract values. Can be used in case of regression models with multiple response variables.} } \value{ The values of the response variable, as vector, or a data frame if \code{x} has more than one defined response variable. } \description{ Returns the values the response variable(s) from a model object. If the model is a multivariate response model, a data frame with values from all response variables is returned. } \examples{ library(lme4) data(cbpp) data(mtcars) cbpp$trials <- cbpp$size - cbpp$incidence m <- glm(cbind(incidence, trials) ~ period, data = cbpp, family = binomial) head(get_response(m)) get_response(m, select = "incidence") m <- lm(mpg ~ wt + cyl + vs, data = mtcars) get_response(m) } insight/man/dot-colour_detect.Rd0000644000176200001440000000037213615562325016412 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/color_if.R \name{.colour_detect} \alias{.colour_detect} \title{Detect coloured cells} \usage{ .colour_detect(x) } \description{ Detect coloured cells } \keyword{internal} insight/man/get_random.Rd0000644000176200001440000000151313566471215015112 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_random.R \name{get_random} \alias{get_random} \title{Get the data from random effects} \usage{ get_random(x) } \arguments{ \item{x}{A fitted mixed model.} } \value{ The data from all random effects terms, as data frame. Or \code{NULL} if model has no random effects. } \description{ Returns the data from all random effects terms. } \examples{ library(lme4) data(sleepstudy) # prepare some data... sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } m <- lmer( Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy ) head(get_random(m)) } insight/man/format_value.Rd0000644000176200001440000000246713615554000015455 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/format_value.R \name{format_value} \alias{format_value} \title{Numeric Values Formatting} \usage{ format_value( x, digits = 2, protect_integers = FALSE, missing = "", width = NULL, as_percent = FALSE, ... ) } \arguments{ \item{x}{Numeric value.} \item{digits}{Number of significant digits.} \item{protect_integers}{Should integers be kept as integers (i.e., without decimals)?} \item{missing}{Value by which \code{NA} values are replaced. By default, an empty string (i.e. \code{""}) is returned for \code{NA}.} \item{width}{Minimum width of the returned string. If not \code{NULL} and \code{width} is larger than the string's length, leading whitespaces are added to the string.} \item{as_percent}{Logical, if \code{TRUE}, value is formatted as percentage value.} \item{...}{Arguments passed to or from other methods.} } \value{ A formatted string. } \description{ Numeric Values Formatting } \examples{ format_value(1.20) format_value(1.2) format_value(1.2012313) format_value(c(0.0045, 234, -23)) format_value(c(0.0045, .12, .34)) format_value(c(0.0045, .12, .34), as_percent = TRUE) format_value(as.factor(c("A", "B", "A"))) format_value(iris$Species) format_value(3) format_value(3, protect_integers = TRUE) format_value(iris) } insight/man/find_formula.Rd0000644000176200001440000000416313613250326015433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/find_formula.R \name{find_formula} \alias{find_formula} \title{Find model formula} \usage{ find_formula(x, ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} } \value{ A list of formulas that describe the model. For simple models, only one list-element, \code{conditional}, is returned. For more complex models, the returned list may have following elements: \itemize{ \item \code{conditional}, the "fixed effects" part from the model. One exception are \code{DirichletRegModel} models from \pkg{DirichletReg}, which has two or three components, depending on \code{model}. \item \code{random}, the "random effects" part from the model (or the \code{id} for gee-models and similar) \item \code{zero_inflated}, the "fixed effects" part from the zero-inflation component of the model \item \code{zero_inflated_random}, the "random effects" part from the zero-inflation component of the model \item \code{dispersion}, the dispersion formula \item \code{instruments}, for fixed-effects regressions like \code{ivreg}, \code{felm} or \code{plm}, the instrumental variables \item \code{cluster}, for fixed-effects regressions like \code{felm}, the cluster specification \item \code{correlation}, for models with correlation-component like \code{gls}, the formula that describes the correlation structure \item \code{slopes}, for fixed-effects individual-slope models like \code{feis}, the formula for the slope parameters \item \code{precision}, for \code{DirichletRegModel} models from \pkg{DirichletReg}, when parametrization (i.e. \code{model}) is \code{"alternative"}. } } \description{ Returns the formula(s) for the different parts of a model (like fixed or random effects, zero-inflated component, ...). } \note{ For models of class \code{lme} or \code{gls} the correlation-component is only returned, when it is explicitly defined as named argument (\code{form}), e.g. \code{corAR1(form = ~1 | Mare)} } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) find_formula(m) } insight/man/get_parameters.Rd0000644000176200001440000001332513613301122015757 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_parameters.R \name{get_parameters} \alias{get_parameters} \alias{get_parameters.rqss} \alias{get_parameters.cgam} \alias{get_parameters.betareg} \alias{get_parameters.DirichletRegModel} \alias{get_parameters.clm2} \alias{get_parameters.coxme} \alias{get_parameters.merMod} \alias{get_parameters.lme} \alias{get_parameters.mixed} \alias{get_parameters.MixMod} \alias{get_parameters.glmmTMB} \alias{get_parameters.BBmm} \alias{get_parameters.glimML} \alias{get_parameters.gamm} \alias{get_parameters.Gam} \alias{get_parameters.gam} \alias{get_parameters.vgam} \alias{get_parameters.zeroinfl} \alias{get_parameters.aovlist} \alias{get_parameters.MCMCglmm} \alias{get_parameters.BFBayesFactor} \alias{get_parameters.stanmvreg} \alias{get_parameters.brmsfit} \alias{get_parameters.stanreg} \alias{get_parameters.sim.merMod} \title{Get model parameters} \usage{ get_parameters(x, ...) \method{get_parameters}{rqss}(x, component = c("all", "conditional", "smooth_terms"), ...) \method{get_parameters}{cgam}(x, component = c("all", "conditional", "smooth_terms"), ...) \method{get_parameters}{betareg}(x, component = c("all", "conditional", "precision"), ...) \method{get_parameters}{DirichletRegModel}(x, component = c("all", "conditional", "precision"), ...) \method{get_parameters}{clm2}(x, component = c("all", "conditional", "scale"), ...) \method{get_parameters}{coxme}(x, effects = c("fixed", "random"), ...) \method{get_parameters}{merMod}(x, effects = c("fixed", "random"), ...) \method{get_parameters}{lme}(x, effects = c("fixed", "random"), ...) \method{get_parameters}{mixed}(x, effects = c("fixed", "random"), ...) \method{get_parameters}{MixMod}( x, effects = c("fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ... ) \method{get_parameters}{glmmTMB}( x, effects = c("fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ... ) \method{get_parameters}{BBmm}(x, effects = c("fixed", "random"), ...) \method{get_parameters}{glimML}(x, effects = c("fixed", "random", "all"), ...) \method{get_parameters}{gamm}(x, component = c("all", "conditional", "smooth_terms"), ...) \method{get_parameters}{Gam}(x, component = c("all", "conditional", "smooth_terms"), ...) \method{get_parameters}{gam}(x, component = c("all", "conditional", "smooth_terms"), ...) \method{get_parameters}{vgam}(x, component = c("all", "conditional", "smooth_terms"), ...) \method{get_parameters}{zeroinfl}( x, component = c("all", "conditional", "zi", "zero_inflated"), ... ) \method{get_parameters}{aovlist}(x, effects = c("fixed", "random", "all"), ...) \method{get_parameters}{MCMCglmm}(x, effects = c("fixed", "random", "all"), ...) \method{get_parameters}{BFBayesFactor}( x, effects = c("all", "fixed", "random"), component = c("all", "extra"), iterations = 4000, progress = FALSE, ... ) \method{get_parameters}{stanmvreg}( x, effects = c("fixed", "random", "all"), parameters = NULL, ... ) \method{get_parameters}{brmsfit}( x, effects = c("fixed", "random", "all"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "simplex", "sigma", "smooth_terms"), parameters = NULL, ... ) \method{get_parameters}{stanreg}( x, effects = c("fixed", "random", "all"), parameters = NULL, ... ) \method{get_parameters}{sim.merMod}( x, effects = c("fixed", "random", "all"), parameters = NULL, ... ) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} \item{component}{Should all parameters, parameters for the conditional model, the zero-inflated part of the model, the dispersion term or the instrumental variables be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variable (so called fixed-effects regressions). May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} \item{effects}{Should parameters for fixed effects, random effects or both be returned? Only applies to mixed models. May be abbreviated.} \item{iterations}{Number of posterior draws.} \item{progress}{Display progress.} \item{parameters}{Regular expression pattern that describes the parameters that should be returned.} } \value{ \itemize{ \item for non-Bayesian models and if \code{effects = "fixed"}, a data frame with two columns: the parameter names and the related point estimates \item if \code{effects = "random"}, a list of data frames with the random effects (as returned by \code{ranef()}), unless the random effects have the same simplified structure as fixed effects (e.g. for models from \pkg{MCMCglmm}) \item for Bayesian models, the posterior samples from the requested parameters as data frame \item for Anova (\code{aov()}) with error term, a list of parameters for the conditional and the random effects parameters \item for models with smooth terms or zero-inflation component, a data frame with three columns: the parameter names, the related point estimates and the component } } \description{ Returns the coefficients (or posterior samples for Bayesian models) from a model. } \details{ In most cases when models either return different "effects" (fixed, random) or "components" (conditional, zero-inflated, ...), the arguments \code{effects} and \code{component} can be used. \cr \cr \code{get_parameters()} is comparable to \code{coef()}, however, the coefficients are returned as data frame (with columns for names and point estimates of coefficients). For Bayesian models, the posterior samples of parameters are returned. } \examples{ data(mtcars) m <- lm(mpg ~ wt + cyl + vs, data = mtcars) get_parameters(m) } insight/man/get_data.Rd0000644000176200001440000000610013602432505014526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_data.R \name{get_data} \alias{get_data} \alias{get_data.gee} \alias{get_data.rqss} \alias{get_data.hurdle} \alias{get_data.glmmTMB} \alias{get_data.merMod} \alias{get_data.glmmadmb} \alias{get_data.rlmerMod} \alias{get_data.clmm} \alias{get_data.mixed} \alias{get_data.lme} \alias{get_data.MixMod} \alias{get_data.brmsfit} \alias{get_data.stanreg} \alias{get_data.MCMCglmm} \title{Get the data that was used to fit the model} \usage{ get_data(x, ...) \method{get_data}{gee}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{rqss}(x, component = c("all", "conditional", "smooth_terms"), ...) \method{get_data}{hurdle}( x, component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ... ) \method{get_data}{glmmTMB}( x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ... ) \method{get_data}{merMod}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{glmmadmb}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{rlmerMod}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{clmm}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{mixed}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{lme}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{MixMod}( x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ... ) \method{get_data}{brmsfit}( x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated"), ... ) \method{get_data}{stanreg}(x, effects = c("all", "fixed", "random"), ...) \method{get_data}{MCMCglmm}(x, effects = c("all", "fixed", "random"), ...) } \arguments{ \item{x}{A fitted model.} \item{...}{Currently not used.} \item{effects}{Should model data for fixed effects, random effects or both be returned? Only applies to mixed models.} \item{component}{Should all predictor variables, predictor variables for the conditional model, the zero-inflated part of the model, the dispersion term or the instrumental variables be returned? Applies to models with zero-inflated and/or dispersion formula, or to models with instrumental variable (so called fixed-effects regressions). May be abbreviated. Note that the \emph{conditional} component is also called \emph{count} or \emph{mean} component, depending on the model.} } \value{ The data that was used to fit the model. } \description{ This functions tries to get the data that was used to fit the model and returns it as data frame. } \note{ Unlike \code{model.frame()}, which may contain transformed variables (e.g. if \code{poly()} or \code{scale()} was used inside the formula to specify the model), \code{get_data()} aims at returning the "original", untransformed data. } \examples{ data(cbpp, package = "lme4") cbpp$trials <- cbpp$size - cbpp$incidence m <- glm(cbind(incidence, trials) ~ period, data = cbpp, family = binomial) head(get_data(m)) } insight/man/get_predictors.Rd0000644000176200001440000000073413615562325016012 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_predictors.R \name{get_predictors} \alias{get_predictors} \title{Get the data from model predictors} \usage{ get_predictors(x) } \arguments{ \item{x}{A fitted model.} } \value{ The data from all predictor variables, as data frame. } \description{ Returns the data from all predictor variables (fixed effects). } \examples{ m <- lm(mpg ~ wt + cyl + vs, data = mtcars) head(get_predictors(m)) } insight/DESCRIPTION0000644000176200001440000000507613615601156013441 0ustar liggesusersPackage: insight Type: Package Title: Easy Access to Model Information for Various Model Objects Description: A tool to provide an easy, intuitive and consistent access to information contained in various R models, like model formulas, model terms, information about random effects, data that was used to fit the model or data from response variables. 'insight' mainly revolves around two types of functions: Functions that find (the names of) information, starting with 'find_', and functions that get the underlying data, starting with 'get_'. The package has a consistent syntax and works with many different model objects, where otherwise functions to access these information are missing. Version: 0.8.1 Authors@R: c(person("Daniel", "Lüdecke", role = c("aut", "cre"), email = "d.luedecke@uke.de", comment = c(ORCID = "0000-0002-8895-3206")), person("Dominique", "Makowski", role = c("aut", "ctb"), email = "dom.makowski@gmail.com", comment = c(ORCID = "0000-0001-5375-9967")), person("Indrajeet", "Patil", role = c("aut", "ctb"), email = "patilindrajeet.science@gmail.com", comment = c(ORCID = "0000-0003-1995-6531")), person("Philip", "Waggoner", role = c("aut", "ctb"), email = "philip.waggoner@gmail.com", comment = c(ORCID = "0000-0002-7825-7573"))) Maintainer: Daniel Lüdecke License: GPL-3 URL: https://easystats.github.io/insight/ BugReports: https://github.com/easystats/insight/issues Depends: R (>= 3.2) Imports: methods, stats, utils Suggests: AER, afex, aod, BayesFactor, bayestestR, betareg, biglm, blavaan, blme, brms, censReg, cgam, coxme, cplm, crch, estimatr, feisr, fixest, gam, gamm4, gamlss, gbm, gee, geepack, GLMMadaptive, glmmTMB, gmnl, HRQoL, httr, lavaan, lfe, logistf, MASS, Matrix, MCMCglmm, mlogit, multgee, lme4, mgcv, nnet, nlme, ordinal, panelr, plm, pscl, quantreg, rms, robustbase, robustlmm, rstanarm, rstudioapi, speedglm, splines, statmod, survey, survival, tripack, truncreg, testthat, VGAM, knitr, rmarkdown, spelling Encoding: UTF-8 LazyData: true RoxygenNote: 7.0.2 VignetteBuilder: knitr Language: en-US NeedsCompilation: no Packaged: 2020-02-02 15:04:24 UTC; Daniel Author: Daniel Lüdecke [aut, cre] (), Dominique Makowski [aut, ctb] (), Indrajeet Patil [aut, ctb] (), Philip Waggoner [aut, ctb] () Repository: CRAN Date/Publication: 2020-02-02 17:10:06 UTC insight/build/0000755000176200001440000000000013615562367013034 5ustar liggesusersinsight/build/vignette.rds0000644000176200001440000000030313615562367015367 0ustar liggesusersb```b`fcb`b2 1# '+L( MAbJ tdqM, (&$y楀aM wjey~L6̜T!%ps QY_/( @hrNb1GRKҊA>insight/build/partial.rdb0000644000176200001440000002437113615562364015165 0ustar liggesusers}k{I| R80`d%P6j TQ :-R̔Tmmuzzw{v~;ϳG}Lo+9$e "2%3$ﱝ9qΉsNDF>b]."ub]gݟz?w]<j)e2_oo<˚0f5XTlȘYبр=W횯[|Cj>h%_p%?~9+v;\y4u#el5}8|b+Q(R%y(zrM)'_x6g9g/\|;%566FrCu^l)5yl HXZnojjn8X1PXGǺזW;TS$%iU(fL3XJv" uu'BN- $U% >[J^|KӗmM"l]qv|J+|;@i$a0ya-*z`£B= 1Zo!bC\YhB94.#-0Oy$7]q+"@n4l BO}zO/l tH+&}QqEd#UjciE]ln>XWDV:Tk8ۨ-5 ڨv!=z5d]FljeԂ#hh9[D0\C5™hRQiOy{`fA4 2V 1V qm0Jɘ^f_tW}AVgZo+bWD:ܕXLC5,3JqSs95.ofULF8z.B9d[o>4w'֒4p Z覝bNRzהMszflB\Gx Т0Z릭6XK=Y]BlcDBX^Ǘ!B 9!,`N ymBqܷz=IFW!F؂=P]hQ}!OZSG a J7rpz:SSV-/S;BUUҽ*OGLNaX@IZ]fmP;Bu}U0[Q) s ^'C<dF[J!j;  㠥YuV6rv6jb!.ɬz08gb;eKRj_㵠XW7XPBBhR1ȑ{Қآϴb:kj@{u#T@; %=,5b][T,%lKы$ӌqkc9Oy0{,YQ]S#F+WB|q]e-C&mUsJQw&^?6pb)7lh9-q;j|[ңk=y.':yPǁ@p˸q@i\Y*"e),5SM">B[).@? -PDyvqXdžmդe*}4l|Эam ˩fL#k3dE݀_ BD%bYm1qZ$4PCXn:V YH`Ufrbnd4#< d}x"nHyiqZhDB;f᳄#Erg }{xh㠥gwF"=z!C\~ X?~m{l·P*8/#.ɮV 2F_`Wr(Uuճμ^Ǣ,t1#G֛k=cBꥇv\jhX}- n-WDf$=l<#AGpD`I25SqRRDYwJ77/ǗEzxtLNK]B7Ԟ.u6vKFeK PjQ`~t ="b}%8`,&Y<*N2s5tEIx xt9tt9ؕ}mWRg_;:d$-i0T:Vɝzu;bfW$(sПq{9lcG*c=l/wx2ͣg-UeYcB$_+w9D.(՛.]nOoa{e2FۛЛ?$ؗ.m~_C@ЦRlˤlVshlGEd< v{::B{:mP DeC0qQV(hn\^%?MUt2Ud̴غRUw*_M턊fe@%mV6uo:3mHj5*>=( NO/$ x#?f  Qh\ҋ7H(篁~mp)޴Su;hDx߅w̞WVm=pٓ FMΜ$}b7j!?1hGzbb$nỏqfFjb$-ZM9͞gfD'F/4@M4AІ @[­01^對#agN$TrCHb7< :v>SN=(<_G%I%/0_Z&INKX]l|jM$KO@%q{ )蟶b$+YKs/@"C͒Lq+D)j b!+=`}ئľC\P5!Z,W42vOۛZ.rG&SDp$ѐm5g9KͰT;L] v_ /rw򅦰ät o3;Bygy8 P2Ь,!nZ4hG|))#M#v*J% iaaJ{ӴLQ| sz%PˉR+29SuLɪ3w&v<&b BSLY 1pq\YXZagSU]@r;wr.~:Vp+VTO帣q'̅,vɛAQYfզFPCUjv4vJ5e]tu*v2htOXF͙d[֪*MS崌F//.NO!%a Z{(@ӍnWm:5ux TY8!&eΏ~>lJ8 zTھQ8I8hs[8Gmm#Ppu^3'U$a~T$n ` t* Us 시v33jǿIܞqmP$ Vϓ97@oc4.3W:eFq,T;ZANr'EA AO#I4\-uRÑix|]uJO w -5&DpjF4謌j*C3:V Cp-5 }C\!8Bb)y;SЍh/6jH<~#u4#& ~rݝvC[vyj!FZ%n%-BRկ̅HaiReaOȽamHb9r.T`|.F%|rPar!M*B)le.Ihuq{li.D ˅F܁R j{WʁJG@H=ucf!!Qѽ' l>@sD%cNSgă$q2eץWDuIvwLR-eC}k`n*{KYƢv9T8PtdJ`Wd{NJ˛ViUCW_mYժۡrmKY߶c3-MLz=zj;jN HOmْܖrShyF1:Yhd&\ B{i*mlvz悄dc)SdQ`t"ŎсMx,~],fDKZO]:Q׭{2 8;7zQtFbS4۰3/0TF+S]Xr/bm.nU]x? kՅ#!0p"u,$FC\!MyEƧ'"_ƄU%<>( =I4=,^UTՃ=ǑAU6bzK#+; U=.hSLEİ :|.%^ ]vZPEnZɣYNkv‹(EvO_ Z?Z>sk$-c x8z#$qrokW!%t3 =MAGH Aֽ,%ij2|M71Ƽccj]s̸7O:h{jxԻނ)_;>8I/;kbm3wɘyUr"1o艄/|)|%y@#GB[W ͙5AG;fD{;1!fvbwvgeBίh&ÿ E[U%uZIYWl5K{i(%g0)z (-]^ k$WAKϭ.JkwxN~y]a?T-sJ3rLW!zw*ɘVV36D[)yѽgt,~(aDYhq~?; z?ɶ8zOz'A mNa'A?J|G{v oYvő.0o]n9? ݦ>PTW9OR-%(j%0 Z>ֲW9Ҳ1l(RN Zj%lھ 曱̼Yc*3ǃUu!/:GR^-1홸޲:@;w+W"ԎCnnx31@A£_^ -PdA480bl-dT{poզ-:%wuj9fwxU}.9)eGAVY'l`i;X^1 Hr22rQlիiTu+(KX%#& _'dTzU`ɖSIK 'ڐXp–'y.0ocG9lWam0ۗ}˥Pò'^_Xc i=zfW 0#Q&I$)R;&Igq`ki\ʑH$ 'f9q; gQ̿Vr4t%@nrD#T@©hŢzJlxOl3ALaT)a$:ԫCe5;ǚT͡v_~TvZ.퐰䮿Wh+п ?^ g#o6Dxa˳ ]am09sdWwx|,;֊$Yq8>J^kg[.8qiKZx捹M/Z6 `@KW!{ 6ۡ^&).BiQ$phmM~q1wx s#9)x灗AGB@.!WBw ᜕ zhA>@j2-K ?AdTghZV|"hZ yO>AOAl47A6W,_l ,-!Ɓb7δD %RWZog$௫UpE[RcQi--p'-D=D{{A|mR%> jӧ-4kMCWI;Ai>21~Н^8$8RoRlF>DO8jQ$@&A'#RW肄ӠCLGgg!@j_NY'$V:$Bj7䊆. vbtq32b ?)S0A~Ǯj=03 -~.BhgqE:" (cR4,n ^3v{5z^tI$ $ $.Z*ݡ'c3HFE;08(QED,Sj!i8p Tkl2LN&I4lGQu| jk2ZrxȬKVY{pS(wA?lQn~QD | qx9La}MI~nC9#Z.IWp zL\ #@ G@ =^I$q֘8pDLrxboarY53 EvV΃z=OV \-oa;a2FY.^nQ? ̴D !hX+dQ=>z.$ݠw75]p`h&jd-OxNKlI+0O@M/b-Ft΃lRp- ?-5s {ÿgBb%W@aeɮ6aHH~` XbnpT2_:6k$!ѽ/aaw~|UQto=l3t+zMcaHx>Zj _柔흊ƅ_b!.IzWqG:k7$y#PM2 i!][k;v d5p܈u_Vqjvma D!:bR-L1J)U)-n)6;Ǽwy_OL2jB4B|%R sefػ:/[H%:K"G%3 ~y>Z#UO#M5}i8VLj"u%wr(=O|AWvZ 5*pGآ 7HJ!kqI/82F3v0A1QFy_!cCQ;@ w٧a[XWl1n%X|vzD-vT{mcx̦?TleTCT=xVN3k3`KS77x}iԋ~s ]1M/AAZ7\zM2/;+;i;ʆzeٯ8 Ec'g&N̸ffg&ffgg?.XL= hEHwxZ^XfB+9G}HX韸&LO{,@,$um:NO&[ { kzc붊X;t%1nnKd7OE&\@QhU?gޱKe=r+8F^^Y3=oͶJ@\qv8\+`H|6xϛqUڰ+iZsB4#}W3EP,Oh?7;*rFQ['jb80YOrϓNȘj.e4phUۚQzkj5ñhzPmj)C5tP<~;r3zٮ׻ j6 _ E'AHjmLz̅ ދIgg %S; f{c`==w)iZ.AKPװ@-NhBqd>q)+ٝ6+Ҟ0 ݿI.O;ޣZ{aDw )j+cu<'JU޴\aS5=i[vcm=kSs`^^v}}\V^w/am[=霶QTN;wtiH冾J?U팥7۱EVA~WҩjމxOzUy&NgsFUɤ*mV7?Pt-֟ `kvu Gڴʘ; rWi8jRk=)M+w6tۆVՍysuR5ZO=}۰ᚅ_~nް{n)NJUUϳFn~-_֓ƒO ӻV,Wm2n 5)ZIzVm}ߕֳklnP"=5\:u_Sl3S/KT_O0zzyhenP;&vu`)U#:+#OD'U`Й˱cw5mX )GtU' }8<`邒y6AtY L3 zLv۫;[ﾆ ^pqMy9>- atn',]O]),c>bHgǍ>U~_I +Vfx?:;e08\I=L2LMLb6io*Le1ioh(类kg'6$izH(n)of="ɔ/<^Kɔ 3.gsIͰMM^7EtK}e>Q]IIXuUb%?97+ ӊv?OWԧ\C7477o(m~oyS"|8v΃nen Qӷiaޜk&w>wRGbͬWS7zp-oka݉ԔEz6[wmv4"ix;qlkIת#h 40@kQV*>y9(N zxoezK5EQh躸`MB/A?llۉVS+kˏF 8!Xq'zw}Ta(Dk*(U[?A#+1vY$ZIx)+"p-'̂F>RPu$w?l$,*)N TԂzAZ2oя Tinsight/tests/0000755000176200001440000000000013563552732013074 5ustar liggesusersinsight/tests/spelling.R0000644000176200001440000000024013563552732015030 0ustar liggesusersif (requireNamespace("spelling", quietly = TRUE)) { spelling::spell_check_test( vignettes = TRUE, error = FALSE, skip_on_cran = TRUE ) } insight/tests/testthat/0000755000176200001440000000000013615601156014725 5ustar liggesusersinsight/tests/testthat/test-gamlss.R0000644000176200001440000000537213531007236017316 0ustar liggesusersif (require("testthat") && require("insight") && require("gamlss")) { context("insight, model_info") data(abdom) m1 <- gamlss( y ~ pb(x), sigma.formula = ~ pb(x), family = BCT, data = abdom, method = mixed(1, 20) ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = "x", sigma = "x")) expect_identical(find_predictors(m1, flatten = TRUE), "x") expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "y") }) test_that("get_response", { expect_equal(get_response(m1), abdom$y) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), "x") }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 610) expect_equal(colnames(get_data(m1)), c("y", "x")) }) test_that("find_formula", { expect_length(find_formula(m1), 4) expect_equal( find_formula(m1), list( conditional = as.formula("y ~ pb(x)"), sigma = as.formula("~pb(x)"), nu = as.formula("~1"), tau = as.formula("~1") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "y", conditional = "x", sigma = "x" ) ) expect_equal(find_variables(m1, flatten = TRUE), c("y", "x")) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "y", conditional = "pb(x)", sigma = "pb(x)", nu = "1", tau = "1" ) ) }) test_that("n_obs", { expect_equal(n_obs(m1), 610) }) test_that("link_function", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "pb(x)"), sigma = c("(Intercept)", "pb(x)"), nu = "(Intercept)", tau = "(Intercept)" ) ) expect_equal(nrow(get_parameters(m1)), 6) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "mixed")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-clmm.R0000644000176200001440000001237513531713511016761 0ustar liggesusersif (require("testthat") && require("insight") && require("ordinal")) { context("insight, model_info") data(wine, package = "ordinal") data(soup) m1 <- clmm(rating ~ temp + contact + (1 | judge), data = wine) m2 <- clmm(SURENESS ~ PROD + (1 | RESP) + (1 | RESP:PROD), data = soup, link = "probit", threshold = "equidistant" ) test_that("model_info", { expect_true(model_info(m1)$is_ordinal) expect_true(model_info(m2)$is_ordinal) expect_true(model_info(m1)$is_logit) expect_true(model_info(m2)$is_probit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("temp", "contact"))) expect_identical( find_predictors(m1, effects = "all"), list( conditional = c("temp", "contact"), random = "judge" ) ) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("temp", "contact", "judge") ) expect_identical(find_predictors(m2), list(conditional = "PROD")) expect_identical( find_predictors(m2, effects = "all"), list( conditional = "PROD", random = c("RESP", "PROD") ) ) expect_identical( find_predictors(m2, effects = "all", flatten = TRUE), c("PROD", "RESP") ) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "judge")) expect_equal(find_random(m2), list(random = c("RESP", "RESP:PROD"))) expect_equal(find_random(m2, split_nested = TRUE), list(random = c("RESP", "PROD"))) }) test_that("get_random", { expect_equal(get_random(m1), wine[, "judge", drop = FALSE]) expect_equal(get_random(m2), soup[, c("RESP", "PROD"), drop = FALSE]) }) test_that("find_response", { expect_identical(find_response(m1), "rating") expect_identical(find_response(m2), "SURENESS") }) test_that("get_response", { expect_equal(get_response(m1), wine$rating) expect_equal(get_response(m2), soup$SURENESS) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("temp", "contact")) expect_equal(colnames(get_predictors(m2)), "PROD") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) expect_equal(link_inverse(m2)(.2), pnorm(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 72) expect_equal( colnames(get_data(m1)), c("rating", "temp", "contact", "judge") ) expect_equal(nrow(get_data(m2)), 1847) expect_equal(colnames(get_data(m2)), c("SURENESS", "PROD", "RESP")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("rating ~ temp + contact"), random = as.formula("~1 | judge") ) ) expect_length(find_formula(m2), 2) expect_equal( find_formula(m2), list( conditional = as.formula("SURENESS ~ PROD"), random = list(as.formula("~1 | RESP"), as.formula("~1 | RESP:PROD")) ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "rating", conditional = c("temp", "contact"), random = "judge" ) ) expect_equal( find_terms(m1, flatten = TRUE), c("rating", "temp", "contact", "judge") ) expect_equal( find_terms(m2), list( response = "SURENESS", conditional = "PROD", random = c("RESP", "PROD") ) ) expect_equal( find_terms(m2, flatten = TRUE), c("SURENESS", "PROD", "RESP") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 72) expect_equal(n_obs(m2), 1847) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("1|2", "2|3", "3|4", "4|5", "tempwarm", "contactyes") ) ) expect_equal( find_parameters(m2), list(conditional = c("threshold.1", "spacing", "PRODTest")) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) }) test_that("get_variance", { expect_equal( get_variance(m1), list( var.fixed = 3.23207765938872, var.random = 1.27946088209319, var.residual = 3.28986813369645, var.distribution = 3.28986813369645, var.dispersion = 0, var.intercept = c(judge = 1.27946088209319) ), tolerance = 1e-4 ) expect_equal( get_variance(m2), list( var.fixed = 0.132313576370902, var.random = 0.193186321588604, var.residual = 1, var.distribution = 1, var.dispersion = 0, var.intercept = c(`RESP:PROD` = 0.148265480396059, RESP = 0.0449208411925493) ), tolerance = 1e-4 ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "z-statistic") }) } insight/tests/testthat/test-Gam2.R0000644000176200001440000000474313552364343016627 0ustar liggesusersif (require("testthat") && require("insight") && require("gam")) { context("insight, gam") data(kyphosis) m1 <- gam::gam( Kyphosis ~ s(Age, 4) + Number, family = binomial, data = kyphosis, trace = TRUE ) test_that("model_info", { expect_true(model_info(m1)$is_binomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Age", "Number"))) expect_identical(find_predictors(m1, flatten = TRUE), c("Age", "Number")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "Kyphosis") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 81) expect_equal(colnames(get_data(m1)), c("Kyphosis", "Age", "Number")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("Kyphosis ~ s(Age, 4) + Number")) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "Kyphosis", conditional = c("s(Age, 4)", "Number") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("Kyphosis", "s(Age, 4)", "Number") ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "Kyphosis", conditional = c("Age", "Number") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("Kyphosis", "Age", "Number") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 81) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "Number"), smooth_terms = "s(Age, 4)" ) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "Number", "s(Age, 4)") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "IWLS")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "F-statistic") }) } insight/tests/testthat/test-geeglm.R0000644000176200001440000000552613552364343017301 0ustar liggesusersif (require("testthat") && require("insight") && require("geepack")) { context("insight, model_info") data(warpbreaks) m1 <- geeglm( breaks ~ tension, id = wool, data = warpbreaks, family = poisson, corstr = "ar1" ) test_that("model_info", { expect_true(model_info(m1)$is_count) expect_false(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = "tension")) expect_identical(find_predictors(m1, flatten = TRUE), "tension") expect_identical( find_predictors(m1, effects = "random"), list(random = "wool") ) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("tension", "wool") ) }) test_that("find_response", { expect_identical(find_response(m1), "breaks") }) test_that("get_response", { expect_equal(get_response(m1), warpbreaks$breaks) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "wool")) }) test_that("get_random", { expect_equal(get_random(m1), warpbreaks[, "wool", drop = FALSE]) }) test_that("get_predictors", { expect_equal(get_predictors(m1), warpbreaks[, "tension", drop = FALSE]) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 54) expect_equal(colnames(get_data(m1)), c("breaks", "tension", "wool")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("breaks ~ tension"), random = as.formula("~wool") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "breaks", conditional = "tension", random = "wool" ) ) expect_equal( find_terms(m1, flatten = TRUE), c("breaks", "tension", "wool") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 54) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c( "(Intercept)", "tensionM", "tensionH" )) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "tensionM", "tensionH") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "chi-squared statistic") }) } insight/tests/testthat/test-lmer.R0000644000176200001440000002613013552364343016772 0ustar liggesusersif (require("testthat") && require("insight") && require("lme4")) { context("insight, find_predictors") data(sleepstudy) set.seed(123) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } m1 <- lme4::lmer(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy ) m2 <- lme4::lmer(Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m2)$is_linear) }) test_that("find_predictors", { expect_equal( find_predictors(m1, effects = "all"), list(conditional = "Days", random = "Subject") ) expect_equal( find_predictors(m1, effects = "all", flatten = TRUE), c("Days", "Subject") ) expect_equal( find_predictors(m1, effects = "fixed"), list(conditional = "Days") ) expect_equal( find_predictors(m1, effects = "fixed", flatten = TRUE), "Days" ) expect_equal( find_predictors(m1, effects = "random"), list(random = "Subject") ) expect_equal( find_predictors(m1, effects = "random", flatten = TRUE), "Subject" ) expect_equal( find_predictors(m2, effects = "all"), list( conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_equal( find_predictors(m2, effects = "all", flatten = TRUE), c("Days", "mysubgrp", "mygrp", "Subject") ) expect_equal( find_predictors(m2, effects = "fixed"), list(conditional = "Days") ) expect_equal(find_predictors(m2, effects = "random"), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_null(find_predictors(m2, effects = "all", component = "zi")) expect_null(find_predictors(m2, effects = "fixed", component = "zi")) expect_null(find_predictors(m2, effects = "random", component = "zi")) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "Subject")) expect_equal(find_random(m1, flatten = TRUE), "Subject") expect_equal(find_random(m2), list(random = c("mysubgrp:mygrp", "mygrp", "Subject"))) expect_equal(find_random(m2, split_nested = TRUE), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_equal( find_random(m2, flatten = TRUE), c("mysubgrp:mygrp", "mygrp", "Subject") ) expect_equal( find_random(m2, split_nested = TRUE, flatten = TRUE), c("mysubgrp", "mygrp", "Subject") ) }) test_that("find_response", { expect_identical(find_response(m1), "Reaction") expect_identical(find_response(m2), "Reaction") }) test_that("get_response", { expect_equal(get_response(m1), sleepstudy$Reaction) }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), .2) expect_identical(link_inverse(m2)(.2), .2) }) test_that("get_data", { expect_equal(colnames(get_data(m1)), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "all")), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "random")), "Subject") expect_equal( colnames(get_data(m2)), c("Reaction", "Days", "mygrp", "mysubgrp", "Subject") ) expect_equal( colnames(get_data(m2, effects = "all")), c("Reaction", "Days", "mygrp", "mysubgrp", "Subject") ) expect_equal(colnames(get_data(m2, effects = "random")), c("mysubgrp", "mygrp", "Subject")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_length(find_formula(m2), 2) expect_equal( find_formula(m1, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = as.formula("~1 + Days | Subject") ) ) expect_equal( find_formula(m2, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = list( as.formula("~1 | mysubgrp:mygrp"), as.formula("~1 | mygrp"), as.formula("~1 | Subject") ) ) ) }) test_that("find_terms", { expect_identical( find_terms(m1), list( response = "Reaction", conditional = "Days", random = c("Days", "Subject") ) ) expect_identical( find_terms(m1, flatten = TRUE), c("Reaction", "Days", "Subject") ) expect_identical( find_terms(m2), list( response = "Reaction", conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_identical( find_terms(m2, flatten = TRUE), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = "Reaction", conditional = "Days", random = "Subject" ) ) expect_identical( find_variables(m1, flatten = TRUE), c("Reaction", "Days", "Subject") ) expect_identical( find_variables(m2), list( response = "Reaction", conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_identical( find_variables(m2, flatten = TRUE), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("get_response", { expect_identical(get_response(m1), sleepstudy$Reaction) }) test_that("get_predictors", { expect_identical(colnames(get_predictors(m1)), "Days") expect_identical(colnames(get_predictors(m2)), "Days") }) test_that("get_random", { expect_identical(colnames(get_random(m1)), "Subject") expect_identical(colnames(get_random(m2)), c("mysubgrp", "mygrp", "Subject")) }) test_that("clean_names", { expect_identical(clean_names(m1), c("Reaction", "Days", "Subject")) expect_identical( clean_names(m2), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "Days"), random = list(Subject = c("(Intercept)", "Days")) ) ) expect_equal(nrow(get_parameters(m1)), 2) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "Days")) expect_equal( find_parameters(m2), list( conditional = c("(Intercept)", "Days"), random = list( `mysubgrp:mygrp` = "(Intercept)", Subject = "(Intercept)", mygrp = "(Intercept)" ) ) ) expect_equal(nrow(get_parameters(m2)), 2) expect_equal(get_parameters(m2)$Parameter, c("(Intercept)", "Days")) expect_equal( names(get_parameters(m2, effects = "random")), c("mysubgrp:mygrp", "Subject", "mygrp") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) }) test_that("get_variance", { skip_on_cran() skip_on_travis() expect_equal( get_variance(m1), list( var.fixed = 908.953362623165, var.random = 1698.23306388298, var.residual = 654.940795852432, var.distribution = 654.940795852432, var.dispersion = 0, var.intercept = c(Subject = 611.897607104638), var.slope = c(Subject.Days = 35.081069440305), cor.slope_intercept = c(Subject = 0.0656180314242511) ), tolerance = 1e-4 ) expect_equal(get_variance_fixed(m1), c(var.fixed = 908.95336262316459396970), tolerance = 1e-4 ) expect_equal(get_variance_random(m1), c(var.random = 1698.23306388298283309268), tolerance = 1e-4 ) expect_equal( get_variance_residual(m1), c(var.residual = 654.94079585243218843971), tolerance = 1e-4 ) expect_equal( get_variance_distribution(m1), c(var.distribution = 654.94079585243218843971), tolerance = 1e-4 ) expect_equal(get_variance_dispersion(m1), c(var.dispersion = 0), tolerance = 1e-4 ) expect_equal( get_variance_intercept(m1), c(var.intercept.Subject = 611.89760710463770010392), toleance = 1e-4 ) expect_equal( get_variance_slope(m1), c(var.slope.Subject.Days = 35.08106944030500073950), toleance = 1e-4 ) expect_equal( get_correlation_slope_intercept(m1), c(cor.slope_intercept.Subject = 0.06561803), toleance = 1e-4 ) expect_warning(expect_equal( get_variance(m2), list( var.fixed = 889.329700216337, var.residual = 941.817768377025, var.distribution = 941.817768377025, var.dispersion = 0, var.intercept = c( `mysubgrp:mygrp` = 0, Subject = 1357.35782386825, mygrp = 24.4073139080596 ) ), tolerance = 1e-4, )) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "REML", optimizer = "nloptwrap") ) }) test_that("find_random_slopes", { expect_equal(find_random_slopes(m1), list(random = "Days")) expect_null(find_random_slopes(m2)) }) m3 <- lme4::lmer(Reaction ~ (1 + Days | Subject), data = sleepstudy ) m4 <- lme4::lmer(Reaction ~ (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy ) m5 <- lme4::lmer(Reaction ~ 1 + (1 + Days | Subject), data = sleepstudy ) m6 <- lme4::lmer(Reaction ~ 1 + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy ) test_that("find_formula", { expect_equal( find_formula(m3), list( conditional = as.formula("Reaction ~ 1"), random = as.formula("~1 + Days | Subject") ) ) expect_equal( find_formula(m5), list( conditional = as.formula("Reaction ~ 1"), random = as.formula("~1 + Days | Subject") ) ) expect_equal( find_formula(m4), list( conditional = as.formula("Reaction ~ 1"), random = list( as.formula("~1 | mysubgrp:mygrp"), as.formula("~1 | mygrp"), as.formula("~1 | Subject") ) ) ) expect_equal( find_formula(m6), list( conditional = as.formula("Reaction ~ 1"), random = list( as.formula("~1 | mysubgrp:mygrp"), as.formula("~1 | mygrp"), as.formula("~1 | Subject") ) ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") }) } insight/tests/testthat/test-lme.R0000644000176200001440000001221613552364343016610 0ustar liggesusersif (require("testthat") && require("insight") && require("nlme") && require("lme4")) { context("insight, model_info") data("sleepstudy") data(Orthodont) m1 <- lme(Reaction ~ Days, random = ~ 1 + Days | Subject, data = sleepstudy ) m2 <- lme(distance ~ age + Sex, data = Orthodont, random = ~1) set.seed(123) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } m3 <- lme(Reaction ~ Days, random = ~ 1 | mygrp / mysubgrp, data = sleepstudy ) test_that("nested_varCorr", { skip_on_travis() skip_on_cran() expect_equal( insight:::.get_nested_lme_varcorr(m3), list( mysubgrp = structure( 7.508310765, .Dim = c(1L, 1L), .Dimnames = list("(Intercept)", "(Intercept)") ), mygrp = structure( 0.004897827, .Dim = c(1L, 1L), .Dimnames = list("(Intercept)", "(Intercept)") ) ), tolerance = 1e-4 ) }) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = "Days")) expect_identical(find_predictors(m2), list(conditional = c("age", "Sex"))) expect_identical( find_predictors(m1, effects = "all"), list(conditional = "Days", random = "Subject") ) expect_identical(find_predictors(m2, effects = "all"), list(conditional = c("age", "Sex"))) expect_identical(find_predictors(m1, flatten = TRUE), "Days") expect_identical( find_predictors(m1, effects = "random"), list(random = "Subject") ) }) test_that("find_response", { expect_identical(find_response(m1), "Reaction") expect_identical(find_response(m2), "distance") }) test_that("get_response", { expect_equal(get_response(m1), sleepstudy$Reaction) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "Subject")) expect_null(find_random(m2)) }) test_that("get_random", { expect_equal(get_random(m1), data.frame(Subject = sleepstudy$Subject)) expect_warning(get_random(m2)) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 180) expect_equal(colnames(get_data(m1)), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m2)), c("distance", "age", "Sex")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("Reaction ~ Days"), random = as.formula("~1 + Days | Subject") ) ) expect_length(find_formula(m2), 2) expect_equal( find_formula(m2), list( conditional = as.formula("distance ~ age + Sex"), random = as.formula("~1") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "Reaction", conditional = "Days", random = "Subject" ) ) expect_equal( find_variables(m1, flatten = TRUE), c("Reaction", "Days", "Subject") ) expect_equal( find_variables(m2), list( response = "distance", conditional = c("age", "Sex") ) ) }) test_that("n_obs", { expect_equal(n_obs(m1), 180) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "Days"), random = c("(Intercept)", "Days") ) ) expect_equal(nrow(get_parameters(m1)), 2) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "Days")) expect_equal( find_parameters(m2), list( conditional = c("(Intercept)", "age", "SexFemale"), random = c("(Intercept)") ) ) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "REML", optimizer = "nlminb") ) }) test_that("get_variance", { skip_on_cran() expect_equal( get_variance(m1), list( var.fixed = 908.95336262308865116211, var.random = 1698.06593646939654718153, var.residual = 654.94240352794997761521, var.distribution = 654.94240352794997761521, var.dispersion = 0, var.intercept = c(Subject = 612.07951112963326067984), var.slope = c(Subject.Days = 35.07130179308116169068), cor.slope_intercept = 0.06600000000000000311 ), tolerance = 1e-4 ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") expect_identical(find_statistic(m3), "t-statistic") }) } insight/tests/testthat/test-truncreg.R0000644000176200001440000000363513552364343017671 0ustar liggesusersif (require("testthat") && require("insight") && require("truncreg") && require("survival")) { context("insight, truncreg") data("tobin", package = "survival") m1 <- truncreg(durable ~ age + quant, data = tobin, subset = durable > 0) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("age", "quant"))) expect_identical(find_predictors(m1, flatten = TRUE), c("age", "quant")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "durable") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 7) expect_equal(colnames(get_data(m1)), c("durable", "age", "quant")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("durable ~ age + quant")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "durable", conditional = c("age", "quant") )) expect_equal(find_terms(m1, flatten = TRUE), c("durable", "age", "quant")) }) test_that("n_obs", { expect_equal(n_obs(m1), 7) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c( "(Intercept)", "age", "quant", "sigma" )) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "age", "quant", "sigma") ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-bigglm.R0000644000176200001440000000700513552364343017274 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { if (require("testthat") && require("insight") && require("glmmTMB") && require("biglm")) { context("insight, model_info") data(Salamanders) Salamanders$cover <- abs(Salamanders$cover) m1 <- bigglm(count ~ mined + log(cover) + sample, family = poisson(), data = Salamanders ) test_that("model_info", { expect_true(model_info(m1)$is_poisson) expect_true(model_info(m1)$is_count) expect_false(model_info(m1)$is_negbin) expect_false(model_info(m1)$is_binomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("mined", "cover", "sample"))) expect_identical( find_predictors(m1, flatten = TRUE), c("mined", "cover", "sample") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "count") }) test_that("get_response", { expect_equal(get_response(m1), Salamanders$count) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c("mined", "cover", "sample") ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 644) expect_equal( colnames(get_data(m1)), c( "site", "mined", "cover", "sample", "DOP", "Wtemp", "DOY", "spp", "count" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("count ~ mined + log(cover) + sample")) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "count", conditional = c("mined", "cover", "sample") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("count", "mined", "cover", "sample") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 644) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "minedno", "log(cover)", "sample") ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "minedno", "log(cover)", "sample") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "count", conditional = c("mined", "log(cover)", "sample") ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } } insight/tests/testthat/test-tobit.R0000644000176200001440000000660513552364343017161 0ustar liggesusersif (require("testthat") && require("insight") && require("AER")) { context("insight, AER") data("Affairs", package = "AER") m1 <- AER::tobit(affairs ~ age + yearsmarried + religiousness + occupation + rating, data = Affairs ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m1)$is_censored) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list( conditional = c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) )) expect_identical( find_predictors(m1, flatten = TRUE), c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "affairs") }) test_that("get_response", { expect_equal(get_response(m1), Affairs$affairs) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 601) expect_equal( colnames(get_data(m1)), c( "affairs", "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list( conditional = as.formula( "affairs ~ age + yearsmarried + religiousness + occupation + rating" ) ) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "affairs", conditional = c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) )) expect_equal( find_terms(m1, flatten = TRUE), c( "affairs", "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) }) test_that("n_obs", { expect_equal(n_obs(m1), 601) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) ) expect_equal(nrow(get_parameters(m1)), 6) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-coxme.R0000644000176200001440000001215513552364343017150 0ustar liggesusersif (require("testthat") && require("insight") && require("survival") && require("coxme")) { context("insight, model_info") data(lung) set.seed(1234) lung$inst2 <- sample(1:10, size = nrow(lung), replace = T) lung <- subset(lung, subset = ph.ecog %in% 0:2) lung$ph.ecog <- factor(lung$ph.ecog, labels = c("good", "ok", "limited")) m1 <- coxme(Surv(time, status) ~ ph.ecog + age + (1 | inst), lung) m2 <- coxme(Surv(time, status) ~ ph.ecog + age + (1 | inst) + (1 | inst2), lung) test_that("model_info", { expect_true(model_info(m1)$is_logit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("ph.ecog", "age"))) expect_identical( find_predictors(m1, effects = "random"), list(random = "inst") ) expect_identical(find_predictors(m2), list(conditional = c("ph.ecog", "age"))) expect_identical(find_predictors(m2, effects = "random"), list(random = c("inst", "inst2"))) }) test_that("find_response", { expect_identical(find_response(m1), "Surv(time, status)") expect_identical(find_response(m1, combine = FALSE), c("time", "status")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) expect_equal(link_inverse(m2)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 226) expect_equal( colnames(get_data(m1)), c( "time", "status", "Surv(time, status)", "ph.ecog", "age", "inst" ) ) expect_equal( colnames(get_data(m2)), c( "time", "status", "Surv(time, status)", "ph.ecog", "age", "inst", "inst2" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("Surv(time, status) ~ ph.ecog + age"), random = as.formula("~1 | inst") ) ) expect_length(find_formula(m2), 2) expect_equal( find_formula(m2), list( conditional = as.formula("Surv(time, status) ~ ph.ecog + age"), random = list(as.formula("~1 | inst"), as.formula("~1 | inst2")) ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "Surv(time, status)", conditional = c("ph.ecog", "age"), random = "inst" ) ) expect_equal( find_terms(m1, flatten = TRUE), c("Surv(time, status)", "ph.ecog", "age", "inst") ) expect_equal( find_terms(m2), list( response = "Surv(time, status)", conditional = c("ph.ecog", "age"), random = c("inst", "inst2") ) ) expect_equal( find_terms(m2, flatten = TRUE), c("Surv(time, status)", "ph.ecog", "age", "inst", "inst2") ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = c("time", "status"), conditional = c("ph.ecog", "age"), random = "inst" ) ) expect_equal( find_variables(m1, flatten = TRUE), c("time", "status", "ph.ecog", "age", "inst") ) expect_equal( find_variables(m2), list( response = c("time", "status"), conditional = c("ph.ecog", "age"), random = c("inst", "inst2") ) ) expect_equal( find_variables(m2, flatten = TRUE), c("time", "status", "ph.ecog", "age", "inst", "inst2") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 225) expect_equal(n_obs(m2), 225) }) test_that("get_response", { expect_equal(colnames(get_response(m1)), c("time", "status")) expect_equal(nrow(get_response(m1)), 226) expect_equal(colnames(get_response(m1)), c("time", "status")) expect_equal(nrow(get_response(m2)), 226) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("ph.ecogok", "ph.ecoglimited", "age"), random = "inst" ) ) expect_equal( find_parameters(m2), list( conditional = c("ph.ecogok", "ph.ecoglimited", "age"), random = c("inst", "inst2") ) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("ph.ecogok", "ph.ecoglimited", "age") ) expect_equal(nrow(get_parameters(m2)), 3) expect_equal( get_parameters(m2)$Parameter, c("ph.ecogok", "ph.ecoglimited", "age") ) expect_length(get_parameters(m2, effects = "random"), 2) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "z-statistic") }) } insight/tests/testthat/test-feis.R0000644000176200001440000000707513552364343016770 0ustar liggesusersif (require("testthat") && require("insight") && require("feisr")) { context("insight, feisr") data(mwp) m1 <- feis( lnw ~ marry + enrol + as.factor(yeargr) | exp + I(exp^2), data = mwp, id = "id", robust = TRUE ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list( conditional = c("marry", "enrol", "yeargr"), slopes = "exp" )) expect_identical(find_predictors(m1, effects = "random"), list(random = "id")) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("marry", "enrol", "yeargr", "exp", "id") ) }) test_that("find_random", { expect_identical(find_random(m1), list(random = "id")) }) test_that("get_random", { expect_identical(colnames(get_random(m1)), "id") }) test_that("find_response", { expect_identical(find_response(m1), "lnw") }) test_that("get_response", { expect_equal(get_response(m1), mwp$lnw) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c("marry", "enrol", "yeargr", "exp") ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 3100) expect_equal( colnames(get_data(m1)), c("lnw", "marry", "enrol", "yeargr", "exp", "id") ) }) test_that("find_formula", { expect_length(find_formula(m1), 3) expect_equal( find_formula(m1), list( conditional = as.formula("lnw ~ marry + enrol + as.factor(yeargr)"), slopes = as.formula("~exp + I(exp^2)"), random = as.formula("~id") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "lnw", conditional = c("marry", "enrol", "as.factor(yeargr)"), slopes = c("exp", "I(exp^2)"), random = "id" ) ) expect_equal( find_terms(m1, flatten = TRUE), c( "lnw", "marry", "enrol", "as.factor(yeargr)", "exp", "I(exp^2)", "id" ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "lnw", conditional = c("marry", "enrol", "yeargr"), slopes = "exp", random = "id" ) ) expect_equal( find_variables(m1, flatten = TRUE), c("lnw", "marry", "enrol", "yeargr", "exp", "id") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 3100) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "marry", "enrol", "as.factor(yeargr)2", "as.factor(yeargr)3", "as.factor(yeargr)4", "as.factor(yeargr)5" ) ) ) expect_equal(nrow(get_parameters(m1)), 6) expect_equal( get_parameters(m1)$Parameter, c( "marry", "enrol", "as.factor(yeargr)2", "as.factor(yeargr)3", "as.factor(yeargr)4", "as.factor(yeargr)5" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-glmrob_base.R0000644000176200001440000000636013552364343020312 0ustar liggesusersif (require("testthat") && require("insight") && require("robustbase")) { context("insight, model_info") data(carrots) m1 <- glmrob( cbind(success, total - success) ~ logdose + block, family = binomial, data = carrots, method = "Mqle", control = glmrobMqle.control(tcc = 1.2) ) test_that("model_info", { expect_true(model_info(m1)$is_binomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("logdose", "block"))) expect_identical(find_predictors(m1, flatten = TRUE), c("logdose", "block")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "cbind(success, total - success)") expect_identical(find_response(m1, combine = FALSE), c("success", "total")) }) test_that("get_response", { expect_equal(get_response(m1), carrots[, c("success", "total")]) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("logdose", "block")) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 24) expect_equal( colnames(get_data(m1)), c( "cbind(success, total - success)", "logdose", "block", "success", "total" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list( conditional = as.formula("cbind(success, total - success) ~ logdose + block") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "cbind(success, total - success)", conditional = c("logdose", "block") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("cbind(success, total - success)", "logdose", "block") ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = c("success", "total"), conditional = c("logdose", "block") )) expect_equal( find_variables(m1, flatten = TRUE), c("success", "total", "logdose", "block") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 24) }) test_that("link_function", { expect_equal(link_function(m1)(.2), qlogis(.2), tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "logdose", "blockB2", "blockB3") ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "logdose", "blockB2", "blockB3") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "Mqle")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-gee.R0000644000176200001440000000530413552364343016573 0ustar liggesusersif (require("testthat") && require("insight") && require("gee")) { context("insight, model_info") data(warpbreaks) m1 <- gee(breaks ~ tension, id = wool, data = warpbreaks) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = "tension")) expect_identical(find_predictors(m1, flatten = TRUE), "tension") expect_identical( find_predictors(m1, effects = "random"), list(random = "wool") ) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("tension", "wool") ) }) test_that("find_response", { expect_identical(find_response(m1), "breaks") }) test_that("get_response", { expect_equal(get_response(m1), warpbreaks$breaks) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "wool")) }) test_that("get_random", { expect_equal(get_random(m1), warpbreaks[, "wool", drop = FALSE]) }) test_that("get_predictors", { expect_equal(get_predictors(m1), warpbreaks[, "tension", drop = FALSE]) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 54) expect_equal(colnames(get_data(m1)), c("breaks", "tension", "wool")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("breaks ~ tension"), random = as.formula("~wool") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "breaks", conditional = "tension", random = "wool" ) ) expect_equal( find_terms(m1, flatten = TRUE), c("breaks", "tension", "wool") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 54) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c( "(Intercept)", "tensionM", "tensionH" )) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "tensionM", "tensionH") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-crch.R0000644000176200001440000000554313552364343016757 0ustar liggesusersif (require("testthat") && require("insight") && require("crch")) { context("insight, model_info") data("RainIbk") RainIbk$sqrtensmean <- apply(sqrt(RainIbk[, grep("^rainfc", names(RainIbk))]), 1, mean) RainIbk$sqrtenssd <- apply(sqrt(RainIbk[, grep("^rainfc", names(RainIbk))]), 1, sd) m1 <- crch(sqrt(rain) ~ sqrtensmean, data = RainIbk, dist = "gaussian") test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m1)$is_censored) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("sqrtensmean"))) expect_identical(find_predictors(m1, flatten = TRUE), c("sqrtensmean")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "rain") }) test_that("get_response", { expect_equal(get_response(m1), sqrt(RainIbk$rain)) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("sqrtensmean")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 4971) expect_equal(colnames(get_data(m1)), c("rain", "sqrtensmean")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("sqrt(rain) ~ sqrtensmean")) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "sqrt(rain)", conditional = c("sqrtensmean") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("sqrt(rain)", "sqrtensmean") ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "rain", conditional = c("sqrtensmean") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("rain", "sqrtensmean") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 4971) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "sqrtensmean", "(scale)_(Intercept)") ) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "sqrtensmean", "(scale)_(Intercept)") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-lm.R0000644000176200001440000001357713565540604016456 0ustar liggesusersif (require("testthat") && require("insight") && require("stats")) { context("insight, lm") data(iris) data(mtcars) m1 <- lm(Sepal.Length ~ Petal.Width + Species, data = iris) m2 <- lm(log(mpg) ~ log(hp) + cyl + I(cyl^2) + poly(wt, degree = 2, raw = TRUE), data = mtcars ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_false(model_info(m1)$is_bayesian) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Petal.Width", "Species"))) expect_identical( find_predictors(m1, flatten = TRUE), c("Petal.Width", "Species") ) expect_null(find_predictors(m1, effects = "random")) expect_identical(find_predictors(m2), list(conditional = c("hp", "cyl", "wt"))) expect_identical(find_predictors(m2, flatten = TRUE), c("hp", "cyl", "wt")) expect_null(find_predictors(m2, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "Sepal.Length") expect_identical(find_response(m2), "mpg") }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), .2) expect_identical(link_inverse(m2)(.2), .2) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 150) expect_equal( colnames(get_data(m1)), c("Sepal.Length", "Petal.Width", "Species") ) expect_equal(nrow(get_data(m2)), 32) expect_equal(colnames(get_data(m2)), c("mpg", "hp", "cyl", "wt")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("Sepal.Length ~ Petal.Width + Species")) ) expect_length(find_formula(m2), 1) expect_equal( find_formula(m2), list( conditional = as.formula( "log(mpg) ~ log(hp) + cyl + I(cyl^2) + poly(wt, degree = 2, raw = TRUE)" ) ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "Sepal.Length", conditional = c("Petal.Width", "Species") ) ) expect_equal( find_terms(m2), list( response = "log(mpg)", conditional = c( "log(hp)", "cyl", "I(cyl^2)", "poly(wt, degree = 2, raw = TRUE)" ) ) ) expect_equal( find_terms(m1, flatten = TRUE), c("Sepal.Length", "Petal.Width", "Species") ) expect_equal( find_terms(m2, flatten = TRUE), c( "log(mpg)", "log(hp)", "cyl", "I(cyl^2)", "poly(wt, degree = 2, raw = TRUE)" ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "Sepal.Length", conditional = c("Petal.Width", "Species") ) ) expect_equal(find_variables(m2), list( response = "mpg", conditional = c("hp", "cyl", "wt") )) expect_equal( find_variables(m1, flatten = TRUE), c("Sepal.Length", "Petal.Width", "Species") ) expect_equal( find_variables(m2, flatten = TRUE), c("mpg", "hp", "cyl", "wt") ) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "Petal.Width", "Speciesversicolor", "Speciesvirginica" ) ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "Petal.Width", "Speciesversicolor", "Speciesvirginica" ) ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "OLS")) }) test_that("get_variance", { expect_warning(expect_null(get_variance(m1))) expect_warning(expect_null(get_variance_dispersion(m1))) expect_warning(expect_null(get_variance_distribution(m1))) expect_warning(expect_null(get_variance_fixed(m1))) expect_warning(expect_null(get_variance_intercept(m1))) expect_warning(expect_null(get_variance_random(m1))) expect_warning(expect_null(get_variance_residual(m1))) }) test_that("is_model", { expect_true(is_model(m1)) }) test_that("all_models_equal", { expect_true(all_models_equal(m1, m2)) }) test_that("get_varcov", { expect_equal(diag(get_varcov(m1)), diag(vcov(m1))) }) test_that("get_statistic", { expect_equal(get_statistic(m1)$Statistic, c(57.5427, 4.7298, -0.2615, -0.1398), tolerance = 1e-3) }) test_that("find_statistic", { expect_equal(find_statistic(m1), "t-statistic") }) data("DNase") DNase1 <- subset(DNase, Run == 1) m3 <- stats::nls( density ~ stats::SSlogis(log(conc), Asym, xmid, scal), DNase1, start = list( Asym = 1, xmid = 1, scal = 1 ) ) ## Dobson (1990) Page 93: Randomized Controlled Trial : counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) outcome <- gl(3, 1, 9) treatment <- gl(3, 3) m4 <- glm(counts ~ outcome + treatment, family = poisson()) test_that("is_model", { expect_true(is_model(m3)) }) test_that("is_model", { expect_false(is_model_supported(m3)) }) test_that("all_models_equal", { expect_false(all_models_equal(m1, m2, m3)) expect_false(all_models_equal(m1, m2, m4)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") expect_identical(find_statistic(m3), "t-statistic") expect_identical(find_statistic(m4), "z-statistic") }) } insight/tests/testthat/test-is_nullmodel.R0000644000176200001440000000122513531007236020507 0ustar liggesusersif (require("testthat") && require("insight")) { context("insight, is_nullmodel") library(lme4) data(mtcars) data(sleepstudy) m1 <- lm(mpg ~ 1, data = mtcars) m2 <- lm(mpg ~ gear, data = mtcars) m3 <- lmer(Reaction ~ 1 + (Days | Subject), data = sleepstudy) m4 <- lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy) m5 <- suppressWarnings(lmer(Reaction ~ 0 + (Days | Subject), data = sleepstudy)) test_that("is_nullmodel", { expect_true(is_nullmodel(m1)) expect_false(is_nullmodel(m2)) expect_true(is_nullmodel(m3)) expect_false(is_nullmodel(m4)) expect_true(is_nullmodel(m5)) }) } insight/tests/testthat/test-namespace.R0000644000176200001440000000613613552364343017773 0ustar liggesusersif (require("testthat") && require("insight") && require("splines")) { context("insight, namespace, splines") data(iris) m1 <- lm(Sepal.Length ~ splines::bs(Petal.Width, df = 4) + Species, data = iris) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Petal.Width", "Species"))) expect_identical( find_predictors(m1, flatten = TRUE), c("Petal.Width", "Species") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("get_predictors", { expect_equal(get_predictors(m1), iris[, c("Petal.Width", "Species")]) }) test_that("find_response", { expect_identical(find_response(m1), "Sepal.Length") }) test_that("get_response", { expect_identical(get_response(m1), iris$Sepal.Length) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-4) }) test_that("link_function", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-4) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 150) expect_equal( colnames(get_data(m1)), c("Sepal.Length", "Species", "Petal.Width") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list( conditional = as.formula("Sepal.Length ~ splines::bs(Petal.Width, df = 4) + Species") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "Sepal.Length", conditional = c("Petal.Width", "Species") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("Sepal.Length", "Petal.Width", "Species") ) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "splines::bs(Petal.Width, df = 4)1", "splines::bs(Petal.Width, df = 4)2", "splines::bs(Petal.Width, df = 4)3", "splines::bs(Petal.Width, df = 4)4", "Speciesversicolor", "Speciesvirginica" ) ) ) }) test_that("get_parameters", { expect_equal(nrow(get_parameters(m1)), 7) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "splines::bs(Petal.Width, df = 4)1", "splines::bs(Petal.Width, df = 4)2", "splines::bs(Petal.Width, df = 4)3", "splines::bs(Petal.Width, df = 4)4", "Speciesversicolor", "Speciesvirginica" ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "OLS")) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "Sepal.Length", conditional = c("splines", "bs(Petal.Width, df = 4)", "Species") ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-lmrob_base.R0000644000176200001440000000456113552364343020144 0ustar liggesusersif (require("testthat") && require("insight") && require("robustbase")) { context("insight, model_info") data(mtcars) m1 <- lmrob(mpg ~ gear + wt + cyl, data = mtcars) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("gear", "wt", "cyl"))) expect_identical(find_predictors(m1, flatten = TRUE), c("gear", "wt", "cyl")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "mpg") }) test_that("get_response", { expect_equal(get_response(m1), mtcars$mpg) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("gear", "wt", "cyl")) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 32) expect_equal(colnames(get_data(m1)), c("mpg", "gear", "wt", "cyl")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("mpg ~ gear + wt + cyl")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "mpg", conditional = c("gear", "wt", "cyl") )) expect_equal(find_terms(m1, flatten = TRUE), c("mpg", "gear", "wt", "cyl")) }) test_that("n_obs", { expect_equal(n_obs(m1), 32) }) test_that("link_function", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c("(Intercept)", "gear", "wt", "cyl")) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "gear", "wt", "cyl") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "SM")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-vgam.R0000644000176200001440000001344013552364343016765 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest && Sys.getenv("USER") != "travis") { if (require("testthat") && require("insight") && require("VGAM")) { context("insight, model_info") data("hunua") m1 <- download_model("vgam_1") m2 <- download_model("vgam_2") test_that("model_info", { expect_true(model_info(m1)$is_binomial) expect_true(model_info(m2)$is_binomial) expect_false(model_info(m1)$is_bayesian) expect_false(model_info(m2)$is_bayesian) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("vitluc", "altitude"))) expect_identical( find_predictors(m1, flatten = TRUE), c("vitluc", "altitude") ) expect_null(find_predictors(m1, effects = "random")) expect_identical(find_predictors(m2), list(conditional = c("vitluc", "altitude"))) expect_identical( find_predictors(m2, flatten = TRUE), c("vitluc", "altitude") ) expect_null(find_predictors(m2, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) expect_null(find_random(m2)) }) test_that("get_random", { expect_warning(get_random(m1)) expect_warning(get_random(m2)) }) test_that("find_response", { expect_identical(find_response(m1), "agaaus") expect_identical(find_response(m2), "cbind(agaaus, kniexc)") expect_identical(find_response(m2, combine = FALSE), c("agaaus", "kniexc")) }) test_that("get_response", { expect_equal(get_response(m1), hunua$agaaus) expect_equal( get_response(m2), data.frame(agaaus = hunua$agaaus, kniexc = hunua$kniexc) ) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("vitluc", "altitude")) expect_equal(colnames(get_predictors(m2)), c("vitluc", "altitude")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) expect_equal(link_inverse(m2)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 392) expect_equal(nrow(get_data(m2)), 392) expect_equal(colnames(get_data(m1)), c("agaaus", "vitluc", "altitude")) expect_equal( colnames(get_data(m2)), c("agaaus", "kniexc", "vitluc", "altitude") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("agaaus ~ vitluc + s(altitude, df = 2)")) ) expect_length(find_formula(m2), 1) expect_equal( find_formula(m2), list( conditional = as.formula("cbind(agaaus, kniexc) ~ vitluc + s(altitude, df = c(2, 3))") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "agaaus", conditional = c("vitluc", "s(altitude, df = 2)") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("agaaus", "vitluc", "s(altitude, df = 2)") ) expect_equal( find_terms(m2), list( response = "cbind(agaaus, kniexc)", conditional = c("vitluc", "s(altitude, df = c(2, 3))") ) ) expect_equal( find_terms(m2, flatten = TRUE), c( "cbind(agaaus, kniexc)", "vitluc", "s(altitude, df = c(2, 3))" ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "agaaus", conditional = c("vitluc", "altitude") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("agaaus", "vitluc", "altitude") ) expect_equal(find_variables(m2), list( response = c("agaaus", "kniexc"), conditional = c("vitluc", "altitude") )) expect_equal( find_variables(m2, flatten = TRUE), c("agaaus", "kniexc", "vitluc", "altitude") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 392) expect_equal(n_obs(m2), 392) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "vitluc"), smooth_terms = "s(altitude, df = 2)" ) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "vitluc", "s(altitude, df = 2)") ) expect_equal( find_parameters(m2), list( conditional = c( "(Intercept):1", "(Intercept):2", "vitluc:1", "vitluc:2" ), smooth_terms = c("s(altitude, df = c(2, 3)):1", "s(altitude, df = c(2, 3)):2") ) ) expect_equal(nrow(get_parameters(m2)), 6) expect_equal( get_parameters(m2)$Parameter, c( "(Intercept):1", "(Intercept):2", "vitluc:1", "vitluc:2", "s(altitude, df = c(2, 3)):1", "s(altitude, df = c(2, 3)):2" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "chi-squared statistic") expect_identical(find_statistic(m2), "chi-squared statistic") }) } } insight/tests/testthat/test-rstanarm.R0000644000176200001440000002243413615512624017662 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { if (suppressWarnings(require("testthat") && require("insight") && require("BayesFactor") && require("rstanarm"))) { m1 <- insight::download_model("stanreg_merMod_5") m2 <- insight::download_model("stanreg_glm_6") m3 <- insight::download_model("stanreg_glm_1") data("puzzles") m4 <- stan_glm( RT ~ color * shape, data = puzzles, prior = rstanarm::cauchy(0, c(3, 1, 2)), iter = 500, chains = 2 ) m5 <- stan_glm( RT ~ color * shape, data = puzzles, prior = rstanarm::cauchy(0, c(1, 2, 3)), iter = 500, chains = 2 ) m6 <- insight::download_model("stanreg_gamm4_1") test_that("get_priors", { expect_equal( colnames(get_priors(m1)), c("Parameter", "Distribution", "Location", "Scale") ) expect_equal( colnames(get_priors(m2)), c( "Parameter", "Distribution", "Location", "Scale", "Adjusted_Scale" ) ) expect_equal(get_priors(m1)$Scale, c(10.0, 2.5, 2.5, 2.5, 2.5), tolerance = 1e-3 ) expect_equal( get_priors(m2)$Adjusted_Scale, c( 4.35866284936698, 1.08966571234175, 1.08966571234175, 0.617270040728345, 0.536028320794122, 0.411970489526739 ), tolerance = 1e-3 ) expect_equal(get_priors(m3)$Adjusted_Scale, c(NA, 2.555042), tolerance = 1e-3 ) expect_equal( get_priors(m4)$Adjusted_Scale, c( 25.5992021152256, 7.67976063456768, 2.55992021152256, 5.11984042304512 ), tolerance = 1e-3 ) expect_equal( get_priors(m5)$Adjusted_Scale, c( 25.5992021152256, 2.55992021152256, 5.11984042304512, 7.67976063456768 ), tolerance = 1e-3 ) expect_equal( get_priors(m6), data.frame( Parameter = "(Intercept)", Distribution = "normal", Location = 0, Scale = 10, Adjusted_Scale = 4.35866284936698, stringsAsFactors = FALSE, row.names = NULL ), tolerance = 1e-3 ) }) test_that("clean_names", { expect_identical( clean_names(m1), c("incidence", "size", "period", "herd") ) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("size", "period"))) expect_identical(find_predictors(m1, flatten = TRUE), c("size", "period")) expect_identical( find_predictors(m1, effects = "all", component = "all"), list( conditional = c("size", "period"), random = "herd" ) ) expect_identical( find_predictors( m1, effects = "all", component = "all", flatten = TRUE ), c("size", "period", "herd") ) }) test_that("find_response", { expect_equal( find_response(m1, combine = TRUE), "cbind(incidence, size - incidence)" ) expect_equal( find_response(m1, combine = FALSE), c("incidence", "size") ) }) test_that("get_response", { expect_equal(nrow(get_response(m1)), 56) expect_equal(colnames(get_response(m1)), c("incidence", "size")) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "herd")) }) test_that("get_random", { expect_equal(get_random(m1), lme4::cbpp[, "herd", drop = FALSE]) }) test_that("find_terms", { expect_identical( find_terms(m1), list( response = "cbind(incidence, size - incidence)", conditional = c("size", "period"), random = "herd" ) ) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = c("incidence", "size"), conditional = c("size", "period"), random = "herd" ) ) expect_identical( find_variables(m1, effects = "fixed"), list( response = c("incidence", "size"), conditional = c("size", "period") ) ) expect_null(find_variables(m1, component = "zi")) }) test_that("n_obs", { expect_equal(n_obs(m1), 56) }) test_that("find_paramaters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "size", "period2", "period3", "period4"), random = sprintf("b[(Intercept) herd:%i]", 1:15) ) ) expect_equal( find_parameters(m1, flatten = TRUE), c( "(Intercept)", "size", "period2", "period3", "period4", sprintf("b[(Intercept) herd:%i]", 1:15) ) ) }) test_that("find_paramaters", { expect_equal( colnames(get_parameters(m1)), c("(Intercept)", "size", "period2", "period3", "period4") ) expect_equal( colnames(get_parameters(m1, effects = "all")), c( "(Intercept)", "size", "period2", "period3", "period4", sprintf("b[(Intercept) herd:%i]", 1:15) ) ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-4) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 56) expect_equal( colnames(get_data(m1)), c("incidence", "size", "period", "herd") ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("cbind(incidence, size - incidence) ~ size + period"), random = as.formula("~1 | herd") ) ) }) test_that("get_variance", { expect_equal( get_variance(m1), list( var.fixed = 0.3710157, var.random = 0.6113405, var.residual = 3.289868, var.distribution = 3.289868, var.dispersion = 0, var.intercept = c(herd = 0.6113405) ), tolerance = 1e-4 ) expect_equal(get_variance_fixed(m1), c(var.fixed = 0.3710157), tolerance = 1e-4 ) expect_equal(get_variance_random(m1), c(var.random = 0.6113405), tolerance = 1e-4 ) expect_equal(get_variance_residual(m1), c(var.residual = 3.289868), tolerance = 1e-4 ) expect_equal(get_variance_distribution(m1), c(var.distribution = 3.289868), tolerance = 1e-4 ) expect_equal(get_variance_dispersion(m1), c(var.dispersion = 0), tolerance = 1e-4 ) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list( algorithm = "sampling", chains = 2, iterations = 500, warmup = 250 ) ) }) test_that("clean_parameters", { expect_equal( clean_parameters(m2), structure( list( Parameter = c( "(Intercept)", "Speciesversicolor", "Speciesvirginica", "Petal.Length", "Speciesversicolor:Petal.Length", "Speciesvirginica:Petal.Length" ), Effects = c( "fixed", "fixed", "fixed", "fixed", "fixed", "fixed" ), Component = c( "conditional", "conditional", "conditional", "conditional", "conditional", "conditional" ), Cleaned_Parameter = c( "(Intercept)", "Speciesversicolor", "Speciesvirginica", "Petal.Length", "Speciesversicolor:Petal.Length", "Speciesvirginica:Petal.Length" ) ), class = c("clean_parameters", "data.frame"), row.names = c(NA, -6L) ) ) }) test_that("find_statistic", { expect_null(find_statistic(m1)) expect_null(find_statistic(m2)) expect_null(find_statistic(m3)) expect_null(find_statistic(m4)) expect_null(find_statistic(m5)) expect_null(find_statistic(m6)) }) model <- stan_glm( disp ~ carb, data = mtcars, priors = NULL, prior_intercept = NULL ) test_that("flat_priors", { p <- get_priors(model) expect_equal(p$Distribution, c("uniform", "normal")) expect_equal(p$Location, c(NA, 0), tolerance = 1e-3) }) } } insight/tests/testthat/test-find_predictor_nested_re.R0000644000176200001440000000126213554405404023051 0ustar liggesusersif (require("testthat") && require("insight") && require("lme4")) { context("insight, find_predictors") set.seed(1984) dat <- data.frame( y = rnorm(1000 * 5, sd = 1 - .20), time = rep(1:10, 100 * 5), g1 = sort(rep(1:100, 10 * 5)), g2 = sort(rep(1:10, 100 * 5)) ) dat$g0 <- paste(dat$time, dat$g1) dat$time1 <- dat$time - 8 dat$post <- 0 dat$post[dat$time >= 8] <- 1 m <- lmer(y ~ post + time1 + (1 | g2 / g1 / g0) + (post + time1 - 1 | g2), data = dat) test_that("clean_names", { expect_equal( find_predictors(m, effects = "all"), list(conditional = c("post", "time1"), random = c("g0", "g1", "g2")) ) }) } insight/tests/testthat/test-clm.R0000644000176200001440000000504613552364343016611 0ustar liggesusersif (require("testthat") && require("insight") && require("ordinal")) { context("insight, model_info") data(wine, package = "ordinal") m1 <- clm(rating ~ temp * contact, data = wine) test_that("model_info", { expect_true(model_info(m1)$is_ordinal) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("temp", "contact"))) expect_identical(find_predictors(m1, flatten = TRUE), c("temp", "contact")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "rating") }) test_that("get_response", { expect_equal(get_response(m1), wine$rating) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("temp", "contact")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 72) expect_equal(colnames(get_data(m1)), c("rating", "temp", "contact")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("rating ~ temp * contact")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "rating", conditional = c("temp", "contact") )) expect_equal( find_terms(m1, flatten = TRUE), c("rating", "temp", "contact") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 72) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "1|2", "2|3", "3|4", "4|5", "tempwarm", "contactyes", "tempwarm:contactyes" ) ) ) expect_equal(nrow(get_parameters(m1)), 7) expect_equal( get_parameters(m1)$Parameter, c( "1|2", "2|3", "3|4", "4|5", "tempwarm", "contactyes", "tempwarm:contactyes" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-logistf.R0000644000176200001440000000546713552364343017514 0ustar liggesusersif (require("testthat") && require("insight") && require("logistf")) { context("insight, model_info") data(sex2) m1 <- logistf(case ~ age + oc + vic + vicl + vis + dia, data = sex2) test_that("model_info", { expect_true(model_info(m1)$is_binomial) expect_true(model_info(m1)$is_logit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c( "age", "oc", "vic", "vicl", "vis", "dia" ))) expect_identical( find_predictors(m1, flatten = TRUE), c("age", "oc", "vic", "vicl", "vis", "dia") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "case") }) test_that("get_response", { expect_equal(get_response(m1), sex2$case) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c("age", "oc", "vic", "vicl", "vis", "dia") ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 239) expect_equal( colnames(get_data(m1)), c("case", "age", "oc", "vic", "vicl", "vis", "dia") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("case ~ age + oc + vic + vicl + vis + dia")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "case", conditional = c("age", "oc", "vic", "vicl", "vis", "dia") )) expect_equal( find_terms(m1, flatten = TRUE), c("case", "age", "oc", "vic", "vicl", "vis", "dia") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 239) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("linkinverse", { expect_false(is.null(link_inverse(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "age", "oc", "vic", "vicl", "vis", "dia") ) ) expect_equal(nrow(get_parameters(m1)), 7) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "age", "oc", "vic", "vicl", "vis", "dia") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "Penalized ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "chi-squared statistic") }) } insight/tests/testthat/test-clm2.R0000644000176200001440000000577213552364343016701 0ustar liggesusersif (require("testthat") && require("insight") && require("ordinal") && require("MASS")) { context("insight, model_info") data(housing, package = "MASS") m1 <- clm2(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) test_that("model_info", { expect_true(model_info(m1)$is_ordinal) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Infl", "Type", "Cont"))) expect_identical( find_predictors(m1, flatten = TRUE), c("Infl", "Type", "Cont") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "Sat") }) test_that("get_response", { expect_equal(get_response(m1), housing$Sat) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("Infl", "Type", "Cont")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("find_weights", { expect_equal(find_weights(m1), "Freq") }) test_that("get_weights", { expect_equal(get_weights(m1), housing$Freq) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 72) expect_equal( colnames(get_data(m1)), c("Sat", "Infl", "Type", "Cont", "(weights)", "Freq") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("Sat ~ Infl + Type + Cont")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "Sat", conditional = c("Infl", "Type", "Cont") )) expect_equal( find_terms(m1, flatten = TRUE), c("Sat", "Infl", "Type", "Cont") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 1681) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("linkinv", { expect_false(is.null(link_inverse(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "Low|Medium", "Medium|High", "InflMedium", "InflHigh", "TypeApartment", "TypeAtrium", "TypeTerrace", "ContHigh" ) ) ) expect_equal(nrow(get_parameters(m1)), 8) expect_equal( get_parameters(m1)$Parameter, c( "Low|Medium", "Medium|High", "InflMedium", "InflHigh", "TypeApartment", "TypeAtrium", "TypeTerrace", "ContHigh" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-negbin.R0000644000176200001440000001014413552364343017273 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest && Sys.getenv("USER") != "travis") { if (require("testthat") && require("insight") && require("aod")) { context("insight, negbin") data(dja) m1 <- aod::negbin(y ~ group + offset(log(trisk)), random = ~village, data = dja ) test_that("model_info", { expect_true(model_info(m1)$is_negbin) expect_true(model_info(m1)$is_mixed) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("group", "trisk"))) expect_identical(find_predictors(m1, flatten = TRUE), c("group", "trisk")) expect_identical( find_predictors(m1, effects = "random"), list(random = "village") ) expect_identical( find_predictors(m1, effects = "all"), list( conditional = c("group", "trisk"), random = "village" ) ) }) test_that("find_random", { expect_identical(find_random(m1), list(random = "village")) }) test_that("get_random", { expect_equal(get_random(m1), dja[, "village", drop = FALSE]) }) test_that("find_response", { expect_identical(find_response(m1), "y") expect_identical(find_response(m1, combine = FALSE), "y") }) test_that("get_response", { expect_equal(get_response(m1), dja[, "y"]) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("group", "trisk")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("link_function", { expect_equal(link_function(m1)(.2), log(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 75) expect_equal(colnames(get_data(m1)), c("y", "group", "trisk", "village")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("y ~ group + offset(log(trisk))"), random = as.formula("~village") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "y", conditional = c("group", "trisk"), random = "village" ) ) expect_equal( find_variables(m1, flatten = TRUE), c("y", "group", "trisk", "village") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 75) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "groupTREAT"), random = c( "phi.villageBAK", "phi.villageBAM", "phi.villageBAN", "phi.villageBIJ", "phi.villageBOU", "phi.villageBYD", "phi.villageDEM", "phi.villageDIA", "phi.villageHAM", "phi.villageLAM", "phi.villageLAY", "phi.villageMAF", "phi.villageMAH", "phi.villageMAK", "phi.villageMED", "phi.villageNAB", "phi.villageSAG", "phi.villageSAM", "phi.villageSOU" ) ) ) expect_equal(nrow(get_parameters(m1)), 2) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "groupTREAT") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "y", conditional = c("group", "offset(log(trisk))"), random = "village" ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } } insight/tests/testthat/test-BayesFactorBF.R0000644000176200001440000001316413602213235020435 0ustar liggesusersif (require("testthat") && require("insight") && require("stats") && require("BayesFactor")) { context("BF correlation") x <- correlationBF(y = iris$Sepal.Length, x = iris$Sepal.Width) test_that("get_data", { expect_true(is.data.frame(get_data(x))) }) test_that("find_formula", { expect_null(find_formula(x)) }) test_that("get_parameters", { expect_equal(nrow(get_parameters(x)), 4000) }) # --------------------------- # context("BF t.test one sample") # data(sleep) # # x <- ttestBF(x = sleep$extra[sleep$group == 1], # y = sleep$extra[sleep$group == 2], # paired = TRUE) # # test_that("get_data", { # expect_true(is.data.frame(get_data(x))) # }) # test_that("find_formula", { # expect_null(find_formula(x)) # }) # test_that("get_parameters", { # expect_equal(nrow(get_parameters(x)), 4000) # }) # --------------------------- context("BF t.test two samples") data(chickwts) chickwts <- chickwts[chickwts$feed %in% c("horsebean", "linseed"), ] chickwts$feed <- factor(chickwts$feed) x <- ttestBF(formula = weight ~ feed, data = chickwts) test_that("get_data", { expect_true(is.data.frame(get_data(x))) }) test_that("find_formula", { expect_null(find_formula(x)) }) test_that("get_parameters", { expect_equal(nrow(get_parameters(x)), 4000) }) # --------------------------- context("BF t.test meta-analytic") t <- c(-.15, 2.39, 2.42, 2.43) N <- c(100, 150, 97, 99) x <- meta.ttestBF(t = t, n1 = N, rscale = 1) test_that("get_data", { expect_true(is.data.frame(get_data(x))) }) test_that("find_formula", { expect_null(find_formula(x)) }) test_that("get_parameters", { expect_equal(nrow(get_parameters(x)), 4000) }) # --------------------------- context("BF ANOVA") data(ToothGrowth) ToothGrowth$dose <- factor(ToothGrowth$dose) levels(ToothGrowth$dose) <- c("Low", "Medium", "High") x <- anovaBF(len ~ supp * dose, data = ToothGrowth) test_that("get_data", { expect_true(is.data.frame(get_data(x))) }) test_that("find_formula", { expect_equal(find_formula(x), list(conditional = as.formula("len ~ supp + dose + supp:dose"))) }) test_that("get_parameters", { expect_equal(colnames(get_parameters(x)), c("mu", "supp-OJ", "supp-VC", "sig2", "g_supp")) }) # --------------------------- context("BF ANOVA Random") data(puzzles) x <- anovaBF(RT ~ shape * color + ID, data = puzzles, whichRandom = "ID") test_that("get_data", { expect_true(is.data.frame(get_data(x))) }) test_that("find_formula", { expect_equal( find_formula(x), list( conditional = as.formula("RT ~ shape + color + shape:color"), random = as.formula("~ID") ) ) }) test_that("get_parameters", { expect_equal( colnames(get_parameters(x)), c( "mu", "shape-round", "shape-square", "ID-1", "ID-2", "ID-3", "ID-4", "ID-5", "ID-6", "ID-7", "ID-8", "ID-9", "ID-10", "ID-11", "ID-12", "sig2", "g_shape", "g_ID" ) ) }) test_that("find_response", { expect_equal(find_response(x), "RT") }) test_that("find_random", { expect_equal(find_random(x), list(random = "ID")) }) test_that("find_variables", { expect_equal( find_variables(x), list( response = "RT", conditional = c("shape", "color"), random = "ID" ) ) }) test_that("find_terms", { expect_equal( find_terms(x), list( response = "RT", conditional = c("shape", "color"), random = "ID" ) ) }) test_that("get_priors", { expect_equal( get_priors(x), data.frame( Parameter = c("fixed", "random", "continuous"), Distribution = c("cauchy", "cauchy", "cauchy"), Location = c(0, 0, 0), Scale = c(0.5, 1, 0.353553390593274), stringsAsFactors = FALSE, row.names = NULL ), tolerance = 1e-5 ) }) # --------------------------- context("BF lm") x <- lmBF(len ~ supp + dose, data = ToothGrowth) test_that("get_data", { expect_true(is.data.frame(get_data(x))) }) test_that("find_formula", { expect_equal(find_formula(x), list(conditional = as.formula("len ~ supp + dose"))) }) test_that("get_parameters", { expect_equal( colnames(get_parameters(x)), c( "mu", "supp-OJ", "supp-VC", "dose-Low", "dose-Medium", "dose-High", "sig2", "g_supp", "g_dose" ) ) }) x2 <- lmBF(len ~ supp + dose + supp:dose, data = ToothGrowth) x <- x / x2 test_that("get_data", { expect_true(is.data.frame(get_data(x))) }) test_that("find_formula", { expect_equal(find_formula(x), list(conditional = as.formula("len ~ supp + dose"))) }) test_that("get_parameters", { expect_equal( colnames(get_parameters(x)), c( "mu", "supp-OJ", "supp-VC", "dose-Low", "dose-Medium", "dose-High", "sig2", "g_supp", "g_dose" ) ) }) test_that("get_priors", { expect_equal( get_priors(x), data.frame( Parameter = c("fixed", "random", "continuous"), Distribution = c("cauchy", "cauchy", "cauchy"), Location = c(0, 0, 0), Scale = c(0.5, 1, 0.353553390593274), stringsAsFactors = FALSE, row.names = NULL ), tolerance = 1e-5 ) }) test_that("find_statistic", { expect_null(find_statistic(x)) }) } insight/tests/testthat/test-betabin.R0000644000176200001440000000712013552364343017435 0ustar liggesusersif (require("testthat") && require("insight") && require("aod")) { context("insight, betabin") data(dja) m1 <- betabin(cbind(y, n - y) ~ group * trisk, ~village, data = dja) test_that("model_info", { expect_true(model_info(m1)$is_binomial) expect_true(model_info(m1)$is_betabinomial) expect_true(model_info(m1)$is_mixed) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("group", "trisk"))) expect_identical(find_predictors(m1, flatten = TRUE), c("group", "trisk")) expect_identical(find_predictors(m1, effects = "random"), list(random = "village")) expect_identical( find_predictors(m1, effects = "all"), list( conditional = c("group", "trisk"), random = "village" ) ) }) test_that("find_random", { expect_identical(find_random(m1), list(random = "village")) }) test_that("get_random", { expect_equal(get_random(m1), dja[, "village", drop = FALSE]) }) test_that("find_response", { expect_identical(find_response(m1), "cbind(y, n - y)") expect_identical(find_response(m1, combine = FALSE), c("y", "n")) }) test_that("get_response", { expect_equal(get_response(m1), dja[, c("y", "n")]) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("group", "trisk")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("link_function", { expect_equal(link_function(m1)(.2), qlogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 75) expect_equal(colnames(get_data(m1)), c("y", "n", "group", "trisk", "village")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("cbind(y, n - y) ~ group * trisk"), random = as.formula("~village") ) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list(response = c("y", "n"), conditional = c("group", "trisk"), random = "village")) expect_equal(find_variables(m1, flatten = TRUE), c("y", "n", "group", "trisk", "village")) }) test_that("n_obs", { expect_equal(n_obs(m1), 75) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "groupTREAT", "trisk", "groupTREAT:trisk"), random = c( "phi.villageBAK", "phi.villageBAM", "phi.villageBAN", "phi.villageBIJ", "phi.villageBOU", "phi.villageBYD", "phi.villageDEM", "phi.villageDIA", "phi.villageHAM", "phi.villageLAM", "phi.villageLAY", "phi.villageMAF", "phi.villageMAH", "phi.villageMAK", "phi.villageMED", "phi.villageNAB", "phi.villageSAG", "phi.villageSAM", "phi.villageSOU" ) ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "groupTREAT", "trisk", "groupTREAT:trisk")) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "cbind(y, n - y)", conditional = c("group", "trisk"), random = "village" ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-BBreg.R0000644000176200001440000000573613552364343017025 0ustar liggesusersif (require("testthat") && require("insight") && require("HRQoL")) { context("insight, BBreg") set.seed(18) k <- 1000 m <- 10 x <- rnorm(k, 5, 3) x2 <- rnorm(k, 7, 3.5) j <- runif(k, 0, 5) fac <- sample(letters[1:4], k, TRUE) beta <- c(-10, 2) p <- 1 / (1 + exp(-(beta[1] + beta[2] * x))) phi <- 1.2 y <- HRQoL::rBB(k, m, p, phi) dat <- data.frame(y, x, x2, j, fac) m1 <- BBreg(y ~ x + x2 + j + fac, m, data = dat) test_that("model_info", { expect_true(model_info(m1)$is_binomial) expect_true(model_info(m1)$is_betabinomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("x", "x2", "j", "fac"))) expect_identical(find_predictors(m1, flatten = TRUE), c("x", "x2", "j", "fac")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "y") }) test_that("get_response", { expect_equal(get_response(m1), dat$y) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("x", "x2", "j", "fac")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("link_function", { expect_equal(link_function(m1)(.2), qlogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 1000) expect_equal(colnames(get_data(m1)), c("y", "x", "x2", "j", "fac")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("y ~ x + x2 + j + fac")) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = "y", conditional = c("x", "x2", "j", "fac") )) expect_equal( find_variables(m1, flatten = TRUE), c("y", "x", "x2", "j", "fac") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 1000) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("Intercept", "x", "x2", "j", "facb", "facc", "facd") ) ) expect_equal(nrow(get_parameters(m1)), 7) expect_equal( get_parameters(m1)$Parameter, c("Intercept", "x", "x2", "j", "facb", "facc", "facd") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "y", conditional = c("x", "x2", "j", "fac") ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-censReg.R0000644000176200001440000000744413552364343017430 0ustar liggesusersif (require("testthat") && require("insight") && require("censReg") && require("AER")) { context("insight, censReg") data("Affairs", package = "AER") m1 <- censReg(affairs ~ age + yearsmarried + religiousness + occupation + rating, data = Affairs ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m1)$is_censored) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list( conditional = c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) )) expect_identical( find_predictors(m1, flatten = TRUE), c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "affairs") }) test_that("get_response", { expect_equal(get_response(m1), Affairs$affairs) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 601) expect_equal( colnames(get_data(m1)), c( "affairs", "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list( conditional = as.formula( "affairs ~ age + yearsmarried + religiousness + occupation + rating" ) ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "affairs", conditional = c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) ) expect_equal( find_variables(m1, flatten = TRUE), c( "affairs", "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) }) test_that("n_obs", { expect_equal(n_obs(m1), 601) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "age", "yearsmarried", "religiousness", "occupation", "rating", "logSigma" ) ) ) expect_equal(nrow(get_parameters(m1)), 7) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "age", "yearsmarried", "religiousness", "occupation", "rating", "logSigma" ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "affairs", conditional = c( "age", "yearsmarried", "religiousness", "occupation", "rating" ) ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-gbm.R0000644000176200001440000000630213552364343016577 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { if (require("testthat") && require("insight") && require("gbm")) { context("insight, gbm") set.seed(102) # for reproducibility m1 <- gbm( mpg ~ gear + cyl + wt, data = mtcars, var.monotone = c(0, 0, 0), distribution = "gaussian", shrinkage = 0.1, interaction.depth = 1, bag.fraction = 0.5, train.fraction = 0.5, n.minobsinnode = 1, cv.folds = 3, keep.data = TRUE, verbose = FALSE, n.cores = 1 ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_false(model_info(m1)$is_binomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("gear", "cyl", "wt"))) expect_identical( find_predictors(m1, flatten = TRUE), c("gear", "cyl", "wt") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "mpg") }) test_that("get_response", { expect_equal(get_response(m1), mtcars$mpg) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("gear", "cyl", "wt")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 32) expect_equal(colnames(get_data(m1)), c("mpg", "gear", "cyl", "wt")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("mpg ~ gear + cyl + wt")) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "mpg", conditional = c("gear", "cyl", "wt") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("mpg", "gear", "cyl", "wt") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 32) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { skip_on_travis() expect_equal( find_parameters(m1), list(conditional = c("wt", "gear", "cyl")) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal(get_parameters(m1)$Parameter, c("wt", "gear", "cyl")) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "mpg", conditional = c("gear", "cyl", "wt") ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_warning(expect_null(find_algorithm(m1))) }) test_that("find_statistic", { expect_null(find_statistic(m1)) }) } } insight/tests/testthat/test-glmmTMB.R0000644000176200001440000005246313576214614017343 0ustar liggesusersif (require("testthat") && require("insight") && require("glmmTMB")) { context("insight, glmmTMB") # fish <- read.csv("https://stats.idre.ucla.edu/stat/data/fish.csv") # fish$nofish <- as.factor(fish$nofish) # fish$livebait <- as.factor(fish$livebait) # fish$camper <- as.factor(fish$camper) m1 <- download_model("glmmTMB_zi_1") m2 <- download_model("glmmTMB_1") m3 <- download_model("glmmTMB_zi_2") m4 <- download_model("glmmTMB_zi_5") m7 <- download_model("glmmTMB_zi_6") fish <- get_data(m7) data(Salamanders) m5 <- glmmTMB( count ~ mined + (1 | site), ziformula = ~mined, family = poisson, data = Salamanders ) m6 <- glmmTMB(count ~ 1, ziformula = ~1, family = poisson(), data = Salamanders ) test_that("find_weights", { expect_null(find_weights(m2)) }) test_that("get_weights", { expect_null(get_weights(m2)) }) test_that("model_info", { expect_true(model_info(m1)$is_zero_inflated) expect_false(model_info(m2)$is_zero_inflated) expect_true(model_info(m3)$is_count) expect_true(model_info(m3)$is_pois) expect_false(model_info(m3)$is_negbin) expect_true(model_info(m6)$is_count) }) test_that("clean_names", { expect_identical(clean_names(m1), c("count", "child", "camper", "persons")) expect_identical(clean_names(m2), c("count", "child", "camper", "persons")) expect_identical( clean_names(m3), c("count", "child", "camper", "persons", "livebait") ) expect_identical( clean_names(m4), c( "count", "child", "camper", "persons", "livebait", "ID", "xb" ) ) expect_identical(clean_names(m6), c("count")) }) test_that("find_predictors", { expect_identical( find_predictors(m1, effects = "all"), list( conditional = c("child", "camper"), random = "persons", zero_inflated = c("child", "camper"), zero_inflated_random = "persons" ) ) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("child", "camper", "persons") ) expect_identical( find_predictors(m1, effects = "random"), list(random = "persons", zero_inflated_random = "persons") ) expect_identical( find_predictors(m1, effects = "random", flatten = TRUE), "persons" ) expect_identical( find_predictors(m1, effects = "random", component = "conditional"), list(random = "persons") ) expect_identical( find_predictors( m1, effects = "random", component = "conditional", flatten = TRUE ), "persons" ) expect_identical( find_predictors(m1), list( conditional = c("child", "camper"), zero_inflated = c("child", "camper") ) ) expect_identical(find_predictors(m1, flatten = TRUE), c("child", "camper")) expect_identical( find_predictors(m2, effects = "all"), list( conditional = c("child", "camper"), random = "persons" ) ) expect_identical( find_predictors(m2, effects = "all", flatten = TRUE), c("child", "camper", "persons") ) expect_identical( find_predictors(m2, effects = "random"), list(random = "persons") ) expect_identical( find_predictors(m2, effects = "random", flatten = TRUE), "persons" ) expect_identical(find_predictors(m2), list(conditional = c("child", "camper"))) expect_null(find_predictors(m6)) }) test_that("find_response", { expect_identical(find_response(m1), "count") expect_identical(find_response(m2), "count") expect_identical(find_response(m6), "count") }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), exp(.2)) expect_identical(link_inverse(m2)(.2), exp(.2)) }) test_that("get_data", { expect_equal( colnames(get_data(m1)), c("count", "child", "camper", "persons") ) expect_equal( colnames(get_data(m1, effects = "all")), c("count", "child", "camper", "persons") ) expect_equal(colnames(get_data(m1, effects = "random")), "persons") expect_equal( colnames(get_data(m2)), c("count", "child", "camper", "persons") ) expect_equal( colnames(get_data(m2, effects = "all")), c("count", "child", "camper", "persons") ) expect_equal(colnames(get_data(m2, effects = "random")), "persons") get_data(m3) expect_equal(colnames(get_data(m6)), "count") expect_null(get_data(m6, effects = "random")) }) test_that("find_predictors", { expect_identical( find_predictors(m3, effects = "fixed", component = "conditional"), list(conditional = c("child", "camper")) ) expect_identical( find_predictors( m3, effects = "fixed", component = "conditional", flatten = TRUE ), c("child", "camper") ) expect_identical( find_predictors(m3, effects = "fixed", component = "zero_inflated"), list(zero_inflated = c("child", "livebait")) ) expect_identical( find_predictors( m3, effects = "fixed", component = "zero_inflated", flatten = TRUE ), c("child", "livebait") ) expect_identical( find_predictors(m3, effects = "all", component = "conditional"), list( conditional = c("child", "camper"), random = "persons" ) ) expect_identical( find_predictors( m3, effects = "all", component = "conditional", flatten = TRUE ), c("child", "camper", "persons") ) expect_identical( find_predictors(m3, effects = "all", component = "zero_inflated"), list( zero_inflated = c("child", "livebait"), zero_inflated_random = "persons" ) ) expect_identical( find_predictors( m3, effects = "all", component = "zero_inflated", flatten = TRUE ), c("child", "livebait", "persons") ) expect_identical( find_predictors(m3, effects = "random", component = "conditional"), list(random = "persons") ) expect_identical( find_predictors( m3, effects = "random", component = "conditional", flatten = TRUE ), "persons" ) expect_identical( find_predictors(m3, effects = "random", component = "zero_inflated"), list(zero_inflated_random = "persons") ) expect_identical( find_predictors( m3, effects = "random", component = "zero_inflated", flatten = TRUE ), "persons" ) expect_identical( find_predictors(m3, effects = "fixed", component = "all"), list( conditional = c("child", "camper"), zero_inflated = c("child", "livebait") ) ) expect_identical( find_predictors( m3, effects = "fixed", component = "all", flatten = TRUE ), c("child", "camper", "livebait") ) expect_identical( find_predictors(m3, effects = "all", component = "all"), list( conditional = c("child", "camper"), random = "persons", zero_inflated = c("child", "livebait"), zero_inflated_random = "persons" ) ) expect_identical( find_predictors( m3, effects = "all", component = "all", flatten = TRUE ), c("child", "camper", "persons", "livebait") ) expect_identical( find_predictors(m3, effects = "random", component = "all"), list(random = "persons", zero_inflated_random = "persons") ) expect_identical( find_predictors( m3, effects = "random", component = "all", flatten = TRUE ), "persons" ) expect_null(find_predictors( m6, effects = "random", component = "all", flatten = TRUE )) }) test_that("find_formula", { expect_length(find_formula(m4), 5) expect_equal( find_formula(m4), list( conditional = as.formula("count ~ child + camper"), random = as.formula("~1 | persons"), zero_inflated = as.formula("~child + livebait"), zero_inflated_random = as.formula("~1 | ID"), dispersion = as.formula("~xb") ) ) expect_equal(find_formula(m6), list(conditional = as.formula("count ~ 1"))) }) test_that("find_predictors", { expect_identical( find_predictors(m4), list( conditional = c("child", "camper"), zero_inflated = c("child", "livebait"), dispersion = "xb" ) ) expect_identical( find_predictors(m4, flatten = TRUE), c("child", "camper", "livebait", "xb") ) expect_identical( find_predictors(m4, effects = "random"), list(random = "persons", zero_inflated_random = "ID") ) expect_identical( find_predictors(m4, effects = "all", flatten = TRUE), c("child", "camper", "persons", "livebait", "ID", "xb") ) expect_identical( find_predictors(m4, effects = "all"), list( conditional = c("child", "camper"), random = "persons", zero_inflated = c("child", "livebait"), zero_inflated_random = "ID", dispersion = "xb" ) ) expect_identical( find_predictors(m4, component = "conditional", flatten = TRUE), c("child", "camper") ) expect_identical( find_predictors(m4, component = "conditional", flatten = FALSE), list(conditional = c("child", "camper")) ) expect_identical( find_predictors(m4, effects = "random", component = "conditional"), list(random = "persons") ) expect_identical( find_predictors(m4, effects = "all", component = "conditional"), list( conditional = c("child", "camper"), random = "persons" ) ) expect_identical( find_predictors(m4, component = "zero_inflated"), list(zero_inflated = c("child", "livebait")) ) expect_identical( find_predictors(m4, effects = "random", component = "zero_inflated"), list(zero_inflated_random = "ID") ) expect_identical( find_predictors( m4, effects = "all", component = "zero_inflated", flatten = TRUE ), c("child", "livebait", "ID") ) expect_identical( find_predictors(m4, component = "dispersion"), list(dispersion = "xb") ) expect_identical( find_predictors(m4, component = "dispersion", flatten = TRUE), "xb" ) expect_null(find_predictors(m4, effects = "random", component = "dispersion")) expect_identical( find_predictors(m4, effects = "all", component = "dispersion"), list(dispersion = "xb") ) expect_identical( find_predictors( m4, effects = "all", component = "dispersion", flatten = TRUE ), "xb" ) }) test_that("find_random", { expect_identical( find_random(m4), list(random = "persons", zero_inflated_random = "ID") ) expect_identical(find_random(m4, flatten = TRUE), c("persons", "ID")) expect_null(find_random(m6, flatten = TRUE)) }) test_that("find_respone", { expect_identical(find_response(m4), "count") expect_identical(find_response(m6), "count") }) test_that("find_terms", { expect_identical( find_terms(m4), list( response = "count", conditional = c("child", "camper"), random = "persons", zero_inflated = c("child", "livebait"), zero_inflated_random = "ID", dispersion = "xb" ) ) expect_identical( find_terms(m4, flatten = TRUE), c( "count", "child", "camper", "persons", "livebait", "ID", "xb" ) ) expect_identical(find_terms(m6), list(response = "count", conditional = "1")) expect_identical(find_terms(m6, flatten = TRUE), c("count", "1")) }) test_that("find_variables", { expect_identical( find_variables(m4), list( response = "count", conditional = c("child", "camper"), random = "persons", zero_inflated = c("child", "livebait"), zero_inflated_random = "ID", dispersion = "xb" ) ) expect_identical( find_variables(m4, flatten = TRUE), c( "count", "child", "camper", "persons", "livebait", "ID", "xb" ) ) expect_identical(find_variables(m6), list(response = "count")) expect_identical(find_variables(m6, flatten = TRUE), "count") }) test_that("get_response", { expect_identical(get_response(m4), fish$count) expect_identical(get_response(m6), Salamanders$count) }) test_that("get_predictors", { expect_identical( colnames(get_predictors(m4)), c("child", "camper", "livebait", "xb") ) expect_null(get_predictors(m6)) }) test_that("get_random", { expect_identical(colnames(get_random(m4)), c("persons", "ID")) expect_warning(expect_null(get_random(m6))) }) test_that("get_data", { expect_identical( colnames(get_data(m4)), c( "count", "child", "camper", "livebait", "xb", "persons", "ID" ) ) expect_identical( colnames(get_data(m4, effects = "fixed")), c("count", "child", "camper", "livebait", "xb") ) expect_identical(colnames(get_data(m4, effects = "random")), c("persons", "ID")) expect_identical(colnames(get_data(m4, component = "zi")), c("count", "child", "livebait", "ID")) expect_identical(colnames(get_data( m4, component = "zi", effects = "fixed" )), c("count", "child", "livebait")) expect_identical(colnames(get_data( m4, component = "zi", effects = "random" )), "ID") expect_identical( colnames(get_data(m4, component = "cond")), c("count", "child", "camper", "persons") ) expect_identical(colnames(get_data( m4, component = "cond", effects = "fixed" )), c("count", "child", "camper")) expect_identical(colnames(get_data( m4, component = "cond", effects = "random" )), "persons") expect_identical(colnames(get_data(m4, component = "disp")), c("count", "xb")) expect_identical(colnames(get_data( m4, component = "disp", effects = "fixed" )), c("count", "xb")) expect_null(get_data(m4, component = "disp", effects = "random")) }) test_that("find_paramaters", { expect_equal( find_parameters(m4), list( conditional = c("(Intercept)", "child", "camper1"), random = list(persons = "(Intercept)"), zero_inflated = c("(Intercept)", "child", "livebait1"), zero_inflated_random = list(ID = "(Intercept)") ) ) expect_equal( find_parameters(m4, flatten = TRUE), c("(Intercept)", "child", "camper1", "livebait1") ) expect_equal( find_parameters(m6), list( conditional = "(Intercept)", zero_inflated = "(Intercept)" ) ) expect_equal( find_parameters(m3), list( conditional = c("(Intercept)", "child", "camper1"), random = list(persons = "(Intercept)"), zero_inflated = c("(Intercept)", "child", "livebait1"), zero_inflated_random = list(persons = "(Intercept)") ) ) expect_equal( find_parameters(m3), list( conditional = c("(Intercept)", "child", "camper1"), random = list(persons = "(Intercept)"), zero_inflated = c("(Intercept)", "child", "livebait1"), zero_inflated_random = list(persons = "(Intercept)") ) ) expect_equal( find_parameters(m3, effects = "fixed"), list( conditional = c("(Intercept)", "child", "camper1"), zero_inflated = c("(Intercept)", "child", "livebait1") ) ) expect_equal( find_parameters(m3, effects = "random", component = "zi"), list(zero_inflated_random = list(persons = "(Intercept)")) ) expect_equal( find_parameters( m3, effects = "fixed", component = "zi", flatten = TRUE ), c("(Intercept)", "child", "livebait1") ) }) test_that("get_paramaters", { expect_equal(nrow(get_parameters(m4)), 6) expect_equal( colnames(get_parameters(m4)), c("Parameter", "Estimate", "Component") ) expect_equal( get_parameters(m4)$Parameter, c( "(Intercept)", "child", "camper1", "(Intercept)", "child", "livebait1" ) ) expect_equal( get_parameters(m4)$Component, c( "conditional", "conditional", "conditional", "zero_inflated", "zero_inflated", "zero_inflated" ) ) expect_equal( get_parameters(m6)$Parameter, c("(Intercept)", "(Intercept)") ) expect_equal( get_parameters(m2)$Parameter, c("(Intercept)", "child", "camper1") ) expect_equal( get_parameters(m2, component = "all")$Parameter, c("(Intercept)", "child", "camper1") ) expect_null(get_parameters(m2, component = "zi")) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) expect_false(is.null(link_function(m3))) expect_false(is.null(link_function(m4))) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) expect_false(is_multivariate(m3)) expect_false(is_multivariate(m4)) }) # test_that("get_variance", { # # expect_warning(expect_equal(get_variance(m5), list( # var.fixed = 0.32588694431268194762, # var.random = 0.07842738279575413307, # var.residual = 0.41218000030914692111, # var.distribution = 0.41218000030914692111, # var.dispersion = 0, # var.intercept = c(site = 0.07842738279575474369) # ), # tolerance = 1e-3)) # # expect_warning(expect_equal(get_variance_fixed(m1), c(var.fixed = 1.09712435712435052437), tolerance = 1e-3)) # expect_warning(expect_equal(get_variance_random(m1), c(var.random = 0.86712737445492238386), tolerance = 1e-3)) # expect_warning(expect_equal(get_variance_residual(m1), c(var.residual = 0.02634500773355940087 ), tolerance = 1e-3)) # expect_warning(expect_equal(get_variance_distribution(m1), c(var.distribution = 0.02634500773355940087 ), tolerance = 1e-3)) # expect_warning(expect_equal(get_variance_dispersion(m1), c(var.dispersion = 0), tolerance = 1e-3)) # }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "ML", optimizer = "nlminb") ) }) test_that("find_random_slopes", { skip_on_cran() skip_on_travis() expect_null(find_random_slopes(m6)) expect_equal( find_random_slopes(m7), list( random = "xb", zero_inflated_random = c("zg", "nofish") ) ) }) test_that("clean_parameters", { expect_equal( clean_parameters(m1), structure( list( Parameter = c( "(Intercept)", "child", "camper1", "(Intercept)", "(Intercept)", "child", "camper1", "(Intercept)" ), Effects = c( "fixed", "fixed", "fixed", "random", "fixed", "fixed", "fixed", "random" ), Component = c( "conditional", "conditional", "conditional", "conditional", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated" ), Group = c("", "", "", "persons", "", "", "", "persons"), Cleaned_Parameter = c( "(Intercept)", "child", "camper1", "(Intercept)", "(Intercept)", "child", "camper1", "(Intercept)" ) ), class = c("clean_parameters", "data.frame"), row.names = c(NA, -8L) ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "z-statistic") expect_identical(find_statistic(m3), "z-statistic") expect_identical(find_statistic(m4), "z-statistic") expect_identical(find_statistic(m5), "z-statistic") expect_identical(find_statistic(m6), "z-statistic") expect_identical(find_statistic(m7), "z-statistic") }) } insight/tests/testthat/test-all_models_equal.R0000644000176200001440000000125213524331052021321 0ustar liggesusersif (require("testthat") && require("insight")) { context("insight, all_models_equal") library(lme4) data(mtcars) data(sleepstudy) m1 <- lm(mpg ~ wt + cyl + vs, data = mtcars) m2 <- lm(mpg ~ wt + cyl, data = mtcars) m3 <- lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy) m4 <- glm(formula = vs ~ wt, family = binomial(), data = mtcars) test_that("all_models_equal", { expect_true(all_models_equal(m1, m2)) expect_false(all_models_equal(m1, m2, m3)) expect_message(expect_false(all_models_equal(m1, m4, m2, m3, verbose = TRUE))) expect_true(is_model_supported(m1)) expect_false(is_model_supported(mtcars)) }) } insight/tests/testthat/test-panelr.R0000644000176200001440000001371613556644712017327 0ustar liggesusersif (require("testthat") && require("insight") && require("panelr")) { context("insight, panelr") data("WageData") wages <- panel_data(WageData, id = id, wave = t) m1 <- wbm(lwage ~ lag(union) + wks | blk + fem | blk * lag(union), data = wages) m2 <- wbm(lwage ~ lag(union) + wks | blk + t | (t | id), data = wages) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m2)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( conditional = c("union", "wks"), instruments = c("blk", "fem"), interactions = c("blk", "union") ) ) expect_identical( find_predictors(m1, flatten = TRUE), c("union", "wks", "blk", "fem") ) expect_null(find_predictors(m1, effects = "random")) expect_identical( find_predictors(m2), list( conditional = c("union", "wks"), instruments = c("blk", "t") ) ) expect_identical(find_predictors(m2, effects = "random"), list(random = "id")) }) test_that("find_random", { expect_null(find_random(m1)) expect_identical(find_random(m2), list(random = "id")) }) test_that("get_random", { expect_null(expect_warning(get_random(m1))) expect_equal(get_random(m2)[[1]], model.frame(m2)$id) }) test_that("find_response", { expect_identical(find_response(m1), "lwage") }) test_that("get_response", { expect_equal(get_response(m1), model.frame(m1)$lwage) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c("lag(union)", "wks", "blk", "fem") ) expect_equal( colnames(get_predictors(m2)), c("lag(union)", "wks", "blk", "t") ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 3570) expect_equal( colnames(get_data(m1)), c( "lwage", "id", "t", "lag(union)", "wks", "blk", "fem", "imean(lag(union))", "imean(wks)", "lag(union)*blk", "imean(lag(union):blk)", "lag(union):blk" ) ) expect_equal( colnames(get_data(m2)), c( "lwage", "id", "t", "lag(union)", "wks", "blk", "imean(lag(union))", "imean(wks)" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 3) expect_equal( find_formula(m1), list( conditional = as.formula("lwage ~ lag(union) + wks"), instruments = as.formula("~blk + fem"), interactions = as.formula("~blk * lag(union)") ) ) expect_equal( find_formula(m2), list( conditional = as.formula("lwage ~ lag(union) + wks"), instruments = as.formula("~blk + t"), random = as.formula("~t | id") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "lwage", conditional = c("union", "wks"), instruments = c("blk", "fem"), interactions = c("blk", "union") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("lwage", "union", "wks", "blk", "fem") ) expect_equal( find_variables(m2), list( response = "lwage", conditional = c("union", "wks"), instruments = c("blk", "t"), random = "id" ) ) expect_equal( find_variables(m2, flatten = TRUE), c("lwage", "union", "wks", "blk", "t", "id") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 3570) expect_equal(n_obs(m2), 3570) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("lag(union)", "wks"), instruments = c("(Intercept)", "imean(lag(union))", "imean(wks)", "blk", "fem"), random = "lag(union):blk" ) ) expect_equal(nrow(get_parameters(m1)), 8) expect_equal( find_parameters(m2), list( conditional = c("lag(union)", "wks"), instruments = c("(Intercept)", "imean(lag(union))", "imean(wks)", "blk", "t") ) ) }) test_that("get_parameters", { expect_equal( get_parameters(m1), data.frame( Parameter = c( "lag(union)", "wks", "(Intercept)", "imean(lag(union))", "imean(wks)", "blk", "fem", "lag(union):blk" ), Estimate = c( 0.0582474262882615, -0.00163678667081885, 6.59813245629044, -0.0279959204722801, 0.00438047648390025, -0.229414915661438, -0.441756913071962, -0.127319623945541 ), Component = c( "within", "within", "between", "between", "between", "between", "between", "interactions" ), stringsAsFactors = FALSE ), tolerance = 1e-4 ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "lwage", conditional = c("lag(union)", "wks"), instruments = c("blk", "fem"), interactions = c("blk", "lag(union)") ) ) expect_equal( find_terms(m2), list( response = "lwage", conditional = c("lag(union)", "wks"), instruments = c("blk", "t"), random = c("t", "id") ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") }) } insight/tests/testthat/test-survey.R0000644000176200001440000000414613552364343017373 0ustar liggesusersif (require("testthat") && require("insight") && require("survey")) { context("insight, svyglm") data(api) dstrat <- svydesign( id = ~1, strata = ~stype, weights = ~pw, data = apistrat, fpc = ~fpc ) m1 <- svyglm(api00 ~ ell + meals + mobility, design = dstrat) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("ell", "meals", "mobility"))) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "api00") }) test_that("get_response", { expect_equal(get_response(m1), apistrat$api00) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 200) expect_equal( colnames(get_data(m1)), c("api00", "ell", "meals", "mobility", "(weights)") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("api00 ~ ell + meals + mobility")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "api00", conditional = c("ell", "meals", "mobility") )) expect_equal( find_terms(m1, flatten = TRUE), c("api00", "ell", "meals", "mobility") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 200) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c( "(Intercept)", "ell", "meals", "mobility" )) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "ell", "meals", "mobility") ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-rqss.R0000644000176200001440000000437213602457455017032 0ustar liggesusersif (require("testthat") && require("insight") && require("quantreg") && require("tripack")) { context("insight, model_info") data("CobarOre") set.seed(123) CobarOre$w <- rnorm(nrow(CobarOre)) # model m1 <- rqss(z ~ w + qss(cbind(x, y), lambda = .08), data = CobarOre) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list(conditional = c("w", "x", "y")) ) expect_identical( find_predictors(m1, flatten = TRUE), c("w", "x", "y") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "z") }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("z ~ w + qss(cbind(x, y), lambda = 0.08)")) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list(response = "z", conditional = c("w", "qss(cbind(x, y), lambda = 0.08)")) ) expect_equal( find_terms(m1, flatten = TRUE), c("z", "w", "qss(cbind(x, y), lambda = 0.08)") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 38) }) test_that("link_function", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c("(Intercept)", "w"), smooth_terms = "cbind(x, y)") ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "w", "cbind(x, y)") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "sfn")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-speedglm.R0000644000176200001440000000605513552364343017637 0ustar liggesusersif (require("testthat") && require("insight") && require("speedglm") && require("glmmTMB")) { context("insight, model_info") data(Salamanders) Salamanders$cover <- abs(Salamanders$cover) m1 <- speedglm(count ~ mined + log(cover) + sample, family = poisson(), data = Salamanders ) test_that("model_info", { expect_true(model_info(m1)$is_poisson) expect_true(model_info(m1)$is_count) expect_false(model_info(m1)$is_negbin) expect_false(model_info(m1)$is_binomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("mined", "cover", "sample"))) expect_identical( find_predictors(m1, flatten = TRUE), c("mined", "cover", "sample") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "count") }) test_that("get_response", { expect_equal(get_response(m1), Salamanders$count) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("mined", "cover", "sample")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("linkfun", { expect_equal(link_function(m1)(.2), log(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 644) expect_equal( colnames(get_data(m1)), c("count", "mined", "cover", "sample") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("count ~ mined + log(cover) + sample")) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "count", conditional = c("mined", "cover", "sample") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("count", "mined", "cover", "sample") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 644) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "minedno", "log(cover)", "sample") ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "minedno", "log(cover)", "sample") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "count", conditional = c("mined", "log(cover)", "sample") ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "eigen")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-nlmer.R0000644000176200001440000000062713602213235017140 0ustar liggesusersif (require("testthat") && require("insight") && require("lme4")) { set.seed(123) startvec <- c(Asym = 200, xmid = 725, scal = 350) nm1 <- lme4::nlmer( formula = circumference ~ SSlogis(age, Asym, xmid, scal) ~ Asym | Tree, data = Orange, start = startvec ) test_that("find_statistic", { expect_identical(find_statistic(nm1), "t-statistic") }) } insight/tests/testthat/test-survfit.R0000644000176200001440000000364213572501701017531 0ustar liggesusersif (require("testthat") && require("insight") && require("survival")) { data("lung") m1 <- survfit(Surv(time, status) ~ sex + age + ph.ecog, data = lung) test_that("model_info", { expect_true(model_info(m1)$is_logit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("sex", "age", "ph.ecog"))) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "Surv(time, status)") expect_identical(find_response(m1, combine = FALSE), c("time", "status")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 227) expect_equal( colnames(get_data(m1)), c("time", "status", "age", "sex", "ph.ecog") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula( "Surv(time, status) ~ sex + age + ph.ecog" )) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = c("time", "status"), conditional = c("sex", "age", "ph.ecog") )) expect_equal( find_variables(m1, flatten = TRUE), c("time", "status", "sex", "age", "ph.ecog") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 227) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "Surv(time, status)", conditional = c("sex", "age", "ph.ecog") ) ) }) test_that("find_statistic", { expect_null(find_statistic(m1)) }) } insight/tests/testthat/test-aovlist.R0000644000176200001440000000761213552364343017520 0ustar liggesusersif (require("testthat") && require("insight") && require("stats")) { context("insight, aovlist") data(npk) m1 <- aov(yield ~ N * P * K + Error(block), data = npk) m2 <- aov(yield ~ N * P * K, data = npk) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m1)$is_anova) expect_true(model_info(m2)$is_linear) expect_true(model_info(m2)$is_anova) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("N", "P", "K", "block"))) expect_identical(find_predictors(m2), list(conditional = c("N", "P", "K"))) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "yield") expect_identical(find_response(m2), "yield") }) test_that("get_response", { expect_equal(get_response(m1), npk$yield) expect_equal(get_response(m2), npk$yield) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("N", "P", "K", "block")) expect_equal(colnames(get_predictors(m2)), c("N", "P", "K")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) expect_equal(link_inverse(m2)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 24) expect_equal(nrow(get_data(m2)), 24) expect_equal(colnames(get_data(m1)), c("yield", "N", "P", "K", "block")) expect_equal(colnames(get_data(m2)), c("yield", "N", "P", "K")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("yield ~ N * P * K + Error(block)")) ) expect_length(find_formula(m2), 1) expect_equal( find_formula(m2), list(conditional = as.formula("yield ~ N * P * K")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "yield", conditional = c("N", "P", "K", "Error(block)") )) expect_equal( find_terms(m1, flatten = TRUE), c("yield", "N", "P", "K", "Error(block)") ) expect_equal(find_terms(m2), list( response = "yield", conditional = c("N", "P", "K") )) expect_equal(find_terms(m2, flatten = TRUE), c("yield", "N", "P", "K")) }) test_that("n_obs", { expect_equal(n_obs(m1), 24) expect_equal(n_obs(m2), 24) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "N1:P1:K1"), random = c("N1", "P1", "K1", "N1:P1", "N1:K1", "P1:K1") ) ) expect_equal(length(get_parameters(m1)), 2) expect_equal(nrow(get_parameters(m1, effects = "all")), 8) expect_equal( get_parameters(m1, effects = "all")$Effects, c( "fixed", "fixed", "random", "random", "random", "random", "random", "random" ) ) expect_equal( find_parameters(m2), list( conditional = c( "(Intercept)", "N1", "P1", "K1", "N1:P1", "N1:K1", "P1:K1", "N1:P1:K1" ) ) ) expect_equal(nrow(get_parameters(m2)), 8) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "F-statistic") expect_identical(find_statistic(m2), "F-statistic") }) } insight/tests/testthat/test-felm.R0000644000176200001440000000760513554512447016766 0ustar liggesusersif (require("testthat") && require("insight") && require("lfe")) { context("insight, lfe") x <- rnorm(1000) x2 <- rnorm(length(x)) id <- factor(sample(20, length(x), replace = TRUE)) firm <- factor(sample(13, length(x), replace = TRUE)) id.eff <- rnorm(nlevels(id)) firm.eff <- rnorm(nlevels(firm)) u <- rnorm(length(x)) y <- x + 0.5 * x2 + id.eff[id] + firm.eff[firm] + u x3 <- rnorm(length(x)) x4 <- sample(12, length(x), replace = TRUE) Q <- 0.3 * x3 + x + 0.2 * x2 + id.eff[id] + 0.3 * log(x4) - 0.3 * y + rnorm(length(x), sd = 0.3) W <- 0.7 * x3 - 2 * x + 0.1 * x2 - 0.7 * id.eff[id] + 0.8 * cos(x4) - 0.2 * y + rnorm(length(x), sd = 0.6) # add them to the outcome y <- y + Q + W dat <- data.frame(y, x, x2, x3, x4, id, firm, Q, W) m1 <- felm(y ~ x + x2 | id + firm | (Q | W ~ x3 + factor(x4)), data = dat) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( conditional = c("x", "x2"), instruments = c("Q", "W", "x3", "x4") ) ) expect_identical(find_predictors(m1, effects = "random"), list(random = c("id", "firm"))) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("x", "x2", "id", "firm", "Q", "W", "x3", "x4") ) }) test_that("find_random", { expect_identical(find_random(m1), list(random = c("id", "firm"))) }) test_that("get_random", { expect_identical(colnames(get_random(m1)), c("id", "firm")) }) test_that("find_response", { expect_identical(find_response(m1), "y") }) test_that("get_response", { expect_equal(get_response(m1), dat$y) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c("x", "x2", "Q", "W", "x3", "x4") ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 1000) expect_equal( colnames(get_data(m1)), c("y", "x", "x2", "id", "firm", "Q", "W", "x3", "x4") ) }) test_that("find_formula", { expect_length(find_formula(m1), 3) expect_equal( find_formula(m1), list( conditional = as.formula("y ~ x + x2"), random = as.formula("~id + firm"), instruments = as.formula("~(Q | W ~ x3 + factor(x4))") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "y", conditional = c("x", "x2"), random = c("id", "firm"), instruments = c("(Q", "W x3", "factor(x4))") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("y", "x", "x2", "id", "firm", "(Q", "W x3", "factor(x4))") ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "y", conditional = c("x", "x2"), random = c("id", "firm"), instruments = c("Q", "W", "x3", "x4") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("y", "x", "x2", "id", "firm", "Q", "W", "x3", "x4") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 1000) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c("x", "x2", "Q(fit)", "W(fit)")) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("x", "x2", "Q(fit)", "W(fit)") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-spatial.R0000644000176200001440000000746613554405404017477 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { if (require("testthat") && require("insight") && require("glmmTMB")) { context("insight, glmmTMB") m1 <- download_model("glmmTMB_spatial_1") test_that("find_weights", { expect_null(find_weights(m1)) }) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("clean_names", { expect_identical(clean_names(m1), c("calcium", "elevation", "region", "pos", "ID")) }) test_that("find_predictors", { expect_identical( find_predictors(m1, effects = "all"), list(conditional = c("elevation", "region"), random = c("pos", "ID")) ) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("elevation", "region", "pos", "ID") ) expect_identical( find_predictors(m1, effects = "random"), list(random = "ID") ) expect_identical(find_predictors(m1, effects = "random", flatten = TRUE), "ID") }) test_that("find_response", { expect_identical(find_response(m1), "calcium") }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), .2) }) test_that("get_data", { expect_equal( colnames(get_data(m1)), c("calcium", "elevation", "region", "pos", "ID") ) expect_equal( colnames(get_data(m1, effects = "all")), c("calcium", "elevation", "region", "pos", "ID") ) }) test_that("find_predictors", { expect_identical( find_predictors(m1, effects = "fixed", component = "conditional"), list(conditional = c("elevation", "region")) ) expect_identical( find_predictors(m1), list(conditional = c("elevation", "region")) ) expect_identical( find_predictors(m1, effects = "all"), list( conditional = c("elevation", "region"), random = c("pos", "ID") ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("calcium ~ elevation + region"), random = as.formula("~pos + 0 | ID") ) ) }) test_that("find_random", { expect_identical( find_random(m1), list(random = "ID") ) }) test_that("find_terms", { expect_identical( find_terms(m1), list( response = "calcium", conditional = c("elevation", "region"), random = c("pos", "ID") ) ) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = "calcium", conditional = c("elevation", "region"), random = c("pos", "ID") ) ) }) test_that("get_predictors", { expect_identical( colnames(get_predictors(m1)), c("elevation", "region") ) }) test_that("get_random", { expect_identical(colnames(get_random(m1)), c("pos", "ID")) }) test_that("get_data", { expect_identical( colnames(get_data(m1)), c("calcium", "elevation", "region", "pos", "ID") ) }) test_that("get_paramaters", { expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "elevation", "region2", "region3") ) }) test_that("find_random_slopes", { skip_on_cran() skip_on_travis() expect_equal( find_random_slopes(m1), list(random = "pos") ) }) } } insight/tests/testthat/test-betareg.R0000644000176200001440000000643613613304321017437 0ustar liggesusersif (require("testthat") && require("insight") && require("betareg")) { data("GasolineYield") data("FoodExpenditure") m1 <- betareg(yield ~ batch + temp, data = GasolineYield) m2 <- betareg(I(food / income) ~ income + persons, data = FoodExpenditure) test_that("model_info", { expect_true(model_info(m1)$is_beta) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("batch", "temp"))) expect_identical(find_predictors(m1, flatten = TRUE), c("batch", "temp")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "yield") expect_identical(find_response(m2), "I(food/income)") expect_identical(find_response(m2, combine = FALSE), c("food", "income")) }) test_that("get_response", { expect_equal(get_response(m1), GasolineYield$yield) expect_equal(get_response(m2), FoodExpenditure[, c("food", "income")]) }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), plogis(.2)) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 32) expect_equal(colnames(get_data(m1)), c("yield", "batch", "temp")) expect_equal(nrow(get_data(m2)), 38) expect_equal( colnames(get_data(m2)), c("I(food/income)", "income", "persons", "food", "income.1") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("yield ~ batch + temp")) ) expect_equal( find_formula(m2), list(conditional = as.formula("I(food/income) ~ income + persons")) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "yield", conditional = c("batch", "temp") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("yield", "batch", "temp") ) expect_equal( find_variables(m2, flatten = TRUE), c("food", "income", "persons") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 32) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "batch1", "batch2", "batch3", "batch4", "batch5", "batch6", "batch7", "batch8", "batch9", "temp"), precision = "(phi)" ) ) expect_equal(nrow(get_parameters(m1)), 12) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "batch1", "batch2", "batch3", "batch4", "batch5", "batch6", "batch7", "batch8", "batch9", "temp", "(phi)" ) ) }) test_that("find_terms", { expect_equal( find_terms(m2), list( response = "I(food/income)", conditional = c("income", "persons") ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "z-statistic") }) } insight/tests/testthat/test-coxph.R0000644000176200001440000000512413552364343017154 0ustar liggesusersif (require("testthat") && require("insight") && require("survival")) { context("insight, coxph") data("lung") lung <- subset(lung, subset = ph.ecog %in% 0:2) lung$sex <- factor(lung$sex, labels = c("male", "female")) lung$ph.ecog <- factor(lung$ph.ecog, labels = c("good", "ok", "limited")) m1 <- coxph(Surv(time, status) ~ sex + age + ph.ecog, data = lung) test_that("model_info", { expect_true(model_info(m1)$is_logit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("sex", "age", "ph.ecog"))) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "Surv(time, status)") expect_identical(find_response(m1, combine = FALSE), c("time", "status")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 226) expect_equal( colnames(get_data(m1)), c( "time", "status", "Surv(time, status)", "sex", "age", "ph.ecog" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula( "Surv(time, status) ~ sex + age + ph.ecog" )) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = c("time", "status"), conditional = c("sex", "age", "ph.ecog") )) expect_equal( find_variables(m1, flatten = TRUE), c("time", "status", "sex", "age", "ph.ecog") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 226) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("sexfemale", "age", "ph.ecogok", "ph.ecoglimited") ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("sexfemale", "age", "ph.ecogok", "ph.ecoglimited") ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "Surv(time, status)", conditional = c("sex", "age", "ph.ecog") ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-gamm4.R0000644000176200001440000000545213567303210017034 0ustar liggesusersunloadNamespace("gam") if (require("testthat") && require("insight") && require("gamm4")) { set.seed(0) dat <- gamSim(1, n = 400, scale = 2) ## simulate 4 term additive truth dat$fac <- fac <- as.factor(sample(1:20, 400, replace = TRUE)) dat$y <- dat$y + model.matrix(~ fac - 1) %*% rnorm(20) * .5 m1 <- gamm4(y ~ s(x0) + x1 + s(x2), data = dat, random = ~ (1 | fac) ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("clean_names", { expect_equal(clean_names(m1), c("y", "x0", "x1", "x2")) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("x0", "x1", "x2"))) expect_identical(find_predictors(m1, flatten = TRUE), c("x0", "x1", "x2")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "y") }) test_that("get_response", { expect_equal(get_response(m1), unname(dat$y[, 1])) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 400) expect_equal( colnames(get_data(m1)), c( "y", "x1", "x0", "x2", "fac", "y.0", "Xr", "Xr.0", "X.(Intercept)", "X.x1", "X.s(x0)Fx1", "X.s(x2)Fx1" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("y ~ s(x0) + x1 + s(x2)")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "y", conditional = c("s(x0)", "x1", "s(x2)") )) expect_equal( find_terms(m1, flatten = TRUE), c("y", "s(x0)", "x1", "s(x2)") ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = "y", conditional = c("x0", "x1", "x2") )) expect_equal(find_variables(m1, flatten = TRUE), c("y", "x0", "x1", "x2")) }) test_that("n_obs", { expect_equal(n_obs(m1), 400) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "x1"), smooth_terms = c("s(x0)", "s(x2)") ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "x1", "s(x0)", "s(x2)") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_error(find_statistic(m1)) }) } insight/tests/testthat/test-polr.R0000644000176200001440000000537513552364343017017 0ustar liggesusersif (require("testthat") && require("insight") && require("MASS")) { context("insight, polr") data(housing, package = "MASS") m1 <- polr(Sat ~ Infl + Type + Cont, data = housing, weights = Freq) test_that("model_info", { expect_true(model_info(m1)$is_ordinal) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Infl", "Type", "Cont"))) expect_identical( find_predictors(m1, flatten = TRUE), c("Infl", "Type", "Cont") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "Sat") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 72) expect_equal( colnames(get_data(m1)), c("Sat", "Infl", "Type", "Cont", "(weights)", "Freq") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("Sat ~ Infl + Type + Cont")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "Sat", conditional = c("Infl", "Type", "Cont") )) expect_equal( find_terms(m1, flatten = TRUE), c("Sat", "Infl", "Type", "Cont") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 1681) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "Intercept: Low|Medium", "Intercept: Medium|High", "InflMedium", "InflHigh", "TypeApartment", "TypeAtrium", "TypeTerrace", "ContHigh" ) ) ) }) test_that("get_parameters", { expect_equal( get_parameters(m1), data.frame( Parameter = c( "Intercept: Low|Medium", "Intercept: Medium|High", "InflMedium", "InflHigh", "TypeApartment", "TypeAtrium", "TypeTerrace", "ContHigh" ), Estimate = c( -0.4961353438375, 0.690708290379271, 0.566393738890106, 1.28881906381232, -0.572350146429611, -0.366186566153346, -1.09101490767244, 0.360284149947385 ), stringsAsFactors = FALSE, row.names = NULL ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-response_data2.R0000644000176200001440000000670213531007237020740 0ustar liggesusersif (suppressWarnings(require("testthat") && require("insight") && require("lme4"))) { context("insight, find_response") data(cbpp) cbpp$trials <- cbpp$size - cbpp$incidence m1 <- glmer(cbind(incidence, trials) ~ period + (1 | herd), data = cbpp, family = binomial ) m2 <- glmer( cbind(incidence, size - incidence) ~ period + (1 | herd), data = cbpp, family = binomial ) m3 <- glm(cbind(incidence, trials) ~ period, data = cbpp, family = binomial ) m4 <- glm(cbind(incidence, size - incidence) ~ period, data = cbpp, family = binomial ) m5 <- glmer(cbind(incidence, size - incidence) ~ (1 | herd), data = cbpp, family = binomial ) test_that("find_response", { expect_equal( find_response(m1, combine = TRUE), "cbind(incidence, trials)" ) expect_equal( find_response(m2, combine = TRUE), "cbind(incidence, size - incidence)" ) expect_equal( find_response(m3, combine = TRUE), "cbind(incidence, trials)" ) expect_equal( find_response(m4, combine = TRUE), "cbind(incidence, size - incidence)" ) expect_equal( find_response(m5, combine = TRUE), "cbind(incidence, size - incidence)" ) expect_equal( find_response(m1, combine = FALSE), c("incidence", "trials") ) expect_equal(find_response(m2, combine = FALSE), c("incidence", "size")) expect_equal( find_response(m3, combine = FALSE), c("incidence", "trials") ) expect_equal(find_response(m4, combine = FALSE), c("incidence", "size")) expect_equal(find_response(m5, combine = FALSE), c("incidence", "size")) }) test_that("get_response", { expect_equal(colnames(get_response(m1)), c("incidence", "trials")) expect_equal(colnames(get_response(m2)), c("incidence", "size")) expect_equal(colnames(get_response(m3)), c("incidence", "trials")) expect_equal(colnames(get_response(m4)), c("incidence", "size")) expect_equal(colnames(get_response(m5)), c("incidence", "size")) }) test_that("get_data", { expect_equal( colnames(get_data(m1)), c( "cbind(incidence, trials)", "period", "herd", "incidence", "trials" ) ) expect_equal( colnames(get_data(m2)), c( "cbind(incidence, size - incidence)", "period", "herd", "incidence", "size" ) ) get_data(m3) get_data(m4) expect_equal( colnames(get_data(m5)), c( "cbind(incidence, size - incidence)", "herd", "incidence", "size" ) ) }) set.seed(123) data(mtcars) m6 <- stats::aov( formula = mpg ~ wt + qsec + Error(disp / am), data = mtcars ) # TO DO # test_that("mod-info", { # get_data(m6) # find_response(m6) # get_response(m6) # find_formula(m6) # }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "z-statistic") expect_identical(find_statistic(m3), "z-statistic") expect_identical(find_statistic(m4), "z-statistic") expect_identical(find_statistic(m5), "z-statistic") expect_identical(find_statistic(m6), "F-statistic") }) } insight/tests/testthat/test-gmnl.R0000644000176200001440000000400013531007236016750 0ustar liggesusersif (require("testthat") && require("insight") && require("gmnl") && require("mlogit") && require("MASS")) { context("insight, polr") data(housing, package = "MASS") dat <- mlogit.data(housing, choice = "Sat", shape = "wide") m1 <- gmnl(Sat ~ Infl + Type + Cont | 1, data = dat, model = "smnl", R = 100 ) test_that("model_info", { expect_true(model_info(m1)$is_ordinal) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Infl", "Type", "Cont"))) expect_identical( find_predictors(m1, flatten = TRUE), c("Infl", "Type", "Cont") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "Sat") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 216) expect_equal(colnames(get_data(m1)), c("Sat", "Infl", "Type", "Cont")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "Sat", conditional = c("Infl", "Type", "Cont", "1") )) expect_equal( find_terms(m1, flatten = TRUE), c("Sat", "Infl", "Type", "Cont", "1") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 72) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = "Sat", conditional = c("Infl", "Type", "Cont") )) expect_equal( find_variables(m1, flatten = TRUE), c("Sat", "Infl", "Type", "Cont") ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-survreg.R0000644000176200001440000000476713552364343017544 0ustar liggesusersif (require("testthat") && require("insight") && require("survival")) { context("insight, model_info") data("ovarian") m1 <- survreg(Surv(futime, fustat) ~ ecog.ps + rx, data = ovarian, dist = "exponential" ) test_that("model_info", { expect_false(model_info(m1)$is_linear) expect_true(model_info(m1)$is_exponential) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("ecog.ps", "rx"))) expect_identical(find_predictors(m1, flatten = TRUE), c("ecog.ps", "rx")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "Surv(futime, fustat)") }) test_that("get_response", { expect_equal(get_response(m1), ovarian[, c("futime", "fustat")]) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("ecog.ps", "rx")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 26) expect_equal( colnames(get_data(m1)), c("futime", "fustat", "Surv(futime, fustat)", "ecog.ps", "rx") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("Surv(futime, fustat) ~ ecog.ps + rx")) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = c("futime", "fustat"), conditional = c("ecog.ps", "rx") )) expect_equal( find_variables(m1, flatten = TRUE), c("futime", "fustat", "ecog.ps", "rx") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 26) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c("(Intercept)", "ecog.ps", "rx")) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "ecog.ps", "rx") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-GLMMadaptive.R0000644000176200001440000002122313552364343020303 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { if (require("testthat") && require("insight") && require("GLMMadaptive") && require("lme4")) { context("insight, model_info") m <- download_model("GLMMadaptive_zi_2") m2 <- download_model("GLMMadaptive_zi_1") data(cbpp) m3 <- GLMMadaptive::mixed_model( cbind(incidence, size - incidence) ~ period, random = ~ 1 | herd, data = cbpp, family = binomial ) test_that("model_info", { expect_true(model_info(m)$is_zero_inflated) expect_true(model_info(m)$is_count) expect_true(model_info(m)$is_pois) expect_false(model_info(m)$is_negbin) }) test_that("find_predictors", { expect_identical( find_predictors(m, effects = "fixed")$conditional, c("child", "camper") ) expect_identical( find_predictors(m, effects = "fixed")$zero_inflated, c("child", "livebait") ) expect_identical( find_predictors(m, effects = "all", flatten = TRUE), c("child", "camper", "persons", "livebait") ) expect_identical( find_predictors(m, effects = "all")$zero_inflated_random, c("persons") ) expect_identical(find_predictors(m, effects = "random")$random, "persons") expect_identical( find_predictors( m, effects = "fixed", component = "cond", flatten = TRUE ), c("child", "camper") ) expect_identical( find_predictors( m, effects = "all", component = "cond", flatten = TRUE ), c("child", "camper", "persons") ) expect_identical( find_predictors(m, effects = "all", component = "cond")$conditional, c("child", "camper") ) expect_identical( find_predictors( m, effects = "random", component = "cond", flatten = TRUE ), "persons" ) expect_identical( find_predictors( m, effects = "fixed", component = "zi", flatten = TRUE ), c("child", "livebait") ) expect_identical( find_predictors( m, effects = "all", component = "zi", flatten = TRUE ), c("child", "livebait", "persons") ) expect_identical( find_predictors( m, effects = "random", component = "zi", flatten = TRUE ), "persons" ) expect_null(find_predictors( m, effects = "fixed", component = "dispersion", flatten = TRUE )) expect_null(find_predictors( m, effects = "all", component = "dispersion", flatten = TRUE )) expect_null(find_predictors( m, effects = "random", component = "dispersion", flatten = TRUE )) }) test_that("find_response", { expect_identical(find_response(m), "count") }) test_that("link_inverse", { expect_identical(link_inverse(m)(.2), exp(.2)) }) test_that("clean_names", { expect_identical( clean_names(m), c("count", "child", "camper", "persons", "livebait") ) }) test_that("find_formula", { expect_length(find_formula(m), 4) expect_identical( names(find_formula(m)), c( "conditional", "random", "zero_inflated", "zero_inflated_random" ) ) }) test_that("find_random", { expect_identical( find_random(m), list(random = "persons", zero_inflated_random = "persons") ) expect_identical(find_random(m, flatten = TRUE), "persons") }) test_that("find_respone", { expect_identical(find_response(m), "count") }) test_that("find_terms", { expect_identical( find_terms(m), list( response = "count", conditional = c("child", "camper"), random = "persons", zero_inflated = c("child", "livebait"), zero_inflated_random = "persons" ) ) expect_identical( find_terms(m, flatten = TRUE), c("count", "child", "camper", "persons", "livebait") ) }) test_that("get_response", { expect_identical(get_response(m3), cbpp[, c("incidence", "size")]) }) test_that("get_predictors", { expect_identical( colnames(get_predictors(m)), c("child", "camper", "livebait") ) }) test_that("get_random", { expect_identical(colnames(get_random(m)), "persons") }) test_that("get_data", { expect_identical( colnames(get_data(m)), c("count", "child", "camper", "livebait", "persons") ) expect_identical( colnames(get_data(m, effects = "fixed")), c("count", "child", "camper", "livebait") ) expect_identical(colnames(get_data(m, effects = "random")), "persons") expect_identical( colnames(get_data(m, component = "zi")), c("count", "child", "livebait", "persons") ) expect_identical(colnames(get_data( m, component = "zi", effects = "fixed" )), c("count", "child", "livebait")) expect_identical(colnames(get_data( m, component = "zi", effects = "random" )), "persons") expect_identical( colnames(get_data(m, component = "cond")), c("count", "child", "camper", "persons") ) expect_identical(colnames(get_data( m, component = "cond", effects = "fixed" )), c("count", "child", "camper")) expect_identical(colnames(get_data( m, component = "cond", effects = "random" )), "persons") expect_identical(colnames(get_data(m, component = "dispersion")), "count") expect_null(get_data(m, component = "dispersion", effects = "random")) expect_identical( colnames(get_data(m3)), c("incidence", "size", "period", "herd") ) }) test_that("find_parameter", { expect_equal( find_parameters(m), list( conditional = c("(Intercept)", "child", "camper1"), random = "(Intercept)", zero_inflated = c("(Intercept)", "child", "livebait1"), zero_inflated_random = "zi_(Intercept)" ) ) expect_equal( find_parameters(m2), list( conditional = c("(Intercept)", "child", "camper1"), random = "(Intercept)", zero_inflated = c("(Intercept)", "child", "livebait1") ) ) expect_equal( find_parameters(m3), list( conditional = c("(Intercept)", "period2", "period3", "period4"), random = "(Intercept)" ) ) expect_equal(nrow(get_parameters(m)), 6) expect_equal( get_parameters(m, effects = "random"), list( random = c(-1.0715496, 1.4083630, 1.9129880, 0.2007521), zero_inflated_random = c(-0.1676294, 0.5502481, 1.2592406, 0.9336591) ), tolerance = 1e-5 ) expect_equal(nrow(get_parameters(m2)), 6) expect_equal(get_parameters(m2, effects = "random"), list(random = c( -1.3262364, -0.2048055, 1.3852572, 0.5282277 )), tolerance = 1e-5 ) expect_equal( get_parameters(m3)$Component, c( "conditional", "conditional", "conditional", "conditional" ) ) expect_error(get_parameters(m3, "zi")) }) test_that("linkfun", { expect_false(is.null(link_function(m))) expect_false(is.null(link_function(m2))) }) test_that("is_multivariate", { expect_false(is_multivariate(m)) expect_false(is_multivariate(m2)) }) test_that("find_algorithm", { expect_equal( find_algorithm(m), list(algorithm = "quasi-Newton", optimizer = "optim") ) }) } # these run successfully for devtools::test_file() locally but fail on Travis # not sure what's going on # test_that("find_statistic", { # expect_identical(find_statistic(m1), "z-statistic") # expect_identical(find_statistic(m2), "z-statistic") # expect_identical(find_statistic(m3), "z-statistic") # }) } insight/tests/testthat/test-glm.R0000644000176200001440000000626513572501701016612 0ustar liggesusersif (require("testthat") && require("insight") && require("glmmTMB")) { context("insight, model_info") data(Salamanders) Salamanders$cover <- abs(Salamanders$cover) m1 <- glm(count ~ mined + log(cover) + sample, family = poisson, data = Salamanders ) test_that("model_info", { expect_true(model_info(m1)$is_poisson) expect_true(model_info(m1)$is_count) expect_false(model_info(m1)$is_negbin) expect_false(model_info(m1)$is_binomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("mined", "cover", "sample"))) expect_identical( find_predictors(m1, flatten = TRUE), c("mined", "cover", "sample") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "count") }) test_that("get_response", { expect_equal(get_response(m1), Salamanders$count) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("mined", "cover", "sample")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("linkfun", { expect_equal(link_function(m1)(.2), -1.609438, tolerance = 1e-4) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 644) expect_equal( colnames(get_data(m1)), c("count", "mined", "cover", "sample") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("count ~ mined + log(cover) + sample")) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "count", conditional = c("mined", "cover", "sample") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("count", "mined", "cover", "sample") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 644) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "minedno", "log(cover)", "sample") ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "minedno", "log(cover)", "sample") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "count", conditional = c("mined", "log(cover)", "sample") ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) test_that("get_statistic", { expect_equal(get_statistic(m1)$Statistic, c(-10.7066515607315, 18.1533878215937, -1.68918157150882, 2.23541768590273), tolernce = 1e-4) }) } insight/tests/testthat/test-cgam.R0000644000176200001440000000215613603137664016745 0ustar liggesusersif (require("testthat") && require("insight") && require("cgam")) { context("insight, model_info") data(cubic, package = "cgam") m <- cgam(y ~ incr.conv(x), data = cubic) test_that("n_obs", { expect_equal(n_obs(m), 50) }) test_that("find_formula", { expect_length(find_formula(m), 1) expect_equal( find_formula(m), list(conditional = as.formula("y ~ incr.conv(x)")) ) }) test_that("find_terms", { expect_equal(find_terms(m), list( response = "y", conditional = "incr.conv(x)" )) expect_equal( find_terms(m, flatten = TRUE), c("y", "incr.conv(x)") ) }) test_that("get_data", { expect_equal(nrow(get_data(m)), 50) expect_equal(colnames(get_data(m)), c("y", "x")) }) test_that("get_response", { expect_equal(get_response(m), cubic$y) }) test_that("is_multivariate", { expect_false(is_multivariate(m)) }) test_that("is_model", { expect_true(is_model(m)) }) test_that("find_statistic", { expect_identical(find_statistic(m), "t-statistic") }) } insight/tests/testthat/test-gam.R0000644000176200001440000001330413554405404016572 0ustar liggesusersif (require("testthat") && require("insight") && require("mgcv")) { context("insight, model_info") set.seed(123) dat <- gamSim(1, n = 400, dist = "normal", scale = 2) m1 <- mgcv::gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) m2 <- download_model("gam_zi_1") m3 <- download_model("gam_mv_1") test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m2)$is_count) expect_true(model_info(m3)$is_multivariate) }) test_that("clean_names", { expect_equal(clean_names(m1), c("y", "x0", "x1", "x2", "x3")) expect_equal(clean_names(m2), c("y", "x2", "x3", "x0", "x1")) expect_equal(clean_names(m3), c("y0", "y1", "x0", "x1", "x2", "x3")) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("x0", "x1", "x2", "x3"))) expect_identical( find_predictors(m1, flatten = TRUE), c("x0", "x1", "x2", "x3") ) expect_null(find_predictors(m1, effects = "random")) expect_identical(find_predictors(m2), list(conditional = c("x2", "x3"), zero_inflated = c("x0", "x1"))) expect_identical(find_predictors(m2, flatten = TRUE), c("x2", "x3", "x0", "x1")) expect_null(find_predictors(m2, effects = "random")) expect_identical(find_predictors(m3), list(y0 = list(conditional = c("x0", "x1")), y1 = list(conditional = c("x2", "x3")))) expect_identical(find_predictors(m3, flatten = TRUE), c("x0", "x1", "x2", "x3")) expect_null(find_predictors(m3, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "y") expect_identical(find_response(m2), "y") expect_identical(find_response(m3), c(y0 = "y0", y1 = "y1")) }) test_that("get_response", { expect_equal(get_response(m1), dat$y) expect_equal(length(get_response(m2)), 500) expect_equal(ncol(get_response(m3)), 2) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) expect_equal(link_inverse(m2)(.2), .2, tolerance = 1e-5) expect_equal(link_inverse(m3)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 400) expect_equal(colnames(get_data(m1)), c("y", "x0", "x1", "x2", "x3")) expect_equal(nrow(get_data(m2)), 500) expect_equal(colnames(get_data(m2)), c("y", "x2", "x3", "x0", "x1")) expect_equal(nrow(get_data(m3)), 300) expect_equal(colnames(get_data(m3)), c("y0", "x0", "x1", "x2", "x3", "y1")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("y ~ s(x0) + s(x1) + s(x2) + s(x3)")) ) expect_length(find_formula(m2), 2) expect_equal( find_formula(m2), list( conditional = as.formula("y ~ s(x2) + s(x3)"), zero_inflated = as.formula("~s(x0) + s(x1)") ) ) expect_length(find_formula(m3), 2) expect_equal( find_formula(m3), structure(list( y0 = list(conditional = as.formula("y0 ~ s(x0) + s(x1)")), y1 = list(conditional = as.formula("y1 ~ s(x2) + s(x3)")) ), is_mv = "1" ) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list(response = "y", conditional = c("x0", "x1", "x2", "x3"))) expect_equal(find_variables(m1, flatten = TRUE), c("y", "x0", "x1", "x2", "x3")) expect_equal(find_variables(m2), list(response = "y", conditional = c("x2", "x3"), zero_inflated = c("x0", "x1"))) expect_equal(find_variables(m2, flatten = TRUE), c("y", "x2", "x3", "x0", "x1")) expect_equal(find_variables(m3), list(response = c(y0 = "y0", y1 = "y1"), y0 = list(conditional = c("x0", "x1")), y1 = list(conditional = c("x2", "x3")))) expect_equal(find_variables(m3, flatten = TRUE), c("y0", "y1", "x0", "x1", "x2", "x3")) }) test_that("n_obs", { expect_equal(n_obs(m1), 400) expect_equal(n_obs(m2), 500) expect_equal(n_obs(m3), 300) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = "(Intercept)", smooth_terms = c("s(x0)", "s(x1)", "s(x2)", "s(x3)") ) ) expect_equal(nrow(get_parameters(m1)), 5) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "s(x0)", "s(x1)", "s(x2)", "s(x3)") ) expect_equal(nrow(get_parameters(m1, "smooth_terms")), 4) expect_equal( find_parameters(m2), list( conditional = c("(Intercept)", "(Intercept).1"), smooth_terms = c("s(x2)", "s(x3)", "s.1(x0)", "s.1(x1)") ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) expect_true(is_multivariate(m3)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "y", conditional = c("s(x0)", "s(x1)", "s(x2)", "s(x3)") ) ) expect_equal( find_terms(m2), list( response = "y", conditional = c("s(x2)", "s(x3)"), zero_inflated = c("s(x0)", "s(x1)") ) ) expect_equal( find_terms(m3), list( y0 = list(response = "y0", conditional = c("s(x0)", "s(x1)")), y1 = list(response = "y1", conditional = c("s(x2)", "s(x3)")) ) ) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "GCV", optimizer = "magic") ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-BBmm.R0000644000176200001440000000610613531007236016641 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest && Sys.getenv("USER") != "travis") { if (require("testthat") && require("insight") && require("HRQoL")) { context("insight, BBmm") set.seed(18) k <- 100 m <- 10 x <- rnorm(k, 5, 3) j <- runif(k, 0, 5) fac <- sample(letters[1:4], k, TRUE) beta <- c(-10, 2) p <- 1 / (1 + exp(-(beta[1] + beta[2] * x))) phi <- 1.2 y <- HRQoL::rBB(k, m, p, phi) z <- as.factor(HRQoL::rBI(k, 4, 0.5, 2)) dat <- data.frame(y, x, j, fac, z) m1 <- BBmm( fixed.formula = y ~ x, random.formula = ~z, m = m, data = dat ) test_that("model_info", { expect_true(model_info(m1)$is_binomial) expect_true(model_info(m1)$is_betabinomial) expect_true(model_info(m1)$is_mixed) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = "x")) expect_identical(find_predictors(m1, flatten = TRUE), "x") expect_identical( find_predictors(m1, effects = "random"), list(random = "z") ) expect_identical( find_predictors(m1, effects = "all"), list( conditional = "x", random = "z" ) ) }) test_that("find_random", { expect_identical(find_random(m1), list(random = "z")) }) test_that("find_response", { expect_identical(find_response(m1), "y") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("link_function", { expect_equal(link_function(m1)(.2), qlogis(.2), tolerance = 1e-5) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("y ~ x"), random = as.formula("~z") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "y", conditional = "x", random = "z" ) ) expect_equal(find_variables(m1, flatten = TRUE), c("y", "x", "z")) }) test_that("n_obs", { expect_equal(n_obs(m1), 100) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "x"), random = "z" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "y", conditional = "x", random = "z" ) ) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "extended likelihood", optimizer = "BB-NR") ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } } insight/tests/testthat/test-mlogit.R0000644000176200001440000000540013531007236017313 0ustar liggesusersif (require("testthat") && require("insight") && require("mlogit")) { context("insight, polr") data("Fishing") Fish <- mlogit.data(Fishing, varying = c(2:9), shape = "wide", choice = "mode" ) m1 <- mlogit(mode ~ price + catch, data = Fish) m2 <- mlogit(mode ~ price + catch | income, data = Fish) test_that("model_info", { expect_true(model_info(m1)$is_ordinal) expect_true(model_info(m2)$is_ordinal) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("price", "catch"))) expect_identical(find_predictors(m1, flatten = TRUE), c("price", "catch")) expect_null(find_predictors(m1, effects = "random")) expect_identical(find_predictors(m2), list(conditional = c("price", "catch", "income"))) expect_identical( find_predictors(m2, flatten = TRUE), c("price", "catch", "income") ) expect_null(find_predictors(m2, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "mode") expect_identical(find_response(m2), "mode") }) test_that("get_response", { expect_equal(get_response(m1), Fish$mode) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) expect_equal(link_inverse(m2)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 4728) expect_equal(nrow(get_data(m2)), 4728) expect_equal( colnames(get_data(m1)), c("mode", "price", "catch", "probabilities", "linpred") ) expect_equal( colnames(get_data(m2)), c( "mode", "price", "catch", "income", "probabilities", "linpred" ) ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_length(find_formula(m2), 1) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "mode", conditional = c("price", "catch") )) expect_equal(find_terms(m1, flatten = TRUE), c("mode", "price", "catch")) expect_equal(find_terms(m2), list( response = "mode", conditional = c("price", "catch", "income") )) expect_equal( find_terms(m2, flatten = TRUE), c("mode", "price", "catch", "income") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 4728) expect_equal(n_obs(m2), 4728) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "z-statistic") }) } insight/tests/testthat/test-plm.R0000644000176200001440000000677313534510641016630 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { if (require("testthat") && require("insight") && require("plm")) { context("insight, model_info") data(Crime) m1 <- plm(lcrmrte ~ lprbarr + factor(year) | . - lprbarr + lmix, data = Crime, model = "random") # data set.seed(123) data("Produc", package = "plm") # model m2 <- plm::plm( formula = log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp, data = Produc, index = c("state", "year") ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( conditional = c("lprbarr", "year"), instruments = c("lprbarr", "lmix") ) ) expect_identical( find_predictors(m1, flatten = TRUE), c("lprbarr", "year", "lmix") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "lcrmrte") }) test_that("get_response", { expect_equal(get_response(m1), Crime$lcrmrte) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("lprbarr", "year", "lmix")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 630) expect_equal( colnames(get_data(m1)), c("lcrmrte", "lprbarr", "year", "lmix") ) expect_equal(nrow(get_data(m2)), 816) expect_equal( colnames(get_data(m2)), c("gsp", "pcap", "pc", "emp", "unemp", "state", "year") ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("lcrmrte ~ lprbarr + factor(year)"), instruments = as.formula("~-lprbarr + lmix") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "lcrmrte", conditional = c("lprbarr", "year"), instruments = c("lprbarr", "lmix") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("lcrmrte", "lprbarr", "year", "lmix") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 630) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "lprbarr", "factor(year)82", "factor(year)83", "factor(year)84", "factor(year)85", "factor(year)86", "factor(year)87" ) ) ) expect_equal(nrow(get_parameters(m1)), 8) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "t-statistic") }) } } insight/tests/testthat/test-ols.R0000644000176200001440000000471313552364343016633 0ustar liggesusersif (require("testthat") && require("insight") && require("rms")) { context("insight, model_info") data(mtcars) m1 <- ols(mpg ~ rcs(hp, 3) * cyl + wt, data = mtcars) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("hp", "cyl", "wt"))) expect_identical(find_predictors(m1, flatten = TRUE), c("hp", "cyl", "wt")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "mpg") }) test_that("get_response", { expect_equal(get_response(m1), mtcars$mpg) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("hp", "cyl", "wt")) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 32) expect_equal(colnames(get_data(m1)), c("mpg", "cyl", "wt", "hp")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("mpg ~ rcs(hp, 3) * cyl + wt")) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = "mpg", conditional = c("hp", "cyl", "wt") )) expect_equal( find_variables(m1, flatten = TRUE), c("mpg", "hp", "cyl", "wt") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 32) }) test_that("linkfun", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("Intercept", "hp", "hp'", "cyl", "wt", "hp * cyl", "hp' * cyl") ) ) expect_equal(nrow(get_parameters(m1)), 7) expect_equal( get_parameters(m1)$Parameter, c("Intercept", "hp", "hp'", "cyl", "wt", "hp * cyl", "hp' * cyl") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "OLS")) }) # TO DO # test_that("find_statistic", { # expect_null(find_statistic(m1)) # }) } insight/tests/testthat/test-multinom.R0000644000176200001440000000402513552364343017676 0ustar liggesusersif (require("testthat") && require("insight") && require("nnet") && require("MASS")) { context("insight, model_info") data("birthwt") m1 <- multinom(low ~ age + lwt + race + smoke, data = birthwt) test_that("model_info", { expect_true(model_info(m1)$is_binomial) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("age", "lwt", "race", "smoke"))) expect_identical( find_predictors(m1, flatten = TRUE), c("age", "lwt", "race", "smoke") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "low") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 189) expect_equal( colnames(get_data(m1)), c("low", "age", "lwt", "race", "smoke") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("low ~ age + lwt + race + smoke")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "low", conditional = c("age", "lwt", "race", "smoke") )) expect_equal( find_terms(m1, flatten = TRUE), c("low", "age", "lwt", "race", "smoke") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 189) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c( "(Intercept)", "age", "lwt", "race", "smoke" )) ) expect_equal(nrow(get_parameters(m1)), 5) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "age", "lwt", "race", "smoke") ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-model_data.R0000644000176200001440000000261013531007236020111 0ustar liggesusersif (require("testthat") && require("insight") && require("splines") && require("glmmTMB")) { context("insight, get_data") data(iris) m1 <- lm(Sepal.Length ~ Species + ns(Petal.Width), data = iris) m2 <- lm(Sepal.Length ~ Species + ns(Petal.Width, knots = 2), data = iris) m3 <- lm(Sepal.Length ~ Species + bs(Petal.Width, degree = 3), data = iris) m4 <- lm(Sepal.Length ~ Species + bs(Petal.Width, degree = 1), data = iris) m5 <- lm(Sepal.Length ~ Species + Petal.Width, data = iris) test_that("get_data", { mf1 <- get_data(m1) mf2 <- get_data(m2) mf3 <- get_data(m3) mf4 <- get_data(m4) mf5 <- model.frame(m5) expect_equal(as.vector(mf1$Petal.Width), as.vector(mf5$Petal.Width)) expect_equal(as.vector(mf2$Petal.Width), as.vector(mf5$Petal.Width)) expect_equal(as.vector(mf3$Petal.Width), as.vector(mf5$Petal.Width)) expect_equal(as.vector(mf4$Petal.Width), as.vector(mf5$Petal.Width)) }) data("Salamanders") m <- glmmTMB( count ~ spp + cover + mined + poly(DOP, 3) + (1 | site), ziformula = ~ spp + mined, dispformula = ~DOY, data = Salamanders, family = nbinom2 ) test_that("get_data", { mf <- get_data(m) expect_equal(ncol(mf), 7) expect_equal( colnames(mf), c("count", "spp", "cover", "mined", "DOP", "DOY", "site") ) }) } insight/tests/testthat/test-fixest.R0000644000176200001440000001416313615521170017331 0ustar liggesusersif (require("testthat") && require("insight") && require("fixest")) { data(trade) m1 <- femlm(Euros ~ log(dist_km) | Origin + Destination + Product, data = trade) m2 <- femlm(log1p(Euros) ~ log(dist_km) | Origin + Destination + Product, data = trade, family = "gaussian") m3 <- feglm(Euros ~ log(dist_km) | Origin + Destination + Product, data = trade) test_that("model_info", { expect_true(model_info(m1)$is_count) expect_true(model_info(m2)$is_linear) expect_true(model_info(m3)$is_count) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = "dist_km", cluster = c("Origin", "Destination", "Product"))) expect_identical(find_predictors(m2), list(conditional = "dist_km", cluster = c("Origin", "Destination", "Product"))) expect_identical(find_predictors(m3), list(conditional = "dist_km", cluster = c("Origin", "Destination", "Product"))) expect_identical( find_predictors(m1, component = "all"), list(conditional = "dist_km", cluster = c("Origin", "Destination", "Product")) ) expect_identical( find_predictors(m2, component = "all"), list(conditional = "dist_km", cluster = c("Origin", "Destination", "Product")) ) expect_identical( find_predictors(m3, component = "all"), list(conditional = "dist_km", cluster = c("Origin", "Destination", "Product")) ) }) test_that("find_random", { expect_null(find_random(m1)) expect_null(find_random(m2)) expect_null(find_random(m3)) }) test_that("get_random", { expect_null(expect_warning(get_random(m1))) }) test_that("find_response", { expect_identical(find_response(m1), "Euros") expect_identical(find_response(m2), "Euros") expect_identical(find_response(m3), "Euros") }) test_that("get_response", { expect_equal(get_response(m1), trade$Euros) expect_equal(get_response(m2), trade$Euros) expect_equal(get_response(m3), trade$Euros) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("dist_km", "Origin", "Destination", "Product")) expect_equal(colnames(get_predictors(m2)), c("dist_km", "Origin", "Destination", "Product")) expect_equal(colnames(get_predictors(m3)), c("dist_km", "Origin", "Destination", "Product")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-4) expect_equal(link_inverse(m2)(.2), .2, tolerance = 1e-4) expect_equal(link_inverse(m3)(.2), exp(.2), tolerance = 1e-4) }) test_that("link_function", { expect_equal(link_function(m1)(.2), log(.2), tolerance = 1e-4) expect_equal(link_function(m2)(.2), .2, tolerance = 1e-4) expect_equal(link_function(m3)(.2), log(.2), tolerance = 1e-4) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 38325) expect_equal(colnames(get_data(m1)), c("Euros", "dist_km", "Origin", "Destination", "Product")) expect_equal(nrow(get_data(m2)), 38325) expect_equal(colnames(get_data(m2)), c("Euros", "dist_km", "Origin", "Destination", "Product")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("Euros ~ log(dist_km)"), cluster = as.formula("~Origin + Destination + Product") ) ) expect_length(find_formula(m2), 2) expect_equal( find_formula(m2), list( conditional = as.formula("log1p(Euros) ~ log(dist_km)"), cluster = as.formula("~Origin + Destination + Product") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list(response = "Euros", conditional = "log(dist_km)", cluster = c("Origin", "Destination", "Product")) ) expect_equal( find_terms(m1, flatten = TRUE), c("Euros", "log(dist_km)", "Origin", "Destination", "Product") ) expect_equal( find_terms(m2), list(response = "log1p(Euros)", conditional = "log(dist_km)", cluster = c("Origin", "Destination", "Product")) ) expect_equal( find_terms(m2, flatten = TRUE), c("log1p(Euros)", "log(dist_km)", "Origin", "Destination", "Product") ) }) test_that("find_variables", { expect_equal( find_variables(m1), list(response = "Euros", conditional = "dist_km", cluster = c("Origin", "Destination", "Product")) ) expect_equal( find_variables(m1, flatten = TRUE), c("Euros", "dist_km", "Origin", "Destination", "Product") ) expect_equal( find_variables(m2), list(response = "Euros", conditional = "dist_km", cluster = c("Origin", "Destination", "Product")) ) expect_equal( find_variables(m1, flatten = TRUE), c("Euros", "dist_km", "Origin", "Destination", "Product") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 38325) expect_equal(n_obs(m2), 38325) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = "log(dist_km)") ) expect_equal( get_parameters(m1), data.frame( Parameter = "log(dist_km)", Estimate = -1.52774702640008, row.names = NULL, stringsAsFactors = FALSE ), tolerance = 1e-4 ) expect_equal( find_parameters(m2), list(conditional = "log(dist_km)") ) expect_equal( get_parameters(m2), data.frame( Parameter = "log(dist_km)", Estimate = -2.16843021944503, row.names = NULL, stringsAsFactors = FALSE ), tolerance = 1e-4 ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") expect_identical(find_statistic(m2), "z-statistic") }) test_that("get_statistic", { stat <- get_statistic(m1) expect_equal(stat$Statistic, -13.212695, tolerance = 1e-3) stat <- get_statistic(m2) expect_equal(stat$Statistic, -14.065336, tolerance = 1e-3) }) } insight/tests/testthat/test-brms.R0000644000176200001440000005514013602425632016774 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { if (suppressWarnings(require("testthat") && require("insight") && require("brms"))) { context("insight, brms-find_response") # Model fitting ----------------------------------------------------------- m1 <- insight::download_model("brms_mixed_6") m2 <- insight::download_model("brms_mv_4") m3 <- insight::download_model("brms_2") m4 <- insight::download_model("brms_zi_3") m5 <- insight::download_model("brms_mv_5") m6 <- insight::download_model("brms_corr_re1") # Tests ------------------------------------------------------------------- test_that("find_statistic", { expect_null(find_statistic(m1)) expect_null(find_statistic(m2)) expect_null(find_statistic(m3)) expect_null(find_statistic(m4)) expect_null(find_statistic(m5)) }) test_that("model_info", { expect_true(model_info(m3)$is_trial) expect_true(model_info(m5)[[1]]$is_zero_inflated) expect_true(model_info(m5)[[1]]$is_bayesian) }) test_that("clean_names", { expect_identical( clean_names(m1), c("count", "Age", "Base", "Trt", "patient") ) expect_identical( clean_names(m2), c( "Sepal.Length", "Sepal.Width", "Petal.Length", "Species" ) ) expect_identical(clean_names(m3), c("r", "n", "treat", "c2")) expect_identical( clean_names(m4), c("count", "child", "camper", "persons") ) expect_identical( clean_names(m5), c( "count", "count2", "child", "camper", "persons", "livebait" ) ) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Age", "Base", "Trt"))) expect_identical( find_predictors(m1, flatten = TRUE), c("Age", "Base", "Trt") ) expect_identical( find_predictors(m1, effects = "all", component = "all"), list( conditional = c("Age", "Base", "Trt"), random = "patient" ) ) expect_identical( find_predictors( m1, effects = "all", component = "all", flatten = TRUE ), c("Age", "Base", "Trt", "patient") ) expect_identical( find_predictors(m2), list( SepalLength = list(conditional = c( "Petal.Length", "Sepal.Width", "Species" )), SepalWidth = list(conditional = "Species") ) ) expect_identical( find_predictors(m2, flatten = TRUE), c("Petal.Length", "Sepal.Width", "Species") ) expect_identical(find_predictors(m3), list(conditional = c("treat", "c2"))) expect_identical( find_predictors(m4), list( conditional = c("child", "camper"), zero_inflated = c("child", "camper") ) ) expect_identical( find_predictors(m4, effects = "random"), list(random = "persons", zero_inflated_random = "persons") ) expect_identical(find_predictors(m4, flatten = TRUE), c("child", "camper")) expect_identical( find_predictors(m5), list( count = list( conditional = c("child", "camper"), zero_inflated = "camper" ), count2 = list( conditional = c("child", "livebait"), zero_inflated = "child" ) ) ) }) test_that("find_response", { expect_equal(find_response(m1, combine = TRUE), "count") expect_equal( find_response(m2, combine = TRUE), c(SepalLength = "Sepal.Length", SepalWidth = "Sepal.Width") ) expect_equal(find_response(m3, combine = TRUE), c("r", "n")) expect_equal(find_response(m1, combine = FALSE), "count") expect_equal( find_response(m2, combine = FALSE), c(SepalLength = "Sepal.Length", SepalWidth = "Sepal.Width") ) expect_equal(find_response(m3, combine = FALSE), c("r", "n")) expect_equal(find_response(m4, combine = FALSE), "count") expect_equal( find_response(m5, combine = TRUE), c(count = "count", count2 = "count2") ) }) test_that("get_response", { expect_length(get_response(m1), 236) expect_equal(ncol(get_response(m2)), 2) expect_equal( colnames(get_response(m2)), c("Sepal.Length", "Sepal.Width") ) expect_equal(ncol(get_response(m3)), 2) expect_equal(colnames(get_response(m3)), c("r", "n")) expect_length(get_response(m4), 250) expect_equal(colnames(get_response(m5)), c("count", "count2")) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = "count", conditional = c("Age", "Base", "Trt"), random = "patient" ) ) expect_identical( find_variables(m6), list( response = "y", conditional = "x", random = "id" ) ) expect_identical( find_variables(m1, effects = "fixed"), list( response = "count", conditional = c("Age", "Base", "Trt") ) ) expect_null(find_variables(m1, component = "zi")) expect_identical( find_variables(m2), list( response = c(SepalLength = "Sepal.Length", SepalWidth = "Sepal.Width"), SepalLength = list(conditional = c( "Petal.Length", "Sepal.Width", "Species" )), SepalWidth = list(conditional = "Species") ) ) expect_identical( find_variables(m2, flatten = TRUE), c( "Sepal.Length", "Sepal.Width", "Petal.Length", "Species" ) ) expect_identical(find_variables(m3), list( response = c("r", "n"), conditional = c("treat", "c2") )) expect_identical( find_variables(m4), list( response = "count", conditional = c("child", "camper"), random = "persons", zero_inflated = c("child", "camper"), zero_inflated_random = "persons" ) ) expect_identical( find_variables(m4, flatten = TRUE), c("count", "child", "camper", "persons") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 236) expect_equal(n_obs(m2), 150) expect_equal(n_obs(m3), 10) expect_equal(n_obs(m4), 250) expect_equal(n_obs(m5), 250) }) test_that("find_random", { expect_equal(find_random(m5), list( count = list( random = "persons", zero_inflated_random = "persons" ), count2 = list( random = "persons", zero_inflated_random = "persons" ) )) expect_equal(find_random(m5, flatten = TRUE), "persons") expect_equal(find_random(m6, flatten = TRUE), "id") }) test_that("get_random", { zinb <- get_data(m4) expect_equal(get_random(m4), zinb[, "persons", drop = FALSE]) }) test_that("get_data", { d <- get_data(m6) expect_equal(nrow(d), 200) expect_equal(ncol(d), 3) }) test_that("find_paramaters", { expect_equal( find_parameters(m1), list( conditional = c( "b_Intercept", "b_Age", "b_Base", "b_Trt1", "b_Base.Trt1" ), random = sprintf("r_patient.%i.Intercept.", 1:59) ) ) expect_equal( find_parameters(m2), structure(list( SepalLength = list( conditional = c( "b_SepalLength_Intercept", "b_SepalLength_Petal.Length", "b_SepalLength_Sepal.Width", "b_SepalLength_Speciesversicolor", "b_SepalLength_Speciesvirginica" ), sigma = "sigma_SepalLength" ), SepalWidth = list( conditional = c( "b_SepalWidth_Intercept", "b_SepalWidth_Speciesversicolor", "b_SepalWidth_Speciesvirginica" ), sigma = "sigma_SepalWidth" ) ), "is_mv" = "1" ) ) expect_equal( find_parameters(m4), list( conditional = c("b_Intercept", "b_child", "b_camper"), random = sprintf("r_persons.%i.Intercept.", 1:4), zero_inflated = c("b_zi_Intercept", "b_zi_child", "b_zi_camper"), zero_inflated_random = sprintf("r_persons__zi.%i.Intercept.", 1:4) ) ) expect_equal( find_parameters(m5), structure(list( count = list( conditional = c("b_count_Intercept", "b_count_child", "b_count_camper"), random = sprintf("r_persons__count.%i.Intercept.", 1:4), zero_inflated = c("b_zi_count_Intercept", "b_zi_count_camper"), zero_inflated_random = sprintf("r_persons__zi_count.%i.Intercept.", 1:4) ), count2 = list( conditional = c( "b_count2_Intercept", "b_count2_child", "b_count2_livebait" ), random = sprintf("r_persons__count2.%i.Intercept.", 1:4), zero_inflated = c("b_zi_count2_Intercept", "b_zi_count2_child"), zero_inflated_random = sprintf("r_persons__zi_count2.%i.Intercept.", 1:4) ) ), "is_mv" = "1" ) ) }) test_that("find_paramaters", { expect_equal( colnames(get_parameters(m4)), c( "b_Intercept", "b_child", "b_camper", "b_zi_Intercept", "b_zi_child", "b_zi_camper" ) ) expect_equal( colnames(get_parameters(m4, component = "zi")), c("b_zi_Intercept", "b_zi_child", "b_zi_camper") ) expect_equal( colnames(get_parameters(m4, effects = "all")), c( "b_Intercept", "b_child", "b_camper", "r_persons.1.Intercept.", "r_persons.2.Intercept.", "r_persons.3.Intercept.", "r_persons.4.Intercept.", "b_zi_Intercept", "b_zi_child", "b_zi_camper", "r_persons__zi.1.Intercept.", "r_persons__zi.2.Intercept.", "r_persons__zi.3.Intercept.", "r_persons__zi.4.Intercept." ) ) expect_equal( colnames(get_parameters( m4, effects = "random", component = "cond" )), c( "r_persons.1.Intercept.", "r_persons.2.Intercept.", "r_persons.3.Intercept.", "r_persons.4.Intercept." ) ) expect_equal( colnames(get_parameters( m5, effects = "random", component = "cond" )), c( "r_persons__count.1.Intercept.", "r_persons__count.2.Intercept.", "r_persons__count.3.Intercept.", "r_persons__count.4.Intercept.", "r_persons__count2.1.Intercept.", "r_persons__count2.2.Intercept.", "r_persons__count2.3.Intercept.", "r_persons__count2.4.Intercept." ) ) expect_equal( colnames(get_parameters( m5, effects = "all", component = "all" )), c( "b_count_Intercept", "b_count_child", "b_count_camper", "r_persons__count.1.Intercept.", "r_persons__count.2.Intercept.", "r_persons__count.3.Intercept.", "r_persons__count.4.Intercept.", "b_zi_count_Intercept", "b_zi_count_camper", "r_persons__zi_count.1.Intercept.", "r_persons__zi_count.2.Intercept.", "r_persons__zi_count.3.Intercept.", "r_persons__zi_count.4.Intercept.", "b_count2_Intercept", "b_count2_child", "b_count2_livebait", "r_persons__count2.1.Intercept.", "r_persons__count2.2.Intercept.", "r_persons__count2.3.Intercept.", "r_persons__count2.4.Intercept.", "b_zi_count2_Intercept", "b_zi_count2_child", "r_persons__zi_count2.1.Intercept.", "r_persons__zi_count2.2.Intercept.", "r_persons__zi_count2.3.Intercept.", "r_persons__zi_count2.4.Intercept." ) ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_length(link_function(m2), 2) expect_false(is.null(link_function(m3))) expect_false(is.null(link_function(m4))) expect_length(link_function(m5), 2) }) test_that("linkinv", { expect_false(is.null(link_inverse(m1))) expect_length(link_inverse(m2), 2) expect_false(is.null(link_inverse(m3))) expect_false(is.null(link_inverse(m4))) expect_length(link_inverse(m2), 2) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_true(is_multivariate(m2)) expect_false(is_multivariate(m3)) expect_false(is_multivariate(m4)) expect_true(is_multivariate(m5)) }) test_that("find_terms", { expect_equal( find_terms(m2), list( SepalLength = list( response = "Sepal.Length", conditional = c("Petal.Length", "Sepal.Width", "Species") ), SepalWidth = list( response = "Sepal.Width", conditional = "Species" ) ) ) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list( algorithm = "sampling", chains = 1, iterations = 500, warmup = 250 ) ) }) test_that("get_priors", { expect_equal( get_priors(m1), data.frame( Parameter = c("Age", "Base", "Base:Trt1", "Trt1"), Distribution = c("student_t", "student_t", "student_t", "student_t"), Location = c("5, 0", "5, 0", "5, 0", "5, 0"), Scale = c(10, 10, 10, 10), stringsAsFactors = FALSE ) ) expect_equal( get_priors(m3), data.frame( Parameter = c("c2", "treat1", "treat1:c2"), Distribution = c("uniform", "uniform", "uniform"), Location = c(0, 0, 0), Scale = c(NA, NA, NA), stringsAsFactors = FALSE ) ) }) test_that("clean_parameters", { expect_equal( clean_parameters(m4), structure( list( Parameter = c( "b_Intercept", "b_child", "b_camper", "r_persons.1.Intercept.", "r_persons.2.Intercept.", "r_persons.3.Intercept.", "r_persons.4.Intercept.", "b_zi_Intercept", "b_zi_child", "b_zi_camper", "r_persons__zi.1.Intercept.", "r_persons__zi.2.Intercept.", "r_persons__zi.3.Intercept.", "r_persons__zi.4.Intercept." ), Effects = c( "fixed", "fixed", "fixed", "random", "random", "random", "random", "fixed", "fixed", "fixed", "random", "random", "random", "random" ), Component = c( "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated" ), Group = c( "", "", "", "Intercept: persons", "Intercept: persons", "Intercept: persons", "Intercept: persons", "", "", "", "Intercept: persons", "Intercept: persons", "Intercept: persons", "Intercept: persons" ), Cleaned_Parameter = c( "(Intercept)", "child", "camper", "persons.1", "persons.2", "persons.3", "persons.4", "(Intercept)", "child", "camper", "persons.1", "persons.2", "persons.3", "persons.4" ) ), class = c("clean_parameters", "data.frame"), row.names = c(NA, -14L) ) ) expect_equal( clean_parameters(m5), structure( list( Parameter = c( "b_count_Intercept", "b_count_child", "b_count_camper", "b_count2_Intercept", "b_count2_child", "b_count2_livebait", "r_persons__count.1.Intercept.", "r_persons__count.2.Intercept.", "r_persons__count.3.Intercept.", "r_persons__count.4.Intercept.", "r_persons__count2.1.Intercept.", "r_persons__count2.2.Intercept.", "r_persons__count2.3.Intercept.", "r_persons__count2.4.Intercept.", "b_zi_count_Intercept", "b_zi_count_camper", "b_zi_count2_Intercept", "b_zi_count2_child", "r_persons__zi_count.1.Intercept.", "r_persons__zi_count.2.Intercept.", "r_persons__zi_count.3.Intercept.", "r_persons__zi_count.4.Intercept.", "r_persons__zi_count2.1.Intercept.", "r_persons__zi_count2.2.Intercept.", "r_persons__zi_count2.3.Intercept.", "r_persons__zi_count2.4.Intercept." ), Effects = c( "fixed", "fixed", "fixed", "fixed", "fixed", "fixed", "random", "random", "random", "random", "random", "random", "random", "random", "fixed", "fixed", "fixed", "fixed", "random", "random", "random", "random", "random", "random", "random", "random" ), Component = c( "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated" ), Group = c( "", "", "", "", "", "", "Intercept: persons", "Intercept: persons", "Intercept: persons", "Intercept: persons", "Intercept: persons2", "Intercept: persons2", "Intercept: persons2", "Intercept: persons2", "", "", "", "", "Intercept: persons", "Intercept: persons", "Intercept: persons", "Intercept: persons", "Intercept: persons2", "Intercept: persons2", "Intercept: persons2", "Intercept: persons2" ), Response = c( "count", "count", "count", "count2", "count2", "count2", "count", "count", "count", "count", "count2", "count2", "count2", "count2", "count", "count", "count2", "count2", "count", "count", "count", "count", "count2", "count2", "count2", "count2" ), Cleaned_Parameter = c( "(Intercept)", "child", "camper", "(Intercept)", "child", "livebait", "persons.1", "persons.2", "persons.3", "persons.4", "persons2.1", "persons2.2", "persons2.3", "persons2.4", "(Intercept)", "camper", "(Intercept)", "child", "persons.1", "persons.2", "persons.3", "persons.4", "persons2.1", "persons2.2", "persons2.3", "persons2.4" ) ), class = c("clean_parameters", "data.frame"), row.names = c(NA, -26L) ) ) }) } } insight/tests/testthat/test-format.R0000644000176200001440000000047013534510641017314 0ustar liggesusersif (require("testthat") && require("insight")) { context("insight, format") test_that("format_value", { expect_equal(nchar(format_value(1.2012313)), 4) expect_equal(format_value(4.2, protect_integers = TRUE), "4.20") expect_equal(format_value(4.0, protect_integers = TRUE), "4") }) } insight/tests/testthat/test-blmer.R0000644000176200001440000002205413552364343017135 0ustar liggesusersif (require("testthat") && require("insight") && require("blme")) { context("insight, blme") data(sleepstudy) set.seed(123) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } m1 <- blmer(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy, cov.prior = NULL ) m2 <- blmer( Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy, cov.prior = wishart ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m2)$is_linear) expect_true(model_info(m1)$is_bayesian) }) test_that("find_predictors", { expect_equal( find_predictors(m1, effects = "all"), list(conditional = "Days", random = "Subject") ) expect_equal( find_predictors(m1, effects = "all", flatten = TRUE), c("Days", "Subject") ) expect_equal( find_predictors(m1, effects = "fixed"), list(conditional = "Days") ) expect_equal( find_predictors(m1, effects = "fixed", flatten = TRUE), "Days" ) expect_equal( find_predictors(m1, effects = "random"), list(random = "Subject") ) expect_equal( find_predictors(m1, effects = "random", flatten = TRUE), "Subject" ) expect_equal( find_predictors(m2, effects = "all"), list( conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_equal( find_predictors(m2, effects = "all", flatten = TRUE), c("Days", "mysubgrp", "mygrp", "Subject") ) expect_equal( find_predictors(m2, effects = "fixed"), list(conditional = "Days") ) expect_equal(find_predictors(m2, effects = "random"), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_null(find_predictors(m2, effects = "all", component = "zi")) expect_null(find_predictors(m2, effects = "fixed", component = "zi")) expect_null(find_predictors(m2, effects = "random", component = "zi")) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "Subject")) expect_equal(find_random(m1, flatten = TRUE), "Subject") expect_equal(find_random(m2), list(random = c("mysubgrp:mygrp", "mygrp", "Subject"))) expect_equal(find_random(m2, split_nested = TRUE), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_equal( find_random(m2, flatten = TRUE), c("mysubgrp:mygrp", "mygrp", "Subject") ) expect_equal( find_random(m2, split_nested = TRUE, flatten = TRUE), c("mysubgrp", "mygrp", "Subject") ) }) test_that("find_response", { expect_identical(find_response(m1), "Reaction") expect_identical(find_response(m2), "Reaction") }) test_that("get_response", { expect_equal(get_response(m1), sleepstudy$Reaction) }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), .2) expect_identical(link_inverse(m2)(.2), .2) }) test_that("get_data", { expect_equal(colnames(get_data(m1)), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "all")), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "random")), "Subject") expect_equal( colnames(get_data(m2)), c("Reaction", "Days", "mygrp", "mysubgrp", "Subject") ) expect_equal( colnames(get_data(m2, effects = "all")), c("Reaction", "Days", "mygrp", "mysubgrp", "Subject") ) expect_equal(colnames(get_data(m2, effects = "random")), c("mysubgrp", "mygrp", "Subject")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_length(find_formula(m2), 2) expect_equal( find_formula(m1, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = as.formula("~1 + Days | Subject") ) ) expect_equal( find_formula(m2, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = list( as.formula("~1 | mysubgrp:mygrp"), as.formula("~1 | mygrp"), as.formula("~1 | Subject") ) ) ) }) test_that("find_terms", { expect_identical( find_terms(m1), list( response = "Reaction", conditional = "Days", random = c("Days", "Subject") ) ) expect_identical( find_terms(m1, flatten = TRUE), c("Reaction", "Days", "Subject") ) expect_identical( find_terms(m2), list( response = "Reaction", conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_identical( find_terms(m2, flatten = TRUE), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = "Reaction", conditional = "Days", random = "Subject" ) ) }) test_that("get_response", { expect_identical(get_response(m1), sleepstudy$Reaction) }) test_that("get_predictors", { expect_identical(colnames(get_predictors(m1)), "Days") expect_identical(colnames(get_predictors(m2)), "Days") }) test_that("get_random", { expect_identical(colnames(get_random(m1)), "Subject") expect_identical(colnames(get_random(m2)), c("mysubgrp", "mygrp", "Subject")) }) test_that("clean_names", { expect_identical(clean_names(m1), c("Reaction", "Days", "Subject")) expect_identical( clean_names(m2), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "Days"), random = list(Subject = c("(Intercept)", "Days")) ) ) expect_equal(nrow(get_parameters(m1)), 2) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "Days")) expect_equal( find_parameters(m2), list( conditional = c("(Intercept)", "Days"), random = list( `mysubgrp:mygrp` = "(Intercept)", Subject = "(Intercept)", mygrp = "(Intercept)" ) ) ) expect_equal(nrow(get_parameters(m2)), 2) expect_equal(get_parameters(m2)$Parameter, c("(Intercept)", "Days")) expect_equal( names(get_parameters(m2, effects = "random")), c("mysubgrp:mygrp", "Subject", "mygrp") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) }) test_that("get_variance", { skip_on_cran() expect_equal( get_variance(m1), list( var.fixed = 908.95336262316459396970, var.random = 1698.23306388298283309268, var.residual = 654.94079585243218843971, var.distribution = 654.94079585243218843971, var.dispersion = 0, var.intercept = c(Subject = 611.89760710463770010392), var.slope = c(Subject.Days = 35.08106944030500073950), cor.slope_intercept = c(Subject = 0.06561803142425107205) ), tolerance = 1e-4 ) expect_equal(get_variance_fixed(m1), c(var.fixed = 908.95336262316459396970), tolerance = 1e-4 ) expect_equal(get_variance_random(m1), c(var.random = 1698.23306388298283309268), tolerance = 1e-4 ) expect_equal( get_variance_residual(m1), c(var.residual = 654.94079585243218843971), tolerance = 1e-4 ) expect_equal( get_variance_distribution(m1), c(var.distribution = 654.94079585243218843971), tolerance = 1e-4 ) expect_equal(get_variance_dispersion(m1), c(var.dispersion = 0), tolerance = 1e-4 ) expect_equal( get_variance_intercept(m1), c(var.intercept.Subject = 611.89760710463770010392), toleance = 1e-4 ) expect_equal( get_variance_slope(m1), c(var.slope.Subject.Days = 35.08106944030500073950), toleance = 1e-4 ) expect_equal( get_correlation_slope_intercept(m1), c(cor.slope_intercept.Subject = 0.06561803), toleance = 1e-4 ) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "REML", optimizer = "nloptwrap") ) }) test_that("find_random_slopes", { expect_equal(find_random_slopes(m1), list(random = "Days")) expect_null(find_random_slopes(m2)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") }) } insight/tests/testthat/test-iv_robust.R0000644000176200001440000000542513552364343020053 0ustar liggesusersif (require("testthat") && require("insight") && require("estimatr")) { context("insight, model_info") data(mtcars) m1 <- iv_robust(mpg ~ gear + cyl | carb + wt, data = mtcars) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( conditional = c("gear", "cyl"), instruments = c("carb", "wt") ) ) expect_identical( find_predictors(m1, component = "instruments"), list(instruments = c("carb", "wt")) ) expect_identical( find_predictors(m1, flatten = TRUE), c("gear", "cyl", "carb", "wt") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "mpg") }) test_that("get_response", { expect_equal(get_response(m1), mtcars$mpg) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("gear", "cyl", "carb", "wt")) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 32) expect_equal( colnames(get_data(m1)), c("mpg", "carb + wt", "gear", "cyl", "carb", "wt") ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("mpg ~ gear + cyl"), instruments = as.formula("~carb + wt") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "mpg", conditional = c("gear", "cyl"), instruments = c("carb", "wt") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("mpg", "gear", "cyl", "carb", "wt") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 32) }) test_that("link_function", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c("(Intercept)", "gear", "cyl")) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "gear", "cyl") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_warning(expect_null(find_algorithm(m1))) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-psm.R0000644000176200001440000000703513552364343016635 0ustar liggesusersif (require("testthat") && require("insight") && require("rms")) { context("insight, rms") n <- 400 set.seed(1) age <- rnorm(n, 50, 12) sex <- factor(sample(c("Female", "Male"), n, TRUE)) # Population hazard function: h <- .02 * exp(.06 * (age - 50) + .8 * (sex == "Female")) d.time <- -log(runif(n)) / h cens <- 15 * runif(n) death <- ifelse(d.time <= cens, 1, 0) d.time <- pmin(d.time, cens) dat <- data.frame(d.time, death, sex, age, stringsAsFactors = FALSE) m1 <- psm(Surv(d.time, death) ~ sex * pol(age, 2), dist = "lognormal", data = dat ) test_that("model_info", { expect_false(model_info(m1)$is_binomial) expect_false(model_info(m1)$is_logit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("sex", "age"))) expect_identical(find_predictors(m1, flatten = TRUE), c("sex", "age")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "Surv(d.time, death)") expect_identical(find_response(m1, combine = FALSE), c("d.time", "death")) }) test_that("get_response", { expect_equal(get_response(m1), dat[, c("d.time", "death")]) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("sex", "age")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 400) expect_equal(colnames(get_data(m1)), c("d.time", "death", "sex", "age")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula( "Surv(d.time, death) ~ sex * pol(age, 2)" )) ) }) test_that("find_terms", { expect_length(find_terms(m1), 2) expect_equal( find_terms(m1), list( response = "Surv(d.time, death)", conditional = c("sex", "pol(age, 2)") ) ) }) test_that("find_variables", { expect_equal(find_variables(m1), list( response = c("d.time", "death"), conditional = c("sex", "age") )) expect_equal( find_variables(m1, flatten = TRUE), c("d.time", "death", "sex", "age") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 400) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("linkinverse", { expect_false(is.null(link_inverse(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "sex=Male", "age", "age^2", "sex=Male * age", "sex=Male * age^2" ) ) ) expect_equal(nrow(get_parameters(m1)), 6) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "sex=Male", "age", "age^2", "sex=Male * age", "sex=Male * age^2" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_warning(find_algorithm(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-speedlm.R0000644000176200001440000001007213552364343017462 0ustar liggesusersif (require("testthat") && require("insight") && require("speedglm")) { context("insight, model_info") data(iris) data(mtcars) m1 <- speedlm(Sepal.Length ~ Petal.Width + Species, data = iris) m2 <- speedlm(log(mpg) ~ log(hp) + cyl + I(cyl^2) + poly(wt, degree = 2, raw = TRUE), data = mtcars ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("Petal.Width", "Species"))) expect_identical( find_predictors(m1, flatten = TRUE), c("Petal.Width", "Species") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "Sepal.Length") }) test_that("get_response", { expect_equal(get_response(m1), iris$Sepal.Length) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("Petal.Width", "Species")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("linkfun", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 150) expect_equal( colnames(get_data(m1)), c("Sepal.Length", "Petal.Width", "Species") ) expect_equal(colnames(get_data(m2)), c("mpg", "hp", "cyl", "wt")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("Sepal.Length ~ Petal.Width + Species")) ) expect_equal( find_formula(m2), list( conditional = as.formula( "log(mpg) ~ log(hp) + cyl + I(cyl^2) + poly(wt, degree = 2, raw = TRUE)" ) ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "Sepal.Length", conditional = c("Petal.Width", "Species") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("Sepal.Length", "Petal.Width", "Species") ) expect_equal( find_variables(m2, flatten = TRUE), c("mpg", "hp", "cyl", "wt") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 150) expect_equal(n_obs(m2), 32) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "Petal.Width", "Speciesversicolor", "Speciesvirginica" ) ) ) expect_equal( find_parameters(m2), list( conditional = c( "(Intercept)", "log(hp)", "cyl", "I(cyl^2)", "poly(wt, degree = 2, raw = TRUE)1", "poly(wt, degree = 2, raw = TRUE)2" ) ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "Petal.Width", "Speciesversicolor", "Speciesvirginica" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "Sepal.Length", conditional = c("Petal.Width", "Species") ) ) expect_equal( find_terms(m2), list( response = "log(mpg)", conditional = c( "log(hp)", "cyl", "I(cyl^2)", "poly(wt, degree = 2, raw = TRUE)" ) ) ) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "eigen")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") }) } insight/tests/testthat/test-mvrstanarm.R0000644000176200001440000006467313602362701020233 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest && Sys.getenv("USER") != "travis") { if (suppressWarnings(require("testthat") && require("insight") && require("rstanarm"))) { context("insight, mv-rstanarm") data("pbcLong") m1 <- download_model("stanmvreg_1") test_that("clean_names", { expect_identical( clean_names(m1), c("logBili", "albumin", "year", "id", "sex") ) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( y1 = list(conditional = "year"), y2 = list(conditional = c("sex", "year")) ) ) expect_identical(find_predictors(m1, flatten = TRUE), c("year", "sex")) expect_identical( find_predictors(m1, effects = "all", component = "all"), list( y1 = list(conditional = "year", random = "id"), y2 = list( conditional = c("sex", "year"), random = "id" ) ) ) expect_identical( find_predictors( m1, effects = "all", component = "all", flatten = TRUE ), c("year", "id", "sex") ) }) test_that("find_response", { expect_equal( find_response(m1, combine = TRUE), c(y1 = "logBili", y2 = "albumin") ) expect_equal( find_response(m1, combine = FALSE), c(y1 = "logBili", y2 = "albumin") ) }) test_that("get_response", { expect_equal(nrow(get_response(m1)), 304) expect_equal(colnames(get_response(m1)), c("logBili", "albumin")) }) test_that("find_statistic", { expect_null(find_statistic(m1)) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = c(y1 = "logBili", y2 = "albumin"), y1 = list(conditional = "year", random = "id"), y2 = list( conditional = c("sex", "year"), random = "id" ) ) ) expect_identical( find_variables(m1, flatten = TRUE), c("logBili", "albumin", "year", "id", "sex") ) expect_identical( find_variables(m1, effects = "random"), list( response = c(y1 = "logBili", y2 = "albumin"), y1 = list(random = "id"), y2 = list(random = "id") ) ) }) test_that("find_terms", { expect_identical( find_terms(m1), list( y1 = list( response = "logBili", conditional = "year", random = "id" ), y2 = list( response = "albumin", conditional = c("sex", "year"), random = c("year", "id") ) ) ) expect_identical( find_terms(m1, flatten = TRUE), c("logBili", "year", "id", "albumin", "sex") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 304) }) test_that("find_paramaters", { expect_equal( find_parameters(m1), structure(list( y1 = list( conditional = c("(Intercept)", "year"), random = sprintf("b[(Intercept) id:%i]", 1:40), sigma = "sigma" ), y2 = list( conditional = c("(Intercept)", "sexf", "year"), random = sprintf( c("b[(Intercept) id:%i]", "b[year id:%i]"), rep(1:40, each = 2) ), sigma = "sigma" ) ), is_mv = "1" ) ) expect_equal( find_parameters(m1, effects = "fixed"), structure(list( y1 = list( conditional = c("(Intercept)", "year"), sigma = "sigma" ), y2 = list( conditional = c("(Intercept)", "sexf", "year"), sigma = "sigma" ) ), is_mv = "1" ) ) expect_equal( find_parameters(m1, effects = "random"), structure(list( y1 = list(random = sprintf("b[(Intercept) id:%i]", 1:40)), y2 = list(random = sprintf( c("b[(Intercept) id:%i]", "b[year id:%i]"), rep(1:40, each = 2) )) ), is_mv = "1" ) ) }) test_that("get_paramaters", { expect_equal( colnames(get_parameters(m1)), c( "y1|(Intercept)", "y1|year", "y2|(Intercept)", "y2|sexf", "y2|year" ) ) expect_equal( colnames(get_parameters(m1, effects = "all")), c( "y1|(Intercept)", "y1|year", sprintf("b[y1|(Intercept) id:%i]", 1:40), "y2|(Intercept)", "y2|sexf", "y2|year", sprintf( c("b[y2|(Intercept) id:%i]", "b[y2|year id:%i]"), rep(1:40, each = 2) ) ) ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_length(link_function(m1), 2) }) test_that("linkinv", { expect_false(is.null(link_inverse(m1))) expect_length(link_inverse(m1), 2) }) test_that("is_multivariate", { expect_true(is_multivariate(m1)) }) test_that("clean_parameters", { expect_identical( clean_parameters(m1), structure( list( Parameter = c( "(Intercept)", "year", "(Intercept)", "sexf", "year", "b[(Intercept) id:1]", "b[(Intercept) id:2]", "b[(Intercept) id:3]", "b[(Intercept) id:4]", "b[(Intercept) id:5]", "b[(Intercept) id:6]", "b[(Intercept) id:7]", "b[(Intercept) id:8]", "b[(Intercept) id:9]", "b[(Intercept) id:10]", "b[(Intercept) id:11]", "b[(Intercept) id:12]", "b[(Intercept) id:13]", "b[(Intercept) id:14]", "b[(Intercept) id:15]", "b[(Intercept) id:16]", "b[(Intercept) id:17]", "b[(Intercept) id:18]", "b[(Intercept) id:19]", "b[(Intercept) id:20]", "b[(Intercept) id:21]", "b[(Intercept) id:22]", "b[(Intercept) id:23]", "b[(Intercept) id:24]", "b[(Intercept) id:25]", "b[(Intercept) id:26]", "b[(Intercept) id:27]", "b[(Intercept) id:28]", "b[(Intercept) id:29]", "b[(Intercept) id:30]", "b[(Intercept) id:31]", "b[(Intercept) id:32]", "b[(Intercept) id:33]", "b[(Intercept) id:34]", "b[(Intercept) id:35]", "b[(Intercept) id:36]", "b[(Intercept) id:37]", "b[(Intercept) id:38]", "b[(Intercept) id:39]", "b[(Intercept) id:40]", "b[(Intercept) id:1]", "b[year id:1]", "b[(Intercept) id:2]", "b[year id:2]", "b[(Intercept) id:3]", "b[year id:3]", "b[(Intercept) id:4]", "b[year id:4]", "b[(Intercept) id:5]", "b[year id:5]", "b[(Intercept) id:6]", "b[year id:6]", "b[(Intercept) id:7]", "b[year id:7]", "b[(Intercept) id:8]", "b[year id:8]", "b[(Intercept) id:9]", "b[year id:9]", "b[(Intercept) id:10]", "b[year id:10]", "b[(Intercept) id:11]", "b[year id:11]", "b[(Intercept) id:12]", "b[year id:12]", "b[(Intercept) id:13]", "b[year id:13]", "b[(Intercept) id:14]", "b[year id:14]", "b[(Intercept) id:15]", "b[year id:15]", "b[(Intercept) id:16]", "b[year id:16]", "b[(Intercept) id:17]", "b[year id:17]", "b[(Intercept) id:18]", "b[year id:18]", "b[(Intercept) id:19]", "b[year id:19]", "b[(Intercept) id:20]", "b[year id:20]", "b[(Intercept) id:21]", "b[year id:21]", "b[(Intercept) id:22]", "b[year id:22]", "b[(Intercept) id:23]", "b[year id:23]", "b[(Intercept) id:24]", "b[year id:24]", "b[(Intercept) id:25]", "b[year id:25]", "b[(Intercept) id:26]", "b[year id:26]", "b[(Intercept) id:27]", "b[year id:27]", "b[(Intercept) id:28]", "b[year id:28]", "b[(Intercept) id:29]", "b[year id:29]", "b[(Intercept) id:30]", "b[year id:30]", "b[(Intercept) id:31]", "b[year id:31]", "b[(Intercept) id:32]", "b[year id:32]", "b[(Intercept) id:33]", "b[year id:33]", "b[(Intercept) id:34]", "b[year id:34]", "b[(Intercept) id:35]", "b[year id:35]", "b[(Intercept) id:36]", "b[year id:36]", "b[(Intercept) id:37]", "b[year id:37]", "b[(Intercept) id:38]", "b[year id:38]", "b[(Intercept) id:39]", "b[year id:39]", "b[(Intercept) id:40]", "b[year id:40]", "sigma", "sigma" ), Effects = c( "fixed", "fixed", "fixed", "fixed", "fixed", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "random", "fixed", "fixed" ), Component = c( "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "conditional", "sigma", "sigma" ), Group = c( "", "", "", "", "", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "Intercept: id", "year: id", "", "" ), Response = c( "y1", "y1", "y2", "y2", "y2", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y1", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y2", "y1", "y2" ), Cleaned_Parameter = c( "(Intercept)", "year", "(Intercept)", "sexf", "year", "id:1", "id:2", "id:3", "id:4", "id:5", "id:6", "id:7", "id:8", "id:9", "id:10", "id:11", "id:12", "id:13", "id:14", "id:15", "id:16", "id:17", "id:18", "id:19", "id:20", "id:21", "id:22", "id:23", "id:24", "id:25", "id:26", "id:27", "id:28", "id:29", "id:30", "id:31", "id:32", "id:33", "id:34", "id:35", "id:36", "id:37", "id:38", "id:39", "id:40", "id:1", "id:1", "id:2", "id:2", "id:3", "id:3", "id:4", "id:4", "id:5", "id:5", "id:6", "id:6", "id:7", "id:7", "id:8", "id:8", "id:9", "id:9", "id:10", "id:10", "id:11", "id:11", "id:12", "id:12", "id:13", "id:13", "id:14", "id:14", "id:15", "id:15", "id:16", "id:16", "id:17", "id:17", "id:18", "id:18", "id:19", "id:19", "id:20", "id:20", "id:21", "id:21", "id:22", "id:22", "id:23", "id:23", "id:24", "id:24", "id:25", "id:25", "id:26", "id:26", "id:27", "id:27", "id:28", "id:28", "id:29", "id:29", "id:30", "id:30", "id:31", "id:31", "id:32", "id:32", "id:33", "id:33", "id:34", "id:34", "id:35", "id:35", "id:36", "id:36", "id:37", "id:37", "id:38", "id:38", "id:39", "id:39", "id:40", "id:40", "sigma", "sigma" ) ), class = c("clean_parameters", "data.frame"), row.names = c(NA, -127L) ) ) }) } } insight/tests/testthat/test-rlmer.R0000644000176200001440000002253013552364343017154 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest) { if (require("testthat") && require("insight") && require("lme4") && require("robustlmm")) { context("insight, find_predictors") data(sleepstudy) set.seed(123) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE ) } m1 <- rlmer( Reaction ~ Days + (Days | Subject), data = sleepstudy, rho.sigma.e = psi2propII(smoothPsi, k = 2.28), rho.sigma.b = chgDefaults(smoothPsi, k = 5.11, s = 10) ) m2 <- rlmer( Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy, rho.sigma.e = psi2propII(smoothPsi, k = 2.28), rho.sigma.b = chgDefaults(smoothPsi, k = 5.11, s = 10) ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m2)$is_linear) }) test_that("find_predictors", { expect_equal( find_predictors(m1, effects = "all"), list(conditional = "Days", random = "Subject") ) expect_equal( find_predictors(m1, effects = "all", flatten = TRUE), c("Days", "Subject") ) expect_equal( find_predictors(m1, effects = "fixed"), list(conditional = "Days") ) expect_equal( find_predictors(m1, effects = "fixed", flatten = TRUE), "Days" ) expect_equal( find_predictors(m1, effects = "random"), list(random = "Subject") ) expect_equal( find_predictors(m1, effects = "random", flatten = TRUE), "Subject" ) expect_equal( find_predictors(m2, effects = "all"), list( conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_equal( find_predictors(m2, effects = "all", flatten = TRUE), c("Days", "mysubgrp", "mygrp", "Subject") ) expect_equal( find_predictors(m2, effects = "fixed"), list(conditional = "Days") ) expect_equal(find_predictors(m2, effects = "random"), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_null(find_predictors(m2, effects = "all", component = "zi")) expect_null(find_predictors(m2, effects = "fixed", component = "zi")) expect_null(find_predictors(m2, effects = "random", component = "zi")) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "Subject")) expect_equal(find_random(m1, flatten = TRUE), "Subject") expect_equal(find_random(m2), list(random = c( "mysubgrp:mygrp", "mygrp", "Subject" ))) expect_equal(find_random(m2, split_nested = TRUE), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_equal( find_random(m2, flatten = TRUE), c("mysubgrp:mygrp", "mygrp", "Subject") ) expect_equal( find_random(m2, split_nested = TRUE, flatten = TRUE), c("mysubgrp", "mygrp", "Subject") ) }) test_that("find_response", { expect_identical(find_response(m1), "Reaction") expect_identical(find_response(m2), "Reaction") }) test_that("get_response", { expect_equal(get_response(m1), sleepstudy$Reaction) }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), .2) expect_identical(link_inverse(m2)(.2), .2) }) test_that("get_data", { expect_equal(colnames(get_data(m1)), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "all")), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "random")), "Subject") expect_equal( colnames(get_data(m2)), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) expect_equal( colnames(get_data(m2, effects = "all")), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) expect_equal(colnames(get_data(m2, effects = "random")), c("mysubgrp", "mygrp", "Subject")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_length(find_formula(m2), 2) expect_equal( find_formula(m1, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = as.formula("~Days | Subject") ) ) expect_equal( find_formula(m2, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = list( as.formula("~1 | mysubgrp:mygrp"), as.formula("~1 | mygrp"), as.formula("~1 | Subject") ) ) ) }) test_that("find_terms", { expect_identical( find_terms(m1), list( response = "Reaction", conditional = "Days", random = c("Days", "Subject") ) ) expect_identical( find_terms(m1, flatten = TRUE), c("Reaction", "Days", "Subject") ) expect_identical( find_terms(m2), list( response = "Reaction", conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_identical( find_terms(m2, flatten = TRUE), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = "Reaction", conditional = "Days", random = "Subject" ) ) }) test_that("get_response", { expect_identical(get_response(m1), sleepstudy$Reaction) }) test_that("get_predictors", { expect_identical(colnames(get_predictors(m1)), "Days") expect_identical(colnames(get_predictors(m2)), "Days") }) test_that("get_random", { expect_identical(colnames(get_random(m1)), "Subject") expect_identical( colnames(get_random(m2)), c("mysubgrp", "mygrp", "Subject") ) }) test_that("clean_names", { expect_identical(clean_names(m1), c("Reaction", "Days", "Subject")) expect_identical( clean_names(m2), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "Days"), random = list(Subject = c("(Intercept)", "Days")) ) ) expect_equal(nrow(get_parameters(m1)), 2) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "Days")) expect_equal( find_parameters(m2), list( conditional = c("(Intercept)", "Days"), random = list( `mysubgrp:mygrp` = "(Intercept)", Subject = "(Intercept)", mygrp = "(Intercept)" ) ) ) expect_equal(nrow(get_parameters(m2)), 2) expect_equal(get_parameters(m2)$Parameter, c("(Intercept)", "Days")) expect_equal( names(get_parameters(m2, effects = "random")), c("mysubgrp:mygrp", "Subject", "mygrp") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) }) test_that("get_variance", { skip_on_cran() skip_on_travis() expect_equal( get_variance(m1), list( var.fixed = 972.98333873885542288917, var.random = 1909.82627106414997797401, var.residual = 401.79840084390571064432, var.distribution = 401.79840084390571064432, var.dispersion = 0, var.intercept = c(Subject = 750.51639089692923789698), var.slope = c(Subject.Days = 41.06728604073937560770), cor.slope_intercept = c(Subject = -0.00703001666895963079) ), tolerance = 1e-4 ) expect_equal( get_variance(m2), list( var.fixed = 914.841369525452, var.random = 1406.78220090082, var.residual = 809.318117324236, var.distribution = 809.318117324236, var.dispersion = 0, var.intercept = c( `mysubgrp:mygrp` = 0, Subject = 1390.66848951126, mygrp = 16.113711389561 ) ), tolerance = 1e-4 ) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "REML", optimizer = "rlmer.fit.DAS.nondiag") ) }) test_that("find_random_slopes", { expect_equal(find_random_slopes(m1), list(random = "Days")) expect_null(find_random_slopes(m2)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") }) } } insight/tests/testthat/test-mixed.R0000644000176200001440000002233113552364343017140 0ustar liggesusersif (require("testthat") && require("insight") && require("lme4") && require("afex")) { context("insight, find_predictors") data(sleepstudy) set.seed(123) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } m1 <- mixed(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy ) m2 <- mixed(Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), data = sleepstudy ) test_that("model_info", { expect_true(model_info(m1)$is_linear) expect_true(model_info(m2)$is_linear) }) test_that("find_predictors", { expect_equal( find_predictors(m1, effects = "all"), list(conditional = "Days", random = "Subject") ) expect_equal( find_predictors(m1, effects = "all", flatten = TRUE), c("Days", "Subject") ) expect_equal( find_predictors(m1, effects = "fixed"), list(conditional = "Days") ) expect_equal( find_predictors(m1, effects = "fixed", flatten = TRUE), "Days" ) expect_equal( find_predictors(m1, effects = "random"), list(random = "Subject") ) expect_equal( find_predictors(m1, effects = "random", flatten = TRUE), "Subject" ) expect_equal( find_predictors(m2, effects = "all"), list( conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_equal( find_predictors(m2, effects = "all", flatten = TRUE), c("Days", "mysubgrp", "mygrp", "Subject") ) expect_equal( find_predictors(m2, effects = "fixed"), list(conditional = "Days") ) expect_equal(find_predictors(m2, effects = "random"), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_null(find_predictors(m2, effects = "all", component = "zi")) expect_null(find_predictors(m2, effects = "fixed", component = "zi")) expect_null(find_predictors(m2, effects = "random", component = "zi")) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "Subject")) expect_equal(find_random(m1, flatten = TRUE), "Subject") expect_equal(find_random(m2), list(random = c("mysubgrp:mygrp", "mygrp", "Subject"))) expect_equal(find_random(m2, split_nested = TRUE), list(random = c("mysubgrp", "mygrp", "Subject"))) expect_equal( find_random(m2, flatten = TRUE), c("mysubgrp:mygrp", "mygrp", "Subject") ) expect_equal( find_random(m2, split_nested = TRUE, flatten = TRUE), c("mysubgrp", "mygrp", "Subject") ) }) test_that("find_response", { expect_identical(find_response(m1), "Reaction") expect_identical(find_response(m2), "Reaction") }) test_that("get_response", { expect_equal(get_response(m1), sleepstudy$Reaction) }) test_that("link_inverse", { expect_identical(link_inverse(m1)(.2), .2) expect_identical(link_inverse(m2)(.2), .2) }) test_that("get_data", { expect_equal(colnames(get_data(m1)), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "all")), c("Reaction", "Days", "Subject")) expect_equal(colnames(get_data(m1, effects = "random")), "Subject") expect_equal( colnames(get_data(m2)), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) expect_equal( colnames(get_data(m2, effects = "all")), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) expect_equal(colnames(get_data(m2, effects = "random")), c("mysubgrp", "mygrp", "Subject")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_length(find_formula(m2), 2) expect_equal( find_formula(m1, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = as.formula("~1 + Days | Subject") ) ) expect_equal( find_formula(m2, component = "conditional"), list( conditional = as.formula("Reaction ~ Days"), random = list( as.formula("~1 | mysubgrp:mygrp"), as.formula("~1 | mygrp"), as.formula("~1 | Subject") ) ) ) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = "Reaction", conditional = "Days", random = "Subject" ) ) expect_identical( find_variables(m1, flatten = TRUE), c("Reaction", "Days", "Subject") ) expect_identical( find_variables(m2), list( response = "Reaction", conditional = "Days", random = c("mysubgrp", "mygrp", "Subject") ) ) expect_identical( find_variables(m2, flatten = TRUE), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("get_response", { expect_identical(get_response(m1), sleepstudy$Reaction) }) test_that("get_predictors", { expect_identical(colnames(get_predictors(m1)), "Days") expect_identical(colnames(get_predictors(m2)), "Days") }) test_that("get_random", { expect_identical(colnames(get_random(m1)), "Subject") expect_identical(colnames(get_random(m2)), c("mysubgrp", "mygrp", "Subject")) }) test_that("clean_names", { expect_identical(clean_names(m1), c("Reaction", "Days", "Subject")) expect_identical( clean_names(m2), c("Reaction", "Days", "mysubgrp", "mygrp", "Subject") ) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) expect_false(is.null(link_function(m2))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "Days"), random = list(Subject = c("(Intercept)", "Days")) ) ) expect_equal(nrow(get_parameters(m1)), 2) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "Days")) expect_equal( find_parameters(m2), list( conditional = c("(Intercept)", "Days"), random = list( `mysubgrp:mygrp` = "(Intercept)", Subject = "(Intercept)", mygrp = "(Intercept)" ) ) ) expect_equal(nrow(get_parameters(m2)), 2) expect_equal(get_parameters(m2)$Parameter, c("(Intercept)", "Days")) expect_equal( names(get_parameters(m2, effects = "random")), c("mysubgrp:mygrp", "Subject", "mygrp") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) expect_false(is_multivariate(m2)) }) test_that("get_variance", { skip_on_cran() skip_on_travis() expect_equal( get_variance(m1), list( var.fixed = 908.95336262316459396970, var.random = 1698.23306388298283309268, var.residual = 654.94079585243218843971, var.distribution = 654.94079585243218843971, var.dispersion = 0, var.intercept = c(Subject = 611.89760710463770010392), var.slope = c(Subject.Days = 35.08106944030500073950), cor.slope_intercept = c(Subject = 0.06561803142425107205) ), tolerance = 1e-4 ) expect_equal(get_variance_fixed(m1), c(var.fixed = 908.95336262316459396970), tolerance = 1e-4 ) expect_equal(get_variance_random(m1), c(var.random = 1698.23306388298283309268), tolerance = 1e-4 ) expect_equal( get_variance_residual(m1), c(var.residual = 654.94079585243218843971), tolerance = 1e-4 ) expect_equal( get_variance_distribution(m1), c(var.distribution = 654.94079585243218843971), tolerance = 1e-4 ) expect_equal(get_variance_dispersion(m1), c(var.dispersion = 0), tolerance = 1e-4 ) expect_equal( get_variance_intercept(m1), c(var.intercept.Subject = 611.89760710463770010392), toleance = 1e-4 ) expect_equal( get_variance_slope(m1), c(var.slope.Subject.Days = 35.08106944030500073950), toleance = 1e-4 ) expect_equal( get_correlation_slope_intercept(m1), c(cor.slope_intercept.Subject = 0.06561803), toleance = 1e-4 ) expect_warning(expect_equal( get_variance(m2), list( var.fixed = 889.329700216337, var.residual = 941.817768377025, var.distribution = 941.817768377025, var.dispersion = 0, var.intercept = c( `mysubgrp:mygrp` = 0, Subject = 1357.35782386825, mygrp = 24.4073139080596 ) ), tolerance = 1e-4, )) }) test_that("find_algorithm", { expect_equal( find_algorithm(m1), list(algorithm = "REML", optimizer = "nloptwrap") ) }) test_that("find_random_slopes", { expect_equal(find_random_slopes(m1), list(random = "Days")) expect_null(find_random_slopes(m2)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") expect_identical(find_statistic(m2), "t-statistic") }) } insight/tests/testthat/test-vglm.R0000644000176200001440000000554013552364343017002 0ustar liggesusersunloadNamespace("gam") if (require("testthat") && require("insight") && require("VGAM")) { context("insight, model_info") d.AD <- data.frame( treatment = gl(3, 3), outcome = gl(3, 1, 9), counts = c(18, 17, 15, 20, 10, 20, 25, 13, 12) ) m1 <- vglm( counts ~ outcome + treatment, family = poissonff, data = d.AD, trace = TRUE ) test_that("model_info", { expect_true(model_info(m1)$is_poisson) expect_false(model_info(m1)$is_bayesian) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("outcome", "treatment"))) expect_identical( find_predictors(m1, flatten = TRUE), c("outcome", "treatment") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "counts") }) test_that("get_response", { expect_equal(get_response(m1), d.AD$counts) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("outcome", "treatment")) }) li <- suppressWarnings(link_inverse(m1)(.2)[1, 1]) test_that("link_inverse", { expect_equal(li, exp(.2), tolerance = 1e-5) expect_warning(link_inverse(m1)(.2)) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 9) expect_equal(colnames(get_data(m1)), c("counts", "outcome", "treatment")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("counts ~ outcome + treatment")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "counts", conditional = c("outcome", "treatment") )) expect_equal( find_terms(m1, flatten = TRUE), c("counts", "outcome", "treatment") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 9) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "(Intercept)", "outcome2", "outcome3", "treatment2", "treatment3" ) ) ) expect_equal(nrow(get_parameters(m1)), 5) expect_equal( get_parameters(m1)$Parameter, c( "(Intercept)", "outcome2", "outcome3", "treatment2", "treatment3" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-rms.R0000644000176200001440000000462313552364343016637 0ustar liggesusersif (require("testthat") && require("insight") && require("rms")) { context("insight, model_info") data(mtcars) m1 <- lrm(am ~ mpg + gear, data = mtcars) test_that("model_info", { expect_true(model_info(m1)$is_binomial) expect_true(model_info(m1)$is_logit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("mpg", "gear"))) expect_identical(find_predictors(m1, flatten = TRUE), c("mpg", "gear")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "am") }) test_that("get_response", { expect_equal(get_response(m1), mtcars$am) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("mpg", "gear")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 32) expect_equal(colnames(get_data(m1)), c("am", "mpg", "gear")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("am ~ mpg + gear")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "am", conditional = c("mpg", "gear") )) expect_equal(find_terms(m1, flatten = TRUE), c("am", "mpg", "gear")) }) test_that("n_obs", { expect_equal(n_obs(m1), 32) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("linkinverse", { expect_false(is.null(link_inverse(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c("Intercept", "mpg", "gear")) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("Intercept", "mpg", "gear") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-LORgee.R0000644000176200001440000000752413615534722017156 0ustar liggesusersif (require("testthat") && require("insight") && require("multgee")) { context("insight, multgee") data(arthritis) m1 <- ordLORgee( y ~ factor(time) + factor(trt) + factor(baseline), data = arthritis, id = id, LORstr = "uniform", repeated = time ) test_that("model_info", { expect_true(model_info(m1)$is_ordinal) expect_false(model_info(m1)$is_multinomial) expect_true(model_info(m1)$is_logit) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("time", "trt", "baseline"))) expect_identical( find_predictors(m1, flatten = TRUE), c("time", "trt", "baseline") ) expect_identical(find_predictors(m1, effects = "random"), list(random = "id")) expect_identical( find_predictors(m1, effects = "all", flatten = TRUE), c("time", "trt", "baseline", "id") ) }) test_that("find_response", { expect_identical(find_response(m1), "y") }) test_that("get_response", { expect_equal(get_response(m1), na.omit(arthritis)$y) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "id")) }) test_that("get_random", { expect_equal(get_random(m1), arthritis[, "id", drop = FALSE]) }) test_that("get_predictors", { expect_equal(get_predictors(m1), na.omit(arthritis)[, c("time", "trt", "baseline"), drop = FALSE]) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), plogis(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 888) expect_equal( colnames(get_data(m1)), c("y", "time", "trt", "baseline", "id") ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("y ~ factor(time) + factor(trt) + factor(baseline)"), random = as.formula("~id") ) ) }) test_that("find_terms", { expect_length(find_terms(m1), 3) expect_equal( find_terms(m1), list( response = "y", conditional = c("factor(time)", "factor(trt)", "factor(baseline)"), random = "id" ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "y", conditional = c("time", "trt", "baseline"), random = "id" ) ) expect_equal( find_variables(m1, flatten = TRUE), c("y", "time", "trt", "baseline", "id") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 888) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "beta10", "beta20", "beta30", "beta40", "factor(time)3", "factor(time)5", "factor(trt)2", "factor(baseline)2", "factor(baseline)3", "factor(baseline)4", "factor(baseline)5" ) ) ) expect_equal(nrow(get_parameters(m1)), 11) expect_equal( get_parameters(m1)$Parameter, c( "beta10", "beta20", "beta30", "beta40", "factor(time)3", "factor(time)5", "factor(trt)2", "factor(baseline)2", "factor(baseline)3", "factor(baseline)4", "factor(baseline)5" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "Fisher's scoring ML")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-hurdle.R0000644000176200001440000000615413552364343017322 0ustar liggesusersif (require("testthat") && require("insight") && require("pscl")) { context("insight, model_info") data("bioChemists") m1 <- hurdle(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists) test_that("model_info", { expect_true(model_info(m1)$is_poisson) expect_true(model_info(m1)$is_zero_inflated) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( conditional = c("fem", "mar", "kid5", "ment"), zero_inflated = c("kid5", "phd") ) ) expect_identical( find_predictors(m1, flatten = TRUE), c("fem", "mar", "kid5", "ment", "phd") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "art") }) test_that("get_response", { expect_equal(get_response(m1), bioChemists$art) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 915) expect_equal( colnames(get_data(m1)), c("art", "fem", "mar", "kid5", "ment", "phd") ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("art ~ fem + mar + kid5 + ment"), zero_inflated = as.formula("~kid5 + phd") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "art", conditional = c("fem", "mar", "kid5", "ment"), zero_inflated = c("kid5", "phd") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("art", "fem", "mar", "kid5", "ment", "phd") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 915) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "count_(Intercept)", "count_femWomen", "count_marMarried", "count_kid5", "count_ment" ), zero_inflated = c("zero_(Intercept)", "zero_kid5", "zero_phd") ) ) expect_equal(nrow(get_parameters(m1)), 8) expect_equal(nrow(get_parameters(m1, component = "zi")), 3) expect_equal( get_parameters(m1)$Parameter, c( "count_(Intercept)", "count_femWomen", "count_marMarried", "count_kid5", "count_ment", "zero_(Intercept)", "zero_kid5", "zero_phd" ) ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "art", conditional = c("fem", "mar", "kid5", "ment"), zero_inflated = c("kid5", "phd") ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-rq.R0000644000176200001440000000517713552364343016465 0ustar liggesusersif (require("testthat") && require("insight") && require("quantreg")) { context("insight, model_info") data(stackloss) m1 <- rq(stack.loss ~ Air.Flow + Water.Temp, data = stackloss, tau = .25 ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list(conditional = c("Air.Flow", "Water.Temp")) ) expect_identical( find_predictors(m1, flatten = TRUE), c("Air.Flow", "Water.Temp") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "stack.loss") }) test_that("get_response", { expect_equal(get_response(m1), stackloss$stack.loss) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("Air.Flow", "Water.Temp")) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 21) expect_equal( colnames(get_data(m1)), c("stack.loss", "Air.Flow", "Water.Temp") ) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("stack.loss ~ Air.Flow + Water.Temp")) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "stack.loss", conditional = c("Air.Flow", "Water.Temp") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("stack.loss", "Air.Flow", "Water.Temp") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 21) }) test_that("link_function", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c( "(Intercept)", "Air.Flow", "Water.Temp" )) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "Air.Flow", "Water.Temp") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_equal(find_algorithm(m1), list(algorithm = "br")) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-zeroinfl.R0000644000176200001440000000531413552364343017664 0ustar liggesusersif (require("testthat") && require("insight") && require("pscl")) { context("insight, model_info") data("bioChemists") m1 <- zeroinfl(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists) test_that("model_info", { expect_true(model_info(m1)$is_poisson) expect_true(model_info(m1)$is_zero_inflated) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( conditional = c("fem", "mar", "kid5", "ment"), zero_inflated = c("kid5", "phd") ) ) expect_identical( find_predictors(m1, flatten = TRUE), c("fem", "mar", "kid5", "ment", "phd") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "art") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 915) expect_equal( colnames(get_data(m1)), c("art", "fem", "mar", "kid5", "ment", "phd") ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("art ~ fem + mar + kid5 + ment"), zero_inflated = as.formula("~kid5 + phd") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "art", conditional = c("fem", "mar", "kid5", "ment"), zero_inflated = c("kid5", "phd") ) ) expect_equal( find_terms(m1, flatten = TRUE), c("art", "fem", "mar", "kid5", "ment", "phd") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 915) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c( "count_(Intercept)", "count_femWomen", "count_marMarried", "count_kid5", "count_ment" ), zero_inflated = c("zero_(Intercept)", "zero_kid5", "zero_phd") ) ) expect_equal(nrow(get_parameters(m1)), 8) expect_equal(nrow(get_parameters(m1, component = "zi")), 3) expect_equal( get_parameters(m1)$Parameter, c( "count_(Intercept)", "count_femWomen", "count_marMarried", "count_kid5", "count_ment", "zero_(Intercept)", "zero_kid5", "zero_phd" ) ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "z-statistic") }) } insight/tests/testthat/test-data.frame.R0000644000176200001440000000053013531007236020021 0ustar liggesusersif (require("testthat") && require("insight")) { context("insight, data.frame") data(iris) test_that("find_parameters", { expect_error(find_parameters(iris)) }) test_that("find_formula", { expect_error(find_formula(iris)) }) test_that("find_statistic", { expect_error(find_statistic(iris)) }) } insight/tests/testthat/test-lm_robust.R0000644000176200001440000000471713552364343020050 0ustar liggesusersif (require("testthat") && require("insight") && require("estimatr")) { context("insight, model_info") data(mtcars) m1 <- lm_robust(mpg ~ gear + wt + cyl, data = mtcars) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("gear", "wt", "cyl"))) expect_identical(find_predictors(m1, flatten = TRUE), c("gear", "wt", "cyl")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "mpg") }) test_that("get_response", { expect_equal(get_response(m1), mtcars$mpg) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), c("gear", "wt", "cyl")) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 32) expect_equal(colnames(get_data(m1)), c("mpg", "gear", "wt", "cyl")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("mpg ~ gear + wt + cyl")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list( response = "mpg", conditional = c("gear", "wt", "cyl") )) expect_equal(find_terms(m1, flatten = TRUE), c("mpg", "gear", "wt", "cyl")) }) test_that("n_obs", { expect_equal(n_obs(m1), 32) }) test_that("link_function", { expect_equal(link_function(m1)(.2), .2, tolerance = 1e-5) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list(conditional = c("(Intercept)", "gear", "wt", "cyl")) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "gear", "wt", "cyl") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_algorithm", { expect_warning(expect_null(find_algorithm(m1))) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-cpglmm.R0000644000176200001440000001012113602213235017270 0ustar liggesusersif (require("testthat") && require("insight") && require("cplm")) { data("FineRoot") m1 <- cpglmm(RLD ~ Stock + Spacing + (1 | Plant), data = FineRoot) test_that("model_info", { expect_true(model_info(m1)$is_count) }) test_that("find_predictors", { expect_equal( find_predictors(m1, effects = "all"), list(conditional = c("Stock", "Spacing"), random = "Plant") ) expect_equal( find_predictors(m1, effects = "all", flatten = TRUE), c("Stock", "Spacing", "Plant") ) expect_equal( find_predictors(m1, effects = "fixed"), list(conditional = c("Stock", "Spacing")) ) expect_equal( find_predictors(m1, effects = "fixed", flatten = TRUE), c("Stock", "Spacing") ) expect_equal( find_predictors(m1, effects = "random"), list(random = "Plant") ) expect_equal( find_predictors(m1, effects = "random", flatten = TRUE), "Plant" ) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "Plant")) expect_equal(find_random(m1, flatten = TRUE), "Plant") }) test_that("find_response", { expect_identical(find_response(m1), "RLD") }) test_that("get_response", { expect_equal(get_response(m1), FineRoot$RLD) }) test_that("get_data", { expect_equal(colnames(get_data(m1)), c("RLD", "Stock", "Spacing", "Plant")) expect_equal(colnames(get_data(m1, effects = "all")), c("RLD", "Stock", "Spacing", "Plant")) expect_equal(colnames(get_data(m1, effects = "random")), "Plant") }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1, component = "conditional"), list( conditional = as.formula("RLD ~ Stock + Spacing"), random = as.formula("~1 | Plant") ) ) }) test_that("find_terms", { expect_identical( find_terms(m1), list( response = "RLD", conditional = c("Stock", "Spacing"), random = "Plant" ) ) expect_identical( find_terms(m1, flatten = TRUE), c("RLD", "Stock", "Spacing", "Plant") ) }) test_that("link_function", { expect_equal(link_function(m1)(.2), log(.2), tolerance = 1e-3) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-3) }) test_that("find_variables", { expect_identical( find_variables(m1), list( response = "RLD", conditional = c("Stock", "Spacing"), random = "Plant" ) ) expect_identical( find_variables(m1, flatten = TRUE), c("RLD", "Stock", "Spacing", "Plant") ) }) test_that("get_predictors", { expect_identical(colnames(get_predictors(m1)), c("Stock", "Spacing")) }) test_that("get_random", { expect_identical(colnames(get_random(m1)), "Plant") }) test_that("clean_names", { expect_identical(clean_names(m1), c("RLD", "Stock", "Spacing", "Plant")) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "StockMM106", "StockMark", "Spacing5x3"), random = list(Plant = c("(Intercept)")) ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "StockMM106", "StockMark", "Spacing5x3")) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("get_variance", { skip_on_cran() skip_on_travis() expect_equal( get_variance(m1), list( var.fixed = 0.1687617, var.random = 0.0002706301, var.residual = 2.763129, var.distribution = 2.763129, var.dispersion = 0, var.intercept = c(Plant = 0.0002706301) ), tolerance = 1e-3 ) }) test_that("find_random_slopes", { expect_null(find_random_slopes(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-ivreg.R0000644000176200001440000000703313552364343017150 0ustar liggesusersif (require("testthat") && require("insight") && require("AER")) { context("insight, model_info") data(CigarettesSW) CigarettesSW$rprice <- with(CigarettesSW, price / cpi) CigarettesSW$rincome <- with(CigarettesSW, income / population / cpi) CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax) / cpi) m1 <- ivreg( log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax / cpi), data = CigarettesSW, subset = year == "1995" ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list( conditional = c("rprice", "rincome"), instruments = c("rincome", "tdiff", "tax", "cpi") ) ) expect_identical( find_predictors(m1, flatten = TRUE), c("rprice", "rincome", "tdiff", "tax", "cpi") ) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_random", { expect_null(find_random(m1)) }) test_that("get_random", { expect_warning(get_random(m1)) }) test_that("find_response", { expect_identical(find_response(m1), "packs") }) test_that("get_response", { expect_equal(get_response(m1), log(CigarettesSW$packs[CigarettesSW$year == "1995"])) }) test_that("get_predictors", { expect_equal( colnames(get_predictors(m1)), c("rprice", "rincome", "tdiff", "tax", "cpi") ) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 48) expect_equal( colnames(get_data(m1)), c("packs", "rprice", "rincome", "tdiff", "tax", "cpi") ) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("log(packs) ~ log(rprice) + log(rincome)"), instruments = as.formula("~log(rincome) + tdiff + I(tax/cpi)") ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "packs", conditional = c("rprice", "rincome"), instruments = c("rincome", "tdiff", "tax", "cpi") ) ) expect_equal( find_variables(m1, flatten = TRUE), c("packs", "rprice", "rincome", "tdiff", "tax", "cpi") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 48) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "log(rprice)", "log(rincome)") ) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "log(rprice)", "log(rincome)") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "log(packs)", conditional = c("log(rprice)", "log(rincome)"), instruments = c("log(rincome)", "tdiff", "I(tax/cpi)") ) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "log(rprice)", "log(rincome)") ) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-MCMCglmm.R0000644000176200001440000000505613552364343017433 0ustar liggesusersif (require("testthat") && require("insight") && require("MCMCglmm")) { context("insight, model_info") data(PlodiaPO) m1 <- MCMCglmm( PO ~ plate, random = ~FSfamily, data = PlodiaPO, verbose = FALSE, nitt = 1300, burnin = 300, thin = 1 ) test_that("model_info", { expect_true(model_info(m1)$is_mixed) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = "plate")) expect_identical(find_predictors(m1, flatten = TRUE), "plate") expect_identical( find_predictors(m1, effects = "random"), list(random = "FSfamily") ) }) test_that("find_random", { expect_equal(find_random(m1), list(random = "FSfamily")) }) test_that("get_random", { expect_equal(get_random(m1), data.frame(FSfamily = PlodiaPO$FSfamily)) }) test_that("find_response", { expect_identical(find_response(m1), "PO") }) test_that("get_response", { expect_equal(get_response(m1), PlodiaPO$PO) }) test_that("get_predictors", { expect_equal(colnames(get_predictors(m1)), "plate") }) test_that("link_inverse", { expect_null(link_inverse(m1)) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 511) expect_equal(colnames(get_data(m1)), c("FSfamily", "PO", "plate")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("PO ~ plate"), random = as.formula("~FSfamily") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "PO", conditional = "plate", random = "FSfamily" ) ) expect_equal(find_terms(m1, flatten = TRUE), c("PO", "plate", "FSfamily")) }) test_that("n_obs", { expect_null(n_obs(m1)) }) test_that("linkfun", { expect_null(link_function(m1)) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "plate"), random = "FSfamily" ) ) expect_equal(nrow(get_parameters(m1)), 2) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "plate")) expect_equal( get_parameters(m1, effects = "random")$Parameter, "FSfamily" ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_null(find_statistic(m1)) }) } insight/tests/testthat/test-gls.R0000644000176200001440000000521213572501701016607 0ustar liggesusersif (require("testthat") && require("insight") && require("nlme")) { data(Ovary) m1 <- gls(follicles ~ sin(2 * pi * Time) + cos(2 * pi * Time), Ovary, correlation = corAR1(form = ~ 1 | Mare) ) test_that("model_info", { expect_true(model_info(m1)$is_linear) }) test_that("find_predictors", { expect_identical( find_predictors(m1), list(conditional = "Time", correlation = "Mare") ) expect_identical(find_predictors(m1, flatten = TRUE), c("Time", "Mare")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "follicles") }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), .2, tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 308) expect_equal(colnames(get_data(m1)), c("Mare", "Time", "follicles")) }) test_that("find_formula", { expect_length(find_formula(m1), 2) expect_equal( find_formula(m1), list( conditional = as.formula("follicles ~ sin(2 * pi * Time) + cos(2 * pi * Time)"), correlation = as.formula("~1 | Mare") ) ) }) test_that("find_terms", { expect_equal( find_terms(m1), list( response = "follicles", conditional = c("sin(2 * pi * Time)", "cos(2 * pi * Time)"), correlation = c("1", "Mare") ) ) expect_equal( find_terms(m1, flatten = TRUE), c( "follicles", "sin(2 * pi * Time)", "cos(2 * pi * Time)", "1", "Mare" ) ) }) test_that("find_variables", { expect_equal( find_variables(m1), list( response = "follicles", conditional = "Time", correlation = "Mare" ) ) expect_equal( find_variables(m1, flatten = TRUE), c("follicles", "Time", "Mare") ) }) test_that("n_obs", { expect_equal(n_obs(m1), 308) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = c("(Intercept)", "sin(2 * pi * Time)", "cos(2 * pi * Time)") ) ) expect_equal(nrow(get_parameters(m1)), 3) expect_equal( get_parameters(m1)$Parameter, c("(Intercept)", "sin(2 * pi * Time)", "cos(2 * pi * Time)") ) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) test_that("find_statistic", { expect_identical(find_statistic(m1), "t-statistic") }) } insight/tests/testthat/test-clean_names.R0000644000176200001440000000724013603567561020305 0ustar liggesusersif (require("testthat") && require("insight")) { context("insight, clean_names") test_that("clean_names", { expect_equal(clean_names(""), "") expect_equal(clean_names("as.factor(test)"), "test") expect_equal(clean_names("log(test)"), "test") expect_equal(clean_names("log(test, base = exp(3))"), "test") expect_equal(clean_names("log(test,base=exp(3))"), "test") expect_equal(clean_names("log(test/10)"), "test") expect_equal(clean_names("log(test^2)"), "test") expect_equal(clean_names("log(log(test))"), "test") expect_equal(clean_names("log(log(test/10))"), "test") expect_equal(clean_names("log(log(test*2))"), "test") expect_equal(clean_names("scale(log(Days1))"), "Days1") expect_equal(clean_names("I(test^2)"), "test") expect_equal(clean_names("I(test/10)"), "test") expect_equal(clean_names("I(test ^ 2)"), "test") expect_equal(clean_names("I(test / 10)"), "test") expect_equal(clean_names("poly(test, 2)"), "test") expect_equal(clean_names("poly(test, degrees = 2)"), "test") expect_equal(clean_names("poly(test, degrees = 2, raw = TRUE)"), "test") expect_equal(clean_names("ns(test)"), "test") expect_equal(clean_names("ns(test, df = 2)"), "test") expect_equal(clean_names("bs(test)"), "test") expect_equal(clean_names("bs(test, df = 2)"), "test") expect_equal(clean_names("offset(test)"), "test") expect_equal(clean_names("offset(log(test))"), "test") expect_equal(clean_names("factor(test)"), "test") expect_equal(clean_names("as.factor(test)"), "test") expect_equal(clean_names("~ 1 | test"), "test") expect_equal(clean_names("~1|test"), "test") expect_equal(clean_names("1 | test"), "test") expect_equal(clean_names("as.factor(Sepal.Length)"), "Sepal.Length") expect_equal(clean_names("log(Sepal.Length)"), "Sepal.Length") expect_equal(clean_names("log(Sepal.Length, base = exp(3))"), "Sepal.Length") expect_equal(clean_names("log(Sepal.Length,base=exp(3))"), "Sepal.Length") expect_equal(clean_names("log(Sepal.Length/10)"), "Sepal.Length") expect_equal(clean_names("log(Sepal.Length^2)"), "Sepal.Length") expect_equal(clean_names("log(log(Sepal.Length))"), "Sepal.Length") expect_equal(clean_names("log(log(Sepal.Length/10))"), "Sepal.Length") expect_equal(clean_names("log(log(Sepal.Length*2))"), "Sepal.Length") expect_equal(clean_names("I(Sepal.Length^2)"), "Sepal.Length") expect_equal(clean_names("I(Sepal.Length/10)"), "Sepal.Length") expect_equal(clean_names("I(Sepal.Length ^ 2)"), "Sepal.Length") expect_equal(clean_names("I(Sepal.Length / 10)"), "Sepal.Length") expect_equal(clean_names("poly(Sepal.Length, 2)"), "Sepal.Length") expect_equal(clean_names("poly(Sepal.Length, degrees = 2)"), "Sepal.Length") expect_equal(clean_names("poly(Sepal.Length, degrees = 2, raw = TRUE)"), "Sepal.Length") expect_equal(clean_names("ns(Sepal.Length)"), "Sepal.Length") expect_equal(clean_names("ns(Sepal.Length, df = 2)"), "Sepal.Length") expect_equal(clean_names("bs(Sepal.Length)"), "Sepal.Length") expect_equal(clean_names("bs(Sepal.Length, df = 2)"), "Sepal.Length") expect_equal(clean_names("offset(Sepal.Length)"), "Sepal.Length") expect_equal(clean_names("offset(log(Sepal.Length))"), "Sepal.Length") expect_equal(clean_names("factor(Sepal.Length)"), "Sepal.Length") expect_equal(clean_names("as.factor(Sepal.Length)"), "Sepal.Length") expect_equal(clean_names("~ 1 | Sepal.Length"), "Sepal.Length") expect_equal(clean_names("~1|Sepal.Length"), "Sepal.Length") expect_equal(clean_names("1 | Sepal.Length"), "Sepal.Length") }) } insight/tests/testthat/test-backticks.R0000644000176200001440000000453513556565021017776 0ustar liggesusersif (require("testthat") && require("insight")) { context("insight, all_models_equal") data(iris) iris$`a m` <- iris$Species iris$`Sepal Width` <- iris$Sepal.Width m <- lm(`Sepal Width` ~ Petal.Length + `a m` * log(Sepal.Length), data = iris) test_that("backticks", { expect_equal( find_parameters(m), list(conditional = c( "(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica", "log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)" )) ) expect_equal( get_parameters(m)$Parameter, c( "(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica", "log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)" ) ) expect_equal( get_statistic(m)$Parameter, c( "(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica", "log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)" ) ) expect_equal( clean_parameters(m)$Parameter, c( "(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica", "log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)" ) ) expect_equal( find_predictors(m), list(conditional = c("Petal.Length", "a m", "Sepal.Length")) ) expect_equal( colnames(get_predictors(m)), c("Petal.Length", "a m", "Sepal.Length") ) expect_equal( find_variables(m), list( response = "Sepal Width", conditional = c("Petal.Length", "a m", "Sepal.Length") ) ) expect_equal( find_terms(m), list( response = "Sepal Width", conditional = c("Petal.Length", "a m", "log(Sepal.Length)") ) ) expect_equal( rownames(get_varcov(m)), c( "(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica", "log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)" ) ) expect_equal( clean_names(m), c("Sepal Width", "Petal.Length", "a m", "Sepal.Length") ) expect_equal(find_response(m), "Sepal Width") expect_equal(get_response(m), iris[["Sepal Width"]]) }) } insight/tests/testthat/test-has_intercept.R0000644000176200001440000000132013531007236020645 0ustar liggesusersif (require("testthat") && require("insight")) { context("insight, has_intercept") library(lme4) data(mtcars) data(sleepstudy) m1 <- lm(mpg ~ 0 + gear, data = mtcars) m2 <- lm(mpg ~ gear, data = mtcars) m3 <- suppressWarnings(lmer(Reaction ~ 0 + Days + (Days | Subject), data = sleepstudy)) m4 <- lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy) m5 <- suppressWarnings(lmer(Reaction ~ 0 + (Days | Subject), data = sleepstudy)) test_that("has_intercept", { expect_true(has_intercept(m2)) expect_false(has_intercept(m1)) expect_true(has_intercept(m4)) expect_false(has_intercept(m3)) expect_false(has_intercept(m5)) }) } insight/tests/testthat/test-gamm.R0000644000176200001440000000571413563552732016764 0ustar liggesusers.runThisTest <- Sys.getenv("RunAllinsightTests") == "yes" if (.runThisTest || Sys.getenv("USER") == "travis") { unloadNamespace("gam") if (require("testthat") && require("insight") && require("mgcv")) { context("insight, model_info") set.seed(0) dat <- gamSim(6, n = 200, scale = .2, dist = "poisson") m1 <- gamm( y ~ s(x0) + s(x1) + s(x2), family = poisson, data = dat, random = list(fac = ~1) ) test_that("model_info", { expect_true(model_info(m1)$is_poisson) }) test_that("clean_names", { expect_equal(clean_names(m1), c("y", "x0", "x1", "x2")) }) test_that("find_predictors", { expect_identical(find_predictors(m1), list(conditional = c("x0", "x1", "x2"))) expect_identical(find_predictors(m1, flatten = TRUE), c("x0", "x1", "x2")) expect_null(find_predictors(m1, effects = "random")) }) test_that("find_response", { expect_identical(find_response(m1), "y") }) test_that("get_response", { expect_equal(get_response(m1), dat$y) }) test_that("link_inverse", { expect_equal(link_inverse(m1)(.2), exp(.2), tolerance = 1e-5) }) test_that("get_data", { expect_equal(nrow(get_data(m1)), 200) expect_equal(colnames(get_data(m1)), c("y", "x0", "x1", "x2", "fac", "g", "g.0", "g.1", "y.0", "Xr.V1", "Xr.V2", "Xr.V3", "Xr.V4", "Xr.V5", "Xr.V6", "Xr.V7", "Xr.V8", "Xr.0.V1", "Xr.0.V2", "Xr.0.V3", "Xr.0.V4", "Xr.0.V5", "Xr.0.V6", "Xr.0.V7", "Xr.0.V8", "Xr.1.V1", "Xr.1.V2", "Xr.1.V3", "Xr.1.V4", "Xr.1.V5", "Xr.1.V6", "Xr.1.V7", "Xr.1.V8", "X.(Intercept)", "X.s(x0)Fx1", "X.s(x1)Fx1", "X.s(x2)Fx1")) }) test_that("find_formula", { expect_length(find_formula(m1), 1) expect_equal( find_formula(m1), list(conditional = as.formula("y ~ s(x0) + s(x1) + s(x2)")) ) }) test_that("find_terms", { expect_equal(find_terms(m1), list(response = "y", conditional = c("s(x0)", "s(x1)", "s(x2)"))) expect_equal(find_terms(m1, flatten = TRUE), c("y", "s(x0)", "s(x1)", "s(x2)")) }) test_that("find_variables", { expect_equal(find_variables(m1), list(response = "y", conditional = c("x0", "x1", "x2"))) expect_equal(find_variables(m1, flatten = TRUE), c("y", "x0", "x1", "x2")) }) test_that("n_obs", { expect_equal(n_obs(m1), 200) }) test_that("linkfun", { expect_false(is.null(link_function(m1))) }) test_that("find_parameters", { expect_equal( find_parameters(m1), list( conditional = "(Intercept)", smooth_terms = c("s(x0)", "s(x1)", "s(x2)") ) ) expect_equal(nrow(get_parameters(m1)), 4) expect_equal(get_parameters(m1)$Parameter, c("(Intercept)", "s(x0)", "s(x1)", "s(x2)")) }) test_that("is_multivariate", { expect_false(is_multivariate(m1)) }) } } insight/tests/testthat.R0000644000176200001440000000036413446526427015064 0ustar liggesuserslibrary(testthat) library(insight) if (length(strsplit(packageDescription("insight")$Version, "\\.")[[1]]) > 3) { Sys.setenv("RunAllinsightTests" = "yes") } else { Sys.setenv("RunAllinsightTests" = "no") } test_check("insight") insight/vignettes/0000755000176200001440000000000013615562370013737 5ustar liggesusersinsight/vignettes/figure3c.png0000644000176200001440000010017713502774207016161 0ustar liggesusersPNG  IHDR !hgsRGBgAMA a pHYs+IDATx^ \UIP`+ = \Aid("} 9 BҗڋH#`Z8 ؈OkpЈ=b*8!}8 vC$;yoYszZU{\ZozF GH $ BTB AHR! @*!H $ dbݺu7l3`+]wޫ.3hE`f zWþ tIa'~0,bg. &~%, ,{gXF4h4șmxSX١Ss2K86ңm _I?D펻+XhQ !AH۹sgp?yfc=~f `ygSl3Ob&ɟ?,?xi0򅛂_c^A=h96f qѶ/țW=K/G ]ӛt<qfi͛7>$ @"۶m ;hCՂ]. _yf|>9ٹ G>3 .+7S T0tƙf qж/(?pf6l;<^r4@Kg>7>8CM؀* {_e`y~ΔЎk[ijTG{tmZ _t7m ̢_Pe>!MTC6W9C#t2ׇ!~nIRn4p0zpjocjrg g愃53ۚ⡽f+hkL qж-zS{^nW $:T=t4 Yh 8 0 Ҵo:X# 4Ӵ|k`J&~WBmm7%`7o6K^! @/(k}7݈hʕat;:YlYp衇TRi,^8rm;VRl+b5*<,;o>є&֌@wР)7+sΊ`)W Z`b9 Z[m^ө~!@o[n],4gyYBO 㨂Շ!!իW7|Y_|,u>SJ**.iwGӮ۔[HS'i Ό\}=i7x4mYS`;99,7*!ڶ6W҆ ;,)q ҥK3@| BҜ^G>d:6D抜A ˅&TX缳3]q-zҶ 1B9BRoRp-I 4uL@5/$cC;j=bv2(H58ʦL!AHʴ7*$< U眏8^]`퇙%dE5#7F{,}7j-_{ @?xi0x)fi22p)uѫޮm;W:_ tK/dJB=G.G TIYCcCdKӱ:?mtluWknq ?~ROUt_y,XNS:uo Re>{=,56k {?sYjv_EPf  'D,  uL5mN<%@{TO0;Ž;Ҝ~݋36gys`q{m| $Dd5wO?m_!?SpI'FE6BB^&4hYjDLq|@3¬d90<;ɼ{e`"^ya}x3QLNՇ{>vZ0ek]F_eki;d:6DFY Sջj/";8; L`@8#5SWS&9$}; f_.3Khc_}@Nԇ_w _֔/^Ǜ+OZ >vqID<em#ҶEбZ~^AC95UpQ,7;QU BBdTTgͦT `l,5w镦ô JW"y7"(yTW+*s}cBdžgLY454[VZʼ KJH{;+OeDMP(ARѴ6nuMO&GKmZel<ʰJp}gt>$ *Y*_?W~Yվl42iQu|!H2L/TD}H"QL2!)ѵ]ڀ*kbsG81ϙR0+]w%Y f60 P& YGqy߻~ ^^}}$L߿`1Ś}6iOe@<0h ϣ0hg`;gV*aѿ\hmFev/T m]˔{_DE;-ŋʦ $DFDg۸q)5R6nb}Pॱn= < ,;,5&Sm7?rr")2!R*ՇZWWmJ o /W] nU]qmb |ty ;IVm[LBk` ƫ?o5:KugiQ\DUe:6~~Rk$ \4ԎR>iJWR#2.Ui||H5U bLJՇ9 L2p5ր!Ϳd:<fDm.Nx=x-H0۶m3K/T{:O1^_a\ Q]pH(z)5ʣ>$ *Y"2w;]e322L/XhPehݙU7왾tGjKairՔ^_we0zjgpCQNl(dB1q=; l_Up:̻(\hJƮƔQP}VtFvbBwmF-m[T 7`J/TfҴkGq3ثF_ >OgwW*Y'k]󠷸P5(>$ ٽt+s:v2%TMxo. /Lt&Er5Qǘb1ՌHrG>wV0fɮA9#W_?7X:wтLH@#FW>TXP5b3Sm(cT[ FljfZWS*ڶn*+e?jwwҥK?뮻 0vW'f~撰6t}i: !=S_Q!AHJ6*L뱛Rn3][h@ewwk:0kZYK•I\sح b7V1Ě"LH٩ 5С{|bFPُR~UF >Zq^̴ϚR| j+/Bڶe *;;+B, >z駟n;bP@2 ǯLj^r;:k( ZJHk >z,?ܲ,Yk)e')EpQe˖->O3h"v֭[C_8%cSfбYRw;4wqIihpd7;y606i7F3L?Zfo?,62QF,]~`DoN 1̬eGO;Si,CUzن H.1cShjkt簍\oEH|/,uޮ۔uqmgT:L^ !5ogg>jc]ǼZe+6\˧fNɟ=fw;8UaT_kZv; CC~ϫ}؋41f;֗-:ߦeWWfbJǟI'o|YY/)We|\X јh|0~<;IX皍2~)f¦<"L4vN憺v :7md=uxKKo~ӻʹNzw<@Sw:կbLsJzv?Aw:2O)K{EJS'^qm0xqf)tƆ^zOY_m83[URk0CZOk%I}@.^OǺyCc]76S_mpNlNujtC>]t g6? TMjGi_q-5>uܸqcQַGW,o;Oy}祈0liMX v;;]"ם9__YG뢝UTyms_D[3mwU"j#*oq_?;5eͷ]dLHA6eM,{Y17 Y$QЊwVxQ^ucM QDo)7Y)ewa9R ||3,T'ḝ6c3u :0"m'hՉ6^ԉ dpf5 >~SjE}X7SuBgHhFV~!܏ks , @}Ƨ?s?uOK, W~ܶe~R:jOuD[eQ: ʢ dEG>JAYK\ƭ/k46_ĬqNT}M-%*8 -IIzwQi_žK6U_YmݺՔZ\)Ȉ)ٵ}tѩN^+ F:gEzm,(eZ&ie~Կ;5] ayR;dw7O6%K˗qΕ#*:akY:0^75 WJwTʹ#軓IﶲWjՉjQDԇ-ܸ7sQFmwg2il/(WߡWw`gAٔjp+Sqf>6ʨ a]w jB68?\˛unQ4[6GqlW=##Щ,eyc|VakAqt55פ,W%ϖ)+:ueAd6`*w'V\ik;W- 1ӑޫ.6ȒiWOg7tMYQF| 2A?nWp:0]4SúYmp0 ௲PjD<dȎuPJop.}a_%rVmv\ׇ|w&OR2 mڴɔZ6i_} {1\J~l}aFiͣfeD X 1*Lǯ ~Mupmj<07t5͘hL<ˠN IJSc;z}}KZ(a~^u!pmzݮsDc '~QM\#vEQ& R2)w\j*v¹g汝]>fE.0KvZW]L _vv{(R mm?=q@ Z4mZ&ugϔ:yc^5cB g.I)(ե)}ʔZ#; ,Jeu:хxS;5FlCe@6;Y2mK {eR1]fCϛwt)T (a?̏:>Uk²f/[2+LUsNq>}+(_,_O-߹Wvԋ3^Oǵ-N#NLJz)eJ;1 .:P'Sؼy#^۹Qe˖ReJ:=tgVw T!hg7u_ 5m{t H҅蟯ʤ#[-Y0̺N-_ }ppHZ']|yn^ fwWGߛjJԴ.Y=R+߱U4>dz3W˸S8v}'Ԃ;;=B.ŬNNfSJęNDpeϖmt[U_HV)ƽ]Ju{1驭֜E?oOTAwv+B}Ia%6!JmQV?gz[*#Q*CF㼍N_]h,fk}:է_$?}X9m _ekw`Ҍ(kܻT8bN5OxCN],k׮m}mg7hWicYԇgBe1;Ff_$m/QYtj$сŴq։u^|skjoX JsE%=dȊ̑A"}~潠V+8^iNuݗ1S;$}.\wk=? isR27рSHwUKvuPhptD}S5+M>XϚV)S]c Z NZ{^Vubɞ:p᛺d m2B_l Z4l5z%?kMoga;БAE>aPׇꃬC6KJ}ea`ѦnuQ Zz_[+cRׂctLYqs–OvqV|c۷o7%TQc.- 46qn! t4~֣6rzSң[gq2Qm'ߺgQ F:ځ>4|\wlݺՔEŹ"pݹ#:tbġѺdq鳻 7oV6Qї{%͐MQnNOL0ilM0'Ii@p}ԃ5?vsGF)>dJ&6m4t4p hkJ@)V,>Z`:9z}Ow)qri)SVuƯ82ԉӯlJ5oRߔw>ӶߝU_H~~˗n u7z=P>֔MZ5-LnVߩnQpcR}}Gk2ei tծ? ǟ!NՕEG?`|4"tbE%)R7m|*cLHځׅ]-`wGgiL境YL.q7eSSO[,NZ |_6Vr)&H ̙^,uA;uf)p 4Oz7^kJ-7Ry)%3t'MRgu<١FhVSnjwjo#5u7̒2(CMu#;*Ūt*|+u a\=5%Dxm;U.{[wn'a&?oxok6Df3X?T)&8? .i7H뼦}" }|Um4wi]_.EE9Rߗ%''tԷ{Y*oj &,tA6ZC>ٙ.w`\^֋39QǘRy]O>jO/_48ug.1F0 [3#;Y] eBb{YX':ykWԉ.ԇe8dS*/L6wdw* nZ`˕-I.hv?=W5Oǫ>,7h%ۑ;b{q~F3ASjciO< ~$yfV tz]NyPLk\ݗ-;UVmw}XH&6\uj(%m^/j2i`7MSjՅ/Mau׶J "\ek=;]&NuH>wgQǤ\!:q{\]w'Q)J;%8)ʗ)+(HY8T ;̀gH;#]7[2dul5n> WC6U]3[M/;,zG1:7i]~jc+kc w #_)Hn)zWL k-g_ǙR:EgWZnQ};6~ȪLǖNn ɄTTd}\_eugR:k׮5V7&`E%M3u0=ye ֊C>}tc{S'_>dJ<{;d3Mf){[M)_0( h:N&ԔSԏo .+^tղ"ھ;ʕ+SG:1`ReSƆz@]wF,j*LvUyOnROA}O\Sv^Sd D ^g>_zSj5'L i=_ik2t /Tݧ߫|y.$R՘:U+ FՁ誰\> 6 gzi+L)SO=Ք=æԛ\4m/4ru1ɔ>s]'kOR-Ro8Zm˦B;(闿&~hwW}@)Ojr!9{Ws=gQ{g y_^+9SS<-YĔZu2H[cnv Ʉ1v:/-}їqcl*˲eL)<*Sߺg]t5LjӉ1Х͗٨YvoLֻox)zK՟${ɦj?>:\_YUNVfa˗/3(aoy5eMf.yW\kJB&b]UmU+بlӴUQuoOgYVԇTvlUk۶qCtLtRqC7e6olJEz6yzQn4lߔZ1zQY)R|}ӯTkJCx:X2mרYԇdBtd[ 勘嗄U6lBY<]uc\ygCJD'>je RNLaJtO宧~8vMLx4|/S:>&)|)5ҠMru?lQ4O:$k{ҔAbjHmoSgv:DߠnV뺅ΧD?l'N^TLH7ZNEL#ՉUN!R~x$k:&wr_7 Dө }ӟt7f4DRNK^64XNgçƣ:}}pcnԏyM=e673Qc*ɷyltsO'yyۅdBzv'nJױ) Et&=@z} ҭ[Rqm<+ϙh-TNQ2ۼyt9~K6Z+.Iđ/Tk2}a&Yʀ-'Q~!뮻L)M6< 2U$6#m]w4oTά24QvLDS)W2}YgΨ~zV8Q?2*sFnY )'4*8Ӄ>}[Y4=Ou:p6W_&,~"+puD^g֟ޖeGRz}hJգR#~Y/[Xtys5f5퀂lzB55͛2-G k.uNwЫŽˈ T鿇}dhT{l6Z+>q2gPcw; uL%fbۖr; wSO7U}tc]^|ۚ,ŗGDQ@ Czbmjd=4qZE%_}tGx\8|"eTm,B2!u:-裏6Y__FoaX.LS{U6yWU}#:߅KdJ.l4]EuxϟRp棏jG7F)·ʖU% @}g=ʔhʌq:7olP/@:bwsQق~seB*[pTM-u+/R+)؆/F3m7KB۶Qپ; ^hU ] .uTnK|/`{'R9(idD Дm |07_lhw٥>|۪WTq_Tf,УkL;c64Xlgrj@M v4Ȳf)E`Ny晑R smpMe1Juh{khkgE'm /YN촨GR:uldx%[<)(co/lRx69ٙIb-wfF]~ǦqeHEz>i _'ž.\C>%ױcFzQ|ke[O=K~S~sY`V\E=vHEyk |h3c,5ء(\* LhMcZvѼ.8׺N4݆0[kIAʀm<;wqEzG_/~wv[P=gM?庬QzԴg9,hЇO7K墌vFkP7ڑ=_TQmoǽ74lX!7ssyoqt6O*0 $הQ7PHQAH Q]hh6Ks]}jP5TdH9TJ p"dA |jY!oHSyͻX):'Qkl4!e7zњ0Qv 6TNo"wʳɏәi;DAC/xjh5WEVi0K7xZSu2(@^ȠC5?2=f8^q:D} dyڰUծmmSݩ?"n}:UX@T[=&6`#>wѵon>,$E<>^i,em[l usLDӺm'w}tlyL#]reI>f?W:) ^il2SjU!e۽,_S7$ vRGQǘFJ3\0tۑy@4Ixw|۾ }ݸ* $WpRTQ#E.pTfdκQ[ZcrG_KIћ.[n5P@y"=Wyu\}"EtiMƮ2,ڏsVfp }; /1K|”mw{ĔTo۲(In}q%c;z5mwv}=FF ?eSMTTNժw$MLj~:l-uLCeG}^kr4){(|;ؔ? t[ ,Z|)&_ZSjշ߫L /nn T#9<֮_}a}#ܙEc5AE|0WnJͷylnI] )6cLڝX Ngo~5q}\}ξGmJ]~<$7yB2!E58Q#B'4Vq*G:# {+{*naƷ3M=oOv(EϢ9y&C'=\6LVhʏ|Ȕ~;R#oeG'>;,4pNIW':r:h_6%Ud\:lzAHiDuv:dwG&tF|7IYm{R\ۋ d_Hʕfn@ԠYn]TFŠM_vnJofHRm_2%D7~LFꂯcQDV\PW/gǕU5upe=; WOa!J;Uƈof}oD9΂uN)fq7`w:etl?|aSgMU[jJyqYJG}Fo/<i*sN"bMVq {)0K_/ޫ./uZj/3W;7渂:5M2jmu.(#2!%7zњnkp . @ ]mۣ:.#-B $;M-Қizmxv 6ِ):4 EgEWw%t^Ý_ִ lbE:yEԇdBddD=p;=uPo^uz4g}SZweoUKl= VEO&jz2%0ϘR7,1dtq缳ZR]\A2޻Ë[z;/}.wdp"M|ۦ^v\˷o|P4k~]ukjEխ6dȎ=-R^yϟVUjdR'j ;o5KG}_8qg|7MV3vSjE6>; B5 ͛MiHW:T6Š^ɏ7`H WSzzOˆ3,>5˖-3%T_=Pqf߱Kc68XշyEԇdBzzg|Qr6#˔se uSVi,VW^m߱9ӆ }K'q] rLUi떁kܐ3>WngFkB@>8>8|Ye ۼUa!re}YCŕŷ7M)=I;ET1纋eBtl|n#Dw<_Y:u\<^S*?S NJkߴW(QmSGud35{̔ dN4dK7W~kӱ? 6)[B}v&?zY"rն=xvNSro񠀣fz6=+ ݍ#?kMU~=ͷ/+LUwGǟƆ\:=$+W 8∠/8Cn1&/U%).S:Ka!JȈ|$gy| > 7`JՖ6W=\SjU@$_&NMAjBl#Iw8iJɸè{݁7 Dr'?iO\wSU%ɷO0݃0#RetԐ#;yïSӮSJX'>NiTN QFˀG5[||ZnJY2j5@xty9 ʂ6a1hտ)~eSN}|ۈ3nO{1V+V0) 4\kӨ-e=_ƩbˤEdd<.]a!:=]NSO=ՔZe5{>۔gEEU˚NJ "u*DUAr-Oqw,OܻɔҙtL%C)%cCBtǮRĺx)߀c*恍{aJ\Soz_6 4>qM9vW7V3,i}вdhMX mWT_8?>4SjOڔF #)U-Q@8> jLW?v2fSv/os]a!FNCLw:]_z__,5\'PJ×ydSjU1cLN@ԪSc㜍yMvt}[ݱ3a{.rk_Z@$`]@O)Egp@kMcJn:etWY R1ʰ{+ب ӴU]z)m NC?q@w}7ykvc";VHjB'L]weJn'lHz:?=#>]0DuS]juVW2EEė %@)njJmGa!repNkݝ (||}K9UOɣ]N, LmNE:p}oxT<4Zx}+ʔZ )%k0h0J)WߟMF" ԦdSm`I7x0~MDM9]ccqYw*?:fҶVLHRN`։۝j׸2-ݼ8y( VU NӝwYtOR ]iؚN_W,ҢMX ){+ 6f=?}Ԫ 7 kܐ3nO׎I3.\]󘩦[Tm|\ƊCsL:Sc⽰ͣ*>,$RZisu:uWYLa N q9餓5uo&w utbգ>ڔZqy:]u T%#2VYM}v (5NB2û5GJb &kj[`tXR>p1fֳ'3iۆ TneZFӹDz.wʸuޔZ)Ý!$_H츮Utmʜ J_mkwGN׉.ԇv_q ffj:Awd>/Yڨo4n͛M:= {1haLVuWfVP$U+;xW6*q.4jmWu*LTq|^%3iG֊;]v|޺}GQt}XH&Nudߵ|A8QP;w 5SEkgP.^o1Mk\qE}j=VyVV,`Eo%3s1 ppr{+CUL5 / ʹ|Eeq%tα:%Iyf/o_6%lٲBOGW!ȧ학m3_ޥu Zi?֍h;_\hJH_H}!˗ȏ$:n|}yšW׼֔ZuzJ2\4K*xN݇\=]OusX8p޶onJ+Luvwm7oٲŔ|lqҕh$y<þDlhoG;ʶu!%*f2x3Q"t¤@;1Yv,ږ&:}3m_|,@zz tR+BRӗI\`=O͕ NI(Ω!G2Eoݙ!l{ޚmG[€7. Fd~iw) v|ol M|0zkt{' cp wF]LZudޥĔ$e-{YCtFwgT$W'/eKJwteJ{HoT6?F}̒{mf h0_Gvwz`[ Y v2O魹^ /eև:f1>lvP[_X^Lw+mlg#W!V~!,E`vtVuYũrƍf)}ojԧlt{ O:V fiu PQ;j=̈\5kjjBz;Ck^gD?UFHsVeL? gԮѱd8+%qnUvPu["u>l\O>dv>Ӟݾ}:Qf  ׶Ӣ^D6`ҍZV$Q?Y]]4,UzԶ:O϶n_}~,*F!>}}EdK@j;|mN v'Iʴ܉Y$ڶ )un}yр>hwbInK#ϛ4T&L%v}khL~\!k0zר}-}kϨݐ[+E6غWTi|\c*ʹJNU :jYuޮqdvm[}΃xm=?mz->mҩ0v^2dnچzJ_@nA0QN5TvصWc3 IcS%q=w EiV}50@(H N .i:<]i)i(Y\S5Yv^|Q}_ǶAѾb>ݑ5:e|YM ;jҥoLJ>F^emNT2NT@vRQ%.mQqejIakH`?m@LjV>3& @i(c(HC믿>l?بu./ P0BTD{U>#S U.z-eѺmkGTP/͵H'yz&m҉0 ;vRrN#zzqTe-O*NTqi{N,.V'| YR <jmz[DT8Q_4ҠAY簮7pBV>βl [F#W3FWVvoJw䡓tNIՔ:\hVSnTVԇ9dms-lBʀUaVs3-_ܔ@|W^~Ѝ P{)jtSK ) +Xi[Ui|\ OB@/˦d8|YBEۼkG~RH&$WpRߔbJd:Y6zIfU#]D /m#},\>ɔ,J[v8L'M%_EԔ6y/Q3ڸ.d]wgMK vZ?zo|~V{0Nb'e1jpѿ/Ii2h̛9GNGR#dz:f5tq'c/6b2W&_'fͻN$| dm=f )I6Z,Xz̺ :),ByRk(W; WY񳺁 LmrWp,DY<QǵigYj¶E}YVzݾkT˻>VTFFjiiuQ ڣ.ޢ7k1 O| +/tW_Q&.ʜe}~zryT}u6dYgsDcNS۽}3f:֮]K/i|"-#moep 4_|P0̰1ŧS?~0Cλin9. ɭ? ƿrw(;rvKR#m7YOJ; zhՉRFZ=<^csUuAFx8ORjp κ4껉Qۉ:;ο$E]w(c=!i:q]0v3+f YmW㌁wf3(m[tN R}_,\pA.}~>ڣ/@GSw"^3Ǩ@Rv2o |aC4՚/&4km {C6To@5x4)kZVn~2#pl=:]YJjHѫ6>k&\v޵؃vǵ[Ǚ0j:q>sifxn2ԇ!"'|2܉[n _z`ٲey"X;tuɒ%:m]]k< _>\*>S~dRVi[:S3 />2u:gWOӯv`Oٙ }_fjB;J kcb 7:I|&\%M`K\H]oَ 2ߏyhۢucġ iKEoy[ՖlAHe (Uߴŵ౳wyр+@*|;E޵qA6>luhCmL\㵵(\i>_yls}~m^ $m:N;`ӦMf y }oXӴcYNyd $C uL8JY#dfiN ^ywZ*r{fm |BqNS@7#мs\AHdB*3yy$}}}d6V'ԇT)*{F>Vo iYQǁLve[|pڳhcL\-]4 Ъ[ڶ@ m[t _:g @*V-;ʯS}j~)k2($H(S}HH|M5g&NC_eipyQ6^[R@Ӿ)K9}u)چXvd@*Wnծmw6Wh :A0ԯ>~?Q/eZO(Շ!L+-QmhK8WGjJM)D6~e ֔COeSs@2և!7mI @TW+x_1|LԨu/Ҁ`w4k]&~hPy?eJAыք0H@|Ui݆-_t+'>GY+m)$?)TdЎC >$ @l\QتN[zSj4'L){J-o-|u (GÁNfоpM2x ҥAPm3mciHѶf:#db7Fh9Esga۶m1Ȥg׀'U@Ҷ=\S2ׇ!HD)]sSj 5[=ǙR/<Z,5;MwG2K̻sf$w <; WE/t衇/fwNkWP^}ZSjU\L:.>WЀ(sIn2P=eg2֜j*. ] b 7e6h+y7g3K1;\֡NMm/_*o3RySVcJ)c\):ݨ,ж/@9ǯ {?s3 R}iݕV^|fQjO@e B*7u8):{ahÎ*~m;ȼ+ &|w;'4]wAпAMw>(=i ,{ydж/@ǯJS5?^ɠ8:2=cf )c}HLrSgMcN viʶF/Yj74д^h zqSjoh-/-[RkךT^Sz*pj<Έ+?AnSS ov@S /^e!}C+> |I/R $Ft (uĽ #?<8.LꌞzAO9=&~%ރrE 6$M`Sl &T){OK w;H0vݕ#;(ϟMq`~>[5qkfY AHTFGG-AHR7AHR! @*!H $ BTB AHR! @*!H $ BTB AHR! @*!H $ BTB AHR! @*!H $ BTB AHR! @*!H $ BTB AHR! @*!H $ T 3tT=Lpy&{;w F|U0~MN SRޫ.3KA0rm3KsΊ`may՟ |M BPzcwђHA vY؆/_,REg@3c&4ضm6Kt뮴Nk.MYifM`_L) hF&$*$^/ FoA.~MӰS\uGK. o}#4GHoh&`C fdgtt4iH7YH Ps(i;f AHD4_ Y`P淙ghM0Qh-w~n]|y0x)f @E4[&&?howXH2nInߙRW^1%( ('[\}}Sͻs#Ҭg NBuZãҀ'VSj%`zB4`M { 6+[ eD6$jBCᓏ,EhM8[03ŗ%zӱ0;4gD,4Ksm7BCT}5S`d19 XU $\LaΒWʔP5}wҜ~gJ]ll)奩ū5l4/%B–BYs-sNtl jJs/XkJ3j)͙l $,x]4[fBJnWO[5Kp0flِ&6m4%zAHXLHpJ/P&$eI9cNc6|JS*{ɦ4g{M C}0MWd&4MgWvMr% Ř>_eV[Got1NsΆu|^&yȔ|fҥAK,eWYM0e`(fϹgY n gf#ɏI@,r}h"4Kyg0Ciʹ͆/̧U6`jsFp4x Њep֛w¿8L|nHZzl t{(pe]_ƿn_)gr^YfIw(il3bUϖgSuh_yk0LkQVn&<:&ϟgMGN6K3jLkcel.7t)3r@  Hc& /}f){urGo `rr gDFX] P T0tƙfR ʲmv80LR:v4~`Yuswݦ4kw>К^m.ۮO^w%qՇz+%aU V( ,1g)HC?6I2uQYS6fo}#f>c Q/},%~o4g*QkؤՔӱl@qD>"׹391c}l} egj$H룀$ӳ){g Cf_'y4x0Li2WyPVdB$ZJQf+eB{=LH[=ƥA[L`R$@64V>Z';5UsXo[kЇO7KՐg&Z֞<,Yj%FӕM ]cm&LFQ35mLHSNut e,d_?inO?qA\%fU6KMI5o/˝ZKY =+ jƗ^0KvS?ye0uřdSrM/XZ& @hmd"@z.Һjk1U BRWmYj4˧Z>is5<(FgWcQ;νe 3YCWoz|R^p{]iw䏶 Bwŵ v5l4KYc:vD4G6<^O}L~a S9:zj4'm0\| qf @/a:6r444_3Gh(+0&3 =! _|3`A r-)󅛜ZKOE;Һ-?m"I&6m ͛9NF%Imt<5KiR^ טgfiaf!2(Q=1@0e jᱫ ]ʤc;v?ܔӔ̼x?DžTaБ, FmlNk>F$>Y:z_LmlkR}pQVF>/`(AV i7 W=en(8D"QuU\]ml)GYrlٌ\vt<)Q33nz>#NA^>:fb-fؔ8?Fcw֛|uʴ3VTБ-W^69o,:Lh@7" г4^ PGWojNZ'[ MlD_?q(LiK_Sjw+f ("B~rq8- V^?[tbg [)E vM0SK[3Ms0`u}OY! lBLt)͙˚R[cl}2c˪lS|MubwLiQ=_lU2J\9C((NA=͆\hJ )^SN:F} ҬR6ܗZ}<6eJuUу-!P! ޱelH_wPqOuUp˔%k)M)[k[v3!M>)tq/L׼+5%;kLH-Я˦vj%IL5Qc`GNƿBg\Yeu" ߿浦4'8΄d 2EIQ lS+ J!WΙya/~[RAL:>luҥKUkR#pM4By3h"x~kJ{`-$AH {'weBRFg]1ԯ2FSLniW^12g)M)_:|XVqMA7t)fn$9gE0;wfC-3L:l`:AHXq2-Æʶb̈́/\SEYש[OfqeBMmur̄d ыViC oZ,́8Iꙸŗ#7/5ϸ)fl?=qf߬ 3$e! zbT'ú  $,l8eM2J5Mf[v75q+ SwV}r ʒ،z$g쇁e ߾1`m`$h!iN &6?hM:fVV'Gݦt2'Kgä́ % RE}-5UFExlw726`_/^`퇙߸Mx.{eafsҒ q&!`c/tlS:a JL92!E (u(.(m$AMc&$4`3ʳ3w;}9tƙȍI.\)it݅f)w//yY@Ý;wj|QSm>tS UɄ$LHILճJ̄d ̛9O&?zN0jMfalxOhP@~#oM>P-Zd dGL&)#6%zAHX,yuY1R8Rk /R hU& vLF#wҜ_”o۶mhҥ@  [6Lfllo)΢ޒP@u ӱu:#k˙m1+֟w5g1K ɲ`$ej16x 4BeҜc3%z AHXزa:63(p2!e5&,PLHQ?0S3=H;nuUm1m4gjdz[lF ~cYʘ ޳lNf ؙ)۔!`QLH fNSak,a%PToi nRtnLH]/LH2MiRo)͗ Yz5X@(eq_|Y3M'~ؚ ip $,ʚ I\bIY€)Kӱ ,OܻɔɔL=)c3Mi2VU!2!5+K=SĦ?kJs:ƚ ^@ë́$UɄu:6<SviSUɢELiNSunRTu:[ ^s7I=clt,lۖ=\V@ӿ ~`{Rm@1|}M,,-:-j0@?#7D:V)NY/Kk7s_~j TͿu+x¾ C гV8o=iyS3;c]=ыVYo}ÙH:.9Z{79֩10R9eV/>({ $,l/E 2+>p&KQn}FS6S6ѳ27mlɶ7Il>I xJ>sukmƑX~( \}}$Us(iVͮ۔fx9lH۫ݶOK۫-nx34K^2Ks֍LE)L)elɫ_eJuBtYLV3x 龢Pŗ[?cF PpHpj%X~"`Dj',P=jYjg̥2 Yn3$Q֣f RO(sU3AHXMؚI/a@GT@,(&JMQ)|V")ۈ2DfY! @-7~eS> Y{b uL\흔2h_)V\ Xq}c;t JRD >U`2'OW&/NXT:Om~`Νf3F]ؒI1nf7ӱifsvi f)[o\9 JV]Ak4%o -ZdQV{7S?o->(v/i8VDNj2%e}F1v-SKj=N@7# SewI(FI֯׫%PԄ{,QFBPJDRыV9 Ъ<@<״LL5-i `A&$5=>8`R\I@+2!(-eBAK3&y(H H󮸖$<Ȅ+S>[~oWRK6\ы[5KADYjɂ4< 0! a۶m|rY*μ/O<,70 929\ѶE/T k?ASgmr&qK!AEprUHwEp.EPRc:>:I̾`ӛ1iۃC3K@\?䭈)F u '\CvREg ^67x҉3 pr-z נrE W@ gBY~'׵y6dRV:t/G^!AEprUT~u r*zu>ąbE殬nWU0z:S 'f7L"TIY?yD{ڧUruutep5_nGψ+Pz(@A.STiۢ#iЌϐmrduŹg "8HKNA.@wgU8@ݩcSj}F*-e'`nUl+Â~oW^ɋ UpN7|Fd+2Z*xG_|1<Dc[Gu~:j:}^YhۢKۺ. 69@;-%K&"8q֭[gJhea3|ͦԬNx/@^6}{GoG" ?& M3IS=Iȓ4 uYW)(:t<ǡ~:Rڶ#AQ=!p *b q&⌀r.t$ *cM(ղ*Yf)UӟEu: .0fwiSONH0qm7n#gYjG"*J괍N3ѱZWu:;>u,(ÐJYy(ɺjHHm[ נbes0.h#-W#Pw|G('lJ͒ԇUiW n0j X^V nqW\וڔtCӛM\{y3ϙ `ovf0wPgN*&ϗ9#moh:O;u( 52(PZu*fm:^l*ܿ/쏺0[ԆoGiU 3 *D))Wl:TtMa'Ԟ~oz`]Opu%;]6`?-T:j)3Dueԉ芎2BSi}PkZdÆ ]em::^&MO 4~769Ҡ=SU_V!AEpLA.TuKqgK^:\S ʭln14@#@ݔ4͙uT-[ h|Ah7}(2G}+KϳGǗ~_,=\Sjhf/ ڙA5P@2O<OHH{< &GMqFQ5dU1\Em6$+WS hDlٲcI^7(AO$ZN7EvӶߴiS۶_tiL5 TJޢhƍ|;h "N4kNa(j:DǸzEuε^BsQqݺuH*So FK{'pžU]e*D:uZ -;*Xti'ˮ,5Soz4jc+Xwlk")?m_vfcVVQ ?u_ >g9-TeSjV9C6[:u^ڙנoWM3n f~B0ǃ%{ !7dO%ع#LL} m/gNUI6l6/?HWgW"UhǪ1_Әh58FxVfPXMq"q'I}8;)Mys7;s̝~ _^+סuҶs|Npl4g/袶uruzCuԫ tM*wѫʴV$Y/?IWϾg}M= (mj#yzy&?әX?zMk{Ӵ<~㺖VՋnۼu_f[պ>^ZqK}]R<7۾Ыhfkgp p .&n'_ma{Źo{ukY}3_~_`v?m=~(Su5we_\cE-Ϗ/ }yKշy^SMfK[h<ȎGٞLWdaT^Dx۞zK}gmݸ'Kw2=R|u24g9.>KO'Y|NVR|ߔ5ASj7RyRq9$nb§ҚRSj7`=ǚdF>|Jh3cOu6+n`J]h36/.m~ާ>lOb whժUl/"436ehk'fq偶-נ^ `LNYsm}1tfO%Wɹ1~}&o1 +wɦ~ȔA/k.hMϏjkWneQ *͓h͉h\D{ޠj}tPu-IIz"Օ,o\m4/JžKA.7o6vi;KQiQiW<:/0RvhSuu%Uc\.S0lM}[aRDi'~2oru61yםNU}K0K]wc0rf3w}Ь 6*^ۼNmkz]ShťWViҺPO*5m[ *]z#\UPO;INL}?ާgEEIQOky4zHNi7nǻ &)b|\>'(F,ey6E}y"mh[;TGҿRr4>Tٲ1eEnV U$~<ߓRv"xsU;c;zf<ꕼ.XQy_|1 "uةM47u9]< 4yIWeJsM6P7v:>v.z (J׉K쌍Rبׯ_oJMq}n-[R'ڶqkɸΩ*^#\?W3㦴 ̘ɬ݉8/wM2f=G@m|\%12_}/Iiɵmևg*/_vbi0Y(4`yQVWX *q[vw˺Saj6z=]7YFۤ6gnNzou8mY+R3Ci׭^1biTAeR`Ku-MA4Ea^tt)z 4_ȪRthfyq zXd w_y)ř,/d**)5c)?UԩQOm<"|ⴇ@Z\hfmKxUG8ѫ4XEi_`z#fmo _&] PYowyS,\{[Qm]Y1 z^)+3ҥOiI)㐍mW>@bEWMնy]jڤ@]]B+Kpsyt6fmv8'SkP?]ltښD7ۧ;jT_@j+A z٤ɀϞ~!. X}i^*k_]fl:ڂ/"z*dl;t'͒hxqQ~j x;uNtkZM޻:>1SYlrZNiPFN|h͚5{A?me_Y[ytǚR8a晊ih6tV[%I:L6NKTAzXYL&Pv}k[7w)H|H(5H[U NJFKzE6\uztSOzZi%Qc0V~%)Vm۶͔b-rSj7yם+ <ٍ|S2@T6o:E]VA2@t`hfuNUY]ArAŠ^8Дz>SQxop0HÀ7UԽ[bJWZoGk| $w㽵2}/Q?Ƨ/r[;<'lYxY _yÆ aNU_4U/FR3C:zꕴǹmW`NuV:n>dJ֯3t4w+@7[|OqӠYj7q}@u_wz}N|d*ؘ)_չM._vŊ䧇l\v^HoۦnʕTMmv^]A\5W??JzM}m5K Zr|ǔq"L@F}=D{u1K-FG ȭ6yoz|\킢EW+5ޗ%_H4Emo_9sTnԢW>@kct;ne;&(ַYlww ׾fJnfSMVSѪzoouMPï{9@~໦bs>;usFOeM~[fNٌȦJO-Ԭm:(:jީEG- cu2?)is2;kbշs?\sퟞ끔>:D{$TmC(h_jsY6dF϶g%y{P Țo,Y6nfɧJCE6O*K"q\:a|1wә6o[L:2h( yu"H<uv],r$/;VX:zW jUc|T{@sM}6T}6_yj >w)1f4´g2U%~m^hR]$~I3cf|6{)U|mbx/?=):%/Rw B2v0vz{f$P g$g/L{\Ny؛k\5__f:6I[撩(*wDw5F&E.Ƥ.YZwm.,j5ӞXPzE :g!526\]޳:P{20X>q\:V꾏hv'~ נ^נbP')gE) .y)㦄2;yP x)l_Rq-:7֓w~/;Q6Cc;LEq W n@+Eԁ媀\> 3aziʕ+M)O>ٔmڴɔk-Q3Cձ^]J N"[c|L/PS0fϫ׾E:O9䐮 T}o65윏>+su|N\yS̞L]2euNƆ_ꭺWl|ڨu9T )٥jNjml+נ^{hM{6rj>}M erS?v65L)?x)jmQ< Ϥۼ4a.r5 =D# tٸq)[l)G[,+5N#9O٩k;JSVhJ\`wc5{oJW^O+Pk؊+ Gj{hUM[fsNӝI SfT A=W%SQّgq/F4=I*3_%h˂Uj7ZS ;[Q3D\*2յ^Y3۶m3vY]7zSZ6?HTo^Sj6`ЌLQ;˗/O}]VǺCN]'曺LӝiMMά#SQ|:\aW4pu6 >F]ן.(,)WV+:fciAklvvAxWi_eJвx^#>kw'ꃓ͏;OH-Og}]yShUR:<>'ˁC>en4۹d*{v}i s"p;f޾͛MsJlU Uz^$|MaيN6C{`R5uuL; St/e,Ubb7 ϴ_UT}QwʮRŇ-׮AvANT&&O:6#W?cgK^oJfqT&W ^U Uz^YY5|)s(0@)m<Թ>ʃ\OPNyG×1~}O?Q:mAC7u`%WxƾXi"d*EQkK/;0x֯_oJ<5OWm[EU?@tz eʿ+S4wFUy&e R:?gJsweSn*{5~Lz-mr"6$M}K6n-[R|M7S X6.<ԉOYU˜( Yz\)-w,|k0=M)L[V| WTiLd @#jkZ5eBK e|kz~vDo ՟TZݻM 6A.&uwi լЫD jֱU,E>ضr_I?zZ*p z|_*/XQ W#`WS)8Aؙ}]}O3O0}uQT\WuĢn,_HU3}!N}K#ϲ*Zⵥmr]{: !H5{F4S0~AǓ21mfU+`_VkP\kP|UWh=2LX4vD)BS` &ﺓ7glxW4f R \kdJ*Lw:K֌6ylT5pȦWyRiÁ95W:|t։lhK$VZkKkjꐬ\Q:,A[F<6Pk_4Ke{|$cZǶM-u/2w땈euIZT}jΏh)p!NP=潕ΔsGMuw|ԶhYJr VAӉ|y*uʨ3EAEcU{3Q'Gt^ Jv3Vt>?5a~ji{}P^l7}?5{^GUPm{\뀶m,UԆa_8w7c?\uz+=8G|}òe:t{%{CrsyomTp6F^s.W]u~}q?nM_ٱ}Nkd{?hm$\\ӬQ>|߳lu{VMնwFwk`yI>^8wճߵ8&Q]^ڷF珮Y!qsw.^s7J]Dvε&]/k?`]wBZuR;P]fIk6yDu{~q֋bv-]^>D6;kUtWArAŠM{Jjq_?~0;~%:﯑Zu?[b?6^;s=gg<:wKUkg=6|y| b{>Ou^:n[^s*͓J[,'ݟ"H~⮯oCOlTA*fٲeԮ*Cձ^i4w#Rm(ָѼV#[f8鲴tRSjWc|$hqєU-ŴUn͋㹛+:7F|{駻:[#[Mpu&D/=n{ckۖ662ġ\m*~e3umk8TO۶i%jz٦W?q] vM^ݧ~ϱKE&>lJv|d3AE}:_|VcUfZz5PnѹF/]1qM\)UUFAZ44zM_7+VT߹<Almm^ ̭ R}^eJ՟ -²7kᇜSyzg`h]$0h? _7~Wr Q?sY7R;'y˫O^ظwo1UrmT0LEqOf)U٩tֹ2[YfO~)w~RGU{³]H];]DR{ۼׯO6pkn)ٹQ9[9[zJs_yEH֕:Y&,5su2N?x'@b0P^lk]5`uՖ<ک:PEݯ=;m츮kP]ڔ9kIe]rE0}';{ ,ұ4S v3×{߃tPz3mPq蓯rOևd*˕%n6.|/-[Rn*;:># gx"T>Zf:+.z:XQY{*!NkRpCLO8LݳޔT>ǵ<{I- ;]*ꨩj}DbƼ*R\N3KNt_0zYxmWe4us6RDڶqm/dzԋ.ؠ~N@JxKu]H>~Ŕ1{}nO ϽࡇT}@ze}20Ҩ\f~>i\26H n·~:ǷND9iN aݪZVcu UQ:ԁe?J/㾩􄓋k곡eo7Ҿq<5Y/ZT歗I0]Ig2w]G:GۼmKm(@7' ^P$m52[r 4\ MzRꜩE} P?يPw9W]6e7kw;Wʺ u{n3vj3+)3cO/o$sTTf==XSjuo^rzw}>eq{׻UoY+˖-3dt9Cc|E7]Hy,1 ,rM 6^훓O>ٔ\soD sMeTd**黮"en^i߰a)?`P{SU-u\aױ{(Wжl5W?q] xHqL d1ַv3[7%$=:i4uO~sV}[ʥj׮I;~UgyQǩ͓Ȣ>%SQ(mFǍ=u:0pO6e7W&u#_N^;~|A*UUPUW>'Zu f zTzE7=mE֤n1>|)5+5Z Os*3Kf:bZ;V_M6'fTT W[:M uך × _B 9 E{^Pm-٪5?q] )ç9? E}=ȩ‡q [gy{) $-? v=w,-JU~6oE}K\Y; |A qqvmSJuNN|nu̹򪲪ekHku|fz=apRq9dig?c QjcwLfKMTT U˗[q4bԗ~Pm-6c[&Wkd#?;@Sj7ϫL72!QʲݚHQ[N||jy؋н@8cA ,/9@VcjU*+cO?os,\2Iʜ#n |RT<.{ 7RU-s͹kJ2QeuW]}զԬNrc4S6vk֬1%\wL?aOW;] PR`eqm۲;^:<}xjSGU~P$m2nURkP_kP1hտ)}ԛdJ|ۈ;i{%h_ʕ+Mxʒ`Ѳ~_ũYEd)~ƴi&S*VonﺩsTT\qt**>gy)wE]IJ̵X!^) o6%$UzN^9ƇSMo~ĔM-SjBj\l} M״gCˎsטR;=9V4d**hnԵ+:۲HDteG`Rh2i^P$m2u:^#\AmsU2:LˢroƗ]5UuWķ=WF)f~On]W5}x0yΧF/X hoveB*ﻐ(;km66ܪ~[{Ejߴ3$P+48ѾS@ڶpu?:]#\l@?qv0~O?x)sMvqC|y~UM1nڮYf5u.8 }\=)ky\Yևd*J+Q,P.ݰ&U>:t>縜p :H~zSj~io⣎2 =cLmfJ1zBT@]"XٕH+'ZN^9'lŸ|75uZv]st~@|DB#n݈4hzשDUtk\ד*l:WԽMmnذکF(c͖/_r põU=У{͏=ge0qX(H@ԡ8? dq'Y w>5ԓMIݶRuWIiSZuBՎ[o8sTT\qI. yu=:U>:ECO7qVNQѯ}i%uB+!SF/Gh/NXIUy{ױ^_LTOh*Ii! H*^8uhEEMFGk1FtM\yYjosz5r&Kv_R#SQ1-[޸z՞A~2_ڢCu Bv\S<{GzѶTy^8Дڕ=(Z晼` &J_]_(HEuCo:(Sӹ&n:pu׮sv8 H*8_7^m۶RrJSj}m;Z87n4[VcLs6#p`v)wMŶ`OivntBl8sir}:٦Q7t@)N߁iERvS-PA_J_4K:iݕN?m{mmuducD .'J}GT^|ǐ#Wit:_uXlT׫v^gx0_fKQjF?}Y&$q KzzթF>,uOO]wYJNuwu?iVK2K@.ԞV\]( Uo n6 vsQ=m\֭3Kuuzapw`$-DuVkP?5L^~,-нlлi} #Zo9V`K#7 >_S}e˖}Ӟ}SB털7 tc wU6:UMV7|7tM?ή6<3W駟6Khw7Rt E*nAc!hUڮuWZoq%}WqI1![ֵ5̪>5&sHbݟYjiV2\F/Xj2a0g^+֮7ut}R@SܾSV2,KuWkPݯ?5LY\Ӆ'5cE,eKS<7EHD`ll M}I)h%WT6[~q uט::*W%܈h]3ڶnyztiz/{%0g: NhCƽ I?wk]uAD7ɏ[swsmnD'wO&ZG:?Uuc.xy1,1Y?Tw^@tl*28Nv}1rIP /e]'\׮,T鳳~WY>?n춣ehۢΪx QSȞܙ ꆂT嘀"EztwCKzx.4Yzkј&:i<1;hmtlESmk#.~h^m]HTnWQ\qB=ɑuijODžK,uQ2u# &ɝ>OUQjШ)Vշw.1OXK/CZaJ~x>gP95ί\zS':M{UU2Dڢnצ]"^;GM^CqtMc@uRkןHؗo }|i)ñ94Sfԏ5vo4~ LYVfWԱxLж>̟OU}kd8|Dm,}قmJ+>\2ZﾦL7G:4&U Nzp׉:6&. ~ewQPDG/ G9i*T}{׭^T?|K穖:uӈ;jN6%ߔGOyAuL.SLo~,5S/3KF8,z(G"T+)GloNהep2+pCSF;׸a>\RC Ʈ1?_ |^:_ 3n&S?:j&>iQǵCKs߶D¶EsYVzc#y j8!uhuAn`$~n{U`ӍYg $ o':ZvQ8;䓝mdPՁzdMAg9}{':g\#tY&v@Fn U1VQշw,p }X}炙石fRiqY皿u%εȋΩWA0h眑^̝׍ʿI@;=/,ny޺unӹx_zg.Uhz{Air&u1D?^k{)-S6PgwYжE*K)HJHY;/MSz3M6ӫ!7mj[' @grO`8e=:ulD4>5E8W{ES+AjEY1W@6zMڶe\;Mϟ ^ˡ^ }_e5HעVe N@y3l/5{R6q*|躟m|\:tl$UχhVw}4/<ߦM Eԇh@R] x 1Ӓ>_AfJcXU}kV*,1]+@/m~5@AP+2U]wkdR0i<um Xe?^OC+_T@R:\ś71o{eJ͆~)UA} vun- 1bE+P};~y?Tum+S2APEև%Di[_Jӗ'Wzɼ?7Rc\jjÃf SmCmK ?@uжE(aM 3ܷf_>|L)[un; Qt}HP'U8GRZ_7t8cLdS*_dIiǸllpAK0KӍfQO[hh@kGqD5gf KM~}~)zN7DEx@(>cQkjkҽW<5f}:P|ro~,*Ǹ^w|->/uh=Ԙq= G(m[ I2)o ^sM:/68sf)uo^:馛R3Ԟ8ʪ *5UV@R0Æ xAE)W_}@SOS|L$PϪJgkUi3s| H hP=NH09d7ַً`͇߶;w|2:j @}`Kf,P43ۛ~W!S(֢K0K )"CpY4Z@\rMeGK,1K ”s@9 *SAejNwfˏۓ%с9,] 1e@ؓeR4P8be0?Lmx0V0_)S>ws=@ϭ٦o4 陧 v{Y˱n4Kgvff~f *?6%M}sgMWyjCE LO҂ܲ.8R94:Ť j[PO#2K@yVlff:vqԚj~G`bfuk3 8Lݳޔ("@$E񍍍R3! Ҷ"eZ9j;@~qSZ0tYjvMiA4 O0y饗E[mgLZF>|J0ϵeAEG&ࡇ@$45X3.2˗MiigV"ˢKڧS~^SAEGlރLU[W~ @>&v҂+Mܖ虭֌K!m{vb”P7 Mxd*B25вsUg |z໦3XQkLEHcMiI+Lڦ;єL?PuV9 qʂ̓K n ,R|UIJ}mfiZ@K`fonQ0co)c3̭+7wr~g~fh+wqm@sCnJm߾=x2K }~?_>.O?H3)t< -/yKfǮLo)SxLwaqcz_c˧ KYI4glzۂ/jL~[7&Qt/?&;NSZlJo?}-kz17`GK# WhYs%۱#e$v_yi۔g#gvYAEGfz2ufif)?`P΢]cQpɫN?,-}&z_xY K<~} ȩ՟ ǃj[PkbO36K &coO_f3'~6šFd0xa7)ujFX3~]1b3vVU8Ua?ق6[&oeyI:PnMѶ9/T]wi~4헎i[pj7'}fi Ʈ,U ,jsk 8Д 6:j ]Jw)-2hp[p'HI+ZMR^qD߻NHG> ,ZfҲ_is`g T͏ĵ{`{O r1>CHUuzEea='H/nW۾fV!bEpn5@,QE k4~T=d||<ۯTۃCɞ( Jk}@]ھ笲w; upʳVl}pJ0e0 ^ߥn u>M Ύmu;Pi5=~ϱM! j,oG?O:v^߭T 3mhd9ݨ )N j w& 2z˒=Kޮ (&(H@_gJ}$l`_]gԜ9(ӟ@`^{P$yO5=+ID+ k~R3[`ϒ/_cJt{Ar^߸{OVBSGjj7(`5Hٟ ʈQp4ÿ}Hx>"£ /,mo[.KENWԩdi}eLiu6qMiIt zK2 =2Zn Z8[MPQflYǔ%@y@e:(O@E`7zl)3n3¬*-SĈlmon3 yvz饗R|3ɔ )ئ|f<(1BSZRI}Ng!ۆ Z6 , jڰnBޚMu+Fuh{(#V7f{evӹ5vݍs,6[ƹ'qقgSꁠ"1_8{zr5k?WY\f'vRz,"~ ۶=Mi]hڦnh_zYZ 1Jndj)lx,->$S*Ưվ?gmJi :yAjmE bJVUDa tnd֯҂D=]SzdLa{WL PG@k"տ)UOS%ٲ(kgKMe`Ŗ(it34oua?xД /Z>;]T۔N )"Ltg6b(r4O;@SZLHq35R-6uWmݺ|LviV4]e3?hJūb]RK^oJ :'`AEGl5>+禍{cJqW@&IH]9lS=xWU3bEٞ'ٹS"Y짬6-puJgf^S->>lJ })-D,fVxc9"(!IK*iLUƠ8فf}OY.F\YO'Wɔ̾)ųonvn_]w=g|ѵw),՟- Po@y>0UThؕ(t5֩_8NU6rI`)م0K8&!?W^Lq[0eV'LE3L?+큉U5s, ى^c]h%9ezkƢFar=ᱤ4e(fs_lzO@5T}u)-J"TIYjjpفl;|wۺ8UٿDSZi gO}b)%]_L?m:yf*"*+yӍ~w gLR9/a'~IjÂ_]]6]sEFQ#e3ʄ-FF@_o7K j] *>2=KNU22 d8DUʚd͆T3 \ҜBdo[ƣF!ZeGδlTT%yӑ'd9LV'3?ҔK-{E\ /?B/f.g뗩Zꅠ"#Ad*M1 *LE eRpO@@YnC+LiH\~є m376CG+nw1|}~0om@}TTi?KX7|)UX7 HTS@柘tI e)ꈠ"#d*b"ز yYϫ Ϛ[!haQg2YH*o=0I(1M V5YUOY.Ff~$Dk˷wφO_f0w?͸@ ~I cvpAEGH0jb:pߕ(N ++EcC\άI>Uj /YZ0ϛLiA8Q:29@YL.-h|҃> \<3d^oJ쾯1u3`U&Zkpk/7KݳkUzٶo_9hSAEGH0jb:`_|)-~^S7춶FV}̔7|{kN9SMt8Д[`퓙{j ֘R3eRwc$x2قn^z!m d*2ISĚMo13lNՉ+S2Yh<8=2yӦ,uofLidJLE6YUOMAk Pc-nYxZ a)5MuNR|5y=`dA~ m d*eשb"g]({Pw)uLaeuڳM_gJsn4yIje~T9]eࢂeih/>lk_2s@ \luPliq z5[ђ/_cJز[Y2ܟcJ \0[LiP?@ W%SM3+SQ)džWg ԆRgݟY}#nVM:>U'c5`m2UT![nhyt9:@]=g7ȶ-NY<[LuG[WV74 nj>}CO;$p)4VN3xgX&}פߚ҂0X̭cܠV>wM4:mW?.3O=?.^~9ckljEcK/,|:U;nPZ\Y?!SS8 : 4OqYǎgukeo7KnWfF*1[R|nT}fVHdl@0=]4pl4`M0}܉]Kh2h꠱؂M{UsZlkDӲtj?jc;ey\7Rp+IuRN5go)Ƿ"lh=ܞuY|ࡇ%7ֺUo^wP ӛjѱ6vf)q47K=clװδNw'h ]4 ^߼, $loTd Uf3D=x0sQE\$(}3kcBYFl@[*}ljjPQ _>x\RO;_M O*HNJퟸ2չ*ˀ-p5il^lAZyr0m)-LGӋlS)E,Z|apS74@0\jS^ }g,oF?}Y젟FZOM|mS SWdbqpUR%)w)uOYa0N"s,3՝Isun d:HZ/͓H8e__mJ^A"#ΰi4OMq<++ENFXYMϘyDV07mSVSp> MC4y-ީ~4Uǟd~3o[6h,T'oʞ:=!Yycg?b~c Xh̄j3R'qϓpN*{?5կ'왚K+_tN9Q9ǚ++ ك9|Ҋ9h[ tlWLѾus~NSmݺ- ~)fxD%I>@T@nE}}8ŒH;wozKCޒ vd@<=oGbMz<X SQq?p|x3qakU0ϛK7y 0/1 u~O>W{235u=k/7K 0.:P $PT ҩ~*# .2׍kO{6:]uCEߖ L٫ƮƴlT&,on vO2:`3o"w{Y*΢KgT٠ R! @=>{ QH_wbpeFPǃꅠ"MOT AET AET AETAȤ3ZIENDB`insight/vignettes/insight.Rmd0000644000176200001440000003224213614067316016052 0ustar liggesusers--- title: "Getting Started with Accessing Model Information" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{insight} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) if (!requireNamespace("lme4", quietly = TRUE)) { knitr::opts_chunk$set(eval = FALSE) } ``` When fitting any statistical model, there are many useful pieces of information that are simultaneously calculated and stored beyond coefficient estimates and general model fit statistics. Although there exist some generic functions to obtain model information and data, many package-specific modeling functions do not provide such methods to allow users to access such valuable information. **insight** is an R-package that fills this important gap by providing a suite of functions to support almost any model. The goal of **insight**, then, is to provide tools to provide *easy*, *intuitive*, and *consistent* access to information contained in model objects. These tools aid applied research in virtually any field who fit, diagnose, and present statistical models by streamlining access to every aspect of many model objects via consistent syntax and output. Built with non-programmers in mind, **insight** offers a broad toolbox for making model and data information easily accessible. While **insight** offers many useful functions for working with and understanding model objects (discussed below), we suggest users start with `model_info()`, as this function provides a clean and consistent overview of model objects (*e.g.*, functional form of the model, the model family, link function, number of observations, variables included in the specification, etc.). With a clear understanding of the model introduced, users are able to adapt other functions for more nuanced exploration of and interaction with virtually any model object. ## Overview of Core Functions A statistical model is an object describing the relationship between variables. Although there are a lot of *different types* of models, each with their specificities, most of them also share some *common components*. The goal of **insight** is to help you retrieve these components. The `get_*` prefix extracts *values* (or *data*) associated with model-specific objects (e.g., parameters or variables), while the `find_*` prefix *lists* model-specific objects (e.g., priors or predictors). These are powerful families of functions allowing for great flexibility in use, whether at a high, descriptive level (`find_*`) or narrower level of statistical inspection and reporting (`get_*`). We point users to the package documentation or the complementary package website, https://easystats.github.io/insight/, for a detailed list of the arguments associated with each function as well as the returned values from each function. ```{r out.width="100%", echo=FALSE} knitr::include_graphics("insight_design_1.png", dpi = 72) ``` ## Definition of Model Components The functions from **insight** address different components of a model. In an effort to avoid confusion about specific "targets" of each function, in this section we provide a short explanation of **insight**'s definitions of regression model components. ### Data The dataset used to fit the model. ### Parameters Values estimated or learned from data that capture the relationship between variables. In regression models, these are usually referred to as *coefficients*. ### Response and Predictors * **response**: the outcome or response variable (dependent variable) of a regression model. * **predictor**: independent variables of (the _fixed_ part of) a regression model. For mixed models, variables that are only in the _random effects_ part (i.e. grouping factors) of the model are not returned as predictors by default. However, these can be included using additional arguments in the function call, treating predictors are "unique". As such, if a variable appears as a fixed effect and a random slope, it is treated as one (the same) predictor. ```{r out.width="65%", echo=FALSE} knitr::include_graphics("figure3a.png", dpi = 72) ``` ### Variables Any unique variable names that appear in a regression model, e.g., response variable, predictors or random effects. A "variable" only relates to the unique occurrence of a term, or the term name. For instance, the expression `x + poly(x, 2)` has only the variable `x`. ```{r out.width="80%", echo=FALSE} knitr::include_graphics("figure3b.png", dpi = 72) ``` ### Terms Terms themselves consist of variable and factor names separated by operators, or involve arithmetic expressions. For instance, the expression `x + poly(x, 2)` has _one_ variable `x`, but _two_ terms `x` and `poly(x, 2)`. ```{r out.width="80%", echo=FALSE} knitr::include_graphics("figure3c.png", dpi = 72) ``` ### Random Effects * **random slopes**: variables that are specified as random slopes in a mixed effects model. * **random or grouping factors**: variables that are specified as grouping variables in a mixed effects model. ```{r out.width="65%", echo=FALSE} knitr::include_graphics("figure3d.png", dpi = 72) ``` ## Examples *Aren't the predictors, terms, and parameters the same thing?* In some cases, yes. But not in all cases, and sometimes it is useful to have the "bare" variable names (terms), but sometimes it is also useful to have the information about a possible transformation of variables. That is the main reason for having functions that cover similar aspects of a model object (like `find_terms()` and `find_predictors()` or `find_variables()`). Here are some examples that demonstrate the differences of each function: ```{r echo=TRUE,message=FALSE,warning=FALSE} library(insight) library(lme4) data(sleepstudy) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA sleepstudy$Weeks <- sleepstudy$Days / 7 sleepstudy$cat <- as.factor(sample(letters[1:4], nrow(sleepstudy), replace = TRUE)) for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } model <- lmer( Reaction ~ Days + I(Days^2) + log1p(Weeks) + cat + (1 | mygrp / mysubgrp) + (1 + Days | Subject), data = sleepstudy ) ``` ```{r echo=TRUE,message=FALSE,warning=FALSE} # find the response variable find_response(model) # find all predictors, fixed part by default find_predictors(model) # find random effects, grouping factors only find_random(model) # find random slopes find_random_slopes(model) # find all predictors, including random effects find_predictors(model, effects = "all", component = "all") # find all terms, including response and random effects # this is essentially the same as the previous example plus response find_terms(model) # find all variables, i.e. also quadratic or log-transformed predictors find_variables(model) ``` Finally, there is `find_parameters()`. Parameters are also known as *coefficients*, and `find_parameters()` does exactly that: returns the model coefficients. ```{r echo=TRUE,message=FALSE,warning=FALSE} # find model parameters, i.e. coefficients find_parameters(model) ``` ## Examples of Use Cases in R We now would like to provide examples of use cases of the **insight** package. These examples probably do not cover typical real-world problems, but serve as illustration of the core idea of this package: The unified interface to access model information. **insight** should help both users and package developers in order to reduce the hassle with the many exceptions from various modelling packages when accessing model information. ### Making Predictions at Specific Values of a Term of Interest Say, the goal is to make predictions for a certain term, holding remaining co-variates constant. This is achieved by calling `predict()` and feeding the `newdata`-argument with the values of the term of interest as well as the "constant" values for remaining co-variates. The functions `get_data()` and `find_predictors()` are used to get this information, which then can be used in the call to `predict()`. In this example, we fit a simple linear model, but it could be replaced by (m)any other models, so this approach is "universal" and applies to many different model objects. ``` r library(insight) m <- lm( Sepal.Length ~ Species + Petal.Width + Sepal.Width, data = iris ) dat <- get_data(m) pred <- find_predictors(m, flatten = TRUE) l <- lapply(pred, function(x) { if (is.numeric(dat[[x]])) mean(dat[[x]]) else unique(dat[[x]]) }) names(l) <- pred l <- as.data.frame(l) cbind(l, predictions = predict(m, newdata = l)) #> Species Petal.Width Sepal.Width predictions #> 1 setosa 1.199333 3.057333 5.101427 #> 2 versicolor 1.199333 3.057333 6.089557 #> 3 virginica 1.199333 3.057333 6.339015 ``` ### Printing Model Coefficients The next example should emphasize the possibilities to generalize functions to many different model objects using **insight**. The aim is simply to print coefficients in a complete, human readable sentence. The first approach uses the functions that are available for some, but obviously not for all models, to access the information about model coefficients. ``` r print_params <- function(model){ paste0( "My parameters are ", paste0(row.names(summary(model)$coefficients), collapse = ", "), ", thank you for your attention!" ) } m1 <- lm(Sepal.Length ~ Petal.Width, data = iris) print_params(m1) #> [1] "My parameters are (Intercept), Petal.Width, thank you for your attention!" # obviously, something is missing in the output m2 <- mgcv::gam(Sepal.Length ~ Petal.Width + s(Petal.Length), data = iris) print_params(m2) #> [1] "My parameters are , thank you for your attention!" ``` As we can see, the function fails for *gam*-models. As the access to models depends on the type of the model in the R ecosystem, we would need to create specific functions for all models types. With **insight**, users can write a function without having to worry about the model type. ``` r print_params <- function(model){ paste0( "My parameters are ", paste0(insight::find_parameters(model, flatten = TRUE), collapse = ", "), ", thank you for your attention!" ) } m1 <- lm(Sepal.Length ~ Petal.Width, data = iris) print_params(m1) #> [1] "My parameters are (Intercept), Petal.Width, thank you for your attention!" m2 <- mgcv::gam(Sepal.Length ~ Petal.Width + s(Petal.Length), data = iris) print_params(m2) #> [1] "My parameters are (Intercept), Petal.Width, s(Petal.Length), thank you for your attention!" ``` ## Examples of Use Cases in R packages **insight** is already used by different packages to solve problems that typically occur when the users' inputs are different model objects of varying complexity. For example, [**ggeffects**](https://strengejacke.github.io/ggeffects), a package that computes and visualizes marginal effects of regression models, requires extraction of the data (`get_data()`) that was used to fit the models, and also the retrieval all model predictors (`find_predictors()`) to decide which covariates are held constant when computing marginal effects. All of this information is required in order to create a data frame for `predict(newdata=)`. Furthermore, the models' link-functions (`link_function()`) resp. link-inverse-functions (`link_inverse()`) are required to obtain predictors at the model's response scale. The [**sjPlot**-package](https://strengejacke.github.io/sjPlot/) creates plots or summary tables from regression models, and uses **insight**-functions to get model-information (`model_info()` or `find_response()`), which is used to build the components of the final plot or table. This information helps, for example, in labeling table columns by providing information on the effect type (odds ratio, incidence rate ratio, etc.) or the different model components, which split plots and tables into the "conditional" and "zero-inflated" parts of a model, in the cases of models with zero-inflation. [**bayestestR**](https://easystats.github.io/bayestestR/) mainly relies on `get_priors()` and `get_parameters()` to retrieve the necessary information to compute various indices or statistics of Bayesian models (like HDI, Credible Interval, MCSE, effective sample size, Bayes factors, etc.). The advantage of `get_parameters()` in this context is that regardless of the number of parameters the posterior distribution has, the necessary data can be easily accessed from the model objects. There is no need to write original, complicated code or regular expressions. A last example is the [**performance**-package](https://easystats.github.io/performance/), which provides functions for computing measures to assess model quality. Many of these indices (e.g. check for overdispersion or zero-inflation, predictive accuracy, logloss, RMSE, etc.) require the number of observations (`n_obs()`) or the data from the response-variable (`get_response()`). Again, in this context, functions from **insight** are helpful, because they offer a unified access to this information. insight/vignettes/figure3d.png0000644000176200001440000010314213502774207016155 0ustar liggesusersPNG  IHDRAxsRGBgAMA a pHYs+IDATx^ UW p$"W$FP_)PBE (55L,Y_h6/f͚K:\wu2Rw ֘e( UE ={|rn<_)cܸqۇ;m4o…淀&Ng57oxb("A(eH֮]{f \(@<]]]fi8:kZ3gzW6k)Z=pJE=ǎlPo(EXK/x=Pħ,be P媷C,h8APn:z*Y >S:Tҁ"A*ư Qaw =d" -_ApVSz9A]f7~xSNo'Ol3ą9zD E斛0aqF($ǁqH *{l5|oÆ ޸q۷'**g=N SI;Z9a"llp,Ѓ @/dA5D eD80$z9A_~,!7VxV4Ph*(NP5  9s5hU @&\  .dPy\B@0/씽S6K b g _yAC9,! és E-Zd~5ၔ!;v7}}'?M&@E4߬kf ?{*@1EǓlbNPFA? EoHs"ٲeY+Upj ¤NYfUagCHrJk'ƺG;w!E^tϤaAN<3(R+ij-@ױ÷R#Wը?4P*H7o7jPuSv%KR,R!d?{^i@=],ʠ1'(`wu (Rpѩ柩5i$С5۲eT \FPQ (?=u'=P`U t|dN{Ȃ4s}1 Ytߧ^?/z (RCOq:jW֫P%A3gQ (/]3=0\ |=: +Y| @)8u3vXvu4wE9dQPa(tyQ (z5u/iYZjYj{ !#%g͚5:zyҮ "5T1V+KA }c\KV2;g[zu6m0|LPdMA$D(@U-\z (RCoqYn\ rvPOm(+ŚΜ9e+Cw\ jӐBukQAG <_ !,˟ǁ:۱ (RCoq:ʌX`YQaرDQ(LC[Q (] v6^ZVgR иrJT@1ix[~׷fu/>DV+A&s(#5jϨ=Q 1Q (^z]JKk eP {Y/x{s/v~bΝkZ1*P-dVS8AP(}e>ƪ\Q4P( 6D 2qHC*;9 tҨ_]NcHNкdxu/rK?O^ ]_#R`(42A@ue[MaҥKRtA*q:v"S#kؐC,[*WҼòKiNCx{rPgξg{W6VW,ksuV]nYG3Wzk,FFЧN?(o;۷˲ϤIt P?|w琇_|ogOx/~sk#C< COLX]vv7z3 󐮮.4Q4 /6x{/8Gf%Abu6r:_l^o?V\CmfEh5{$mr󽓾uߤ}?~oy+jU=GJo+T4Ms0S=^LX(FBk[ĥmՍ"A%?q' ~hTɲ"ҹR`[;~VqDʃuW/~UA¾uދPa\s؍$u-7FuR){ ēisg̨*qJ2eU~00G 5k{nwo{Wd)ȹ{Kݺc,0?U$A:vjO^::q+xi?o00nX{t\Tt}4u:eQXVzeuf(B7ha7Юn p!AפU2jT\5i?t})ȣ~{$뇴QOCž/4jT(1ࡂ c@%MAI"}{èq$HmUB1s$Ws Ҏ hX 5RcD;B4x{ꂏ܍^Hf+}n;{+ʅѾS~輧qP(rݬI @+/ zg0D7EURuc]R{~;3y44-tqmR%[״;df)}{/lxNJ?țh'=wT 0 ^Yx=s>g! P4!>՜\Q:vv_Ci;\dq(9 KmA϶m HzBIƬYR2- V㣎?@h=BK2]i[T-CGXd3/BdY YX*P4F?~\v_`eQNvШT\dz%+jЩQN9,Q?fi8eB3k;ǿYvmUN 0}i`/e{*s${;[oׁSo;Vzn_CX#46gFӳSV+z$Si"92BÞ[Pa¨PC+eG x vHrqG{ݧgl5zyKy==~UaYMgK3FqIBiuP1$6fxdhnLs4`}lA5>hGEy NU6[qs~$j^CE v͘1ߖV/=l5IcrJaeW*6Asԛ 1J٬,s C>|Q@2w~Wúym<&7!p:Ar> #ovedF1x.ǟ5K_ _$,S>hN3$`y?Ь)ߗuI'v(ݳj?n13>ݵf\4^PP񐬤>*gEhw=7Au~%۬{6mվ师ObIh^mr;=wX<'uZsqA=4 }*vh;kڵZNo[wvn(mq,Zyͯn"~Wk{WtlGrv:OQN~Z/^l+Nˋʅm/cŽ]^Hlej ~rcEmKKϖ-[EÅ-$!S@*<_DGzHK߫mZ2 ZƗ~o~}^i}עx}745WX{ |}t;q_5~z?,G}ocjxn)늷Duvj$N%U':n#.@f6 ИLZ1kEQ&Goڵz 8hۓnU6;b U8ʝ&|Γz $mSt*K{1Kr k/j۸ߋʖw ;u̵^\e++\CKYHCz|{^3KY}}lӖy>guRNU7]뽅'^g)vٔ>l~3zG1kJuؔ2F{o>%6t3@UǗ-[o]y9hz0yg5jF9TRx[AP< ], T`R\ ۽jժGTÎ*dI'%ױ>Q08N1)aJR =5s}ASgMuC4UDT\=uS}~%:;/mѸ_{Z!=UxBy-O|d85l !i;t̒ݢ.u?m9oUӡ|ўv^l1Kv3l09ݽ0 a窑+, {2I^d"UQsԩ񶂠 UУ{K@6k,dN{B T^=|ԠK=^t~]JK'кȣGZtR̋/,مu+e$Ia auasD^/*W^dz!:Νk5T"+P9 ZG o6?sX;ڜn5O*g\Yr ; fzSb&wf #IUӤD.\FICY3APsԩćU:oTфFvnT!NTHIdexwZ)d}qΕo zWF@!F126upuPTZw\}wM.n(r}CQ9>7 ɢ~HOU/¸lw߳4kCzAǚ`AN•;w%(ۇI C20{X`: jH^ YUj9 pI2Tno²,HC iV z؅̙3R\J_4It\_^nUinu%~N22e7vXi]NNa/Ε~S=^@ GDW6FzzfоQ!=#%Ǖ ?2KCOy(ؠkowYj P(.5d7]R2F;,'Ȣ<:UmO#\y\Oe7-E}Yк^jWpT$&y jnt\#%T瘠z \_e"+#~u7|YBQ 8C< oބf-\P5,MW6+@rҵW/h,z:ЬcR'3KP#OUdz2uT*Q,nUse pl>,ГjqU*԰9Â9Ȣ"ru<8WQ:E}p5ޗAIGWכθ'Q`S8u4M"pUPUpg^Oʷ+ȯuWV~RC͵\EWvFr`׾~EC#?+S>kIsNа!uWLn돫hSU<&79A]R{2K {a† @-J\ze㱌;=! {Dß3J,k] eu_^Aia(@TEOO蜠s!>4o xݨwNg^w_D|N8,rڮg6K0":`P!(y@Ӆ(@W^@e}է)*r:vFh+<S77o6Kvi}]..Ey.C.ʱKא+ y=x.]jZ)tsTtTFzH ⺩;vo}.Fu3j*Ԙ],Q h5Qn;  |a :w TLkX:d}ެ]u3˛Mޒk*un󓬮7AGR2?cZA9Nj@mVs۱(h2j3:Uj;W#Q3tv8ܸtImS؍ZbX7Lвr}ybhKQ,wx?w\ԪLP߹>oҍk` *K4uݐ>KX:bQ {H[wIUׁNA5an)2A?rf]tڥf=+#o%CݯEQi/YaǾb:̒ݨ3K:+ uf #A^yj̠ڬX27 SI79AFv洨BUZ,aͩGOWmYnteVj 3|ΧM~TRP*≚M[iW٣Q VAIuEy'C|1LȜzztY+'^=o$}-{^!Jaqp.u^Y瘵VOn߬Oofͮ{fxYꥴCmeJr}\vt-pyͫw ;qa6aV%vo *&ϛ#|mmV\iZJ=h5t}MbUv櫃]u"t.z! }}UT/F#FhCyUbs޹~vFs*;ڙF1)d/w ,ٍl? [am#u**B}TIZbœT=^p" *(V1K1ò2Ծ RC~?,t$Ryl FzNyْ:"͢~uJY𑎆|U~?,Y 0@qQ?䧬\ƘrQ0tٔz;-OHv&WYOX>tg͚E_Us_0?Nk>y`ݘ,U\M1q=9FU)e\/#;9J^z5'hQi{E nNMv"lhP})?e0]0ˤ/u8׷~W9@,{{U~3g9AyAqQ?93Aw6Ks8o ?;t=y!zoij|ynBtc.7zyf}풏ҶVoD#^t* T6md(hsvdv=ۄʼjj3&j3%ԞQ\űMH=GJ/pq{V%0V%6~SBC5ujvĻ}J ka'r+:Wݽ*\C2n4&tt3c?z@2rN~^}ǡOUݧ}g~J;CQ?g&h(2w[Nԛ|DiP(k;S(=f͢}m~0tg/w߽}/WX2P]עr? G,bQkJP;j6-_SI7a\q;_y5]N\T_hr *KbH\1H2D׼RP>䄖3UZn3X~TpD_&E>2QaP}S:W&hYÍBC.<"o7*K4N@TPB6?ATBz~{S(l ,U,}=YS}u֧n}I7a-&=vf͚eZFQh.,}*J\s\,ٹp1R)*NS]s~t ?ʂr"+{UVC|lCF`V 8[xBܡBv贗cf-9~tI{),ys@u Z6j~#u"z)  2\ {v>iڴifn$4 }:*YuVaC\JׄXjYsOSaqi8*'2Uh5Q?u Zp}z ls& F"+;UfRC|dW~UvQo/zo}߿nȯ/LN]e0NPJ?{A>!|*Cepړt=^pMrz׮ʶݞJaSX**5m$d}ϩ篝!q]u@@Y-Yl2j A2~gdzeCVC*|Mk춾YB谓_r63R1;J&NuuuySL5\c~ ʫ}<8J&`+2d=sԮllLI1GDEXP@8w\J_^~ЍU6=c)lH]5 Fׂ+K pd8IqEG22W@J?_83AGpQ>_|}ACbo}躯R^1k.INuSP#^wu7DiQڤ2sԞgOYӺRjU8 q Ei<f1@؃H1t%4|{~* /4KpeV;l\6SԤ:RiUpؑ镾:rP?LPht="y;^0KFFTR ,0KvjN&A@tUk &(Pa5I;F9jٓ ;n=e*$k:a)a0adC?FK7s[J5Gfj4vXcP5~u}Z*rJX@ǰQpTNdzjCXTZ٨E_J+í/o1Kv8,! k/R{YBt!yuYy|o6^;C(:$Uj6mYK*6(uݣkٴQsWZxa-BOY5>.$NdWXA\GRn.IKXOy'ot^!ԓ?/aSX,X ]2Y Ĭ7 ˥F"M)Zwr? 颺<ޞIq2׉UGW:t}ʽ: ~}3דb~N /[*=dfUQ]ԏ۬y~0ts%[טtnݟ񦬻ʬ}f Y^:t\;ܬ-fx}og//_9?xڷf?rH2$;]]g(CyO1n/Ҭ ;nQz.[,)NpM3,P=ӓn~B1PdQ\ }Ӷ1ѹn*U ՛?ma˪6q5%-vX/"ӍUPʑX}QUV*?su,0"=D:@UE]^\et?{HW:{m 8ž/_qY+]tEWōfmמoZ⍽M5? 6pmn̒/"֗<} ?TW/xwW=k7XlawTe-dD.KxسGq=cvvut>ǎwH?GQYw ֘t11fڵ3'FA dl.(I0^x})iOaaCtC 0Qr?1F Րި~zG_W֓( ΰՐ*SSzk_u:YEu]u=dU?wJWe˖DװzF.K}?6fzWc&Pz}uLT74-f@*秼>W2>_((^;;[F?1z8)Xoow>s'N9XW|{i'ntoa'{.o!6"熾-~ui8)ŸޱރΛp'HRWWYN 힞?y7dpWzc>Zc=0Hˣȥ6n J RtL?Azr=QFnmҸO4hsFnf->Q񶂠IU`bp8Q/F*p*Q*fiFwUYޠO*UrIKAFi; q22 7wA0uTژ1cƾږu\ԃtaeWMꈝUYնk˸:<7ϑKK/p:EN\Xehv4^;nOv^~y$)x/,99J+:m!ShQi~Qf] 1Ҽm^dc`3PC*k+9:UiWU[ZzOe,,Vo+z?]Y1{.5kYjH?G.W;z hԣhԋ-.ԴuVZe֒ 1W}dD҃zbeq\Ҹzp}!ʌ2]} TkY״KZܺn*RHY HL(*?_w'^K&>oǴeԱ' kU,:m޸8`讯}KvN2Ҧv8ۧ-YUj[hޟ(sk ,u.toF fѐ74=5tlu MT⨽\%c<)b1 ._E^3ɲbWTqʡe7H@zѩIZA؍꘰LdbP+ y3 9,eGIBW4)U#P/v'CJ? ;{|>u|{T;k TmU*HzedU}\E=UFGm,]<t8Gé}x74ƽz!IF^:Yg@'RfyrT$Qxz߼YceIy~=t^gQDp"k:Q`_B@4ԅk]/iv0эqu:"#_U뇢u*=,<_x/~լT#xk}g':?h{#:D|t7O{nzoz7|dy__2߱;~u~ UT E _6KR ]ez=SߪYvpmGŠr>Ƕoykϥ;MҾR!H?Gu=5zHF7NWG&Mq)mw~朋E?n\@V\7OEZױuo:W7FC}6m(2ݰa|jT.7V纞tS/2_txA>YwM{[A}_ƹiX[)+(uq o |90{m=uo~zw{k\.+21eky=[S{#euؓǾe+:Sgׯt߿_FO?ϬeC {5-4$2ʴOUUq}f<,fg2㶃(.g(xUe1XtN>z1Ј9&MEK#e]E4 hMZT UAm)/*g\J˥Sbê\O W *?_1+ j?_ *p;yqwA|AAP56͇ڃϘҰ~ViFa^mCj# l/|U} X 1s̒]5k˲@%,* ,0KP^a2rӪ (4kxXWCOp_oZis7n\h L@/O>h&!φ4:i<*HX=^oO APpժUfͮ =ՐG> }rJ(:Z ^}Wo1Kvr;\yQ:|svҐwT(Mجq]c{ɒ%fx\Y3޲@6<_h"?_Eųm2ƿ`*c#},ٍzIf)Yw6+_hfNבqsaS% (_XUElPO~جZhY2?_EF&h2;,xq,مeCm(WC>裥 Jh((-[2 ((*44]Ü,^@|Ϸ 1 <5l=V%)#3Ir̜93̡4ET#@1PYomٕg/_nmTIX_ J&|a(@uP2gɮ}۳~6ܘz_iұy?Ьqo6kə8qbca>… PjE (57rC.,wߎ;% DQ/L *$ Lw}ZC'v/uB:sN2eXwfY  i*J=N@;RUo(sh! 8| F ̚]{/퍞~IԑMo y13>ݵf-y5}EQ)*Ǝnw(J=N@%"ԛeʕ~׬j7@ޞuE^ZQ:>t딷z]{ }A? l:Rnph[ԁ\a"hs=׬@' m $ŋD'/tO@wݴ}ڤNqFAH(/ I&t3KDcah]emRs%@R6[Λ>}YsӜeb{\ l$; ̿2yGG@XޱcY$ (I7yuQsٲe:g '@l=T槆1 ;v{c~+D5wM}7ꄓO('Ё9sAP>5GԩS |L2 ~@tɭ <̾ 2;Gu;`-'yޑg{^OOʏ (ƴ @UP)̿P AT APB@P)AT APB@P)AT APB@P)AT APB@P)AT APB@P)AT APB@@~yw1kx饗+9:n67UeCRtʺk~sd|wNgJpdǼ#^;b~ #d]跼۬ I3s?wyOnF?IgI*;~UoZ>ޘ_d֊ ((aN9ԂjSC]3̢=C=_ʀ 6{}Ͻɛ|D=:`M0_N2v}fmHU-7sRÞ{fmHȲA@a)q,{i槭s7x{gbʮ{f]M6_cd9SzY£"+c-<ؽfW~6ۃ}}к,@ؽ_9s3Cި3&@.~fa{|^ ;?{#fmq{oK-h $"!w;^ׯ7kCzo\\j>/{Hh#ɖWr+Oiמ3K=F:GoFEVT}[;@eWg|\t%NYr^#۷{;?\ 5_}ىK/dۛ^~ѬA͖2we6gfa*Tl5W.P4uWlԐf6cZ1'h4u1f (..NPQ&c/n4kCVsa. |'}YKע:EB?emPS=Lm-bg04_ 3df}zxh] (Jemn\_5T٘́,)<2}/S1K jp/|pPf}bsZ-~ޯګJq0'(( fzgnVfm 6[o_]g}KYc?2?E]]~w7zƇZBPT K7#f4OTsVṶqDQvQ$B`;Z; EmӖf>SoϮ3k{ݣgĐ(<2?_ro4DN2k@ʊ=ͻ.0kCJo„ f-_ZC7;Up w 84@e/]1*?淪CD׬:h~ϑ(kCOWReFq_6k{͛8[f-;YfQ}:U/i1 KϮ7R9TˋY~msyvtpW{TlZ:7,y+:جü TC(6tOj: GS:~I^כOL;7yu^ {~ʺ ^}o>l 'ygN|tyW~RX;[Ys'|ػKj7='ɳ5vE/$֘ڼjq^jtiߐfqĂjмً'}O[Q9؂͂ysQúi VGi[qeeo - =WK{]cշOufչo<[֫;oyҾj(O]q\| =ޔm_2k{) Z,8ۦ@*/*7*?QK:V򫺢84֯E7硛ZW˴&kc{nakĎgm77۳ޮb:߆1 ?EVz>9?@d87OU ͒]PyUIC~2ޚ5@}}~@'Wl>PcfmeC,Ե{tw^=߬ /N':]tYWXU+w6 >c׵ ~Ay(ݷ-Ӭ3.])@B{6jȜ*o/n5MgeK=$w>{(lHA8Q=u ʒ-yc_o_'()mD+5;Q?jw@E_}+*ڧ9o5k夠{/5nIt TꠐǴYge!g"ζnQN:5TE ~W鱩+R3p4 p,OsY <(A$8\ۡsOA6^dL)uħ.BeBE4߽>R?؊}{풏. `a\=W~?lvef-֛!],m[~, (Dg?gW2;dfi85DjiT#5F*OQjL :'"ü֩qyH,Hhhm_'n4Q.'(Ldlչ8װ:({󢠍G:Ν{(6?tϪ.ͣ6 gd}I gƶ;HFT~2 %k\7`C}Y=ZW=[]UfHW;^\kAycXUL)לuf),M}_ެGٍFP8p1Y|she`~l\ S ^7_3\mOK,( FfqmGXF{/z'O6kݴ_طZ5ZsA۩4'hJe((vl7{AE-AA$m,ռfq /}oe9uljE*hGMͲ/ T ;-Đ(.+j > ")072?iT&64ݽ_nዼ4<{fn\!o_?`]o~Y24u5d'k_5Gbz9yity>m;^VYw*l<tۧx]:ssi[O煲n_B\4͇:-'cۯMԡeFǢIY}Rʵ>[2g6{/(W+'~ǻ/SVYx=vYspUKRth?w0|==W P}/>]]Kw߯ ]7AYeGKTsmYC\ 2a~H)gґv)0DpDi5 "/rnS@owԯ h ?2 ŕXcmlY.8mblz[#YopQ[UհSK۲b f4{H[&{ZQ6Sq͠ c&T\is/e^hQww!gub%c-o[?5KR~vWv^,K2$5w}h#FAv1~gPLYwzYf l?VpeeaҐ4O`{34KCvA!m?G Y6k )N2AU{@-lnp!,se!aSݤWiNPWPb@`owvgS)v -ɓ'xlq7i)J.lO?`˶I(bٵ3[ǩ(5pLMpQ5{q/bչm63똑qM^pf4hfgvFUYp<, 5C 7MLк9wC3 PgnpP w,8oءuځ $T,}t~\ hkQ9A]d *ST_AY=ienZ¯ҐC6 I +E;4Pj־wz}7|˽Wʮg됶1XWNxؙu^ǖȂoys |ș}}}P} 2dna;m}nQVO'K^>{noV#w^n [fjc6;͔\la׀Ϋ1]kR^,vvJP淖sY\_;杆Ľ(RMvT*AjO3-n6ft4cAif)5mVTvv߽{cxG|boy|51 xOkǒ3A-%4@RjtonyO AP,9ەjE.Qn`:U6OuǛxKܗH>{Pvcrqfi.*>rގ -4/ұNgR/ڶgN{? YfrnƹuQ:؎COW/qhsAQʯY*۹΢NXu Q'J(̦-PlÔGV@,'?x\{>Ro͑q(vQ!c9x06 p];Aน6Q_y%z53mnISA@l~C`iϑƾY.MzLy!o]<;ޢ.y?d_Ϛ%Kٵ zՎPHL33Klބ~0Ic~ꦀl㭩̽w@&Ӳ۬V vĈQ:e$E,ed\n`Z*HLsMIV4jCơaow}AB ǩS{||^@ٵkɨ#q؆m Zv(n&-yNC3kCr Km[V|4r d#XmQ?ƾrd5w2T^^7yJ=Ts#wC6S;-־+?-<"oLAgJrб~k?goRlV#HVe7rc@=nƹX'B&m;ʖv9vYI} ;Zȓu8ܔJQ}) T`:.K/4R4\[" F /aWGՎ+>LYeV~Wf{4DvZ|4d = "CmmU<;yJ򡣈: ĥޔ}fmȂٟlLSvrqfiO- q؂-0,5,gQ:E{[fmMj:цʮ-cЪV$qn۞a)جtC6H~H\[yw%@R(E0'mkSRx w~^4dQ'dֲEٵe9vb?x+`0sҐ2ebYbۧ,PچU-7Ev!ym eN@cfxXL*C%m.zY&j58FN[\ۏ4KC5K *HIfx^/-};6rJ俛bSYg9,; D Z(n@mȦ>5pgf )f XfޒOPv[6ߥUϖF"/l՜ɭǩ]|APL i,X_B"(alA* qAPMe׮L(YZʧ~l|$=LiYMko` N;RXvv3mڐ8w 4G)Grߤ:)YoW!&4K@~uThj FԎlalG6ݨ3v9fU`OR~gk2)=Y6j'>ds9vyԸڐY*_fiHY~ h,򜠶 R$\lA_Rtci& 32D]l.]'?AujI`%+(і5YVYKRyGpU5f|/7YfT>l+!H1.pI6t=l2nf{Es {>\ƞ%b`ke72KCv~[}w/7KCF_4,%'9Av/!{V0Ke='YAP -sچ'lK@CpY.@Vԇ 5x0vqS-r> dpQt%fmHm:}MKl,lfiN48M2Q k&hA 1I3[cǿ.pڔZvڎ=~}Y3ԩa[&ʑsI:Q9~M!gL? ?GH5ؑr@)v4۾M̌N5֭[7zֳtN9p̹f,E]_{6\rM !ڟeìSZIki 圠ulPڿtNPBvCi(+Pi 7m3O, 7/%w[9Am$6|Y ?7eUfm圲뤠mEy[f-ΩΕ-ص/q$Qo9s3ʞ s~A53k(ኛ:+,$ZvYнG0=:OY16?dt=l:}^s׮5Kn ){T͑,eg[;5+xy=oܚB 1ڬ [~gm>oܺ}fX(9ATǎ՚պ>&a]4KCly  Ѐim`O z)hd7"{QU̇fj$ j\.;ͧ, Q}aqUKAFtnŧ\f \~V69 2RTLPϹ#u9GWfbd'=70mʑY;)zu/s8' u}׶v,s|QFŲ)5ku+;}/C]t|kc7Q1lq4YmfE^L͏xc~}AfEɦehk@Bà g(5S`Oe/#ӁFt~L{}pUf)ʮcTם|.pf6ѼݓΈՑ6і{g ܽnVu^k2@.Q#`#KvI֨8WW/dwQpb-س弥aT(v?cZB z5Rj`֐}7J9\e%jyc pw΃s [oyCkNpQʎҶ4oO#־+fMAC={*,(# 5WVg'IA(T^T7[s$vL#x2KZ52w7)P]]l#-Vi[ztzlGmaAN7yQ8}41mYA jXnӽ[o7kS1)~GJo„H3۾kXf-:r'z84길5tڹ5o`ޠlc{;Nobq)WYjOF7(`r/6LS?jWZ(}g//jf۞F v}[ zY+l,n|뻅y3-H _eE417y̫X %A԰ j^5*;@٠jD.Ҳ-`"lѬ9Pv#Q0Aۡ+8ڳ Ysc >̙q𷕻z\אʍ]HyujcAA;w۶-dIFKٍH:ږ}iѩۥ~>*ڦR~=|] mZu "6U"I=l:Qݰw4_U 栍M (!QCyQ@Q9jMϜf)JQv)CۂIimӾZĜqTܠ!q?jSM"u  U , R6{S`-~g4'h~fo-So~NsЛ-()ZA~kǼQ`g}NP 対_K} {(sl6?M[%nN]2/1lk:v: kɋZ}Qi{T[e)޹, Qmŵ sN4&k͹:u($E϶yͫX 8_[5|nŝ+ѥw-&(/ߺg_Цzf_RvQ2d6R+RlwNPp^g+죂8{~Pm57k{)0wvTUcWWw (cN^b{_}oTZ?aNntWW-9R=bx|>?~ࠌ~aؾ}E.|Eck'@c.|zt l7Qrt.G?bGTndh~󿭴c}޳|;yG6͓;wyox|}n =u2='ꬃ7m>rkmgx{~'{br;mz/P9A@!}{F}_-z6Q=kB M8TA4:7:G_?Oy oh{ u>Pe=83]ZV3_}M<̲ܷ~= F&v[30CejrA' Mgs(s[]:_Tz~<6om>e/=o,W6ϵ祉g]h8Y?ά Ir>TJ/u\em~XmE;r7a$ܓ*yA5h=UR[3ϙ:s7JlspǷSuVO]lֆh1 APP,}}5O|%Lo͏rQQFYB*6Ds&9bk~ˌsdW¹Nǣ{nmsx?p1y : % :- oZUꔟ/Uf1PI!`S|#"p: 2jF FE4eVڦ@ ((}6(^!=KKPT`/?!^wL)ӢyZږ֬APP,==|-` հʋ>70{m^Y瘟L նAPP,}}fa82AMn<&? .ELs2,(Ep6Rrגw?@E1@nO/vYˎR( y\5~˻^” һ;[<3SoHSpu:@oW{3bʡ/'W_M0(w/:~?{Y秽'Wˀ ( a5MKZv}7S:֬H5]-ف OKNuʧ~z t9_^PJ zY~_Go5EU(kOU\ti90.F4ͩZ+ `NPT˼ 3R ʄto4`e@6KLA[oO-*zoe-*AP@p]mQQ[O?2(H!RuN0'(uVkֲ3zũf@b aMx?*#΁I UBמ67зٟb  Is*e* (J! R* ( I0{`IENDB`insight/vignettes/insight_design_1.png0000644000176200001440000014643313465514404017674 0ustar liggesusersPNG  IHDRp gAMA a pHYs  ~tEXtSoftwarepaint.net 4.1.6N ̙IDATx^xTeuvwwoٽuW,J5&H+*+BB $@;̜7̙If$sS „A0a```````t(L F„A0a```````t(L "m8^c`‘reF{0 !rv,Z= +m%}woҪu5AXtm6zha,%dY6U&B+{&%%W0,t3DźwgzLem#oTn݋ܝZ.$I/2߾c Im3FI7y$M_շh3 >&[M-EqKDo&Y7l!a`XV>M$HJIZ+iol׿Vʴ[>Pnhn9B-uM@ξ2(j{Ќ-&n0J%j5^D]3gG?Rf̘-|ex0E;|ܹ'0g(L7gGVvM6~O+0ax7@%_/V~a -Lhu_(L6mR[^!,Xeo@a9$ F0Ԓi/˒-a-L2$̙37wq 3Q2Swaa:vea- L` D}}o[=?sl 3MDGG˵^]\wx%'w߭~:*w9СCbZ*Lt SCV$Idڪ- &YNlm&~)e1{FV40AmE䲇8va0y>)~/Iď]"trj+ܨߗZYk*rfQЃ!Jgʶ1V%_Z})X } rv@R>D/^{֭[^1վ^e]ks%Mr[+5c|9>ګ؇mZ:Vnn z^pywa8⪅ih{? *DfI;7<}nd:ω ˃>x+_ TpTu9>%0 P5 oִ 2 N; 6~>UW֦7;s z(»j|qBEw$u]bȑZYό5(=IfcԳʱZ2b)Y3,e-m#au-w(V&(g(a_iy(o!z֚`WGU"'*c#PvZ8&%(ur5%[%CS촢ەԏU: /^P~y s5E>@n!,&=XQ\!egGИRiV #=WYQy>}i>zIѝԝ6 azӂfy L:J߷W(ޤc)[Y|VHg9'ҝamÆ_Ma)6`}WfᤳXj|u-{ LI?]qNo`lҥgߐhI0ZQA`ozZGƟQWxeBV`g~$ql݇ ̹n0u}w+ao8Gæj$ 2F#::Z?k" vCoaшHDs>J/.#2$ Z"Jn;:& P?bV6X~qJvPlϬ[H|]me.YZ?Ri%]r~;aذaZփ׾z߿[:sMovlֲ7cG~i"q۾J!dv>&1a1JuQo|r43YǥH;,O;n/vAߥ-Ҙ4EE(RGn`T;=e ;-{ L*Ǟ>K7wjiн[J*Y!x@Z1$:-|G# -ۙZ%WVj7K7߀$g;wp|7;V(%I &9ʞkyX09PK:@KZ^C+k-/јa݂c Bs[NsZ}tUQ_~ &M8܆/4Q1Pnt}֪]2%Wkkkb\֓.z(jdZ}otE=hNMVܷtYn"̪_tfreM}׌?^zqQl_FNiƅ'oš\vФ~U?k1G[9I*[v&YBQDm?$ando,Zٕ)}7,x CUTw=:†h*7 ٹZQT SX-|ZMPd- Zhvx&idQ9> MivW[NZ-YߪHڄWϞֲ> tyh}/8?kuNWx~vTZo&+c]~N S%}*nmg~1;ٹϟ?_}W2mZo)e˦?ZSguDݏTWOXsU: WkCb\RKyT]'=풻ac&OGFWk;{„ ]?uׯ.~zv-L2T%!0wZ2-*.[G2]^KBhI)rۿpĵ& ue]mazy2?L͞5aL&)_]!Pwadh?]Z~C{wRCJZ$|>>ia!4´vZsw47wsBw LhYhP{WZؔOpՂe޺ QJjzcX(r伄 W S7=|O*PqaNѿ/7~w}W+dHFݎwM㦷0%068&dmI]%]bK6MWkɭ?Q9 Yr-L.ur |VaX&*L3fP}Tg?O)-KGV/?Ԓ> ꫏"DKm =m&jݮw;}ȼD?mSŢj@yG侅ijefq+6 l ^䖞b;awۮFgS8=w_?-*Lms=O*)(|*IpZ(;Sxw]ǽ֘ڡDv9wORzĉM]I䪅f4d.2@&-*@t_%!.,Ւe] ]r1"I ]gyFR *(R^WF4vKMiL2<~\[-4s;j /W{07!5֛m4Bt3B \kmxD d-Le(vW Ʒo߮q ʴ-05t('$d\~Kv=dzc68f+ 0A𴘵؄spmP 8hS;yڵg?ƾ;>.̴4nܸ|%9d}yرrrvBKU S͓Ý TYHU>@i3soӰd\ikѶnʻ*L˗/W*nvK3r ׮fjwBcy6=&}Re9t5I@oj>Q IOMijt~W.VzgslZ=D ˪C2 3|1Lpp:IJ9 Ȱ1wV֬Yq~ӟ0qf:2î̟a0mL9лӲ=]r۽7j.n;GДDRu1&ˤMԒ1SЧjI7;mWQl]0qe[ȤoO]r_}7qm]8$}kjU 4W5<ބ$ɦ6-cRƒQ7n%}yh[+Lڃd$Y'rl{\ Siwfԣ |gIo-]r9Ъ¤7v;f[T UW?6&34UQnÜ~6iOvG7 _t]{BI~ &N!?} J}duD{Zͭ?Ql١ɭ!dQ ^ ~зȐEQOt)R_> IV^/~~7DқZ(q}|뿴jG棶V!mEъL1TTTO/kNڢǮH*.4hcxwd!X(D-WWQcPOesVۇ0kB07|D8ޞnmIt޾$HʲSt4臘>vwb Zu;թAϧ~ҥ6ou1E]82 ' ψW}o%5~qϧx)zN+ }7 j _Cľ}~ӟ;O?_oi Z ϵ 8y"iQnT_˫! VdۀKx#QZ "aO(:q%8'O>Z~& qnLHO9A=qbDjy&s&KsX[[}Vx&wo1{墋>OSqV`_iFԛ"ڠV=fQo-ja~+vlRܺ\kLZ2Mڮ;8X!}SN`{'ϐypiŽZoi.nekG{Ì[ ҷxxtKr܃W3οM ږV&л~jn5kIt8q'RܣTۏcV96DF"ZU6+gfkwec |rAJEIP^{>믫?8 N+#MwnC'N׫Q~6ZBJRf\%X-ΖYbjTCM4h”Qپ'[" /d ?VJ6ΕhN,k5^/&`e kۙQm9ڶjaZtKo~㯹TzCĶ4YQ78+f\څwB'Sw+(·O:2Ŀ0Q  iGfP^-q^K99'^̹+; @`{}#l`?Oy4bϣϽ"U fZX*Gǝ9<9ve}GC taSEq{=U߼ET}5E[Fii7mѿyWѩ&ţQ@Ve_":VP(5tz4H_(t,/;la66\am=Ҏ mĕ-L6mR#wqGRR% S20j?Oi#$GWψ' Bx?;~>ₓoKuaSWv8C#l 6xbz?>'59!IСC_m?F^z6m 05PzV\|Yo^R0nXl믿0zp$&&>7F[[hHKL=!PzP%я~[,?Qk8|8PG/Əc]w}mb˖-Z1F S aBBBvޭk,Ck500ߛ:OR#{ojĈZ ^aaa{o/###b [Ee-q~X{KbŊ7GTT<}VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0VO &n ^(L7S0{kItfe2| `>:LEz)+omQ![~Y?-ȱ]/b{5w缝="Q$d'L#n;A$"`6̌O= ]e[oA|˜H(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&P/AaB| GPo@aB !(LAaB &ć0!~ &KP„&:!Ls13!}0!> #(L7x$L}w_]&09si60<1koqg̓GZ3>N8I͜`Ȼzn"h/";A@_nV8lj`c`^yQhmf;U.j`f󔽨97^fo+Ԥ}8h,BvVgh zsP(L,ϛG6$^*`Z8ۿ֟Yꎰ?S%˂@!2_$F</o+eg* jQ8#TAM5 'RMJhESkXtY: Ӌsԗ*N4iЂ#PǟU88=$n0(LAaB  vЗ߱>ӑ  p|FZ-C2~@ϟ [v&(z:PvD\4J9$g8,K9b]< $4&C1n\˰`& L lInӄ-L2MqkVA֢͝wrMdf"C„&ď0!(L'KSF0&]rN[0.%ZQ@_vDQ mGIS㞔[[՗NZ,Xɡ t}֎>!u:ad-pᜭ0Q3Vd]VoNx„&ď0!(L]ƕ0QS'՗sy2ƨ}L7| ]ۤظĮ,= {J)S&V,>rC:ejGԄR2Kmw@_rώ +ΟF^ /55xC{eQ ۅV~P Ԥpj _]m@* '*%U3fi3pF`_~vg'Ӵp)=[V ;J6 MGº@Cƃ„&ď0!Ca2x:94xwÂ݄#S]f)jXjx2B(/hvԸ'q.$=*ɲ}ԝXg3 Ra(9g- @f1z8ٓgFS5.5q(D[/N@_!Ѹ]y>oAaB| GPo0!]JE2-ٵF80P„&z01+ N!÷{|I@_>8tt<eCv !(LAaB \Pp/y~pn.a`Z]ܰn !(LAaB/AaB| GPo@aB !(LAaB &ć0!~ Nȁ̺{c 0>υ΍橡}یyAaB  Ibz l1,_3ﾦNY1w gֹ: t}n4a(:2f9I#y PB/f(S'm3ڷو>CaO }x&cQO`z!ڐOrؿlfpwofnYP?„x'ļXdm6d|A"egGi)~a:әg;oo!n/*gHERI"Is|}6 Pԡ߶3y"LRYC'y gJwECVN2sUiOwو`wH0!~ y}ʼ!hgwl־ُ.P "LK7zL19ѕ9B?7}}`ɷDM) y}UE yoPJ[.q軓bEeEW6\ aiN 'y9/lj,r%即~q^ GPop/Lt99B"K 0uޢ1A%cxM 1h}9j5m5ye a)c7h,5ye#mi+LPDoǝ0O#1-P.ؠ>H@_>tԇs 3٤륰 p1ZiӘ߄RCzI6̊E5ZLKV#ji|j8n˷;a M8{JpQXF-2+SS RKb$egʕrS#8TT.H/N4Wnk-5㧦:BnؠgLgjW7I~r fNS/u q"(322｡iyI1\W˟1滊0|ĝ*F@rGQ6KWja?Tzʚ ܨxd*SNq ò'7}qM27;̼82ɺ0E\㖞b'WưMo{WZIݐ 8ͬ-`&bQ8h-D3$o)P?„x0"^<Nέ$2/K]2jGYoeyje0$ɍ^'nvVvl)ZD/mY1L`㨧-+ U qt@56g=ɦ6)%SK˜rsQa^ T q\oAre= uL썘֧ Ņb%85h\[ch2 DF .c+L`* o{:0dK@`G4~,ԙ%7Ҳ. Nt=dyaU]r:_]SjsS[^YfpڢHN lL8RrE7oMP?„xK8 LEڷs yzTsKLKnz0u E  Ef,Zd3qU (…sdTLE&p]whI6)&ƓmΝym +LNήQ2.h {;kZcHe%ܶO!P9#bCv Ko۩r+7JahYQGiҳ4+c{7:H\ G_b,3y<YE0 #BD{`KޭD^:dž <*10iiz>^u+bkwX^lgphF'C:nYAaB  c['ѳ@0&esa4)+G 12J+`dPKkڢ40QRu!"l3,٦ a⃷@Ir]p:?#'f^~i.dFEᤤb2%75Iw,+Nx:z?|5rh֤4\YQiض0:@WdНhQ')Qpha[,x9C+63v´+H{aZ„„ &zvT[M\Z^'Z⤼l#  ͔[]<$qǬXDCar L&<͗6 S@_1}]irǨAԖoLLﾮ';-rw: =-]Q$h^2qdPll@aB  ΅Kkv4,2M:Ve1Z*$ja& *JdsC-Ji[/\rO/HߥX߂0!~  5u 1C1μw_۟I,^Lz:g}}q@Xz:@j(={1?u,S&9npԸ'"f ~y): ]}o?[G͜@B0 8#د?f>%-m[˭/6}nuW|e1έojVvM28oTOFӷDA~<;5~! #,mnI}vg'qݹ<8&(jyy9v_^wfӚE2-i{L_&q}짒zj/<޵m' \HyIjIؽL+Sw -(8qH(LAaB„F=. `EyӖY>bC(&o.V9ҍO [@aB  N9u91w}pҫ%f1$ r&'´3gEeM<;05&t}4ѬS\=7U&E=gN,ǖZ5eAaB  NկJYR^6ˉm*.Kq[0}m'Djޖ6KIfNʨ>KiƆE"ZP[V)K!!tTh4 }X0ݚ0!~ C'„ *(LAaB &ć0!~ &KP„&:%LpT5b CP?„xd= =mڐw3Z8jx{֨C]m@2 {!giL@_"Iv&ć0!~ O2ZdԐw~U̅mj[m'd/'x=)SdN80?dz\QMkrh?!:ojp CP?„xCDM+UVp[nPw 5 lǒx g3Ķ=߿[nk3~a|lzhz<|gt;Ԝ2pۿ7c2ӥƢ CP?„x{a& atQ˞'mHdb+%EYPYgoavgitUb/fIN7Uyf|/ !(LAaB0$d YE`?x<|f@UC9ܦbZTZD' K1٠M6 ka ͦ*Ky 鏧?'ԔQ|fԬgsZʬZ;g'0;ssI룮H=;օ\Jy7ydYf^}6i ~L5̐-0!> #(L7 ӈoC-pl6Qu3?=(&'),eٲA3nO |ĔKREdjo['Sf)td Zz˷ Qdu. OH vgOf1P*ȕ կ#JEHٙDΚ/?r"\5Re9_)q}){daŒB!/h5kןnPPs#`pK  CP?„x0QSFIe%D*YA>RWP"Ä`/^8p;VL-)9IbYfB%\]v]1?UDzcdq QƩ/y.L~rqk㲹-߂_1o-&cM\FX&"WZF 3Ƽ-c|/ !(LAaB%GϙTS%ڤ,P'5o.9|9KbJۼ^nnRĤ Rv^>sa"UiLIWK}9DQ怾0rc*LP/*&.hb4r\_gt@lnD&ć0!~ 1LP %̊E"k U00]_r$qBE&YL$^T^&U\'By{ZJf: L Xl] tԨC0KF [gdo !(LAaBQg(GO^Ff7b1яsΈɉq~vn˷ןhl-1me>d'ˤt3pFⅳbe!.|?Ne`?kntoj$S:P„&|(L+W*? yP(zf„&ď0!넉=gS\ ~L&Dku"R &ć0!~ ^'L˦6dC*/Q7ؘ(3mLXTLuSpP„&z_ǨqO:gcrN&ć0!~ Äx CP?„x %(LAaB  (L0!> #(L70!^„&ď0!ހ„x CP?„x %(LAaB  (L0!> #(L70!^„&ď0!ހ„x CP?„x %(LAaB  (L0!> #(L70!^„&ď0!ހ„x CP?„x %(LAaB  (L0!> #(L70!^„&ď0!ހ„x CP?„x %(LAaB  (L0!> #(L70!^„&ď0!ހ„x CP?„x %(LAaB  (L0!>´'%x*L~DORn#xn a>=s@_cF70ݹaޭl5#:ピBT;rLc0d\M+c=Aj3;$JS·)L9X%+I5 gGaXO^:_,gV`;جTʹ&G֋+{c>zGt Y:d!З?G6풻42kx"Lʹ/O{6 GM#BY˪GPWjF֚= SиRcH(SdŠ  3Uҙ; y9.Րxp<7y{aO SҐP{<&`돕m?QN1~[gNT>bGvPmrh`w;]Zsѐw !N?[6$I>C^V PL|1VюC''t?ϢCac8x^R8=}#6X{&Přk y/q'LG)ޘw! [~l]g'P T~dk*1;Dp;x6G$R4&Uv;9GC+ƼʁYP_3{^0Mnk6~m;z%EaC.P!0deFcw/]gσ-|m;%KmI"#f3jGO.iJsZC'S5)PM%HT*R7D/Jhqj&oMӝ#jabc^+HMlҧ:~=X*"oT_1#n`)R}vӉiZU֞osa$~L $J_1bŦVXQpU;"+ 'Ǡt 9L+٣]vYqo]i-3},(ŵV륇GƖ'@.LӋ<1e[,zN˸}Q%wGz?FD R&1J7J{UgZr=EOUDFikU3P*+" JIyE*CWZ]QҐrR{yJIZmW#`L'EYDGG[Ȓ풶(ŝcp#LgLjuuNv*E y)c[$&]d*k j9Gօ"?OZMԳ$Ee|=Y!llv'ӑ8rݙČ4fnHn{ˠVi1b:PYHJy ?fCf"&hV|qPRm ~Z0oTDmn.l̐n &R,i<=`94_hcD5q6/DP%=ToKG1VIถGr{#ȰֵkNXAne]Wٿm=ڟ )pBqoۨ:ifEYA9#:^S0"l;\H H6he;gV`{0T&FޘË=H{V#G´S  VA3UIZl +)fz8lU[PtX]fcsQۉqGƝ)84t< !P|GB„gͺ*9bRν Bؔ; eY]H˒(5iFνsd6={_q3GKhf'Vzk밵rs}VW|AhxQI~]ϖI8% a"_…ȅBF _4q_Nӷɒ|fez$Gp [ #\=JNP2la 'phx TI3s`%_YI{MJs.vtP$^iV"Ƒ9rI8)rO &bmݳ gIELPӬ-L )>:HiHWZKM8_*c iJE]"{]6EÖ1(ljX-#)=1IcO*1ӕ"2*-WW/G|c`+LԄlzycg'3M=Wp t}HHd9yB0sx6;Pjh"S/&ysb%zf(fe_y qup~!WUs%pY@(ğ%D3'.MIڊu;gW/2$A{Y\[dC??>p;z⵫2C=7=7Q2Sq=dxY& YuQώ+@,E, iGe)1p7Y =L!lM5|^m} $_#t<-F)N{}ΪZXya$vW<{0e"-Hʧ6 We?N *os:,E2b%?YG&eESU&9\k&sb9R4;0 f&7%VaP*-M+N\#- Fh^_D0gJEZA5q -(#4^[ѸC4H۾,#k1T-G5e7HEیw㈢x$LGǝj07 hym_ͅm`GkRl gEv9Vs%D2whKZezStr%Lms )RǙj-ǧ/rhWR@5g^88,&XWqA_[bpR%wm lhIXKm; Lm%)+?: " ǐ&CHcT!i ;B|9*Lw)MY)}C4X{%W,+Wo~&Ll0ՉJK>Y3\E"Xn-*{=H5Q{.SlINZkNsrD%C%e (\sY[N]KN|돔,<wa.^n!9ON'Zdiܓbr" k+;PIm8 uBt8 k߶F/[6 Sr6m(]Q@,{{:FyrS۾h5ms֩/Z)7ԗGa`9,&KEj x?AvD+9HaY~Oۼ^)׾{(M7$z޳ *  I ^:e`˯ ߶SgJަ+<|KG=>!4QMf'߆  VQclvg{Wb;%w,OikG<MN@`T'oKwE%Eg5$MbQŵ eIrqGӯ.sj{)xlvbKEÿj6Wư J:Ep n.9 ~&e(uEF`(UIךբ+x}5E\Gժ@ CTU^_ yf0\Qx'-LC=8Hm<;<6R`yaia~@:f''m@PK&M]p%L%>W_C׳j)g21K. WO%s/FMKs 6HKt):仌]QP̕}%k5@[ O•O4a*8ߏiPK8pY1|v Su2iUqUߵV|-LR}m%+ f+V _$(X+8ڔuI#[\nkl:]钳48Bϟ "&I 6Hd}зg-LHoo6^PxF9o%rPA$r&nd)\D/ gW^$E")@Z@,T@C!i3rk M0*j}Ϥqn۹E@}BnkchF =aHC MT"3b?^}s/"x0y}āO0ӈa^ҵAIYBp鞭:J>W&"Mv^ r8Wϰr0}hp8FPA K/tu*}1k N/p^k))Aя8'Kg@;}1J{\Xt~Saihi"S%0P(5iK?v6@=;D 䧅kV0]MoR>̈́l.x7 :;E [sgiLU㐒e z T v:w0wTC~$mUҶ&'tt(:thT :dwM[m.j-;StBP97}=+'nPI dʧ0lWJ9/dD,a]dZ~3AU ĐeW.%&JIp2}U)[3䞸&Gm?tɹ`7CM3UQW 騅=&114E/?}qup\ WW69g`jW ӦOW3ab}>aYnllr?560N²sajoa2bŨ>"8+Hcޖ1CH\GR&Z2q{)7]㮋1%q~W]D ^r^ZZވ1s܅0ݵ\*;LV|*>]" ^Ҋ(L_$q)LI2KQ,>KlIԗ8IVnDP6Nޕ *08K!tBv=i.l+x sQMՙԦB8z'´__'k Gƞixq0$<MymGxRNGD(iZFd~eJcfX6'yPUi:n) s2軚2trhx \%Faov稷0]0a Fz XF3.k Ys2Q~GJdԔ.LIxp7%8%/iTG-Lr} ӖەhTL\ZM ikr)\qr8i:p0dKN[gOez G&r̭51Kxez4Eد?Q_a?R WԗAY~p qn!L} MOO0jTq]oQH"Vga c ڡ'm`o40Cx (P%[mҕjPy_t+@ p8oe'C(A 5.+Pt| N*.֕.>ɍTajfӷ>єƛyJ)a:>gSutٹc׫.ù!UzJeIubhd׻*L[sgK!nB/u_"C|.+rCuw/PJA@3T_!43VjH_[ڊn83OI!p- c"kUhmk-LUaJxE{%ud'kTVU8-)&msv{А-8.ἅiXZn[WDF4 qgR%WDL)./G6q]r 4dd$5⥋|fܨߛ75Jة4,}n$& z)xT\@T ɐkBI±\{&&6Z2ˉd=xrUge9l&bx|zbi`CMvSI YKe&F1,N;ŪL.ba_]ȶtW.U (ɕ[<-L@]VxP|?+i2hU*D cymJdR GZCⳡ+D8>^ 6tT$B}]H_"vSk`a–40Ү=iC2 Bdk3%|v݅)OhR3hYdjmy _ 뀎\>7Hm 3X\Mߒuk~m"7tlmyz(#{_I‡^HԢC#bh31\U()L+r~:IQpd2>|DiY!ieOgRg_ݖMx|w43쮽ehiGN&\̭'\k0U`Zm?U^ךX?LBTbgj@>‡)Wۈn?'Jx%kra9ip:rnt돕S-4)ȃK wű~Ƶ_#E{ەѾK'3Zq+A|@&A0ҵJ!c^eݖ8x yZRcc?^~򞕏V32ȼDL{]Jo8& 6~n$_#ܸ= å+φm!;mxGm߿߻o&13 dGljL&Oi5UgQQ7ϐ!>E]z>zn8X,Kz;캀Yb@ y9\,nK(i';Șؒʶj3UÔTG|DƜVGZO1bSAHgH29֙@`Ыcm2>&Бkd&,te뇓Af?b:\eۏ`L&7",-EHsE=Bl4n{l53~y5|"Lm%ӂWdIV$I.lI4l@=%.q7uy`;U*+[w+i|0JGqW[C/0! GPo@aB !/{!P߃„x %(LE SXcA:!L['?eA,0!^„oi?O);J!ѓ!yf_nwidj"Cޑm?Uv?%·\;L/oCNf%ARv1pa ! &KP0v15j6Eo Qdwt۩8ƜFۧ͜~1I=ș:]S.*󎜚UGHRjoCOUxӨ';E(2蒮qdnR?GLa۴2 E]y,4<7OȯvIAaB !]cR :k$hͳn$2sO{ETa(JY #Gw;Ӟ?(m%-?T]I(k LUI oDQd蒮 T%?`MED_v(EYI DO0o%T~ ?PJsuBs_„x C8Ј8eLO& 辰|2vk#+OLk`Oz@֞"uS:Gǝ fЉ"w ;\VX)o@i8jJNUnȱ}[ 'm(=݀z8Ɯ֊uqu#.\ S/ȃrI˄)Io(L `ݫ_PKP2+Q㕣JE3hL>X):GeQ ?))k0ҫUxPo8m?/T*jG:P.8\T ckGrriR.GՊ\rMGk|F䝬VWr^"L{U:S-#w(mQ>%Jy>_+Ό~U ?&ٓ×=gW.O*Dj#h)}7 IfZs>z5( _ݙwu[L)E\{ο°reʷٕ u遹)kREN:>UsE^ -mҶWf  1Ԧ7'mK^Ņڴ͜M"+xV-*c}EY',Wh|+cw~}f~=V_9ZpV^K%J gݽXisՇF_HXI(=&ej+T|';k]vZ(W&(lQYR.%s\Tt&,wZ]ӭR{vPnGEs] &ćx"+<8$H'ypFN5>k!ԢqeH0op@ /%vK pb/ʲ||fM8;:y4ak3w?Jmh.MWKU6vb֞"%8>"1OPLur(PFP+f/[LίJ_Y"{_I[9 Fb+L}AB{v蒽TJQPHHYc#GxW La#HeYN@ᚕ=JK.n'de6 q˨*KwNLD"f^mQv<@Ϋ9TPf%_2 ʅd]C&/w^ &LMDv*"C 2fb wZ*Y[|mEMה#|WAaB !aJ8j%Am[ f[E6u9,,؉Jk4Z-Ta2tcvZfmTUSAm'l-#cTKP Lp^My)Wz69&`a!ZI73yG<S:/1-z)NξөtF̽(2%h)WU6\R,lee™Iǖ I+a f}G2@Գ"M<3[{ x=0Au>4)Cckb{LJcTa:_+#95I{J◐u It3'wM:C27,TJ2ZKͻd}RG\ Kd]CciiӅiV0 ?Jx$AJOӳ L$T[vE!9ט*(L0!>w%[}ŐwC;iT=SsTE7d\|q\PοUG? @n;0RϮ®93xi8r?- /Vv=.B밠n</{ZdK {%~~Zi*޲KzBWZ$XiۏImg=S7d@6XQJu=Ri+&]Z9Gvm;P# ˚0o-uĥ0YsSV,S<0]&nM\T*bɮ„x C:q\QGǝ1$PLF!OۢS`G97^%veP#;=weqLucNkMjm{ Ntpi/ D SC )aQS84"ż΅Vw2d`IwG78)lC^' $X5I%ʱNDwK.{5CZh>[;a:%IX extb{p[HlKq'Cn'BCUAER;Х 1́0\10'0ZR?UXv>jRJ&c0!^„>|7{o1|kTgD-LP`?MR>'(҄i0F> (Ioj%?i 鸅t6***Lb*WjcҌT-?4*({+OHnRpDyKns/;IV ] '-/\xY{Y˃dma0`ha:r<&k/C hw&KP=ԉ2d-?ǭ:;uvURmKJcщ놇N8SY R}!{O T8 ܶ ikk- WS8q6pxt5isbZs5͢I璿NH+^; ڤԇ<ɤ4ήR}B(T_\Vw,:b%LNuxJ|_0,6 1pq9)C%gi}+ǽ`7b 2^*^CTqIl)uZ#j7߁{ɝh`*W>&7$*/jza%lr)mv`~_xlP >D r+rI H2mަ'|QRzT沱LvXꢴ+0!^„?0% ( _3zEO-dPgs8S-݅τWS4Zn3W>R^_q"2 y |"JX1(L0!>ď-L{9l5|*z8W%^{ z(=%73+eQ>:6Ƽ֪ Ȼ^&L~syJ txCҜT_.svĜl{vy &ćw WRFd%h\M'}8CYbsqf]F1K/_kv|"o7˄)u-QgMܭ\"a[-Wx3rd~kLt5L &ćw t_ؾ:SI:Mnq:}Se^&L?'Av῝lg+{ 3Hlm @aB !maBnqp  (L0!>-Lȭ  (L0!>de&0!ހ„x C-L@aB4q8{91FF8 `l!L.mMX_Ä&<%Ĝk Ƽo 'p[51+G=g:5e75u!-0mZoӟg` pIٓٓx(Ls¨:[ȖesSy̓!tj5637ښƗHlM.=61r@5s #(L7x"LڷJj8CTsS|a>6]4pm>Šo (L7t(LkfzTCj&y1' |wp/&M3MZ ݹ]kV(@M ׮JCJ!v(L3-6}E]|a n'V4[+b؁{:g.qM|#m/u3䁿m(yo"> }#~ ļRii;zs"I))m)2zf9/={jRȁh<D+8@=;4c-4tϬL:Jy5j}~4]l& Q̋@43wf3ls \}O9ǙY T= GZOҟ$ppxj^M gw HޏcRbP&úIp>vD0!> 03ϒih-u |s}az~&,vNM&sD$\NE,M2Co,KזM- ;Ez8.6%҅zv" ɉMfR7*jX)/j}̱BLyXᏱGI%C $bjSA*-|+A8V7^<zVS"'c2I9 NVij__}mp bh+4jV:q11^aYU8^0M+.ې/7b#PjsPo8ygJRb9NTM.*2qj\& !DmeEibd׷Q=5K-d $ /52rvHPAںN&MJYAR [fFάJ[eQVtaJUEX٤Ո(6Kd&V*,Ɋ V6NN&d >5ID4I%-Vc=H$]L=o^1pSE h#%>E v! ;a:F(jIϘ!bu ΀{!t2e|i)ZQ?KC0%) C\" "Ӝd8TqҚ2q՝"fW`bZ\]5u 9d(5! 1£Ȋ}L r3/QnMz6K1O qgc-(=(LW{wV՚F"U(s&[Z N'jR U'yܓR50_]sSj޳ gF->S.pe+LNWCATY} #(}It%E;7q3%K\'AJR^7l K5\m;ɀAYlj CG?8"n KѤ-f0UqfcFh]ϛI[GrF26ERiPs)܅&۾'i'C6矄lBJ?ĸd;N=Lc-LGEzHiabD0MZ،gwQ[ޏw>tѝTJ(J%eW%߅mƑϰGK#(L78>dlk&DC^^ଅ)%ə0' !1^/D +v4g :Imarz/#ws;6kmW=r4c<ٝ>vX:0jEfIJYbr"Ya&/N #uM<o\ v! Ga͝Pkar%L瞳&KÉ&!T\۾w\))!N 'Q=;0C\Xȓr`:']r#J y K'_DjS2Ȇ-L.[zF0o.3\.ql&bvoyȢ#5dݭg |켱G\xc -LGs6Q㦅 @gE&y1%(0عS!qkSK P;͜(o'L?΀}Z SˋI o0?p? DH_mhtZg&ď0!(L]e 9c?O^KPenk{$LWid gjOQDnZ#ɍ R^6rxCqWBqTO{p!oI/^YZ"<Ϯt oznP+Kzav{$G=E)綅L0 )lkZP.b*W(L]`I4 p,Ox?[}}) I~yԃICVeFEt黋|~x2# !Ԡ=ԗ(p j&HyZ4(vNjQ:8ޭZ-/AJ[-LPg~zz[*Oϖ|@(z5ڛ|ޮL`jp05#pY7βwS1UB|b\k1Ӈt<ˊBUAYK!4 K#(L7R֬Rx8Ѱ ˂XxJZJ\_4Y 1eV~{%tpf[Č4E%@; 稧R0%arm%hP/WW K˭- 4%;Mf (-V=x:X( )zkZD%S'J%_<ȜuW_V>@*/39Qrbus|~ =(5kW3eCv0L R +aK}62Nɼ(qd;{Ϊ'y(q:-LR&~32LϚ?fK&u-SVilBf=ڼZL>9q^:tɥ\"E.K柴-6>r xf\LG2/ i1& @>^62A<2#6g2j9}-D㰧v$ǿcOw‡v>\-e}_6Il;}ޜu'vؼc6% ǃ= %oSCC-ֶmr6#T*M=5k5߶QpY *-@)=V^ l1p"EBLqXw.90!Ca!a8s h-zr{ia:W&j3-m5+*Mܫe1L;1NVDl>0,m>0!~ ^'Ly~}}'Ya\շCU-d$5cl6Taz.1sR-%T b#-Q-`eC W*TIbUX*UKYi,wm"H)kTbi^v뿗.9ď0!넉YH8IԉC pۿʰbǰo>a@/2ab?O>Kf[g +b1,Ty%V[gyN|d"NU2\n1E.9ď0!pu!7_ %&P/AaB|&C|  (L0!>[?„xC')/]D]͢0!>E   PoPI#di"q̻?ZMGf32`U׆'VG<;C$I#s1](L?„x'D/&0=L~qrmTRDO;Z{ &'-=)f=x4J/lԸ'1+vPjPzC   yMC pfao>rO&=G&ҋ`\5~!FkۼB/S& !8 #(L7&zd۾ѐw ʋ,0hG"7v500&t}#R91v71daXjBPc 4&яkh>2dE[$d k(A"a#p*C`+za pG؋}yE5 yv2ϑg8 !xGPop#LgFUUs<"ߕ$wzT8!M,Sf9Esg - H%E,m5u,{ Ex"7GrS2bim%B^fh0 Wr=̼WY{ӵy 92M)pjE`]rk RI A50!mő{%LD{w9/<[ z!+Cah>#٤lX#je @ar}-+rZDMK9VA;E̸"5ɍg0(TqvEOe,N,%o®} s21;S5<@f"j$vGq Gez)j9@, sߖΗjDuEeG|&5aZDx:۱Śq?Ojm1Nu C.9ď0!`/LOi)mm|-%n=, ({%o~ƶ`l(Lɉr[k[{7HÙۺAaYygbuз-LW6~%7aEv/ycm)3mRdhi0t0) RY ѻٽ;,Ppʲ .8T\(&]^BzF=Gn#|2;E@ r fs+$85r _Դ)`LoȻ !xGPo0tQSFszk"]rYlO=0^S./M&-Rыg;wgOZx=ӗZCnPͅڠ+)皘^{Fe!4 ׹}b$]/5S['0aR])i=NL*)ҷ ¤"\sF@_)T6|Ĉ0UUQ'Դ8-˦gz.h=7R>sj|&זn@aB|0!~ 1LJ#x<];aZ0%/m V_:d+LgHSe)jSRA [b6Tk-6! NÊRe4a&L.L0q[HL,5-c+Lw Gzܚԋh-v&[a2@ϙ$D'+˰5|żt L9PyEC (L?„x0M$]ZjPg訅Y\&%^H j/a SF`&՗Ȋenfcϓۅɾ:>J #-LD/wD}##Wц<9%[pC sq'lƹ;¬~Աz!(LYD.90!(LiC:&c09oabwo'U3 nKsɝ_& Sۋ$XzP6Sqg!-Ln@6K -LIvab%PώekSAQ)djv!_)T' -Li`}#INsga]nPw!~ 5 eo >jT8}R-u!Lfj),0o+ g}3QpZ?{B JA@* pElB %@=t$`(i̙~~Nv 3{I>?y̙3dLJ/&ԿdD/&Z\$$7S)k9A3EҢ/fwWi0a(L)cqQ7I4eOBf8knuH UVǑQl3yO.z)kSN5fF-a Ӹm-Ȗ++r[[:YZ[/iokcΒC" pIsVY.Nn7G4,awH/̇{Oߛ6!N&mvz-~Hhl5Hf5ځB/w9F5%"\"9|S_8g+k-x,Qk÷֒:e\v.%D& tk'N`7ٔ y̭dh-&>a= (Ld@Aݔf)]|m7Zɍ> ]"j Qt8-qQ%D ϔhRC AP',L3MP*Ne&c! !"e-‹ 6!'4g@w2?M<.; GEGA#>]ũcA .NM& o~%N{){ a~o= ޚeNvš%ԫl7ZiDiJJ:(M̔&dqq`dQijDS5d, vU $vK^Ǖ.|4W)cP͒{)&>#F>$NElz,V|_VaGgG9D .u&n'3HPs4lDMo7̒v­mD& va؇_wبG/z\?@(f-{G< ;hKy=jF&Y ĹҜי0"PJ_ThGZBY#(Wyc %FlØlZ u%?W4w9566@3LM$bB#SdV_//_j\99a&~oV?{(%JfĆ8qO255}bgw|?÷/vI9wtzdp=P"yJ]{c;apn_it( SnGUȄd@z -`5N$I=G3j|(4V]% )1&x(^J!!#GRB=]%)/x|ig /?W2Q|Sb#5y?ȠAqgVzA^_'/]e;į1 'ޚo': i{=ag:~Gf';j8U"b|RTU:j1RGҍ3Kum/EU@Z6Lxp>|㄃7&gq;+k=q}; d^ <5!LP ]¢3^Z+Tn6)KZxD`M!)9Py9w,!2L8Kq& ԧ}uRP*Κ$Ξ$$_ֈ&ۦԉSB3Lzy)q1RS Sx%Dž aFc 6><y |ij_i.peߏ~݃]r?<-DxQ~./RbWhm5`Qwlo[ 2 }K?K÷$9id;ԛSym5uewp3sck{i 5ܺK˪1fO6h484\ j U9Q<,;&I_qe\仄[݊ ,Տ +1LHAaB`6[ZC^R2q-n N Sc*1+X]/J=NE0&bVh;3sih.LҢ/}W| tMwHnYąKj6,za)ȓm.L XѯiDL-c?8d@U&Logps/"֞W: pa?ϋFn"r^\'5yGjŁGcOIo z5ѡagyMd.%xrIdL{1_)L}7G?XR`5#d4~em5 SSf=mgLY%j vDK (LVb!a#/])Ԡ^ Nc-4I,GFZ\QtW&0enWy[.}Y0z$Eؒ^w rՌ$LQdF@I*[)  0*wT%UoZ8y\%A㇦E `}iƨD 3 m+S0aZrLRtϿO+#o?TS&y3L0=a!~$-r}GcDrI2 zԓ!.9$0!Nh.LdxoJ0u-* S(a %w_0 tf41+_{ɂ1J9H0yF`  :FQڵfI-/ӎn zAwI1II56Aׯ!ͅ l H ߖ; bu(ˊS!ٽLʖ[fG ӥj><5Gj9wo&lVUEM͒{%YUe6xȘ*L S%nwэz}kQ۔}]rHAaB\8nIG~1|D90)tINOȒ#F>]-h!ô3.]/ 驝<caRS<滰wu~IwɽϓwM]r'SMN7Mh7oO4<.h_f`wsMN1<q0'j6RG/&ANx>T-LEvl*Dvze#VkVa1 aW0;<(fPS v!n„8!0|"{⽻xT7T/5JDMj>L,&qhpzEݼ"ab, T_gd|Ys\IÜ%'}C9Y]Abh'=?*Į0Iͯ(S6gl8oO"L$_\AA1Y, P1=÷(_[jrۊ!Eh y oYo0W 0ntO6*lyET(E2=xC7ƛ?@j%f i|I3ΟwPt3|$ 9;@TewD0ÄD& . ޛ MȊ3'Isƾwb Ne]蒌/ΘZ9H 7slef7 >/u.ZO 4;o2_OLq|ʦCrw"#"M-} _$.oǟ0-{% M?ޤ׮g_HaJ,EfL@Dvh`?fx6 F^l:J'|:(5ʓP=h9VN/P#o: p'_ Up cNRkg%T*f'~f1I}kFt] ^D"  zwϞo\h$21W=X\ 8|"N]y8j6{.Q8_Est먯 ΒC" 'Lj*55o&k}%+gohqkxd0MɒDi_]J{JP~9\^ҁUڥ*zJ5vudKrJ/7Qs5%D& N/fjiG-Ooew v+tYC<(3H[cI ( (VPFZG[#ÄD& %8-aBg! q &EBdKq& (LCPYrHAaB„8MZ>D%D& (LCGbe'5ԇc+htq坾aB" &!ӓBV_K>H!zf|"MköDeX3joG::8K (LP*L/$2mE-{H:} Us^N&5"TٌQ3 Zv\VAaB„8eaz:A8S[ ס0_f+LxpPX,}-hrc:*=W:)|X^ȁ„8 qH JZYd\ ߨJr=LLb^Z!»]&O^^~f\O oh㷋s5ZEjʰ-[sdVz?( 5B+r=`B.Uk~.thm[*cz~?| UEz벆hݱJqUxG$D 7@aB„8*L sk 'sFQu-A^k+\/2ۥkuz>Y{$EggYlJs̳76R+*)Jl>3)pI_3.kymuv~8oq.j0Gq#Ot_>+W5W]Ҿ9,gh*e}6:ATncϔ=*/< LpJ= ֠e„8 qUTNʨ k;iw2xHxppQ3"^^]r L5J,$ ftMbhߣQtkz:}8{t.A0*Kj$"1 kSR#~Ø%s#dMP@ _j%aQöp3z$ Ӌ!՞I Z2F/W1ݪWw]m%{v,Tg! q *CTmX[ iKWBj{ٵg,+E@´'wp7fis0*LNHƞKGfηӸ0y3L㐀GcvHwW,֏ài7Z9C&$0!N@aB\pz[M`dpWoZl?m20$LO'Wk03L1L6y~ E֞B *A&o W%F;oJHAaB„8$0~Ez@AJjiq-=S&ULe,.Tѿ-SW'ݓYUv+LP SyxV/P({iɡ3LR=zO[{^M9NHW*)8M>0kX4rL_SU g* g+ko&Q]$?PRYkijjL$M=j( Ȋ*T!h3 a.9 P'0!qE Àl hl]ttBdKq& (LC\& a.9 P'0!AaB\3LHAaB„8 q%D& (LCPYrHAaB„8 q%D& (LCP1LHAaB„8 q%D& (LCP a.9 P'0!AaB\g! q &EpAP'0!AaB\$d),qa?{+ a"(!=ȐdHwjXۡq0C8r5n?fX]3~j I$c;tHa*n=tHa*n=J-?(￮ L zV*s90愊W*PqXPx/5cTǩo 8)A 86#Xܿ ܁mDZ&p0Ck3`i&L~?~<WXIENDB`insight/vignettes/figure3a.png0000644000176200001440000010352413502774207016156 0ustar liggesusersPNG  IHDRYͨ sRGBgAMA a pHYs+IDATx^ Uՙ/UUTQ FШ81h0pĨ $>1iNn4>\qj1-(H4p,G0TEU}jm9k=>.s:{wku""""""""""""""^$""""""""""""""d%""""""""""""" AV"""""""""""""d%""""""""""""" AV"""""""""""""d%""""""""""""" AV"""""""""""""d%""""""""""""" AV"""""""""""""d%""""""""""""" AV"2K.U%"""""hxAD-[5k֨%""qY3fS' "c~ԨQbܸq|(lod%"*Aǂ dyʕ!""""xADdI&۷2|;w,Q>ގu2QA`6lؠ~mʔ)bɒ%jȌD!;eРA1cƈYf" nذa2*8DT9]CXz;vZ""""""} Nz 2fϞM0AXB-mҎs`"Ix|< """"" 8yÀT(8dA# rG AIDDvK; +՜5k'M𴬩'""""" pii?QvЎ3JD5 W°DDDDDDD& J3Y)s̑/7jlj(;㜓WZ% "./G?ΑDDDDDD~(5СC'+vAVN@:2C]f̘!֭[' $ZZZbF75x4F;u 1 / +ë́ Ċ+=?NvAV &N('|:mۦ ^cbO_-Ȋy1QhM4gcפIT7LLȁ0BqČ3_ld%Bj09  Ve&۳OQ][N| R-UIDa&+iT [(K19V+W7 WV8d=~$(a›4"*W^lj`\g7|_46_W5MH%f̶E%ڀ tQMi¨&LPK0ܤ;(I[V8d=~$ϴtSpBU15Q бkڅfQdk[jIeԦN#F/?K/Y`F]۪83_e1Pږ,YJz"'&xK8DdKX/^JDDwyh]rMxuMMDDyu+0=^Ɵ=2uяTxA=fRy XU,hMy$ю3J$3\<Λ7O :T>iNDWr>W=\+Dk;L0DiNCDhq|i55(f ֨v0j/LVʂ(gV%ȿ)S:? Yz|$y}nO}̙DD?Z3EOߘ9l")2Z>/}^$=N"d6tZDTL 3# hiS`zt@6Վ#5N Qy]s$"ʣW^.,_)YxLުDDE hwUUsƩva7>Dv`&k1!xQFaÆsʗMMJհ/,bJgdž.yyhW\խ/|=Ts嗜CE`ㅗ%߮S%b=p>R1YFvh#:p@1cƌl;vͲeTYՎ/\Pcdž.y}lMꦧVlhs{Ք9Y%֥W7"21lpJzÔ =ɚHEPN7N4>Jv0 IHDq WW; +=4z—4^Zbԩv 8q/UY^Xt7'V؇XG+/9Vl^yS#G/"r~}C,LVVE/h_-o"N!z2_ix_tA=1* ;cz9zU$𷸿Zc- z ׇsTdj`VZJDsbCd](o.{=Px+#( ғ}a. |7@'2'h`ہm5kM37iVa+<&9Nݘ1͛Ւ}Cy͟?_-cUbFlg/>O-%wST/P Z"WgVKzH9&v~L4JxΏ>,ZʪA@떹Z OmSK=>ZP]ۇST|^2_^uΜ9j^0 Q{>? ߿+?,Ytܣ« 6 {"ùpQFΒ=EQOqQI;m#w, :$a]` ]y׺EB=p/&L+VPKYҢJ]w| *84Fl8 x {OVؿA@Q~c˓:κE~q In1cƨ] pﰄUs[ϨRcr-۳\=wR$j:\#FP% 4H'Ag1equľ=ӧ8:ν?7mP|l7):8ǝЬms=Zi p$?|#=M;ۆB%$ı~LSrHu Yw$h WI{ 7q{A<9 Xg+|n7 D`78I$8磍Bpdgjk{AlZJ3 JDCy]jI}sb'R47g557|_-YKM9Ye p>`}n5S70.ۇDyGzQuLfܷ :~}IS3aLFҙN]Ys 1=d6Z"lӇDxZssGIzn;WE?v1BHZ++ +4vuV *M 8 *] I&R<WgxN5g`3 dIl_ZZmYv*<9NV% g{K?|+ۖ6 #sBD ,b=\z_s1+M^ 3b}Oami6;h&]!Qy(&խo*LViA =daq)n/ 18&ض>(mRvp>%ߏqiBy <S znڴINB J؍?^snf͛WuH =V\Ts9ia4x9Ay%0?(1%#Gj߻u{_uv#ZxyR8~c7Am޼O>dbRlM"ðM3TKvᜬh$y81\9탗>JŵVN}F!/|0=nܧ 7w)L'bۇs7uc 'l C_\yymUm7yp.*ོ3~WVtJ4jA#dR.G 'MJzxz閸47m;8c1JY<I)E9NV%1g.*Ma A/dW%U{;U>Lֺ YDTˎsuM&-d7&Jѱ}Ffti&m p? TGաD/oULy^I~0 5N=EO2iK%ol=FQ%ݎ[;\0ҝ〆̫b3\ܡ5? 42SoQ@ |1oG5|&mĠjZCϔUKG^.6xSk߹A)U( T˖gӱy^tc^T!^zyG+WTKݐe㸏niiQ%Z8>(Cݼ:LlWy3JQpV?C 鬙3gRtXwrԋ\yHq^\q3+|1oCdHO G1dp\0.:r*d`ߺT8 O]Lk{h1TIoϭ7 l1l\6㜬bZ|.>6Ӽۇl[Njy˭'~ ڵkUI/7ӹlV6uxJvx=X)Γ +^A[yLx} x T4:8ɓ݇YK;޴p]\e*E5S%r !/#@;`w~LzM[u :<bJږpY✬bZ|v\b Wf3Iktz=]έ'gzZܳau)H-=EOѣUZmjECtyRyX3#ʉLLðhLAM$fkqq1m]g7#&=X-U[T)L6AhvW;ZRֶ1kFљk: [㕗Կd! Sw#Hws9YL5;i0M>T C,%DIa"_k.8N:zзLԡ)s(O֫JTxeRvn ?\pL8mݺUƌJz4ʸ^7Û+prnl-͖)u뿒CFqsΠUtv_uhFjsukڅb+"g-Ye!^J]*a.¼8'f7fl-69ǰml)yl`NOu+hp٭'xf̘@GQwIC}ĈgKzS 2DP,vJ/pq<1דI.b6nܨJx I8 s9GgQ 75t.fL9 U[zU 4~bUBgzRxp]WCO=Z"dzT Nf2>MWwm9Ysڿ"pcjp{;(e;sj)wM{MÈDӒyHH>W/ 3eS sW^5*7A'j'eǏ("-+HYq> DS7{l1w\իرcՒdÆ SK=~z K':A]]*%Mt͛Ւ}Ƞ?Z@`ԫ쫤RMC5<z/I3_Qk#6|_oa?yj+:[q%jʡSƪI{t"Myd%؟v||0xd?<$PWKyi~?FȏZk!0sKK{黫v4}ȯ"_xCA 8Wsa&QI3*9fŊj)^yIľ#{y}&ny}n!چŶAIx jNV'zCx өYڮ$ɦ4)yb᧫R5P^vwX4Tq-C'W '*^$_yim]6Yc\ ASEݘ d%/J r`9*aqd2JEW ?~PzaT(dst12^vnӦM,FUX[gfar8\pyQ ?\pVs[NPWsUB)$}dgY'\֛[qb7~Jy=G^v*a^:d6ϹSj{x|[wRѶT 63aDӌ+ AV?\oJ_!sa as<,_E} >Lp, [u"0x/ST#$Bҝ/Yh͚5{߯xiĉ2u/Sd.1뼍zi5 Yɚ$.D.H3dIMltn۲`cіߨR0Z}}T V:\E֒B[tcn_9S[9d"kYEsR% ]J9YA8,ϞD) 7@Q" l3 $1TASNZ:y/ 46nQe?n]:n89bO~`$ +7Q6 ?\plB0+$*ŭ G/4tnyON:^|PύjU+/ɹXݼ{| lknVK0Z 5pއߡ/omcd%"f>@M^Ip?z3e)Tm{uZg;A%r|@ # ch߸ êo%O0k^qNV}na~p7|OJ{?弟5kؼysJp:'9]I/suD5ԤYAaڒUx}yƢ?~Z:FIz~̺R{U0"xmSR_"I?My4y1 1,j*SK=!&{U}xDay񚮾N(?JffqNd-g".0}QxEn]Ԓ2{6F-QlA$uO\g#ָEg%(C}[,8>4cՇZSժӄm(^`n ?\pV_t^ n^ "fYa1k]^C_R)Js}/N:Une-'Vr]wymS8'4s(g[}?.3_|QtΟ?_l۶M#CVt^"˕5GF)3`c0m/z$p߶)R,6ȐGd~zzjHY1_vg5'+*Iu >\ËxyfW&[S:YaG}ͮC.:G=qr8MM>`!7T%0sګsGD)rEG[j;«yx!2Ё+~FɘC3_+e#~Z xotc.@y;7nT%=S*wijXw.;1940_2(f<3eqZj/QTC#ھ9j;-%sDi*E_:;NkG8tp i?ywxϹ~yd-0Ac풟sWA1 /vg5'WEN:ȚPFImS4trlj15~ǥא+Y0Tpmj' /[x /0?{nV-UC7ߩZoQsڋA}vzL-Uc>|#;EnƱFlr0Q'<')lo/VFцԤny}q61 'vg5'לIAndfMYiS4A-T[ƯUIVRiCǫQm!3u~O7 d(v)jٻITV;!B_Rѫz|"uL(J 3 kiPqd?d m̙3Rt Eb(h ?\pVsz1 yw+dMI3f*|S}HɇJռ 6tY!` 4&UX;a9'DGQXIT/ ~IChjݪUTPaI?vTbX+^q'Lʪ<ɠ׼yTIL!Z?FQю~dEkظxIbѫ17 dT֭[U)^In.uz5p(1Z4d[vzTv ;ujZԋDQǨ.Yvv.:}8'#U,}`5ߌapDKm@+N5)B=Oa,dfcaH;;;~/C+>Fg@w6lmLW"SVIxq nVK]0Lp2+s0R AmqY2# ( gj/ɚ" dV/=bƠ]TP~;wZCv>2CC?#9v+A?17(ǓjknWpxX f5_F~-NJ`P2֭[JՊIPw*UC[5NA8:844g7OBяQi.89Y`"/7M8/klWfn朘:uja/6Wָ׹aCzjٽmFMٰDEӾyѺb ^QK䰠Yvj/ɚ _CW탟|rÉgy } IߛzЇJaگ觴(in3l XW{ ?dܺu*E'`vٸq*e֏QPi.89Y^ OExW'OV%=T਍?'t5D8"dɫ6=h hM kL9 U t3OW%kmAyu>O6g.'d((J^w_u14"Xssڡy wF ItCѫ/sQ%J흸ygI=$f;Qb2uq%Բ"c~= /Wm?榑*(jv;^Ⴓ1|㉊JeL||1̚5˸Ay/|}͹q’%KTIhذa (#S6+^36m_&!y+p*Ҁ~*jƞ[o78Ҟ͙ ~ÐڄsڋÁ";Jr ~%;qNV;([0u (A8;=qg!")^dM׾y>''Ω8ilaLa"{} u??}ϲxˢ/pYXx*!&x dhƕ~"rӃ}\e'Wma>q+qrWk4AoѨo?. ٲ9LP,X"AF) Z \`ҎW^RK㜬j=|O/z7E(>Eidoߞ)/ZP8ùy s-/V%iӦR-GǽlC1A>JlDoܹA[ cWx]g*xuV^-Ǝ̜Ւ7[#dtp"Cи]c{1ONn`ƉAB\Dy\tEO\`oq&*\/=};֮]+Ԡxxy= WРcH ԩVO:.h LERCROV?3sQ᡽i>x,r.,3>1 ӇE?SK4m1't|c~I4 !`\߸' CW.sڇA]0kC= (j6"[y[vqc9=+;QvJ¹_{i&ٯOWuuu0:%o^\p! @ nl~l}ԭ(E kN>=0}gQGnq(_Gl}ǵ2v}b Lq4QY݂A+o\_7~Or8)\$Yٱ߃s c48^ۄk./!;@qLYq Չ!FglS䯲rs2?>`cSFn2xt$N55 (E}͛7K[5Z_/8/_0Dֻ io6^QnئŧH㦸H%lѣ1~}E-cq^ud`xqp^#d;^QylĊT07IA$x '69'sKiC`hݞIT$]'dqjɟ&Qq!`<4 `XQlNE7>³mHȺ;`\!i ~DTLyeڤ>?1x=`з}2y˪?V^~-MNPʦ S`F8AV|p ?[d(dygsKKqcԤIT)Z?F&YY`K2x '>N d|N%V7x,fD81dLlvΠUɟLg|`~C iT)>M3g Q=^KSRҁES{G#L￿*%'E&! M> ~0zr#,/?ӹq guk$ŸQU/o9}\x/Vt~ab y|}Jv跎 `Vstۖws,ouۆ6!M#+}E9$܄ृ¹=r"ĹNAR yڵ2낧Wm?^l_mgLt\8Xׅ :fS( ۈ!׭[g<.Kl/斵mĉ -˓-;_zSl:c1V{?d&+70^s+/:F-E-e!JZ(.^9R4NjI/h]iK%I/g|g;娒 ۊcN?_q>bU3VWWJ=~zBW^9$i7">)ˑm*3~p[ȘE|c6-… 1EZ`/҈14J8diIAG/'p^y;c K'\MRO#&֏]-]YiNQ(eZV"| ߖZ-ȊNʡ )?ClZ0,n={;wZrl5EE/Oo߶g*1g }OMF5i2UgɉW)(.E 3YkðaÌfZ]^Idb<emxsOaDx)g|gkt*Qp_"_4Pq4c\:摉+xXa̙DD_6 QM^!4̀M*U⨳hjRKDDDDD7?<_t~Q`?M6R2:~1e;tдDD`k; + 4˗/WKzxYzgĚ^PKվwyDDDDDDI{Vp0$봠4Ix5 ~;T(lnd% 1t X`Zϕ/ܫJՐʧ}6_ي0G?Yq >\5c c<S6[v*a]EDW Qťד-hmƹXJDDDD<_ٌ0u:'=Doe˖WkMb͛7'imΜ9DD?yhd%FGMC{~_jGL퓗DDDDDy "6>nrÆ Mb G֓3'L V<}tU""ʗ Q<8wʔ)V d}!jc?y>tZ"""""6 սfΜBG4eŴL`YfnX"|X*/x]g*, =P~qzɒ%j);+Y/fl\`"Y""""j#KnБİz iPFlgQ5>2ގ3JD8$ O< ܄,ÞUX?v1rajl`a<:.\k.jdΟ?_->.ql-pL]:!g nbÇŲ7AUӼxrjlQ%Gx 2.#F woT[ZZƍeG8Vf=iX/pym6{ !ꉨ(lnd%"[ Xu0JDDDDDDD~!(j@N})hV𚈈W?(##>l~ĊSg|C͆9:k4k׮UjӦMS%""J3Y2b7%Vmۦ(i eE.SKzC,~CDDDDDDDҥKٳS ":sLQMDD +>~޶C-uA`u!Nj'Fs>{*u2'\-V=~YWKi5U= Sn!Kh^鵽m켞yyb_҇+V j(>cJ†7 JGLbte%Bchq "so|N-uAϽ Ԥ~{nV-u}͢׸/%""""[׺YWu׻bw{8}sn&  q{ŝT-uc?p±sO+eAiP?i^߃ּ|F?؏WgVKݚo Ǩ#(/Ҫlc⃇r]uuPQbU=ޤ|&"""JZy&\'r|iQ |h'Z"7xBSC1jbK=J:ҦߙUߏO%=DA*SY`;cСCoAPL78A4vZ"7;9-&Qws6W;DpnsDDDD  |s~:u9~ק!])j UXξxX s2\~"WZ*v^p+h[tk"dͺ*6(>nֺf\V9G+R(^ ow㞺Nظ t0YQ3YM邇TMw-_ˇ*!ؙ:%ίJr\5\gkm0RWjuJDDᰍ!ʪ aT_g!2""""ۤ 9t8Ĝ^(fs/ʀ̣Sh9:eLV"09Kg7O#~[G_3AO-/' Ζ-[x\-՗AÈRONG~oXLRkpN:U4|\5Y]a{_y)Z%~!WxȺ_kO쏆Ɣ+9 zϖJLZtKŽ3ϐsU:Q1J^tAV ;xԷR2>~A,#1 ݈a!s~ۙٯ. [y3,\ɫT1C `IѾK  ^%aؓR{azVy܃9pq~/~aqSg#^hc&s>{aD@{%@e{Uq4qMbϫ.KN*0w Ҭcs@-ў[N:Kb״ R0}xD :T-ESCFzr ycE 4MH4^x*(AV:F=Xy׉^RK jIAI-E=/./ؾ`jv}Ψl1&m--ՋUN/dw~̪`{,JǬ_2:Psp\u]kyzeaza ԕաw,ֶ#IM}"""" 'tW  JiCVYFݰfD(>, n"C6}*uʽ5aDx#1P_@P;>5MJݧVnQQ-p$!TGk9U)tic˺wN +;߫,МdqNO2 f=Bf[G̣'r`{mgP1sºm/}k{M9-0'Hܓb6BaK1w&> ̢sbWe=vG'JV \{V]'@-thiyd+10( rVGZ݂?XS#hӦMb~YfU[Ös t sЮ>-,$JyhkZr`Xe( ͭ 2cm ˪3 of=MCCCVmuRɪ;FJ׀Mhy? 9sn&1B]xmZꂹ#˃;/C^!P ; c:Ւ7Ygub? e[-CVwmhc*3O.m~KDSk{Sto&t !硫:Iw ?:6= 𯶝xoOgAv^n2nKr NJui:CY@ߪ>?DDDD $!3CBKrNJ_~,c[ Ln>=uR8κ-uNVl_l`r8v8^y>-xU7QWa #OgXpγχZzٯ<(E5lwkw$X+?nHzXQgr.Xq>SCU+N>yT Op~wuCph my]~aWP&L[{Ɏy|y7new9T󨛳D cW{ago9w_ j49fkͺ)rxJO7zOmx{ p~7|ՕmEe?BSo]yuž볠m|{gt{uQIDDDD6p$kW TW$MAϤTΗXOg=n2dT ]\2qC2'q b~; ,9;2ۮR9%deq%r.a 8XQ/OG뀺^ 5p.z %O]A08kb˹p{@%otYeiҵYmo3Lg,/e N:Uvj{me/tT ֢ObuQj~ȶF} pge=wwSK]@@>C=V+!H "HF (K* [ޞVJJ`Ehqg~ #p ܶ]t9o _k>^z7CR

7Q}=wN:7|_#QйcUi9C}71J:ё `^O1w߲ yI*!;] ~ MWݙ^#/"cI'Jmt7⍞KMM(y&CCuu"""" +uPvj3Yj2Q+. M@pS, ѯ.øHaȰs lSȨ '7+a֨7BԙSy\yLDJ'MuWs];?>]tHd""""`/UjݱYV#C 2oPRbJ.3mPFR7nYiCvT Ɩ63%6K]&Ř5jqe]4^x*U1e:k*0U3.` ^U2kJݚ>VMK`h[] a{&AL0u / }M3y]?LV"""Pd%M5lшeFM8X;$<Ȃ.Sˁ!^7y|qFve{{nV8 3[3PIODDDTkd%3S'72Y] ~QIAy7HRuzWAV}Ȓq ![q<+!l(W]VnCӐ>R8sTʺz.isN_, g!Xcxp˒ #l[ aGRrNVB{hlt*%WU[É#n 1[ԭS4me}}?uNdv^+ؖ9w%=X.˩o'O$"""U KͺCn!c[o~rca䮥Wu8d- .eQR].+Qpe +*lkSg}$ÞG;8I:Gt퐯i\((=M1Ηhs9@Oi͍pfY8T%}:Ŏ?%ԫu}ꝺ!0v&X OIIS:o/'p3W$᪻&nWss;JDDDT$ Y&MlN]i\=CuxÔ`MsC11- .wPR]  ,/?y 4#xd+"S1nQ#]o;uŒ6F':cTU)?ta> W@-À1Η`N!,!- tgL;oncTwaM7_@CǮ:;2 ^Q`PD-佐$(A,Jw gp=]֘hlpnj, +3Ym K X=hoJ5 a>%/#C,ClۘrM3⑷Q t䢜Gұ{}lic :cej梍',3\<g$uqN {As 1wROs"9qptl/MS/|_[Fu%Ŗ-!_XrD&x +53Yo&J[7Yr4'""" AV Ev ĦBlVs:u ;5tHQdy7}drVvS)ya x6}xbubũ׋)Gڸ 6Ti]V L]Czh6&Dn5｠JaԓP;6Kdxio[ &̳gC\{-wbv.mn[uƐ.x\%BYf|aΏ3.k[ {ᇋt &Uܮ]N,(e? Qwnc4(д>D5WwO?>5K[_|A]Z NޑqPmdDDDDd֪ uKzNV] %ֱ 7qI =*9 Cа`aY+D9t s*Ռӭg\J61qXy. Hq>e;U[CIf]`ѐORO6 )#0Pm.ٷ_*]VY< QwlciQpJ.I=N}v^{wmyg@&ڵyU͕JDDDDdf$:xTZ7]& Ʊne eF9*:}A59b-JuTlݹtngUl';Yљ[ oY)j\$dJWu/,o=GּsɊa0/nianHp z SZ3هܴYenI&@nWK&kRP={/ԓpn:JDCU]s栍1DDDDDA1JfNzٙoA.5uy\̰WzqMެS UX!RKu4yGcR%3]$ð֥Y2ݫ S:c$qL@gt|N{Ŗmo8߻|i#ys;6i.` ۼI^c{UJOnm'h#-}?]ZaCT[=۟*uK:h|u@r'rq7Q} Q-aJۺN,n]-c,K؇GtPrCa.]߼?c0H3-ǴԆ5ÞG*uC@oEP²7R`t3}U 'osV\gJl=PwtAR,U:yZvQgSB-|a5 ̭8:KۮbD]TɿPaчTY'3^W-+kh]Q} |SgR0n3mNjuĶsܜ^JnYJ*յJ-tӝ dsϰs[ga+;rLU?Z}j Tj?R8Y=8k jm-UK}MqToi+Yq\?H> 㫿H>}_B"0ئKY-7Uި-}_7}Z """0d%Ekp*`@" 9YcSvCln?COQnȬT3O^g\izX`7n`HѠбp+? B}F1jwB0L]:ڱN36-VK޶)&>}Zi&Jݰjn}6\nkb˹CL8xTU{axm|r&r6j&5@m;'+3Ѕ~p=n!!mc &]g/tǧo~ҩj[ja g i zc@+sۢ{Rt!yy<{zj[k5RCgv=JǯRQӇ%Y+ך :tqxeDDDDDa1J|IjZ[sAbuA q%Ӹ[z̕e_Z7iJ+3AI+N6{jq ޛ2Pfݤ nYU{lM@(Wgm]tY^?bZ`=F=;S>OJ>XXSg[Υqջ]P1r;*QZd8mIӷ5Y|6'u¿SٚEJ7WJ:^yIt}4JU Gfju;w _﫯ho}_Z'v^pܧAw)dBT -ܧ]6Y3]1!T<}ݱ^AlY]UK0D-Ce"uR:o+b> bT.humΉ?KTH_?{j>ͬ nNE-[/zٮ4CAUjhxw￨~9QQ߃UzcK (z[@{O;jlY%M=W_>}NɰtuNEly=~am~\-u?j{XV~.[7qoo{w߿W'\`y[rx[?ۿWxcܫpg/ZTw 3X?{繪ȁsb?u[ݻw{_oq\J8ywR0ؗjݧ}<Գm^!i}!(;s1Vՙ2YKn޵uEva[hp_5O-QK]z?K+ A?η2Kasa jy@x) [:dU=j-Į]jK׾Jf,sdzD{=4,JQɃ :>o~[#Bb]tGR}SGf{uO+s:F7k8?C_C.}2糝:V*h+/=~u߬{yuJ6fyn;r^CBe 1Vՙ YK&nSG;%u6fq/*dʴ922h 45~J-Șkw]pn՜~lovMg]JmkPC>"ۮ57OLX.EVڏmmCX C"#2.4߽H-@Uo~][' m"̱r[{Xͷ<6E9MpJضۖY foJ{CV:5"mpֱ%""""YFĵc0J۞|wryk` 4}1kY3`jCVv DuQgP 7/J" HV('WGX 1Vՙ YK&X/]xݪ-t0^rU X='ku5@eNV>=vAt덗^.̫ž|Exy204/D䯪jMݵ͕A*5bp^>=4^xZ Ʃ7a>AD&{}Q:qlman=ܻW6ܤJݐr m?QV8\0yA;u:' \b7ֶstOdsYwtzwCSbȑ/<(J,XYlxG' 8G/Z,_}! ֚VPcǼ}[y@+t- G~* ɋѬ3~P,ؼR-uA}kbZyY- ٷx1gsZـD}m7xfmЄn7/Fa,>ZC*l4|dnF]x g~{X>*]6OA2Q 밧׊'nQ`]ÉŎ/N;#kKYO'cUýN#'Ij?#!q |/ Ҵ?Pwc87O>S:S 亁'^&RGmXn4vhZ@qx%x`|gVWKDDDTd QrHVdVq[ƯU z 3YC7MH-uAV潝b'R<ǙJDDDU&"ru+?WpZJϋ_pD*n}L]fssjTurb ߑ9Y>wfEZϨޞ[{W?`X>qImqh<, b8bd:Ty/DDDD4f/ H8'+0̇E0|pRVX=z1}|((4`GLVGDDAP25+ 0@4`V"""t1JDZ[eQ`jIB&Q4Y,UmNV#"a^K/WKɨt +ykjvLTfR-Dbk9Y9YYerXW1ͺT|A<㜬DD3---⠷TKA d%"""""" DD/> rzefpMlzMmc᳆~ebС/(M Q0,0DDD`,AV"""""""""""""O""""""""""""""AV"""""""""""""d%""""""""""""" AV"""""""""""""d%""""""""""""" AV""""""""""""""߄E6^T,JIENDB`insight/R/0000755000176200001440000000000013615055655012133 5ustar liggesusersinsight/R/find_formula.R0000644000176200001440000006233613613250065014723 0ustar liggesusers#' @title Find model formula #' @name find_formula #' #' @description Returns the formula(s) for the different parts of a model #' (like fixed or random effects, zero-inflated component, ...). #' #' @param ... Currently not used. #' @inheritParams find_predictors #' #' @return A list of formulas that describe the model. For simple models, #' only one list-element, \code{conditional}, is returned. For more complex #' models, the returned list may have following elements: #' \itemize{ #' \item \code{conditional}, the "fixed effects" part from the model. One exception are \code{DirichletRegModel} models from \pkg{DirichletReg}, which has two or three components, depending on \code{model}. #' \item \code{random}, the "random effects" part from the model (or the \code{id} for gee-models and similar) #' \item \code{zero_inflated}, the "fixed effects" part from the zero-inflation component of the model #' \item \code{zero_inflated_random}, the "random effects" part from the zero-inflation component of the model #' \item \code{dispersion}, the dispersion formula #' \item \code{instruments}, for fixed-effects regressions like \code{ivreg}, \code{felm} or \code{plm}, the instrumental variables #' \item \code{cluster}, for fixed-effects regressions like \code{felm}, the cluster specification #' \item \code{correlation}, for models with correlation-component like \code{gls}, the formula that describes the correlation structure #' \item \code{slopes}, for fixed-effects individual-slope models like \code{feis}, the formula for the slope parameters #' \item \code{precision}, for \code{DirichletRegModel} models from \pkg{DirichletReg}, when parametrization (i.e. \code{model}) is \code{"alternative"}. #' } #' #' @note For models of class \code{lme} or \code{gls} the correlation-component #' is only returned, when it is explicitly defined as named argument #' (\code{form}), e.g. \code{corAR1(form = ~1 | Mare)} #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' find_formula(m) #' @importFrom stats formula terms as.formula #' @export find_formula <- function(x, ...) { UseMethod("find_formula") } # Default method ----------------------------------- #' @export find_formula.default <- function(x, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) } tryCatch( { list(conditional = stats::formula(x)) }, error = function(x) { NULL } ) } #' @export find_formula.data.frame <- function(x, ...) { stop("A data frame is no valid object for this function") } #' @export find_formula.aovlist <- function(x, ...) { f <- attr(x, "terms", exact = TRUE) attributes(f) <- NULL list(conditional = f) } # GAM ----------------------------------------------------------- #' @export find_formula.gam <- function(x, ...) { f <- tryCatch( { stats::formula(x) }, error = function(x) { NULL } ) if (!is.null(f)) { if (is.list(f)) { mi <- .gam_family(x) if (!is.null(mi) && mi$family == "ziplss") { # handle formula for zero-inflated models f <- list(conditional = f[[1]], zero_inflated = f[[2]]) } else if (mi$family == "Multivariate normal") { # handle formula for multivariate models r <- lapply(f, function(.i) deparse(.i[[2]])) f <- lapply(f, function(.i) list(conditional = .i)) names(f) <- r attr(f, "is_mv") <- "1" } } else { f <- list(conditional = f) } } f } #' @export find_formula.gamlss <- function(x, ...) { tryCatch( { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.random <- lapply(lme4::findbars(x$mu.formula), function(.x) { f <- .safe_deparse(.x) stats::as.formula(paste0("~", f)) }) if (length(f.random) == 1) { f.random <- f.random[[1]] } .compact_list(list( conditional = stats::as.formula(.get_fixed_effects(x$mu.formula)), random = f.random, sigma = x$sigma.formula, nu = x$nu.formula, tau = x$tau.formula )) }, error = function(x) { NULL } ) } #' @importFrom stats as.formula #' @export find_formula.bamlss <- function(x, ...) { f <- stats::formula(x) .compact_list(list( conditional = stats::as.formula(.safe_deparse(f$mu$formula)), sigma = stats::as.formula(paste0("~", as.character(f$sigma$formula)[3])) )) } #' @export find_formula.gamm <- function(x, ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) NextMethod() } # Other models ---------------------------------------------- #' @export find_formula.gee <- function(x, ...) { tryCatch( { id <- parse(text = .safe_deparse(x$call))[[1]]$id # alternative regex-patterns that also work: # sub(".*id ?= ?(.*?),.*", "\\1", .safe_deparse(x$call), perl = TRUE) # sub(".*\\bid\\s*=\\s*([^,]+).*", "\\1", .safe_deparse(x$call), perl = TRUE) list( conditional = stats::formula(x), random = stats::as.formula(paste0("~", id)) ) }, error = function(x) { NULL } ) } #' @export find_formula.MANOVA <- function(x, ...) { .compact_list(list( conditional = x$input$formula, random = stats::as.formula(paste0("~", x$input$subject)) )) } #' @export find_formula.RM <- find_formula.MANOVA #' @export find_formula.gls <- function(x, ...) { ## TODO this is an intermediate fix to return the correlation variables from gls-objects f_corr <- parse(text = .safe_deparse(x$call$correlation))[[1]]$form l <- tryCatch( { list( conditional = stats::formula(x), correlation = stats::as.formula(f_corr) ) }, error = function(x) { NULL } ) .compact_list(l) } #' @export find_formula.LORgee <- function(x, ...) { tryCatch( { id <- parse(text = .safe_deparse(x$call))[[1]]$id # alternative regex-patterns that also work: # sub(".*id ?= ?(.*?),.*", "\\1", .safe_deparse(x$call), perl = TRUE) # sub(".*\\bid\\s*=\\s*([^,]+).*", "\\1", .safe_deparse(x$call), perl = TRUE) list( conditional = stats::formula(x), random = stats::as.formula(paste0("~", id)) ) }, error = function(x) { NULL } ) } #' @export find_formula.cglm <- function(x, ...) { tryCatch( { id <- parse(text = .safe_deparse(x$call))[[1]]$id # alternative regex-patterns that also work: # sub(".*id ?= ?(.*?),.*", "\\1", .safe_deparse(x$call), perl = TRUE) # sub(".*\\bid\\s*=\\s*([^,]+).*", "\\1", .safe_deparse(x$call), perl = TRUE) list( conditional = stats::formula(x), random = stats::as.formula(paste0("~", id)) ) }, error = function(x) { NULL } ) } # Panel data models --------------------------------------- #' @export find_formula.ivreg <- function(x, ...) { tryCatch( { f <- .safe_deparse(stats::formula(x)) cond <- .trim(substr(f, start = 0, stop = regexpr(pattern = "\\|", f) - 1)) instr <- .trim(substr(f, regexpr(pattern = "\\|", f) + 1, stop = 10000L)) list( conditional = stats::as.formula(cond), instruments = stats::as.formula(paste0("~", instr)) ) }, error = function(x) { NULL } ) } #' @export find_formula.iv_robust <- function(x, ...) { tryCatch( { f <- .safe_deparse(stats::formula(x)) cond <- .trim(gsub("(.*)\\+(\\s)*\\((.*)\\)", "\\1", f)) instr <- .trim(gsub("(.*)\\((.*)\\)", "\\2", f)) list( conditional = stats::as.formula(cond), instruments = stats::as.formula(paste0("~", instr)) ) }, error = function(x) { NULL } ) } #' @export find_formula.plm <- function(x, ...) { tryCatch( { f <- .safe_deparse(stats::formula(x)) bar_pos <- regexpr(pattern = "\\|", f) if (bar_pos == -1) { stop_pos <- nchar(f) + 1 } else { stop_pos <- bar_pos } cond <- .trim(substr(f, start = 0, stop = stop_pos - 1)) instr <- .trim(substr(f, stop_pos + 1, stop = 10000L)) if (.is_empty_string(instr)) { list(conditional = stats::as.formula(cond)) } else { # check if formula starts with dot, and remove it instr <- gsub("(^\\.\\s*)(.*)", "\\2", instr) list( conditional = stats::as.formula(cond), instruments = stats::as.formula(paste0("~", instr)) ) } }, error = function(x) { NULL } ) } #' @export find_formula.felm <- function(x, ...) { f <- .safe_deparse(stats::formula(x)) f_parts <- unlist(strsplit(f, "(? 1) { f.rand <- paste0("~", .trim(f_parts[2])) } else { f.rand <- NULL } if (length(f_parts) > 2) { f.instr <- paste0("~", .trim(f_parts[3])) } else { f.instr <- NULL } if (length(f_parts) > 3) { f.clus <- paste0("~", .trim(f_parts[4])) } else { f.clus <- NULL } .compact_list(list( conditional = stats::as.formula(f.cond), random = stats::as.formula(f.rand), instruments = stats::as.formula(f.instr), cluster = stats::as.formula(f.clus) )) } #' @export find_formula.feglm <- function(x, ...) { f <- .safe_deparse(stats::formula(x)) f_parts <- unlist(strsplit(f, "(? 1) { f.instr <- paste0("~", .trim(f_parts[2])) } else { f.instr <- NULL } if (length(f_parts) > 2) { f.clus <- paste0("~", .trim(f_parts[3])) } else { f.clus <- NULL } .compact_list(list( conditional = stats::as.formula(f.cond), instruments = stats::as.formula(f.instr), cluster = stats::as.formula(f.clus) )) } #' @export find_formula.fixest <- function(x, ...) { f <- .safe_deparse(stats::formula(x)) f_parts <- unlist(strsplit(f, "(? 1) { f.clus <- paste0("~", .trim(f_parts[2])) } else { f.clus <- parse(text = deparse(x$call))[[1]]$fixef if (!is.null(f.clus)) { f.clus <- paste("~", paste(eval(f.clus), collapse = " + ")) } } .compact_list(list( conditional = stats::as.formula(f.cond), cluster = stats::as.formula(f.clus) )) } #' @export find_formula.feis <- function(x, ...) { f <- .safe_deparse(stats::formula(x)) f_parts <- unlist(strsplit(f, "(? 1) { f.slopes <- paste0("~", .trim(f_parts[2])) } else { f.slopes <- NULL } .compact_list(list( conditional = stats::as.formula(f.cond), slopes = stats::as.formula(f.slopes), random = stats::as.formula(paste0("~", id)) )) } #' @export find_formula.wbm <- function(x, ...) { f <- .safe_deparse(stats::formula(x)) f_parts <- unlist(strsplit(f, "(? 1) { f.instr <- paste0("~", .trim(f_parts[2])) } else { f.instr <- NULL } if (length(f_parts) > 2) { f_parts[3] <- .trim(f_parts[3]) if (grepl("\\((.+)\\|(.+)\\)", f_parts[3])) { # we have multiple random effects, which we can better extract # via "lme4::findbars()" if (length(gregexpr("\\|", f_parts[3])[[1]]) > 1) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.rand <- lme4::findbars(stats::as.formula(paste("~", f_parts[3]))) } else { f.rand <- gsub("(\\(|\\))", "", f_parts[3]) f.rand <- stats::as.formula(paste0("~", .trim(f.rand))) } f.clint <- NULL } else { ## TODO dangerous fix to convert cross-level interactions # into random effects... f.clint <- f_parts[3] f.clint <- paste0("~", .trim(f.clint)) f.rand <- NULL } } else { f.rand <- NULL f.clint <- NULL } .compact_list(list( conditional = stats::as.formula(f.cond), instruments = stats::as.formula(f.instr), interactions = stats::as.formula(f.clint), random = f.rand )) } #' @export find_formula.wbgee <- find_formula.wbm #' @export find_formula.glimML <- function(x, ...) { .compact_list(list( conditional = x@formula, random = x@random )) } #' @export find_formula.tobit <- function(x, ...) { tryCatch( { list(conditional = parse(text = .safe_deparse(x$call))[[1]]$formula) }, error = function(x) { NULL } ) } # Zero inflated models -------------------------------------- #' @export find_formula.hurdle <- function(x, ...) { .zeroinf_formula(x) } #' @export find_formula.zeroinfl <- find_formula.hurdle #' @export find_formula.zerotrunc <- find_formula.hurdle # Ordinal models -------------------------------------- #' @importFrom stats as.formula #' @export find_formula.clmm2 <- function(x, ...) { .compact_list(list( conditional = stats::as.formula(.safe_deparse(attr(x$location, "terms", exact = TRUE))), scale = stats::as.formula(.safe_deparse(attr(x$scale, "terms", exact = TRUE))), random = stats::as.formula(paste0("~", parse(text = .safe_deparse(x$call))[[1]]$random)) )) } #' @importFrom stats formula #' @export find_formula.clm2 <- function(x, ...) { .compact_list(list( conditional = stats::formula(attr(x$location, "terms", exact = TRUE)), scale = stats::formula(attr(x$scale, "terms", exact = TRUE)) )) } #' @export find_formula.DirichletRegModel <- function(x, ...) { f <- .safe_deparse(stats::formula(x)) f_parts <- unlist(strsplit(f, "(? 1) { f.cond2 <- paste0("~", .trim(f_parts[2])) } else { f.cond2 <- NULL } if (length(f_parts) > 2) { f.cond3 <- paste0("~", .trim(f_parts[3])) } else { f.cond3 <- NULL } out <- .compact_list(list( conditional = stats::as.formula(f.cond), conditional2 = stats::as.formula(f.cond2), conditional3 = stats::as.formula(f.cond3) )) if (x$parametrization == "alternative") { if (length(out) == 2) names(out)[2] <- "precision" } out } # Mixed models ----------------------- #' @export find_formula.glmmTMB <- function(x, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.cond <- stats::formula(x) f.zi <- stats::formula(x, component = "zi") f.disp <- stats::formula(x, component = "disp") if (identical(.safe_deparse(f.zi), "~0") || identical(.safe_deparse(f.zi), "~1")) { f.zi <- NULL } if (identical(.safe_deparse(f.disp), "~0") || identical(.safe_deparse(f.disp), "~1")) { f.disp <- NULL } f.random <- lapply(lme4::findbars(f.cond), function(.x) { f <- .safe_deparse(.x) stats::as.formula(paste0("~", f)) }) if (length(f.random) == 1) { f.random <- f.random[[1]] } f.zirandom <- lapply(lme4::findbars(f.zi), function(.x) { f <- .safe_deparse(.x) if (f == "NULL") { return(NULL) } stats::as.formula(paste0("~", f)) }) if (length(f.zirandom) == 1) { f.zirandom <- f.zirandom[[1]] } f.cond <- stats::as.formula(.get_fixed_effects(f.cond)) if (!is.null(f.zi)) f.zi <- stats::as.formula(.get_fixed_effects(f.zi)) .compact_list(list( conditional = f.cond, random = f.random, zero_inflated = f.zi, zero_inflated_random = f.zirandom, dispersion = f.disp )) } #' @export find_formula.nlmerMod <- function(x, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.random <- lapply(lme4::findbars(stats::formula(x)), function(.x) { f <- .safe_deparse(.x) stats::as.formula(paste0("~", f)) }) if (length(f.random) == 1) { f.random <- f.random[[1]] } f.cond <- lme4::nobars(stats::as.formula(gsub("(.*)(~)(.*)~(.*)", "\\1\\2\\4", .safe_deparse(stats::formula(x))))) f.nonlin <- stats::as.formula(paste0("~", .trim(gsub("(.*)~(.*)~(.*)", "\\2", .safe_deparse(stats::formula(x)))))) .compact_list(list( conditional = f.cond, nonlinear = f.nonlin, random = f.random )) } #' @export find_formula.merMod <- function(x, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.cond <- stats::formula(x) f.random <- lapply(lme4::findbars(f.cond), function(.x) { f <- .safe_deparse(.x) stats::as.formula(paste0("~", f)) }) if (length(f.random) == 1) { f.random <- f.random[[1]] } f.cond <- stats::as.formula(.get_fixed_effects(f.cond)) .compact_list(list(conditional = f.cond, random = f.random)) } #' @export find_formula.rlmerMod <- find_formula.merMod #' @export find_formula.cpglmm <- find_formula.merMod #' @export find_formula.glmmadmb <- find_formula.merMod #' @export find_formula.mixed <- find_formula.merMod #' @export find_formula.clmm <- find_formula.merMod #' @export find_formula.cgamm <- find_formula.merMod #' @export find_formula.coxme <- find_formula.merMod #' @export find_formula.lme <- function(x, ...) { fm <- eval(x$call$fixed) fmr <- eval(x$call$random) ## TODO this is an intermediate fix to return the correlation variables from lme-objects fc <- parse(text = .safe_deparse(x$call$correlation))[[1]]$form .compact_list(list( conditional = fm, random = fmr, correlation = stats::as.formula(fc) )) } #' @export find_formula.mixor <- function(x, ...) { fm <- x$call$formula f_id <- deparse(x$call$id) f_rs <- x$call$which.random.slope if (!is.null(f_rs)) { f_rs <- trimws(unlist(strsplit(.safe_deparse(x$call$formula[[3]]), "\\+")))[f_rs] fmr <- paste(f_rs, "|", f_id) } else { fmr <- f_id } fmr <- stats::as.formula(paste("~", fmr)) .compact_list(list( conditional = fm, random = fmr )) } #' @export find_formula.MixMod <- function(x, ...) { f.cond <- stats::formula(x) f.zi <- stats::formula(x, type = "zi_fixed") f.random <- stats::formula(x, type = "random") f.zirandom <- stats::formula(x, type = "zi_random") .compact_list(list( conditional = f.cond, random = f.random, zero_inflated = f.zi, zero_inflated_random = f.zirandom )) } #' @export find_formula.BBmm <- function(x, ...) { f.cond <- parse(text = .safe_deparse(x$call))[[1]]$fixed.formula f.rand <- parse(text = .safe_deparse(x$call))[[1]]$random.formula .compact_list(list( conditional = stats::as.formula(f.cond), random = stats::as.formula(f.rand) )) } #' @export find_formula.mmclogit <- function(x, ...) { tryCatch( { list( conditional = stats::formula(x), random = as.formula(parse(text = .safe_deparse(x$call))[[1]]$random) ) }, error = function(x) { NULL } ) } # Bayesian models -------------------------------- #' @export find_formula.stanreg <- function(x, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.cond <- stats::formula(x) f.random <- lapply(lme4::findbars(f.cond), function(.x) { f <- .safe_deparse(.x) stats::as.formula(paste0("~", f)) }) if (length(f.random) == 1) { f.random <- f.random[[1]] } f.cond <- stats::as.formula(.get_fixed_effects(f.cond)) .compact_list(list(conditional = f.cond, random = f.random)) } #' @export find_formula.brmsfit <- function(x, ...) { f <- stats::formula(x) if (.obj_has_name(f, "forms")) { mv_formula <- lapply(f$forms, .get_brms_formula) attr(mv_formula, "is_mv") <- "1" mv_formula } else { .get_brms_formula(f) } } #' @export find_formula.stanmvreg <- function(x, ...) { f <- stats::formula(x) mv_formula <- lapply(f, .get_stanmv_formula) attr(mv_formula, "is_mv") <- "1" mv_formula } #' @export find_formula.MCMCglmm <- function(x, ...) { fm <- x$Fixed$formula fmr <- x$Random$formula .compact_list(list(conditional = fm, random = fmr)) } #' @importFrom utils tail #' @export find_formula.BFBayesFactor <- function(x, ...) { if (.classify_BFBayesFactor(x) == "linear") { fcond <- utils::tail(x@numerator, 1)[[1]]@identifier$formula dt <- utils::tail(x@numerator, 1)[[1]]@dataTypes frand <- names(dt)[which(dt == "random")] if (!.is_empty_object(frand)) { f.random <- stats::as.formula(paste0("~", frand)) fcond <- sub(frand, "", fcond, fixed = TRUE) fcond <- gsub("(.*)\\+$", "\\1", .trim(fcond)) f.cond <- stats::as.formula(.trim(fcond)) } else { f.random <- NULL f.cond <- stats::as.formula(fcond) } } else { return(NULL) } .compact_list(list( conditional = f.cond, random = f.random )) } # helper --------------------------- .get_brms_formula <- function(f) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.cond <- f$formula f.random <- lapply(lme4::findbars(f.cond), function(.x) { fm <- .safe_deparse(.x) stats::as.formula(paste0("~", fm)) }) if (length(f.random) == 1) { f.random <- f.random[[1]] } f.cond <- stats::as.formula(.get_fixed_effects(f.cond)) f.zi <- f$pforms$zi f.zirandom <- NULL if (!.is_empty_object(f.zi)) { f.zirandom <- lapply(lme4::findbars(f.zi), function(.x) { f <- .safe_deparse(.x) stats::as.formula(paste0("~", f)) }) if (length(f.zirandom) == 1) { f.zirandom <- f.zirandom[[1]] } f.zi <- stats::as.formula(paste0("~", .safe_deparse(f.zi[[3L]]))) f.zi <- stats::as.formula(.get_fixed_effects(f.zi)) } .compact_list(list( conditional = f.cond, random = f.random, zero_inflated = f.zi, zero_inflated_random = f.zirandom )) } .get_stanmv_formula <- function(f) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } f.cond <- f f.random <- lapply(lme4::findbars(f.cond), function(.x) { fm <- .safe_deparse(.x) stats::as.formula(paste0("~", fm)) }) if (length(f.random) == 1) { f.random <- f.random[[1]] } f.cond <- stats::as.formula(.get_fixed_effects(f.cond)) .compact_list(list( conditional = f.cond, random = f.random )) } # Find formula for zero-inflated regressions, where # zero-inflated part is separated by | from count part .zeroinf_formula <- function(x) { f <- tryCatch( { stats::formula(x) }, error = function(x) { NULL } ) if (is.null(f)) { return(NULL) } f <- .trim(unlist(strsplit(.safe_deparse(f), "\\|"))) c.form <- stats::as.formula(f[1]) if (length(f) == 2) { zi.form <- stats::as.formula(paste0("~", f[2])) } else { zi.form <- NULL } ## TODO could be extended to all find_formula() # fix dot-formulas c.form <- .dot_formula(f = c.form, model = x) # fix dot-formulas zi.form <- tryCatch( { if (as.character(zi.form[2]) == ".") { resp <- .safe_deparse(c.form[2]) pred <- setdiff(colnames(.get_data_from_env(x)), resp) zi.form <- stats::as.formula(paste(resp, "~", paste0(pred, collapse = " + "))) } zi.form }, error = function(e) { zi.form } ) .compact_list(list(conditional = c.form, zero_inflated = zi.form)) } # try to guess "full" formula for dot-abbreviation, e.g. # lm(mpg ~., data = mtcars) .dot_formula <- function(f, model) { # fix dot-formulas tryCatch( { if (as.character(f[[3]])[1] == ".") { resp <- .safe_deparse(f[[2]]) pred <- setdiff(colnames(.get_data_from_env(model)), resp) f <- stats::as.formula(paste(resp, "~", paste0(pred, collapse = " + "))) } f }, error = function(e) { f } ) } insight/R/model_info.R0000644000176200001440000004436713615526334014404 0ustar liggesusers#' @title Access information from model objects #' @name model_info #' #' @description Retrieve information from model objects. #' #' @inheritParams find_predictors #' @inheritParams link_inverse #' @inheritParams find_formula #' #' @return A list with information about the model, like family, link-function #' etc. (see 'Details'). #' #' @details \code{model_info()} returns a list with information about the #' model for many different model objects. Following information #' is returned, where all values starting with \code{is_} are logicals. #' \itemize{ #' \item \code{is_binomial}: family is binomial (but not negative binomial) #' \item \code{is_poisson}: family is poisson #' \item \code{is_negbin}: family is negative binomial #' \item \code{is_count}: model is a count model (i.e. family is either poisson or negative binomial) #' \item \code{is_beta}: family is beta #' \item \code{is_betabinomial}: family is beta-binomial #' \item \code{is_dirichlet}: family is dirichlet #' \item \code{is_exponential}: family is exponential (e.g. Gamma or Weibull) #' \item \code{is_logit}: model has logit link #' \item \code{is_progit}: model has probit link #' \item \code{is_linear}: family is gaussian #' \item \code{is_tweedie}: family is tweedie #' \item \code{is_ordinal}: family is ordinal, multinomial, or cumulative link #' \item \code{is_cumulative}: family is ordinal, multinomial, or cumulative link #' \item \code{is_multinomial}: family is multinomial or categorical link #' \item \code{is_categorical}: family is categorical link #' \item \code{is_censored}: model is a censored model (has a censored response, including survival models) #' \item \code{is_truncated}: model is a truncated model (has a truncated response) #' \item \code{is_survival}: model is a survival model #' \item \code{is_zero_inflated}: model has zero-inflation component #' \item \code{is_hurdle}: model has zero-inflation component and is a hurdle-model (truncated family distribution) #' \item \code{is_mixed}: model is a mixed effects model (with random effects) #' \item \code{is_multivariate}: model is a multivariate response model (currently only works for \emph{brmsfit} objects) #' \item \code{is_trial}: model response contains additional information about the trials #' \item \code{is_bayesian}: model is a Bayesian model #' \item \code{is_anova}: model is an Anova object #' \item \code{link_function}: the link-function #' \item \code{family}: the family-object #' \item \code{n_obs}: number of observations #' \item \code{model_terms}: a list with all model terms, including terms such as random effects or from zero-inflated model parts. #' } #' #' @examples #' ldose <- rep(0:5, 2) #' numdead <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16) #' sex <- factor(rep(c("M", "F"), c(6, 6))) #' SF <- cbind(numdead, numalive = 20 - numdead) #' dat <- data.frame(ldose, sex, SF, stringsAsFactors = FALSE) #' m <- glm(SF ~ sex * ldose, family = binomial) #' #' model_info(m) #' \dontrun{ #' library(glmmTMB) #' data("Salamanders") #' m <- glmmTMB( #' count ~ spp + cover + mined + (1 | site), #' ziformula = ~ spp + mined, #' dispformula = ~DOY, #' data = Salamanders, #' family = nbinom2 #' ) #' } #' #' model_info(m) #' @importFrom stats formula terms #' @export model_info <- function(x, ...) { UseMethod("model_info") } # Default methods -------------------------------------- #' @export model_info.data.frame <- function(x, ...) { stop("A data frame is no valid object for this function") } #' @importFrom stats family #' @export model_info.default <- function(x, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) } faminfo <- tryCatch( { if (inherits(x, c("Zelig-relogit"))) { stats::binomial(link = "logit") } else { stats::family(x) } }, error = function(x) { NULL } ) if (!is.null(faminfo)) { .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } else { warning("Could not access model information.", call. = FALSE) } } # Models with general handling, Gaussian ---------------------------------- #' @export model_info.mmclogit <- function(x, ...) { .make_family(x, ...) } #' @export model_info.maxLik <- model_info.mmclogit #' @export model_info.censReg <- model_info.mmclogit #' @export model_info.htest <- model_info.mmclogit #' @export model_info.BFBayesFactor <- model_info.mmclogit #' @export model_info.lme <- model_info.mmclogit #' @export model_info.bayesx <- model_info.mmclogit #' @export model_info.rq <- model_info.mmclogit #' @export model_info.crq <- model_info.mmclogit #' @export model_info.crqs <- model_info.mmclogit #' @export model_info.nlrq <- model_info.mmclogit #' @export model_info.rqss <- model_info.mmclogit #' @export model_info.mixed <- model_info.mmclogit #' @export model_info.plm <- model_info.mmclogit #' @export model_info.mcmc <- model_info.mmclogit #' @export model_info.gls <- model_info.mmclogit #' @export model_info.nls <- model_info.mmclogit #' @export model_info.MANOVA <- model_info.mmclogit #' @export model_info.RM <- model_info.mmclogit #' @export model_info.truncreg <- model_info.mmclogit #' @export model_info.lmRob <- model_info.mmclogit #' @export model_info.speedlm <- model_info.mmclogit #' @export model_info.lmrob <- model_info.mmclogit #' @export model_info.complmrob <- model_info.mmclogit #' @export model_info.lm_robust <- model_info.mmclogit #' @export model_info.iv_robust <- model_info.mmclogit #' @export model_info.felm <- model_info.mmclogit #' @export model_info.feis <- model_info.mmclogit #' @export model_info.ivreg <- model_info.mmclogit #' @export model_info.aovlist <- model_info.mmclogit #' @export model_info.rma <- model_info.mmclogit #' @export model_info.mlm <- function(x, ...) { .make_family(x, multi.var = TRUE, ...) } # Models with logit-link -------------------------------- #' @export model_info.logistf <- function(x, ...) { faminfo <- stats::binomial(link = "logit") .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.lrm <- model_info.logistf #' @export model_info.multinom <- model_info.logistf #' @export model_info.mlogit <- model_info.logistf #' @export model_info.gmnl <- model_info.logistf # Models with ordinal family ------------------------------------ #' @export model_info.clm <- function(x, ...) { faminfo <- stats::binomial(link = .get_ordinal_link(x)) .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.clm2 <- model_info.clm #' @export model_info.clmm <- model_info.clm #' @export model_info.mixor <- model_info.clm # Models with family-function ---------------------------------- #' @importFrom stats family #' @export model_info.bamlss <- function(x, ...) { faminfo <- stats::family(x) .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$links[1] == "logit", link.fun = faminfo$links[1], ... ) } #' @export model_info.speedglm <- function(x, ...) { faminfo <- stats::family(x) .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.brmultinom <- model_info.speedglm # Models with tobit family ---------------------------------- #' @export model_info.flexsurvreg <- function(x, ...) { dist <- parse(text = .safe_deparse(x$call))[[1]]$dist faminfo <- .make_tobit_family(x, dist) .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.tobit <- function(x, ...) { faminfo <- .make_tobit_family(x) .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.crch <- model_info.tobit #' @export model_info.survreg <- model_info.tobit # Models with family in object ---------------------------------- #' @export model_info.MixMod <- function(x, ...) { faminfo <- x$family .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.glmmPQL <- model_info.MixMod #' @export model_info.glmx <- function(x, ...) { faminfo <- x$family$glm .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.fixest <- function(x, ...) { faminfo <- x$family if (is.null(faminfo)) { if (!is.null(x$method) && x$method == "feols") { .make_family(x, ...) } } else if (inherits(faminfo, "family")) { .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } else { fitfam <- switch( faminfo, "negbin" = "negative binomial", "logit" = "binomial", faminfo ) link <- switch( faminfo, "poisson" = , "negbin" = "log", "logit" = "logit", "gaussian" = "identity" ) .make_family( x = x, fitfam = fitfam, logit.link = link == "logit", link.fun = link, ... ) } } #' @export model_info.feglm <- model_info.fixest # Survival-models ---------------------------------------- #' @export model_info.coxph <- function(x, ...) { .make_family( x = x, fitfam = "survival", logit.link = TRUE, link.fun = NULL, ... ) } #' @export model_info.aareg <- model_info.coxph #' @export model_info.survfit <- model_info.coxph #' @export model_info.coxme <- model_info.coxph # Zero-Inflated Models ------------------------------ #' @export model_info.zeroinfl <- function(x, ...) { if (is.list(x$dist)) { dist <- x$dist[[1]] } else { dist <- x$dist } fitfam <- switch( dist, poisson = "poisson", negbin = "negative binomial", "poisson" ) .make_family( x = x, fitfam = fitfam, zero.inf = TRUE, link.fun = "log", ... ) } #' @export model_info.zerotrunc <- model_info.zeroinfl #' @export model_info.hurdle <- function(x, ...) { if (is.list(x$dist)) { dist <- x$dist[[1]] } else { dist <- x$dist } fitfam <- switch( dist, poisson = "poisson", negbin = "negative binomial", "poisson" ) .make_family( x = x, fitfam = fitfam, zero.inf = TRUE, hurdle = TRUE, link.fun = "log", ... ) } # Bayesian Models --------------------------- #' @export model_info.brmsfit <- function(x, ...) { faminfo <- stats::family(x) if (is_multivariate(x)) { lapply(faminfo, function(.x) { .make_family( x = x, fitfam = .x$family, zero.inf = FALSE, logit.link = .x$link == "logit", multi.var = TRUE, link.fun = .x$link, ... ) }) } else { .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", multi.var = FALSE, link.fun = faminfo$link, ... ) } } #' @export model_info.stanmvreg <- function(x, ...) { faminfo <- stats::family(x) lapply(faminfo, function(.x) { .make_family( x = x, fitfam = .x$family, zero.inf = FALSE, logit.link = .x$link == "logit", multi.var = TRUE, link.fun = .x$link, ... ) }) } # Other models ---------------------------- #' @export model_info.cglm <- function(x, ...) { link <- parse(text = .safe_deparse(x$call))[[1]]$link method <- parse(text = .safe_deparse(x$call))[[1]]$method if (!is.null(method) && method == "clm") { .make_family(x, ...) } else if (!is.null(link)) { .make_family( x, logit.link = link == "logit", link.fun = link, ... ) } else { .make_family(x, ...) } } #' @export model_info.cgam <- function(x, ...) { faminfo <- x$family .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.gamm <- function(x, ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) NextMethod() } #' @export model_info.LORgee <- function(x, ...) { if (grepl(pattern = "logit", x = x$link, fixed = TRUE)) { link <- "logit" } else if (grepl(pattern = "probit", x = x$link, fixed = TRUE)) { link <- "probit" } else if (grepl(pattern = "cauchit", x = x$link, fixed = TRUE)) { link <- "cauchit" } else if (grepl(pattern = "cloglog", x = x$link, fixed = TRUE)) { link <- "cloglog" } else { link <- "logit" } if (x$link == "Cumulative logit") family <- "ordinal" else family <- "multinomial" .make_family( x = x, fitfam = family, logit.link = link == "logit", link.fun = link, ... ) } #' @export model_info.BBreg <- function(x, ...) { .make_family( x = x, fitfam = "betabinomial", logit.link = TRUE, multi.var = FALSE, zero.inf = FALSE, link.fun = "logit", ... ) } #' @export model_info.BBmm <- model_info.BBreg #' @export model_info.glmmadmb <- function(x, ...) { .make_family( x = x, fitfam = x$family, logit.link = x$link == "logit", multi.var = FALSE, zero.inf = x$zeroInflation, link.fun = x$link, ... ) } #' @export model_info.cpglmm <- function(x, ...) { link <- parse(text = .safe_deparse(x@call))[[1]]$link if (is.numeric(link)) link <- "tweedie" .make_family( x = x, fitfam = "poisson", logit.link = FALSE, multi.var = FALSE, link.fun = link, ... ) } #' @export model_info.cpglm <- model_info.cpglmm #' @export model_info.glimML <- function(x, ...) { fitfam <- switch(x@method, BB = "betabinomial", NB = "negative binomial") .make_family( x = x, fitfam = fitfam, logit.link = x@link == "logit", multi.var = FALSE, zero.inf = FALSE, link.fun = x@link, ... ) } #' @export model_info.gam <- function(x, ...) { if (!inherits(x, c("glm", "lm"))) { class(x) <- c(class(x), "glm", "lm") } faminfo <- .gam_family(x) link <- faminfo$link[1] is.mv <- faminfo$family == "Multivariate normal" if (is.mv) link <- "identity" .make_family( x = x, fitfam = faminfo$family, logit.link = link == "logit", link.fun = link, multi.var = is.mv, ... ) } #' @export model_info.vgam <- function(x, ...) { faminfo <- x@family link.fun <- faminfo@blurb[3] if (grepl("^(l|L)ogit", link.fun)) link.fun <- "logit" .make_family( x = x, fitfam = faminfo@vfamily[1], logit.link = any(.string_contains("logit", faminfo@blurb)), link.fun = link.fun, ... ) } #' @export model_info.vglm <- model_info.vgam #' @export model_info.glmmTMB <- function(x, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } faminfo <- stats::family(x) .make_family( x = x, fitfam = faminfo$family, zero.inf = !.is_empty_object(lme4::fixef(x)$zi), hurdle = grepl("truncated", faminfo$family), logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.betareg <- function(x, ...) { .make_family( x = x, fitfam = "beta", logit.link = x$link$mean$name == "logit", link.fun = x$link$mean$name, ... ) } #' @export model_info.DirichletRegModel <- function(x, ...) { .make_family( x = x, fitfam = "dirichlet", logit.link = TRUE, link.fun = "logit", ... ) } #' @export model_info.gbm <- function(x, ...) { faminfo <- switch( x$distribution$name, laplace = , tdist = , gaussian = list(name = "gaussian", logit = FALSE, link = NULL), coxph = list(name = "survival", logit = TRUE, link = NULL), poisson = list(name = "poisson", logit = FALSE, link = "log"), huberized = , adaboost = , bernoulli = list(name = "binomial", logit = TRUE, link = "logit"), ) .make_family( x = x, fitfam = faminfo$name, logit.link = faminfo$logit, link.fun = faminfo$link, ... ) } #' @export model_info.MCMCglmm <- function(x, ...) { .make_family( x = x, fitfam = x$Residual$family, logit.link = FALSE, link.fun = "", ... ) } #' @export model_info.polr <- function(x, ...) { link <- x$method if (link == "logistic") link <- "logit" faminfo <- stats::binomial(link = link) .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.svyolr <- function(x, ...) { l <- switch(x$method, logistic = "logit", x$method) faminfo <- stats::binomial(link = l) .make_family( x = x, fitfam = faminfo$family, logit.link = faminfo$link == "logit", link.fun = faminfo$link, ... ) } #' @export model_info.gamlss <- function(x, ...) { faminfo <- get(x$family[1], asNamespace("gamlss"))() .make_family( x = x, fitfam = faminfo$family[2], logit.link = faminfo$mu.link == "logit", link.fun = faminfo$mu.link, ... ) } insight/R/find_predictors.R0000644000176200001440000001273013602434030015417 0ustar liggesusers#' @title Find names of model predictors #' @name find_predictors #' #' @description Returns the names of the predictor variables for the #' different parts of a model (like fixed or random effects, zero-inflated #' component, ...). Unlike \code{\link{find_parameters}}, the names from #' \code{find_predictors()} match the original variable names from the data #' that was used to fit the model. #' #' @param x A fitted model. #' @param effects Should variables for fixed effects, random effects #' or both be returned? Only applies to mixed models. May be abbreviated. #' @param component Should all predictor variables, predictor variables for the #' conditional model, the zero-inflated part of the model, the dispersion #' term or the instrumental variables be returned? Applies to models #' with zero-inflated and/or dispersion formula, or to models with instrumental #' variable (so called fixed-effects regressions). May be abbreviated. Note that the #' \emph{conditional} component is also called \emph{count} or \emph{mean} #' component, depending on the model. #' @param flatten Logical, if \code{TRUE}, the values are returned #' as character vector, not as list. Duplicated values are removed. #' #' @return A list of character vectors that represent the name(s) of the #' predictor variables. Depending on the combination of the arguments #' \code{effects} and \code{component}, the returned list has following #' elements: #' \itemize{ #' \item \code{conditional}, the "fixed effects" terms from the model #' \item \code{random}, the "random effects" terms from the model #' \item \code{zero_inflated}, the "fixed effects" terms from the zero-inflation component of the model #' \item \code{zero_inflated_random}, the "random effects" terms from the zero-inflation component of the model #' \item \code{dispersion}, the dispersion terms #' \item \code{instruments}, for fixed-effects regressions like \code{ivreg}, \code{felm} or \code{plm}, the instrumental variables #' \item \code{correlation}, for models with correlation-component like \code{gls}, the variables used to describe the correlation structure #' } #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' find_predictors(m) #' @export find_predictors <- function(x, effects = c("fixed", "random", "all"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "instruments", "correlation", "smooth_terms"), flatten = FALSE) { effects <- match.arg(effects) component <- match.arg(component) f <- find_formula(x) is_mv <- is_multivariate(f) elements <- .get_elements(effects, component) # filter formulas, depending on requested effects and components if (is_mv) { f <- lapply(f, function(.x) .prepare_predictors(x, .x, elements)) } else { f <- .prepare_predictors(x, f, elements) } # random effects are returned as list, so we need to unlist here if (is_mv) { l <- lapply(f, function(.i) .return_vars(.i, x)) } else { l <- .return_vars(f, x) } if (.is_empty_object(l) || .is_empty_object(.compact_list(l))) { return(NULL) } # some models, like spatial models, have random slopes that are not defined # as fixed effect predictor. In such cases, we have to add the random slope term # manually, so other functions like "get_data()" work as expected... if (.obj_has_name(l, "random") && effects == "all") { random_slope <- unname(unlist(find_random_slopes(x))) all_predictors <- unlist(unique(l)) rs_not_in_pred <- unique(setdiff(random_slope, all_predictors)) if (length(rs_not_in_pred)) l$random <- c(rs_not_in_pred, l$random) } if (flatten) { unique(unlist(l)) } else { l } } .return_vars <- function(f, x) { l <- lapply(names(f), function(i) { if (i %in% c("random", "zero_inflated_random")) { unique(paste(unlist(f[[i]]))) } else if (is.numeric(f[[i]])) { f[[i]] } else { if (is.list(f[[i]])) { # this is for multivariate response models, where # we have a list of formulas lapply(f[[i]], function(j) unique(all.vars(j))) } else { unique(all.vars(f[[i]])) } } }) empty_elements <- sapply(l, .is_empty_object) l <- .compact_list(l) # here we handle special cases for non-linear model in brms if (inherits(x, "brmsfit")) { nf <- stats::formula(x) if (!is.null(attr(nf$formula, "nl", exact = TRUE)) && .obj_has_name(nf, "pforms")) { nl_parms <- names(nf$pforms) l <- lapply(l, .remove_values, nl_parms) } } # remove constants l <- lapply(l, .remove_values, c(".", "pi", "1", "0")) l <- lapply(l, .remove_values, c(0, 1)) l <- lapply(l, function(i) gsub("`", "", i, fixed = TRUE)) names(l) <- names(f)[!empty_elements] l } .prepare_predictors <- function(x, f, elements) { f <- f[names(f) %in% elements] # from conditional model, remove response if (.obj_has_name(f, "conditional")) { f[["conditional"]] <- f[["conditional"]][[3]] } # if we have random effects, just return grouping variable, not random slopes if (.obj_has_name(f, "random")) { f[["random"]] <- .get_group_factor(x, f[["random"]]) } # same for zi-random effects if (.obj_has_name(f, "zero_inflated_random")) { f[["zero_inflated_random"]] <- .get_group_factor(x, f[["zero_inflated_random"]]) } f } insight/R/find_response.R0000644000176200001440000000506313613251343015106 0ustar liggesusers#' @title Find name of the response variable #' @name find_response #' #' @description Returns the name(s) of the response variable(s) from a model object. #' #' @param x A fitted model. #' @param combine Logical, if \code{TRUE} and the response is a matrix-column, #' the name of the response matches the notation in formula, and would for #' instance also contain patterns like \code{"cbind(...)"}. Else, the original #' variable names from the matrix-column are returned. See 'Examples'. #' #' @return The name(s) of the response variable(s) from \code{x} as character vector. #' #' @examples #' library(lme4) #' data(cbpp) #' cbpp$trials <- cbpp$size - cbpp$incidence #' m <- glm(cbind(incidence, trials) ~ period, data = cbpp, family = binomial) #' #' find_response(m, combine = TRUE) #' find_response(m, combine = FALSE) #' @export find_response <- function(x, combine = TRUE) { f <- find_formula(x) # this is for multivariate response models, where # we have a list of formulas if (is_multivariate(f)) { resp <- unlist(lapply(f, function(i) .safe_deparse(i$conditional[[2L]]))) } else { resp <- .safe_deparse(f$conditional[[2L]]) } check_cbind(resp, combine, model = x) } # should not be called for brms-models! check_cbind <- function(resp, combine, model) { if (!combine && inherits(model, "DirichletRegModel")) { resp <- model$varnames } else if (!combine && any(grepl("cbind\\((.*)\\)", resp))) { resp <- .extract_combined_response(resp, "cbind") } else if (!combine && any(grepl("Surv\\((.*)\\)", resp))) { resp <- .extract_combined_response(resp, "Surv") } else if (!combine && any(grepl("Curv\\((.*)\\)", resp))) { resp <- .extract_combined_response(resp, "Curv") } else if (!combine && any(grepl("/", resp, fixed = TRUE))) { resp <- strsplit(resp, split = "/", fixed = TRUE) resp <- gsub("(I|\\(|\\))", "", .trim(unlist(resp))) } else if (any(.string_contains("|", resp))) { # check for brms Additional Response Information r1 <- .trim(sub("(.*)\\|(.*)", "\\1", resp)) r2 <- .trim(sub("(.*)\\|(.*)\\(([^,)]*).*", "\\3", resp)) resp <- c(r1, r2) } .remove_pattern_from_names(resp, ignore_asis = TRUE) } .extract_combined_response <- function(resp, pattern) { resp <- sub(sprintf("%s\\(([^,].*)([\\)].*)", pattern), "\\1", resp) resp <- strsplit(resp, split = ",", fixed = TRUE) resp <- .trim(unlist(resp)) if (any(.string_contains("-", resp[2]))) { resp[2] <- .trim(sub("(.*)(\\-)(.*)", "\\1", resp[2])) } resp } insight/R/download_model.R0000644000176200001440000000302713524331052015232 0ustar liggesusers#' @title Download circus models #' @name download_model #' #' @description Downloads pre-compiled models from the \emph{circus}-repository. #' The \emph{circus}-repository contains a variety of fitted models to help #' the systematic testing of other packages #' #' @param name Model name. #' @param url String with the URL from where to download the model data. #' Optional, and should only be used in case the repository-URL is #' changing. By default, models are downloaded from #' \code{https://raw.github.com/easystats/circus/master/data/}. #' #' @return A model from the \emph{circus}-repository. #' #' @details The code that generated the model is available at the #' \url{https://easystats.github.io/circus/reference/index.html}. #' #' @references \url{https://easystats.github.io/circus/} #' #' @export download_model <- function(name, url = NULL) { .download_data_github(name, url) } # Download rda files from github .download_data_github <- function(name, url) { if (!requireNamespace("httr", quietly = TRUE)) { stop("Package `httr` required to download models from the circus-repo.", call. = FALSE) } if (is.null(url)) { url <- "https://raw.github.com/easystats/circus/master/data/" } url <- paste0(url, name, ".rda") temp_file <- tempfile() on.exit(unlink(temp_file)) request <- httr::GET(url) httr::stop_for_status(request) writeBin(httr::content(request, type = "raw"), temp_file) x <- load(temp_file) model <- get(x) rm(x) model } insight/R/utils_get_data.R0000644000176200001440000003517013571247604015252 0ustar liggesusers# Function that does the most work for preparing and transforming the data, # to ensure we have a "clean" data frame from the data that was used to fit # the model. This also means that, unless necessary for further processing, # variables transformed during model fitting are not included in this data frame # #' @importFrom stats getCall formula na.omit .prepare_get_data <- function(x, mf, effects = "fixed") { if (.is_empty_object(mf)) { warning("Could not get model data.", call. = F) return(NULL) } # we may store model weights here later mw <- NULL # do we have an offset, not specified in the formula? if ("(offset)" %in% colnames(mf) && .obj_has_name(x, "call") && .obj_has_name(x$call, "offset")) { offcol <- which(colnames(mf) == "(offset)") colnames(mf)[offcol] <- clean_names(.safe_deparse(x$call$offset)) } # clean 1-dimensional matrices mf[] <- lapply(mf, function(.x) { if (is.matrix(.x) && dim(.x)[2] == 1 && !inherits(.x, c("ns", "bs"))) { as.vector(.x) } else { .x } }) # check if we have any matrix columns, e.g. from splines mc <- sapply(mf, is.matrix) # don't change response value, if it's a matrix # bound with cbind() rn <- find_response(x, combine = TRUE) rn_not_combined <- find_response(x, combine = FALSE) trials.data <- NULL if (mc[1] && rn == colnames(mf)[1]) { mc[1] <- FALSE if (inherits(x, c("coxph", "flexsurvreg", "coxme", "survreg", "survfit", "crq", "psm"))) { mf <- cbind(mf[[1]][, 1], mf[[1]][, 2], mf) colnames(mf)[1:2] <- rn_not_combined } else { tryCatch( { trials.data <- as.data.frame(mf[[1]]) colnames(trials.data) <- rn_not_combined # if columns were bound via substraction, e.g. # "cbind(succes, total - success)", we need to sum up success and # total for the original total-column. pattern <- sprintf("%s(\\s*)-(\\s*)%s", rn_not_combined[2], rn_not_combined[1]) if (grepl(pattern = pattern, x = rn)) { trials.data[[2]] <- trials.data[[1]] + trials.data[[2]] } }, error = function(x) { NULL } ) } } # if we have any matrix columns, we remove them from original # model frame and convert them to regular data frames, give # proper column names and bind them back to the original model frame if (any(mc)) { # try to get model data from environment md <- tryCatch( { eval(stats::getCall(x)$data, environment(stats::formula(x))) }, error = function(x) { NULL } ) # if data not found in environment, reduce matrix variables into regular vectors if (is.null(md)) { # we select the non-matrix variables and convert matrix-variables into # regular data frames, then binding them together mf_matrix <- mf[, which(mc), drop = FALSE] mf_nonmatrix <- mf[, -which(mc), drop = FALSE] # fix for rms::rcs() functions if (any(class(mf_matrix[[1]]) == "rms")) class(mf_matrix[[1]]) <- "matrix" mf_list <- lapply(mf_matrix, as.data.frame, stringsAsFactors = FALSE) mf_matrix <- do.call(cbind, mf_list) mf <- cbind(mf_nonmatrix, mf_matrix) } else { # fix NA in column names if (any(is.na(colnames(md)))) colnames(md) <- make.names(colnames(md)) # get "matrix" terms and "normal" predictors, but exclude # response variable(s) mf_matrix <- mf[, -which(mc), drop = FALSE] spline.term <- clean_names(names(which(mc))) other.terms <- clean_names(colnames(mf_matrix))[-1] # now we have all variable names that we need from the original # data set needed.vars <- c(other.terms, spline.term) # if response is a matrix vector (e.g. multivariate response), # we need to include all response names as well, because else # rows may not match due to additional missings in the response variables if (is.matrix(mf[[1]])) { needed.vars <- c(dimnames(mf[[1]])[[2]], needed.vars) } else { needed.vars <- c(colnames(mf)[1], needed.vars) } # check model weights if ("(weights)" %in% needed.vars && !.obj_has_name(md, "(weights)")) { needed.vars <- needed.vars[-which(needed.vars == "(weights)")] mw <- mf[["(weights)"]] } if (inherits(x, c("coxph", "coxme"))) { mf <- md } else { needed.vars <- unique(clean_names(needed.vars)) mf <- md[, needed.vars, drop = FALSE] # we need this hack to save variable and value label attributes, if any value_labels <- lapply(mf, function(.l) attr(.l, "labels", exact = TRUE)) variable_labels <- lapply(mf, function(.l) attr(.l, "label", exact = TRUE)) # removing NAs drops all label-attributes mf <- stats::na.omit(mf) # then set back attributes mf <- as.data.frame(mapply(function(.d, .l) { attr(.d, "labels") <- .l .d }, mf, value_labels, SIMPLIFY = FALSE), stringsAsFactors = FALSE) mf <- as.data.frame(mapply(function(.d, .l) { attr(.d, "label") <- .l .d }, mf, variable_labels, SIMPLIFY = FALSE), stringsAsFactors = FALSE) } # add back model weights, if any if (!is.null(mw)) mf$`(weights)` <- mw } # check if we really have all formula terms in our model frame now pv <- tryCatch( { find_predictors(x, effects = effects, flatten = TRUE) }, error = function(x) { NULL } ) if (!is.null(pv) && !all(pv %in% colnames(mf))) { warning("Some model terms could not be found in model data. You probably need to load the data into the environment.", call. = FALSE) } } # check if we have monotonic variables, included in formula # with "mo()"? If yes, remove from model frame mos_eisly <- grepl(pattern = "^mo\\(([^,)]*).*", x = colnames(mf)) if (any(mos_eisly)) mf <- mf[!mos_eisly] # clean variable names cvn <- .remove_pattern_from_names(colnames(mf), ignore_lag = TRUE) # keep "as is" variable for response variables in data frame if (colnames(mf)[1] == rn[1] && grepl("^I\\(", rn[1])) { md <- tryCatch( { tmp <- .get_data_from_env(x)[, unique(c(rn_not_combined, cvn)), drop = FALSE] tmp[, rn_not_combined, drop = FALSE] }, error = function(x) { NULL } ) if (!is.null(md)) { mf <- cbind(mf, md) cvn <- .remove_pattern_from_names(colnames(mf), ignore_lag = TRUE) cvn[1] <- rn[1] } } # do we have duplicated names? dupes <- which(duplicated(cvn)) if (!.is_empty_string(dupes)) cvn[dupes] <- sprintf("%s.%s", cvn[dupes], 1:length(dupes)) colnames(mf) <- cvn # add weighting variable weighting_var <- find_weights(x) if (!is.null(weighting_var) && !weighting_var %in% colnames(mf) && length(weighting_var) == 1) { mf <- tryCatch( { tmp <- suppressWarnings(cbind(mf, get_weights(x))) colnames(tmp)[ncol(tmp)] <- weighting_var tmp }, error = function(e) { mf } ) } # add back possible trials-data if (!is.null(trials.data)) { new.cols <- setdiff(colnames(trials.data), colnames(mf)) if (!.is_empty_string(new.cols)) mf <- cbind(mf, trials.data[, new.cols, drop = FALSE]) } mf } # combine data from different model components ------------------------------- # This helper functions ensures that data from different model components # are included in the returned data frame # .return_data <- function(x, mf, effects, component, model.terms, is_mv = FALSE) { response <- unlist(model.terms$response) if (is_mv) { fixed.component.data <- switch( component, all = c( sapply(model.terms[-1], function(i) i$conditional), sapply(model.terms[-1], function(i) i$zero_inflated), sapply(model.terms[-1], function(i) i$dispersion) ), conditional = sapply(model.terms[-1], function(i) i$conditional), zi = , zero_inflated = sapply(model.terms[-1], function(i) i$zero_inflated), dispersion = sapply(model.terms[-1], function(i) i$dispersion) ) random.component.data <- switch( component, all = c( sapply(model.terms[-1], function(i) i$random), sapply(model.terms[-1], function(i) i$zero_inflated_random) ), conditional = sapply(model.terms[-1], function(i) i$random), zi = , zero_inflated = sapply(model.terms[-1], function(i) i$zero_inflated_random) ) fixed.component.data <- unlist(fixed.component.data) random.component.data <- unlist(random.component.data) } else { fixed.component.data <- switch( component, all = c(model.terms$conditional, model.terms$zero_inflated, model.terms$dispersion), conditional = model.terms$conditional, zi = , zero_inflated = model.terms$zero_inflated, dispersion = model.terms$dispersion ) random.component.data <- switch( component, all = c(model.terms$random, model.terms$zero_inflated_random), conditional = model.terms$random, zi = , zero_inflated = model.terms$zero_inflated_random ) } # this is to remove the "1" from intercept-ony-models if (!.is_empty_object(fixed.component.data)) { fixed.component.data <- .remove_values(fixed.component.data, c("1", "0")) fixed.component.data <- .remove_values(fixed.component.data, c(1, 0)) } if (!.is_empty_object(random.component.data)) { random.component.data <- .remove_values(random.component.data, c("1", "0")) random.component.data <- .remove_values(random.component.data, c(1, 0)) } dat <- switch( effects, all = mf[, unique(c(response, fixed.component.data, random.component.data, find_weights(x))), drop = FALSE], fixed = mf[, unique(c(response, fixed.component.data, find_weights(x))), drop = FALSE], random = mf[, unique(random.component.data), drop = FALSE] ) if (.is_empty_object(dat)) { print_color(sprintf("Warning: Data frame is empty, probably component '%s' does not exist in the %s-part of the model?\n", component, effects), "red") return(NULL) } if ("(offset)" %in% colnames(mf) && !("(offset)" %in% colnames(dat))) { dat <- cbind(dat, mf[["(offset"]]) } dat } # find zi-data ----------------------------------- # this function tries to get the data from variables from the zero-inflated # component and adds them to the model frame. Useful if the zi-component # has other variables than the count component. # .add_zeroinf_data <- function(x, mf, tn) { tryCatch( { env_data <- eval(x$call$data, envir = parent.frame())[, tn, drop = FALSE] if (.obj_has_name(x$call, "subset")) { env_data <- subset(env_data, subset = eval(x$call$subset)) } .merge_dataframes(env_data, mf, replace = TRUE) }, error = function(x) { mf } ) } # special model handling ----------------------------------- .get_zelig_relogit_frame <- function(x) { vars <- find_variables(x, flatten = TRUE) x$data[, vars, drop = FALSE] } # combine data from count and zi-component ----------------------------------- .return_zeroinf_data <- function(x, component) { model.terms <- find_variables(x, effects = "all", component = "all", flatten = FALSE) mf <- tryCatch( { stats::model.frame(x) }, error = function(x) { NULL } ) mf <- .prepare_get_data(x, mf) # add variables from other model components mf <- .add_zeroinf_data(x, mf, model.terms$zero_inflated) fixed.data <- switch( component, all = c(model.terms$conditional, model.terms$zero_inflated), conditional = model.terms$conditional, zi = , zero_inflated = model.terms$zero_inflated ) mf[, unique(c(model.terms$response, fixed.data, find_weights(x))), drop = FALSE] } # "clean" model frame and get data ----------------------------------- # here we have a model frame with many variables, so just extract the important ones... # .get_data_from_modelframe <- function(x, dat, effects) { cn <- clean_names(colnames(dat)) ft <- switch( effects, fixed = find_variables(x, effects = "fixed", flatten = TRUE), all = find_variables(x, flatten = TRUE), random = find_random(x, split_nested = TRUE, flatten = TRUE) ) remain <- intersect(c(ft, find_weights(x)), cn) mf <- tryCatch( { dat[, remain, drop = FALSE] }, error = function(x) { dat } ) .prepare_get_data(x, mf, effects) } # find data from the environment ----------------------------------- # return data from a data frame that is in the environment, # and subset the data, if necessary .get_data_from_env <- function(x) { # first try, parent frame dat <- tryCatch( { eval(x$call$data, envir = parent.frame()) }, error = function(e) { NULL } ) if (is.null(dat)) { # second try, global env dat <- tryCatch( { eval(x$call$data, envir = globalenv()) }, error = function(e) { NULL } ) } if (!is.null(dat) && .obj_has_name(x$call, "subset")) { dat <- subset(dat, subset = eval(x$call$subset)) } dat } # find data from the environment, for models with S4 -------------------------- # return data from a data frame that is in the environment, # and subset the data, if necessary .get_S4_data_from_env <- function(x) { # first try, parent frame dat <- tryCatch( { eval(x@call$data, envir = parent.frame()) }, error = function(e) { NULL } ) if (is.null(dat)) { # second try, global env dat <- tryCatch( { eval(x@call$data, envir = globalenv()) }, error = function(e) { NULL } ) } if (!is.null(dat) && .obj_has_name(x@call, "subset")) { dat <- subset(dat, subset = eval(x@call$subset)) } dat } # find start vector of nlmer-models from the environment ----------------------------------- # return data from a data frame that is in the environment, # and subset the data, if necessary .get_startvector_from_env <- function(x) { tryCatch( { sv <- eval(parse(text = .safe_deparse(x@call))[[1]]$start) if (is.list(sv)) sv <- sv[["nlpars"]] names(sv) }, error = function(e) { NULL } ) } insight/R/find_random.R0000644000176200001440000000527513531007236014534 0ustar liggesusers#' @title Find names of random effects #' @name find_random #' #' @description Return the name of the grouping factors from mixed effects models. #' #' @param x A fitted mixed model. #' @param split_nested Logical, if \code{TRUE}, terms from nested random #' effects will be returned as separated elements, not as single string #' with colon. See 'Examples'. #' #' @inheritParams find_predictors #' @inheritParams find_variables #' #' @return A list of character vectors that represent the name(s) of the #' random effects (grouping factors). Depending on the model, the #' returned list has following elements: #' \itemize{ #' \item \code{random}, the "random effects" terms from the conditional part of model #' \item \code{zero_inflated_random}, the "random effects" terms from the zero-inflation component of the model #' } #' #' @examples #' library(lme4) #' data(sleepstudy) #' sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) #' sleepstudy$mysubgrp <- NA #' for (i in 1:5) { #' filter_group <- sleepstudy$mygrp == i #' sleepstudy$mysubgrp[filter_group] <- #' sample(1:30, size = sum(filter_group), replace = TRUE) #' } #' #' m <- lmer( #' Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), #' data = sleepstudy #' ) #' #' find_random(m) #' find_random(m, split_nested = TRUE) #' @export find_random <- function(x, split_nested = FALSE, flatten = FALSE) { f <- find_formula(x) if (is_multivariate(x)) { rn <- names(find_response(x)) l <- lapply(rn, function(i) .find_random_effects(x, f[[i]], split_nested)) names(l) <- rn l <- .compact_list(l) } else { l <- .find_random_effects(x, f, split_nested) } if (.is_empty_object(l)) { return(NULL) } if (flatten) { unique(unlist(l)) } else { l } } .find_random_effects <- function(x, f, split_nested) { if (!.obj_has_name(f, "random") && !.obj_has_name(f, "zero_inflated_random")) { return(NULL) } if (.obj_has_name(f, "random")) { if (is.list(f$random)) { r1 <- unique(unlist(lapply(f$random, function(.x) .get_model_random(.x, split_nested, x)))) } else { r1 <- unique(unlist(.get_model_random(f$random, split_nested, x))) } } else { r1 <- NULL } if (.obj_has_name(f, "zero_inflated_random")) { if (is.list(f$zero_inflated_random)) { r2 <- unique(unlist(lapply(f$zero_inflated_random, function(.x) .get_model_random(.x, split_nested, x)))) } else { r2 <- unique(.get_model_random(f$zero_inflated_random, split_nested, x)) } } else { r2 <- NULL } .compact_list(list(random = r1, zero_inflated_random = r2)) } insight/R/print.easystats_check.R0000644000176200001440000000104513545706254016566 0ustar liggesusers#' @export print.easystats_check <- function(x, ...) { # check attributes title <- attr(x, "title") text <- attr(x, "text") color <- attr(x, "color") # no attributes found? check list elements then... if (is.null(title) && is.null(text) && is.null(color)) { if ("title" %in% names(x)) title <- x$title if ("text" %in% names(x)) text <- x$text if ("color" %in% names(x)) color <- x$color } if (!is.null(title)) { print_color(paste0("# ", title, "\n\n"), "blue") } print_color(text, color) } insight/R/clean_parameters.R0000644000176200001440000003444713600731467015573 0ustar liggesusers#' @title Get clean names of model parameters #' @name clean_parameters #' #' @description This function "cleans" names of model parameters by removing #' patterns like \code{"r_"} or \code{"b[]"} (mostly applicable to Stan models) #' and adding columns with information to which group or component parameters #' belong (i.e. fixed or random, count or zero-inflated...) #' \cr \cr #' The main purpose of this function is to easily filter and select model parameters, #' in particular of - but not limited to - posterior samples from Stan models, #' depending on certain characteristics. This might be useful when only selective #' results should be reported or results from all parameters should be filtered #' to return only certain results (see \code{\link{print_parameters}}). #' #' @param x A fitted model. #' @inheritParams find_parameters #' #' @return A data frame with "cleaned" parameter names and information on #' effects, component and group where parameters belong to. To be consistent #' across different models, the returned data frame always has at least four #' columns \code{Parameter}, \code{Effects}, \code{Component} and #' \code{Cleaned_Parameter}. See 'Details'. #' #' @details The \code{Effects} column indicate if a parameter is a \emph{fixed} #' or \emph{random} effect. The \code{Component} can either be \emph{conditional} #' or \emph{zero_inflated}. For models with random effects, the \code{Group} #' column indicates the grouping factor of the random effects. For multivariate #' response models from \pkg{brms} or \pkg{rstanarm}, an additional \emph{Response} #' column is included, to indicate which parameters belong to which response #' formula. Furthermore, \emph{Cleaned_Parameter} column is returned that #' contains "human readable" parameter names (which are mostly identical to #' \code{Parameter}, except for for models from \pkg{brms} or \pkg{rstanarm}, #' or for specific terms like smooth- or spline-terms). #' #' @examples #' \dontrun{ #' library(brms) #' model <- download_model("brms_zi_2") #' clean_parameters(model) #' } #' @export clean_parameters <- function(x, ...) { UseMethod("clean_parameters") } #' @export clean_parameters.default <- function(x, ...) { pars <- find_parameters(x, effects = "all", component = "all", flatten = FALSE) l <- lapply(names(pars), function(i) { eff <- if (grepl("random", i, fixed = TRUE)) { "random" } else { "fixed" } com <- if (grepl("zero_inflated", i, fixed = TRUE)) { "zero_inflated" } else if (grepl("nonlinear", i, fixed = TRUE)) { "nonlinear" } else if (grepl("instruments", i, fixed = TRUE)) { "instruments" } else if (grepl("extra", i, fixed = TRUE)) { "extra" } else if (grepl("scale", i, fixed = TRUE)) { "scale" } else { "conditional" } fun <- if (grepl("smooth", i, fixed = TRUE)) { "smooth" } else { "" } if (eff == "random") { rand_eff <- lapply(names(pars[[i]]), function(j) { data.frame( Parameter = pars[[i]][[j]], Effects = eff, Component = com, Group = j, Function = fun, Cleaned_Parameter = pars[[i]][[j]], stringsAsFactors = FALSE, row.names = NULL ) }) do.call(rbind, rand_eff) } else { data.frame( Parameter = pars[[i]], Effects = eff, Component = com, Group = "", Function = fun, Cleaned_Parameter = pars[[i]], stringsAsFactors = FALSE, row.names = NULL ) } }) out <- .remove_backticks_from_parameter_names(do.call(rbind, l)) out <- .remove_empty_columns_from_pars(out) .fix_random_effect_smooth(x, out) } #' @export clean_parameters.BFBayesFactor <- function(x, ...) { pars <- find_parameters(x, effects = "all", component = "all", flatten = FALSE) l <- lapply(names(pars), function(i) { eff <- if (grepl("random", i, fixed = TRUE)) { "random" } else { "fixed" } com <- if (grepl("extra", i, fixed = TRUE)) { "extra" } else { "conditional" } data.frame( Parameter = pars[[i]], Effects = eff, Component = com, Cleaned_Parameter = pars[[i]], stringsAsFactors = FALSE, row.names = NULL ) }) out <- .remove_backticks_from_parameter_names(do.call(rbind, l)) out <- .remove_empty_columns_from_pars(out) .fix_random_effect_smooth(x, out) } #' @export clean_parameters.wbm <- function(x, ...) { pars <- find_parameters(x, effects = "all", component = "all", flatten = FALSE) l <- lapply(names(pars), function(i) { com <- if (grepl("random", i, fixed = TRUE)) { "interactions" } else if (grepl("instruments", i, fixed = TRUE)) { "instruments" } else { "conditional" } fun <- if (grepl("smooth", i, fixed = TRUE)) { "smooth" } else { "" } data.frame( Parameter = pars[[i]], Effects = "fixed", Component = com, Group = "", Function = fun, Cleaned_Parameter = clean_names(pars[[i]]), stringsAsFactors = FALSE, row.names = NULL ) }) out <- .remove_backticks_from_parameter_names(do.call(rbind, l)) out <- .remove_empty_columns_from_pars(out) .fix_random_effect_smooth(x, out) } #' @export clean_parameters.wbgee <- clean_parameters.wbm #' @export clean_parameters.lavaan <- function(x, ...) { params <- get_parameters(x) data.frame( Parameter = params$Parameter, Component = params$Component, Group = "", Function = "", Cleaned_Parameter = params$Parameter, stringsAsFactors = FALSE, row.names = NULL ) } #' @export clean_parameters.blavaan <- function(x, ...) { params <- get_parameters.lavaan(x) data.frame( Parameter = params$Parameter, Component = params$Component, Group = "", Function = "", Cleaned_Parameter = params$Parameter, stringsAsFactors = FALSE, row.names = NULL ) } #' @export clean_parameters.brmsfit <- function(x, ...) { pars <- find_parameters(x, effects = "all", component = "all", flatten = FALSE) is_mv <- is_multivariate(pars) if (is_mv) { l <- do.call( rbind, lapply(names(pars), function(i) .get_stan_params(pars[[i]], response = i)) ) } else { l <- .get_stan_params(pars) } out <- do.call(rbind, l) out <- .remove_empty_columns_from_pars(.clean_brms_params(out, is_mv)) .fix_random_effect_smooth(x, out) } #' @export clean_parameters.stanreg <- function(x, ...) { pars <- find_parameters(x, effects = "all", component = "all", flatten = FALSE) l <- .get_stan_params(pars) out <- do.call(rbind, l) out <- .remove_empty_columns_from_pars(.clean_stanreg_params(out)) .fix_random_effect_smooth(x, out) } #' @export clean_parameters.stanmvreg <- function(x, ...) { pars <- find_parameters(x, effects = "all", component = "all", flatten = FALSE) l <- do.call( rbind, lapply(names(pars), function(i) .get_stan_params(pars[[i]], response = i)) ) out <- do.call(rbind, l) out <- .remove_empty_columns_from_pars(.clean_stanreg_params(out)) .fix_random_effect_smooth(x, out) } .get_stan_params <- function(pars, response = NA) { lapply(names(pars), function(i) { eff <- if (grepl("random", i, fixed = TRUE)) { "random" } else { "fixed" } com <- if (grepl("zero_inflated", i, fixed = TRUE)) { "zero_inflated" } else if (grepl("sigma", i, fixed = TRUE)) { "sigma" } else if (grepl("priors", i, fixed = TRUE)) { "priors" } else { "conditional" } fun <- if (grepl("smooth", i, fixed = TRUE)) { "smooth" } else { "" } data.frame( Parameter = pars[[i]], Effects = eff, Component = com, Group = "", Response = response, Function = fun, stringsAsFactors = FALSE, row.names = NULL ) }) } .clean_brms_params <- function(out, is_mv) { out$Cleaned_Parameter <- out$Parameter # for multivariate response models, remove responses from parameter names if (is_mv) { resp <- unique(out$Response) resp_pattern <- sprintf("_%s_(.*)", resp, resp) for (i in resp_pattern) { out$Cleaned_Parameter <- gsub(pattern = i, "_\\1", out$Cleaned_Parameter, perl = TRUE) } resp_pattern <- sprintf("__%s(.*)", resp, resp) for (i in resp_pattern) { out$Cleaned_Parameter <- gsub(pattern = i, "\\1", out$Cleaned_Parameter, perl = TRUE) } resp_pattern <- sprintf("__zi_%s(.*)", resp, resp) for (i in resp_pattern) { out$Cleaned_Parameter <- gsub(pattern = i, "\\1", out$Cleaned_Parameter, perl = TRUE) } resp_pattern <- sprintf("(sigma)(_%s)", resp, resp) for (i in resp_pattern) { out$Cleaned_Parameter <- gsub(pattern = i, "\\1", out$Cleaned_Parameter, perl = TRUE) } } smooth_function <- grepl(pattern = "(bs_|bs_zi_)", out$Cleaned_Parameter) if (any(smooth_function)) { out$Function[smooth_function] <- "smooth" } # clean fixed effects, conditional and zero-inflated out$Cleaned_Parameter <- gsub(pattern = "(b_|bs_|bsp_|bcs_)(?!zi_)(.*)", "\\2", out$Cleaned_Parameter, perl = TRUE) out$Cleaned_Parameter <- gsub(pattern = "(b_zi_|bs_zi_|bsp_zi_|bcs_zi_)(.*)", "\\2", out$Cleaned_Parameter, perl = TRUE) # correlation and sd cor_sd <- grepl("(sd_|cor_)(.*)", out$Cleaned_Parameter) if (any(cor_sd)) { out$Cleaned_Parameter[cor_sd] <- gsub("(sd_|cor_)(.*)__(.*)", "\\2_\\3", out$Cleaned_Parameter[cor_sd]) out$Group[cor_sd] <- "SD/Cor" } # extract group-names from random effects and clean random effects rand_eff <- grepl("r_(.*)\\.(.*)\\.", out$Cleaned_Parameter) if (any(rand_eff)) { r_pars <- gsub("r_(.*)\\.(.*)\\.", "\\1", out$Cleaned_Parameter[rand_eff]) r_grps <- gsub("r_(.*)\\.(.*)\\.", "\\2", out$Cleaned_Parameter[rand_eff]) r_pars <- gsub("__zi", "", r_pars) r_grps <- sprintf("%s: %s", r_grps, gsub("(.*)\\.(.*)", "\\1", r_pars)) out$Cleaned_Parameter[rand_eff] <- r_pars out$Group[rand_eff] <- r_grps } # clean remaining parameters priors <- grepl("^prior_", out$Cleaned_Parameter) if (length(priors)) { out$Cleaned_Parameter <- gsub("^prior_", "", out$Cleaned_Parameter) out$Component[priors] <- "priors" } simplex <- grepl("^simo_", out$Cleaned_Parameter) if (length(simplex)) { out$Cleaned_Parameter <- gsub("^simo_", "", out$Cleaned_Parameter) out$Component[simplex] <- "simplex" } smooth <- grepl("^sds_", out$Cleaned_Parameter) if (length(smooth)) { out$Cleaned_Parameter <- gsub("^sds_", "", out$Cleaned_Parameter) out$Component[smooth] <- "smooth_sd" out$Function[smooth] <- "smooth" } # fix intercept names intercepts <- which(out$Cleaned_Parameter == "Intercept") if (!.is_empty_object(intercepts)) { out$Cleaned_Parameter[intercepts] <- "(Intercept)" } interaction_terms <- which(grepl("\\.", out$Cleaned_Parameter)) if (length(interaction_terms)) { for (i in interaction_terms) { i_terms <- strsplit(out$Cleaned_Parameter[i], "\\.") find_i_terms <- sapply(i_terms, function(j) j %in% out$Cleaned_Parameter) if (all(find_i_terms)) { out$Cleaned_Parameter[i] <- gsub("\\.", ":", out$Cleaned_Parameter[i]) } } } out } .clean_stanreg_params <- function(out) { out$Cleaned_Parameter <- out$Parameter # extract group-names from random effects and clean random effects rand_intercepts <- grepl("^b\\[\\(Intercept\\)", out$Cleaned_Parameter) if (any(rand_intercepts)) { re_grp_level <- gsub("b\\[(.*) (.*):(.*)\\]", "\\2", out$Cleaned_Parameter[rand_intercepts]) out$Cleaned_Parameter[rand_intercepts] <- gsub( "b\\[\\(Intercept\\) (.*)\\]", "\\1", out$Cleaned_Parameter[rand_intercepts] ) out$Group[rand_intercepts] <- sprintf("Intercept: %s", re_grp_level) } # extract group-names from random effects and clean random effects rand_effects <- grepl("^b\\[", out$Cleaned_Parameter) if (any(rand_effects)) { re_grp_level <- gsub("b\\[(.*) (.*):(.*)\\]", "\\2", out$Cleaned_Parameter[rand_effects]) r_grps <- gsub("b\\[(.*) (.*)\\]", "\\1", out$Cleaned_Parameter[rand_effects]) r_pars <- gsub("b\\[(.*) (.*)\\]", "\\2", out$Cleaned_Parameter[rand_effects]) out$Group[rand_effects] <- sprintf("%s: %s", r_grps, re_grp_level) out$Cleaned_Parameter[rand_effects] <- r_pars } # clean remaining parameters smooth <- grepl("^smooth_sd\\[", out$Cleaned_Parameter) if (length(smooth)) { out$Cleaned_Parameter <- gsub("^smooth_sd\\[(.*)\\]", "\\1", out$Cleaned_Parameter) out$Component[smooth] <- "smooth_sd" out$Function[smooth] <- "smooth" } out } .remove_empty_columns_from_pars <- function(x) { if (.obj_has_name(x, "Response") && all(is.na(x$Response))) { pos <- which(colnames(x) == "Response") x <- x[, -pos] } if (.obj_has_name(x, "Group") && .is_empty_string(x$Group)) { pos <- which(colnames(x) == "Group") x <- x[, -pos] } if (.obj_has_name(x, "Function") && .is_empty_string(x$Function)) { pos <- which(colnames(x) == "Function") x <- x[, -pos] } x } # Fix random effects assignment for smooth terms # # This function checks whether smooth terms were used as random effects, # (i.e. s(term, by="re")) and if so, the value in the "effecs" column will # be set to "random". # .fix_random_effect_smooth <- function(x, out) { if ("Function" %in% colnames(out) && "smooth" %in% out$Function) { vars <- find_terms(x)$conditional vars <- gsub(" ", "", vars, fixed = TRUE) random_smooth_terms <- grepl("^s\\((.*)(bs=\"re\"+)\\)", x = vars) if (any(random_smooth_terms)) { random_term <- paste0( "s(", gsub("^s\\(([^,]*)(.*)(bs=\"re\"+)\\)", "\\1", vars[random_smooth_terms]), ")" ) out$Effects[which(out$Parameter == random_term)] <- "random" } } class(out) <- c("clean_parameters", class(out)) out } insight/R/print_color.R0000644000176200001440000000171113525034155014600 0ustar liggesusers#' @title Coloured console output #' @name print_color #' #' @description Convenient function that allows coloured output in the console. #' Mainly implemented to reduce package dependencies. #' #' @param text The text to print. #' @param color,colour Character vector, indicating the colour for printing. #' May be one of \code{"red"}, \code{"yellow"}, \code{"green"}, \code{"blue"}, #' \code{"violet"}, \code{"cyan"} or \code{"grey"}. Formatting is also possible #' with \code{"bold"} or \code{"italic"}. #' #' @details This function prints \code{text} directly to the console using #' \code{cat()}, so no string is returned. #' #' @return Nothing. #' #' @examples #' print_color("I'm blue dabedi dabedei", "blue") #' @export print_color <- function(text, color) { cat(.colour(colour = color, x = text)) } #' @rdname print_color #' @export print_colour <- function(text, colour) { print_color(color = colour, text = text) } insight/R/format_ci.R0000644000176200001440000000502013602361500014177 0ustar liggesusers#' Confidence/Credible Interval (CI) Formatting #' #' @param CI_low Lower CI bound. #' @param CI_high Upper CI bound. #' @param ci CI level in percentage. #' @param digits Number of significant digits. #' @param brackets Logical, if \code{TRUE} (default), values are encompassed in square brackets. #' @param width Minimum width of the returned string. If not \code{NULL} and \code{width} is larger than the string's length, leading whitespaces are added to the string. If \code{width="auto"}, width will be set to the length of the longest string. #' @param width_low,width_high Like \code{width}, but only applies to the lower or higher confidence interval value. This can be used when the values for the lower and upper CI are of very different length. #' #' @return A formatted string. #' @examples #' format_ci(1.20, 3.57, ci = 0.90) #' format_ci(1.20, 3.57, ci = NULL) #' format_ci(1.20, 3.57, ci = NULL, brackets = FALSE) #' format_ci(c(1.205645, 23.4), c(3.57, -1.35), ci = 0.90) #' format_ci(c(1.20, NA, NA), c(3.57, -1.35, NA), ci = 0.90) #' #' # automatic alignment of width, useful for printing multiple CIs in columns #' x <- format_ci(c(1.205, 23.4, 100.43), c(3.57, -13.35, 9.4)) #' cat(x, sep = "\n") #' #' x <- format_ci(c(1.205, 23.4, 100.43), c(3.57, -13.35, 9.4), width = "auto") #' cat(x, sep = "\n") #' @export format_ci <- function(CI_low, CI_high, ci = 0.95, digits = 2, brackets = TRUE, width = NULL, width_low = width, width_high = width) { if (!is.null(width) && width == "auto") { width_low <- max(unlist(lapply(stats::na.omit(round(CI_low, digits)), function(.i) nchar(as.character(.i))))) width_high <- max(unlist(lapply(stats::na.omit(round(CI_high, digits)), function(.i) nchar(as.character(.i))))) } if (!is.null(ci)) { ifelse(is.na(CI_low) & is.na(CI_high), "", paste0(ci * 100, "% CI ", .format_ci(CI_low, CI_high, digits = digits, brackets = brackets, width_low = width_low, width_high = width_high))) } else { ifelse(is.na(CI_low) & is.na(CI_high), "", .format_ci(CI_low, CI_high, digits = digits, brackets = brackets, width_low = width_low, width_high = width_high)) } } #' @keywords internal .format_ci <- function(CI_low, CI_high, digits = 2, brackets = TRUE, width_low = NULL, width_high = NULL) { paste0( ifelse(isTRUE(brackets), "[", ""), format_value(CI_low, digits = digits, missing = "NA", width = width_low), ", ", format_value(CI_high, digits = digits, missing = "NA", width = width_high), ifelse(isTRUE(brackets), "]", "") ) } insight/R/find_variables.R0000644000176200001440000000520213602434003015205 0ustar liggesusers#' @title Find names of all variables #' @name find_variables #' #' @description Returns a list with the names of all variables, including #' response value and random effects. #' #' @inheritParams find_predictors #' #' @note The difference to \code{\link{find_terms}} is that \code{find_variables()} #' returns each variable name only once, while \code{find_terms()} may return a #' variable multiple times in case of transformations or when arithmetic expressions #' were used in the formula. #' #' @return A list with (depending on the model) following elements (character #' vectors): #' \itemize{ #' \item \code{response}, the name of the response variable #' \item \code{conditional}, the names of the predictor variables from the \emph{conditional} model (as opposed to the zero-inflated part of a model) #' \item \code{random}, the names of the random effects (grouping factors) #' \item \code{zero_inflated}, the names of the predictor variables from the \emph{zero-inflated} part of the model #' \item \code{zero_inflated_random}, the names of the random effects (grouping factors) #' \item \code{dispersion}, the name of the dispersion terms #' \item \code{instruments}, the names of instrumental variables #' } #' #' @examples #' library(lme4) #' data(cbpp) #' data(sleepstudy) #' # some data preparation... #' cbpp$trials <- cbpp$size - cbpp$incidence #' sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) #' sleepstudy$mysubgrp <- NA #' for (i in 1:5) { #' filter_group <- sleepstudy$mygrp == i #' sleepstudy$mysubgrp[filter_group] <- #' sample(1:30, size = sum(filter_group), replace = TRUE) #' } #' #' m1 <- glmer( #' cbind(incidence, size - incidence) ~ period + (1 | herd), #' data = cbpp, #' family = binomial #' ) #' find_variables(m1) #' #' m2 <- lmer( #' Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), #' data = sleepstudy #' ) #' find_variables(m2) #' find_variables(m2, flatten = TRUE) #' @export find_variables <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "instruments", "smooth_terms"), flatten = FALSE) { effects <- match.arg(effects) component <- match.arg(component) if (component %in% c("all", "conditional")) { resp <- find_response(x, combine = FALSE) } else { resp <- NULL } pr <- find_predictors(x, effects = effects, component = component, flatten = flatten) if (flatten) { unique(c(resp, pr)) } else if (is.null(resp)) { pr } else { c(list(response = resp), pr) } } insight/R/get_weights.R0000644000176200001440000000276013554405404014565 0ustar liggesusers#' @title Get the values from model weights #' @name get_weights #' #' @description Returns weighting variable of a model. #' #' @param x A fitted model. #' @param ... Currently not used. #' #' @return The weighting variable, or \code{NULL} if no weights were specified. #' #' @examples #' data(mtcars) #' mtcars$weight <- rnorm(nrow(mtcars), 1, .3) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars, weights = weight) #' get_weights(m) #' @export get_weights <- function(x, ...) { UseMethod("get_weights") } #' @export get_weights.default <- function(x, ...) { w <- NULL tryCatch( { w <- stats::weights(x) }, error = function(x) { NULL }, warning = function(x) { NULL }, finally = function(x) { NULL } ) if (is.null(w)) { tryCatch( { w <- stats::model.frame(x)[["(weights)"]] }, error = function(x) { NULL }, warning = function(x) { NULL }, finally = function(x) { NULL } ) } if (is.null(w)) { tryCatch( { w <- .get_data_from_env(x)[[find_weights(x)]] }, error = function(x) { NULL }, warning = function(x) { NULL }, finally = function(x) { NULL } ) } w } #' @export get_weights.brmsfit <- function(x, ...) { w <- find_weights(x) if (!is.null(w)) { get_data(x)[[w]] } } insight/R/find_statistic.R0000644000176200001440000001456713613304073015267 0ustar liggesusers#' @title Find statistic for model #' @description Returns the statistic for a regression model (\emph{t}-statistic, #' \emph{z}-statistic, etc.). #' @name find_statistic #' #' @description Small helper that checks if a model is a regression model #' object and return the statistic used. #' #' @param x An object. #' @param ... Currently not used. #' #' @return A character describing the type of statistic. If there is no #' statistic available with a distribution, \code{NULL} will be returned. #' #' @examples #' # regression model object #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' find_statistic(m) #' @export find_statistic <- function(x, ...) { # model object check -------------------------------------------------------- # check if the object is a model object; if so, quit early if (!isTRUE(is_model(x))) { stop(message("The entered object is not a model object."), call. = FALSE) } # t-value objects ---------------------------------------------------------- t.mods <- c( "BBreg", "BBmm", "bcplm", "biglm", "bglmerMod", "blmerMod", "cch", "censReg", "coeftest", "complmrob", "cpglm", "cpglmm", "crq", "drc", "feis", "felm", "gamlss", "garch", "glmmPQL", "gls", "gmm", "ivreg", "iv_robust", "lm", "lm_robust", "lm.beta", "lme", "lmerMod", "lmRob", "lmrob", "maxLik", "mixed", "mlm", "multinom", "nlmerMod", "nlrq", "nls", "orcutt", "polr", "rlm", "rlmerMod", "rq", "rqss", "speedlm", "svyglm", "svyolr", "truncreg", "wbm", "wblm", "zcpglm" ) # z-value objects ---------------------------------------------------------- z.mods <- c( "aareg", "betareg", "bracl", "brglm", "brglmFit", "brmultinom", "cglm", "clm", "clm2", "clmm", "clmm2", "coxme", "coxph", "crch", "DirichletRegModel", "ergm", "feglm", "fixest", "flexsurvreg", "gee", "glimML", "glmmadmb", "glmmLasso", "glmmTMB", "glmx", "gmnl", "hurdle", "lavaan", "loggammacenslmrob", "LORgee", "lrm", "mixor", "MixMod", "mjoint", "mle2", "mlogit", "mclogit", "mmclogit", "mvmeta", "negbin", "nlreg", "objectiveML", "psm", "rma", "rma.uni", "sem", "slm", "survreg", "tobit", "vglm", "wbgee", "zeroinfl", "zerotrunc" ) # F-value objects ---------------------------------------------------------- f.mods <- c( "Anova.mlm", "aov", "aovlist", "anova", "Gam", "manova" ) # chi-squared value objects ------------------------------------------------ chi.mods <- c( "geeglm", "logistf", "MANOVA", "RM", "vgam" ) # mixed bag ---------------------------------------------------------------- # models for which there is no clear t-or z-statistic # which statistic to use will be decided based on the family used g.mods <- c( "bigglm", "cgam", "cgamm", "gam", "glm", "glmc", "glmerMod", "glmRob", "glmrob", "speedglm" ) # t-statistic g.t.mods <- c( "quasi", "gaussian", "quasibinomial", "quasipoisson", "Gamma", "inverse.gaussian" ) # z-statistic g.z.mods <- c( "binomial", "poisson" ) # pattern finding ---------------------------------------------------------- unclear.mods <- c("plm") # no statistic ------------------------------------------------------------- unsupported.mods <- c( "BFBayesFactor", "brmsfit", "stanreg", "stanmvreg", "gbm", "list", "MCMCglmm", "survfit" ) # edge cases --------------------------------------------------------------- # tweedie-check needs to come first, because glm can also have tweedie # family, so this exception needs to be caught before checking for g.mods tryCatch( { suppressWarnings( if (!is_multivariate(x) && model_info(x)$is_tweedie) { return("t-statistic") } ) }, error = function(e) {} ) # statistic check ----------------------------------------------------------- if (class(x)[[1]] %in% unsupported.mods) { return(NULL) } if (class(x)[[1]] %in% t.mods) { return("t-statistic") } if (class(x)[[1]] %in% z.mods) { return("z-statistic") } if (class(x)[[1]] %in% f.mods) { return("F-statistic") } if (class(x)[[1]] %in% chi.mods) { return("chi-squared statistic") } if (class(x)[[1]] %in% g.mods) { if (model_info(x)$family %in% g.t.mods) { return("t-statistic") } else { return("z-statistic") } } # ambiguous cases ----------------------------------------------------------- if (class(x)[[1]] %in% unclear.mods) { col_names <- colnames(as.data.frame(summary(x)$coefficients)) t_names <- c( "t", "t-value", "t value", "t.value", "Pr(>|t|)" ) z_names <- c( "z", "z-value", "z value", "z.value", "Pr(>|z|)", "Pr(>|Z|)", "Naive z", "Robust z", "san.z", "Wald Z" ) f_names <- c("F", "F-value", "F value", "F.value") chi_names <- c("Chisq", "chi-sq", "chi.sq", "Wald", "W", "Pr(>|W|)") if (length(colnames(as.data.frame(summary(x)$coefficients))) == 0L) { return(NULL) } if (any(t_names %in% col_names)) { return("t-statistic") } if (any(z_names %in% col_names)) { return("z-statistic") } if (any(f_names %in% col_names)) { return("F-statistic") } if (any(chi_names %in% col_names)) { return("chi-squared statistic") } } } insight/R/find_terms.R0000644000176200001440000000632313554630176014413 0ustar liggesusers#' @title Find all model terms #' @name find_terms #' #' @description Returns a list with the names of all terms, including #' response value and random effects, "as is". This means, on-the-fly #' tranformations or arithmetic expressions like \code{log()}, \code{I()}, #' \code{as.factor()} etc. are preserved. #' #' @inheritParams find_formula #' @inheritParams find_predictors #' #' @return A list with (depending on the model) following elements (character #' vectors): #' \itemize{ #' \item \code{response}, the name of the response variable #' \item \code{conditional}, the names of the predictor variables from the \emph{conditional} model (as opposed to the zero-inflated part of a model) #' \item \code{random}, the names of the random effects (grouping factors) #' \item \code{zero_inflated}, the names of the predictor variables from the \emph{zero-inflated} part of the model #' \item \code{zero_inflated_random}, the names of the random effects (grouping factors) #' \item \code{dispersion}, the name of the dispersion terms #' \item \code{instruments}, the names of instrumental variables #' } #' #' @note The difference to \code{\link{find_variables}} is that \code{find_terms()} #' may return a variable multiple times in case of multiple transformations #' (see examples below), while \code{find_variables()} returns each variable #' name only once. #' #' @examples #' library(lme4) #' data(sleepstudy) #' m <- lmer( #' log(Reaction) ~ Days + I(Days^2) + (1 + Days + exp(Days) | Subject), #' data = sleepstudy #' ) #' #' find_terms(m) #' @export find_terms <- function(x, flatten = FALSE, ...) { f <- find_formula(x) if (is_multivariate(f)) { l <- lapply(f, .get_variables_list) } else { l <- .get_variables_list(f) } if (flatten) { unique(unlist(l)) } else { l } } .get_variables_list <- function(f) { f$response <- .safe_deparse(f$conditional[[2L]]) f$conditional <- .safe_deparse(f$conditional[[3L]]) f <- lapply(f, function(.x) { if (is.list(.x)) { .x <- sapply(.x, .formula_to_string) } else { if (!is.character(.x)) .x <- .safe_deparse(.x) } .x }) f <- lapply(f, function(.x) { f_parts <- gsub("~", "", .trim(unlist(strsplit(split = "[\\*\\+\\:\\-\\|](?![^(]*\\))", x = .x, perl = TRUE)))) # if user has used namespace in formula-functions, these are returned # as empty elements. rempove those here if (any(nchar(f_parts) == 0)) { f_parts <- f_parts[-which(nchar(f_parts) == 0)] } .remove_backticks_from_string(unique(f_parts)) }) # remove "1" and "0" from variables in random effects if (.obj_has_name(f, "random")) { pos <- which(f$random %in% c("1", "0")) if (length(pos)) f$random <- f$random[-pos] } if (.obj_has_name(f, "zero_inflated_random")) { pos <- which(f$zero_inflated_random %in% c("1", "0")) if (length(pos)) f$zero_inflated_random <- f$zero_inflated_random[-pos] } # reorder, so response is first .compact_list(f[c(length(f), 1:(length(f) - 1))]) } .formula_to_string <- function(f) { if (!is.character(f)) f <- .safe_deparse(f) f } insight/R/get_variances.R0000644000176200001440000002310513602213234015052 0ustar liggesusers#' @title Get variance components from random effects models #' @name get_variance #' #' @description This function extracts the different variance components of a #' mixed model and returns the result as list. Functions like #' \code{get_variance_residual(x)} or \code{get_variance_fixed(x)} are shortcuts #' for \code{get_variance(x, component = "residual")} etc. #' #' @param x A mixed effects model. #' @param component Character value, indicating the variance component that should #' be returned. By default, all variance components are returned. The #' distribution-specific (\code{"distribution"}) and residual (\code{"residual"}) #' variance are the most computational intensive components, and hence may #' take a few seconds to calculate. #' @param verbose Toggle off warnings. #' @param ... Currently not used. #' #' @return A list with following elements: #' \itemize{ #' \item \code{var.fixed}, variance attributable to the fixed effects #' \item \code{var.random}, (mean) variance of random effects #' \item \code{var.residual}, residual variance (sum of dispersion and distribution) #' \item \code{var.distribution}, distribution-specific variance #' \item \code{var.dispersion}, variance due to additive dispersion #' \item \code{var.intercept}, the random-intercept-variance, or between-subject-variance (\ifelse{html}{\out{τ00}}{\eqn{\tau_{00}}}) #' \item \code{var.slope}, the random-slope-variance (\ifelse{html}{\out{τ11}}{\eqn{\tau_{11}}}) #' \item \code{cor.slope_intercept}, the random-slope-intercept-correlation (\ifelse{html}{\out{ρ01}}{\eqn{\rho_{01}}}) #' } #' #' @details This function returns different variance components from mixed models, #' which are needed, for instance, to calculate r-squared measures or the #' intraclass-correlation coefficient (ICC). #' \subsection{Fixed effects variance}{ #' The fixed effects variance, \ifelse{html}{\out{σ2f}}{\eqn{\sigma^2_f}}, #' is the variance of the matrix-multiplication \ifelse{html}{\out{β∗X}}{\eqn{\beta*X}} #' (parameter vector by model matrix). #' } #' \subsection{Random effects variance}{ #' The random effect variance, \ifelse{html}{\out{σ2i}}{\eqn{\sigma^2_i}}, #' represents the \emph{mean} random effect variance of the model. Since #' this variance reflect the "average" random effects variance for mixed #' models, it is also appropriate for models with more complex random #' effects structures, like random slopes or nested random effects. #' Details can be found in \cite{Johnson 2014}, in particular equation 10. #' For simple random-intercept models, the random effects variance equals #' the random-intercept variance. #' } #' \subsection{Distribution-specific variance}{ #' The distribution-specific variance, #' \ifelse{html}{\out{σ2d}}{\eqn{\sigma^2_d}}, #' depends on the model family. For Gaussian models, it is #' \ifelse{html}{\out{σ2}}{\eqn{\sigma^2}} (i.e. #' \code{sigma(model)^2}). For models with binary outcome, it is #' \eqn{\pi^2 / 3} for logit-link and \code{1} for probit-link. For all #' other models, the distribution-specific variance is based on lognormal #' approximation, \eqn{log(1 + var(x) / \mu^2)} (see \cite{Nakagawa et al. 2017}). #' The expected variance of a zero-inflated model is computed according #' to \cite{Zuur et al. 2012, p277}. #' } #' \subsection{Variance for the additive overdispersion term}{ #' The variance for the additive overdispersion term, #' \ifelse{html}{\out{σ2e}}{\eqn{\sigma^2_e}}, #' represents \dQuote{the excess variation relative to what is expected #' from a certain distribution} (Nakagawa et al. 2017). In (most? many?) #' cases, this will be \code{0}. #' } #' \subsection{Residual variance}{ #' The residual variance, \ifelse{html}{\out{σ2ε}}{\eqn{\sigma^2_\epsilon}}, #' is simply \ifelse{html}{\out{σ2d + σ2e}}{\eqn{\sigma^2_d + \sigma^2_e}}. #' } #' \subsection{Random intercept variance}{ #' The random intercept variance, or \emph{between-subject} variance #' (\ifelse{html}{\out{τ00}}{\eqn{\tau_{00}}}), #' is obtained from \code{VarCorr()}. It indicates how much groups #' or subjects differ from each other, while the residual variance #' \ifelse{html}{\out{σ2ε}}{\eqn{\sigma^2_\epsilon}} #' indicates the \emph{within-subject variance}. #' } #' \subsection{Random slope variance}{ #' The random slope variance (\ifelse{html}{\out{τ11}}{\eqn{\tau_{11}}}) #' is obtained from \code{VarCorr()}. This measure is only available #' for mixed models with random slopes. #' } #' \subsection{Random slope-intercept correlation}{ #' The random slope-intercept correlation #' (\ifelse{html}{\out{ρ01}}{\eqn{\rho_{01}}}) #' is obtained from \code{VarCorr()}. This measure is only available #' for mixed models with random intercepts and slopes. #' } #' #' @note This function supports models of class \code{merMod} (including models #' from \pkg{blme}), \code{clmm}, \code{cpglmm}, \code{glmmadmb}, \code{glmmTMB}, #' \code{MixMod}, \code{lme}, \code{mixed}, \code{rlmerMod}, \code{stanreg} or #' \code{wbm}. Support for objects of class \code{MixMod} (\pkg{GLMMadaptiv}) or #' \code{lme} (\pkg{nlme}) is experimental and may not work for all models. #' #' @references \itemize{ #' \item Johnson, P. C. D. (2014). Extension of Nakagawa & Schielzeth’s R2 GLMM to random slopes models. Methods in Ecology and Evolution, 5(9), 944–946. \doi{10.1111/2041-210X.12225} #' \item Nakagawa, S., Johnson, P. C. D., & Schielzeth, H. (2017). The coefficient of determination R2 and intra-class correlation coefficient from generalized linear mixed-effects models revisited and expanded. Journal of The Royal Society Interface, 14(134), 20170213. \doi{10.1098/rsif.2017.0213} #' \item Zuur, A. F., Savel'ev, A. A., & Ieno, E. N. (2012). Zero inflated models and generalized linear mixed models with R. Newburgh, United Kingdom: Highland Statistics. #' } #' #' @examples #' \dontrun{ #' library(lme4) #' data(sleepstudy) #' m <- lmer(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy) #' #' get_variance(m) #' get_variance_fixed(m) #' get_variance_residual(m) #' } #' @export get_variance <- function(x, component = c("all", "fixed", "random", "residual", "distribution", "dispersion", "intercept", "slope", "rho01"), verbose = TRUE, ...) { UseMethod("get_variance") } #' @export get_variance.default <- function(x, component = c("all", "fixed", "random", "residual", "distribution", "dispersion", "intercept", "slope", "rho01"), verbose = TRUE, ...) { warning(sprintf("Objects of class `%s` are not supported.", class(x)[1])) NULL } #' @export get_variance.merMod <- function(x, component = c("all", "fixed", "random", "residual", "distribution", "dispersion", "intercept", "slope", "rho01"), verbose = TRUE, ...) { component <- match.arg(component) tryCatch( { .compute_variances(x, component = component, name_fun = "get_variance", name_full = "random effect variances", verbose = verbose) }, error = function(e) { NULL } ) } #' @export get_variance.rlmerMod <- get_variance.merMod #' @export get_variance.cpglmm <- get_variance.merMod #' @export get_variance.glmmTMB <- get_variance.merMod #' @export get_variance.glmmadmb <- get_variance.merMod #' @export get_variance.stanreg <- get_variance.merMod #' @export get_variance.MixMod <- get_variance.merMod #' @export get_variance.clmm <- get_variance.merMod #' @export get_variance.wbm <- get_variance.merMod #' @export get_variance.wblm <- get_variance.merMod #' @export get_variance.lme <- get_variance.merMod #' @export get_variance.mixed <- function(x, component = c("all", "fixed", "random", "residual", "distribution", "dispersion", "intercept", "slope", "rho01"), verbose = TRUE, ...) { component <- match.arg(component) .compute_variances(x$full_model, component = component, name_fun = "get_variance", name_full = "random effect variances", verbose = verbose) } #' @rdname get_variance #' @export get_variance_residual <- function(x, ...) { unlist(get_variance(x, component = "residual", ...)) } #' @rdname get_variance #' @export get_variance_fixed <- function(x, ...) { unlist(get_variance(x, component = "fixed", ...)) } #' @rdname get_variance #' @export get_variance_random <- function(x, ...) { unlist(get_variance(x, component = "random", ...)) } #' @rdname get_variance #' @export get_variance_distribution <- function(x, ...) { unlist(get_variance(x, component = "distribution", ...)) } #' @rdname get_variance #' @export get_variance_dispersion <- function(x, ...) { unlist(get_variance(x, component = "dispersion", ...)) } #' @rdname get_variance #' @export get_variance_intercept <- function(x, ...) { unlist(get_variance(x, component = "intercept", ...)) } #' @rdname get_variance #' @export get_variance_slope <- function(x, ...) { unlist(get_variance(x, component = "slope", ...)) } #' @rdname get_variance #' @export get_correlation_slope_intercept <- function(x, ...) { unlist(get_variance(x, component = "rho01", ...)) } insight/R/format_value.R0000644000176200001440000001000613615554702014734 0ustar liggesusers#' Numeric Values Formatting #' #' @param x Numeric value. #' @param digits Number of significant digits. #' @param protect_integers Should integers be kept as integers (i.e., without decimals)? #' @param missing Value by which \code{NA} values are replaced. By default, an empty string (i.e. \code{""}) is returned for \code{NA}. #' @param width Minimum width of the returned string. If not \code{NULL} and \code{width} is larger than the string's length, leading whitespaces are added to the string. #' @param as_percent Logical, if \code{TRUE}, value is formatted as percentage value. #' @param ... Arguments passed to or from other methods. #' #' #' @return A formatted string. #' #' @examples #' format_value(1.20) #' format_value(1.2) #' format_value(1.2012313) #' format_value(c(0.0045, 234, -23)) #' format_value(c(0.0045, .12, .34)) #' format_value(c(0.0045, .12, .34), as_percent = TRUE) #' #' format_value(as.factor(c("A", "B", "A"))) #' format_value(iris$Species) #' #' format_value(3) #' format_value(3, protect_integers = TRUE) #' #' format_value(iris) #' @export format_value <- function(x, digits = 2, protect_integers = FALSE, missing = "", width = NULL, as_percent = FALSE, ...) { UseMethod("format_value") } #' @export format_value.data.frame <- function(x, digits = 2, protect_integers = FALSE, missing = "", width = NULL, as_percent = FALSE, ...) { as.data.frame(sapply(x, format_value, digits = digits, protect_integers = protect_integers, missing = missing, width = width, as_percent = as_percent, simplify = FALSE)) } #' @export format_value.numeric <- function(x, digits = 2, protect_integers = FALSE, missing = "", width = NULL, as_percent = FALSE, ...) { if (protect_integers) { out <- .format_value_unless_integer(x, digits = digits, .missing = missing, .width = width, .as_percent = as_percent, ...) } else { out <- .format_value(x, digits = digits, .missing = missing, .width = width, .as_percent = as_percent, ...) } # Deal with negative zeros if (!is.factor(x)) { whitespace <- ifelse(is.null(width), "", " ") out[out == "-0"] <- paste0(whitespace, "0") out[out == "-0.0"] <- paste0(whitespace, "0.0") out[out == "-0.00"] <- paste0(whitespace, "0.00") out[out == "-0.000"] <- paste0(whitespace, "0.000") out[out == "-0.0000"] <- paste0(whitespace, "0.0000") } out } #' @export format_value.double <- format_value.numeric #' @export format_value.character <- format_value.numeric #' @export format_value.factor <- format_value.numeric #' @export format_value.logical <- format_value.numeric #' @importFrom stats na.omit .format_value_unless_integer <- function(x, digits = 2, .missing = "", .width = NULL, .as_percent = FALSE, ...) { if (is.numeric(x) && !all(.is.int(stats::na.omit(x)))) { .format_value(x, digits = digits, .missing = .missing, .width = .width, .as_percent = .as_percent) } else if (anyNA(x)) { .convert_missing(x, .missing) } else { as.character(x) } } .format_value <- function(x, digits = 2, .missing = "", .width = NULL, .as_percent = FALSE, ...) { if (is.numeric(x)) { if (isTRUE(.as_percent)) { x <- ifelse(is.na(x), .missing, ifelse(x > 1e+5, sprintf("%.5e", x), sprintf("%.*f%%", digits, 100 * x))) } else { x <- ifelse(is.na(x), .missing, ifelse(x > 1e+5, sprintf("%.5e", x), sprintf("%.*f", digits, x))) } } else if (anyNA(x)) { x <- .convert_missing(x, .missing) } if (!is.null(.width)) { x <- format(x, justify = "right", width = .width) } x } .convert_missing <- function(x, .missing) { if (length(x) == 1) { return(as.character(.missing)) } missings <- which(is.na(x)) x[missings] <- as.character(.missing) x[!missings] <- as.character(x) x } .is.int <- function(x) { tryCatch( expr = { ifelse(is.infinite(x), FALSE, x %% 1 == 0) }, warning = function(w) { is.integer(x) }, error = function(e) { FALSE } ) } insight/R/get_priors.R0000644000176200001440000002035513615512325014430 0ustar liggesusers#' @title Get summary of priors used for a model #' @name get_priors #' #' @description Provides a summary of the prior distributions used #' for the parameters in a given model. #' #' @param x A Bayesian model. #' @param ... Currently not used. #' #' @return A data frame with a summary of the prior distributions used #' for the parameters in a given model. #' #' @examples #' \dontrun{ #' library(rstanarm) #' model <- stan_glm(Sepal.Width ~ Species * Petal.Length, data = iris) #' get_priors(model) #' } #' #' @export get_priors <- function(x, ...) { UseMethod("get_priors") } #' @export get_priors.stanreg <- function(x, ...) { if (!requireNamespace("rstanarm", quietly = TRUE)) { stop("To use this function, please install package 'rstanarm'.") } ps <- rstanarm::prior_summary(x) l <- .compact_list(lapply(ps[c("prior_intercept", "prior")], function(.x) { if (!is.null(.x)) { # quick and dirty fix for flat priors # else, .compact_list() will set this item as "NA" if (is.na(.x$dist)) { .x$dist <- "uniform" .x$location <- 0 .x$scale <- 0 .x$adjusted_scale <- 0 } do.call(cbind, .x) } })) if (length(l) > 1) { prior_info <- Reduce(function(x, y) merge(x, y, all = TRUE, sort = FALSE), l) } else { cn <- colnames(l[[1]]) prior_info <- as.data.frame(l) colnames(prior_info) <- cn } # fix parameters for flat priors here flat <- which(prior_info$dist == "uniform") if (length(flat) > 0) { prior_info$location[flat] <- NA prior_info$scale[flat] <- NA prior_info$adjusted_scale[flat] <- NA } prior_info$parameter <- find_parameters(x)$conditional prior_info <- prior_info[, intersect(c("parameter", "dist", "location", "scale", "adjusted_scale"), colnames(prior_info))] colnames(prior_info) <- gsub("dist", "distribution", colnames(prior_info)) colnames(prior_info) <- gsub("df", "DoF", colnames(prior_info)) priors <- as.data.frame(lapply(prior_info, function(x) { if (.is_numeric_character(x)) { as.numeric(as.character(x)) } else { as.character(x) } }), stringsAsFactors = FALSE) string <- strsplit(names(priors), "_", fixed = TRUE) string <- lapply(string, .capitalize) names(priors) <- unlist(lapply(string, paste0, collapse = "_")) priors } #' @export get_priors.stanmvreg <- function(x, ...) { if (!requireNamespace("rstanarm", quietly = TRUE)) { stop("To use this function, please install package 'rstanarm'.") } ps <- rstanarm::prior_summary(x) l <- .compact_list(lapply(ps[c("prior_intercept", "prior")], function(.x) { lapply(.x, function(.i) { if (!is.null(.i)) do.call(cbind, .i) }) })) prior_info <- do.call(rbind, lapply(l, function(.x) { if (length(.x) > 1) { out <- lapply(names(.x), function(.i) { if (!("adjusted_scale" %in% colnames(.x[[.i]]))) .x[[.i]] <- cbind(.x[[.i]], adjusted_scale = NA) data.frame(.x[[.i]], response = .i, stringsAsFactors = FALSE) }) do.call(rbind, out) } else { cn <- colnames(.x[[1]]) prior_info <- as.data.frame(.x) colnames(prior_info) <- cn } })) # find parameter names params <- unlist(lapply(find_parameters(x), function(.i) .i$conditional)) params <- params[c(which(params == "(Intercept)"), which(params != "(Intercept)"))] prior_info$parameter <- params prior_info <- prior_info[, intersect(c("parameter", "dist", "location", "scale", "adjusted_scale", "response"), colnames(prior_info))] colnames(prior_info) <- gsub("dist", "distribution", colnames(prior_info)) colnames(prior_info) <- gsub("df", "DoF", colnames(prior_info)) priors <- as.data.frame(lapply(prior_info, function(x) { if (.is_numeric_character(x)) { as.numeric(as.character(x)) } else { as.character(x) } }), stringsAsFactors = FALSE) string <- strsplit(names(priors), "_", fixed = TRUE) string <- lapply(string, .capitalize) names(priors) <- unlist(lapply(string, paste0, collapse = "_")) # minor fixes priors$Parameter <- sprintf("%s|%s", priors$Response, priors$Parameter) priors } #' @export get_priors.brmsfit <- function(x, ...) { ## TODO needs testing for edge cases - check if "coef"-column is # always empty for intercept-class x$prior$coef[x$prior$class == "Intercept"] <- "(Intercept)" # get default prior for all parameters, if defined def_prior_b <- which(x$prior$prior != "" & x$prior$class == "b" & x$prior$coef == "") # check which parameters have a default prior need_def_prior <- which(x$prior$prior == "" & x$prior$class == "b" & x$prior$coef != "") if (!.is_empty_object(def_prior_b) && !.is_empty_object(need_def_prior)) { x$prior$prior[need_def_prior] <- x$prior$prior[def_prior_b] } # get default prior for all parameters, if defined def_prior_intercept <- which(x$prior$prior != "" & x$prior$class == "Intercept" & x$prior$coef == "") # check which parameters have a default prior need_def_prior <- which(x$prior$prior == "" & x$prior$class == "Intercept" & x$prior$coef != "") if (!.is_empty_object(def_prior_intercept) && !.is_empty_object(need_def_prior)) { x$prior$prior[need_def_prior] <- x$prior$prior[def_prior_intercept] } prior_info <- x$prior[x$prior$coef != "" & x$prior$class %in% c("b", "(Intercept)"), ] # find additional components, avoid duplicated coef-names components <- prior_info$dpar != "" prior_info$dpar[components] <- paste0(prior_info$dpar[components], "_") prior_info$coef <- paste0(prior_info$dpar, prior_info$coef) prior_info$Distribution <- gsub("(.*)\\(.*", "\\1", prior_info$prior) prior_info$Location <- gsub("(.*)\\((.*)\\,(.*)", "\\2", prior_info$prior) prior_info$Scale <- gsub("(.*)\\,(.*)\\)(.*)", "\\2", prior_info$prior) prior_info$Parameter <- prior_info$coef prior_info <- prior_info[, c("Parameter", "Distribution", "Location", "Scale")] pinfo <- as.data.frame(lapply(prior_info, function(x) { if (.is_numeric_character(x)) { as.numeric(as.character(x)) } else { as.character(x) } }), stringsAsFactors = FALSE) if (.is_empty_string(pinfo$Distribution)) { print_color("Model was fitted with uninformative (flat) priors!\n", "red") pinfo$Distribution <- "uniform" pinfo$Location <- 0 pinfo$Scale <- NA } pinfo } #' @importFrom utils tail #' @export get_priors.BFBayesFactor <- function(x, ...) { prior <- .compact_list(utils::tail(x@numerator, 1)[[1]]@prior[[1]]) switch( .classify_BFBayesFactor(x), "correlation" = names(prior) <- "rho", "ttest" = names(prior) <- "Difference" ) data.frame( Parameter = names(prior), Distribution = "cauchy", Location = 0, Scale = unlist(prior), stringsAsFactors = FALSE, row.names = NULL ) } #' @export get_priors.blavaan <- function(x, ...) { if (!requireNamespace("lavaan", quietly = TRUE)) { stop("Package 'lavaan' required for this function to work. Please install it.") } PE <- lavaan::parameterEstimates( x, se = FALSE, ci = FALSE, remove.eq = FALSE, remove.system.eq = TRUE, remove.ineq = FALSE, remove.def = FALSE, add.attributes = TRUE ) if (!("group" %in% names(PE))) PE$group <- 1 newpt <- x@ParTable pte2 <- which(newpt$free > 0) relevant_rows <- match( with(newpt, paste(lhs[pte2], op[pte2], rhs[pte2], group[pte2], sep = "")), paste(PE$lhs, PE$op, PE$rhs, PE$group, sep = "") ) # Priors priors <- rep(NA, nrow(PE)) priors[relevant_rows] <- newpt$prior[pte2] priors[is.na(PE$prior)] <- NA stats::na.omit(data.frame( Parameter = paste(PE$lhs, PE$op, PE$rhs, sep = ""), Distribution = gsub("(.*)\\((.*)", "\\1", priors), Location = as.numeric(gsub("(.*)\\((.*)\\,(.*)\\)(.*)", "\\2", priors)), Scale = as.numeric(gsub("(.*)\\((.*)\\,(.*)\\)(.*)", "\\3", priors)), stringsAsFactors = FALSE )) } #' @importFrom stats na.omit .is_numeric_character <- function(x) { (is.character(x) && !anyNA(suppressWarnings(as.numeric(stats::na.omit(x))))) || (is.factor(x) && !anyNA(suppressWarnings(as.numeric(levels(x))))) } insight/R/format_table.R0000644000176200001440000000360313531534744014715 0ustar liggesusers#' Dataframe and Tables Pretty Formatting #' #' @param x A data frame. #' @param sep Column separator. #' @param header Header separator. Can be \code{NULL}. #' @inheritParams format_value #' #' @return A data frame in character format. #' @examples #' cat(format_table(iris)) #' cat(format_table(iris, sep = " ", header = "*", digits = 1)) #' @export format_table <- function(x, sep = " | ", header = "-", digits = 2, protect_integers = TRUE, missing = "", width = NULL) { df <- x # round all numerics col_names <- names(df) df <- as.data.frame(sapply(df, function(i) { if (is.numeric(i)) { format_value(i, digits = digits, protect_integers = protect_integers, missing = missing, width = width) } else { i } }, simplify = FALSE), stringsAsFactors = FALSE) # Convert to character df <- as.data.frame(sapply(df, as.character, simplify = FALSE), stringsAsFactors = FALSE) names(df) <- col_names df[is.na(df)] <- as.character(missing) # Add colnames as row df <- rbind(colnames(df), df) # Align aligned <- format(df, justify = "right") # Centre first row first_row <- as.character(aligned[1, ]) for (i in 1:length(first_row)) { aligned[1, i] <- format(trimws(first_row[i]), width = nchar(first_row[i]), justify = "right") } final <- as.matrix(aligned) # left-align first column (if a character or a factor) if (!is.numeric(x[, 1])) { final[, 1] <- format(trimws(final[, 1]), justify = "left") } # Transform to character rows <- c() for (row in 1:nrow(final)) { final_row <- paste0(final[row, ], collapse = sep) rows <- paste0(rows, final_row, sep = "\n") # First row separation if (row == 1) { if (!is.null(header)) { rows <- paste0(rows, paste0(rep_len(header, nchar(final_row)), collapse = ""), sep = "\n") } } } rows } insight/R/has_intercept.R0000644000176200001440000000160513524331052015073 0ustar liggesusers#' @title Checks if model has an intercept #' @name has_intercept #' #' @description Checks if model has an intercept. #' #' @param x A model object. #' #' @return \code{TRUE} if \code{x} has an intercept, \code{FALSE} otherwise. #' #' @examples #' model <- lm(mpg ~ 0 + gear, data = mtcars) #' has_intercept(model) #' #' model <- lm(mpg ~ gear, data = mtcars) #' has_intercept(model) #' #' library(lme4) #' model <- lmer(Reaction ~ 0 + Days + (Days | Subject), data = sleepstudy) #' has_intercept(model) #' #' model <- lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy) #' has_intercept(model) #' @export has_intercept <- function(x) { if (is_multivariate(x)) { unlist(lapply(find_terms(x), .check_for_intercept)) } else { .check_for_intercept(find_terms(x)) } } .check_for_intercept <- function(vars) { !("0" %in% vars[["conditional"]]) } insight/R/get_response.R0000644000176200001440000000330513613305061014737 0ustar liggesusers#' @title Get the values from the response variable #' @name get_response #' #' @description Returns the values the response variable(s) from a model object. #' If the model is a multivariate response model, a data frame with values #' from all response variables is returned. #' #' @param select Optional name(s) of response variables for which to extract values. #' Can be used in case of regression models with multiple response variables. #' @inheritParams find_predictors #' #' @return The values of the response variable, as vector, or a data frame if #' \code{x} has more than one defined response variable. #' #' @examples #' library(lme4) #' data(cbpp) #' data(mtcars) #' cbpp$trials <- cbpp$size - cbpp$incidence #' #' m <- glm(cbind(incidence, trials) ~ period, data = cbpp, family = binomial) #' head(get_response(m)) #' get_response(m, select = "incidence") #' #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' get_response(m) #' @export get_response <- function(x, select = NULL) { rn <- find_response(x, combine = FALSE) # exceptions if (inherits(x, "DirichletRegModel")) { rv <- x$Y class(rv) <- "matrix" data.frame(rv) } else if (length(rn) > 1) { rv <- get_data(x)[, rn, drop = FALSE] colnames(rv) <- rn # if user only wants specific response value, return this only if (!is.null(select) && all(select %in% colnames(rv))) { rv <- rv[, select, drop = TRUE] } rv } else { rv <- get_data(x)[[find_response(x, combine = TRUE)]] if (!is.factor(rv) && !is.numeric(rv) && !is.character(rv) && !is.logical(rv) && !is.integer(rv)) { as.vector(rv) } else { rv } } } insight/R/is_multivariate.R0000644000176200001440000000246413554405404015456 0ustar liggesusers#' @title Checks if an object stems from a multivariate response model #' @name is_multivariate #' #' @description Small helper that checks if a model is a multivariate response #' model, i.e. a model with multiple outcomes. #' #' @param x A model object, or an object returned by a function from this package. #' #' @return A logical, \code{TRUE} if either \code{x} is a model object and is #' a multivariate response model, or \code{TRUE} if a return value from a #' function of \pkg{insight} is from a multivariate response model. #' #' @examples #' \dontrun{ #' library(rstanarm) #' data("pbcLong") #' model <- stan_mvmer( #' formula = list( #' logBili ~ year + (1 | id), #' albumin ~ sex + year + (year | id) #' ), #' data = pbcLong, #' chains = 1, cores = 1, seed = 12345, iter = 1000 #' ) #' #' f <- find_formula(model) #' is_multivariate(model) #' is_multivariate(f) #' } #' @export is_multivariate <- function(x) { if (inherits(x, "gam", which = TRUE) == 1) { f <- .gam_family(x) gam_mv <- !is.null(f) && f$family == "Multivariate normal" } else { gam_mv <- FALSE } (inherits(x, "brmsfit") && !is.null(stats::formula(x)$response)) | inherits(x, "stanmvreg") | inherits(x, "mlm") | gam_mv | !is.null(attr(x, "is_mv", exact = TRUE)) } insight/R/is_model.R0000644000176200001440000000663313614067316014055 0ustar liggesusers#' @title Checks if an object is a regression model object #' @name is_model #' #' @description Small helper that checks if a model is a regression model #' object. #' #' @param x An object. #' #' @return A logical, \code{TRUE} if \code{x} is a (supported) model object. #' #' @details This function returns \code{TRUE} if \code{x} is a model object. #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' #' is_model(m) #' is_model(mtcars) #' @export is_model <- function(x) { inherits( x, c( "_ranger", "aareg", "anova", "Anova.mlm", "aov", "aovlist", "Arima", "bamlss", "bamlss.frame", "bayesmeta", "bayesx", "BBmm", "BBreg", "bcplm", "betareg", "BFBayesFactor", "bglmerMod", "biglm", "bigglm", "blavaan", "blmerMod", "bracl", "brglm", "brglmFit", "brmsfit", "brmultinom", "btergm", "cch", "censReg", "cgam", "cgamm", "cglm", "clm", "clm2", "clmm", "clmm2", "coeftest", "complmrob", "confusionMatrix", "coxme", "coxph", "cpglm", "cpglmm", "crch", "crq", "crqs", "DirichletRegModel", "drc", "emmGrid", "epi.2by2", "ergm", "feglm", "feis", "felm", "fitdistr", "fixest", "flexsurvreg", "gam", "Gam", "GAMBoost", "gamlr", "gamlss", "gamm", "gamm4", "garch", "gbm", "gee", "geeglm", "glimML", "glm", "glmaag", "glmbb", "glmboostLSS", "glmc", "glmdm", "glmdisc", "glmerMod", "glmlep", "glmmadmb", "glmmEP", "glmmfields", "glmmLasso", "glmmPQL", "glmmTMB", "glmnet", "glmrob", "glmRob", "glmx", "gls", "gmnl", "gmm", "htest", "hurdle", "iv_robust", "ivreg", "lavaan", "lm", "lm_robust", "lme", "lmrob", "lmRob", "loggammacenslmrob", "logistf", "LogitBoost", "loo", "LORgee", "lmodel2", "lqmm", "lrm", "manova", "MANOVA", "maxLik", "mboostLSS", "mclogit", "mmclogit", "mcmc", "MCMCglmm", "mediate", "merMod", "mixed", "mixor", "MixMod", "mjoint", "mle2", "mlm", "mlogit", "multinom", "mvmeta", "mvr", "negbin", "nlreg", "nlrq", "nls", "objectiveML", "ols", "orcutt", "plm", "plmm", "polr", "psm", "rdrobust", "ridgelm", "rjags", "rlm", "rlme", "rlmerMod", "RM", "rma", "rma.uni", "rms", "rq", "rqss", "sem", "slm", "speedlm", "speedglm", "stanmvreg", "stanreg", "survfit", "survreg", "survPresmooth", "svyglm", "svyolr", "tobit", "truncreg", "vgam", "vglm", "wbm", "wblm", "zcpglm", "zeroinfl", "zerotrunc" ) ) } insight/R/is_nullmodel.R0000644000176200001440000000207013524331052014726 0ustar liggesusers#' @title Checks if model is a null-model (intercept-only) #' @name is_nullmodel #' #' @description Checks if model is a null-model (intercept-only), i.e. if #' the conditional part of the model has no predictors. #' #' @param x A model object. #' #' @return \code{TRUE} if \code{x} is a null-model, \code{FALSE} otherwise. #' #' @examples #' model <- lm(mpg ~ 1, data = mtcars) #' is_nullmodel(model) #' #' model <- lm(mpg ~ gear, data = mtcars) #' is_nullmodel(model) #' #' library(lme4) #' model <- lmer(Reaction ~ 1 + (Days | Subject), data = sleepstudy) #' is_nullmodel(model) #' #' model <- lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy) #' is_nullmodel(model) #' @export is_nullmodel <- function(x) { if (is_multivariate(x)) { unlist(lapply(find_predictors(x, effects = "fixed", component = "conditional"), .check_for_nullmodel)) } else { .check_for_nullmodel(find_predictors(x, effects = "fixed", component = "conditional")) } } .check_for_nullmodel <- function(preds) { is.null(preds[["conditional"]]) } insight/R/link_function.R0000644000176200001440000002535213614067316015123 0ustar liggesusers#' @title Get link-function from model object #' @name link_function #' #' @description Returns the link-function from a model object. #' #' @inheritParams find_predictors #' @inheritParams find_formula #' @inheritParams link_inverse #' #' @return A function, describing the link-function from a model-object. #' For multivariate-response models, a list of functions is returned. #' #' @examples #' # example from ?stats::glm #' counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) #' outcome <- gl(3, 1, 9) #' treatment <- gl(3, 3) #' m <- glm(counts ~ outcome + treatment, family = poisson()) #' #' link_function(m)(.3) #' # same as #' log(.3) #' @export #' @importFrom stats family make.link link_function <- function(x, ...) { UseMethod("link_function") } # Default method --------------------------- #' @export link_function.default <- function(x, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) } tryCatch( { # get model family ff <- .gam_family(x) # return link function, if exists if ("linkfun" %in% names(ff)) { return(ff$linkfun) } # else, create link function from link-string if ("link" %in% names(ff)) { return(match.fun(ff$link)) } NULL }, error = function(x) { NULL } ) } # Gaussian family ------------------------------------------ #' @export link_function.lm <- function(x, ...) { stats::gaussian(link = "identity")$linkfun } #' @export link_function.lme <- link_function.lm #' @export link_function.bayesx <- link_function.lm #' @export link_function.mixed <- link_function.lm #' @export link_function.truncreg <- link_function.lm #' @export link_function.censReg <- link_function.lm #' @export link_function.gls <- link_function.lm #' @export link_function.rq <- link_function.lm #' @export link_function.rqss <- link_function.lm #' @export link_function.crq <- link_function.lm #' @export link_function.crqs <- link_function.lm #' @export link_function.lmRob <- link_function.lm #' @export link_function.complmRob <- link_function.lm #' @export link_function.speedlm <- link_function.lm #' @export link_function.biglm <- link_function.lm #' @export link_function.lmrob <- link_function.lm #' @export link_function.lm_robust <- link_function.lm #' @export link_function.iv_robust <- link_function.lm #' @export link_function.aovlist <- link_function.lm #' @export link_function.felm <- link_function.lm #' @export link_function.feis <- link_function.lm #' @export link_function.ivreg <- link_function.lm #' @export link_function.plm <- link_function.lm #' @export link_function.MANOVA <- link_function.lm #' @export link_function.RM <- link_function.lm # General family --------------------------------- #' @export link_function.glm <- link_function.default #' @export link_function.speedglm <- link_function.default #' @export link_function.bigglm <- link_function.default #' @export link_function.brglm <- link_function.default #' @export link_function.cgam <- link_function.default # Logit link ------------------------ #' @export link_function.multinom <- function(x, ...) { stats::make.link(link = "logit")$linkfun } #' @export link_function.BBreg <- link_function.multinom #' @export link_function.BBmm <- link_function.multinom #' @export link_function.gmnl <- link_function.multinom #' @export link_function.logistf <- link_function.multinom #' @export link_function.lrm <- link_function.multinom #' @export link_function.mlogit <- link_function.multinom #' @export link_function.coxph <- link_function.multinom #' @export link_function.survfit <- link_function.multinom #' @export link_function.coxme <- link_function.multinom # Log links ------------------------ #' @export link_function.zeroinfl <- function(x, ...) { stats::make.link("log")$linkfun } #' @export link_function.hurdle <- link_function.zeroinfl #' @export link_function.zerotrunc <- link_function.zeroinfl # Tobit links --------------------------------- #' @export link_function.tobit <- function(x, ...) { .make_tobit_family(x)$linkfun } #' @export link_function.crch <- link_function.tobit #' @export link_function.survreg <- link_function.tobit #' @export link_function.psm <- link_function.tobit #' @export link_function.flexsurvreg <- function(x, ...) { dist <- parse(text = .safe_deparse(x$call))[[1]]$dist .make_tobit_family(x, dist)$linkfun } # Ordinal and cumulative links -------------------------- #' @export link_function.clm <- function(x, ...) { stats::make.link(link = .get_ordinal_link(x))$linkfun } #' @export link_function.clm2 <- link_function.clm #' @export link_function.clmm <- link_function.clm #' @export link_function.mixor <- link_function.clm # Other models ----------------------------- #' @export link_function.cglm <- function(x, ...) { link <- parse(text = .safe_deparse(x$call))[[1]]$link method <- parse(text = .safe_deparse(x$call))[[1]]$method if (!is.null(method) && method == "clm") { link <- "identiy" } stats::make.link(link = link)$linkfun } #' @export link_function.fixest <- function(x, ...) { if (is.null(x$family)) { if (!is.null(x$method) && x$method == "feols") { stats::gaussian(link = "identity")$linkfun } } else if (inherits(x$family, "family")) { x$family$linkfun } else { link <- switch( x$family, "poisson" = , "negbin" = "log", "logit" = "logit", "gaussian" = "identity" ) stats::make.link(link)$linkfun } } #' @export link_function.feglm <- link_function.fixest #' @export link_function.glmx <- function(x, ...) { x$family$glm$linkfun } #' @export link_function.cpglmm <- function(x, ...) { f <- .get_cplm_family(x) f$linkfun } #' @export link_function.cpglm <- link_function.cpglmm #' @export link_function.gam <- function(x, ...) { lf <- tryCatch( { # get model family ff <- .gam_family(x) # return link function, if exists if ("linkfun" %in% names(ff)) { return(ff$linkfun) } # else, create link function from link-string if ("link" %in% names(ff)) { return(match.fun(ff$link)) } NULL }, error = function(x) { NULL } ) if (is.null(lf)) { mi <- .gam_family(x) if (.obj_has_name(mi, "linfo")) { if (.obj_has_name(mi$linfo, "linkfun")) { lf <- mi$linfo$linkfun } else { lf <- mi$linfo[[1]]$linkfun } } } lf } #' @export link_function.glimML <- function(x, ...) { stats::make.link(link = x@link)$linkfun } #' @export link_function.glmmadmb <- function(x, ...) { x$linkfun } #' @rdname link_function #' @export link_function.gamlss <- function(x, what = c("mu", "sigma", "nu", "tau"), ...) { what <- match.arg(what) faminfo <- get(x$family[1], asNamespace("gamlss"))() switch( what, "mu" = faminfo$mu.linkfun, "sigma" = faminfo$sigma.linkfun, "nu" = faminfo$nu.linkfun, "tau" = faminfo$tau.linkfun, faminfo$mu.linkfun ) } #' @export link_function.gamm <- function(x, ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) NextMethod() } #' @export link_function.bamlss <- function(x, ...) { flink <- stats::family(x)$links[1] tryCatch( { stats::make.link(flink)$linkfun }, error = function(e) { print_colour("\nCould not find appropriate link-function.\n", "red") } ) } #' @export link_function.LORgee <- function(x, ...) { if (grepl(pattern = "logit", x = x$link, fixed = TRUE)) { link <- "logit" } else if (grepl(pattern = "probit", x = x$link, fixed = TRUE)) { link <- "probit" } else if (grepl(pattern = "cauchit", x = x$link, fixed = TRUE)) { link <- "cauchit" } else if (grepl(pattern = "cloglog", x = x$link, fixed = TRUE)) { link <- "cloglog" } else { link <- "logit" } stats::make.link(link)$linkfun } #' @export link_function.vgam <- function(x, ...) { x@family@linkfun } #' @export link_function.vglm <- function(x, ...) { x@family@linkfun } #' @export link_function.polr <- function(x, ...) { link <- switch( x$method, logistic = "logit", probit = "probit", "log" ) stats::make.link(link)$linkfun } #' @export link_function.svyolr <- function(x, ...) { link <- switch( x$method, logistic = "logit", probit = "probit", "log" ) stats::make.link(link)$linkfun } #' @rdname link_function #' @export link_function.betareg <- function(x, what = c("mean", "precision"), ...) { what <- match.arg(what) switch( what, "mean" = x$link$mean$linkfun, "precision" = x$link$precision$linkfun ) } #' @rdname link_function #' @export link_function.DirichletRegModel <- function(x, what = c("mean", "precision"), ...) { what <- match.arg(what) if (x$parametrization == "common") { stats::make.link("logit")$linkfun } else { switch( what, "mean" = stats::make.link("logit")$linkfun, "precision" = stats::make.link("log")$linkfun ) } } #' @importFrom stats poisson #' @export link_function.gbm <- function(x, ...) { switch( x$distribution$name, laplace = , tdist = , gaussian = stats::gaussian(link = "identity")$linkfun, poisson = stats::poisson(link = "log")$linkfun, huberized = , adaboost = , coxph = , bernoulli = stats::make.link("logit")$linkfun ) } #' @export link_function.stanmvreg <- function(x, ...) { fam <- stats::family(x) lapply(fam, function(.x) .x$linkfun) } #' @export link_function.brmsfit <- function(x, ...) { fam <- stats::family(x) if (is_multivariate(x)) { lapply(fam, .brms_link_fun) } else { .brms_link_fun(fam) } } # helper ----------------------- .brms_link_fun <- function(fam) { # do we have custom families? if (!is.null(fam$family) && (is.character(fam$family) && fam$family == "custom")) { il <- stats::make.link(fam$link)$linkfun } else { if ("linkfun" %in% names(fam)) { il <- fam$linkfun } else if ("link" %in% names(fam) && is.character(fam$link)) { il <- stats::make.link(fam$link)$linkfun } else { ff <- get(fam$family, asNamespace("stats")) il <- ff(fam$link)$linkfun } } il } insight/R/color_if.R0000644000176200001440000000727513554405404014056 0ustar liggesusers#' @title Color-formatting for data columns based on condition #' @name color_if #' #' @description Convenient function that formats columns in data frames #' with color codes, where the color is chosen based on certain conditions. #' Columns are then printed in color in the console. #' #' @param x A data frame #' @param columns Character vector with column names of \code{x} that should be formatted. #' @param predicate A function that takes \code{columns} and \code{value} as input #' and which should return \code{TRUE} or \code{FALSE}, based on if the condition #' (in comparison with \code{value}) is met. #' @param value The comparator. May be used in conjunction with \code{predicate} #' to quickly set up a function which compares elements in \code{colums} to \code{value}. #' May be ignored when \code{predicate} is a function that internally computes other #' comparisons. See 'Examples'. #' @param color_if,colour_if Character vector, indicating the color code used to #' format values in \code{x} that meet the condition of \code{predicate} and \code{value}. #' May be one of \code{"red"}, \code{"yellow"}, \code{"green"}, \code{"blue"}, #' \code{"violet"}, \code{"cyan"} or \code{"grey"}. Formatting is also possible #' with \code{"bold"} or \code{"italic"}. #' @param color_else,colour_else See \code{color_if}, but only for conditions #' that are \emph{not} met. #' @param digits Digits for rounded values. #' #' @details The predicate-function simply works like this: #' \code{which(predicate(x[, columns], value))} #' #' @return The . #' #' @examples #' # all values in Sepal.Length larger than 5 in green, all remaining in red #' x <- color_if(iris[1:10, ], columns = "Sepal.Length", predicate = `>`, value = 5) #' x #' cat(x$Sepal.Length) #' #' # all levels "setosa" in Species in green, all remaining in red #' x <- color_if(iris, columns = "Species", predicate = `==`, value = "setosa") #' cat(x$Species) #' #' # own function, argument "value" not needed here #' p <- function(x, y) { #' x >= 4.9 & x <= 5.1 #' } #' # all values in Sepal.Length between 4.9 and 5.1 in green, all remaining in red #' x <- color_if(iris[1:10, ], columns = "Sepal.Length", predicate = p) #' cat(x$Sepal.Length) #' @export color_if <- function(x, columns, predicate = `>`, value = 0, color_if = "green", color_else = "red", digits = 2) { xnew <- x if (columns %in% names(x)) { x_if <- which(predicate(x[, columns], value)) x_else <- which(!predicate(x[, columns], value)) values <- x[, columns] xnew[, columns] <- format( if (is.numeric(values)) { round(values, digits = digits) } else { values }, width = nchar(columns), nsmall = digits, justify = "right" ) # remove NA xnew[, columns][trimws(xnew[, columns]) == "NA"] <- "" if (!is.null(color_if) && length(x_if)) { xnew[, columns][x_if] <- .colour(color_if, xnew[, columns][x_if]) } if (!is.null(color_else) && length(x_else)) { xnew[, columns][x_else] <- .colour(color_else, xnew[, columns][x_else]) } } xnew } #' Detect coloured cells #' @keywords internal .colour_detect <- function(x) { ansi_regex <- paste0( "(?:(?:\\x{001b}\\[)|\\x{009b})", "(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])", "|\\x{001b}[A-M]" ) grepl(ansi_regex, x, perl = TRUE) } #' @rdname color_if #' @export colour_if <- function(x, columns, predicate = `>`, value = 0, colour_if = "green", colour_else = "red", digits = 2) { color_if(x = x, columns = columns, predicate = predicate, value = value, color_if = colour_if, color_else = colour_else, digits = digits) } insight/R/find_random_slopes.R0000644000176200001440000000333413602424413016112 0ustar liggesusers#' @title Find names of random slopes #' @name find_random_slopes #' #' @description Return the name of the random slopes from mixed effects models. #' #' @param x A fitted mixed model. #' #' @return A list of character vectors with the name(s) of the random slopes, or #' \code{NULL} if model has no random slopes. Depending on the model, the #' returned list has following elements: #' \itemize{ #' \item \code{random}, the random slopes from the conditional part of model #' \item \code{zero_inflated_random}, the random slopes from the zero-inflation component of the model #' } #' #' @examples #' library(lme4) #' data(sleepstudy) #' #' m <- lmer(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy) #' find_random_slopes(m) #' @export find_random_slopes <- function(x) { random_slopes <- vector(mode = "list") forms <- find_formula(x) random_slopes$random <- .extract_random_slopes(forms$random) random_slopes$zero_inflated_random <- .extract_random_slopes(forms$zero_inflated_random) random_slopes <- .compact_list(random_slopes) if (.is_empty_object(random_slopes)) { NULL } else { random_slopes } } .extract_random_slopes <- function(fr) { if (is.null(fr)) { return(NULL) } if (!is.list(fr)) fr <- list(fr) random_slope <- lapply(fr, function(forms) { if (grepl("(.*)\\|(.*)\\|(.*)", .safe_deparse(forms))) { pattern <- "(.*)\\|(.*)\\|(.*)" } else { pattern <- "(.*)\\|(.*)" } pattern <- gsub(pattern, "\\1", .safe_deparse(forms)) re <- all.vars(forms) re[sapply(re, function(x) { grepl(x, pattern, fixed = TRUE) })] }) unique(unlist(.compact_list(random_slope))) } insight/R/find_interactions.R0000644000176200001440000000444513577635053015772 0ustar liggesusers#' @title Find interaction terms from models #' @name find_interactions #' #' @description Returns all lowest to highest order interaction terms from a model. #' #' @inheritParams find_predictors #' #' @return A list of character vectors that represent the interaction terms. #' Depending on \code{component}, the returned list has following #' elements (or \code{NULL}, if model has no interaction term): #' \itemize{ #' \item \code{conditional}, interaction terms that belong to the "fixed effects" terms from the model #' \item \code{zero_inflated}, interaction terms that belong to the "fixed effects" terms from the zero-inflation component of the model #' \item \code{instruments}, for fixed-effects regressions like \code{ivreg}, \code{felm} or \code{plm}, interaction terms that belong to the instrumental variables #' } #' #' @examples #' data(mtcars) #' #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' find_interactions(m) #' #' m <- lm(mpg ~ wt * cyl + vs * hp * gear + carb, data = mtcars) #' find_interactions(m) #' @export find_interactions <- function(x, component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "instruments"), flatten = FALSE) { component <- match.arg(component) .find_interactions(x, effects = "fixed", component, flatten, main_effects = FALSE) } .find_interactions <- function(x, effects = "fixed", component, flatten, main_effects = FALSE) { f <- find_formula(x) is_mv <- is_multivariate(f) elements <- .get_elements(effects = effects, component = component) if (is_mv) { l <- lapply(f, function(.x) .compact_list(lapply(.x[elements], function(i) .get_interaction_terms(i, main_effects)))) } else { l <- .compact_list(lapply(f[elements], function(i) .get_interaction_terms(i, main_effects))) } if (.is_empty_object(l)) { return(NULL) } if (flatten) { unique(unlist(l)) } else { l } } #' @importFrom stats terms .get_interaction_terms <- function(f, main_effects = FALSE) { if (is.null(f)) { return(NULL) } terms <- labels(stats::terms(f)) if (main_effects) { terms } else { interaction_terms <- grepl(":", terms, fixed = TRUE) if (any(interaction_terms)) { terms[interaction_terms] } else { NULL } } } insight/R/find_parameters.R0000644000176200001440000010465713615253624015432 0ustar liggesusers#' @title Find names of model parameters #' @name find_parameters #' #' @description Returns the names of model parameters, like they typically #' appear in the \code{summary()} output. For Bayesian models, the parameter #' names equal the column names of the posterior samples after coercion #' from \code{as.data.frame()}. #' #' @param parameters Regular expression pattern that describes the parameters that #' should be returned. #' @param effects Should parameters for fixed effects, random effects #' or both be returned? Only applies to mixed models. May be abbreviated. #' @param component Should all parameters, parameters for the #' conditional model, the zero-inflated part of the model, the dispersion #' term or the instrumental variables be returned? Applies to models #' with zero-inflated and/or dispersion formula, or to models with instrumental #' variable (so called fixed-effects regressions). May be abbreviated. Note that the #' \emph{conditional} component is also called \emph{count} or \emph{mean} #' component, depending on the model. #' @param ... Currently not used. #' @inheritParams find_predictors #' #' @return A list of parameter names. For simple models, only one list-element, #' \code{conditional}, is returned. For more complex models, the returned #' list may have following elements: #' \itemize{ #' \item \code{conditional}, the "fixed effects" part from the model #' \item \code{random}, the "random effects" part from the model #' \item \code{zero_inflated}, the "fixed effects" part from the zero-inflation component of the model #' \item \code{zero_inflated_random}, the "random effects" part from the zero-inflation component of the model #' \item \code{dispersion}, the dispersion parameters #' \item \code{simplex}, simplex parameters of monotonic effects (\pkg{brms} only) #' \item \code{smooth_terms}, the smooth parameters #' } #' #' @details In most cases when models either return different "effects" (fixed, #' random) or "components" (conditional, zero-inflated, ...), the arguments #' \code{effects} and \code{component} can be used. Not all model classes that #' support these arguments are listed here in the 'Usage' section. #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' find_parameters(m) #' @importFrom stats coef #' @export find_parameters <- function(x, ...) { UseMethod("find_parameters") } # Default methods ------------------------------------------- #' @export find_parameters.default <- function(x, flatten = FALSE, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) pars <- find_parameters.gam(x) } else { pars <- tryCatch( { p <- .remove_backticks_from_string(names(stats::coef(x))) list(conditional = p) }, error = function(x) { NULL } ) } if (is.null(pars$conditional) || is.null(pars)) { print_color(sprintf("Parameters can't be retrieved for objects of class '%s'.\n", class(x)[1]), "red") return(NULL) } if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.data.frame <- function(x, flatten = FALSE, ...) { stop("A data frame is no valid object for this function.") } # Ordinal ----------------------------------------------- #' @export find_parameters.polr <- function(x, flatten = FALSE, ...) { pars <- list(conditional = c(sprintf("Intercept: %s", names(x$zeta)), names(stats::coef(x)))) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.clm2 <- function(x, flatten = FALSE, ...) { cf <- stats::coef(x) n_intercepts <- length(x$xi) n_location <- length(x$beta) n_scale <- length(x$zeta) if (n_scale == 0) { pars <- list(conditional = names(cf)) pars$conditional <- .remove_backticks_from_string(pars$conditional) } else { pars <- .compact_list(list( conditional = names(cf)[1:(n_intercepts + n_location)], scale = names(cf)[(1 + n_intercepts + n_location):(n_scale + n_intercepts + n_location)] )) pars <- rapply(pars, .remove_backticks_from_string, how = "list") } if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.clmm2 <- find_parameters.clm2 #' @export find_parameters.bracl <- function(x, flatten = FALSE, ...) { pars <- list(conditional = names(stats::coef(x))) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.betareg <- function(x, flatten = FALSE, ...) { pars <- list( conditional = names(x$coefficients$mean), precision = names(x$coefficients$precision) ) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.DirichletRegModel <- function(x, flatten = FALSE, ...) { if (x$parametrization == "common") { pars <- list(conditional = names(unlist(stats::coef(x)))) } else { pars <- .compact_list(list( conditional = names(unlist(stats::coef(x)[["beta"]])), precision = names(unlist(stats::coef(x)[["gamma"]])) )) pars$precision <- .remove_backticks_from_string(pars$precision) } pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.mixor <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { effects <- match.arg(effects) coefs <- x$Model random_start <- grep("(\\(Intercept\\) \\(Intercept\\)|Random\\.\\(Intercept\\))", rownames(coefs)) thresholds <- grep("Threshold\\d", rownames(coefs)) l <- list( conditional = rownames(coefs)[c(1, thresholds, 2:(random_start - 1))], random = rownames(coefs)[random_start:(thresholds[1] - 1)] ) .filter_parameters(l, effects = effects, flatten = flatten) } #' @export find_parameters.multinom <- function(x, flatten = FALSE, ...) { params <- stats::coef(x) pars <- if (is.matrix(params)) { list(conditional = colnames(params)) } else { list(conditional = names(params)) } pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.brmultinom <- find_parameters.multinom # GAM (additive models) --------------------------------------------- #' @importFrom stats na.omit coef #' @export find_parameters.gamlss <- function(x, flatten = FALSE, ...) { pars <- lapply(x$parameters, function(i) { .remove_backticks_from_string(names(stats::na.omit(stats::coef(x, what = i)))) }) names(pars) <- x$parameters if ("mu" %in% names(pars)) names(pars)[1] <- "conditional" pars <- .compact_list(pars) if (flatten) { unique(unlist(pars)) } else { pars } } #' @rdname find_parameters #' @export find_parameters.gam <- function(x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, ...) { pars <- list(conditional = names(stats::coef(x))) pars$conditional <- .remove_backticks_from_string(pars$conditional) st <- summary(x)$s.table pars$conditional <- pars$conditional[.grep_non_smoothers(pars$conditional)] pars$smooth_terms <- row.names(st) pars <- .compact_list(pars) component <- match.arg(component) elements <- .get_elements(effects = "all", component = component) pars <- .compact_list(pars[elements]) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.Gam <- function(x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, ...) { pars <- names(stats::coef(x)) component <- match.arg(component) l <- .compact_list(list( conditional = pars[.grep_non_smoothers(pars)], smooth_terms = pars[.grep_smoothers(pars)] )) .filter_parameters(l, effects = "all", component = component, flatten = flatten, recursive = TRUE) } #' @export find_parameters.vgam <- find_parameters.Gam #' @export find_parameters.gamm <- function(x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) component <- match.arg(component) l <- find_parameters.gam(x, component = component) if (flatten) { unique(unlist(l)) } else { l } } #' @export find_parameters.cgam <- function(x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, ...) { component <- match.arg(component) sc <- summary(x) estimates <- sc$coefficients smooth_terms <- sc$coefficients2 l <- .compact_list(list( conditional = rownames(estimates), smooth_terms = rownames(smooth_terms) )) l <- lapply(l, .remove_backticks_from_string) component <- match.arg(component) elements <- .get_elements(effects = "all", component = component) l <- .compact_list(l[elements]) if (flatten) { unique(unlist(l)) } else { l } } # Mixed Models ------------------------------------------------------- #' @export find_parameters.glmmTMB <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), flatten = FALSE, ...) { effects <- match.arg(effects) component <- match.arg(component) if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package 'lme4' required for this function to work. Please install it.") } # we extract random effects only when really necessary, to save # computational time. In particular model with large sample and # many random effects groups may take some time to return random effects if (effects == "fixed") { l <- .compact_list(list( conditional = names(lme4::fixef(x)$cond), zero_inflated = names(lme4::fixef(x)$zi), dispersion = names(lme4::fixef(x)$disp) )) } else { l <- .compact_list(list( conditional = names(lme4::fixef(x)$cond), random = lapply(lme4::ranef(x)$cond, colnames), zero_inflated = names(lme4::fixef(x)$zi), zero_inflated_random = lapply(lme4::ranef(x)$zi, colnames), dispersion = names(lme4::fixef(x)$disp) )) } .filter_parameters(l, effects = effects, component = component, flatten = flatten) } #' @export find_parameters.MixMod <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated"), flatten = FALSE, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package 'lme4' required for this function to work. Please install it.") } re.names <- dimnames(lme4::ranef(x))[[2]] has_zeroinf <- !is.null(find_formula(x)[["zero_inflated"]]) if (has_zeroinf) { z_inflated <- names(lme4::fixef(x, sub_model = "zero_part")) z_inflated_random <- re.names[grepl("^zi_", re.names, perl = TRUE)] } else { z_inflated <- NULL z_inflated_random <- NULL } l <- .compact_list(list( conditional = names(lme4::fixef(x, sub_model = "main")), random = re.names[grepl("^(?!zi_)", re.names, perl = TRUE)], zero_inflated = z_inflated, zero_inflated_random = z_inflated_random )) l <- lapply(l, .remove_backticks_from_string) effects <- match.arg(effects) component <- match.arg(component) elements <- .get_elements(effects = effects, component = component) l <- .compact_list(l[elements]) if (flatten) { unique(unlist(l)) } else { l } } #' @export find_parameters.nlmerMod <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package 'lme4' required for this function to work. Please install it.") } effects <- match.arg(effects) startvectors <- .get_startvector_from_env(x) if (effects == "fixed") { l <- .compact_list(list( conditional = setdiff(names(lme4::fixef(x)), startvectors), nonlinear = startvectors )) } else { l <- .compact_list(list( conditional = setdiff(names(lme4::fixef(x)), startvectors), nonlinear = startvectors, random = lapply(lme4::ranef(x), colnames) )) } .filter_parameters(l, effects = effects, flatten = flatten) } #' @rdname find_parameters #' @export find_parameters.merMod <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { effects <- match.arg(effects) if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package 'lme4' required for this function to work. Please install it.") } # we extract random effects only when really necessary, to save # computational time. In particular model with large sample and # many random effects groups may take some time to return random effects if (effects == "fixed") { l <- list(conditional = names(lme4::fixef(x))) } else { l <- .compact_list(list( conditional = names(lme4::fixef(x)), random = lapply(lme4::ranef(x), colnames) )) } .filter_parameters(l, effects = effects, flatten = flatten) } #' @export find_parameters.rlmerMod <- find_parameters.merMod #' @export find_parameters.glmmadmb <- find_parameters.merMod #' @export find_parameters.cpglmm <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { if (!requireNamespace("cplm", quietly = TRUE)) { stop("Package 'cplm' required for this function to work. Please install it.") } effects <- match.arg(effects) # we extract random effects only when really necessary, to save # computational time. In particular model with large sample and # many random effects groups may take some time to return random effects if (effects == "fixed") { l <- list(conditional = names(cplm::fixef(x))) } else { l <- .compact_list(list( conditional = names(cplm::fixef(x)), random = lapply(cplm::ranef(x), colnames) )) } .filter_parameters(l, effects = effects, flatten = flatten) } #' @export find_parameters.coxme <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package 'lme4' required for this function to work. Please install it.") } effects <- match.arg(effects) if (effects == "fixed") { l <- list(conditional = names(lme4::fixef(x))) } else { l <- .compact_list(list( conditional = names(lme4::fixef(x)), random = names(lme4::ranef(x)) )) } .filter_parameters(l, effects = effects, flatten = flatten, recursive = FALSE) } #' @export find_parameters.mixed <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package 'lme4' required for this function to work. Please install it.") } effects <- match.arg(effects) if (effects == "fixed") { l <- list(conditional = names(lme4::fixef(x$full_model))) } else { l <- .compact_list(list( conditional = names(lme4::fixef(x$full_model)), random = lapply(lme4::ranef(x$full_model), colnames) )) } .filter_parameters(l, effects = effects, flatten = flatten) } #' @export find_parameters.lme <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package 'lme4' required for this function to work. Please install it.") } effects <- match.arg(effects) if (effects == "fixed") { l <- list(conditional = names(lme4::fixef(x))) } else { re <- lme4::ranef(x) if (is.data.frame(re)) { rn <- colnames(re) } else { rn <- lapply(re, colnames) } l <- .compact_list(list( conditional = names(lme4::fixef(x)), random = rn )) } .filter_parameters(l, effects = effects, flatten = flatten) } # zero-inflated models -------------------------------------------- #' @rdname find_parameters #' @export find_parameters.zeroinfl <- function(x, component = c("all", "conditional", "zi", "zero_inflated"), flatten = FALSE, ...) { cf <- names(stats::coef(x)) component <- match.arg(component) l <- .compact_list(list( conditional = cf[grepl("^count_", cf, perl = TRUE)], zero_inflated = cf[grepl("^zero_", cf, perl = TRUE)] )) .filter_parameters(l, effects = "all", component = component, flatten = flatten, recursive = FALSE) } #' @rdname find_parameters #' @export find_parameters.hurdle <- find_parameters.zeroinfl #' @export find_parameters.zerotrunc <- find_parameters.default # Bayesian models ----------------------------------------- #' @rdname find_parameters #' @export find_parameters.BFBayesFactor <- function(x, effects = c("all", "fixed", "random"), component = c("all", "extra"), flatten = FALSE, ...) { conditional <- NULL random <- NULL extra <- NULL effects <- match.arg(effects) component <- match.arg(component) if (.classify_BFBayesFactor(x) == "correlation") { conditional <- "rho" } else if (.classify_BFBayesFactor(x) == "ttest") { conditional <- "Difference" } else if (.classify_BFBayesFactor(x) == "meta") { conditional <- "Effect" } else if (.classify_BFBayesFactor(x) == "linear") { posteriors <- as.data.frame(suppressMessages( BayesFactor::posterior(x, iterations = 20, progress = FALSE, index = 1, ...) )) params <- colnames(posteriors) vars <- find_variables(x, effects = "all") dat <- get_data(x) if ("conditional" %in% names(vars)) { conditional <- unlist(lapply(vars$conditional, function(i) { if (is.factor(dat[[i]])) { sprintf("%s-%s", i, levels(dat[[i]])) } else { i } })) } if ("random" %in% names(vars)) { random <- unlist(lapply(vars$random, function(i) { if (is.factor(dat[[i]])) { sprintf("%s-%s", i, levels(dat[[i]])) } else { i } })) } extra <- setdiff(params, c(conditional, random)) } elements <- .get_elements(effects, component = component) l <- lapply(.compact_list(list(conditional = conditional, random = random, extra = extra)), .remove_backticks_from_string) l <- .compact_list(l[elements]) if (flatten) { unique(unlist(l)) } else { l } } #' @export find_parameters.MCMCglmm <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { sc <- summary(x) effects <- match.arg(effects) l <- .compact_list(list( conditional = rownames(sc$solutions), random = rownames(sc$Gcovariances) )) .filter_parameters(l, effects = effects, flatten = flatten, recursive = FALSE) } #' @rdname find_parameters #' @export find_parameters.brmsfit <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "simplex", "sigma", "smooth_terms"), flatten = FALSE, parameters = NULL, ...) { ## TODO remove "make.names()" in a future update fe <- make.names(colnames(as.data.frame(x))) is_mv <- NULL cond <- fe[grepl(pattern = "(b_|bs_|bsp_|bcs_)(?!zi_)(.*)", fe, perl = TRUE)] zi <- fe[grepl(pattern = "(b_zi_|bs_zi_|bsp_zi_|bcs_zi_)", fe, perl = TRUE)] rand <- fe[grepl(pattern = "(?!.*__zi)(?=.*r_)", fe, perl = TRUE) & !grepl(pattern = "^prior_", fe, perl = TRUE)] randzi <- fe[grepl(pattern = "r_(.*__zi)", fe, perl = TRUE)] simo <- fe[grepl(pattern = "^simo_", fe, perl = TRUE)] smooth_terms <- fe[grepl(pattern = "^sds_", fe, perl = TRUE)] priors <- fe[grepl(pattern = "^prior_", fe, perl = TRUE)] sigma <- fe[grepl(pattern = "^sigma_", fe, perl = TRUE)] l <- .compact_list(list( conditional = cond, random = rand, zero_inflated = zi, zero_inflated_random = randzi, simplex = simo, smooth_terms = smooth_terms, sigma = sigma, priors = priors )) effects <- match.arg(effects) component <- match.arg(component) elements <- .get_elements(effects = effects, component = component) elements <- c(elements, "priors") if (is_multivariate(x)) { rn <- names(find_response(x)) l <- lapply(rn, function(i) { if (.obj_has_name(l, "conditional")) { conditional <- l$conditional[grepl(sprintf("^(b_|bs_|bsp_|bcs_)\\Q%s\\E_", i), l$conditional)] } else { conditional <- NULL } if (.obj_has_name(l, "random")) { random <- l$random[grepl(sprintf("__\\Q%s\\E\\.", i), l$random)] } else { random <- NULL } if (.obj_has_name(l, "zero_inflated")) { zero_inflated <- l$zero_inflated[grepl(sprintf("^(b_zi_|bs_zi_|bsp_zi_|bcs_zi_)\\Q%s\\E_", i), l$zero_inflated)] } else { zero_inflated <- NULL } if (.obj_has_name(l, "zero_inflated_random")) { zero_inflated_random <- l$zero_inflated_random[grepl(sprintf("__zi_\\Q%s\\E\\.", i), l$zero_inflated_random)] } else { zero_inflated_random <- NULL } if (.obj_has_name(l, "simplex")) { simplex <- l$simplex } else { simplex <- NULL } if (.obj_has_name(l, "sigma")) { sigma <- l$sigma[grepl(sprintf("^sigma_\\Q%s\\E", i), l$sigma)] } else { sigma <- NULL } if (.obj_has_name(l, "smooth_terms")) { smooth_terms <- l$smooth_terms } else { smooth_terms <- NULL } if (.obj_has_name(l, "priors")) { priors <- l$priors } else { priors <- NULL } pars <- .compact_list(list( conditional = conditional, random = random, zero_inflated = zero_inflated, zero_inflated_random = zero_inflated_random, simplex = simplex, smooth_terms = smooth_terms, sigma = sigma, priors = priors )) .compact_list(pars[elements]) }) names(l) <- rn is_mv <- "1" } else { l <- .compact_list(l[elements]) } l <- .filter_pars(l, parameters, !is.null(is_mv) && is_mv == "1") attr(l, "is_mv") <- is_mv if (flatten) { unique(unlist(l)) } else { l } } #' @importFrom stats coef #' @rdname find_parameters #' @export find_parameters.bayesx <- function(x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, parameters = NULL, ...) { cond <- rownames(stats::coef(x)) smooth_terms <- rownames(x$smooth.hyp) l <- .compact_list(list( conditional = cond, smooth_terms = smooth_terms )) l <- .filter_pars(l, parameters) component <- match.arg(component) elements <- .get_elements(effects = "all", component) l <- .compact_list(l[elements]) if (flatten) { unique(unlist(l)) } else { l } } #' @rdname find_parameters #' @export find_parameters.stanreg <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "smooth_terms"), flatten = FALSE, parameters = NULL, ...) { fe <- colnames(as.data.frame(x)) cond <- fe[grepl(pattern = "^(?!(b\\[|sigma|Sigma))", fe, perl = TRUE) & .grep_non_smoothers(fe)] rand <- fe[grepl(pattern = "^b\\[", fe, perl = TRUE)] smooth_terms <- fe[grepl(pattern = "^smooth_sd", fe, perl = TRUE)] l <- .compact_list(list( conditional = cond, random = rand, smooth_terms = smooth_terms )) l <- .filter_pars(l, parameters) effects <- match.arg(effects) component <- match.arg(component) elements <- .get_elements(effects, component) l <- .compact_list(l[elements]) if (flatten) { unique(unlist(l)) } else { l } } #' @export find_parameters.stanmvreg <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "sigma"), flatten = FALSE, parameters = NULL, ...) { fe <- colnames(as.data.frame(x)) rn <- names(find_response(x)) cond <- fe[grepl(pattern = "^(?!(b\\[|sigma|Sigma))", fe, perl = TRUE) & .grep_non_smoothers(fe) & !grepl(pattern = "\\|sigma$", fe, perl = TRUE)] rand <- fe[grepl(pattern = "^b\\[", fe, perl = TRUE)] sigma <- fe[grepl(pattern = "\\|sigma$", fe, perl = TRUE) & .grep_non_smoothers(fe)] l <- .compact_list(list( conditional = cond, random = rand, sigma = sigma )) if (.obj_has_name(l, "conditional")) { x1 <- sub(pattern = "(.*)(\\|)(.*)", "\\1", l$conditional) x2 <- sub(pattern = "(.*)(\\|)(.*)", "\\3", l$conditional) l.cond <- lapply(rn, function(i) { list(conditional = x2[which(x1 == i)]) }) names(l.cond) <- rn } else { l.cond <- NULL } if (.obj_has_name(l, "random")) { x1 <- sub(pattern = "b\\[(.*)(\\|)(.*)", "\\1", l$random) x2 <- sub(pattern = "(b\\[).*(.*)(\\|)(.*)", "\\1\\4", l$random) l.random <- lapply(rn, function(i) { list(random = x2[which(x1 == i)]) }) names(l.random) <- rn } else { l.random <- NULL } if (.obj_has_name(l, "sigma")) { l.sigma <- lapply(rn, function(i) { list(sigma = "sigma") }) names(l.sigma) <- rn } else { l.sigma <- NULL } l <- mapply(c, l.cond, l.random, l.sigma, SIMPLIFY = FALSE) l <- .filter_pars(l, parameters, is_mv = TRUE) effects <- match.arg(effects) component <- match.arg(component) elements <- .get_elements(effects, component) l <- lapply(l, function(i) .compact_list(i[elements])) attr(l, "is_mv") <- "1" if (flatten) { unique(unlist(l)) } else { l } } # Simulation models ----------------------------- #' @rdname find_parameters #' @export find_parameters.sim.merMod <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, parameters = NULL, ...) { fe <- colnames(.get_armsim_fixef_parms(x)) re <- colnames(.get_armsim_ranef_parms(x)) l <- .compact_list(list( conditional = fe, random = re )) l <- .filter_pars(l, parameters) effects <- match.arg(effects) elements <- .get_elements(effects, component = "all") l <- .compact_list(l[elements]) if (flatten) { unique(unlist(l)) } else { l } } #' @export find_parameters.sim <- function(x, flatten = FALSE, parameters = NULL, ...) { l <- .filter_pars( list(conditional = colnames(.get_armsim_fixef_parms(x))), parameters ) if (flatten) { unique(unlist(l)) } else { l } } #' @export find_parameters.mcmc <- function(x, flatten = FALSE, parameters = NULL, ...) { l <- .filter_pars(list(conditional = colnames(x)), parameters) if (flatten) { unique(unlist(l)) } else { l } } # SEM models ------------------------------------------------------ #' @export find_parameters.blavaan <- function(x, flatten = FALSE, ...) { if (!requireNamespace("lavaan", quietly = TRUE)) { stop("Package 'lavaan' required for this function to work. Please install it.") } pars <- data.frame( pars = names(lavaan::coef(x)), comp = NA, stringsAsFactors = FALSE ) pars$comp[grepl("~", pars$pars, fixed = TRUE)] <- "regression" pars$comp[grepl("=~", pars$pars, fixed = TRUE)] <- "latent" pars$comp[grepl("~~", pars$pars, fixed = TRUE)] <- "residual" pars$comp[grepl("~1", pars$pars, fixed = TRUE)] <- "intercept" pos_latent <- grep("=~", pars$pars, fixed = TRUE) pos_residual <- grep("~~", pars$pars, fixed = TRUE) pos_intercept <- grep("~1", pars$pars, fixed = TRUE) pos_regression <- setdiff(1:nrow(pars), c(pos_latent, pos_residual, pos_intercept)) pos <- c(min(pos_latent), min(pos_residual), min(pos_intercept), min(pos_regression)) comp_levels <- c("latent", "residual", "intercept", "regression") comp_levels <- comp_levels[order(pos)] pars$comp <- factor(pars$comp, levels = comp_levels) pars <- split(pars, pars$comp) pars <- lapply(pars, function(i) i$pars) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.lavaan <- function(x, flatten = FALSE, ...) { if (!requireNamespace("lavaan", quietly = TRUE)) { stop("Package 'lavaan' required for this function to work. Please install it.") } pars <- get_parameters(x) pars$Component <- factor(pars$Component, levels = unique(pars$Component)) pars <- split(pars$Parameter, pars$Component) if (flatten) { unique(unlist(pars)) } else { pars } } # Panel models ---------------------------------------- #' @export find_parameters.wbm <- function(x, flatten = FALSE, ...) { s <- summary(x) pars <- .compact_list(list( conditional = rownames(s$within_table), instruments = rownames(s$between_table), random = rownames(s$ints_table) )) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.wbgee <- find_parameters.wbm # Other models ----------------------------------- #' @export find_parameters.mlm <- function(x, flatten = FALSE, ...) { cs <- stats::coef(summary(x)) out <- lapply(cs, function(i) { list(conditional = .remove_backticks_from_string(rownames(i))) }) names(out) <- gsub("^Response (.*)", "\\1", names(cs)) attr(out, "is_mv") <- TRUE if (flatten) { unique(unlist(out)) } else { out } } #' @export find_parameters.glmx <- function(x, flatten = FALSE, ...) { cf <- stats::coef(summary(x)) out <- list( conditional = .remove_backticks_from_string(names(cf$glm[, 1])), extra = .remove_backticks_from_string(rownames(cf$extra)) ) if (flatten) { unique(unlist(out)) } else { out } } #' @export find_parameters.gbm <- function(x, flatten = FALSE, ...) { s <- summary(x, plotit = FALSE) pars <- list(conditional = as.character(s$var)) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.BBreg <- function(x, flatten = FALSE, ...) { pars <- list(conditional = rownames(stats::coef(x))) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.lrm <- function(x, flatten = FALSE, ...) { pars <- list(conditional = names(stats::coef(x))) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.flexsurvreg <- find_parameters.lrm #' @export find_parameters.BBmm <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { l <- .compact_list(list( conditional = rownames(x$fixed.coef), random = x$namesRand )) effects <- match.arg(effects) .filter_parameters(l, effects = effects, flatten = flatten, recursive = FALSE) } #' @export find_parameters.glimML <- function(x, effects = c("all", "fixed", "random"), flatten = FALSE, ...) { l <- .compact_list(list( conditional = names(x@fixed.param), random = names(x@random.param) )) effects <- match.arg(effects) .filter_parameters(l, effects = effects, flatten = flatten, recursive = FALSE) } #' @export find_parameters.aovlist <- function(x, flatten = FALSE, ...) { l <- lapply(stats::coef(x), names) # merge "intercept" and "block" into conditional # while "Within" becomes "random" l <- list(unname(unlist(l[c(1, 2)])), l[[3]]) l <- lapply(l, .remove_backticks_from_string) names(l) <- c("conditional", "random") if (flatten) { unique(unlist(l)) } else { l } } #' @export find_parameters.crq <- function(x, flatten = FALSE, ...) { sc <- summary(x) if (all(lapply(sc, is.list))) { pars <- list(conditional = rownames(sc[[1]]$coefficients)) } else { pars <- list(conditional = rownames(sc$coefficients)) } pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.crqs <- find_parameters.crq #' @export find_parameters.rqss <- function(x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, ...) { sc <- summary(x) pars <- list( conditional = rownames(sc$coef), smooth_terms = rownames(sc$qsstab) ) pars$conditional <- .remove_backticks_from_string(pars$conditional) pars$smooth_terms <- .remove_backticks_from_string(pars$smooth_terms) component <- match.arg(component) elements <- .get_elements(effects = "all", component) pars <- .compact_list(pars[elements]) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.aareg <- function(x, flatten = FALSE, ...) { sc <- summary(x) pars <- list(conditional = rownames(sc$table)) pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } } #' @export find_parameters.rma <- function(x, flatten = FALSE, ...) { tryCatch( { cf <- stats::coef(x) pars <- list(conditional = names(cf)) pars$conditional[grepl("intrcpt", pars$conditional)] <- "(Intercept)" pars$conditional <- .remove_backticks_from_string(pars$conditional) if (flatten) { unique(unlist(pars)) } else { pars } }, error = function(x) { NULL } ) } # helper ---------------------------- .filter_parameters <- function(l, effects, component = "all", flatten, recursive = TRUE) { if (isTRUE(recursive)) { # recursively remove back-ticks from all list-elements parameters l <- rapply(l, .remove_backticks_from_string, how = "list") } else { l <- lapply(l, .remove_backticks_from_string) } # keep only requested effects elements <- .get_elements(effects, component = component) # remove empty list-elements l <- .compact_list(l[elements]) if (flatten) { unique(unlist(l)) } else { l } } insight/R/get_nested_lme_varcorr.R0000644000176200001440000000335313524331052016761 0ustar liggesusers# Caution! this is somewhat experimental... # It retrieves the variance-covariance matrix of random effects # from nested lme-models. .get_nested_lme_varcorr <- function(x) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package `lme4` needs to be installed to compute variances for mixed models.", call. = FALSE) } vcor <- lme4::VarCorr(x) class(vcor) <- "matrix" re_index <- (which(rownames(vcor) == "(Intercept)") - 1)[-1] vc_list <- split(data.frame(vcor, stringsAsFactors = FALSE), findInterval(1:nrow(vcor), re_index)) vc_rownames <- split(rownames(vcor), findInterval(1:nrow(vcor), re_index)) re_pars <- unique(unlist(find_parameters(x)["random"])) re_names <- find_random(x, split_nested = TRUE, flatten = TRUE) names(vc_list) <- re_names mapply( function(x, y) { if ("Corr" %in% colnames(x)) { g_cor <- suppressWarnings(stats::na.omit(as.numeric(x[, "Corr"]))) } else { g_cor <- NULL } row.names(x) <- as.vector(y) vl <- rownames(x) %in% re_pars x <- suppressWarnings(apply(x[vl, vl, drop = FALSE], MARGIN = c(1, 2), FUN = as.numeric)) m1 <- matrix(, nrow = nrow(x), ncol = ncol(x)) m1[1:nrow(m1), 1:ncol(m1)] <- as.vector(x[, 1]) rownames(m1) <- rownames(x) colnames(m1) <- rownames(x) if (!is.null(g_cor)) { m1_cov <- sqrt(prod(diag(m1))) * g_cor for (j in 1:ncol(m1)) { m1[j, nrow(m1) - j + 1] <- m1_cov[1] } } attr(m1, "cor_slope_intercept") <- g_cor m1 }, vc_list, vc_rownames, SIMPLIFY = FALSE ) } .is_nested_lme <- function(x) { sapply(find_random(x), function(i) any(grepl(":", i, fixed = TRUE))) } insight/R/compute_variances.R0000644000176200001440000005141413600232625015756 0ustar liggesusers#' @importFrom stats nobs .compute_variances <- function(x, component, name_fun = NULL, name_full = NULL, verbose = TRUE) { ## Original code taken from GitGub-Repo of package glmmTMB ## Author: Ben Bolker, who used an cleaned-up/adapted ## version of Jon Lefcheck's code from SEMfit ## Major revisions and adaption to more complex models and other packages ## by Daniel Lüdecke faminfo <- model_info(x) if (!faminfo$is_mixed) { stop("Model is not a mixed model.", call. = FALSE) } if (faminfo$family %in% c("truncated_nbinom1", "truncated_nbinom2")) { if (verbose) { warning(sprintf("Truncated negative binomial families are currently not supported by `%s`.", name_fun), call. = F) } return(NA) } # get necessary model information, like fixed and random effects, # variance-covariance matrix etc. vals <- .get_variance_information(x, faminfo = faminfo, name_fun = name_fun, verbose = verbose) # Test for non-zero random effects ((near) singularity) no_random_variance <- FALSE if (.is_singular(x, vals) && !(component %in% c("slope", "intercept"))) { if (verbose) { warning(sprintf("Can't compute %s. Some variance components equal zero.\n Solution: Respecify random structure!", name_full), call. = F) } no_random_variance <- TRUE } # initialize return values, if not all components are requested var.fixed <- NULL var.random <- NULL var.residual <- NULL var.distribution <- NULL var.dispersion <- NULL var.intercept <- NULL var.slope <- NULL cor.slope_intercept <- NULL # Get variance of fixed effects: multiply coefs by design matrix if (component %in% c("fixed", "all")) { var.fixed <- .compute_variance_fixed(vals) } # Are random slopes present as fixed effects? Warn. if (!.random_slopes_in_fixed(x) && verbose) { warning(sprintf("Random slopes not present as fixed effects. This artificially inflates the conditional %s.\n Solution: Respecify fixed structure!", name_full), call. = FALSE) } # Separate observation variance from variance of random effects nr <- sapply(vals$re, nrow) not.obs.terms <- names(nr[nr != n_obs(x)]) obs.terms <- names(nr[nr == n_obs(x)]) # Variance of random effects if (component %in% c("random", "all") && !isTRUE(no_random_variance)) { var.random <- .compute_variance_random(not.obs.terms, x = x, vals = vals) } # Residual variance, which is defined as the variance due to # additive dispersion and the distribution-specific variance (Johnson et al. 2014) if (component %in% c("residual", "distribution", "all")) { var.distribution <- .compute_variance_distribution(x, var.cor = vals$vc, faminfo, name = name_full, verbose = verbose) } if (component %in% c("residual", "dispersion", "all")) { var.dispersion <- .compute_variance_dispersion(x = x, vals = vals, faminfo = faminfo, obs.terms = obs.terms) } if (component %in% c("residual", "all")) { var.residual <- var.distribution + var.dispersion } if (component %in% c("intercept", "all")) { var.intercept <- .between_subject_variance(vals, x) } if (component %in% c("slope", "all")) { var.slope <- .random_slope_variance(vals, x) } if (component %in% c("rho01", "all")) { cor.slope_intercept <- .random_slope_intercept_corr(vals, x) } # if we only need residual variance, we can delete those # values again... if (component == "residual") { var.distribution <- NULL var.dispersion <- NULL } .compact_list(list( "var.fixed" = var.fixed, "var.random" = var.random, "var.residual" = var.residual, "var.distribution" = var.distribution, "var.dispersion" = var.dispersion, "var.intercept" = var.intercept, "var.slope" = var.slope, "cor.slope_intercept" = cor.slope_intercept )) } # store essential information on coefficients, model matrix and so on # as list, since we need these information throughout the functions to # calculate the variance components... # #' @importFrom stats model.matrix .get_variance_information <- function(x, faminfo, name_fun = "get_variances", verbose = TRUE) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package `lme4` needs to be installed to compute variances for mixed models.", call. = FALSE) } if (inherits(x, "lme") && !requireNamespace("nlme", quietly = TRUE)) { stop("Package `nlme` needs to be installed to compute variances for mixed models.", call. = FALSE) } if (inherits(x, "rstanarm") && !requireNamespace("rstanarm", quietly = TRUE)) { stop("Package `rstanarm` needs to be installed to compute variances for mixed models.", call. = FALSE) } if (inherits(x, "stanreg")) { vals <- list( beta = lme4::fixef(x), X = rstanarm::get_x(x), vc = lme4::VarCorr(x), re = lme4::ranef(x) ) } else if (inherits(x, "MixMod")) { vals <- list( beta = lme4::fixef(x), X = stats::model.matrix(x), vc = x$D, re = list(lme4::ranef(x)) ) names(vals$re) <- x$id_name } else if (inherits(x, "lme")) { re_names <- find_random(x, split_nested = TRUE, flatten = TRUE) comp_x <- as.matrix(cbind(`(Intercept)` = 1, get_predictors(x))) rownames(comp_x) <- 1:nrow(comp_x) if (.is_nested_lme(x)) { vals_vc <- .get_nested_lme_varcorr(x) vals_re <- lme4::ranef(x) } else { vals_vc <- list(nlme::getVarCov(x)) vals_re <- list(lme4::ranef(x)) } vals <- list( beta = lme4::fixef(x), X = comp_x, vc = vals_vc, re = vals_re ) names(vals$re) <- re_names names(vals$vc) <- re_names } else if (inherits(x, "clmm")) { if (requireNamespace("ordinal", quietly = TRUE)) { f <- find_formula(x)$conditional mm <- stats::model.matrix(f, x$model) vals <- list( beta = c("(Intercept)" = 1, stats::coef(x)[intersect(names(coef(x)), colnames(mm))]), X = mm, vc = ordinal::VarCorr(x), re = ordinal::ranef(x) ) } } else if (inherits(x, "glmmadmb")) { vals <- list( beta = lme4::fixef(x), X = stats::model.matrix(x), vc = lme4::VarCorr(x), re = lme4::ranef(x) ) } else if (inherits(x, "cpglmm")) { if (!requireNamespace("cplm", quietly = TRUE)) { stop("Package 'cplm' required. Please install it.") } vals <- list( beta = cplm::fixef(x), X = cplm::model.matrix(x), vc = cplm::VarCorr(x), re = cplm::ranef(x) ) } else { vals <- list( beta = lme4::fixef(x), X = lme4::getME(x, "X"), vc = lme4::VarCorr(x), re = lme4::ranef(x) ) } # for glmmTMB, tell user that dispersion model is ignored if (inherits(x, "glmmTMB")) { vals <- lapply(vals, .collapse_cond) } if (!is.null(find_formula(x)[["dispersion"]]) && verbose) { warning(sprintf("%s ignores effects of dispersion model.", name_fun), call. = FALSE) } vals } # helper-function, telling user if family / distribution is supported or not .badlink <- function(link, family, verbose = TRUE) { if (verbose) { warning(sprintf("Model link '%s' is not yet supported for the %s distribution.", link, family), call. = FALSE) } return(NA) } # glmmTMB returns a list of model information, one for conditional # and one for zero-inflated part, so here we "unlist" it, returning # only the conditional part. .collapse_cond <- function(x) { if (is.list(x) && "cond" %in% names(x)) { x[["cond"]] } else { x } } # Get fixed effects variance # #' @importFrom stats var .compute_variance_fixed <- function(vals) { with(vals, stats::var(as.vector(beta %*% t(X)))) } # Compute variance associated with a random-effects term (Johnson 2014) # #' @importFrom stats nobs .compute_variance_random <- function(terms, x, vals) { .sigma_sum <- function(Sigma) { rn <- rownames(Sigma) if (!is.null(rn)) { valid <- rownames(Sigma) %in% colnames(vals$X) if (!all(valid)) { rn <- rn[valid] Sigma <- Sigma[valid, valid] } } Z <- vals$X[, rn, drop = FALSE] Z.m <- Z %*% Sigma sum(diag(crossprod(Z.m, Z))) / n_obs(x) } if (inherits(x, "MixMod")) { .sigma_sum(vals$vc) } else { sum(sapply(vals$vc[terms], .sigma_sum)) } } # Calculate Distribution-specific variance (Nakagawa et al. 2017) .compute_variance_distribution <- function(x, var.cor, faminfo, name, verbose = TRUE) { if (inherits(x, "lme")) { sig <- x$sigma } else { sig <- attr(var.cor, "sc") } if (is.null(sig)) sig <- 1 # Distribution-specific variance depends on the model-family # and the related link-function if (faminfo$is_linear && !faminfo$is_tweedie) { dist.variance <- sig^2 } else { if (faminfo$is_binomial) { dist.variance <- switch( faminfo$link_function, logit = pi^2 / 3, probit = 1, cloglog = , clogloglink = pi^2 / 6, .badlink(faminfo$link_function, faminfo$family, verbose = verbose) ) } else if (faminfo$is_count) { dist.variance <- switch( faminfo$link_function, log = .variance_distributional(x, faminfo, sig, name = name, verbose = verbose), sqrt = 0.25, .badlink(faminfo$link_function, faminfo$family, verbose = verbose) ) } else if (faminfo$family %in% c("Gamma", "gamma")) { ## TODO needs some more checking dist.variance <- switch( faminfo$link_function, inverse = , identity = stats::family(x)$variance(sig), log = .variance_distributional(x, faminfo, sig, name = name, verbose = verbose), .badlink(faminfo$link_function, faminfo$family, verbose = verbose) ) } else if (faminfo$family == "beta") { dist.variance <- switch( faminfo$link_function, logit = .variance_distributional(x, faminfo, sig, name = name, verbose = verbose), .badlink(faminfo$link_function, faminfo$family, verbose = verbose) ) } else if (faminfo$is_tweedie) { dist.variance <- switch( faminfo$link_function, log = .variance_distributional(x, faminfo, sig, name = name, verbose = verbose), .badlink(faminfo$link_function, faminfo$family, verbose = verbose) ) } else { dist.variance <- sig } } dist.variance } # Get dispersion-specific variance .compute_variance_dispersion <- function(x, vals, faminfo, obs.terms) { if (faminfo$is_linear) { 0 } else { if (length(obs.terms) == 0) { 0 } else { .compute_variance_random(obs.terms, x = x, vals = vals) } } } # This is the core-function to calculate the distribution-specific variance # Nakagawa et al. 2017 propose three different methods, here we only rely # on the lognormal-approximation. # #' @importFrom stats family .variance_distributional <- function(x, faminfo, sig, name, verbose = TRUE) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package `lme4` needs to be installed to compute variances for mixed models.", call. = FALSE) } # lognormal-approximation of distributional variance, # see Nakagawa et al. 2017 # in general want log(1+var(x)/mu^2) null_model <- .null_model(x, verbose = verbose) # check if null-model could be computed if (!is.null(null_model)) { if (inherits(null_model, "cpglmm")) { if (!requireNamespace("cplm", quietly = TRUE)) { stop("Package 'cplm' required. Please install it.") } null_fixef <- unname(cplm::fixef(null_model)) } else { null_fixef <- unname(.collapse_cond(lme4::fixef(null_model))) } mu <- exp(null_fixef) } else { mu <- NA } if (is.na(mu)) { if (verbose) { warning("Can't calculate model's distribution-specific variance. Results are not reliable.", call. = F) } return(0) } else if (mu < 6) { if (verbose) { warning(sprintf("mu of %0.1f is too close to zero, estimate of %s may be unreliable.\n", mu, name), call. = FALSE) } } cvsquared <- tryCatch( { vv <- switch( faminfo$family, # (zero-inflated) poisson `zero-inflated poisson` = , poisson = .variance_family_poisson(x, mu, faminfo), # hurdle-poisson `hurdle poisson` = , truncated_poisson = stats::family(x)$variance(sig), # Gamma, exponential Gamma = stats::family(x)$variance(sig), # (zero-inflated) negative binomial `zero-inflated negative binomial` = , `negative binomial` = , genpois = , nbinom1 = , nbinom2 = .variance_family_nbinom(x, mu, sig, faminfo), # other distributions tweedie = .variance_family_tweedie(x, mu, sig), beta = .variance_family_beta(x, mu, sig), # default variance for non-captured distributions .variance_family_default(x, mu, verbose) ) vv / mu^2 }, error = function(x) { if (verbose) { warning("Can't calculate model's distribution-specific variance. Results are not reliable.", call. = F) } 0 } ) log1p(cvsquared) } # Get distributional variance for poisson-family .variance_family_poisson <- function(x, mu, faminfo) { if (faminfo$is_zero_inflated) { .variance_zip(x, faminfo, family_var = mu) } else { if (inherits(x, "MixMod")) { return(mu) } else if (inherits(x, "cpglmm")) { .get_cplm_family(x)$variance(mu) } else { stats::family(x)$variance(mu) } } } # Get distributional variance for beta-family .variance_family_beta <- function(x, mu, phi) { if (inherits(x, "MixMod")) { stats::family(x)$variance(mu) } else { mu * (1 - mu) / (1 + phi) } } # Get distributional variance for tweedie-family # #' @importFrom stats plogis .variance_family_tweedie <- function(x, mu, phi) { p <- unname(stats::plogis(x$fit$par["thetaf"]) + 1) phi * mu^p } # Get distributional variance for nbinom-family .variance_family_nbinom <- function(x, mu, sig, faminfo) { if (faminfo$is_zero_inflated) { if (missing(sig)) sig <- 0 .variance_zinb(x, sig, faminfo, family_var = mu * (1 + sig)) } else { if (inherits(x, "MixMod")) { if (missing(sig)) { return(rep(1e-16, length(mu))) } mu * (1 + sig) } else { stats::family(x)$variance(mu, sig) } } } # For zero-inflated negative-binomial models, the distributional variance # is based on Zuur et al. 2012 # #' @importFrom stats plogis family predict .variance_zinb <- function(model, sig, faminfo, family_var) { if (inherits(model, "glmmTMB")) { v <- stats::family(model)$variance # zi probability p <- stats::predict(model, type = "zprob") # mean of conditional distribution mu <- stats::predict(model, type = "conditional") # sigma betad <- model$fit$par["betad"] k <- switch( faminfo$family, gaussian = exp(0.5 * betad), Gamma = exp(-0.5 * betad), exp(betad) ) pvar <- (1 - p) * v(mu, k) + mu^2 * (p^2 + p) } else if (inherits(model, "MixMod")) { v <- family_var p <- stats::plogis(stats::predict(model, type_pred = "link", type = "zero_part")) mu <- stats::predict(model, type_pred = "link", type = "mean_subject") k <- sig pvar <- (1 - p) * v(mu, k) + mu^2 * (p^2 + p) } else { pvar <- family_var } mean(pvar) # pearson residuals # pred <- predict(model, type = "response") ## (1 - p) * mu # pred <- stats::predict(model, type_pred = "response", type = "mean_subject") # (insight::get_response(model) - pred) / sqrt(pvar) } # For zero-inflated poisson models, the distributional variance # is based on Zuur et al. 2012 # #' @importFrom stats plogis family predict .variance_zip <- function(model, faminfo, family_var) { if (inherits(model, "glmmTMB")) { p <- stats::predict(model, type = "zprob") mu <- stats::predict(model, type = "conditional") pvar <- (1 - p) * (mu + p * mu^2) } else if (inherits(model, "MixMod")) { p <- stats::plogis(stats::predict(model, type_pred = "link", type = "zero_part")) mu <- stats::predict(model, type = "mean_subject") pvar <- (1 - p) * (mu + p * mu^2) } else { pvar <- family_var } mean(pvar) } # Get distribution-specific variance for general and # undefined families / link-functions .variance_family_default <- function(x, mu, verbose) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package `lme4` needs to be installed to compute variances for mixed models.", call. = FALSE) } tryCatch( { if (inherits(x, "merMod")) { mu * (1 + mu / lme4::getME(x, "glmer.nb.theta")) } else if (inherits(x, "MixMod")) { stats::family(x)$variance(mu) } else { mu * (1 + mu / x$theta) } }, error = function(x) { if (verbose) { warning("Can't calculate model's distribution-specific variance. Results are not reliable.", call. = F) } 0 } ) } # Null model is needed to calculate the mean for the model's response, # which we need to compute the distribution-specific variance # (see .variance_distributional()) # #' @importFrom stats as.formula update reformulate .null_model <- function(model, verbose = TRUE) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package `lme4` needs to be installed to compute variances for mixed models.", call. = FALSE) } if (inherits(model, "MixMod")) { nullform <- stats::as.formula(paste(find_response(model), "~ 1")) null.model <- stats::update(model, fixed = nullform) } else if (inherits(model, "cpglmm")) { nullform <- find_formula(model)[["random"]] null.model <- stats::update(model, nullform) } else { f <- stats::formula(model) resp <- find_response(model) re.terms <- paste0("(", sapply(lme4::findbars(f), .safe_deparse), ")") nullform <- stats::reformulate(re.terms, response = resp) null.model <- tryCatch( { stats::update(model, nullform) }, error = function(e) { msg <- e$message if (verbose) { if (grepl("(^object)(.*)(not found$)", msg)) { insight::print_color("Can't calculate null-model. Probably the data that was used to fit the model cannot be found.\n", "red") } else if (grepl("^could not find function", msg)) { insight::print_color("Can't calculate null-model. Probably you need to load the package that was used to fit the model.\n", "red") } } return(NULL) } ) } null.model } # return existence of random slopes .random_slopes_in_fixed <- function(model) { rs <- find_random_slopes(model) fe <- find_predictors(model, effects = "fixed", component = "all") # if model has no random slopes, there are no random slopes that # are *not* present as fixed effects if (is.null(rs)) { return(TRUE) } # make sure we have identical subcomponents between random and # fixed effects fe <- .compact_list(fe[c("conditional", "zero_inflated")]) if (length(rs) > length(fe)) rs <- rs[1:length(fe)] if (length(fe) > length(rs)) fe <- fe[1:length(rs)] all(mapply(function(r, f) all(r %in% f), rs, fe, SIMPLIFY = TRUE)) } # random intercept-variances, i.e. # between-subject-variance (tau 00) .between_subject_variance <- function(vals, x) { # retrieve only intercepts if (inherits(x, "MixMod")) { vars <- lapply(vals$vc, function(i) i)[1] } else { vars <- lapply(vals$vc, function(i) i[1]) } sapply(vars, function(i) i) } # random slope-variances (tau 11) .random_slope_variance <- function(vals, x) { if (inherits(x, "MixMod")) { diag(vals$vc)[-1] } else if (inherits(x, "lme")) { unlist(lapply(vals$vc, function(x) diag(x)[-1])) } else { unlist(lapply(vals$vc, function(x) diag(x)[-1])) } } # slope-intercept-correlations (rho 01) .random_slope_intercept_corr <- function(vals, x) { if (inherits(x, "lme")) { rho01 <- unlist(sapply(vals$vc, function(i) attr(i, "cor_slope_intercept"))) if (is.null(rho01)) { vc <- lme4::VarCorr(x) if ("Corr" %in% colnames(vc)) { rho01 <- as.vector(suppressWarnings(na.omit(as.numeric(vc[, "Corr"])))) } } rho01 } else { corrs <- lapply(vals$vc, attr, "correlation") rho01 <- sapply(corrs, function(i) { if (!is.null(i)) { i[-1, 1] } else { NULL } }) unlist(rho01) } } insight/R/utils_model_info.R0000644000176200001440000001762213615526274015621 0ustar liggesusers.make_family <- function(x, fitfam = "gaussian", zero.inf = FALSE, hurdle = FALSE, logit.link = FALSE, multi.var = FALSE, link.fun = "identity", ...) { # create logical for family binom_fam <- fitfam %in% c("bernoulli", "binomial", "quasibinomial", "binomialff") | grepl("\\Qbinomial\\E", fitfam, ignore.case = TRUE) poisson_fam <- fitfam %in% c("poisson", "quasipoisson", "genpois", "ziplss") | grepl("\\Qpoisson\\E", fitfam, ignore.case = TRUE) neg_bin_fam <- grepl("\\Qnegative binomial\\E", fitfam, ignore.case = TRUE) | grepl("\\Qnbinom\\E", fitfam, ignore.case = TRUE) | grepl("\\Qnegbin\\E", fitfam, ignore.case = TRUE) | grepl("\\Qnzbinom\\E", fitfam, ignore.case = TRUE) | grepl("\\Qgenpois\\E", fitfam, ignore.case = TRUE) | grepl("\\Qnegbinomial\\E", fitfam, ignore.case = TRUE) | grepl("\\Qneg_binomial\\E", fitfam, ignore.case = TRUE) | fitfam %in% c("ztnbinom", "nbinom") beta_fam <- inherits(x, "betareg") | fitfam %in% c( "beta", "Beta", "betabinomial", "Beta Inflated", "Zero Inflated Beta", "Beta Inflated zero", "Beta Inflated one" ) betabin_fam <- inherits(x, "BBreg") | fitfam %in% "betabinomial" dirichlet_fam <- inherits(x, "DirichletRegModel") | fitfam %in% "dirichlet" ## TODO beta-binomial = binomial? if (betabin_fam) binom_fam <- TRUE exponential_fam <- fitfam %in% c("Gamma", "gamma", "weibull") linear_model <- (!binom_fam & !exponential_fam & !poisson_fam & !neg_bin_fam & !logit.link) || fitfam %in% c("Student's-t", "t Family", "gaussian", "Gaussian") || grepl("(\\st)$", fitfam) tweedie_fam <- grepl("^(tweedie|Tweedie)", fitfam) tweedie_model <- (linear_model && tweedie_fam) || inherits(x, c("cpglm", "cpglmm")) zero.inf <- zero.inf | fitfam == "ziplss" | grepl("\\Qzero_inflated\\E", fitfam, ignore.case = TRUE) | grepl("\\Qzero-inflated\\E", fitfam, ignore.case = TRUE) | grepl("\\Qneg_binomial\\E", fitfam, ignore.case = TRUE) | grepl("\\Qhurdle\\E", fitfam, ignore.case = TRUE) | grepl("^(zt|zi|za|hu)", fitfam, perl = TRUE) | grepl("^truncated", fitfam, perl = TRUE) hurdle <- hurdle | grepl("\\Qhurdle\\E", fitfam, ignore.case = TRUE) | grepl("^hu", fitfam, perl = TRUE) | grepl("^truncated", fitfam, perl = TRUE) | fitfam == "ztnbinom" | fitfam %in% c("truncpoiss", "truncnbinom", "truncnbinom1") is.ordinal <- inherits(x, c("svyolr", "polr", "clm", "clm2", "clmm", "gmnl", "mixor", "mlogit", "DirichletRegModel", "multinom", "LORgee", "brmultinom")) | fitfam %in% c("cumulative", "cratio", "sratio", "acat", "ordinal", "multinomial", "dirichlet") is.multinomial <- inherits(x, c("gmnl", "mlogit", "DirichletRegModel", "multinom", "brmultinom")) | fitfam %in% c("cratio", "sratio", "acat", "multinomial", "dirichlet") is.categorical <- fitfam == "categorical" is.bayes <- inherits(x, c( "brmsfit", "stanfit", "MCMCglmm", "stanreg", "stanmvreg", "bmerMod", "BFBayesFactor", "bamlss", "bayesx", "mcmc" )) is.survival <- inherits(x, c("aareg", "survreg", "survfit", "survPresmooth", "flexsurvreg", "coxph", "coxme")) # check if we have binomial models with trials instead of binary outcome # and check if we have truncated or censored brms-regression is.trial <- FALSE is.censored <- FALSE is.truncated <- FALSE if (inherits(x, "brmsfit") && is.null(stats::formula(x)$responses)) { rv <- tryCatch( { .safe_deparse(stats::formula(x)$formula[[2L]]) }, error = function(x) { NULL } ) if (!is.null(rv)) { is.trial <- .trim(sub("(.*)\\|(.*)\\(([^,)]*).*", "\\2", rv)) %in% c("trials", "resp_trials") is.censored <- grepl("(.*)\\|(.*)cens\\(", rv) is.truncated <- grepl("(.*)\\|(.*)trunc\\(", rv) } } if (binom_fam && !inherits(x, "brmsfit")) { is.trial <- tryCatch( { rv <- .safe_deparse(stats::formula(x)[[2L]]) grepl("cbind\\((.*)\\)", rv) }, error = function(x) { FALSE } ) } dots <- list(...) if (.obj_has_name(dots, "no_terms") && isTRUE(dots$no_terms)) { model_terms <- NULL } else { if (inherits(x, "mcmc")) { model_terms <- find_parameters(x) } else { model_terms <- tryCatch( { find_variables(x, effects = "all", component = "all", flatten = FALSE) }, error = function(x) { NULL } ) } } if (inherits(x, "htest")) { if (grepl("t-test", x$method)) { is_ttest <- TRUE is_correlation <- FALSE } else { is_ttest <- FALSE is_correlation <- TRUE } } else { is_ttest <- FALSE is_correlation <- FALSE } is_meta <- FALSE if (inherits(x, "BFBayesFactor")) { is_ttest <- FALSE is_correlation <- FALSE obj_type <- .classify_BFBayesFactor(x) if (obj_type == "correlation") { is_correlation <- TRUE } else if (obj_type == "ttest") { is_ttest <- TRUE } else if (obj_type == "meta") { is_meta <- TRUE } } if (inherits(x, "rma")) is_meta <- TRUE list( is_binomial = binom_fam & !neg_bin_fam, is_count = poisson_fam | neg_bin_fam, is_poisson = poisson_fam, is_negbin = neg_bin_fam, is_beta = beta_fam, is_betabinomial = betabin_fam, is_dirichlet = dirichlet_fam, is_exponential = exponential_fam, is_logit = logit.link, is_probit = link.fun == "probit", is_censored = inherits(x, c("tobit", "crch", "censReg")) | is.censored | is.survival, is_truncated = inherits(x, "truncreg") | is.truncated, is_survival = is.survival, is_linear = linear_model, is_tweedie = tweedie_model, is_zeroinf = zero.inf, is_zero_inflated = zero.inf, is_hurdle = hurdle, is_ordinal = is.ordinal, is_cumulative = is.ordinal, is_multinomial = is.multinomial | is.categorical, is_categorical = is.categorical, is_mixed = !is.null(find_random(x)), is_multivariate = multi.var, is_trial = is.trial, is_bayesian = is.bayes, is_anova = inherits(x, c("aov", "aovlist", "MANOVA", "RM")), is_ttest = is_ttest, is_correlation = is_correlation, is_meta = is_meta, link_function = link.fun, family = fitfam, n_obs = n_obs(x), model_terms = model_terms ) } .get_ordinal_link <- function(x) { switch( x$link, logistic = "logit", cloglog = "log", x$link ) } #' @importFrom stats gaussian binomial Gamma .make_tobit_family <- function(x, dist = NULL) { if (is.null(dist)) { if (inherits(x, "flexsurvreg")) { dist <- parse(text = .safe_deparse(x$call))[[1]]$dist } else { dist <- x$dist } } f <- switch( dist, gaussian = stats::gaussian("identity"), logistic = stats::binomial("logit"), llogis = , loglogistic = stats::binomial("log"), lnorm = , lognormal = stats::gaussian("log"), gompertz = stats::Gamma("log"), gamma = , gengamma = , gengamma.orig = stats::Gamma(), exponential = , exp = , weibull = stats::Gamma("log"), stats::gaussian("identity") ) if (dist == "weibull") f$family <- "weibull" f } .classify_BFBayesFactor <- function(x) { if (!requireNamespace("BayesFactor", quietly = TRUE)) { stop("This function needs `BayesFactor` to be installed.") } if (any(class(x@denominator) %in% c("BFcorrelation"))) { "correlation" } else if (any(class(x@denominator) %in% c("BFoneSample", "BFindepSample"))) { "ttest" } else if (any(class(x@denominator) %in% c("BFmetat"))) { "meta" } else if (any(class(x@denominator) %in% c("BFlinearModel"))) { "linear" } else { class(x@denominator) } } insight/R/get_varcov.R0000644000176200001440000003144013613276575014423 0ustar liggesusers#' @title Get variance-covariance matrix from models #' #' @description Returns the variance-covariance, as retrieved by #' \code{stats::vcov()}, but works for more model objects that probably #' don't provide a \code{vcov()}-method. #' @name get_varcov #' #' @param x A model. #' @param component Should the complete variance-covariance matrix of the model #' be returned, or only for specific model components only (like count or #' zero-inflated model parts)? Applies to models with zero-inflated component, #' or models with precision (e.g. \code{betareg}) component. \code{component} #' may be one of \code{"conditional"}, \code{"zi"}, \code{"zero-inflated"}, #' \code{"precision"}, or \code{"all"}. May be abbreviated. Note that the #' \emph{conditional} component is also called \emph{count} or \emph{mean} #' component, depending on the model. #' @param effects Should the complete variance-covariance matrix of the model #' be returned, or only for specific model parameters only? Currently only #' applies to models of class \code{mixor}. #' @param ... Currently not used. #' #' @note \code{get_varcov()} tries to return the nearest positive definite matrix #' in case of a negative variance-covariance matrix. #' #' @return The variance-covariance matrix, as \code{matrix}-object. #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' get_varcov(m) #' @importFrom stats vcov #' @export get_varcov <- function(x, ...) { UseMethod("get_varcov") } # Default models ---------------------------------------------------- #' @export get_varcov.default <- function(x, ...) { vc <- suppressWarnings(stats::vcov(x)) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.maxLik <- get_varcov.default # models with special components --------------------------------------------- #' @rdname get_varcov #' @export get_varcov.betareg <- function(x, component = c("conditional", "precision", "all"), ...) { component <- match.arg(component) vc <- switch( component, "conditional" = stats::vcov(object = x, model = "mean"), "precision" = stats::vcov(object = x, model = "precision"), stats::vcov(object = x) ) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @rdname get_varcov #' @export get_varcov.DirichletRegModel <- function(x, component = c("conditional", "precision", "all"), ...) { component <- match.arg(component) if (x$parametrization == "common") { vc <- stats::vcov(x) } else { if (component == "conditional") { vc <- stats::vcov(x) keep <- grepl("^(?!\\(phi\\))", rownames(vc), perl = TRUE) vc <- vc[keep, keep] } else if (component == "precision") { vc <- stats::vcov(x) keep <- grepl("^\\(phi\\)", rownames(vc), perl = TRUE) vc <- vc[keep, keep] } else { vc <- stats::vcov(x) } } if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @rdname get_varcov #' @export get_varcov.clm2 <- function(x, component = c("all", "conditional", "scale"), ...) { component <- match.arg(component) n_intercepts <- length(x$xi) n_location <- length(x$beta) n_scale <- length(x$zeta) vc <- stats::vcov(x) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } range <- switch( component, "all" = 1:(n_scale + n_intercepts + n_location), "conditional" = 1:(n_intercepts + n_location), "scale" = (1 + n_intercepts + n_location):(n_scale + n_intercepts + n_location) ) vc <- vc[range, range] .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.clmm2 <- get_varcov.clm2 #' @export get_varcov.glmx <- function(x, component = c("all", "conditional", "extra"), ...) { component <- match.arg(component) vc <- stats::vcov(object = x) if (component != "all") { keep <- match(insight::find_parameters(x)[[component]], rownames(vc)) vc <- vc[keep, keep] } if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @rdname get_varcov #' @export get_varcov.truncreg <- function(x, component = c("conditional", "all"), ...) { component <- match.arg(component) vc <- stats::vcov(x) if (component == "conditional") { vc <- vc[1:(nrow(vc) - 1), 1:(ncol(vc) - 1)] } if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @rdname get_varcov #' @export get_varcov.gamlss <- function(x, component = c("conditional", "all"), ...) { component <- match.arg(component) vc <- suppressWarnings(stats::vcov(x)) if (component == "conditional") { cond_pars <- length(find_parameters(x)$conditional) vc <- as.matrix(vc)[1:cond_pars, 1:cond_pars] } if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } # Zero-Inflated models ---------------------------------------------------- #' @rdname get_varcov #' @export get_varcov.hurdle <- function(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) { component <- match.arg(component) vc <- switch( component, "conditional" = stats::vcov(object = x, model = "count"), "zi" = , "zero_inflated" = stats::vcov(object = x, model = "zero"), stats::vcov(object = x) ) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.zeroinfl <- get_varcov.hurdle #' @export get_varcov.zerocount <- get_varcov.hurdle # Zero-Inflated mixed models ------------------------------------------------ #' @rdname get_varcov #' @export get_varcov.MixMod <- function(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) { component <- match.arg(component) vc <- switch( component, "conditional" = stats::vcov(x, parm = "fixed-effects"), "zi" = , "zero_inflated" = stats::vcov(x, parm = "zero_part"), stats::vcov(x) ) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @rdname get_varcov #' @export get_varcov.glmmTMB <- function(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) { component <- match.arg(component) vc <- switch( component, "conditional" = stats::vcov(x)[["cond"]], "zi" = , "zero_inflated" = stats::vcov(x)[["zi"]], stats::vcov(x, full = TRUE) ) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } # Bayesian models ------------------------------------------------ #' @rdname get_varcov #' @export get_varcov.brmsfit <- function(x, component = c("conditional", "zero_inflated", "zi", "all"), ...) { component <- match.arg(component) params <- find_parameters(x, effects = "fixed", component = component, flatten = TRUE) params <- gsub("^b_", "", params) vc <- stats::vcov(x)[params, params] if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } # Other models with special handling ----------------------------------------- #' @export get_varcov.rq <- function(x, ...) { s <- summary(x, covariance = TRUE) vc <- as.matrix(s$cov) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.crq <- get_varcov.rq #' @export get_varcov.nlrq <- get_varcov.rq #' @export get_varcov.flexsurvreg <- function(x, ...) { pars <- find_parameters(x, flatten = TRUE) vc <- as.matrix(stats::vcov(x))[pars, pars] if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.mixed <- function(x, ...) { vc <- as.matrix(stats::vcov(x$full_model)) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.cpglmm <- function(x, ...) { vc <- as.matrix(x@vcov) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.cpglm <- get_varcov.cpglmm #' @export get_varcov.cglm <- function(x, ...) { vc <- as.matrix(x$var) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @rdname get_varcov #' @export get_varcov.mixor <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) params <- find_parameters(x, effects = effects, flatten = TRUE) vc <- as.matrix(stats::vcov(x))[params, params] if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.gamm <- function(x, ...) { vc <- stats::vcov(x$gam) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.list <- function(x, ...) { if ("gam" %in% names(x)) { vc <- stats::vcov(x$gam) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } } #' @export get_varcov.BBmm <- function(x, ...) { vc <- x$fixed.vcov if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.BBreg <- function(x, ...) { vc <- x$vcov if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.feis <- function(x, ...) { vc <- x$vcov if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.glimML <- function(x, ...) { if (!requireNamespace("aod", quietly = TRUE)) { stop("Package 'aod' required for this function to work. Please install it.") } vc <- aod::vcov(x) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.vglm <- function(x, ...) { if (!requireNamespace("VGAM", quietly = TRUE)) { stop("Package 'VGAM' required for this function to work. Please install it.") } vc <- VGAM::vcov(x) if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.vgam <- get_varcov.vglm #' @export get_varcov.geeglm <- function(x, ...) { vc <- summary(x)$cov.unscaled if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.tobit <- function(x, ...) { coef_names <- find_parameters(x, flatten = TRUE) vc <- stats::vcov(x)[coef_names, coef_names] if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.lmRob <- function(x, ...) { vc <- x$cov if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.glmRob <- get_varcov.lmRob #' @export get_varcov.gee <- function(x, ...) { vc <- x$naive.variance if (.is_negativ_matrix(vc)) { vc <- .fix_negative_matrix(vc) } .remove_backticks_from_matrix_names(as.matrix(vc)) } #' @export get_varcov.LORgee <- get_varcov.gee # helper-functions ----------------------------------------------------- .is_negativ_matrix <- function(x) { if (is.matrix(x) && (nrow(x) == ncol(x))) { rv <- tryCatch( { eigenvalues <- eigen(x, only.values = TRUE)$values eigenvalues[abs(eigenvalues) < 1e-07] <- 0 any(eigenvalues <= 0) }, error = function(e) { FALSE } ) } else { rv <- FALSE } rv } .fix_negative_matrix <- function(m) { if (requireNamespace("Matrix", quietly = TRUE)) { as.matrix(Matrix::nearPD(m)$mat) } else { m } } insight/R/get_data.R0000644000176200001440000005154413613305554014031 0ustar liggesusers#' @title Get the data that was used to fit the model #' @name get_data #' #' @description This functions tries to get the data that was used to fit the #' model and returns it as data frame. #' #' @param effects Should model data for fixed effects, random effects #' or both be returned? Only applies to mixed models. #' #' @inheritParams find_predictors #' @inheritParams find_formula #' #' @return The data that was used to fit the model. #' #' @note Unlike \code{model.frame()}, which may contain transformed variables #' (e.g. if \code{poly()} or \code{scale()} was used inside the formula to #' specify the model), \code{get_data()} aims at returning the "original", #' untransformed data. #' #' @examples #' data(cbpp, package = "lme4") #' cbpp$trials <- cbpp$size - cbpp$incidence #' m <- glm(cbind(incidence, trials) ~ period, data = cbpp, family = binomial) #' head(get_data(m)) #' @importFrom stats model.frame na.omit #' @export get_data <- function(x, ...) { UseMethod("get_data") } # default method ------------------------------------------------------ #' @export get_data.default <- function(x, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) } mf <- tryCatch( { if (inherits(x, "Zelig-relogit")) { .get_zelig_relogit_frame(x) } else { stats::model.frame(x) } }, error = function(x) { NULL } ) if (is.null(mf)) { mf <- tryCatch( { .get_data_from_env(x)[, find_variables(x, flatten = TRUE), drop = FALSE] }, error = function(x) { NULL } ) } .prepare_get_data(x, mf) } #' @export get_data.data.frame <- function(x, ...) { x } # classical and survival models ----------------------------------------------- #' @rdname get_data #' @export get_data.gee <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { dat <- .get_data_from_env(x) switch( effects, all = dat[, find_variables(x, flatten = TRUE), drop = FALSE], fixed = dat[, find_variables(x, effects = "fixed", flatten = TRUE), drop = FALSE], random = dat[, find_random(x, flatten = TRUE), drop = FALSE] ) }, error = function(x) { NULL } ) .prepare_get_data(x, stats::na.omit(mf)) } #' @rdname get_data #' @export get_data.rqss <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) mf <- tryCatch( { dat <- .get_data_from_env(x) dat[, find_variables(x, effects = "all", component = component, flatten = TRUE), drop = FALSE] }, error = function(x) { NULL } ) .prepare_get_data(x, stats::na.omit(mf)) } #' @export get_data.gls <- function(x, ...) { mf <- tryCatch( { dat <- .get_data_from_env(x) data_columns <- intersect(colnames(dat), find_variables(x, flatten = TRUE)) dat[, data_columns, drop = FALSE] }, error = function(x) { NULL } ) .prepare_get_data(x, stats::na.omit(mf)) } #' @export get_data.survfit <- get_data.gls #' @export get_data.aareg <- get_data.gls #' @export get_data.complmrob <- get_data.gls #' @export get_data.nlrq <- get_data.gls # zero-inflated models ------------------------------------------------------- #' @rdname get_data #' @export get_data.hurdle <- function(x, component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ...) { component <- match.arg(component) .return_zeroinf_data(x, component) } #' @export get_data.zeroinfl <- get_data.hurdle #' @export get_data.zerotrunc <- get_data.default # mixed models ------------------------------------------------------------- #' @rdname get_data #' @export get_data.glmmTMB <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ...) { effects <- match.arg(effects) component <- match.arg(component) model.terms <- find_variables(x, effects = "all", component = "all", flatten = FALSE) mf <- tryCatch( { stats::model.frame(x) }, error = function(x) { NULL } ) mf <- .prepare_get_data(x, mf) # add variables from other model components mf <- .add_zeroinf_data(x, mf, model.terms$dispersion) mf <- .add_zeroinf_data(x, mf, model.terms$zero_inflated) mf <- .add_zeroinf_data(x, mf, model.terms$zero_inflated_random) .return_data(x, mf, effects, component, model.terms) } #' @rdname get_data #' @export get_data.merMod <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { switch( effects, fixed = stats::model.frame(x, fixed.only = TRUE), all = stats::model.frame(x, fixed.only = FALSE), random = stats::model.frame(x, fixed.only = FALSE)[, find_random(x, split_nested = TRUE, flatten = TRUE), drop = FALSE] ) }, error = function(x) { NULL } ) .prepare_get_data(x, mf, effects) } #' @export get_data.MANOVA <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { switch( effects, fixed = .remove_column(x$input$data, x$input$subject), all = x$input$data, random = x$input$data[, x$input$subject, drop = FALSE] ) }, error = function(x) { NULL } ) .prepare_get_data(x, mf, effects) } #' @export get_data.RM <- get_data.MANOVA #' @export get_data.cpglmm <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) dat <- stats::model.frame(x) mf <- tryCatch( { switch( effects, fixed = dat[, find_predictors(x, effects = "fixed", flatten = TRUE), drop = FALSE], all = dat, random = dat[, find_random(x, split_nested = TRUE, flatten = TRUE), drop = FALSE] ) }, error = function(x) { NULL } ) .prepare_get_data(x, mf, effects) } #' @export get_data.mixor <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { switch( effects, fixed = stats::model.frame(x), all = cbind(stats::model.frame(x), x$id), random = data.frame(x$id) ) }, error = function(x) { NULL } ) fix_cn <- which(colnames(mf) %in% c("x.id", "x$id")) colnames(mf)[fix_cn] <- deparse(x$call$id) .prepare_get_data(x, mf, effects) } #' @rdname get_data #' @export get_data.glmmadmb <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) fixed_data <- x$frame random_data <- .get_data_from_env(x)[, find_random(x, split_nested = TRUE, flatten = TRUE), drop = FALSE] mf <- tryCatch( { switch( effects, fixed = fixed_data, all = cbind(fixed_data, random_data), random = random_data ) }, error = function(x) { NULL } ) .prepare_get_data(x, mf, effects) } #' @rdname get_data #' @export get_data.rlmerMod <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) .get_data_from_modelframe(x, stats::model.frame(x), effects) } #' @rdname get_data #' @export get_data.clmm <- get_data.rlmerMod #' @rdname get_data #' @export get_data.mixed <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) .get_data_from_modelframe(x, x$data, effects) } #' @rdname get_data #' @export get_data.lme <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) dat <- tryCatch( { x$data }, error = function(x) { NULL } ) stats::na.omit(.get_data_from_modelframe(x, dat, effects)) } #' @rdname get_data #' @export get_data.MixMod <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ...) { effects <- match.arg(effects) component <- match.arg(component) tryCatch( { fitfram <- x$model_frames$mfX if (!.is_empty_object(x$model_frames$mfZ)) { fitfram <- .merge_dataframes(x$model_frames$mfZ, fitfram, replace = TRUE) } if (!.is_empty_object(x$model_frames$mfX_zi)) { fitfram <- .merge_dataframes(x$model_frames$mfX_zi, fitfram, replace = TRUE) } if (!.is_empty_object(x$model_frames$mfZ_zi)) { fitfram <- .merge_dataframes(x$model_frames$mfZ_zi, fitfram, replace = TRUE) } fitfram$grp__id <- unlist(x$id) colnames(fitfram)[ncol(fitfram)] <- x$id_name[1] # test... fitfram <- .prepare_get_data(x, fitfram) model.terms <- find_variables(x, effects = "all", component = "all", flatten = FALSE) .return_data(x, mf = fitfram, effects, component, model.terms) }, error = function(x) { NULL } ) } #' @export get_data.BBmm <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { dat <- .get_data_from_env(x)[, find_variables(x, flatten = TRUE), drop = FALSE] switch( effects, all = dat[, find_variables(x, flatten = TRUE), drop = FALSE], fixed = dat[, find_variables(x, effects = "fixed", flatten = TRUE), drop = FALSE], random = dat[, find_random(x, flatten = TRUE), drop = FALSE] ) }, error = function(x) { x$X } ) .prepare_get_data(x, stats::na.omit(mf)) } #' @export get_data.glimML <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) dat <- x@data mf <- switch( effects, all = dat[, find_variables(x, flatten = TRUE), drop = FALSE], fixed = dat[, find_variables(x, effects = "fixed", flatten = TRUE), drop = FALSE], random = dat[, find_random(x, flatten = TRUE), drop = FALSE] ) .prepare_get_data(x, stats::na.omit(mf)) } # sem models ------------------------------------- #' @export get_data.lavaan <- function(x, ...) { mf <- tryCatch( { .get_S4_data_from_env(x) }, error = function(x) { NULL } ) .prepare_get_data(x, stats::na.omit(mf)) } #' @export get_data.blavaan <- get_data.lavaan # additive models (gam) ------------------------------------- #' @export get_data.vgam <- function(x, ...) { mf <- tryCatch( { get(x@misc$dataname, envir = parent.frame())[, find_variables(x, flatten = TRUE), drop = FALSE] }, error = function(x) { NULL } ) .prepare_get_data(x, mf) } #' @export get_data.gamm <- function(x, ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) mf <- stats::model.frame(x) .prepare_get_data(x, mf) } #' @export get_data.gamlss <- function(x, ...) { mf <- tryCatch( { elements <- c("mu", "sigma", "nu", "tau") mf_list <- .compact_list(lapply(elements, function(e) { if (paste0(e, ".x") %in% names(x)) { stats::model.frame(x, what = e) } else { NULL } })) mf_data <- mf_list[[1]] if (length(mf_list) > 1) { for (i in 2:length(mf_list)) { cn <- setdiff(colnames(mf_list[[i]]), colnames(mf_data)) if (length(cn)) mf_data <- cbind(mf_data, mf_list[[i]][, cn, drop = FALSE]) } } mf_data }, error = function(x) { NULL } ) .prepare_get_data(x, mf, effects = "all") } # fixed effects and panel regression -------------------------------------- #' @export get_data.felm <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) .get_data_from_modelframe(x, stats::model.frame(x), effects) } #' @export get_data.feis <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { .get_data_from_env(x) }, error = function(x) { stats::model.frame(x) } ) .get_data_from_modelframe(x, mf, effects) } #' @export get_data.fixest <- function(x, ...) { mf <- .get_data_from_env(x) .get_data_from_modelframe(x, mf, effects = "all") } #' @export get_data.feglm <- function(x, ...) { mf <- as.data.frame(x$data) .get_data_from_modelframe(x, mf, effects = "all") } #' @export get_data.plm <- function(x, ...) { mf <- stats::model.frame(x) model_terms <- find_variables(x, effects = "all", component = "all", flatten = TRUE) cn <- colnames(mf) mf <- as.data.frame(lapply(mf, as.vector)) colnames(mf) <- clean_names(cn) # find index variables index <- eval(parse(text = .safe_deparse(x$call))[[1]]$index) # try to get index variables from orignal data if (!is.null(index)) { original_data <- .get_data_from_env(x) keep <- intersect(index, colnames(original_data)) if (length(keep)) { mf <- cbind(mf, original_data[, keep, drop = FALSE]) model_terms <- c(model_terms, keep) } } .prepare_get_data(x, mf[, model_terms, drop = FALSE]) } #' @export get_data.wbm <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- stats::model.frame(x) # dat <- as.data.frame(x@orig_data) if (effects == "random") { return(stats::na.omit(mf[, unique(find_random(x, split_nested = TRUE, flatten = TRUE)), drop = FALSE])) } resp.col <- which(colnames(mf) == find_response(x)) mf <- mf[, c(resp.col, (1:ncol(mf))[-resp.col])] .prepare_get_data(x, stats::na.omit(mf)) } #' @export get_data.wbgee <- get_data.wbm #' @export get_data.ivreg <- function(x, ...) { mf <- stats::model.frame(x) cn <- clean_names(colnames(mf)) ft <- find_variables(x, flatten = TRUE) remain <- setdiff(ft, cn) if (.is_empty_object(remain)) { final_mf <- mf } else { final_mf <- tryCatch( { dat <- .get_data_from_env(x) cbind(mf, dat[, remain, drop = FALSE]) }, error = function(x) { NULL } ) } .prepare_get_data(x, stats::na.omit(final_mf)) } #' @export get_data.iv_robust <- get_data.ivreg # Bayesian regression --------------------------------------------------- #' @rdname get_data #' @export get_data.brmsfit <- function(x, effects = c("all", "fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated"), ...) { effects <- match.arg(effects) component <- match.arg(component) model.terms <- find_variables(x, effects = "all", component = "all", flatten = FALSE) mf <- stats::model.frame(x) if (.is_multi_membership(x)) { model.terms <- lapply(model.terms, .clean_brms_mm) rs <- setdiff(unname(unlist(find_random_slopes(x))), unname(unlist(model.terms))) if (!.is_empty_object(rs)) model.terms$random <- c(rs, model.terms$random) } .return_data( x, .prepare_get_data(x, mf, effects = effects), effects, component, model.terms, is_mv = is_multivariate(x) ) } #' @rdname get_data #' @export get_data.stanreg <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) model.terms <- find_variables(x, effects = "all", component = "all", flatten = FALSE) mf <- stats::model.frame(x) .return_data( x, .prepare_get_data(x, mf, effects = effects), effects, component = "all", model.terms, is_mv = is_multivariate(x) ) } #' @export get_data.BFBayesFactor <- function(x, ...) { x@data } #' @rdname get_data #' @export get_data.MCMCglmm <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { env_dataframes <- names(which(unlist(eapply(.GlobalEnv, is.data.frame)))) pv <- find_predictors(x, effects = effects, component = "all", flatten = TRUE) matchframe <- unlist(lapply(env_dataframes, function(.x) { dat <- get(.x) all(pv %in% colnames(dat)) })) mf <- env_dataframes[matchframe][1] if (!is.na(mf)) { dat <- get(mf) switch( effects, fixed = dat[, setdiff(colnames(dat), find_random(x, flatten = T)), drop = FALSE], all = dat, random = dat[, find_random(x, flatten = TRUE), drop = FALSE] ) } else { NULL } }, error = function(x) { NULL } ) .prepare_get_data(x, mf, effects = effects) } #' @export get_data.stanmvreg <- function(x, ...) { mf <- tryCatch( { out <- data.frame() for (i in stats::model.frame(x)) { out <- .merge_dataframes(out, i) } out }, error = function(x) { NULL } ) .prepare_get_data(x, mf) } # other models ------------------------------------------------------ #' @export get_data.DirichletRegModel <- function(x, ...) { mf <- x$data resp <- sapply(x$data, inherits, "DirichletRegData") .prepare_get_data(x, mf[!resp]) } #' @export get_data.vglm <- function(x, ...) { mf <- tryCatch( { if (!length(x@model)) { env <- environment(x@terms$terms) if (is.null(env)) env <- parent.frame() fcall <- x@call fcall$method <- "model.frame" fcall$smart <- FALSE eval(fcall, env, parent.frame()) } else { x@model } }, error = function(x) { NULL } ) .prepare_get_data(x, mf) } #' @export get_data.biglm <- function(x, ...) { mf <- stats::model.frame(x) .prepare_get_data(x, mf) } #' @export get_data.bigglm <- get_data.biglm #' @export get_data.LORgee <- function(x, effects = c("all", "fixed", "random"), ...) { effects <- match.arg(effects) mf <- tryCatch( { dat <- .get_data_from_env(x)[, find_variables(x, flatten = TRUE), drop = FALSE] switch( effects, all = dat[, find_variables(x, flatten = TRUE), drop = FALSE], fixed = dat[, find_variables(x, effects = "fixed", flatten = TRUE), drop = FALSE], random = dat[, find_random(x, flatten = TRUE), drop = FALSE] ) }, error = function(x) { stats::model.frame(x) } ) .prepare_get_data(x, stats::na.omit(mf)) } #' @export get_data.gmnl <- function(x, ...) { mf <- tryCatch( { x$mf }, error = function(x) { NULL } ) .prepare_get_data(x, mf) } #' @export get_data.gbm <- function(x, ...) { mf <- tryCatch( { get(.safe_deparse(x$call$data), envir = parent.frame())[, find_variables(x, flatten = TRUE), drop = FALSE] }, error = function(x) { stats::model.frame(x) } ) .get_data_from_modelframe(x, mf, effects = "all") } #' @export get_data.tobit <- function(x, ...) { dat <- .get_data_from_env(x) ft <- find_variables(x, flatten = TRUE) remain <- intersect(ft, colnames(dat)) .prepare_get_data(x, stats::na.omit(dat[, remain, drop = FALSE])) } #' @export get_data.clmm2 <- function(x, ...) { mf <- tryCatch( { data_complete <- x$location data_scale <- x$scale if (!is.null(data_scale)) { remain <- setdiff(colnames(data_scale), colnames(data_complete)) if (length(remain)) data_complete <- cbind(data_complete, data_scale[, remain, drop = FALSE]) } data_complete <- cbind(data_complete, x$grFac) colnames(data_complete)[ncol(data_complete)] <- unlist(.find_random_effects(x, f = find_formula(x), split_nested = TRUE)) data_complete }, error = function(x) { NULL } ) .prepare_get_data(x, mf) } #' @export get_data.clm2 <- function(x, ...) { mf <- tryCatch( { data_complete <- x$location data_scale <- x$scale if (!is.null(data_scale)) { remain <- setdiff(colnames(data_scale), colnames(data_complete)) if (length(remain)) data_complete <- cbind(data_complete, data_scale[, remain, drop = FALSE]) } data_complete }, error = function(x) { NULL } ) .prepare_get_data(x, mf) } #' @export get_data.bracl <- function(x, ...) { mf <- stats::model.frame(x) suppressWarnings(.prepare_get_data(x, mf)) } #' @export get_data.rma <- function(x, ...) { mf <- tryCatch( { .get_data_from_env(x) }, error = function(x) { NULL } ) .prepare_get_data(x, stats::na.omit(mf)) } insight/R/get_parameters.R0000644000176200001440000011233013615254727015261 0ustar liggesusers#' @title Get model parameters #' @name get_parameters #' #' @description Returns the coefficients (or posterior samples for Bayesian #' models) from a model. #' #' @param iterations Number of posterior draws. #' @param progress Display progress. #' @param ... Currently not used. #' #' @inheritParams find_parameters #' @inheritParams find_predictors #' #' @return \itemize{ #' \item for non-Bayesian models and if \code{effects = "fixed"}, a data frame with two columns: the parameter names and the related point estimates #' \item if \code{effects = "random"}, a list of data frames with the random effects (as returned by \code{ranef()}), unless the random effects have the same simplified structure as fixed effects (e.g. for models from \pkg{MCMCglmm}) #' \item for Bayesian models, the posterior samples from the requested parameters as data frame #' \item for Anova (\code{aov()}) with error term, a list of parameters for the conditional and the random effects parameters #' \item for models with smooth terms or zero-inflation component, a data frame with three columns: the parameter names, the related point estimates and the component #' } #' #' @details In most cases when models either return different "effects" (fixed, #' random) or "components" (conditional, zero-inflated, ...), the arguments #' \code{effects} and \code{component} can be used. #' \cr \cr #' \code{get_parameters()} is comparable to \code{coef()}, however, the coefficients #' are returned as data frame (with columns for names and point estimates of #' coefficients). For Bayesian models, the posterior samples of parameters are #' returned. #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' get_parameters(m) #' @importFrom stats coef #' @export get_parameters <- function(x, ...) { UseMethod("get_parameters") } # Default models --------------------------------------------- #' @export get_parameters.default <- function(x, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) return(get_parameters.gam(x, ...)) } tryCatch( { cf <- stats::coef(x) params <- data.frame( Parameter = names(cf), Estimate = unname(cf), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) }, error = function(x) { print_color(sprintf("Parameters can't be retrieved for objects of class '%s'.\n", class(x)[1]), "red") NULL } ) } #' @export get_parameters.data.frame <- function(x, ...) { stop("A data frame is no valid object for this function") } # Survival and censored models --------------------------------------------- #' @export get_parameters.flexsurvreg <- function(x, ...) { cf <- stats::coef(x) params <- data.frame( Parameter = names(cf), Estimate = unname(cf), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) } #' @export get_parameters.aareg <- function(x, ...) { sc <- summary(x) params <- data.frame( Parameter = rownames(sc$table), Estimate = unname(sc$table[, 2]), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) } #' @export get_parameters.crq <- function(x, ...) { sc <- summary(x) if (all(lapply(sc, is.list))) { list_sc <- lapply(sc, function(i) { .x <- as.data.frame(i) .x$Parameter <- rownames(.x) .x }) out <- do.call(rbind, list_sc) params <- data.frame( Parameter = out$Parameter, Estimate = out$coefficients.Value, Component = sprintf("tau (%g)", out$tau), stringsAsFactors = FALSE, row.names = NULL ) } else { params <- data.frame( Parameter = names(sc$coefficients[, 1]), Estimate = unname(sc$coefficients[, 1]), stringsAsFactors = FALSE, row.names = NULL ) } .remove_backticks_from_parameter_names(params) } #' @export get_parameters.crqs <- get_parameters.crq #' @importFrom stats setNames #' @rdname get_parameters #' @export get_parameters.rqss <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) sc <- summary(x) smooth_terms <- sc$qsstab[, 3] names(smooth_terms) <- rownames(sc$qsstab) .return_smooth_parms( conditional = stats::setNames(sc$coef[, 1], rownames(sc$coef)), smooth_terms = smooth_terms, component = component ) } #' @importFrom stats setNames #' @rdname get_parameters #' @export get_parameters.cgam <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) sc <- summary(x) estimates <- sc$coefficients smooth_terms <- sc$coefficients2 if (!is.null(smooth_terms)) smooth_terms <- stats::setNames(smooth_terms[, 1], rownames(smooth_terms)) .return_smooth_parms( conditional = stats::setNames(estimates[, 1], rownames(estimates)), smooth_terms = smooth_terms, component = component ) } # Special models --------------------------------------------- #' @export get_parameters.lrm <- function(x, ...) { tryCatch( { cf <- stats::coef(x) params <- data.frame( Parameter = names(cf), Estimate = unname(cf), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) }, error = function(x) { NULL } ) } #' @export get_parameters.multinom <- function(x, ...) { params <- stats::coef(x) if (is.matrix(params)) { out <- data.frame() for (i in 1:nrow(params)) { out <- rbind(out, data.frame( Parameter = colnames(params), Estimate = unname(params[i, ]), Response = rownames(params)[i], stringsAsFactors = FALSE, row.names = NULL )) } } else { out <- data.frame( Parameter = names(params), Estimate = unname(params), stringsAsFactors = FALSE, row.names = NULL ) } .remove_backticks_from_parameter_names(out) } #' @export get_parameters.brmultinom <- get_parameters.multinom #' @export get_parameters.glmx <- function(x, component = c("all", "conditional", "extra"), ...) { component <- match.arg(component) cf <- stats::coef(summary(x)) params <- rbind( data.frame( Parameter = names(cf$glm[, 1]), Estimate = unname(cf$glm[, 1]), Component = "conditional", stringsAsFactors = FALSE, row.names = NULL ), data.frame( Parameter = rownames(cf$extra), Estimate = cf$extra[, 1], Component = "extra", stringsAsFactors = FALSE, row.names = NULL ) ) if (component != "all") { params <- params[params$Component == component, ] } .remove_backticks_from_parameter_names(params) } #' @export get_parameters.mlm <- function(x, ...) { cs <- stats::coef(summary(x)) out <- lapply(names(cs), function(i) { params <- data.frame( Parameter = rownames(cs[[i]]), Estimate = cs[[i]][, 1], Response = gsub("^Response (.*)", "\\1", i), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) }) do.call(rbind, out) } #' @export get_parameters.gbm <- function(x, ...) { s <- summary(x, plotit = FALSE) params <- data.frame( Parameter = as.character(s$var), Estimate = s$rel.inf, stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) } #' @rdname get_parameters #' @export get_parameters.betareg <- function(x, component = c("all", "conditional", "precision"), ...) { component <- match.arg(component) cf <- stats::coef(x) params <- data.frame( Parameter = names(cf), Estimate = unname(cf), Component = c(rep("conditional", length(x$coefficients$mean)), rep("precision", length(x$coefficients$precision))), stringsAsFactors = FALSE, row.names = NULL ) if (component != "all") { params <- params[params$Component == component, ] } .remove_backticks_from_parameter_names(params) } #' @rdname get_parameters #' @export get_parameters.DirichletRegModel <- function(x, component = c("all", "conditional", "precision"), ...) { component <- match.arg(component) cf <- stats::coef(x) if (x$parametrization == "common") { component <- "all" n_comp <- lapply(cf, length) pattern <- paste0("(", paste(x$varnames, collapse = "|"), ")\\.(.*)") p_names <- gsub(pattern, "\\2", names(unlist(cf))) params <- data.frame( Parameter = p_names, Estimate = unname(unlist(cf)), Response = rep(names(n_comp), sapply(n_comp, function(i) i)), stringsAsFactors = FALSE, row.names = NULL ) } else { out1 <- .gather(data.frame(do.call(cbind, cf$beta)), names_to = "Response", values_to = "Estimate") out2 <- .gather(data.frame(do.call(cbind, cf$gamma)), names_to = "Component", values_to = "Estimate") out1$Component <- "conditional" out2$Component <- "precision" out2$Response <- NA params <- merge(out1, out2, all = TRUE, sort = FALSE) params$Parameter <- gsub("(.*)\\.(.*)\\.(.*)", "\\3", names(unlist(cf))) params <- params[c("Parameter", "Estimate", "Component", "Response")] } if (component != "all") { params <- params[params$Component == component, ] } .remove_backticks_from_parameter_names(params) } #' @export get_parameters.BBreg <- function(x, ...) { pars <- summary(x)$coefficients params <- data.frame( Parameter = rownames(pars), Estimate = pars[, "Estimate"], stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) } #' @export get_parameters.rma <- function(x, ...) { tryCatch( { cf <- stats::coef(x) params <- data.frame( Parameter = names(cf), Estimate = unname(cf), stringsAsFactors = FALSE, row.names = NULL ) params$Parameter[grepl("intrcpt", params$Parameter)] <- "(Intercept)" .remove_backticks_from_parameter_names(params) }, error = function(x) { NULL } ) } # SEM models --------------------------------------------- #' @export get_parameters.blavaan <- function(x, ...) { if (!requireNamespace("lavaan", quietly = TRUE)) { stop("Package 'lavaan' required for this function to work. Please install it.") } if (!requireNamespace("blavaan", quietly = TRUE)) { stop("Package 'blavaan' required for this function to work. Please install it.") } draws <- blavaan::blavInspect(x, "draws") posteriors <- as.data.frame(as.matrix(draws)) names(posteriors) <- names(lavaan::coef(x)) posteriors } #' @export get_parameters.lavaan <- function(x, ...) { if (!requireNamespace("lavaan", quietly = TRUE)) { stop("Package 'lavaan' required for this function to work. Please install it.") } params <- lavaan::parameterEstimates(x) params$parameter <- paste0(params$lhs, params$op, params$rhs) params$comp <- NA params$comp[params$op == "~"] <- "regression" params$comp[params$op == "=~"] <- "latent" params$comp[params$op == "~~"] <- "residual" params$comp[params$op == "~1"] <- "intercept" params <- data.frame( Parameter = params$parameter, Estimate = params$est, Component = params$comp, stringsAsFactors = FALSE ) .remove_backticks_from_parameter_names(params) } # Ordinal models --------------------------------------------- #' @export get_parameters.polr <- function(x, ...) { pars <- c(sprintf("Intercept: %s", names(x$zeta)), names(x$coefficients)) params <- data.frame( Parameter = pars, Estimate = c(unname(x$zeta), unname(x$coefficients)), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) } #' @export get_parameters.bracl <- function(x, ...) { pars <- stats::coef(x) params <- data.frame( Parameter = names(pars), Estimate = unname(pars), Response = gsub("(.*):(.*)", "\\1", names(pars)), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) } #' @rdname get_parameters #' @export get_parameters.clm2 <- function(x, component = c("all", "conditional", "scale"), ...) { component <- match.arg(component) cf <- stats::coef(summary(x)) n_intercepts <- length(x$xi) n_location <- length(x$beta) n_scale <- length(x$zeta) params <- data.frame( Parameter = rownames(cf), Estimate = unname(cf[, "Estimate"]), Component = c(rep("conditional", times = n_intercepts + n_location), rep("scale", times = n_scale)), stringsAsFactors = FALSE, row.names = NULL ) if (component != "all") { params <- params[params$Component == component, ] } .remove_backticks_from_parameter_names(params) } # Mixed models --------------------------------------------- #' @export get_parameters.clmm2 <- get_parameters.clm2 #' @rdname get_parameters #' @export get_parameters.coxme <- function(x, effects = c("fixed", "random"), ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } effects <- match.arg(effects) if (effects == "fixed") { l <- list(conditional = lme4::fixef(x)) } else { l <- .compact_list(list( conditional = lme4::fixef(x), random = lme4::ranef(x) )) } fixed <- data.frame( Parameter = names(l$conditional), Estimate = unname(l$conditional), stringsAsFactors = FALSE ) if (effects == "fixed") { .remove_backticks_from_parameter_names(fixed) } else { l$random } } #' @export get_parameters.wbm <- function(x, effects = c("fixed", "random"), ...) { effects <- match.arg(effects) if (effects == "fixed") { s <- summary(x) terms <- c( rownames(s$within_table), rownames(s$between_table), rownames(s$ints_table) ) wt <- s$within_table bt <- s$between_table it <- s$ints_table if (!is.null(wt)) { wt <- data.frame(params = wt, component = "within", stringsAsFactors = FALSE) } if (!is.null(bt)) { bt <- data.frame(params = bt, component = "between", stringsAsFactors = FALSE) } if (!is.null(it)) { it <- data.frame(params = it, component = "interactions", stringsAsFactors = FALSE) } params <- rbind(wt, bt, it) out <- data.frame( Parameter = terms, Estimate = params[[1]], Component = params[["component"]], stringsAsFactors = FALSE ) .remove_backticks_from_parameter_names(out) } else { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } lme4::ranef(x) } } #' @export get_parameters.wbgee <- function(x, ...) { get_parameters.wbm(x, effects = "fixed") } #' @export get_parameters.nlmerMod <- function(x, effects = c("fixed", "random"), ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } effects <- match.arg(effects) startvectors <- .get_startvector_from_env(x) fx <- lme4::fixef(x) if (effects == "fixed") { l <- .compact_list(list( conditional = fx[setdiff(names(fx), startvectors)], nonlinear = fx[startvectors] )) } else { l <- .compact_list(list( conditional = fx[setdiff(names(fx), startvectors)], nonlinear = fx[startvectors], random = lapply(lme4::ranef(x), colnames) )) } fixed <- data.frame( Parameter = c( names(l$conditional), names(l$nonlinear) ), Estimate = c(unname(l$conditional), unname(l$nonlinear)), Component = c( rep("fixed", length(l$conditional)), rep("nonlinear", length(l$nonlinear)) ), stringsAsFactors = FALSE ) if (effects == "fixed") { .remove_backticks_from_parameter_names(fixed) } else { l$random } } #' @rdname get_parameters #' @export get_parameters.merMod <- function(x, effects = c("fixed", "random"), ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } effects <- match.arg(effects) if (effects == "fixed") { l <- list(conditional = lme4::fixef(x)) } else { l <- .compact_list(list( conditional = lme4::fixef(x), random = lme4::ranef(x) )) } fixed <- data.frame( Parameter = names(l$conditional), Estimate = unname(l$conditional), stringsAsFactors = FALSE ) if (effects == "fixed") { .remove_backticks_from_parameter_names(fixed) } else { l$random } } #' @export get_parameters.rlmerMod <- get_parameters.merMod #' @export get_parameters.glmmadmb <- get_parameters.merMod #' @rdname get_parameters #' @export get_parameters.lme <- get_parameters.merMod #' @export get_parameters.cpglmm <- function(x, effects = c("fixed", "random"), ...) { if (!requireNamespace("cplm", quietly = TRUE)) { stop("To use this function, please install package 'cplm'.") } effects <- match.arg(effects) if (effects == "fixed") { l <- list(conditional = cplm::fixef(x)) } else { l <- .compact_list(list( conditional = cplm::fixef(x), random = cplm::ranef(x) )) } fixed <- data.frame( Parameter = names(l$conditional), Estimate = unname(l$conditional), stringsAsFactors = FALSE ) if (effects == "fixed") { .remove_backticks_from_parameter_names(fixed) } else { l$random } } #' @rdname get_parameters #' @export get_parameters.mixed <- function(x, effects = c("fixed", "random"), ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } effects <- match.arg(effects) if (effects == "fixed") { l <- list(conditional = lme4::fixef(x$full_model)) } else { l <- .compact_list(list( conditional = lme4::fixef(x$full_model), random = lme4::ranef(x$full_model) )) } fixed <- data.frame( Parameter = names(l$conditional), Estimate = unname(l$conditional), stringsAsFactors = FALSE ) if (effects == "fixed") { .remove_backticks_from_parameter_names(fixed) } else { l$random } } #' @rdname get_parameters #' @export get_parameters.MixMod <- function(x, effects = c("fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } effects <- match.arg(effects) component <- match.arg(component) has_zeroinf <- !is.null(find_formula(x)[["zero_inflated"]]) if (component %in% c("zi", "zero_inflated") && !has_zeroinf) { stop("Model has no zero-inflation component.", call. = FALSE) } re.names <- dimnames(lme4::ranef(x))[[2]] re <- lme4::ranef(x) if (has_zeroinf) { z_inflated <- lme4::fixef(x, sub_model = "zero_part") z_inflated_random <- re[grepl("^zi_", re.names, perl = TRUE)] } else { z_inflated <- NULL z_inflated_random <- NULL component <- "conditional" } l <- .compact_list(list( conditional = lme4::fixef(x, sub_model = "main"), random = re[grepl("^(?!zi_)", re.names, perl = TRUE)], zero_inflated = z_inflated, zero_inflated_random = z_inflated_random )) fixed <- data.frame( Parameter = names(l$conditional), Estimate = unname(l$conditional), Component = "conditional", stringsAsFactors = FALSE ) if (has_zeroinf) { fixedzi <- data.frame( Parameter = names(l$zero_inflated), Estimate = unname(l$zero_inflated), Component = "zero_inflated", stringsAsFactors = FALSE ) } else { fixedzi <- NULL } if (effects == "fixed") { params <- switch( component, all = rbind(fixed, fixedzi), conditional = fixed, zi = , zero_inflated = fixedzi ) .remove_backticks_from_parameter_names(params) } else if (effects == "random") { switch( component, all = .compact_list(list(random = l$random, zero_inflated_random = l$zero_inflated_random)), conditional = list(random = l$random), zi = , zero_inflated = list(zero_inflated_random = l$zero_inflated_random) ) } } #' @rdname get_parameters #' @export get_parameters.glmmTMB <- function(x, effects = c("fixed", "random"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion"), ...) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } effects <- match.arg(effects) component <- match.arg(component) if (effects == "fixed") { l <- .compact_list(list( conditional = lme4::fixef(x)$cond, zero_inflated = lme4::fixef(x)$zi, dispersion = lme4::fixef(x)$disp )) } else { l <- .compact_list(list( conditional = lme4::fixef(x)$cond, random = lme4::ranef(x)$cond, zero_inflated = lme4::fixef(x)$zi, zero_inflated_random = lme4::ranef(x)$zi, dispersion = lme4::fixef(x)$disp )) } fixed <- data.frame( Parameter = names(l$conditional), Estimate = unname(l$conditional), Component = "conditional", stringsAsFactors = FALSE ) if (.obj_has_name(l, "zero_inflated")) { fixedzi <- data.frame( Parameter = names(l$zero_inflated), Estimate = unname(l$zero_inflated), Component = "zero_inflated", stringsAsFactors = FALSE ) } else { fixedzi <- NULL } if (effects == "fixed") { out <- switch( component, all = rbind(fixed, fixedzi), conditional = fixed, zi = , zero_inflated = fixedzi ) .remove_backticks_from_parameter_names(out) } else if (effects == "random") { switch( component, all = .compact_list(list(random = l$random, zero_inflated_random = l$zero_inflated_random)), conditional = l$random, zi = , zero_inflated = l$zero_inflated_random ) } } #' @export get_parameters.mixor <- function(x, effects = c("all", "fixed", "random"), ...) { coefs <- stats::coef(x) effects <- match.arg(effects) params <- find_parameters(x, effects = "fixed", flatten = TRUE) fixed <- data.frame( Parameter = params, Estimate = unname(coefs[params]), Effects = "fixed", stringsAsFactors = FALSE ) if (effects != "fixed") { params <- find_parameters(x, effects = "random", flatten = TRUE) random <- data.frame( Parameter = params, Estimate = unname(coefs[params]), Effects = "random", stringsAsFactors = FALSE ) } else { random <- NULL } switch( effects, "all" = rbind(fixed, random), "fixed" = fixed, "random" = random ) } #' @rdname get_parameters #' @export get_parameters.BBmm <- function(x, effects = c("fixed", "random"), ...) { effects <- match.arg(effects) l <- .compact_list(list( conditional = x$fixed.coef, random = x$random.coef )) fixed <- data.frame( Parameter = rownames(l$conditional), Estimate = l$conditional, stringsAsFactors = FALSE, row.names = NULL ) if (effects == "fixed") { .remove_backticks_from_parameter_names(fixed) } else { l$random } } #' @rdname get_parameters #' @export get_parameters.glimML <- function(x, effects = c("fixed", "random", "all"), ...) { effects <- match.arg(effects) l <- .compact_list(list( conditional = x@fixed.param, random = x@random.param )) fixed <- data.frame( Parameter = names(l$conditional), Estimate = l$conditional, stringsAsFactors = FALSE, row.names = NULL ) fixed <- .remove_backticks_from_parameter_names(fixed) random <- data.frame( Parameter = names(l$random), Estimate = l$random, stringsAsFactors = FALSE, row.names = NULL ) random <- .remove_backticks_from_parameter_names(random) all <- rbind( cbind(fixed, data.frame(Effects = "fixed", stringsAsFactors = FALSE)), cbind(random, data.frame(Effects = "random", stringsAsFactors = FALSE)) ) if (effects == "fixed") { fixed } else if (effects == "random") { random } else { all } } # GAM models --------------------------------------------- #' @rdname get_parameters #' @export get_parameters.gamm <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) get_parameters.gam(x, component, ...) } #' @rdname get_parameters #' @export get_parameters.Gam <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) pars <- stats::coef(x) .return_smooth_parms( conditional = pars[.grep_non_smoothers(names(pars))], smooth_terms = pars[.grep_smoothers(names(pars))], component = component ) } #' @rdname get_parameters #' @export get_parameters.gam <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) pars <- stats::coef(x) st <- summary(x)$s.table smooth_terms <- st[, 1] names(smooth_terms) <- row.names(st) .return_smooth_parms( conditional = pars[.grep_non_smoothers(names(pars))], smooth_terms = smooth_terms, component = component ) } #' @rdname get_parameters #' @export get_parameters.vgam <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) pars <- stats::coef(x) .return_smooth_parms( conditional = pars[.grep_non_smoothers(names(pars))], smooth_terms = pars[.grep_smoothers(names(pars))], component = component ) } #' @importFrom stats na.omit #' @export get_parameters.gamlss <- function(x, ...) { pars <- lapply(x$parameters, function(i) { stats::na.omit(stats::coef(x, what = i)) }) names(pars) <- x$parameters if ("mu" %in% names(pars)) names(pars)[1] <- "conditional" do.call(rbind, lapply(names(pars), function(i) { params <- data.frame( Parameter = names(pars[[i]]), Estimate = pars[[i]], Component = i, stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) })) # data.frame( # Parameter = c(names(pars$conditional), names(pars$sigma), names(pars$nu), names(pars$tau)), # Estimate = c(unname(pars$conditional), unname(pars$sigma), unname(pars$nu), unname(pars$tau)), # Component = c( # rep("conditional", length(pars$conditional)), # rep("sigma", length(pars$sigma)), # rep("nu", length(pars$nu)), # rep("tau", length(pars$tau)) # ), # stringsAsFactors = FALSE, # row.names = NULL # ) } # Zero-Inflated models ------------------------------------- #' @rdname get_parameters #' @export get_parameters.zeroinfl <- function(x, component = c("all", "conditional", "zi", "zero_inflated"), ...) { component <- match.arg(component) .return_zeroinf_parms(x, component) } #' @export get_parameters.hurdle <- get_parameters.zeroinfl #' @export get_parameters.zerotrunc <- get_parameters.default # Standard models -------------------------------------------------- #' @export get_parameters.aov <- function(x, ...) { cf <- stats::coef(x) params <- data.frame( Parameter = names(cf), Estimate = unname(cf), stringsAsFactors = FALSE, row.names = NULL ) .remove_backticks_from_parameter_names(params) } #' @rdname get_parameters #' @export get_parameters.aovlist <- function(x, effects = c("fixed", "random", "all"), ...) { effects <- match.arg(effects) l <- lapply(stats::coef(x), function(i) { params <- data.frame( Parameter = names(i), Estimate = unname(i), stringsAsFactors = FALSE ) .remove_backticks_from_parameter_names(params) }) l <- list(rbind(l[[1]], l[[2]]), l[[3]]) names(l) <- c("conditional", "random") all <- rbind( cbind(l$conditional, data.frame(Effects = "fixed", stringsAsFactors = FALSE)), cbind(l$random, data.frame(Effects = "random", stringsAsFactors = FALSE)) ) if (effects == "fixed") { l$conditional } else if (effects == "random") { l$random } else { all } } # Bayesian models ------------------------------------- #' @rdname get_parameters #' @export get_parameters.MCMCglmm <- function(x, effects = c("fixed", "random", "all"), ...) { effects <- match.arg(effects) sc <- summary(x) l <- .compact_list(list( conditional = sc$solutions[, 1], random = sc$Gcovariances[, 1] )) names(l$conditional) <- rownames(sc$solutions) names(l$random) <- rownames(sc$Gcovariances) fixed <- data.frame( Parameter = names(l$conditional), Estimate = unname(l$conditional), stringsAsFactors = FALSE ) fixed <- .remove_backticks_from_parameter_names(fixed) random <- data.frame( Parameter = names(l$random), Estimate = unname(l$random), stringsAsFactors = FALSE ) random <- .remove_backticks_from_parameter_names(random) all <- rbind( cbind(fixed, data.frame(Effects = "fixed", stringsAsFactors = FALSE)), cbind(random, data.frame(Effects = "random", stringsAsFactors = FALSE)) ) if (effects == "fixed") { fixed } else if (effects == "random") { random } else { all } } #' @rdname get_parameters #' @export get_parameters.BFBayesFactor <- function(x, effects = c("all", "fixed", "random"), component = c("all", "extra"), iterations = 4000, progress = FALSE, ...) { if (!requireNamespace("BayesFactor", quietly = TRUE)) { stop("This function requires package `BayesFactor` to work. Please install it.") } effects <- match.arg(effects) component <- match.arg(component) bf_type <- .classify_BFBayesFactor(x) params <- find_parameters(x, effects = effects, component = component, flatten = TRUE) if (bf_type %in% c("correlation", "ttest", "meta", "linear")) { posteriors <- as.data.frame(suppressMessages( BayesFactor::posterior(x, iterations = iterations, progress = progress, index = 1, ...) )) switch( bf_type, "correlation" = data.frame("rho" = as.numeric(posteriors$rho)), "ttest" = data.frame("Difference" = as.numeric(posteriors[, 2])), "meta" = data.frame("Effect" = as.numeric(posteriors$delta)), "linear" = .get_bf_posteriors(posteriors, params), NULL ) } else { NULL } } #' @rdname get_parameters #' @export get_parameters.stanmvreg <- function(x, effects = c("fixed", "random", "all"), parameters = NULL, ...) { effects <- match.arg(effects) elements <- .get_elements(effects, "all") parms <- find_parameters(x, flatten = FALSE, parameters = parameters) for (i in names(parms)) { parms[[i]]$conditional <- sprintf("%s|%s", i, parms[[i]]$conditional) find_bracket <- regexpr(pattern = "\\[", parms[[i]]$random) parms[[i]]$random <- paste0( substr(parms[[i]]$random, start = 1, stop = find_bracket), i, "|", substr(parms[[i]]$random, start = find_bracket + 1, stop = 1000000L) ) parms[[i]]$sigma <- NULL } as.data.frame(x)[unlist(lapply(.compact_list(parms), function(i) i[elements]))] } #' @rdname get_parameters #' @export get_parameters.brmsfit <- function(x, effects = c("fixed", "random", "all"), component = c("all", "conditional", "zi", "zero_inflated", "dispersion", "simplex", "sigma", "smooth_terms"), parameters = NULL, ...) { effects <- match.arg(effects) component <- match.arg(component) if (is_multivariate(x)) { parms <- find_parameters(x, flatten = FALSE, parameters = parameters) elements <- .get_elements(effects, component) ## TODO remove "optional = FALSE" in a future update as.data.frame(x, optional = FALSE)[unlist(lapply(parms, function(i) i[elements]))] } else { ## TODO remove "optional = FALSE" in a future update as.data.frame(x, optional = FALSE)[.get_parms_data(x, effects, component, parameters)] } } #' @rdname get_parameters #' @export get_parameters.stanreg <- function(x, effects = c("fixed", "random", "all"), parameters = NULL, ...) { effects <- match.arg(effects) as.data.frame(x)[.get_parms_data(x, effects, "all", parameters)] } #' @importFrom stats coef #' @rdname find_parameters #' @export get_parameters.bayesx <- function(x, component = c("all", "conditional", "smooth_terms"), flatten = FALSE, parameters = NULL, ...) { component <- match.arg(component) smooth_terms <- find_parameters(x, component = "smooth_terms", flatten = TRUE) fixed_dat <- attr(x$fixed.effects, "sample") smooth_dat <- do.call(cbind, lapply(smooth_terms, function(i) { dat <- data.frame(x$effects[[i]]$Mean) colnames(dat) <- i dat })) switch( component, "all" = cbind(fixed_dat, smooth_dat), "conditional" = fixed_dat, "smooth_terms" = smooth_dat ) } # simulations --------------------------------- #' @rdname get_parameters #' @export get_parameters.sim.merMod <- function(x, effects = c("fixed", "random", "all"), parameters = NULL, ...) { effects <- match.arg(effects) fe <- re <- NULL if (effects %in% c("fixed", "all")) fe <- .get_armsim_fixef_parms(x) if (effects %in% c("random", "all")) re <- .get_armsim_ranef_parms(x) dat <- do.call(cbind, .compact_list(list(fe, re))) as.data.frame(dat)[.get_parms_data(x, effects, "all", parameters)] } #' @export get_parameters.sim <- function(x, parameters = NULL, ...) { dat <- .get_armsim_fixef_parms(x) as.data.frame(dat)[.get_parms_data(x, "all", "all", parameters)] } #' @export get_parameters.mcmc <- function(x, parameters = NULL, ...) { as.data.frame(x)[.get_parms_data(x, "all", "all", parameters)] } # utility functions --------------------------------- .get_parms_data <- function(x, effects, component, parameters = NULL) { elements <- .get_elements(effects, component) unlist(find_parameters(x, flatten = FALSE, parameters = parameters)[elements]) } .return_zeroinf_parms <- function(x, component) { cf <- stats::coef(x) conditional <- grepl("^count_", names(cf), perl = TRUE) zero_inflated <- grepl("^zero_", names(cf), perl = TRUE) cond <- data.frame( Parameter = names(cf)[conditional], Estimate = unname(cf)[conditional], Component = "conditional", stringsAsFactors = FALSE, row.names = NULL ) zi <- data.frame( Parameter = names(cf)[zero_inflated], Estimate = unname(cf)[zero_inflated], Component = "zero_inflated", stringsAsFactors = FALSE, row.names = NULL ) pars <- switch( component, all = rbind(cond, zi), conditional = cond, zi = , zero_inflated = zi ) if (component != "all") { pars <- .remove_column(pars, "Component") } .remove_backticks_from_parameter_names(pars) } .return_smooth_parms <- function(conditional, smooth_terms, component) { cond <- data.frame( Parameter = names(conditional), Estimate = conditional, Component = "conditional", stringsAsFactors = FALSE, row.names = NULL ) if (!is.null(smooth_terms)) { smooth <- data.frame( Parameter = names(smooth_terms), Estimate = smooth_terms, Component = "smooth_terms", stringsAsFactors = FALSE, row.names = NULL ) } else { smooth <- NULL } pars <- switch( component, all = rbind(cond, smooth), conditional = cond, smooth_terms = smooth ) if (component != "all") { pars <- .remove_column(pars, "Component") } .remove_backticks_from_parameter_names(pars) } #' @importFrom methods slot slotNames .get_armsim_fixef_parms <- function(x) { sn <- methods::slotNames(x) as.data.frame(methods::slot(x, sn[1])) } #' @importFrom methods .hasSlot .get_armsim_ranef_parms <- function(x) { dat <- NULL if (methods::.hasSlot(x, "ranef")) { re <- x@ranef dat <- data.frame() for (i in 1:length(re)) { dn <- dimnames(re[[i]])[[2]] cn <- dimnames(re[[i]])[[3]] l <- lapply(1:length(dn), function(j) { d <- as.data.frame(re[[i]][, j, ]) colnames(d) <- sprintf("%s.%s", cn, dn[j]) d }) if (ncol(dat) == 0) { dat <- do.call(cbind, l) } else { dat <- cbind(dat, do.call(cbind, l)) } } } dat } .get_bf_posteriors <- function(posteriors, params) { cn <- intersect(colnames(posteriors), params) posteriors[, cn, drop = FALSE] } insight/R/colour_tools.R0000644000176200001440000000515013525034155014772 0ustar liggesusers.rstudio_with_ansi_support <- function() { if (Sys.getenv("RSTUDIO", "") == "") { return(FALSE) } if ((cols <- Sys.getenv("RSTUDIO_CONSOLE_COLOR", "")) != "" && !is.na(as.numeric(cols))) { return(TRUE) } requireNamespace("rstudioapi", quietly = TRUE) && rstudioapi::isAvailable() && rstudioapi::hasFun("getConsoleHasColor") } .supports_color <- function() { enabled <- getOption("crayon.enabled") if (!is.null(enabled)) { return(isTRUE(enabled)) } if (.rstudio_with_ansi_support() && sink.number() == 0) { return(TRUE) } if (!isatty(stdout())) { return(FALSE) } if (Sys.info()["sysname"] == "windows") { if (Sys.getenv("ConEmuANSI") == "ON") { return(TRUE) } if (Sys.getenv("CMDER_ROOT") != "") { return(TRUE) } return(FALSE) } if ("COLORTERM" %in% names(Sys.getenv())) { return(TRUE) } if (Sys.getenv("TERM") == "dumb") { return(FALSE) } grepl("^screen|^xterm|^vt100|color|ansi|cygwin|linux", Sys.getenv("TERM"), ignore.case = TRUE, perl = TRUE ) } .blue <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[34m", x[!is.na(x)], "\033[39m") } x } .bold <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[1m", x[!is.na(x)], "\033[22m") } x } .italic <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[3m", x[!is.na(x)], "\033[23m") } x } .red <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[31m", x[!is.na(x)], "\033[39m") } x } .green <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[32m", x[!is.na(x)], "\033[39m") } x } .yellow <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[33m", x[!is.na(x)], "\033[39m") } x } .violet <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[35m", x[!is.na(x)], "\033[39m") } x } .cyan <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[36m", x[!is.na(x)], "\033[39m") } x } .grey <- function(x) { if (.supports_color()) { x[!is.na(x)] <- paste0("\033[90m", x[!is.na(x)], "\033[39m") } x } .colour <- function(colour = "red", x) { switch( colour, red = .red(x), yellow = .yellow(x), green = .green(x), blue = .blue(x), violet = .violet(x), cyan = .cyan(x), grey = .grey(x), bold = .bold(x), italic = .italic(x), warning(paste0("`color` ", colour, " not yet supported.")) ) } insight/R/get_statistic.R0000644000176200001440000005661313613634107015130 0ustar liggesusers#' @title Get statistic associated with estimates #' @description Returns the statistic (\emph{t}, \code{z}, ...) for model estimates. #' In most cases, this is the related column from \code{coef(summary())}. #' @name get_statistic #' #' @param x A model. #' @param column_index For model objects that have no defined \code{get_statistic()} #' method yet, the default method is called. This method tries to extract the #' statistic column from \code{coef(summary())}, where the index of the column #' that is being pulled is \code{column_index}. Defaults to 3, which is the #' default statistic column for most models' summary-output. #' @param component Should all parameters, parameters for the conditional model, #' or for the zero-inflated part of the model be returned? Applies to models #' with zero-inflated component. \code{component} may be one of #' \code{"conditional"}, \code{"zi"}, \code{"zero-inflated"} or \code{"all"} #' (default). For models with smooth terms, \code{component = "smooth_terms"} #' is also possible. May be abbreviated. Note that the \emph{conditional} #' component is also called \emph{count} or \emph{mean} component, depending #' on the model. #' @param robust Logical, if \code{TRUE}, test statistic based on robust standard #' errors is returned. #' @param ... Currently not used. #' #' @return A data frame with the model's parameter names and the related test statistic. #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' get_statistic(m) #' @export get_statistic <- function(x, ...) { UseMethod("get_statistic") } # Default models ---------------------------------------------------------- #' @rdname get_statistic #' @export get_statistic.default <- function(x, column_index = 3, ...) { cs <- stats::coef(summary(x)) out <- data.frame( Parameter = rownames(cs), Statistic = as.vector(cs[, column_index]), stringsAsFactors = FALSE, row.names = NULL ) out <- .remove_backticks_from_parameter_names(out) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.mlm <- function(x, ...) { cs <- stats::coef(summary(x)) out <- lapply(names(cs), function(i) { params <- cs[[i]] data.frame( Parameter = rownames(params), Statistic = as.vector(params[, 3]), Response = gsub("^Response (.*)", "\\1", i), stringsAsFactors = FALSE, row.names = NULL ) }) out <- .remove_backticks_from_parameter_names(do.call(rbind, out)) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.lme <- function(x, ...) { get_statistic.default(x, column_index = 4) } #' @export get_statistic.plm <- get_statistic.default #' @export get_statistic.maxLik <- get_statistic.default #' @export get_statistic.glmmadmb <- get_statistic.default #' @export get_statistic.lm_robust <- get_statistic.default #' @export get_statistic.geeglm <- get_statistic.default #' @export get_statistic.truncreg <- get_statistic.default #' @export get_statistic.tobit <- get_statistic.default #' @export get_statistic.censReg <- get_statistic.default #' @export get_statistic.negbin <- get_statistic.default #' @export get_statistic.feis <- get_statistic.default # Models with zero-inflation component -------------------------------------- #' @importFrom stats coef #' @rdname get_statistic #' @export get_statistic.glmmTMB <- function(x, component = c("all", "conditional", "zi", "zero_inflated"), ...) { component <- match.arg(component) cs <- .compact_list(stats::coef(summary(x))) out <- lapply(names(cs), function(i) { data.frame( Parameter = find_parameters(x, effects = "fixed", component = i, flatten = TRUE), Statistic = as.vector(cs[[i]][, 3]), Component = i, stringsAsFactors = FALSE, row.names = NULL ) }) stat <- do.call(rbind, out) stat$Component <- .rename_values(stat$Component, "cond", "conditional") stat$Component <- .rename_values(stat$Component, "zi", "zero_inflated") stat <- .filter_component(stat, component) stat <- .remove_backticks_from_parameter_names(stat) attr(stat, "statistic") <- find_statistic(x) stat } #' @export get_statistic.zeroinfl <- function(x, component = c("all", "conditional", "zi", "zero_inflated"), ...) { component <- match.arg(component) cs <- .compact_list(stats::coef(summary(x))) out <- lapply(names(cs), function(i) { comp <- ifelse(i == "count", "conditional", "zi") data.frame( Parameter = find_parameters(x, effects = "fixed", component = comp, flatten = TRUE), Statistic = as.vector(cs[[i]][, 3]), Component = comp, stringsAsFactors = FALSE, row.names = NULL ) }) stat <- do.call(rbind, out) stat$Component <- .rename_values(stat$Component, "cond", "conditional") stat$Component <- .rename_values(stat$Component, "zi", "zero_inflated") stat <- .filter_component(stat, component) stat <- .remove_backticks_from_parameter_names(stat) attr(stat, "statistic") <- find_statistic(x) stat } #' @export get_statistic.hurdle <- get_statistic.zeroinfl #' @export get_statistic.zerocount <- get_statistic.zeroinfl #' @export get_statistic.MixMod <- function(x, component = c("all", "conditional", "zi", "zero_inflated"), ...) { component <- match.arg(component) s <- summary(x) cs <- list(s$coef_table, s$coef_table_zi) names(cs) <- c("conditional", "zero_inflated") cs <- .compact_list(cs) out <- lapply(names(cs), function(i) { data.frame( Parameter = find_parameters(x, effects = "fixed", component = i, flatten = TRUE), Statistic = as.vector(cs[[i]][, 3]), Component = i, stringsAsFactors = FALSE, row.names = NULL ) }) stat <- .filter_component(do.call(rbind, out), component) stat <- .remove_backticks_from_parameter_names(stat) attr(stat, "statistic") <- find_statistic(x) stat } # gam models -------------------------------------------------------------- #' @importFrom stats na.omit #' @export get_statistic.Gam <- function(x, ...) { p.aov <- stats::na.omit(summary(x)$parametric.anova) out <- data.frame( Parameter = rownames(p.aov), Statistic = as.vector(p.aov[, 4]), stringsAsFactors = FALSE, row.names = NULL ) out <- .remove_backticks_from_parameter_names(out) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.gam <- function(x, ...) { cs <- summary(x)$p.table cs.smooth <- summary(x)$s.table out <- data.frame( Parameter = c(rownames(cs), rownames(cs.smooth)), Statistic = c(as.vector(cs[, 3]), as.vector(cs.smooth[, 3])), Component = c(rep("conditional", nrow(cs)), rep("smooth_terms", nrow(cs.smooth))), stringsAsFactors = FALSE, row.names = NULL ) out <- .remove_backticks_from_parameter_names(out) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.gamm <- function(x, ...) { x <- x$gam class(x) <- c("gam", "lm", "glm") get_statistic.gam(x, ...) } #' @export get_statistic.list <- function(x, ...) { if ("gam" %in% names(x)) { x <- x$gam class(x) <- c("gam", "lm", "glm") get_statistic.gam(x, ...) } } #' @importFrom utils capture.output #' @export get_statistic.gamlss <- function(x, ...) { parms <- get_parameters(x) utils::capture.output(cs <- summary(x)) out <- data.frame( Parameter = parms$Parameter, Statistic = as.vector(cs[, 3]), Component = parms$Component, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.vglm <- function(x, ...) { if (!requireNamespace("VGAM", quietly = TRUE)) { stop("Package 'VGAM' needed for this function to work. Please install it.") } cs <- VGAM::coef(VGAM::summary(x)) out <- data.frame( Parameter = rownames(cs), Statistic = as.vector(cs[, 3]), stringsAsFactors = FALSE, row.names = NULL ) out <- .remove_backticks_from_parameter_names(out) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.vgam <- function(x, ...) { params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = as.vector(params$Estimate / sqrt(diag(get_varcov(x)))), Component = params$Component, stringsAsFactors = FALSE, row.names = NULL ) out <- .remove_backticks_from_parameter_names(out) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.cgam <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) sc <- summary(x) stat <- as.vector(sc$coefficients[, 3]) if (!is.null(sc$coefficients2)) stat <- c(stat, rep(NA, nrow(sc$coefficients2))) params <- get_parameters(x, component = "all") out <- data.frame( Parameter = params$Parameter, Statistic = stat, Component = params$Component, stringsAsFactors = FALSE, row.names = NULL ) if (component != "all") { out <- out[out$Component == component, ] } attr(out, "statistic") <- find_statistic(x) out } # Survival models ------------------------------------------ #' @export get_statistic.coxph <- function(x, ...) { get_statistic.default(x, column_index = 4) } #' @importFrom stats vcov #' @export get_statistic.coxme <- function(x, ...) { beta <- x$coefficients out <- NULL if (length(beta) > 0) { out <- data.frame( Parameter = names(beta), Statistic = as.vector(beta / sqrt(diag(stats::vcov(x)))), stringsAsFactors = FALSE, row.names = NULL ) out <- .remove_backticks_from_parameter_names(out) attr(out, "statistic") <- find_statistic(x) } out } #' @export get_statistic.survreg <- function(x, ...) { parms <- get_parameters(x) s <- summary(x) out <- data.frame( Parameter = parms$Parameter, Statistic = s$table[, 3], stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.flexsurvreg <- function(x, ...) { parms <- get_parameters(x) se <- x$res[, "se"] out <- data.frame( Parameter = parms$Parameter, Statistic = parms$Estimate / se, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.aareg <- function(x, ...) { sc <- summary(x) parms <- get_parameters(x) out <- data.frame( Parameter = parms$Parameter, Statistic = unname(sc$test.statistic), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } # Ordinal models -------------------------------------------------- #' @rdname get_statistic #' @export get_statistic.clm2 <- function(x, component = c("all", "conditional", "scale"), ...) { component <- match.arg(component) stats <- stats::coef(summary(x)) n_intercepts <- length(x$xi) n_location <- length(x$beta) n_scale <- length(x$zeta) out <- data.frame( Parameter = rownames(stats), Statistic = unname(stats[, "z value"]), Component = c(rep("conditional", times = n_intercepts + n_location), rep("scale", times = n_scale)), stringsAsFactors = FALSE, row.names = NULL ) if (component != "all") { out <- out[out$Component == component, ] } attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.clmm2 <- get_statistic.clm2 #' @export get_statistic.mixor <- function(x, effects = c("all", "fixed", "random"), ...) { stats <- x$Model[, "z value"] effects <- match.arg(effects) parms <- get_parameters(x, effects = effects) out <- data.frame( Parameter = parms$Parameter, Statistic = stats[parms$Parameter], Effects = parms$Effects, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.multinom <- function(x, ...) { parms <- get_parameters(x) stderr <- summary(x)$standard.errors if (is.matrix(stderr)) { se <- c() for (i in 1:nrow(stderr)) { se <- c(se, as.vector(stderr[i, ])) } } else { se <- as.vector(stderr) } out <- data.frame( Parameter = parms$Parameter, Statistic = parms$Estimate / se, stringsAsFactors = FALSE, row.names = NULL ) if ("Response" %in% colnames(parms)) { out$Response <- parms$Response } attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.brmultinom <- get_statistic.multinom #' @export get_statistic.bracl <- function(x, ...) { parms <- get_parameters(x) out <- data.frame( Parameter = parms$Parameter, Statistic = stats::coef(summary(x))[, "z value"], Response = parms$Response, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } # Other models ------------------------------------------------------- #' @export get_statistic.wbm <- function(x, ...) { s <- summary(x) statistic_column <- if ("t val." %in% c( colnames(s$within_table), colnames(s$between_table), colnames(s$ints_table) )) { "t val." } else { "z val." } stat <- c( s$within_table[, statistic_column], s$between_table[, statistic_column], s$ints_table[, statistic_column] ) params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = as.vector(stat), Component = params$Component, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.wbgee <- get_statistic.wbm #' @export get_statistic.cpglmm <- function(x, ...) { if (!requireNamespace("cplm", quietly = TRUE)) { stop("To use this function, please install package 'cplm'.") } stats <- cplm::summary(x)$coefs params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = as.vector(stats[, "t value"]), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @importFrom utils capture.output #' @export get_statistic.cpglm <- function(x, ...) { if (!requireNamespace("cplm", quietly = TRUE)) { stop("To use this function, please install package 'cplm'.") } junk <- utils::capture.output(stats <- cplm::summary(x)$coefficients) params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = as.vector(stats[, "t value"]), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.MANOVA <- function(x, ...) { stats <- as.data.frame(x$WTS) out <- data.frame( Parameter = rownames(stats), Statistic = as.vector(stats[[1]]), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.RM <- get_statistic.MANOVA #' @export get_statistic.rq <- function(x, ...) { stat <- tryCatch( { cs <- stats::coef(summary(x)) cs[, "t value"] }, error = function(e) { cs <- stats::coef(summary(x, covariance = TRUE)) cs[, "t value"] } ) params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = stat, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.crq <- get_statistic.rq #' @export get_statistic.nlrq <- get_statistic.rq #' @export get_statistic.rqss <- function(x, component = c("all", "conditional", "smooth_terms"), ...) { component <- match.arg(component) cs <- summary(x) stat <- c(as.vector(cs$coef[, "t value"]), as.vector(cs$qsstab[, "F value"])) params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = unname(stat), Component = params$Component, stringsAsFactors = FALSE, row.names = NULL ) if (component != "all") { out <- out[out$Component == component, ] } attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.bigglm <- function(x, ...) { parms <- get_parameters(x) cs <- summary(x)$mat se <- as.vector(cs[, 4]) out <- data.frame( Parameter = parms$Parameter, Statistic = parms$Estimate / se, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.biglm <- function(x, ...) { parms <- get_parameters(x) cs <- summary(x)$mat se <- as.vector(cs[, 4]) out <- data.frame( Parameter = parms$Parameter, Statistic = parms$Estimate / se, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.LORgee <- function(x, ...) { out <- get_statistic.default(x) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.crch <- function(x, ...) { cs <- do.call(rbind, stats::coef(summary(x), model = "full")) params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = as.vector(cs[, 3]), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.fixest <- function(x, ...) { cs <- summary(x)$coeftable params <- get_parameters(x) out <- data.frame( Parameter = params$Parameter, Statistic = as.vector(cs[, 3]), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.glmx <- function(x, component = c("all", "conditional", "extra"), ...) { component <- match.arg(component) cf <- stats::coef(summary(x)) parms <- get_parameters(x) out <- rbind( data.frame( Parameter = parms$Parameter[parms$Component == "conditional"], Statistic = unname(cf$glm[, 3]), Component = "conditional", stringsAsFactors = FALSE, row.names = NULL ), data.frame( Parameter = parms$Parameter[parms$Component == "extra"], Statistic = cf$extra[, 3], Component = "extra", stringsAsFactors = FALSE, row.names = NULL ) ) if (component != "all") { out <- out[out$Component == component, ] } attr(out, "statistic") <- find_statistic(x) out } #' @rdname get_statistic #' @importFrom stats coef #' @export get_statistic.gee <- function(x, robust = FALSE, ...) { parms <- get_parameters(x) cs <- stats::coef(summary(x)) if (isTRUE(robust)) { stats <- as.vector(cs[, "Robust z"]) } else { stats <- as.vector(cs[, "Naive z"]) } out <- data.frame( Parameter = parms$Parameter, Statistic = stats, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.complmrob <- function(x, ...) { parms <- get_parameters(x) stat <- summary(x)$stats out <- data.frame( Parameter = parms$Parameter, Statistic = as.vector(stat[, "t value"]), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @importFrom stats qchisq #' @importFrom utils capture.output #' @export get_statistic.logistf <- function(x, ...) { parms <- get_parameters(x) utils::capture.output(s <- summary(x)) out <- data.frame( Parameter = parms$Parameter, Statistic = as.vector(stats::qchisq(1 - s$prob, df = 1)), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @importFrom stats vcov #' @export get_statistic.svyglm.nb <- function(x, ...) { if (!isNamespaceLoaded("survey")) { requireNamespace("survey", quietly = TRUE) } parms <- get_parameters(x) se <- sqrt(diag(stats::vcov(x, stderr = "robust"))) out <- data.frame( Parameter = parms$Parameter, Statistic = parms$Estimate / se, stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.svyglm.zip <- get_statistic.svyglm.nb #' @rdname get_statistic #' @importFrom stats coef #' @export get_statistic.betareg <- function(x, component = c("all", "conditional", "precision"), ...) { component <- match.arg(component) parms <- get_parameters(x) cs <- do.call(rbind, stats::coef(summary(x))) se <- as.vector(cs[, 2]) out <- data.frame( Parameter = parms$Parameter, Statistic = parms$Estimate / se, Component = parms$Component, stringsAsFactors = FALSE, row.names = NULL ) if (component != "all") { out <- out[out$Component == component, ] } attr(out, "statistic") <- find_statistic(x) out } #' @rdname get_statistic #' @importFrom stats coef #' @importFrom utils capture.output #' @export get_statistic.DirichletRegModel <- function(x, component = c("all", "conditional", "precision"), ...) { component <- match.arg(component) parms <- get_parameters(x) junk <- utils::capture.output(cs <- summary(x)$coef.mat) out <- data.frame( Parameter = parms$Parameter, Statistic = unname(cs[, "z value"]), Response = parms$Response, stringsAsFactors = FALSE, row.names = NULL ) if (!is.null(parms$Component)) { out$Component <- parms$Component } else { component <- "all" } if (component != "all") { out <- out[out$Component == component, ] } attr(out, "statistic") <- find_statistic(x) out } #' @importFrom methods slot #' @export get_statistic.glimML <- function(x, ...) { if (!requireNamespace("aod", quietly = TRUE)) { stop("Package 'aod' required for this function to work. Please install it.") } parms <- get_parameters(x) s <- methods::slot(aod::summary(x), "Coef") out <- data.frame( Parameter = parms$Parameter, Statistic = s[, 3], stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @importFrom stats coef vcov #' @export get_statistic.lrm <- function(x, ...) { parms <- get_parameters(x) stat <- stats::coef(x) / sqrt(diag(stats::vcov(x))) out <- data.frame( Parameter = parms$Parameter, Statistic = as.vector(stat), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } #' @export get_statistic.ols <- get_statistic.lrm #' @export get_statistic.rms <- get_statistic.lrm #' @export get_statistic.psm <- get_statistic.lrm #' @export get_statistic.rma <- function(x, ...) { parms <- get_parameters(x) stat <- x$zval out <- data.frame( Parameter = parms$Parameter, Statistic = as.vector(stat), stringsAsFactors = FALSE, row.names = NULL ) attr(out, "statistic") <- find_statistic(x) out } insight/R/all_equal_models.R0000644000176200001440000000446513527040073015557 0ustar liggesusers#' @title Checks if all objects are models of same class #' @name all_models_equal #' #' @description Small helper that checks if all objects are \emph{supported} #' (regression) model objects and of same class. #' #' @param ... A list of objects. #' @inheritParams get_variance #' #' @return A logical, \code{TRUE} if \code{x} are all supported model objects #' of same class. #' #' @examples #' library(lme4) #' data(mtcars) #' data(sleepstudy) #' #' m1 <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' m2 <- lm(mpg ~ wt + cyl, data = mtcars) #' m3 <- lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy) #' m4 <- glm(formula = vs ~ wt, family = binomial(), data = mtcars) #' #' all_models_same_class(m1, m2) #' all_models_same_class(m1, m2, m3) #' all_models_same_class(m1, m4, m2, m3, verbose = TRUE) #' all_models_same_class(m1, m4, mtcars, m2, m3, verbose = TRUE) #' @export all_models_equal <- function(..., verbose = FALSE) { objects <- list(...) object_names <- match.call(expand.dots = FALSE)$`...` all_supported <- vapply(objects, is_model_supported, FUN.VALUE = logical(1)) all_classes <- sapply(objects, class) if (is.matrix(all_classes)) { all_classes <- as.vector(all_classes[1, ]) } else if (is.list(all_classes)) { all_classes <- sapply(all_classes, function(i) i[1]) } all_equal <- all(vapply(all_classes[-1], function(i) identical(i, all_classes[1]), FUN.VALUE = logical(1))) if (!all(all_supported) && verbose) { differ <- which(!all_supported) m1 <- "Following objects are no (supported) models:" m2 <- paste0(sprintf("%s", object_names[differ]), collapse = ", ") message(paste(m1, m2, collapse = " ")) } if (!all(all_equal) && verbose) { differ <- which(!duplicated(all_classes)) m1 <- sprintf( "Following objects are not identical with %s (of class \"%s\"):", object_names[1], all_classes[[1]] ) m2 <- paste0( sprintf( "%s (\"%s\")", object_names[differ[-1]], sapply(all_classes[differ[-1]], function(x) as.vector(x[[1]])) ), collapse = ", " ) message(paste(m1, m2, collapse = " ")) } all(all_supported) && all(all_equal) } #' @rdname all_models_equal #' @export all_models_same_class <- all_models_equal insight/R/find_algorithm.R0000644000176200001440000001337513600224571015242 0ustar liggesusers#' @title Find sampling algorithm and optimizers #' @name find_algorithm #' #' @description Returns information on the sampling or estimation algorithm #' as well as optimization functions, or for Bayesian model information on #' chains, iterations and warmup-samples. #' #' @inheritParams find_parameters #' #' @return A list with elements depending on the model. #' \cr #' For frequentist models: #' \itemize{ #' \item \code{algorithm}, for instance \code{"OLS"} or \code{"ML"} #' \item \code{optimizer}, name of optimizing function, only applies to specific models (like \code{gam}) #' } #' For frequentist mixed models: #' \itemize{ #' \item \code{algorithm}, for instance \code{"REML"} or \code{"ML"} #' \item \code{optimizer}, name of optimizing function #' } #' For Bayesian models: #' \itemize{ #' \item \code{algorithm}, the algorithm #' \item \code{chains}, number of chains #' \item \code{iterations}, number of iterations per chain #' \item \code{warmup}, number of warmups per chain #' } #' #' #' @examples #' library(lme4) #' data(sleepstudy) #' m <- lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy) #' find_algorithm(m) #' \dontrun{ #' library(rstanarm) #' m <- stan_lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy) #' find_algorithm(m) #' } #' #' @export find_algorithm <- function(x, ...) { UseMethod("find_algorithm") } #' @export find_algorithm.default <- function(x, ...) { warning(sprintf("Objects of class `%s` are not supported.", class(x)[1])) NULL } #' @export find_algorithm.Gam <- function(x, ...) { list("algorithm" = "IWLS") } #' @export find_algorithm.lmRob <- function(x, ...) { list("algorithm" = x$robust.control$final.alg) } #' @export find_algorithm.lmrob <- function(x, ...) { list("algorithm" = x$control$method) } #' @export find_algorithm.glmrob <- function(x, ...) { list("algorithm" = x$method) } #' @export find_algorithm.logistf <- function(x, ...) { list("algorithm" = x$method) } #' @export find_algorithm.bigglm <- function(x, ...) { list("algorithm" = "ML") } #' @export find_algorithm.BBreg <- function(x, ...) { list("algorithm" = "ML") } #' @export find_algorithm.glimML <- function(x, ...) { list("algorithm" = "ML") } #' @export find_algorithm.BBmm <- function(x, ...) { method <- parse(text = .safe_deparse(x$call))[[1]]$method if (is.null(method)) method <- "BB-NR" list(algorithm = "extended likelihood", optimizer = method) } #' @export find_algorithm.biglm <- function(x, ...) { list("algorithm" = "OLS") } #' @export find_algorithm.gamlss <- function(x, ...) { list("algorithm" = as.character(x$method)[1]) } #' @export find_algorithm.gam <- function(x, ...) { list( "algorithm" = x$method, "optimizer" = x$optimizer ) } #' @export find_algorithm.lm <- function(x, ...) { list("algorithm" = "OLS") } #' @export find_algorithm.speedlm <- function(x, ...) { list("algorithm" = x$method) } #' @export find_algorithm.blavaan <- function(x, ...) { if (!requireNamespace("blavaan", quietly = TRUE)) { stop("Package 'blavaan' required for this function to work. Please install it.") } list( "chains" = blavaan::blavInspect(x, "n.chains"), "sample" = x@external$sample, "warmup" = x@external$burnin ) } #' @export find_algorithm.speedglm <- function(x, ...) { list("algorithm" = x$method) } #' @export find_algorithm.rq <- function(x, ...) { list("algorithm" = x$method) } #' @export find_algorithm.bayesx <- function(x, ...) { list( "algorithm" = x$method, "iterations" = x$iterations, "warmup" = x$burnin ) } #' @export find_algorithm.crq <- function(x, ...) { list("algorithm" = x$method) } #' @export find_algorithm.rqss <- function(x, ...) { list("algorithm" = x$method) } #' @export find_algorithm.glm <- function(x, ...) { list("algorithm" = "ML") } #' @export find_algorithm.LORgee <- function(x, ...) { list("algorithm" = "Fisher's scoring ML") } #' @export find_algorithm.merMod <- function(x, ...) { algorithm <- ifelse(as.logical(x@devcomp$dims[["REML"]]), "REML", "ML") list( "algorithm" = algorithm, "optimizer" = as.character(x@optinfo$optimizer) ) } #' @export find_algorithm.rlmerMod <- find_algorithm.merMod #' @export find_algorithm.mixed <- function(x, ...) { x <- x$full_model algorithm <- ifelse(as.logical(x@devcomp$dims[["REML"]]), "REML", "ML") list( "algorithm" = algorithm, "optimizer" = as.character(x@optinfo$optimizer) ) } #' @export find_algorithm.lme <- function(x, ...) { optimizer <- "nlminb" if (!is.null(x$call$control) && "optim" %in% as.character(x$call$control)) { optimizer <- "optim" } list( "algorithm" = x$method, "optimizer" = optimizer ) } #' @export find_algorithm.MixMod <- function(x, ...) { list( ## TODO fix me "algorithm" = "quasi-Newton", "optimizer" = x$control$optimizer ) } #' @export find_algorithm.glmmTMB <- function(x, ...) { algorithm <- ifelse(x$modelInfo$REML, "REML", "ML") list( "algorithm" = algorithm, "optimizer" = "nlminb" ) } #' @export find_algorithm.stanreg <- function(x, ...) { info <- x$stanfit@sim list( "algorithm" = x$algorithm, "chains" = info$chains, "iterations" = info$iter, "warmup" = info$warmup ) } #' @export find_algorithm.brmsfit <- function(x, ...) { info <- x$fit@sim list( "algorithm" = x$algorithm, "chains" = info$chains, "iterations" = info$iter, "warmup" = info$warmup ) } insight/R/is_model_supported.R0000644000176200001440000000522013614067316016151 0ustar liggesusers#' @title Checks if an object is a regression model object supported in #' \pkg{insight} package. #' @name is_model_supported #' #' @description Small helper that checks if a model is a \emph{supported} #' (regression) model object. \code{supported_models()} prints a list #' of currently supported model classes. #' #' @inheritParams is_model #' #' @return A logical, \code{TRUE} if \code{x} is a (supported) model object. #' #' @details This function returns \code{TRUE} if \code{x} is a model object #' that works with the package's functions. A list of supported models can #' also be found here: \url{https://github.com/easystats/insight}. #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' #' is_model_supported(m) #' is_model_supported(mtcars) #' @export is_model_supported <- function(x) { inherits(x, .supported_models_list()) } #' @rdname is_model_supported #' @export supported_models <- function() { sort(.supported_models_list()) } .supported_models_list <- function() { c( "aareg", "aov", "aovlist", "bamlss", "bamlss.frame", "bayesx", "BBmm", "BBreg", "betareg", "BFBayesFactor", "biglm", "bigglm", "blavaan", "bracl", "brglm", "brmsfit", "brmultinom", "censReg", "cgam", "cgamm", "cglm", "clm", "clm2", "clmm", "clmm2", "complmrob", "coxme", "coxph", "cpglm", "cpglmm", "crch", "crq", "crqs", "DirichletRegModel", "feis", "felm", "feglm", "fixest", "flexsurvreg", "gam", "Gam", "gamlss", "gamm", "gamm4", "gbm", "gee", "geeglm", "glimML", "glm", "glmmadmb", "glmmPQL", "glmmTMB", "glmrob", "glmRob", "glmx", "gls", "gmnl", "htest", "hurdle", "iv_robust", "ivreg", "lavaan", "lm", "lm_robust", "lme", "lmrob", "lmRob", "logistf", "LORgee", "lrm", "MANOVA", "maxLik", "mcmc", "MCMCglmm", "merMod", "mixed", "mixor", "MixMod", "mlm", "mclogit", "mlogit", "mmlogit", "multinom", "ols", "plm", "polr", "psm", "rlm", "rlmerMod", "RM", "rma", "rma.uni", "rq", "rqss", "speedlm", "speedglm", "stanmvreg", "stanreg", "survfit", "survreg", "svyglm", "svyolr", "tobit", "truncreg", "vgam", "vglm", "wbm", "wblm", "wbgee", "zeroinfl", "zerotrunc" ) } insight/R/find_weights.R0000644000176200001440000000314713555323465014735 0ustar liggesusers#' @title Find names of model weights #' @name find_weights #' #' @description Returns the name of the variable that describes the weights of a model. #' #' @param x A fitted model. #' @param ... Currently not used. #' #' @return The name of the weighting variable as character vector, or \code{NULL} #' if no weights were specified. #' #' @examples #' data(mtcars) #' mtcars$weight <- rnorm(nrow(mtcars), 1, .3) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars, weights = weight) #' find_weights(m) #' @export find_weights <- function(x, ...) { UseMethod("find_weights") } #' @export find_weights.default <- function(x, ...) { tryCatch( { w <- .safe_deparse(parse(text = .safe_deparse(x$call))[[1]]$weights) # edge case, users use "eval(parse())" to parse weight variables if (grepl("^eval\\(parse\\(", w)) { w <- eval(parse(text = .trim(gsub("eval\\(parse\\((.*)=(.*)\\)\\)", "\\2", w)))) } if (.is_empty_object(w) || w == "NULL") w <- NULL w }, error = function(e) { NULL } ) } #' @export find_weights.brmsfit <- function(x, ...) { f <- find_formula(x) if (is_multivariate(f)) { resp <- unlist(lapply(f, function(i) .safe_deparse(i$conditional[[2L]]))) } else { resp <- .safe_deparse(f$conditional[[2L]]) } resp <- .compact_character(unname(sapply(resp, function(i) { if (grepl("(.*)\\|(\\s+)weights\\((.*)\\)", i)) { i } else { "" } }))) w <- .trim(sub("(.*)\\|(\\s+)weights\\((.*)\\)", "\\3", resp)) if (.is_empty_object(w)) w <- NULL w } insight/R/clean_names.R0000644000176200001440000001227413613634107014522 0ustar liggesusers#' @title Get clean names of model terms #' @name clean_names #' #' @description This function "cleans" names of model terms (or a character #' vector with such names) by removing patterns like \code{log()} or #' \code{as.factor()} etc. #' #' @param x A fitted model, or a character vector. #' #' @return The "cleaned" variable names as character vector, i.e. pattern #' like \code{s()} for splines or \code{log()} are removed from #' the model terms. #' #' @note Typically, this method is intended to work on character vectors, #' in order to remove patterns that obscure the variable names. For #' convenience reasons it is also possible to call \code{clean_names()} #' also on a model object. If \code{x} is a regression model, this #' function is (almost) equal to calling \code{find_variables()}. The #' main difference is that \code{clean_names()} always returns a character #' vector, while \code{find_variables()} returns a list of character #' vectors, unless \code{flatten = TRUE}. See 'Examples'. #' #' @examples #' # example from ?stats::glm #' counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) #' outcome <- c(gl(3, 1, 9)) #' treatment <- gl(3, 3) #' m <- glm(counts ~ log(outcome) + as.factor(treatment), family = poisson()) #' clean_names(m) #' #' # difference "clean_names()" and "find_variables()" #' library(lme4) #' m <- glmer( #' cbind(incidence, size - incidence) ~ period + (1 | herd), #' data = cbpp, #' family = binomial #' ) #' #' clean_names(m) #' find_variables(m) #' find_variables(m, flatten = TRUE) #' @export clean_names <- function(x) { UseMethod("clean_names") } #' @export clean_names.default <- function(x) { cleaned <- unname(find_variables(x, flatten = TRUE)) .remove_values(cleaned, c("1", "0")) } #' @export clean_names.character <- function(x) { .remove_pattern_from_names(x) } .remove_pattern_from_names <- function(x, ignore_asis = FALSE, ignore_lag = FALSE) { # return if x is empty if (.is_empty_string(x)) { return("") } # for gam-smoothers/loess, remove s()- and lo()-function in column name # for survival, remove strata(), and so on... pattern <- c( "as.factor", "as.numeric", "factor", "offset", "log1p", "log10", "log2", "log-log", "scale-log", "log", "lag", "diff", "lspline", "pspline", "poly", "catg", "asis", "matrx", "pol", "strata", "strat", "scale", "scored", "interaction", "sqrt", "lsp", "rcs", "pb", "lo", "bs", "ns", "t2", "te", "ti", "tt", # need to be fixed first "mmc", "mm", "mi", "mo", "gp", "s", "I" ) # sometimes needed for panelr models, where we need to preserve "lag()" if (ignore_lag) { lag_pattern <- which(pattern == "lag") if (length(lag_pattern)) pattern <- pattern[-lag_pattern] } # do we have a "log()" pattern here? if yes, get capture region # which matches the "cleaned" variable name cleaned <- sapply(1:length(x), function(i) { for (j in 1:length(pattern)) { # remove possible namespace x[i] <- sub("(.*)::(.*)", "\\2", x[i]) if (pattern[j] == "offset") { x[i] <- .trim(unique(sub("^offset\\(([^-+ )]*).*", "\\1", x[i]))) } else if (pattern[j] == "I") { if (!ignore_asis) x[i] <- .trim(unique(sub("I\\(((\\w|\\.)*).*", "\\1", x[i]))) } else if (pattern[j] == "asis") { if (!ignore_asis) x[i] <- .trim(unique(sub("asis\\(((\\w|\\.)*).*", "\\1", x[i]))) } else if (pattern[j] == "log-log") { x[i] <- .trim(unique(sub("^log\\(log\\(((\\w|\\.)*).*", "\\1", x[i]))) } else if (pattern[j] == "scale-log") { x[i] <- .trim(unique(sub("^scale\\(log\\(((\\w|\\.)*).*", "\\1", x[i]))) x[i] <- .trim(unique(sub("^scale\\(log1p\\(((\\w|\\.)*).*", "\\1", x[i]))) x[i] <- .trim(unique(sub("^scale\\(log2\\(((\\w|\\.)*).*", "\\1", x[i]))) x[i] <- .trim(unique(sub("^scale\\(log10\\(((\\w|\\.)*).*", "\\1", x[i]))) } else if (pattern[j] %in% c("mmc", "mm")) { ## TODO multimembership-models need to be fixed p <- paste0("^", pattern[j], "\\((.*)\\).*") g <- .trim(sub(p, "\\1", x[i])) x[i] <- .trim(unlist(strsplit(g, ","))) } else { # p <- paste0("^", pattern[j], "\\(([^,/)]*).*") # this one should be more generic... p <- paste0("^", pattern[j], "\\(((\\w|\\.)*).*") x[i] <- unique(sub(p, "\\1", x[i])) } } # for coxme-models, remove random-effect things... .trim(sub("^(.*)\\|(.*)", "\\2", x[i])) }) # remove for random intercept only models .remove_values(cleaned, c("1", "0")) } ## TODO multimembership-models may also have weights, this does not work yet .clean_brms_mm <- function(x) { # only clean for mm() / mmc() functions, else return x if (!grepl("^(mmc|mm)\\(", x)) { return(x) } # extract terms from mm() / mmc() functions, i.e. get # multimembership-terms unname(.compact_character(unlist(sapply(c("mmc", "mm"), function(j) { if (grepl(paste0("^", j, "\\("), x = x)) { p <- paste0("^", j, "\\((.*)\\).*") g <- .trim(sub(p, "\\1", x)) .trim(unlist(strsplit(g, ","))) } else { "" } }, simplify = FALSE)))) } insight/R/n_obs.R0000644000176200001440000001133713614067316013357 0ustar liggesusers#' @title Get number of observations from a model #' @name n_obs #' #' @description This method returns the number of observation that were used #' to fit the model, as numeric value. #' #' @param weighted For survey designs, returns the weighted sample size. #' @inheritParams find_predictors #' @inheritParams get_response #' @inheritParams find_formula #' #' @return The number of observations used to fit the model, or \code{NULL} if #' this information is not available. #' #' @examples #' data(mtcars) #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' n_obs(m) #' @importFrom stats model.frame nobs #' @export n_obs <- function(x, ...) { UseMethod("n_obs") } #' @export n_obs.default <- function(x, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) } tryCatch( { stats::nobs(x) }, error = function(x) { NULL } ) } #' @export n_obs.censReg <- n_obs.default #' @rdname n_obs #' @export n_obs.svyolr <- function(x, weighted = FALSE, ...) { if (weighted) { stats::nobs(x) } else { nrow(stats::model.frame(x)) } } #' @export n_obs.gamm <- function(x, ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) NextMethod() } #' @export n_obs.bayesx <- function(x, ...) { length(x$response) } #' @export n_obs.flexsurvreg <- function(x, ...) { x$N } #' @export n_obs.bamlss <- function(x, ...) { nrow(x$model.frame) } #' @export n_obs.lmRob <- function(x, ...) { length(x$fitted.values) } #' @export n_obs.LORgee <- function(x, ...) { x$nobs } #' @export n_obs.mcmc <- function(x, ...) { nrow(as.data.frame(x)) } #' @export n_obs.biglm <- function(x, ...) { x$n } #' @export n_obs.bigglm <- n_obs.biglm #' @export n_obs.rqss <- n_obs.biglm #' @export n_obs.hurdle <- n_obs.biglm #' @export n_obs.zerotrunc <- n_obs.biglm #' @export n_obs.zeroinfl <- n_obs.biglm #' @export n_obs.cgam <- function(x, ...) { nrow(get_data(x)) } #' @export n_obs.cglm <- n_obs.cgam #' @export n_obs.gbm <- function(x, ...) { length(x$fit) } #' @export n_obs.glimML <- function(x, ...) { nrow(x@data) } #' @export n_obs.glmRob <- function(x, ...) { length(x$fitted.values) } #' @export n_obs.gmnl <- function(x, ...) { x$logLik$nobs } #' @export n_obs.multinom <- function(x, ...) { nrow(x$fitted.values) } #' @export n_obs.cpglmm <- function(x, ...) { nrow(x@frame) } #' @export n_obs.cpglm <- function(x, ...) { nrow(x$model.frame) } #' @export n_obs.rq <- function(x, ...) { length(x$fitted.values) } #' @export n_obs.BBreg <- function(x, ...) { x$nObs } #' @export n_obs.BBmm <- n_obs.BBreg #' @export n_obs.crq <- function(x, ...) { n <- nrow(x$residuals) if (.is_empty_object(n)) { n <- nrow(x$fitted.values) } n } #' @export n_obs.crqs <- n_obs.crq #' @export n_obs.MANOVA <- function(x, ...) { nrow(x$input$data) } #' @export n_obs.RM <- n_obs.MANOVA #' @importFrom stats fitted #' @export n_obs.nlrq <- function(x, ...) { length(stats::fitted(x)) } #' @export n_obs.survfit <- function(x, ...) { length(x$n.event) } #' @export n_obs.survreg <- function(x, ...) { length(x$linear.predictors) } #' @export n_obs.aareg <- function(x, ...) { max(x$n) } #' @export n_obs.coxph <- n_obs.aareg #' @export n_obs.coxme <- n_obs.aareg #' @export n_obs.felm <- function(x, ...) { x$N } #' @export n_obs.feis <- function(x, ...) { length(x$fitted.values) } #' @export n_obs.fixest <- function(x, ...) { x$nobs } #' @export n_obs.feglm <- function(x, ...) { x$nobs["nobs"] } #' @export n_obs.complmrob <- n_obs.cgam #' @export n_obs.aovlist <- function(x, ...) { nrow(stats::model.frame(x)) } #' @rdname n_obs #' @export n_obs.stanmvreg <- function(x, select = NULL, ...) { n <- min(x$n_yobs) if (!is.null(select)) { if (select %in% names(x$n_yobs)) { n <- x$n_yobs[select] } else { print_color(sprintf("Could not find response '%s'. Model's response variables are named %s.\n", select, paste(names(x$n_yobs), collapse = ", ")), "red") cat("Returning smallest number of observations now.\n") n <- min(x$n_yobs) } } n } #' @export n_obs.mlogit <- function(x, ...) { nrow(x$model) } #' @export n_obs.maxLik <- n_obs.mlogit #' @export n_obs.wbm <- function(x, ...) { nrow(x@frame) } #' @export n_obs.wbgee <- function(x, ...) { stats::nobs(x) } insight/R/get_predictors.R0000644000176200001440000000156413552111346015267 0ustar liggesusers#' @title Get the data from model predictors #' @name get_predictors #' #' @description Returns the data from all predictor variables (fixed effects). #' #' @inheritParams find_predictors #' #' @return The data from all predictor variables, as data frame. #' #' @examples #' m <- lm(mpg ~ wt + cyl + vs, data = mtcars) #' head(get_predictors(m)) #' @export get_predictors <- function(x) { vars <- if (inherits(x, "wbm")) { unlist(.compact_list(find_terms(x, flatten = FALSE)[c("conditional", "instruments")])) } else { find_predictors(x, effects = "fixed", component = "all", flatten = TRUE) } dat <- get_data(x) dat <- dat[, intersect(vars, colnames(dat)), drop = FALSE] if (.is_empty_object(dat)) { print_color("Warning: Data frame is empty, probably you have an intercept-only model?\n", "red") return(NULL) } dat } insight/R/print_parameters.R0000644000176200001440000001620513524331052015624 0ustar liggesusers#' @title Prepare summary statistics of model parameters for printing #' @name print_parameters #' #' @description This function takes a data frame, typically a data frame with #' information on summaries of model parameters like \code{\link[bayestestR]{hdi}} #' or \code{\link[bayestestR]{equivalence_test}}, as input and splits this information #' into several parts, depending on the model. See details below. #' #' @param x A fitted model, or a data frame returned by \code{\link{clean_parameters}}. #' @param ... One or more objects (data frames), which contain information about #' the model parameters and related statistics (like confidence intervals, HDI, #' ROPE, ...). #' @param split_by \code{split_by} should be a character vector with one or #' more of the following elements: \code{"Effects"}, \code{"Component"}, #' \code{"Response"} and \code{"Group"}. These are the column names returned #' by \code{\link{clean_parameters}}, which is used to extract the information #' from which the group or component model parameters belong. If \code{NULL}, the #' merged data frame is returned. Else, the data frame is split into a list, #' split by the values from those columns defined in \code{split_by}. #' #' @return A data frame or a list of data frames (if \code{split_by} is not \code{NULL}). #' If a list is returned, the element names reflect the model components where the #' extracted information in the data frames belong to, e.g. \code{`random.zero_inflated.Intercept: persons`}. #' This is the data frame that contains the parameters for the random effects from #' group-level "persons" from the zero-inflated model component. #' #' @details This function prepares data frames that contain information #' about model parameters for clear printing. #' \cr \cr #' First, \code{x} is required, which should either be a model object or a #' prepared data frame as returned by \code{\link{clean_parameters}}. If #' \code{x} is a model, \code{clean_parameters()} is called on that model #' object to get information with which model components the parameters #' are associated. #' \cr \cr #' Then, \code{...} take one or more data frames that also contain information #' about parameters from the same model, but also have additional information #' provided by other methods. For instance, a data frame in \code{...} might #' be the result of \code{\link[bayestestR]{hdi}}, where we #' have a) a \code{Parameters} column and b) columns with the HDI values. #' \cr \cr #' Now we have a data frame with model parameters and information about the #' association to the different model components, a data frame with model #' parameters, and some summary statistics. \code{print_parameters()} #' then merges these data frames, so the statistic of interest (in our example: #' the HDI) is also associated with the different model components. The data #' frame is split into a list, so for a clear printing. Users can loop over this #' list and print each component for a better overview. Further, parameter #' names are "cleaned", if necessary, also for a cleaner print. See also 'Examples'. #' #' @examples #' \dontrun{ #' library(bayestestR) #' model <- download_model("brms_zi_2") #' x <- hdi(model, effects = "all", component = "all") #' #' # hdi() returns a data frame; here we use only the informaton on #' # parameter names and HDI values #' tmp <- as.data.frame(x)[, 1:4] #' tmp #' #' # Based on the "split_by" argument, we get a list of data frames that #' # is split into several parts that reflect the model components. #' print_parameters(model, tmp) #' #' # This is the standard print()-method for "bayestestR::hdi"-objects. #' # For printing methods, it is easy to print complex summary statistics #' # in a clean way to the console by splitting the information into #' # different model components. #' x #' } #' #' @importFrom stats na.omit #' @export print_parameters <- function(x, ..., split_by = c("Effects", "Component", "Group", "Response")) { obj <- list(...) cp <- if (!inherits(x, "clean_parameters")) { clean_parameters(x) } else { x } cn1 <- colnames(cp) obj <- lapply(obj, function(i) { # make sure we have a Parameter column if (!"Parameter" %in% colnames(i)) colnames(i)[1] <- "Parameter" # remove all other common columns that might produce duplicates cn2 <- colnames(i) dupes <- stats::na.omit(match(cn1, cn2)[-1]) if (length(dupes) > 0) i <- i[, -dupes, drop = FALSE] i }) # merge all objects together obj <- Reduce( function(x, y) merge(x, y, all.x = FALSE, by = "Parameter", sort = FALSE), c(list(cp), obj) ) # return merged data frame if no splitting requested if (.is_empty_object(split_by)) { return(obj) } # determine where to split data frames split_by <- split_by[split_by %in% colnames(obj)] f <- lapply(split_by, function(i) { if (i %in% colnames(obj)) obj[[i]] }) names(f) <- split_by # split into groups, remove empty elements out <- split(obj, f) out <- .compact_list(lapply(out, function(i) { if (nrow(i) > 0) i })) # remove trailing dots names(out) <- list_names <- gsub("(.*)\\.$", "\\1", names(out)) has_zeroinf <- any(grepl("zero_inflated", names(out), fixed = TRUE)) # create title attributes, and remove unnecessary columns from output out <- lapply(names(out), function(i) { # init title variables title1 <- title2 <- "" # get data frame element <- out[[i]] # split name at ".", so we have all components the data frame refers to (i.e. # fixed/random, conditional/zero-inflated, group-lvl or random slope etc.) # as character vector parts <- unlist(strsplit(i, ".", fixed = TRUE)) # iterate all parts of the component names, to create title attribute for (j in 1:length(parts)) { # Rename "fixed", "random" etc. into proper titles. Here we have the # "Main title" of a subcomponent (like "Random effects") if (parts[j] %in% c("fixed", "random") || (has_zeroinf && parts[j] %in% c("conditional", "zero_inflated"))) { tmp <- switch( parts[j], "fixed" = "Fixed effects", "random" = "Random effects", "conditional" = "(conditional)", "zero_inflated" = "(zero-inflated)" ) title1 <- paste0(title1, " ", tmp) } else if (!parts[j] %in% c("conditional", "zero_inflated")) { # here we have the "subtitles" of a subcomponent # (like "Intercept: Group-Level 1") title2 <- paste0(title2, " ", parts[j]) } } .effects <- unique(element$Effects) .component <- unique(element$Component) # we don't need "Effects" and "Random" column any more keep <- setdiff(colnames(element), c("Effects", "Component", "Cleaned_Parameter")) element <- element[, c("Cleaned_Parameter", keep)] # add attributes attr(element, "main_title") <- .trim(title1) attr(element, "sub_title") <- .trim(title2) attr(element, "Effects") <- .effects attr(element, "Component") <- .component element }) names(out) <- list_names out } insight/R/get_random.R0000644000176200001440000000173513502531610014364 0ustar liggesusers#' @title Get the data from random effects #' @name get_random #' #' @description Returns the data from all random effects terms. #' #' @inheritParams find_random #' #' @return The data from all random effects terms, as data frame. Or \code{NULL} #' if model has no random effects. #' #' @examples #' library(lme4) #' data(sleepstudy) #' # prepare some data... #' sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) #' sleepstudy$mysubgrp <- NA #' for (i in 1:5) { #' filter_group <- sleepstudy$mygrp == i #' sleepstudy$mysubgrp[filter_group] <- #' sample(1:30, size = sum(filter_group), replace = TRUE) #' } #' #' m <- lmer( #' Reaction ~ Days + (1 | mygrp / mysubgrp) + (1 | Subject), #' data = sleepstudy #' ) #' #' head(get_random(m)) #' @export get_random <- function(x) { if (.is_empty_object(find_random(x))) { warning("No random effects found in model.") return(NULL) } get_data(x, effects = "random") } insight/R/link_inverse.R0000644000176200001440000002623513614067316014752 0ustar liggesusers#' @title Get link-inverse function from model object #' @name link_inverse #' #' @description Returns the link-inverse function from a model object. #' #' @param what For \code{gamlss} models, indicates for which distribution #' parameter the link (inverse) function should be returned; for \code{betareg} #' or \code{DirichletRegModel}, can be \code{"mean"} or \code{"precision"}. #' @inheritParams find_predictors #' @inheritParams find_formula #' #' @return A function, describing the inverse-link function from a model-object. #' For multivariate-response models, a list of functions is returned. #' #' @examples #' # example from ?stats::glm #' counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12) #' outcome <- gl(3, 1, 9) #' treatment <- gl(3, 3) #' m <- glm(counts ~ outcome + treatment, family = poisson()) #' #' link_inverse(m)(.3) #' # same as #' exp(.3) #' @importFrom stats family make.link gaussian formula #' @export link_inverse <- function(x, ...) { UseMethod("link_inverse") } # Default method --------------------------------------- #' @export link_inverse.default <- function(x, ...) { if (inherits(x, "list") && .obj_has_name(x, "gam")) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) } if (inherits(x, "Zelig-relogit")) { stats::make.link(link = "logit")$linkinv } else { tryCatch( { stats::family(x)$linkinv }, error = function(x) { NULL } ) } } # GLM families --------------------------------------------------- #' @export link_inverse.glm <- function(x, ...) { tryCatch( { stats::family(x)$linkinv }, error = function(x) { NULL } ) } #' @export link_inverse.speedglm <- link_inverse.glm #' @export link_inverse.bigglm <- link_inverse.glm # Tobit Family --------------------------------- #' @export link_inverse.tobit <- function(x, ...) { .make_tobit_family(x)$linkinv } #' @export link_inverse.crch <- link_inverse.tobit #' @export link_inverse.survreg <- link_inverse.tobit #' @export link_inverse.psm <- link_inverse.tobit #' @export link_inverse.flexsurvreg <- function(x, ...) { dist <- parse(text = .safe_deparse(x$call))[[1]]$dist .make_tobit_family(x, dist)$linkinv } # Gaussian identity links --------------------------------- #' @export link_inverse.lm <- function(x, ...) { stats::gaussian(link = "identity")$linkinv } #' @export link_inverse.bayesx <- link_inverse.lm #' @export link_inverse.biglm <- link_inverse.lm #' @export link_inverse.aovlist <- link_inverse.lm #' @export link_inverse.ivreg <- link_inverse.lm #' @export link_inverse.iv_robust <- link_inverse.lm #' @export link_inverse.mixed <- link_inverse.lm #' @export link_inverse.lme <- link_inverse.lm #' @export link_inverse.rq <- link_inverse.lm #' @export link_inverse.rqss <- link_inverse.lm #' @export link_inverse.crq <- link_inverse.lm #' @export link_inverse.crqs <- link_inverse.lm #' @export link_inverse.censReg <- link_inverse.lm #' @export link_inverse.plm <- link_inverse.lm #' @export link_inverse.lm_robust <- link_inverse.lm #' @export link_inverse.truncreg <- link_inverse.lm #' @export link_inverse.felm <- link_inverse.lm #' @export link_inverse.feis <- link_inverse.lm #' @export link_inverse.gls <- link_inverse.lm #' @export link_inverse.lmRob <- link_inverse.lm #' @export link_inverse.MANOVA <- link_inverse.lm #' @export link_inverse.RM <- link_inverse.lm #' @export link_inverse.lmrob <- link_inverse.lm #' @export link_inverse.complmrob <- link_inverse.lm #' @export link_inverse.speedlm <- link_inverse.lm #' @rdname link_inverse #' @export link_inverse.betareg <- function(x, what = c("mean", "precision"), ...) { what <- match.arg(what) switch( what, "mean" = x$link$mean$linkinv, "precision" = x$link$precision$linkinv ) } #' @rdname link_inverse #' @export link_inverse.DirichletRegModel <- function(x, what = c("mean", "precision"), ...) { what <- match.arg(what) if (x$parametrization == "common") { stats::make.link("logit")$linkinv } else { switch( what, "mean" = stats::make.link("logit")$linkinv, "precision" = stats::make.link("log")$linkinv ) } } # Logit links ----------------------------------- #' @export link_inverse.gmnl <- function(x, ...) { stats::make.link("logit")$linkinv } #' @export link_inverse.mlogit <- link_inverse.gmnl #' @export link_inverse.BBreg <- link_inverse.gmnl #' @export link_inverse.BBmm <- link_inverse.gmnl #' @export link_inverse.coxph <- link_inverse.gmnl #' @export link_inverse.survfit <- link_inverse.gmnl #' @export link_inverse.coxme <- link_inverse.gmnl #' @export link_inverse.lrm <- link_inverse.gmnl #' @export link_inverse.logistf <- link_inverse.gmnl #' @export link_inverse.multinom <- link_inverse.gmnl # Log-links --------------------------------------- #' @export link_inverse.zeroinfl <- function(x, ...) { stats::make.link("log")$linkinv } #' @export link_inverse.hurdle <- link_inverse.zeroinfl #' @export link_inverse.zerotrunc <- link_inverse.zeroinfl # Ordinal models ----------------------------------- #' @export link_inverse.clm <- function(x, ...) { stats::make.link(.get_ordinal_link(x))$linkinv } #' @export link_inverse.clmm <- link_inverse.clm #' @export link_inverse.clm2 <- link_inverse.clm #' @export link_inverse.mixor <- link_inverse.clm # Other models ---------------------------- #' @export link_function.cglm <- function(x, ...) { link <- parse(text = .safe_deparse(x$call))[[1]]$link method <- parse(text = .safe_deparse(x$call))[[1]]$method if (!is.null(method) && method == "clm") { link <- "identiy" } stats::make.link(link = link)$linkinv } #' @export link_inverse.cpglmm <- function(x, ...) { f <- .get_cplm_family(x) f$linkinv } #' @export link_inverse.cpglm <- link_inverse.cpglmm #' @export link_inverse.fixest <- function(x, ...) { if (is.null(x$family)) { if (!is.null(x$method) && x$method == "feols") { stats::gaussian(link = "identity")$linkinv } } else if (inherits(x$family, "family")) { x$family$linkinv } else { link <- switch( x$family, "poisson" = , "negbin" = "log", "logit" = "logit", "gaussian" = "identity" ) stats::make.link(link)$linkinv } } #' @export link_inverse.feglm <- link_inverse.fixest #' @export link_inverse.glmx <- function(x, ...) { x$family$glm$linkinv } #' @export link_inverse.glmmadmb <- function(x, ...) { x$ilinkfun } #' @export link_inverse.polr <- function(x, ...) { link <- x$method if (link == "logistic") link <- "logit" stats::make.link(link)$linkinv } #' @export link_inverse.svyolr <- function(x, ...) { link <- x$method if (link == "logistic") link <- "logit" stats::make.link(link)$linkinv } #' @export link_inverse.LORgee <- function(x, ...) { if (grepl(pattern = "logit", x = x$link, fixed = TRUE)) { link <- "logit" } else if (grepl(pattern = "probit", x = x$link, fixed = TRUE)) { link <- "probit" } else if (grepl(pattern = "cauchit", x = x$link, fixed = TRUE)) { link <- "cauchit" } else if (grepl(pattern = "cloglog", x = x$link, fixed = TRUE)) { link <- "cloglog" } else { link <- "logit" } stats::make.link(link)$linkinv } #' @export link_inverse.glimML <- function(x, ...) { stats::make.link(x@link)$linkinv } #' @export link_inverse.glmmTMB <- function(x, ...) { ff <- stats::family(x) if ("linkinv" %in% names(ff)) { ff$linkinv } else if ("link" %in% names(ff) && is.character(ff$link)) { stats::make.link(ff$link)$linkinv } else { match.fun("exp") } } #' @export link_inverse.MCMCglmm <- function(x, ...) { NULL } #' @export link_inverse.gamm <- function(x, ...) { x <- x$gam class(x) <- c(class(x), c("glm", "lm")) NextMethod() } #' @export link_inverse.stanmvreg <- function(x, ...) { fam <- stats::family(x) lapply(fam, function(.x) .x$linkinv) } #' @export link_inverse.gbm <- function(x, ...) { switch( x$distribution$name, laplace = , tdist = , gaussian = stats::gaussian(link = "identity")$linkinv, poisson = stats::poisson(link = "log")$linkinv, huberized = , adaboost = , coxph = , bernoulli = stats::make.link("logit")$linkinv ) } #' @export link_inverse.brmsfit <- function(x, ...) { fam <- stats::family(x) if (is_multivariate(x)) { lapply(fam, .brms_link_inverse) } else { .brms_link_inverse(fam) } } #' @rdname link_inverse #' @export link_inverse.gamlss <- function(x, what = c("mu", "sigma", "nu", "tau"), ...) { what <- match.arg(what) faminfo <- get(x$family[1], asNamespace("gamlss"))() switch( what, "mu" = faminfo$mu.linkinv, "sigma" = faminfo$sigma.linkinv, "nu" = faminfo$nu.linkinv, "tau" = faminfo$tau.linkinv, faminfo$mu.linkinv ) } #' @export link_inverse.bamlss <- function(x, ...) { flink <- stats::family(x)$links[1] tryCatch( { stats::make.link(flink)$linkinv }, error = function(e) { print_colour("\nCould not find appropriate link-inverse-function.\n", "red") } ) } #' @export link_inverse.glmmPQL <- function(x, ...) { x$family$linkinv } #' @export link_inverse.MixMod <- link_inverse.glmmPQL #' @export link_inverse.cgam <- link_inverse.glmmPQL #' @export link_inverse.vgam <- function(x, ...) { x@family@linkinv } #' @export link_inverse.vglm <- link_inverse.vgam #' @export link_inverse.gam <- function(x, ...) { li <- tryCatch( { .gam_family(x)$linkinv }, error = function(x) { NULL } ) if (is.null(li)) { mi <- .gam_family(x) if (.obj_has_name(mi, "linfo")) { if (.obj_has_name(mi$linfo, "linkinv")) { li <- mi$linfo$linkinv } else { li <- mi$linfo[[1]]$linkinv } } } li } # helper -------------- .brms_link_inverse <- function(fam) { # do we have custom families? if (!is.null(fam$family) && (is.character(fam$family) && fam$family == "custom")) { il <- stats::make.link(fam$link)$linkinv } else { if ("linkinv" %in% names(fam)) { il <- fam$linkinv } else if ("link" %in% names(fam) && is.character(fam$link)) { il <- stats::make.link(fam$link)$linkinv } else { ff <- get(fam$family, asNamespace("stats")) il <- ff(fam$link)$linkinv } } il } #' @importFrom stats poisson .get_cplm_family <- function(x) { link <- parse(text = .safe_deparse(x@call))[[1]]$link if (!is.numeric(link)) { stats::poisson(link = link) } else { if (!requireNamespace("statmod", quietly = TRUE)) { stop("Package 'statmod' required. Please install it.") } statmod::tweedie(link.power = link) } } insight/R/helper_functions.R0000644000176200001440000003666513613300340015623 0ustar liggesusers# remove trailing/leading spaces from character vectors .trim <- function(x) gsub("^\\s+|\\s+$", "", x) # remove NULL elements from lists .compact_list <- function(x) x[!sapply(x, function(i) length(i) == 0 || is.null(i) || any(i == "NULL"))] # remove empty string from character .compact_character <- function(x) x[!sapply(x, function(i) nchar(i) == 0 || is.null(i) || any(i == "NULL"))] # remove values from vector .remove_values <- function(x, values) { remove <- x %in% values if (any(remove)) { x <- x[!remove] } x } # rename values in a vector .rename_values <- function(x, old, new) { x[x %in% old] <- new x } # is string empty? .is_empty_string <- function(x) { x <- x[!is.na(x)] length(x) == 0 || all(nchar(x) == 0) } # is string empty? .is_empty_object <- function(x) { if (is.list(x)) { x <- tryCatch( { .compact_list(x) }, error = function(x) { x } ) } # this is an ugly fix because of ugly tibbles if (inherits(x, c("tbl_df", "tbl"))) x <- as.data.frame(x) x <- suppressWarnings(x[!is.na(x)]) length(x) == 0 || is.null(x) } # does string contain pattern? .string_contains <- function(pattern, x) { pattern <- paste0("\\Q", pattern, "\\E") grepl(pattern, x, perl = TRUE) } # has object an element with given name? .obj_has_name <- function(x, name) { name %in% names(x) } # checks if a brms-models is a multi-membership-model .is_multi_membership <- function(x) { if (inherits(x, "brmsfit")) { re <- find_random(x, split_nested = TRUE, flatten = TRUE) any(grepl("^(mmc|mm)\\(", re)) } else { return(FALSE) } } # merge data frames, remove double columns .merge_dataframes <- function(data, ..., replace = TRUE) { # check for identical column names tmp <- cbind(...) if (nrow(data) == 0) { return(tmp) } doubles <- colnames(tmp) %in% colnames(data) # keep order? reihenfolge <- c(which(!doubles), which(doubles)) # remove duplicate column names, if requested if (replace && any(doubles)) tmp <- tmp[, !doubles, drop = FALSE] # bind all data x <- cbind(tmp, data) # restore order if (replace) { # check for correct length. if "data" had duplicated variables, # but not all variable are duplicates, add indices of regular values if (ncol(x) > length(reihenfolge)) { # get remaining indices xl <- seq_len(ncol(x))[-seq_len(length(reihenfolge))] # add to "reihefolge" reihenfolge <- c(reihenfolge, xl) } # sort data frame x <- x[, order(reihenfolge), drop = FALSE] } x } # removes random effects from a formula that is in lmer-notation #' @importFrom stats terms drop.terms update .get_fixed_effects <- function(f) { f_string <- .safe_deparse(f) # for some wird brms-models, we also have a "|" in the response. # in order to check for "|" only in the random effects, we have # to remove the response here... f_response <- .safe_deparse(f[[2]]) f_predictors <- sub(f_response, "", f_string, fixed = TRUE) if (grepl("|", f_predictors, fixed = TRUE)) { # intercept only model, w/o "1" in formula notation? # e.g. "Reaction ~ (1 + Days | Subject)" if (length(f) > 2 && grepl("^\\(", .safe_deparse(f[[3]]))) { # check if we have any terms *after* random effects, e.g. # social ~ (1|school) + open + extro + agree + school if (.formula_empty_after_random_effect(f_predictors)) { # here we fix intercept only models with random effects, # like social ~ (1|school). .trim(paste0(.safe_deparse(f[[2]]), " ~ 1")) } else { # here we fix models where random effects come first, # like social ~ (1|school) + open + extro + agree + school # the regex removes "(1|school) + " .trim(gsub("\\((.*)\\)(\\s)*\\+(\\s)*", "", f_string)) } } else if (!grepl("\\+(\\s)*\\((.*)\\)", f_string)) { f_terms <- stats::terms(f) pos_bar <- grep("|", labels(f_terms), fixed = TRUE) no_bars <- stats::drop.terms(f_terms, pos_bar, keep.response = TRUE) stats::update(f_terms, no_bars) } else { .trim(gsub("\\+(\\s)*\\((.*)\\)", "", f_string)) } } else { .trim(gsub("\\+(\\s)*\\((.*)\\)", "", f_string)) } } # check if any terms appear in the formula after random effects # like "~ (1|school) + open + extro + agree + school" # this regex removes "(1|school)", as well as any +, -, *, whitespace etc. # if there are any chars left, these come from further terms that come after # random effects... .formula_empty_after_random_effect <- function(f) { nchar(gsub("(~|\\+|\\*|-|/|:)", "", gsub(" ", "", gsub("\\((.*)\\)", "", f)))) == 0 } # extract random effects from formula .get_model_random <- function(f, split_nested = FALSE, model) { is_special <- inherits(model, c("MCMCglmm", "gee", "LORgee", "mixor", "clmm2", "felm", "feis", "BFBayesFactor", "BBmm", "glimML", "MANOVA", "RM", "cglm")) if (!requireNamespace("lme4", quietly = TRUE)) { stop("To use this function, please install package 'lme4'.") } if (identical(.safe_deparse(f), "~0") || identical(.safe_deparse(f), "~1")) { return(NULL) } re <- sapply(lme4::findbars(f), .safe_deparse) if (is_special && .is_empty_object(re)) { re <- all.vars(f[[2L]]) if (length(re) > 1) { re <- as.list(re) split_nested <- FALSE } } else { re <- .trim(substring(re, max(gregexpr(pattern = "\\|", re)[[1]]) + 1)) } # check for multi-membership models if (inherits(model, "brmsfit")) { if (grepl("mm\\((.*)\\)", re)) { re <- trimws(unlist(strsplit(gsub("mm\\((.*)\\)", "\\1", re), ","))) } } if (split_nested) { # remove parenthesis for nested models re <- unique(unlist(strsplit(re, "\\:"))) # nested random effects, e.g. g1 / g2 / g3, deparse to "g0:(g1:g2)". # when we split at ":", we have "g0", "(g1" and "g2)". In such cases, # we need to remove the parantheses. But we need to preserve them in # case we have group factors in other models, like panelr, where we can # have "lag(union)" as group factor. In such cases, parantheses should be # preserved. We here check if group factors, after passing to "clean_names()", # still have "(" or ")" in their name, and if so, just remove parantheses # for these cases... has_parantheses <- vapply( clean_names(re), function(i) { grepl("[\\(\\)]", x = i) }, logical(1) ) if (any(has_parantheses)) { re[has_parantheses] <- gsub(pattern = "[\\(\\)]", replacement = "", x = re[has_parantheses]) } re } else { unique(re) } } # in case we need the random effects terms as formula (symbol), # not as character string, then call this functions instead of # .get_model_random() .get_group_factor <- function(x, f) { if (is.list(f)) { f <- lapply(f, function(.x) { .get_model_random(.x, split_nested = TRUE, x) }) } else { f <- .get_model_random(f, split_nested = TRUE, x) } if (is.null(f)) { return(NULL) } if (is.list(f)) { f <- lapply(f, function(i) sapply(i, as.symbol)) } else { f <- sapply(f, as.symbol) } f } # to reduce redundant code, I extract this part which is used several # times accross this package .get_elements <- function(effects, component) { elements <- c("conditional", "conditional2", "conditional3", "precision", "nonlinear", "random", "zero_inflated", "zero_inflated_random", "dispersion", "instruments", "interactions", "simplex", "smooth_terms", "sigma", "nu", "tau", "correlation", "slopes", "cluster", "extra", "scale") elements <- switch( effects, all = elements, fixed = elements[elements %in% c("conditional", "conditional2", "conditional3", "precision", "zero_inflated", "dispersion", "instruments", "interactions", "simplex", "smooth_terms", "correlation", "slopes", "sigma", "nonlinear", "cluster", "extra", "scale")], random = elements[elements %in% c("random", "zero_inflated_random")] ) elements <- switch( component, all = elements, conditional = elements[elements %in% c("conditional", "conditional2", "conditional3", "precision", "nonlinear", "random", "slopes")], zi = , zero_inflated = elements[elements %in% c("zero_inflated", "zero_inflated_random")], dispersion = elements[elements == "dispersion"], instruments = elements[elements == "instruments"], interactions = elements[elements == "interactions"], simplex = elements[elements == "simplex"], sigma = elements[elements == "sigma"], smooth_terms = elements[elements == "smooth_terms"], correlation = elements[elements == "correlation"], cluster = elements[elements == "cluster"], nonlinear = elements[elements == "nonlinear"], slopes = elements[elements == "slopes"], extra = elements[elements == "extra"], scale = elements[elements == "scale"], precision = elements[elements == "precision"] ) elements } # checks if a mixed model fit is singular or not. Need own function, # because lme4::isSingular() does not work with glmmTMB #' @importFrom stats na.omit .is_singular <- function(x, vals, tolerance = 1e-5) { if (!requireNamespace("lme4", quietly = TRUE)) { stop("Package `lme4` needs to be installed to compute variances for mixed models.", call. = FALSE) } tryCatch( { if (inherits(x, c("glmmTMB", "clmm", "cpglmm"))) { is_si <- any(sapply(vals$vc, function(.x) any(abs(diag(.x)) < tolerance))) } else if (inherits(x, "merMod")) { theta <- lme4::getME(x, "theta") diag.element <- lme4::getME(x, "lower") == 0 is_si <- any(abs(theta[diag.element]) < tolerance) } else if (inherits(x, "MixMod")) { vc <- diag(x$D) is_si <- any(sapply(vc, function(.x) any(abs(.x) < tolerance))) } else if (inherits(x, "lme")) { is_si <- any(abs(stats::na.omit(as.numeric(diag(vals$vc))) < tolerance)) } else { is_si <- FALSE } is_si }, error = function(x) { FALSE } ) } # Filter parameters from Stan-model fits .filter_pars <- function(l, parameters = NULL, is_mv = NULL) { if (!is.null(parameters)) { if (is.null(is_mv)) { is_mv <- isTRUE(attr(l, "is_mv", exact = TRUE) == "1") } if (is_multivariate(l) || is_mv) { for (i in names(l)) { l[[i]] <- .filter_pars_univariate(l[[i]], parameters) } } else { l <- .filter_pars_univariate(l, parameters) } if (isTRUE(is_mv)) attr(l, "is_mv") <- "1" } l } .filter_pars_univariate <- function(l, parameters) { lapply(l, function(component) { unlist(unname(sapply( parameters, function(pattern) { component[grepl(pattern = pattern, x = component, perl = TRUE)] }, simplify = FALSE ))) }) } # remove column .remove_column <- function(data, variables) { data[, -which(colnames(data) %in% variables), drop = FALSE] } .grep_smoothers <- function(x) { grepl("^(s\\()", x, perl = TRUE) | grepl("^(ti\\()", x, perl = TRUE) | grepl("^(te\\()", x, perl = TRUE) | grepl("^(t2\\()", x, perl = TRUE) | grepl("^(gam::s\\()", x, perl = TRUE) | grepl("^(VGAM::s\\()", x, perl = TRUE) | grepl("^(mgcv::s\\()", x, perl = TRUE) | grepl("^(mgcv::ti\\()", x, perl = TRUE) | grepl("^(mgcv::te\\()", x, perl = TRUE) | grepl("^(brms::s\\()", x, perl = TRUE) | grepl("^(brms::t2\\()", x, perl = TRUE) | grepl("^(smooth_sd\\[)", x, perl = TRUE) } .grep_zi_smoothers <- function(x) { grepl("^(s\\.\\d\\()", x, perl = TRUE) | grepl("^(gam::s\\.\\d\\()", x, perl = TRUE) | grepl("^(mgcv::s\\.\\d\\()", x, perl = TRUE) } .grep_non_smoothers <- function(x) { grepl("^(?!(s\\())", x, perl = TRUE) & # this one captures smoothers in zi- or mv-models from gam grepl("^(?!(s\\.\\d\\())", x, perl = TRUE) & grepl("^(?!(ti\\())", x, perl = TRUE) & grepl("^(?!(te\\())", x, perl = TRUE) & grepl("^(?!(t2\\())", x, perl = TRUE) & grepl("^(?!(gam::s\\())", x, perl = TRUE) & grepl("^(?!(gam::s\\.\\d\\())", x, perl = TRUE) & grepl("^(?!(VGAM::s\\())", x, perl = TRUE) & grepl("^(?!(mgcv::s\\())", x, perl = TRUE) & grepl("^(?!(mgcv::s\\.\\d\\())", x, perl = TRUE) & grepl("^(?!(mgcv::ti\\())", x, perl = TRUE) & grepl("^(?!(mgcv::te\\())", x, perl = TRUE) & grepl("^(?!(brms::s\\())", x, perl = TRUE) & grepl("^(?!(brms::t2\\())", x, perl = TRUE) & grepl("^(?!(smooth_sd\\[))", x, perl = TRUE) } # .split_formula <- function(f) { # rhs <- if (length(f) > 2) # f[[3L]] # else # f[[2L]] # # lapply(.extract_formula_parts(rhs), .safe_deparse) # } # # # .extract_formula_parts <- function(x, sep = "|") { # if (is.null(x)) # return(NULL) # rval <- list() # if (length(x) > 1L && x[[1L]] == sep) { # while (length(x) > 1L && x[[1L]] == sep) { # rval <- c(x[[3L]], rval) # x <- x[[2L]] # } # } # c(x, rval) # } .safe_deparse <- function(string) { paste0(sapply(deparse(string, width.cutoff = 500), .trim, simplify = TRUE), collapse = " ") } #' @importFrom stats family .gam_family <- function(x) { faminfo <- tryCatch( { stats::family(x) }, error = function(e) { NULL } ) # try to set manually, if not found otherwise if (is.null(faminfo)) { faminfo <- tryCatch( { x$family }, error = function(e) { NULL } ) } faminfo } # for models with zero-inflation component, return # required component of model-summary .filter_component <- function(dat, component) { switch( component, "cond" = , "conditional" = dat[dat$Component == "conditional", ], "zi" = , "zero_inflated" = dat[dat$Component == "zero_inflated", ], "dispersion" = dat[dat$Component == "dispersion", ], "smooth_terms" = dat[dat$Component == "smooth_terms", ], dat ) } # capitalizes the first letter in a string .capitalize <- function(x) { capped <- grep("^[A-Z]", x, invert = TRUE) substr(x[capped], 1, 1) <- toupper(substr(x[capped], 1, 1)) x } .remove_backticks_from_parameter_names <- function(x) { if (is.data.frame(x) && "Parameter" %in% colnames(x)) { x$Parameter <- gsub("`", "", x$Parameter, fixed = TRUE) } x } .remove_backticks_from_string <- function(x) { if (is.character(x)) { x <- gsub("`", "", x, fixed = TRUE) } x } .remove_backticks_from_matrix_names <- function(x) { if (is.matrix(x)) { colnames(x) <- gsub("`", "", colnames(x), fixed = TRUE) rownames(x) <- gsub("`", "", colnames(x), fixed = TRUE) } x } #' @importFrom stats reshape #' @keywords internal .gather <- function(x, names_to = "key", values_to = "value", columns = colnames(x)) { if (is.numeric(columns)) columns <- colnames(x)[columns] dat <- stats::reshape( x, idvar = "id", ids = row.names(x), times = columns, timevar = names_to, v.names = values_to, varying = list(columns), direction = "long" ) if (is.factor(dat[[values_to]])) dat[[values_to]] <- as.character(dat[[values_to]]) dat[, 1:(ncol(dat) - 1), drop = FALSE] } insight/NEWS.md0000644000176200001440000002036513615554214013031 0ustar liggesusers# insight 0.8.1 ## New supported model classes * `cglm` (*cglm*), `DirichletRegModel` (*DirichletReg*). ## General * Improved efficiency of `find_parameters()` and `get_parameters()` for mixed models with large samples and many random effects, and only fixed effects where requested. ## Changes to functions * `model_info()` now returns `$is_multinomial` for multinomial (but not ordinal or cumulative) link models. * `format_value()` gets an `as_percent` argument to format values as percentages. ## Bug fixes * Fixed issue in `get_data()` for *clmm2*-models. * Fixed issue in `get_data()` for models that used the `lspline()`-function. * Fixed issue in `get_statistic()` for *multinom* models. * Fixed issue in `get_priors()` for *stanreg* models with flat intercept priors. * Fixed tests that failed due to latest **fixest** update. # insight 0.8.0 ## New supported model classes * `brglm` (*brglm*), `cgam`, `cgamm` (*cgam*), `cpglm`, `cpglmm` (*cplm*), `feglm` (*apaca*), `glmmadmb` (*glmmADMB*), `glmx` (*glmx*), partial support for `mcmc` (*coda*), `mixor` (*mixor*), `MANOVA`, `RM` (*MANOVA.RM*). ## General * Better handling of `clm2`, `clmm2` and `rqss` models. ## New functions * `format_ci()` (re-implemented and slightly enhanced from _parameters_), to format confidence/credible intervals. ## Changes to functions * `find_parameters()` now also works for `BFBayesFactor` objects. * Suppress non-informative warning in `get_data()` for model data with weights. * `format_value()` automatically uses scientific notation for *very* large numbers (> 1e+5). Furthermore, the check for integer values was made more robust, to avoid warnings when checking *very* large numbers for integer type. * Improved `find_parameters()`, `get_parameters()` and `clean_parameters()` for `BFBayesFactor`-objects. * `get_priors()` now works for `stanmvreg` objects. * Other minor improvements. ## Bug fixes * Better detect Tweedie-models in `model_info()`. * Fixed issue in `find_random_slopes()` for *panelr*-models with multiple random-effect parts. * Fixed issues with `zerotrunc` models. * Fixed issues with `brmsfit` models with correlated random effects. * Fixed issue with edge-cases in `clean_names()`. * Fixed issue with breaking changes with latest *brms*-update. * Further minor bug fixes. # insight 0.7.1 ## New supported model classes * `complmrob` (*complmrob*), `fixest` (*fixest*), `mclogit` and `mmclogit` (*mclogit*). ## Bug fixes * Fixed bug in `find_formula()` for mixed models, when random effects are written before any fixed effects terms (like `social ~ (1|school) + open + extro`). * Fixed bug in `model_info()` for *VGAM* models, where logit-link was not always correctly identified. * Fixed issue in `get_priors()` for *brmsfit* models, where parameters of conditional and zero-inflated model components had identical names. This caused errors in `bayestestR::simulate_prior()`. * Fixed CRAN check issue. # insight 0.7.0 ## Breaking changes * In order to unify column names across easystats-packages, `get_parameters()` and `get_priors()` now return column names according to our naming conventions (i.e. capitalized column names). * `model_info()` returned both `$is_zeroinf` and `$is_zero_inflated` for zero-inflated models. Now `$is_zeroinf` is softly deprecated, so `model_info()` will return `$is_zero_inflated` only in future updates. ## New supported model classes * `aareg` (*survival*), `brmultinom` and `bracl` (*brglm2*), and `wbgee` (*panelr*). Furthermore, for different model-types from *panelr* models (within-between, between, etc.) are now also supported. * Preliminary support for `rma` models (*metafor*). ## Changes to functions * `get_statistic()` supports `multinom` models (*nnet*). * `link_inverse()` gets a `what`-argument, to return the link-inverse function for specific distribution parameters from **gamls** models. ## Bug fixes * Fixed edge case for `find_weights()`. * Fixed bug in `get_statistic()` for *glmmTMB* models that won't return any data. # insight 0.6.0 ## New supported model classes * `bayesx` (*R2BayesX*), `bamlss` (*bamlss*) and `flexsurvreg` (*flexsurv*). Note that support for these models is still somewhat experimental. * Support for *lavaan* and *blavaan* was added, but only applies to some of the functions: `get_data()`, `get_parameters()`, `find_parameters()`, `clean_parameters()`, `find_algorithm()` and `get_priors()` (the two latter only for *blavaan*). ## New functions * `get_statistic()` to return the test statistic of model estimates. * `get_varcov()` to return the variance-covariance matrix for models. * `supported_models()` to print a list of supported models. ## Changes to functions * `model_info()` now returns the element `is_survival` for survival models. * `model_info()` now returns the element `is_truncated` for truncated regression, or *brmsfit* models with `trunc()` as additional response part. * `model_info()` now recognizes beta and beta inflated families from package *gamlss*. * Better support for nonlinear quantile regression (`quantreg::nlrq()`). * Better support for nonlinear mixed models (`lme4::nlmer()`). Note that model-specification requires the random term to be written in parentheses, i.e. `(slope | group)`. ## Bug fixes * Fixed issues in `get_data()`, `find_parameters()` and `get_parameters()` for *gamlss* models. * Fixed issue in `get_data()` for *plm* models, where the `index`-argument was used in the `plm()`-function call. * Fixed issue in `get_data()`, `find_predictors()` and `find_variables()` for *brmsfit* multi-membership-models. * `is_model()` did not recognize objects of class `anova` and `manova`. * `model_info()` now correctly recognizes censored regression models from *brmsfit*. * Fixed issues in `find_parameters()` and `get_parameters()` with *multinom* models. * Fixed issues in `clean_names()` for cases where variable transformations where made in specific patterns, like `log(test/10)`. # insight 0.5.0 ## Breaking Changes * The previous `is_model()` function has been renamed to `is_model_supported()` since it was unclear if the function checked the entered object was a model or a supported model in *insight*. The new `is_model()` function checks if the entered object is a model object, while `is_model_supported()` checks if a supported model object. ## New functions * `find_statistic()` to return the test statistic of a regression model. * `format_value()` and `format_table()` as utility-functions to format (model) output, especially for tabular output. * `color_if()` as utility-function to add color formatting to values, depending on certain conditions. ## General * Make extraction of model family information more stable for gam-objects. ## Changes to functions * `find_parameters()` and `get_parameters()` now also support objects of class `sim` and `sim.merMod` (from `arm::sim()`). * `get_variance()` now also supports models of class *clmm*. * `find_predictors()` and `find_variables()` now include the Euclidean distance matrix for spatial models from *glmmTMB* (returned as random effects element, or more precise, as random slope). ## Bug fixes * `find_formula()` now extracts group factors of random effects for *gamlss* models. * `find_parameters()` and `get_parameters()` no longer show `NA` coefficients from group factors of random effects for *gamlss* models. * `find_parameters()` and `get_parameters()` did not work for multivariate response models of class *brmsfit* when argument `parameters` was specified. * `get_data()` dropped value and variable label attributes, when model frame contained matrix variables (like splines). * `get_priors()` swapped column names `location` and `scale` for *brmsfit* -objects. * `get_parameters()` did not work for *glmmTMB* models without zero-inflation component. * `find_predictors()` did not remove parentheses from terms in multiple nested random effects. * Better support for *gam* models (package *mgcv*) with `ziplss` or `mvn` families. # insight 0.4.1 ## Changes to functions * `get_variance()` now supports models with Gamma-family. * `get_weights()` and `find_weights()` now work for *brms*-models. ## Bug fixes * Fix CRAN-check issues due to recent update from the *panelr*-package. insight/MD50000644000176200001440000002564213615601156012244 0ustar liggesusersa68b8069f64557fb840ae9239dc0fb3d *DESCRIPTION 1d230dddca5c883f07afd8d2e43b7689 *NAMESPACE 23e4076f41eb880be125ada95aab9588 *NEWS.md dc8d65e62e7ee58df1114ff139fe5401 *R/all_equal_models.R aeca14e11166af6a7ad19c8c21551513 *R/clean_names.R 6b8f93d2ba388f38667af3bea5557e7d *R/clean_parameters.R ba35db022b740bf2066e840380408f71 *R/color_if.R 61df921b8e7647fff07c89f4ab4a5868 *R/colour_tools.R c888fecd5d81eda3c585b57fca655db1 *R/compute_variances.R 9fb3e79faf86feaa0578b9a91c6924d0 *R/download_model.R 811ab9a0b92a13b62f42d9a56c81df6c *R/find_algorithm.R dc6b504924c16b02fec34300c92c6446 *R/find_formula.R f8057a8964264c1007c9b74f52614218 *R/find_interactions.R 4aa90e0256c81d65c531dd548adfb51c *R/find_parameters.R a6ffe6d96d59c7c589bdf464c94da049 *R/find_predictors.R 0835173d8a559f33fc37ef59ed976bba *R/find_random.R a357e8071edf03de22d5b947cfae2956 *R/find_random_slopes.R d86db51b6e871ea60dad254beafc09bc *R/find_response.R cc8c6450febfb5f3faddb08618f0fbfd *R/find_statistic.R 860de0cfcde49b8a1397a958714f59aa *R/find_terms.R 1ebab94b309b14236b84cd3b73be80a9 *R/find_variables.R d16a518ed5705a955057ae1058778ab8 *R/find_weights.R 01dec103d0d215941b1473f1beca696b *R/format_ci.R 29ad6cfb1b57e90bca0cdc0bc1473b6e *R/format_table.R a70305d27d72d270314567ae3388acb6 *R/format_value.R d6dc55ee44810cc1201e796673b12c9e *R/get_data.R 5d6c13813da07a8acdb595a7aaf02aab *R/get_nested_lme_varcorr.R 5e1d11f96cd160f07508c901ee79f88e *R/get_parameters.R 44003292e87c658d58b42149be373209 *R/get_predictors.R b8124d501cd79411a9ce67ed20b5f005 *R/get_priors.R 9af4f178cdfe7128237c4db1ed145307 *R/get_random.R 61ca352eff83e6860560442ab68c582f *R/get_response.R 602067eaaca35158800f20096c2c46d7 *R/get_statistic.R d78909827263dcee0f141d3b4a61f715 *R/get_varcov.R e869293c4fcbda4b6a5bf8e8923e22f7 *R/get_variances.R 5e3c2ada471c68a4d45bbb2490d238da *R/get_weights.R 35bda8f5c9af2fb037923dce8de72881 *R/has_intercept.R f041f21e1a7e3540246f9e54cd6646ce *R/helper_functions.R fb41342f64857e6a9fdc4b20419394c1 *R/is_model.R 1326b5d39b4268017897a5611bd00339 *R/is_model_supported.R 1b8cc11b5206d6f136e2761e0bff1f34 *R/is_multivariate.R ace8a39f103ed6ae780afab76e739b45 *R/is_nullmodel.R c396c972a7c0b18ca30cf6774d46c86f *R/link_function.R 0d929fb2ebf441b5b6bc89121a760734 *R/link_inverse.R 556d09d7a345d7b1b22528d92e937d9e *R/model_info.R 33adafadfaf1246d82534173f8510db7 *R/n_obs.R 95729c3d67066619fb165216b4511c7d *R/print.easystats_check.R 355cfb877da1a7c340e6e6d2711cc02d *R/print_color.R db236865adde5dd4b126a266dcbb9e12 *R/print_parameters.R e5aa52e6210ba720de303f92bb92f30a *R/utils_get_data.R 122e6f31b4a75f4a02990a7b1a5e2400 *R/utils_model_info.R e4f5dd5b481548cf07a74bdfde6127df *README.md 81a6a76b4d761d40a511741da114abe1 *build/partial.rdb ff97a19cbd5f291efce6296e130388d4 *build/vignette.rds fbd584790cacf26fa9e176040cb6d473 *inst/CITATION 58f1d39b8b4b9805bcc145fe995669b4 *inst/WORDLIST 7d1e8774d6fc84dfb770919331105163 *inst/doc/insight.R f966cff74a57381b9576307abb67c811 *inst/doc/insight.Rmd c0a539aac73bfc4a9083f9ffab6aa127 *inst/doc/insight.html ece9b53ac27ac5a772fe520d56f05b37 *man/all_models_equal.Rd f3ab0ff98a9182fd26a16b86c2441840 *man/clean_names.Rd d4fc6c09087717bfc4b1ac578ae2c4a9 *man/clean_parameters.Rd 9f17ef3a3aceb898a2331877f8c4b5d7 *man/color_if.Rd 3cb443dcacfa4ad1d223a80896b7de05 *man/dot-colour_detect.Rd aeb7141efd9f340944e5b5a6e3b06274 *man/download_model.Rd 734dc632a0c942a6c4bd3b04cb972714 *man/figures/logo.png 944ac94f1489aa4a78766026bcdbfba0 *man/find_algorithm.Rd 2452c443f163a0cbf1301296437caf01 *man/find_formula.Rd d69548da157044e65c3f45897c377c64 *man/find_interactions.Rd 072b2fd222b7cdeec3f37652386e0ee9 *man/find_parameters.Rd d3c0b9c5df0361ced429b60cd0ada321 *man/find_predictors.Rd 1b480e76a54bbaf023497438bf989591 *man/find_random.Rd cd327282231be6a00867254e654ad3ec *man/find_random_slopes.Rd 65f2e159a21134f78171fab9dc9a5d57 *man/find_response.Rd ca69717fc48a0a7aec230c10f2576687 *man/find_statistic.Rd 405aa07633011c061c4a8e6e6252e87a *man/find_terms.Rd f8d4fa43aed638a1d146cb63f1038057 *man/find_variables.Rd eaf5b6847622a83e757b2cdb65841e3e *man/find_weights.Rd 6f39e464ab9c8f57c3cb74f195d205ec *man/format_ci.Rd b072b187fc8ccbe3670c4b6a76963e1e *man/format_table.Rd de1a59d5008614e72530f6cc989c0f31 *man/format_value.Rd ab7f1c92b066499b7c67c790eebbc5e7 *man/get_data.Rd 13e37ff6361e0421eb045d00d7ded95e *man/get_parameters.Rd a954191d7fad45d859b82fb6be682bcd *man/get_predictors.Rd c1463a27e53d7830cfd3a1772bb34876 *man/get_priors.Rd 973e08c92295e83ab5aa98d6be9d9c5c *man/get_random.Rd 1703f76c56aef7b0a8aef7fb2b06885e *man/get_response.Rd f3d8ef1570cf41964b79c674f35fe400 *man/get_statistic.Rd 7182186091a95dab4a364d71c2e514e1 *man/get_varcov.Rd 7c8dd1dead299be14d43aafb80c3fdc2 *man/get_variance.Rd 052063ba912ae4c675e2617dfc546e5a *man/get_weights.Rd 890c95cf4d4afc9c6f08c8fffce71bc1 *man/has_intercept.Rd c05022b512db3533a33f4407c68daeda *man/is_model.Rd 5027ed84606ecd86e32f9fab257eeac6 *man/is_model_supported.Rd a7a67eb751941698a2c4974a2924975e *man/is_multivariate.Rd fe388894ccf9332f5595f2084de9036d *man/is_nullmodel.Rd cf35b9749dca2bcf83268fcd122774b9 *man/link_function.Rd 23fea2811f4e2f3887cd17fc7554151e *man/link_inverse.Rd 8d7388e5cbbc41103d31ead8603ae3e7 *man/model_info.Rd adb8540f10a7fc3d5db253a7a7779cdc *man/n_obs.Rd 06a901761fcf0229358ab16965bb66ac *man/print_color.Rd b9b4dad841c173259551b05c95e1fb89 *man/print_parameters.Rd 52e4cfc6848ac432bf7398e4f7b41889 *tests/spelling.R 3dd94ae1e0749ef1002f19657e397e9c *tests/testthat.R 9aed3735208b6021bef14abfbbb1428b *tests/testthat/test-BBmm.R 5dd24406d389762aabe47934d041f1a1 *tests/testthat/test-BBreg.R fd5f3ed1b491395fd868873c1cc3c9e3 *tests/testthat/test-BayesFactorBF.R 94da1ec7d940380cec89beebff2cee51 *tests/testthat/test-GLMMadaptive.R 8065c872e8fe1f2924e0f4f12c2ea1b5 *tests/testthat/test-Gam2.R 52c2f8a2d321b8720929568e88e17ce1 *tests/testthat/test-LORgee.R 4c763e3b95422697d561452b3c56cf23 *tests/testthat/test-MCMCglmm.R 13f801a82df54ed18f4c2f6c80e8f80d *tests/testthat/test-all_models_equal.R 8b75cac17e186c9e022739c19d3a5ac2 *tests/testthat/test-aovlist.R b67ecfaa85c6ef20c9a2bae450cdee4a *tests/testthat/test-backticks.R 79708e58b61f24385d6507b55c5eed9f *tests/testthat/test-betabin.R 957f2479a2d1c17af5fa04d1297477a8 *tests/testthat/test-betareg.R 733f0d8e30a49b1b4712865dc7396bfb *tests/testthat/test-bigglm.R b44364f7575aaa520b0edaa5131eb0fe *tests/testthat/test-blmer.R 4155d85275a17145ff51ef6868fd55dd *tests/testthat/test-brms.R 7fcbbc2fd523ed1ddffd73fb2f4f86fb *tests/testthat/test-censReg.R d22ba49a163f552c55feb601c8a799d5 *tests/testthat/test-cgam.R 03371b63ce766a6664781cec54250a8d *tests/testthat/test-clean_names.R 6da3fb5e729cc514d90674f11f03ffd1 *tests/testthat/test-clm.R b23bd9dcde395c763b9d44508e7f437f *tests/testthat/test-clm2.R 2ddb2eeda393640e691e035b265bb8bb *tests/testthat/test-clmm.R 1f4d897184d35112e414535a3d907b2b *tests/testthat/test-coxme.R 3c3c15234105d77544b920fc76ba3e8c *tests/testthat/test-coxph.R 82e4d513c4c66a5c6d66a3f9708d3362 *tests/testthat/test-cpglmm.R 83b518e4f236a2436026ac492061786c *tests/testthat/test-crch.R d483a040cc014385cb3bc26311e2faa3 *tests/testthat/test-data.frame.R b662d6ab1dd3e436ddc9ae6c8adda936 *tests/testthat/test-feis.R 9f536e0c63368278aa51db2bdc17b85f *tests/testthat/test-felm.R b16e13c6b188ac4354c5bac87be8ba5b *tests/testthat/test-find_predictor_nested_re.R e7cdd93a1ddf3549d4c8e292744b8d3f *tests/testthat/test-fixest.R 2a1f111701da379b67504f9b71917651 *tests/testthat/test-format.R c06cc2ea6f4e95ef416c581933c25c24 *tests/testthat/test-gam.R 61538fc31cd9f27e12cdc1b5c3105ee5 *tests/testthat/test-gamlss.R 7b6bca67537f7a693c3f7204e139f252 *tests/testthat/test-gamm.R 4d16a8a0efda98800a4bf797c1078847 *tests/testthat/test-gamm4.R 4c79580a3b43e3a6c15501dd8332e287 *tests/testthat/test-gbm.R 05248a55faac183c565ca83578535565 *tests/testthat/test-gee.R 8385354858fed70e4754b67c9b66c900 *tests/testthat/test-geeglm.R d4a4a706ad076fb2fdabe70b76023c99 *tests/testthat/test-glm.R 6843a85f2ad7021c701b9078c9faf049 *tests/testthat/test-glmmTMB.R f10ca5e562ffdeafe41e05d7014c6710 *tests/testthat/test-glmrob_base.R 1111e497893bd07eb1bd4b98f04f821d *tests/testthat/test-gls.R 92efb4694e248c2afc0bac79dedc56b6 *tests/testthat/test-gmnl.R cb2caa435f66f5eaf382fcd4c0427e84 *tests/testthat/test-has_intercept.R 8a7b0f4435c8f665b33f11264c39f4fc *tests/testthat/test-hurdle.R 7060a383e0d0f9d74d67403a49683a2c *tests/testthat/test-is_nullmodel.R 85f5db194c0bf9e8d7839f0b17257348 *tests/testthat/test-iv_robust.R e2ddfc68139cab3f9b70b3e9edf7b405 *tests/testthat/test-ivreg.R 14a2b2521c94b8733f160f5a9456edf8 *tests/testthat/test-lm.R 0374bc51a563526cbaa8fba9b830fd02 *tests/testthat/test-lm_robust.R 8241e4d63c78bdecb01ca524faf71bea *tests/testthat/test-lme.R 68f05a78f3b6e264c79c6c0f09bd696f *tests/testthat/test-lmer.R 71db4717b46d02faa15d1093a8e9bb99 *tests/testthat/test-lmrob_base.R 4474e95b660138754653d4fd8e60ed62 *tests/testthat/test-logistf.R 3e58715f2c7874343a9e50df23ce255b *tests/testthat/test-mixed.R 6b239a7a073800c8c60477b0b61fd16b *tests/testthat/test-mlogit.R 7fb20ff47143bddc06cf5fd2b7e48074 *tests/testthat/test-model_data.R 1ca31d326415b541f6f648c11bb36358 *tests/testthat/test-multinom.R 897582736faf5ba78dab495971a875ac *tests/testthat/test-mvrstanarm.R eb1c57e5001a3fce271a7f4113d45c61 *tests/testthat/test-namespace.R 716ced5290ed0760839f7fd7441b5cbd *tests/testthat/test-negbin.R 1c19193291e5cfbec10aed335b1c77b2 *tests/testthat/test-nlmer.R 0834b1c8afdeb25eb22ce536408b5107 *tests/testthat/test-ols.R 99509a9c325345c7111dd571a45bc400 *tests/testthat/test-panelr.R 94ae87449625e15e69d9355074707033 *tests/testthat/test-plm.R 383b125a184f45c2a9a2cc946032c72f *tests/testthat/test-polr.R ea659cee47de22e1b1bd5ef45cca567c *tests/testthat/test-psm.R 6dcf3f9a614caa9904c4986a3c97c2a7 *tests/testthat/test-response_data2.R 9112c12cfecec61344e39d7b1ddabd93 *tests/testthat/test-rlmer.R 49a99f9911999a7f421e94b8ccc4fcc0 *tests/testthat/test-rms.R d5411a53849d4ccac730fa24d3ba8fd0 *tests/testthat/test-rq.R 36ff4675cc8111abf31c657e26765243 *tests/testthat/test-rqss.R 2f046107347d18468d0c67b312d09599 *tests/testthat/test-rstanarm.R 896104e77424208ac1c224eec7f8c96b *tests/testthat/test-spatial.R 1ea0ae21b0ebfb3f7c9616f3f15542a1 *tests/testthat/test-speedglm.R 16d19b137855d3294964cd612bda370d *tests/testthat/test-speedlm.R d39579cc70cb6d57816fc5fd1de6fc80 *tests/testthat/test-survey.R a8908e7d7629654a94e36c02545530c6 *tests/testthat/test-survfit.R 506f47f2e186d41e9675ea7536420e0f *tests/testthat/test-survreg.R 212a6bbe0862876de239f948e788fb65 *tests/testthat/test-tobit.R 646ee584092453ab22f321a2618f9b8f *tests/testthat/test-truncreg.R 3e4f4aa8ca386085aa830f83487c2afb *tests/testthat/test-vgam.R 5d0d52c0cb1bcd5deb509a9e1c24ad1d *tests/testthat/test-vglm.R 63d361b549958d9d3c845f9f978a9c8a *tests/testthat/test-zeroinfl.R b3d6e26817614fc39933f2c801d2e074 *vignettes/figure3a.png d2532dd9f119fa9ee21d77389ce0d16c *vignettes/figure3b.png 517c45734e9c9dc34738063ff7e81ed0 *vignettes/figure3c.png 3e810b7bbd075fb581640cac1148ce86 *vignettes/figure3d.png f966cff74a57381b9576307abb67c811 *vignettes/insight.Rmd 1a24201ab3d9d3a81bf9dd53bb5102cd *vignettes/insight_design_1.png insight/inst/0000755000176200001440000000000013615562366012711 5ustar liggesusersinsight/inst/doc/0000755000176200001440000000000013615562367013457 5ustar liggesusersinsight/inst/doc/insight.html0000644000176200001440000105542713615562366016027 0ustar liggesusers Getting Started with Accessing Model Information

Getting Started with Accessing Model Information

When fitting any statistical model, there are many useful pieces of information that are simultaneously calculated and stored beyond coefficient estimates and general model fit statistics. Although there exist some generic functions to obtain model information and data, many package-specific modeling functions do not provide such methods to allow users to access such valuable information.

insight is an R-package that fills this important gap by providing a suite of functions to support almost any model. The goal of insight, then, is to provide tools to provide easy, intuitive, and consistent access to information contained in model objects. These tools aid applied research in virtually any field who fit, diagnose, and present statistical models by streamlining access to every aspect of many model objects via consistent syntax and output.

Built with non-programmers in mind, insight offers a broad toolbox for making model and data information easily accessible. While insight offers many useful functions for working with and understanding model objects (discussed below), we suggest users start with model_info(), as this function provides a clean and consistent overview of model objects (e.g., functional form of the model, the model family, link function, number of observations, variables included in the specification, etc.). With a clear understanding of the model introduced, users are able to adapt other functions for more nuanced exploration of and interaction with virtually any model object.

Overview of Core Functions

A statistical model is an object describing the relationship between variables. Although there are a lot of different types of models, each with their specificities, most of them also share some common components. The goal of insight is to help you retrieve these components.

The get_* prefix extracts values (or data) associated with model-specific objects (e.g., parameters or variables), while the find_* prefix lists model-specific objects (e.g., priors or predictors). These are powerful families of functions allowing for great flexibility in use, whether at a high, descriptive level (find_*) or narrower level of statistical inspection and reporting (get_*). We point users to the package documentation or the complementary package website, https://easystats.github.io/insight/, for a detailed list of the arguments associated with each function as well as the returned values from each function.

Definition of Model Components

The functions from insight address different components of a model. In an effort to avoid confusion about specific “targets” of each function, in this section we provide a short explanation of insight’s definitions of regression model components.

Data

The dataset used to fit the model.

Parameters

Values estimated or learned from data that capture the relationship between variables. In regression models, these are usually referred to as coefficients.

Response and Predictors

  • response: the outcome or response variable (dependent variable) of a regression model.
  • predictor: independent variables of (the fixed part of) a regression model. For mixed models, variables that are only in the random effects part (i.e. grouping factors) of the model are not returned as predictors by default. However, these can be included using additional arguments in the function call, treating predictors are “unique”. As such, if a variable appears as a fixed effect and a random slope, it is treated as one (the same) predictor.

Variables

Any unique variable names that appear in a regression model, e.g., response variable, predictors or random effects. A “variable” only relates to the unique occurrence of a term, or the term name. For instance, the expression x + poly(x, 2) has only the variable x.

Terms

Terms themselves consist of variable and factor names separated by operators, or involve arithmetic expressions. For instance, the expression x + poly(x, 2) has one variable x, but two terms x and poly(x, 2).

Random Effects

  • random slopes: variables that are specified as random slopes in a mixed effects model.
  • random or grouping factors: variables that are specified as grouping variables in a mixed effects model.

Examples

Aren’t the predictors, terms, and parameters the same thing?

In some cases, yes. But not in all cases, and sometimes it is useful to have the “bare” variable names (terms), but sometimes it is also useful to have the information about a possible transformation of variables. That is the main reason for having functions that cover similar aspects of a model object (like find_terms() and find_predictors() or find_variables()).

Here are some examples that demonstrate the differences of each function:

Finally, there is find_parameters(). Parameters are also known as coefficients, and find_parameters() does exactly that: returns the model coefficients.

Examples of Use Cases in R

We now would like to provide examples of use cases of the insight package. These examples probably do not cover typical real-world problems, but serve as illustration of the core idea of this package: The unified interface to access model information. insight should help both users and package developers in order to reduce the hassle with the many exceptions from various modelling packages when accessing model information.

Making Predictions at Specific Values of a Term of Interest

Say, the goal is to make predictions for a certain term, holding remaining co-variates constant. This is achieved by calling predict() and feeding the newdata-argument with the values of the term of interest as well as the “constant” values for remaining co-variates. The functions get_data() and find_predictors() are used to get this information, which then can be used in the call to predict().

In this example, we fit a simple linear model, but it could be replaced by (m)any other models, so this approach is “universal” and applies to many different model objects.

Printing Model Coefficients

The next example should emphasize the possibilities to generalize functions to many different model objects using insight. The aim is simply to print coefficients in a complete, human readable sentence.

The first approach uses the functions that are available for some, but obviously not for all models, to access the information about model coefficients.

As we can see, the function fails for gam-models. As the access to models depends on the type of the model in the R ecosystem, we would need to create specific functions for all models types. With insight, users can write a function without having to worry about the model type.

Examples of Use Cases in R packages

insight is already used by different packages to solve problems that typically occur when the users’ inputs are different model objects of varying complexity.

For example, ggeffects, a package that computes and visualizes marginal effects of regression models, requires extraction of the data (get_data()) that was used to fit the models, and also the retrieval all model predictors (find_predictors()) to decide which covariates are held constant when computing marginal effects. All of this information is required in order to create a data frame for predict(newdata=<data frame>). Furthermore, the models’ link-functions (link_function()) resp. link-inverse-functions (link_inverse()) are required to obtain predictors at the model’s response scale.

The sjPlot-package creates plots or summary tables from regression models, and uses insight-functions to get model-information (model_info() or find_response()), which is used to build the components of the final plot or table. This information helps, for example, in labeling table columns by providing information on the effect type (odds ratio, incidence rate ratio, etc.) or the different model components, which split plots and tables into the “conditional” and “zero-inflated” parts of a model, in the cases of models with zero-inflation.

bayestestR mainly relies on get_priors() and get_parameters() to retrieve the necessary information to compute various indices or statistics of Bayesian models (like HDI, Credible Interval, MCSE, effective sample size, Bayes factors, etc.). The advantage of get_parameters() in this context is that regardless of the number of parameters the posterior distribution has, the necessary data can be easily accessed from the model objects. There is no need to write original, complicated code or regular expressions.

A last example is the performance-package, which provides functions for computing measures to assess model quality. Many of these indices (e.g. check for overdispersion or zero-inflation, predictive accuracy, logloss, RMSE, etc.) require the number of observations (n_obs()) or the data from the response-variable (get_response()). Again, in this context, functions from insight are helpful, because they offer a unified access to this information.

insight/inst/doc/insight.Rmd0000644000176200001440000003224213614067316015564 0ustar liggesusers--- title: "Getting Started with Accessing Model Information" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{insight} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) if (!requireNamespace("lme4", quietly = TRUE)) { knitr::opts_chunk$set(eval = FALSE) } ``` When fitting any statistical model, there are many useful pieces of information that are simultaneously calculated and stored beyond coefficient estimates and general model fit statistics. Although there exist some generic functions to obtain model information and data, many package-specific modeling functions do not provide such methods to allow users to access such valuable information. **insight** is an R-package that fills this important gap by providing a suite of functions to support almost any model. The goal of **insight**, then, is to provide tools to provide *easy*, *intuitive*, and *consistent* access to information contained in model objects. These tools aid applied research in virtually any field who fit, diagnose, and present statistical models by streamlining access to every aspect of many model objects via consistent syntax and output. Built with non-programmers in mind, **insight** offers a broad toolbox for making model and data information easily accessible. While **insight** offers many useful functions for working with and understanding model objects (discussed below), we suggest users start with `model_info()`, as this function provides a clean and consistent overview of model objects (*e.g.*, functional form of the model, the model family, link function, number of observations, variables included in the specification, etc.). With a clear understanding of the model introduced, users are able to adapt other functions for more nuanced exploration of and interaction with virtually any model object. ## Overview of Core Functions A statistical model is an object describing the relationship between variables. Although there are a lot of *different types* of models, each with their specificities, most of them also share some *common components*. The goal of **insight** is to help you retrieve these components. The `get_*` prefix extracts *values* (or *data*) associated with model-specific objects (e.g., parameters or variables), while the `find_*` prefix *lists* model-specific objects (e.g., priors or predictors). These are powerful families of functions allowing for great flexibility in use, whether at a high, descriptive level (`find_*`) or narrower level of statistical inspection and reporting (`get_*`). We point users to the package documentation or the complementary package website, https://easystats.github.io/insight/, for a detailed list of the arguments associated with each function as well as the returned values from each function. ```{r out.width="100%", echo=FALSE} knitr::include_graphics("insight_design_1.png", dpi = 72) ``` ## Definition of Model Components The functions from **insight** address different components of a model. In an effort to avoid confusion about specific "targets" of each function, in this section we provide a short explanation of **insight**'s definitions of regression model components. ### Data The dataset used to fit the model. ### Parameters Values estimated or learned from data that capture the relationship between variables. In regression models, these are usually referred to as *coefficients*. ### Response and Predictors * **response**: the outcome or response variable (dependent variable) of a regression model. * **predictor**: independent variables of (the _fixed_ part of) a regression model. For mixed models, variables that are only in the _random effects_ part (i.e. grouping factors) of the model are not returned as predictors by default. However, these can be included using additional arguments in the function call, treating predictors are "unique". As such, if a variable appears as a fixed effect and a random slope, it is treated as one (the same) predictor. ```{r out.width="65%", echo=FALSE} knitr::include_graphics("figure3a.png", dpi = 72) ``` ### Variables Any unique variable names that appear in a regression model, e.g., response variable, predictors or random effects. A "variable" only relates to the unique occurrence of a term, or the term name. For instance, the expression `x + poly(x, 2)` has only the variable `x`. ```{r out.width="80%", echo=FALSE} knitr::include_graphics("figure3b.png", dpi = 72) ``` ### Terms Terms themselves consist of variable and factor names separated by operators, or involve arithmetic expressions. For instance, the expression `x + poly(x, 2)` has _one_ variable `x`, but _two_ terms `x` and `poly(x, 2)`. ```{r out.width="80%", echo=FALSE} knitr::include_graphics("figure3c.png", dpi = 72) ``` ### Random Effects * **random slopes**: variables that are specified as random slopes in a mixed effects model. * **random or grouping factors**: variables that are specified as grouping variables in a mixed effects model. ```{r out.width="65%", echo=FALSE} knitr::include_graphics("figure3d.png", dpi = 72) ``` ## Examples *Aren't the predictors, terms, and parameters the same thing?* In some cases, yes. But not in all cases, and sometimes it is useful to have the "bare" variable names (terms), but sometimes it is also useful to have the information about a possible transformation of variables. That is the main reason for having functions that cover similar aspects of a model object (like `find_terms()` and `find_predictors()` or `find_variables()`). Here are some examples that demonstrate the differences of each function: ```{r echo=TRUE,message=FALSE,warning=FALSE} library(insight) library(lme4) data(sleepstudy) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA sleepstudy$Weeks <- sleepstudy$Days / 7 sleepstudy$cat <- as.factor(sample(letters[1:4], nrow(sleepstudy), replace = TRUE)) for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } model <- lmer( Reaction ~ Days + I(Days^2) + log1p(Weeks) + cat + (1 | mygrp / mysubgrp) + (1 + Days | Subject), data = sleepstudy ) ``` ```{r echo=TRUE,message=FALSE,warning=FALSE} # find the response variable find_response(model) # find all predictors, fixed part by default find_predictors(model) # find random effects, grouping factors only find_random(model) # find random slopes find_random_slopes(model) # find all predictors, including random effects find_predictors(model, effects = "all", component = "all") # find all terms, including response and random effects # this is essentially the same as the previous example plus response find_terms(model) # find all variables, i.e. also quadratic or log-transformed predictors find_variables(model) ``` Finally, there is `find_parameters()`. Parameters are also known as *coefficients*, and `find_parameters()` does exactly that: returns the model coefficients. ```{r echo=TRUE,message=FALSE,warning=FALSE} # find model parameters, i.e. coefficients find_parameters(model) ``` ## Examples of Use Cases in R We now would like to provide examples of use cases of the **insight** package. These examples probably do not cover typical real-world problems, but serve as illustration of the core idea of this package: The unified interface to access model information. **insight** should help both users and package developers in order to reduce the hassle with the many exceptions from various modelling packages when accessing model information. ### Making Predictions at Specific Values of a Term of Interest Say, the goal is to make predictions for a certain term, holding remaining co-variates constant. This is achieved by calling `predict()` and feeding the `newdata`-argument with the values of the term of interest as well as the "constant" values for remaining co-variates. The functions `get_data()` and `find_predictors()` are used to get this information, which then can be used in the call to `predict()`. In this example, we fit a simple linear model, but it could be replaced by (m)any other models, so this approach is "universal" and applies to many different model objects. ``` r library(insight) m <- lm( Sepal.Length ~ Species + Petal.Width + Sepal.Width, data = iris ) dat <- get_data(m) pred <- find_predictors(m, flatten = TRUE) l <- lapply(pred, function(x) { if (is.numeric(dat[[x]])) mean(dat[[x]]) else unique(dat[[x]]) }) names(l) <- pred l <- as.data.frame(l) cbind(l, predictions = predict(m, newdata = l)) #> Species Petal.Width Sepal.Width predictions #> 1 setosa 1.199333 3.057333 5.101427 #> 2 versicolor 1.199333 3.057333 6.089557 #> 3 virginica 1.199333 3.057333 6.339015 ``` ### Printing Model Coefficients The next example should emphasize the possibilities to generalize functions to many different model objects using **insight**. The aim is simply to print coefficients in a complete, human readable sentence. The first approach uses the functions that are available for some, but obviously not for all models, to access the information about model coefficients. ``` r print_params <- function(model){ paste0( "My parameters are ", paste0(row.names(summary(model)$coefficients), collapse = ", "), ", thank you for your attention!" ) } m1 <- lm(Sepal.Length ~ Petal.Width, data = iris) print_params(m1) #> [1] "My parameters are (Intercept), Petal.Width, thank you for your attention!" # obviously, something is missing in the output m2 <- mgcv::gam(Sepal.Length ~ Petal.Width + s(Petal.Length), data = iris) print_params(m2) #> [1] "My parameters are , thank you for your attention!" ``` As we can see, the function fails for *gam*-models. As the access to models depends on the type of the model in the R ecosystem, we would need to create specific functions for all models types. With **insight**, users can write a function without having to worry about the model type. ``` r print_params <- function(model){ paste0( "My parameters are ", paste0(insight::find_parameters(model, flatten = TRUE), collapse = ", "), ", thank you for your attention!" ) } m1 <- lm(Sepal.Length ~ Petal.Width, data = iris) print_params(m1) #> [1] "My parameters are (Intercept), Petal.Width, thank you for your attention!" m2 <- mgcv::gam(Sepal.Length ~ Petal.Width + s(Petal.Length), data = iris) print_params(m2) #> [1] "My parameters are (Intercept), Petal.Width, s(Petal.Length), thank you for your attention!" ``` ## Examples of Use Cases in R packages **insight** is already used by different packages to solve problems that typically occur when the users' inputs are different model objects of varying complexity. For example, [**ggeffects**](https://strengejacke.github.io/ggeffects), a package that computes and visualizes marginal effects of regression models, requires extraction of the data (`get_data()`) that was used to fit the models, and also the retrieval all model predictors (`find_predictors()`) to decide which covariates are held constant when computing marginal effects. All of this information is required in order to create a data frame for `predict(newdata=)`. Furthermore, the models' link-functions (`link_function()`) resp. link-inverse-functions (`link_inverse()`) are required to obtain predictors at the model's response scale. The [**sjPlot**-package](https://strengejacke.github.io/sjPlot/) creates plots or summary tables from regression models, and uses **insight**-functions to get model-information (`model_info()` or `find_response()`), which is used to build the components of the final plot or table. This information helps, for example, in labeling table columns by providing information on the effect type (odds ratio, incidence rate ratio, etc.) or the different model components, which split plots and tables into the "conditional" and "zero-inflated" parts of a model, in the cases of models with zero-inflation. [**bayestestR**](https://easystats.github.io/bayestestR/) mainly relies on `get_priors()` and `get_parameters()` to retrieve the necessary information to compute various indices or statistics of Bayesian models (like HDI, Credible Interval, MCSE, effective sample size, Bayes factors, etc.). The advantage of `get_parameters()` in this context is that regardless of the number of parameters the posterior distribution has, the necessary data can be easily accessed from the model objects. There is no need to write original, complicated code or regular expressions. A last example is the [**performance**-package](https://easystats.github.io/performance/), which provides functions for computing measures to assess model quality. Many of these indices (e.g. check for overdispersion or zero-inflation, predictive accuracy, logloss, RMSE, etc.) require the number of observations (`n_obs()`) or the data from the response-variable (`get_response()`). Again, in this context, functions from **insight** are helpful, because they offer a unified access to this information. insight/inst/doc/insight.R0000644000176200001440000000457313615562366015257 0ustar liggesusers## ---- include = FALSE--------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) if (!requireNamespace("lme4", quietly = TRUE)) { knitr::opts_chunk$set(eval = FALSE) } ## ----out.width="100%", echo=FALSE--------------------------------------------- knitr::include_graphics("insight_design_1.png", dpi = 72) ## ----out.width="65%", echo=FALSE---------------------------------------------- knitr::include_graphics("figure3a.png", dpi = 72) ## ----out.width="80%", echo=FALSE---------------------------------------------- knitr::include_graphics("figure3b.png", dpi = 72) ## ----out.width="80%", echo=FALSE---------------------------------------------- knitr::include_graphics("figure3c.png", dpi = 72) ## ----out.width="65%", echo=FALSE---------------------------------------------- knitr::include_graphics("figure3d.png", dpi = 72) ## ----echo=TRUE,message=FALSE,warning=FALSE------------------------------------ library(insight) library(lme4) data(sleepstudy) sleepstudy$mygrp <- sample(1:5, size = 180, replace = TRUE) sleepstudy$mysubgrp <- NA sleepstudy$Weeks <- sleepstudy$Days / 7 sleepstudy$cat <- as.factor(sample(letters[1:4], nrow(sleepstudy), replace = TRUE)) for (i in 1:5) { filter_group <- sleepstudy$mygrp == i sleepstudy$mysubgrp[filter_group] <- sample(1:30, size = sum(filter_group), replace = TRUE) } model <- lmer( Reaction ~ Days + I(Days^2) + log1p(Weeks) + cat + (1 | mygrp / mysubgrp) + (1 + Days | Subject), data = sleepstudy ) ## ----echo=TRUE,message=FALSE,warning=FALSE------------------------------------ # find the response variable find_response(model) # find all predictors, fixed part by default find_predictors(model) # find random effects, grouping factors only find_random(model) # find random slopes find_random_slopes(model) # find all predictors, including random effects find_predictors(model, effects = "all", component = "all") # find all terms, including response and random effects # this is essentially the same as the previous example plus response find_terms(model) # find all variables, i.e. also quadratic or log-transformed predictors find_variables(model) ## ----echo=TRUE,message=FALSE,warning=FALSE------------------------------------ # find model parameters, i.e. coefficients find_parameters(model) insight/inst/CITATION0000644000176200001440000000057313504604506014041 0ustar liggesusersbibentry( bibtype = "article", title = "insight: A Unified Interface to Access Information from Model Objects in R.", volume = "4", doi = "10.21105/joss.01412", number = "38", journal = "Journal of Open Source Software", author = c(person("Daniel", "Lüdecke"), person("Philip", "Waggoner"), person("Dominique", "Makowski")), year = "2019", pages = "1412" ) insight/inst/WORDLIST0000644000176200001440000000151713602213235014067 0ustar liggesusers’s AER afex al Anova aod apaca bamlss BayesFactor bayestestR BayesX biglm blavaan brglm brms brmsfit censReg clmm colour coloured Coloured comparator complmrob cplm crch doi DOI easystats estimatr et feisr fixest flexsurv gam gamls gamlss gbm ggeffects github GLMM GLMMadaptive glmmADMB glmmTMB glmx HDI HRQoL https Ieno intra intraclass io joss JOSS lavaan lfe logloss mclogit MCSE metafor mgcv MixMod mixor modelling monotic multgee multinom Nakagawa Newburgh nnet occurence optimizers panelr plm poisson polr pre quantreg rms robustbase robustlmm Savel'ev Schielzeth Schielzeth’s sjPlot specificities speedglm stanmvreg stanreg substracted substraction tibbles tranformations tweedie Tweedie untransformed variates VGAM warmup warmups Zuur