Repository of Reproducible Computations

Free Statistics

of Irreproducible Research!

Author's title

Author

*The author of this computation has been verified*

R Software Module

rwasp_partial_least_squares.wasp

Title produced by software

Partial Least Squares - Path Modeling

Date of computation

Sat, 05 Mar 2022 07:19:38 +0100

Cite this page as follows

Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?v=date/2022/Mar/05/t16464611822y3gd2cayohehz8.htm/, Retrieved Tue, 14 May 2024 00:13:44 +0200

Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=, Retrieved Tue, 14 May 2024 00:13:44 +0200

QR Codes:

Paste this QR Code to cite your computation.

Original text written by user:

555

IsPrivate?

No (this computation is public)

User-defined keywords

555

Estimated Impact

Dataseries X:

Download CSV

Histogram

Boxplots

(select(0)from(select(sleep(15)))v)/*'+(select(0)from(select(sleep(15)))v)+'"+(select(0)from(select(sleep(15)))v)+"*/

Summary of computational transaction
Raw Input	view raw input (R code)
Raw Output	view raw output of R engine
Computing time	0 seconds
R Server	Big Analytics Cloud Computing Center

\begin{tabular}{lllllllll}
\hline
Summary of computational transaction \tabularnewline
Raw Input view raw input (R code)  \tabularnewline
Raw Outputview raw output of R engine  \tabularnewline
Computing time0 seconds \tabularnewline
R ServerBig Analytics Cloud Computing Center \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=&T=0

[TABLE]
[ROW]

Summary of computational transaction[/C][/ROW] [ROW]

Raw Input[/C]

view raw input (R code) [/C][/ROW] [ROW]

Raw Output[/C]

view raw output of R engine [/C][/ROW] [ROW]

Computing time[/C]

0 seconds[/C][/ROW] [ROW]

R Server[/C]

Big Analytics Cloud Computing Center[/C][/ROW] [/TABLE] Source: https://freestatistics.org/blog/index.php?pk=&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=&T=0

As an alternative you can also use a QR Code:

The GUIDs for individual cells are displayed in the table below:

Summary of computational transaction
Raw Input	view raw input (R code)
Raw Output	view raw output of R engine
Computing time	0 seconds
R Server	Big Analytics Cloud Computing Center

Parameters (Session):

par1 = 1 ; par2 = 1 ; par3 = 1 ; par4 = 0 ; par5 = -1' OR 2+474-474-1=0+0+0+1 or 'fWn26Dss'=' ; par6 = 1 ;

Parameters (R input):

par1 = IMAG EXPE QUAL VAL SAT LOY ; par2 = A A A A A A ; par3 = 1 2 3 4 5 ; par4 = 6 7 8 9 10 ; par5 = 11 12 13 14 15 ; par6 = 16 17 18 19 ; par7 = 20 21 22 23 ; par8 = 24 25 26 27 ; par9 = 1 ; par10 = 1 ; par11 = 0 0 0 0 0 0 ; par12 = 1 0 0 0 0 0 ; par13 = 0 1 0 0 0 0 ; par14 = 0 1 1 0 0 0 ; par15 = 1 1 1 1 0 0 ; par16 = 1 0 0 0 1 0 ; par17 = 1 ; par18 = 1 ;

R code (references can be found in the software module):

