### setting enviorment ###
library(foreign)
library(semPLS)
## Loading required package: lattice
library(knitr)
setwd('/Users/huangzongxian/Desktop/20201208高等量化上機/PLS demo')
options(digits = 5, scipen = 999)
rm(list = ls())

1. Reference

### loading data ###
data <- read.csv("Corporate Reputation Data.csv", sep = ";")
str(data)
## 'data.frame':    344 obs. of  46 variables:
##  $ serviceprovider: int  3 3 3 3 3 3 1 1 3 3 ...
##  $ servicetype    : int  2 2 2 2 2 2 1 1 1 2 ...
##  $ csor_1         : int  3 2 3 3 4 3 7 4 7 4 ...
##  $ csor_2         : int  3 5 1 3 3 3 5 1 5 1 ...
##  $ csor_3         : int  3 6 2 5 4 4 7 3 6 5 ...
##  $ csor_4         : int  3 4 2 3 4 3 3 3 4 2 ...
##  $ csor_5         : int  3 6 4 5 4 3 3 2 6 4 ...
##  $ csor_global    : int  3 6 4 5 4 4 7 4 7 5 ...
##  $ attr_1         : int  5 6 5 3 6 4 5 4 6 5 ...
##  $ attr_2         : int  1 6 6 7 6 1 7 1 3 1 ...
##  $ attr_3         : int  3 6 5 5 6 5 3 5 7 6 ...
##  $ attr_global    : int  5 6 6 7 6 5 7 5 7 6 ...
##  $ perf_1         : int  5 6 4 5 5 6 4 5 7 6 ...
##  $ perf_2         : int  4 6 4 5 6 6 7 6 7 5 ...
##  $ perf_3         : int  2 6 2 5 7 4 6 6 4 4 ...
##  $ perf_4         : int  5 6 5 3 6 5 5 4 6 6 ...
##  $ perf_5         : int  6 6 4 6 5 6 4 7 7 5 ...
##  $ perf_global    : int  6 6 5 6 7 6 7 7 7 6 ...
##  $ qual_1         : int  5 6 3 5 6 5 5 6 7 6 ...
##  $ qual_2         : int  6 6 4 6 5 5 5 3 7 6 ...
##  $ qual_3         : int  4 6 3 6 7 5 6 2 6 5 ...
##  $ qual_4         : int  2 6 4 7 7 6 4 1 7 6 ...
##  $ qual_5         : int  4 5 3 5 6 5 7 6 6 7 ...
##  $ qual_6         : int  4 6 5 4 6 6 7 5 7 7 ...
##  $ qual_7         : int  2 6 4 5 6 3 4 1 6 4 ...
##  $ qual_8         : int  5 5 4 6 7 4 4 5 7 7 ...
##  $ qual_global    : int  6 6 5 7 7 6 7 6 7 7 ...
##  $ like_1         : int  3 6 5 6 6 6 4 4 7 6 ...
##  $ like_2         : int  1 6 5 5 6 7 1 3 5 6 ...
##  $ like_3         : int  2 6 5 6 7 7 7 4 7 6 ...
##  $ comp_1         : int  4 6 4 6 6 3 7 6 5 6 ...
##  $ comp_2         : int  5 7 5 4 4 4 5 6 7 5 ...
##  $ comp_3         : int  5 6 2 4 6 4 7 6 6 5 ...
##  $ cusl_1         : int  5 7 7 7 6 7 7 5 5 6 ...
##  $ cusl_2         : int  3 7 7 7 7 7 7 4 7 6 ...
##  $ cusl_3         : int  3 7 5 7 7 7 7 6 7 7 ...
##  $ cusa           : int  5 7 6 6 6 6 7 4 6 6 ...
##  $ age            : int  2 6 2 3 2 2 1 5 1 3 ...
##  $ education      : int  3 3 3 4 2 2 2 2 1 2 ...
##  $ occupation     : int  11 -99 11 11 12 11 11 3 11 2 ...
##  $ nphh           : int  5 2 2 1 5 1 3 3 4 2 ...
##  $ sample_type    : int  1 1 1 1 1 1 1 1 1 1 ...
##  $ mga_1          : int  2 2 2 2 2 2 1 1 1 2 ...
##  $ mga_2          : int  1 1 1 1 1 1 1 1 1 1 ...
##  $ mga_3          : int  1 1 1 1 1 1 2 2 1 1 ...
##  $ mga_4          : int  1 1 1 1 1 1 1 1 1 1 ...
summary(data)
##  serviceprovider  servicetype       csor_1         csor_2         csor_3    
##  Min.   :1       Min.   :1.00   Min.   :1.00   Min.   :1.00   Min.   :1.00  
##  1st Qu.:1       1st Qu.:1.00   1st Qu.:3.00   1st Qu.:2.00   1st Qu.:3.00  
##  Median :2       Median :2.00   Median :4.00   Median :3.00   Median :4.00  
##  Mean   :2       Mean   :1.64   Mean   :4.24   Mean   :3.08   Mean   :3.99  
##  3rd Qu.:3       3rd Qu.:2.00   3rd Qu.:5.00   3rd Qu.:4.00   3rd Qu.:5.00  
##  Max.   :4       Max.   :2.00   Max.   :7.00   Max.   :7.00   Max.   :7.00  
##      csor_4         csor_5      csor_global       attr_1         attr_2    
##  Min.   :1.00   Min.   :1.00   Min.   :1.00   Min.   :1.00   Min.   :1.00  
##  1st Qu.:2.00   1st Qu.:3.00   1st Qu.:4.00   1st Qu.:4.00   1st Qu.:1.00  
##  Median :3.00   Median :4.00   Median :5.00   Median :5.00   Median :2.00  
##  Mean   :3.12   Mean   :3.98   Mean   :4.99   Mean   :4.99   Mean   :2.94  
##  3rd Qu.:4.00   3rd Qu.:5.00   3rd Qu.:6.00   3rd Qu.:6.00   3rd Qu.:5.00  
##  Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00  
##      attr_3      attr_global       perf_1         perf_2         perf_3    
##  Min.   :1.00   Min.   :2.00   Min.   :1.00   Min.   :1.00   Min.   :1.00  
##  1st Qu.:4.00   1st Qu.:5.00   1st Qu.:4.00   1st Qu.:4.00   1st Qu.:4.00  
##  Median :5.00   Median :6.00   Median :5.00   Median :5.00   Median :5.00  
##  Mean   :4.81   Mean   :5.59   Mean   :4.62   Mean   :5.07   Mean   :4.72  
##  3rd Qu.:6.00   3rd Qu.:7.00   3rd Qu.:6.00   3rd Qu.:6.00   3rd Qu.:6.00  
##  Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00  
##      perf_4         perf_5      perf_global       qual_1         qual_2    
##  Min.   :1.00   Min.   :1.00   Min.   :3.00   Min.   :1.00   Min.   :1.00  
##  1st Qu.:4.00   1st Qu.:4.00   1st Qu.:5.00   1st Qu.:4.00   1st Qu.:3.00  
##  Median :5.00   Median :5.00   Median :6.00   Median :5.00   Median :5.00  
##  Mean   :4.92   Mean   :4.97   Mean   :5.98   Mean   :5.05   Mean   :4.37  
##  3rd Qu.:6.00   3rd Qu.:6.00   3rd Qu.:7.00   3rd Qu.:6.00   3rd Qu.:5.00  
##  Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00  
##      qual_3         qual_4         qual_5         qual_6         qual_7   
##  Min.   :1.00   Min.   :1.00   Min.   :1.00   Min.   :1.00   Min.   :1.0  
##  1st Qu.:4.00   1st Qu.:3.00   1st Qu.:4.00   1st Qu.:4.00   1st Qu.:3.0  
##  Median :5.00   Median :4.00   Median :5.00   Median :5.00   Median :4.0  
##  Mean   :5.08   Mean   :4.41   Mean   :5.01   Mean   :4.92   Mean   :4.4  
##  3rd Qu.:6.00   3rd Qu.:5.00   3rd Qu.:6.00   3rd Qu.:6.00   3rd Qu.:6.0  
##  Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.0  
##      qual_8      qual_global       like_1         like_2         like_3    
##  Min.   :1.00   Min.   :2.00   Min.   :1.00   Min.   :1.00   Min.   :1.00  
##  1st Qu.:4.00   1st Qu.:5.00   1st Qu.:4.00   1st Qu.:3.00   1st Qu.:3.00  
##  Median :5.00   Median :6.00   Median :5.00   Median :4.00   Median :5.00  
##  Mean   :4.84   Mean   :6.03   Mean   :4.58   Mean   :4.25   Mean   :4.48  
##  3rd Qu.:6.00   3rd Qu.:7.00   3rd Qu.:6.00   3rd Qu.:6.00   3rd Qu.:6.00  
##  Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :7.00  
##      comp_1         comp_2         comp_3         cusl_1           cusl_2      
##  Min.   :1.00   Min.   :1.00   Min.   :1.00   Min.   :-99.00   Min.   :-99.00  
##  1st Qu.:4.00   1st Qu.:4.00   1st Qu.:4.00   1st Qu.:  4.00   1st Qu.:  4.00  
##  Median :5.00   Median :6.00   Median :5.50   Median :  5.00   Median :  6.00  
##  Mean   :4.65   Mean   :5.42   Mean   :5.22   Mean   :  4.22   Mean   :  4.06  
##  3rd Qu.:6.00   3rd Qu.:7.00   3rd Qu.:6.00   3rd Qu.:  6.00   3rd Qu.:  7.00  
##  Max.   :7.00   Max.   :7.00   Max.   :7.00   Max.   :  7.00   Max.   :  7.00  
##      cusl_3            cusa             age           education      
##  Min.   :-99.00   Min.   :-99.00   Min.   :-99.00   Min.   :-99.000  
##  1st Qu.:  5.00   1st Qu.:  5.00   1st Qu.:  2.00   1st Qu.:  2.000  
##  Median :  6.00   Median :  6.00   Median :  3.00   Median :  2.000  
##  Mean   :  4.74   Mean   :  5.14   Mean   :  3.04   Mean   : -0.105  
##  3rd Qu.:  7.00   3rd Qu.:  6.00   3rd Qu.:  4.00   3rd Qu.:  3.000  
##  Max.   :  7.00   Max.   :  7.00   Max.   :  6.00   Max.   :  4.000  
##    occupation         nphh         sample_type       mga_1          mga_2     
##  Min.   :-99.0   Min.   :-99.00   Min.   :1.00   Min.   :1.00   Min.   :1.00  
##  1st Qu.:  3.0   1st Qu.:  2.00   1st Qu.:1.00   1st Qu.:1.00   1st Qu.:1.00  
##  Median :  4.0   Median :  3.00   Median :1.00   Median :2.00   Median :1.00  
##  Mean   : -7.9   Mean   :  1.72   Mean   :1.83   Mean   :1.64   Mean   :1.49  
##  3rd Qu.:  7.0   3rd Qu.:  4.00   3rd Qu.:3.00   3rd Qu.:2.00   3rd Qu.:2.00  
##  Max.   : 13.0   Max.   :  5.00   Max.   :4.00   Max.   :2.00   Max.   :2.00  
##      mga_3         mga_4     
##  Min.   :1.0   Min.   :1.00  
##  1st Qu.:1.0   1st Qu.:1.00  
##  Median :2.0   Median :1.00  
##  Mean   :1.5   Mean   :1.29  
##  3rd Qu.:2.0   3rd Qu.:2.00  
##  Max.   :2.0   Max.   :2.00
data <- data[-which(data$cusa == -99 | data$cusl_1 == -99|
                    data$cusl_2 == -99 | data$cusl_3 == -99),] # missing value

2. Model Specification

# measurement model
CRPmm <- rbind(c('qual_1', 'QUAL'),
                c('qual_2', 'QUAL'),
                c('qual_3', 'QUAL'),
                c('qual_4', 'QUAL'),
                c('qual_5', 'QUAL'),
                c('qual_6', 'QUAL'),
                c('qual_7', 'QUAL'),
                c('qual_8', 'QUAL'),
                c('perf_1', 'PERF'),
                c('perf_2', 'PERF'),
                c('perf_3', 'PERF'),
                c('perf_4', 'PERF'),
                c('perf_5', 'PERF'),
                c('csor_1', 'CSOR'),
                c('csor_2', 'CSOR'),
                c('csor_3', 'CSOR'),
                c('csor_4', 'CSOR'),
                c('csor_5', 'CSOR'),
                c('attr_1', 'ATTR'),
                c('attr_2', 'ATTR'),
                c('attr_3', 'ATTR'),
                c('CUSA', 'cusa'),
                c('COMP', 'comp_1'),
                c('COMP', 'comp_2'),
                c('COMP', 'comp_3'),
                c('LIKE', 'like_1'),
                c('LIKE', 'like_2'),
                c('LIKE', 'like_3'),
                c('CUSL', 'cusl_1'),
                c('CUSL', 'cusl_2'),
                c('CUSL', 'cusl_3'))