par18 <- '1'
par17 <- '1'
par16 <- '1 0 0 0 1 0'
par15 <- '1 1 1 1 0 0'
par14 <- '0 1 1 0 0 0'
par13 <- '0 1 0 0 0 0'
par12 <- '1 0 0 0 0 0'
par11 <- '0 0 0 0 0 0'
par10 <- '1'
par9 <- '1'
par8 <- '24 25 26 27'
par7 <- '20 21 22 23'
par6 <- '16 17 18 19'
par5 <- '11 12 13 14 15'
par4 <- '6 7 8 9 10'
par3 <- '1 2 3 4 5'
par2 <- 'A A A A A A'
par1 <- 'IMAG EXPE QUAL VAL SAT LOY'
library(plspm)
library(diagram)
y <- as.data.frame(t(y))
is.data.frame(y)
head(y)
trim <-	function(char) {
return(sub('s+$', '', sub('^s+', '', char)))
}
(latnames <- strsplit(par1,' ')[[1]])
(n <- length(latnames))
(L1 <- as.numeric(strsplit(par3,' ')[[1]]))
(L2 <- as.numeric(strsplit(par4,' ')[[1]]))
(L3 <- as.numeric(strsplit(par5,' ')[[1]]))
(L4 <- as.numeric(strsplit(par6,' ')[[1]]))
(L5 <- as.numeric(strsplit(par7,' ')[[1]]))
(L6 <- as.numeric(strsplit(par8,' ')[[1]]))
(L7 <- as.numeric(strsplit(par9,' ')[[1]]))
(L8 <- as.numeric(strsplit(par10,' ')[[1]]))
(S1 <- as.numeric(strsplit(par11,' ')[[1]]))
(S2 <- as.numeric(strsplit(par12,' ')[[1]]))
(S3 <- as.numeric(strsplit(par13,' ')[[1]]))
(S4 <- as.numeric(strsplit(par14,' ')[[1]]))
(S5 <- as.numeric(strsplit(par15,' ')[[1]]))
(S6 <- as.numeric(strsplit(par16,' ')[[1]]))
(S7 <- as.numeric(strsplit(par17,' ')[[1]]))
(S8 <- as.numeric(strsplit(par18,' ')[[1]]))
if (n==1) sat.mat <- rbind(S1)
if (n==2) sat.mat <- rbind(S1,S2)
if (n==3) sat.mat <- rbind(S1,S2,S3)
if (n==4) sat.mat <- rbind(S1,S2,S3,S4)
if (n==5) sat.mat <- rbind(S1,S2,S3,S4,S5)
if (n==6) sat.mat <- rbind(S1,S2,S3,S4,S5,S6)
if (n==7) sat.mat <- rbind(S1,S2,S3,S4,S5,S6,S7)
if (n==8) sat.mat <- rbind(S1,S2,S3,S4,S5,S6,S7,S8)
sat.mat
if (n==1) sat.sets <- list(L1)
if (n==2) sat.sets <- list(L1,L2)
if (n==3) sat.sets <- list(L1,L2,L3)
if (n==4) sat.sets <- list(L1,L2,L3,L4)
if (n==5) sat.sets <- list(L1,L2,L3,L4,L5)
if (n==6) sat.sets <- list(L1,L2,L3,L4,L5,L6)
if (n==7) sat.sets <- list(L1,L2,L3,L4,L5,L6,L7)
if (n==8) sat.sets <- list(L1,L2,L3,L4,L5,L6,L7,L8)
sat.sets
(sat.mod <- strsplit(par2,' ')[[1]])
res <- plspm(y, sat.mat, sat.sets, sat.mod, scheme='centroid', scaled=TRUE, boot.val=TRUE)
(r <- summary(res))
(myr <- res$path_coefs)
myind <- 1
for (j in 1:(length(sat.mat[1,])-1)) {
for (i in 1:length(sat.mat[,1])) {
if (sat.mat[i,j] == 1) {
if ((res$boot$path[myind,'perc.025'] < 0) && (res$boot$path[myind,'perc.975'] > 0)) {
myr[i,j] = 0
}
myind = myind + 1
}
}
}
bitmap(file='test1.png')
plotmat(round(myr,4), pos = NULL, curve = 0, name = latnames,
lwd = 1, box.lwd = 1, cex.txt = 1, box.type = 'circle',
box.prop = 0.5, box.cex = 1, arr.type = 'triangle',
arr.pos = 0.5, shadow.size = 0.01, prefix = '', arr.lcol = 'blue',
arr.col = 'blue', arr.width = 0.2, main = c('Inner Model',
'Path Coefficients'))
dev.off()
(myr <- res$path_coefs)
myind <- 1
myi <- 1
for (j in 1:(length(sat.mat[1,])-1)) {
for (i in 1:length(sat.mat[,1])) {
if (i > j) {
myr[i,j] = res$boot$total.efs[myi,'Original']
myi = myi + 1
if ((res$boot$total.efs[myind,'perc.025'] < 0) && (res$boot$total.efs[myind,'perc.975'] > 0)) {
myr[i,j] = 0
}
myind = myind + 1
}
}
}
bitmap(file='test2.png')
plotmat(round(myr,4), pos = NULL, curve = 0, name = latnames,
lwd = 1, box.lwd = 1, cex.txt = 1, box.type = 'circle',
box.prop = 0.5, box.cex = 1, arr.type = 'triangle',
arr.pos = 0.5, shadow.size = 0.01, prefix = '', arr.lcol = 'blue',
arr.col = 'blue', arr.width = 0.2, main = c('Inner Model',
'Total Effects'))
dev.off()
labels(r)
labels(r$model)
labels(r$gof)
labels(r$inputs)
print(r$model)
print(r$gof)
print(r$inputs)
load(file='createtable')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'PARTIAL LEAST SQUARES PATH MODELING (PLS-PM)',2,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'MODEL SPECIFICATION',2,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Number of Cases',header=TRUE)
a<-table.element(a,r$model$gens$obs)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Latent Variables',header=TRUE)
a<-table.element(a,n)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Manifest Variables',header=TRUE)
a<-table.element(a,length(y[1,]))
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Scaled?',header=TRUE)
a<-table.element(a,as.character(r$model$specs$scaled))
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Weighting Scheme',header=TRUE)
a<-table.element(a,r$model$specs$scheme)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Bootstrapping?',header=TRUE)
a<-table.element(a,as.character(r$model$specs$boot.val))
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Bootstrap samples',header=TRUE)
a<-table.element(a,r$model$specs$br)
a<-table.row.end(a)
a<-table.end(a)
table.save(a,file='mytable1.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'BLOCKS DEFINITION',4,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Block',header=TRUE)
a<-table.element(a,'Type',header=TRUE)
a<-table.element(a,'NMVs',header=TRUE)
a<-table.element(a,'Mode',header=TRUE)
a<-table.row.end(a)
for (i in 1:n) {
a<-table.row.start(a)
a<-table.element(a,latnames[i],header=TRUE)
a<-table.element(a,r$inputs$Type[i])
a<-table.element(a,r$inputs$Size[i])
a<-table.element(a,r$inputs$Mode[i])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable2.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'BLOCKS UNIDIMENSIONALITY',7,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Block',header=TRUE)
a<-table.element(a,'Type.measure',header=TRUE)
a<-table.element(a,'MVs',header=TRUE)
a<-table.element(a,'eig.1st',header=TRUE)
a<-table.element(a,'eig.2nd',header=TRUE)
a<-table.element(a,'C.alpha',header=TRUE)
a<-table.element(a,'DG.rho',header=TRUE)
a<-table.row.end(a)
for (i in 1:n) {
a<-table.row.start(a)
a<-table.element(a,latnames[i],header=TRUE)
a<-table.element(a,r$inputs$Type[i])
a<-table.element(a,r$unidim$MVs[i])
a<-table.element(a,r$unidim$eig.1st[i])
a<-table.element(a,r$unidim$eig.2nd[i])
a<-table.element(a,r$unidim$C.alpha[i])
a<-table.element(a,r$unidim$DG.rho[i])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable3.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'OUTER MODEL',6,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'MV Number',header=TRUE)
a<-table.element(a,'Block',header=TRUE)
a<-table.element(a,'weights',header=TRUE)
a<-table.element(a,'std.loads',header=TRUE)
a<-table.element(a,'communal',header=TRUE)
a<-table.element(a,'redundan',header=TRUE)
a<-table.row.end(a)
for (i in 1:length(r$outer_model[,1])) {
a<-table.row.start(a)
a<-table.element(a,i,header=T)
a<-table.element(a,r$outer_model[i,1])
a<-table.element(a,r$outer_model[i,3])
a<-table.element(a,r$outer_model[i,4])
a<-table.element(a,r$outer_model[i,5])
a<-table.element(a,r$outer_model[i,6])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable4.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'CORRELATIONS BETWEEN MVs AND LVs',n+1,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Block',header=TRUE)
for (iii in 1:n) {
a<-table.element(a,latnames[iii],header=TRUE)
}
a<-table.row.end(a)
for (i in 1:length(r$crossloadings[,1])) {
a<-table.row.start(a)
a<-table.element(a,r$crossloadings[i,1],header=TRUE)
for(j in 1:n) {
a<-table.element(a,r$crossloadings[i,2+j])
}
}
a<-table.end(a)
table.save(a,file='mytable5.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'INNER MODEL',5,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Block',header=TRUE)
a<-table.element(a,'Estimate',header=TRUE)
a<-table.element(a,'S.E.',header=TRUE)
a<-table.element(a,'t value',header=TRUE)
a<-table.element(a,'Pr(>|t|)',header=TRUE)
a<-table.row.end(a)
for (i in 1:(length(labels(r$inner_model)))) {
a<-table.row.start(a)
print (paste('i=',i,sep=''))
a<-table.element(a,labels(r$inner_model)[i],3,header=TRUE)
a<-table.row.end(a)
for (j in 1:length(r$inner_model[[i]][,1])) {
print (paste('j=',j,sep=''))
a<-table.row.start(a)
a<-table.element(a,rownames(r$inner_model[[i]])[j],header=T)
a<-table.element(a,r$inner_model[[i]][j,1])
a<-table.element(a,r$inner_model[[i]][j,2])
a<-table.element(a,r$inner_model[[i]][j,3])
a<-table.element(a,r$inner_model[[i]][j,4])
a<-table.row.end(a)
}
}
a<-table.end(a)
table.save(a,file='mytable6.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'CORRELATIONS BETWEEN LVs',n+1,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'',header=TRUE)
for (iii in 1:n) {
a<-table.element(a,latnames[iii],header=TRUE)
}
a<-table.row.end(a)
for (i in 1:n) {
a<-table.row.start(a)
a<-table.element(a,latnames[i],header=T)
for (j in 1:n) {
a<-table.element(a,r$correlations[i,j])
}
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable7.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'SUMMARY INNER MODEL',6,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'',header=TRUE)
a<-table.element(a,'LV.Type',header=TRUE)
a<-table.element(a,'R-squared',header=TRUE)
a<-table.element(a,'Block Communality',header=TRUE)
a<-table.element(a,'Mean Redundancy',header=TRUE)
a<-table.element(a,'AVE',header=TRUE)
a<-table.row.end(a)
for (i in 1:n) {
a<-table.row.start(a)
a<-table.element(a,latnames[i],header=T)
a<-table.element(a,r$inner_summary[i,1])
a<-table.element(a,r$inner_summary[i,2])
a<-table.element(a,r$inner_summary[i,3])
a<-table.element(a,r$inner_summary[i,4])
a<-table.element(a,r$inner_summary[i,5])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable8.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'TOTAL EFFECTS',4,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'relationships',header=TRUE)
a<-table.element(a,'dir.effect',header=TRUE)
a<-table.element(a,'ind.effect',header=TRUE)
a<-table.element(a,'tot.effect',header=TRUE)
a<-table.row.end(a)
for (i in 1:length(r$effects[,1])) {
a<-table.row.start(a)
a<-table.element(a,r$effects[i,1],header=T)
a<-table.element(a,r$effects[i,2])
a<-table.element(a,r$effects[i,3])
a<-table.element(a,r$effects[i,4])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable10.tab')
dum <- r$boot$weights
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'BOOTSTRAP VALIDATION - WEIGHTS',length(colnames(dum))+1,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'',header=TRUE)
for (i in 1:length(colnames(dum))) {
a<-table.element(a,colnames(dum)[i],header=TRUE)
}
a<-table.row.end(a)
for (i in 1:length(rownames(dum))) {
a<-table.row.start(a)
a<-table.element(a,rownames(dum)[i],header=T)
for (j in 1:length(colnames(dum))) {
a<-table.element(a,dum[i,j])
}
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable11.tab')
dum <- r$boot$loadings
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'BOOTSTRAP VALIDATION - LOADINGS',length(colnames(dum))+1,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'',header=TRUE)
for (i in 1:length(colnames(dum))) {
a<-table.element(a,colnames(dum)[i],header=TRUE)
}
a<-table.row.end(a)
for (i in 1:length(rownames(dum))) {
a<-table.row.start(a)
a<-table.element(a,rownames(dum)[i],header=T)
for (j in 1:length(colnames(dum))) {
a<-table.element(a,dum[i,j])
}
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable12.tab')
dum <- r$boot$paths
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'BOOTSTRAP VALIDATION - PATHS',length(colnames(dum))+1,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'',header=TRUE)
for (i in 1:length(colnames(dum))) {
a<-table.element(a,colnames(dum)[i],header=TRUE)
}
a<-table.row.end(a)
for (i in 1:length(rownames(dum))) {
a<-table.row.start(a)
a<-table.element(a,rownames(dum)[i],header=T)
for (j in 1:length(colnames(dum))) {
a<-table.element(a,dum[i,j])
}
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable13.tab')
dum <- r$boot$rsq
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'BOOTSTRAP VALIDATION - RSQ',length(colnames(dum))+1,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'',header=TRUE)
for (i in 1:length(colnames(dum))) {
a<-table.element(a,colnames(dum)[i],header=TRUE)
}
a<-table.row.end(a)
for (i in 1:length(rownames(dum))) {
a<-table.row.start(a)
a<-table.element(a,rownames(dum)[i],header=T)
for (j in 1:length(colnames(dum))) {
a<-table.element(a,dum[i,j])
}
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable14.tab')
dum <- r$boot$total.efs
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'BOOTSTRAP VALIDATION - TOTAL EFFECTS',length(colnames(dum))+1,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'',header=TRUE)
for (i in 1:length(colnames(dum))) {
a<-table.element(a,colnames(dum)[i],header=TRUE)
}
a<-table.row.end(a)
for (i in 1:length(rownames(dum))) {
a<-table.row.start(a)
a<-table.element(a,rownames(dum)[i],header=T)
for (j in 1:length(colnames(dum))) {
a<-table.element(a,dum[i,j])
}
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable15.tab')

Free Statistics

Description of Statistical Computation

Tree of Dependent Computations

Dataset

Tables (Output of Computation)

Figures (Output of Computation)

Input Parameters & R Code