# structural model
CRPsm <- rbind(c('QUAL', 'COMP'),
                c('QUAL', 'LIKE'),
                c('PERF', 'COMP'),
                c('PERF', 'LIKE'),
                c('CSOR', 'COMP'),
                c('CSOR', 'LIKE'),
                c('ATTR', 'COMP'),
                c('ATTR', 'LIKE'),
                c('COMP', 'CUSA'),
                c('COMP', 'CUSL'),
                c('LIKE', 'CUSA'),
                c('LIKE', 'CUSL'),
                c('CUSA', 'CUSL'))

3. Model Fitting

# fitting
CRP <- plsm(data = data, strucmod = CRPsm, measuremod = CRPmm)
CRP_fit <- sempls(model = CRP, data = data, wscheme = 'pathWeighting')
## All 336 observations are valid.
## Converged after 10 iterations.
## Tolerance: 0.0000001
## Scheme: path weighting
CRP_fit # basic results
##                    Path Estimate
## gam_1_1  attr_1 -> ATTR    0.418
## gam_1_2  attr_2 -> ATTR    0.204
## gam_1_3  attr_3 -> ATTR    0.656
## gam_2_1  csor_1 -> CSOR    0.274
## gam_2_2  csor_2 -> CSOR    0.035
## gam_2_3  csor_3 -> CSOR    0.418
## gam_2_4  csor_4 -> CSOR    0.094
## gam_2_5  csor_5 -> CSOR    0.421
## gam_3_1  perf_1 -> PERF    0.465
## gam_3_2  perf_2 -> PERF    0.170
## gam_3_3  perf_3 -> PERF    0.186
## gam_3_4  perf_4 -> PERF    0.350
## gam_3_5  perf_5 -> PERF    0.201
## gam_4_1  qual_1 -> QUAL    0.201
## gam_4_2  qual_2 -> QUAL    0.055
## gam_4_3  qual_3 -> QUAL    0.097
## gam_4_4  qual_4 -> QUAL   -0.011
## gam_4_5  qual_5 -> QUAL    0.157
## gam_4_6  qual_6 -> QUAL    0.397
## gam_4_7  qual_7 -> QUAL    0.228
## gam_4_8  qual_8 -> QUAL    0.203
## lam_5_1  COMP -> comp_1    0.823
## lam_5_2  COMP -> comp_2    0.823
## lam_5_3  COMP -> comp_3    0.842
## lam_6_1  LIKE -> like_1    0.879
## lam_6_2  LIKE -> like_2    0.866
## lam_6_3  LIKE -> like_3    0.846
## lam_7_1    CUSA -> cusa    1.000
## lam_8_1  CUSL -> cusl_1    0.834
## lam_8_2  CUSL -> cusl_2    0.919
## lam_8_3  CUSL -> cusl_3    0.844
## beta_1_5   ATTR -> COMP    0.085
## beta_2_5   CSOR -> COMP    0.057
## beta_3_5   PERF -> COMP    0.295
## beta_4_5   QUAL -> COMP    0.431
## beta_1_6   ATTR -> LIKE    0.159
## beta_2_6   CSOR -> LIKE    0.190
## beta_3_6   PERF -> LIKE    0.116
## beta_4_6   QUAL -> LIKE    0.378
## beta_5_7   COMP -> CUSA    0.135
## beta_6_7   LIKE -> CUSA    0.445
## beta_5_8   COMP -> CUSL    0.011
## beta_6_8   LIKE -> CUSL    0.334
## beta_7_8   CUSA -> CUSL    0.510
gof(CRP_fit)
##                     Value
## Average R-squared    0.51
## Average Communality  0.73
## GoF                  0.61
rSquared2(CRP_fit)
##      R-squared R-squared-corrected predecessors
## ATTR         .                   .            0
## CSOR         .                   .            0
## PERF         .                   .            0
## QUAL         .                   .            0
## COMP      0.63                0.62            4
## LIKE      0.56                0.55            4
## CUSA      0.29                0.29            2
## CUSL      0.56                0.56            3
## 
##  Average R-squared: 0.51
qSquared(CRP_fit, d = 5)
##      Q-Squared
## ATTR         .
## CSOR         .
## PERF         .
## QUAL         .
## COMP      0.41
## LIKE      0.39
## CUSA      0.29
## CUSL      0.41
# boot-strapping
CRPfit_Boot <- bootsempls(CRP_fit, nboot = 200, start = "ones", verbose = F)
## Loading required package: boot
## 
## Attaching package: 'boot'
## The following object is masked from 'package:lattice':
## 
##     melanoma
CRPfit_Bootsummary <- summary(CRPfit_Boot , type = "perc", level = 0.95)
tab <- cbind(CRP_fit$coefficients$Path, CRPfit_Bootsummary$table,
             CRPfit_Bootsummary$table$Estimate/CRPfit_Bootsummary$table$Std.Error)
kable(tab)
CRP_fit\(coefficients\)Path Estimate Bias Std.Error Lower Upper CRPfit_Bootsummary\(table\)Estimate/CRPfit_Bootsummary\(table\)Std.Error
gam_1_1 attr_1 -> ATTR 0.41812 0.00032 0.06804 0.29453 0.55567 6.14557
gam_1_2 attr_2 -> ATTR 0.20396 -0.00447 0.06829 0.05585 0.33309 2.98695
gam_1_3 attr_3 -> ATTR 0.65620 -0.00347 0.06130 0.52812 0.78245 10.70487
gam_2_1 csor_1 -> CSOR 0.27435 -0.00163 0.08207 0.09770 0.44487 3.34292
gam_2_2 csor_2 -> CSOR 0.03454 -0.00123 0.07525 -0.11582 0.18498 0.45903
gam_2_3 csor_3 -> CSOR 0.41827 -0.01796 0.08859 0.23564 0.56252 4.72158
gam_2_4 csor_4 -> CSOR 0.09417 -0.00055 0.07635 -0.05319 0.24337 1.23339
gam_2_5 csor_5 -> CSOR 0.42117 0.01258 0.09216 0.24813 0.61582 4.56983
gam_3_1 perf_1 -> PERF 0.46532 -0.00753 0.07153 0.31400 0.60212 6.50504
gam_3_2 perf_2 -> PERF 0.17039 -0.00273 0.07166 0.01505 0.31445 2.37785
gam_3_3 perf_3 -> PERF 0.18647 -0.00460 0.05796 0.05170 0.28256 3.21713
gam_3_4 perf_4 -> PERF 0.35005 0.00562 0.07033 0.21685 0.49442 4.97748
gam_3_5 perf_5 -> PERF 0.20102 0.00403 0.07135 0.05489 0.36962 2.81749
gam_4_1 qual_1 -> QUAL 0.20147 0.00069 0.06523 0.08525 0.33633 3.08863
gam_4_2 qual_2 -> QUAL 0.05531 -0.00544 0.05162 -0.04817 0.15474 1.07137
gam_4_3 qual_3 -> QUAL 0.09665 0.00656 0.06569 -0.00552 0.24167 1.47128
gam_4_4 qual_4 -> QUAL -0.01058 0.00664 0.05852 -0.10286 0.15532 -0.18089
gam_4_5 qual_5 -> QUAL 0.15670 -0.00605 0.06227 0.02334 0.27222 2.51645
gam_4_6 qual_6 -> QUAL 0.39721 0.00136 0.06842 0.26363 0.53563 5.80585
gam_4_7 qual_7 -> QUAL 0.22768 -0.01227 0.05801 0.08783 0.32582 3.92484
gam_4_8 qual_8 -> QUAL 0.20295 -0.00153 0.05949 0.08193 0.32076 3.41132
lam_5_1 COMP -> comp_1 0.82347 0.00197 0.01986 0.78406 0.86323 41.46727
lam_5_2 COMP -> comp_2 0.82250 0.00006 0.02167 0.77789 0.86345 37.96090
lam_5_3 COMP -> comp_3 0.84247 0.00152 0.02269 0.79188 0.88315 37.12209
lam_6_1 LIKE -> like_1 0.87859 -0.00058 0.01591 0.84457 0.90376 55.21887
lam_6_2 LIKE -> like_2 0.86624 0.00124 0.01737 0.82983 0.89963 49.87139
lam_6_3 LIKE -> like_3 0.84645 -0.00125 0.02032 0.80065 0.88371 41.64699
lam_7_1 CUSA -> cusa 1.00000 0.00000 0.00000 NA NA 19376801068279856.00000
lam_8_1 CUSL -> cusl_1 0.83396 0.00162 0.02449 0.77740 0.87569 34.05830
lam_8_2 CUSL -> cusl_2 0.91939 0.00166 0.00970 0.90074 0.93810 94.82814
lam_8_3 CUSL -> cusl_3 0.84355 0.00011 0.02390 0.79878 0.88538 35.29030
beta_1_5 ATTR -> COMP 0.08539 0.00353 0.05636 -0.02315 0.20294 1.51521
beta_2_5 CSOR -> COMP 0.05689 -0.00257 0.05429 -0.05351 0.15479 1.04796
beta_3_5 PERF -> COMP 0.29527 0.00188 0.07315 0.13737 0.45056 4.03659
beta_4_5 QUAL -> COMP 0.43140 0.00302 0.07186 0.28322 0.56610 6.00335
beta_1_6 ATTR -> LIKE 0.15864 -0.00756 0.06263 0.03064 0.26210 2.53309
beta_2_6 CSOR -> LIKE 0.18987 0.00469 0.05398 0.09634 0.30887 3.51707
beta_3_6 PERF -> LIKE 0.11577 0.00039 0.06963 -0.00086 0.27266 1.66265
beta_4_6 QUAL -> LIKE 0.37835 0.01074 0.06492 0.24170 0.51655 5.82829
beta_5_7 COMP -> CUSA 0.13500 0.00072 0.07004 -0.00241 0.26760 1.92733
beta_6_7 LIKE -> CUSA 0.44512 0.00233 0.06361 0.32051 0.57791 6.99794
beta_5_8 COMP -> CUSL 0.01149 0.00231 0.04828 -0.07633 0.11364 0.23794
beta_6_8 LIKE -> CUSL 0.33356 -0.00030 0.05332 0.23573 0.45172 6.25569
beta_7_8 CUSA -> CUSL 0.50994 -0.00153 0.03945 0.41893 0.57819 12.92626