From c1973560283599a7933c1d3b18bd5996fd4a33c5 Mon Sep 17 00:00:00 2001
From: Soumya Ray <soumya.ray@gmail.com>
Date: Fri, 9 Apr 2021 07:25:23 +0800
Subject: [PATCH] Produces unstandardized construct scores

---
 NAMESPACE                                   |   1 +
 R/unstandardize.R                           |  75 ++++++++++++++++++++
 man/unstandardize_scores.Rd                 |  13 ++++
 tests/fixtures/V_3_6_0/unstandardized.RData | Bin 0 -> 4495 bytes
 tests/testthat/test-unstandardize.R         |  36 ++++++++++
 5 files changed, 125 insertions(+)
 create mode 100644 R/unstandardize.R
 create mode 100644 man/unstandardize_scores.Rd
 create mode 100644 tests/fixtures/V_3_6_0/unstandardized.RData
 create mode 100644 tests/testthat/test-unstandardize.R

diff --git a/NAMESPACE b/NAMESPACE
index 9b1d8c71..3baa2085 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -93,3 +93,4 @@ export(specific_effect_significance)
 export(specify_model)
 export(total_indirect_ci)
 export(two_stage)
+export(unstandardize_scores)
diff --git a/R/unstandardize.R b/R/unstandardize.R
new file mode 100644
index 00000000..35a75344
--- /dev/null
+++ b/R/unstandardize.R
@@ -0,0 +1,75 @@
+# # https://rdrr.io/cran/plspm/src/R/rescale.r
+#
+# library(plspm)
+# data(satisfaction)
+#
+# # define path matrix (inner model)
+# IMAG <- c(0,0,0,0,0,0)
+# EXPE <- c(1,0,0,0,0,0)
+# QUAL <- c(0,1,0,0,0,0)
+# VAL <- c(0,1,1,0,0,0)
+# SAT <- c(1,1,1,1,0,0)
+# LOY <- c(1,0,0,0,1,0)
+# sat_path <- rbind(IMAG, EXPE, QUAL, VAL, SAT, LOY)
+#
+# # define list of blocks (outer model)
+# sat_blocks <- list(1:5, 6:10, 11:15, 16:19, 20:23, 24:27)
+#
+# # vector of modes (reflective indicators)
+# sat_modes <- rep("A", 6)
+#
+# # apply plspm with bootstrap validation
+# satpls <- plspm(satisfaction, sat_path, sat_blocks, modes = sat_modes,
+#                 scaled = FALSE, boot.val = TRUE)
+#
+# scores <- satpls$scores[,"IMAG"]
+# imag_data <- as.matrix(satpls$data[1:5])
+#
+# wgs <- satpls$outer_model$weight[1:5]
+# wgs/sum(wgs)
+# rescaled <- imag_data %*% (wgs/sum(wgs))
+#
+# as.vector(rescaled)
+# rescale(satpls)[,"IMAG"]
+
+#' Rescales standardized construct scores back into same units of items.
+#' Inspired by \code{rescale()} function of \code{plspm} package
+#' NOTE: Experimental feature only
+#'
+#' @example
+#' measurements <- constructs(
+#'   composite("Image",       multi_items("IMAG", 1:5)),
+#'   composite("Expectation", multi_items("CUEX", 1:3)),
+#'   composite("Loyalty",     multi_items("CUSL", 1:3)),
+#'   composite("Complaints",  single_item("CUSCO"))
+#' )
+#'
+#' structure <- relationships(
+#'   paths(from = c("Image", "Expectation"), to = c("Complaints", "Loyalty"))
+#' )
+#'
+#' pls_model <- estimate_pls(data = mobi, measurements, structure)
+#' unstandardize_scores(pls_model)
+#'
+#' @export
+unstandardize_scores <- function(pls_model) {
+  construct_names <- seminr:::construct_names(pls_model$smMatrix)
+
+  construct_names -> .
+    sapply(., seminr:::items_of_construct, model=pls_model) -> .
+    unlist(.) -> .
+    unname(.) -> .
+    . -> construct_items
+
+  relevant_data <- pls_model$data[, construct_items]
+  weights <- pls_model$outer_weights[names(relevant_data), ]
+  weight_sums <- matrix(colSums(weights), ncol(weights), ncol(weights))
+
+  weights %*% (1/weight_sums) -> .
+    .[weights == 0] <- 0
+    colnames(.) <- colnames(weights)
+    . -> normalized_wts
+
+  unstd_scores <- as.matrix(relevant_data) %*% normalized_wts
+  as.data.frame(unstd_scores)
+}
diff --git a/man/unstandardize_scores.Rd b/man/unstandardize_scores.Rd
new file mode 100644
index 00000000..21d0a4b4
--- /dev/null
+++ b/man/unstandardize_scores.Rd
@@ -0,0 +1,13 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/unstandardize.R
+\name{unstandardize_scores}
+\alias{unstandardize_scores}
+\title{Rescales standardized construct scores back into same units of items.
+Inspired by \code{rescale()} function of \code{plspm} package}
+\usage{
+unstandardize_scores(pls_model)
+}
+\description{
+Rescales standardized construct scores back into same units of items.
+Inspired by \code{rescale()} function of \code{plspm} package
+}
diff --git a/tests/fixtures/V_3_6_0/unstandardized.RData b/tests/fixtures/V_3_6_0/unstandardized.RData
new file mode 100644
index 0000000000000000000000000000000000000000..1334549e6a0105dd6297d0fe9abb88be4c77d194
GIT binary patch
literal 4495
zcmV;A5peDwiwFP!000001C?0`SdD4>KT@<%+Rpl(bKdt9O`D}vq;3hVM1`7?Bq}O8
zktGIMl4UHVq(&pzrx7tFYZ^&}N<tXf8B2_cl>eFId7i%iJKwqH`ns<7dV03|zJI^_
zci-<z6WyoSYERMTa5z0V>WZhQhT>O_Mqt1g>!BQux|(9rL$RTy7>y$06A~gL62s=l
z$rERU$)jWE&WTjqGgR!UD;{0N^BIh))LsjJtp}44m$YrJT7bZz`btsy8<4&!DXE?t
z1B^ycU5*A9n4tFoH+v2QfuBj%?==-bkFw1^QM?eSr0Y!|2kV1aSbJ%d&<w;yzF85X
z5}<t_`jyq50%=a%qE0m#m~xaqARR7m$e54-OrO}ZLv<8mk+{c=77iGGtWUl1ZaXkb
zC+SwpV?a>t7`AqdDM;Ik>n=Rn0us)yO8K)0ppYF2W#P5kK?6hs>sxo0dJ+4KiD83t
z@;WdGJojkz#xo%P&U{PVDi<(`8lBfZ=m1D|$Mtf(lS1q;^~=jHg*yXXy5Q)OA!;B<
zPg&#B<p;7+=L_6QcZ2Z9YqKX`Sp}lXI~Q99JAqU@)qlvw1fYI#a({Tk59of;7H*&1
zfgZWRE_cs!ka^sicKiHf5ajBPocm%m@ym3i=`=kk1Zj`D>pfkrgIL4AIa)9f^y!yl
zJ6-dDKWcO&SIZq3&nHigJbnS<M>mg$R(%HX0_P!LR+xe?Q1jE9vMWGsj<=~k_8dfY
zGJi+UHlW^}zNQwF1k9mD!wVlXz?2TSW;w!-*cW`spB4SmND;4bwLzczAYH9@OxIT*
z_*JjYZc^icXu=ZD>!|{uZOtsVZnpy}_KR$It`*@&YDZOm2pt0A{ozNbyM{pb7Btno
zSKwVAlw^0<2AKZl#UY;lz#kfr;XX$jsQW8w|2k3w#%gv6bGG{d^%tk4rl=A`-&F;T
zoxK|*)=LwebLW8Qw)MO9nR!5$JAS-s(+JXg7JeD&Z-M?n{d?}RFc4MW8qi^#3Y1O%
zWpvP6kRrVFjx)<$Pd){P*6qDD@Hj}?LMP0qJPNdzeN{~3PGB-)miRUm0Cme@Z%O)8
zpuZgS-T7oOh<CiXkvMZ7^xIS0bK}8{AgftRmn4>h#5bYwxbaF5Df4s?1aHkvwaU_f
zDV!DJ;#?1sq1T(AZ|VRk$|H5qemN~@2H}#;Mv>VQfqC9C-RyK0@HT&>E)Q}9k==Sv
z+jWycx?bcrJ-ZB;nu6mRE?z(nG_iU#w*-XAvFdW83Sg>iUB-W(4s^@QJB5!sfyuaF
zY<JZdWcuyRBZnOYhFUx@#QZm4@{Ib4`UQ3C+x_9Q9%tjggjr^-Gu{^HW3_*lo0@=d
zUMjEm_+WC*xG>gt-gl>oPV{cmg@6214zkM+)3Rr#0hJb!ku=j4M5ps(Lp{2HM)w4l
zuH9xbhJhgdcBAcyHZWcl|0+AO5M-#{ByDef5=%Tm`YimQd9nrZC&?6MZhQV0Fsa5X
zO5{&Ls;uWskkt=v)QwFeb<EebEzNzb;8&^d4su_R-&#{!ln2JmrFo;z?gPp-dF+u2
zP2heQk+fdpJxCAkw#|Ne2$+J?mGiV{5-;Q2LqC1~eh>-PTydVi8^n#9%y~zgNxnpt
zhhoaMwF0yGEO+(3Y%qEfGi}ns=O7i@a<182AiRtHXRh4JH2~UmlX})(0PefQ3bn6U
zAh~|>r~Vz=fv$H;ZykRDWVagPtd^96;Dbl!qov+J?>u$Hy>t`s_WM67dF%l~B~R)g
za2z9kT&4|@y)iRAZ`FdZXGqp|<3B;RAo!xE*I}UDxAq)ceG2G<Q$D@D9|+Qk7t16A
zkC3{f#V6JBk`h5W>3ve@B{vY&{5J13odPC0U&js^=S1*}rhQI4WjG8>X1{Xej(7;-
z_gZlsg{whO?wvGJV+9E7Pjn4xe+=|*3s?SO6AV(%AFF4r`42taXsV-r^Z>Euz1I$h
zr-L{&x2b>Uc;L@mdMx<TL0|%%0zw)Vb@wIIkLZXkYt%X)fP~kzX?l(#&e8EL8!Hrb
z5ICXCe@|a93R;)C=jc<Q4f8yLy+#37dtXJZO$gA%3B?XNYe0(ido*#?5Jg|2)<sxm
zn}vXIm)o&>KimY`Ov}$`nH)s9-Z9$A+d%9iniTkH4+z4uod<pX2?RSnAG_m{1T^X|
z4EM}Q$+#0B*`oW|b*DGzxXC-hdnx+gv~ic419}1d%60zJU*7}cv39BS>RynT%wKSS
z;(QRfoH!Srbsm_gCsA{FeLxh@%S)qk0my#VI=tl8B%(v2Q-@IRc~O^0UtrW$2ZU)V
z`q`Vq4Ut(pK!2lV=iSk{Aadw5c;aUT{N&+hT!YqtsC4KCLunca@5$33cMMRT`_A02
zO8{93-zz|H2K4v6^@!aj1%~4?pjLk&sT;wpD*u2!B_R0qaMP5wl^~hWXUF3+OF<kw
zUhl*Gfgo;5TgUve0ho<~<+FB7C+~Gp?+HU^47LQ5l>Iq2d@hK-Dt|!A@hTi?_5$es
zr=xloZULr5bH3VuF5r*c?CZWR5A-jX<(2ldC+7vrjs;&S3;@x@E1L3+zQmsR@C#3G
zuS<j%{@v)OI(nvx_wn+avlSsA(cL}w(lo_;aD++URMTRh+Y2jqUaJSbd*bLn1O5Qs
z-Qsi~M_rJjkzYJ)#jlG$0Hr)v2jcL!MZ;egDC)iW?00Soy`Xro9pO(~)>Ie-0rUEf
z*8tI4pp<qW5Zu&=*s?00T#&r%GpQ~<8KmV~-5rii2U)NfZk=8Xl=tH6dZ989&F%M6
z-M5qY!~QWY+Agf|y6$t}dH=r5Z*`yUxT^Ea2DR`=JeW^W@#;bEcHaZ>Pfhk3!$yIq
z)p)7B)iQEU&=UHi<1R&i>)k8OMAHozrM<l%M0`n6JOU-Zl^|B0-`{=CpL?SCxFb-*
z)?Hv$OeMV02$v`m#)UOogS2e@Ny9@@kRm?VJc_B$w&SyY2Z{3DqJQ9K%-4S(9GnCE
z8$U$A@O+Rd`3?r2@l>CKa0Fz@lOwJ^dkMyf4-xVwR{B{DjJ0mw?E9z5ee9Ry2gS{`
zdEJz3?g7k!nd(j#_knEEj*g2?K_o7sTO2p?M=Q@w0g*B<I^8^sZA<IC-2+6rlgrl*
zjU~F}N1ZLo6W<_w;(g2y@rUQ-P4AQLdV^8fNS)dghwk?r(j6B*zbkjD0lKy&ES(tz
zV&e}7tTv|*+%mLI^zqShWt#Ufpf}9E{?hs(=z9-lYV4heU93y`3C}oA;}qco>%l}B
zmlcRneG1&oGY?s{65eG;esj)ktyA>JZ~U<JEWTk^{ME1&#ONMB_-Jl$Umsvl+*p6y
zsz=G$k2ZCGuVek7y2p4iKX{+F*{Q<$_MZeNsUL)2gzB7&{1~k8DX^Vzkkl_ehx3g4
z6tRQyiuomaLV7p2QaRtP@JhGtmFojZUU8g4G{=4=fuDa3S-ybio0biewOY&tUcz6^
zhXu|cNt!N;T4oO7)ZBZSD;m1-Aph7tjp_m0B|2?L+*436qq`5GIB*_tpJLWpJ{*<f
zNO19gv2ELsP(<>M`>H{Gdr8cs<76M>#C;jpEzTF_596klbx=#z*?E@XIj%QU&lIX3
zzOrvJ1RodSBDz5Nr7kbLEw-IT-V0cVm^WT?nIzuTkLZ=?LOD(WzS#ZY=5vK4-?-kj
zk?yb^dT`UWGijA19>L{-7EL-yAZ@(9bI<H+gl7T5K`VJXO8jE{y2lFoTU#=ujwNLc
zQ2}*Y<o$s8$8~~vz<9Av@Oz268giqeYghMogYD3?(-Uk+KJohm<B+lPfb)fLkoP*p
z${QbzMywHkA5yG2&ALbZ%Q^Nw+m9)0&OVPvjIW=Hd+ht{I5b)N=)UVa6?0WQvHjvX
zJ1&|v$MI{j*73;Zhi0v_`NsCx@$^%1j;~^*RNQ07#f}&IQx(_0<&$QOeAb+8kByf-
z=d;$)eUeYS&bH6S$KF>pXP?I-hqbTjo+>`s_}KPo73cf0{NXu^4|cu?KWts7sxNkY
zY`bjSs_^6coc|uzKm4=rtI{9M8dd3v9WS19Sm*IRu3PMvU015&WY>eLzT1yA|F?e1
z<{97Ts5qypPyVlckUeL|O{<u*<7f9fHePmKRoPR;zp7CcKDHlK_}F<@rE_+DvHHb7
z)>ZWr_B!YP$HBqxbzbJ_le=_XKsL4YW%AH=;0L|4evn}gvP!2x_bg5Voh7NN3d{!C
zHhy2LqDByJJ<+8WlMKT1a|2$rj{ttTjU3jrfq3`EiB^vl-(y!?|6Ej)3<l^v#j-~g
z@|It1djryrvhd$twh_O$PGnZ?+_#srK`?m4wylR8fL6|Tg0bnLdq>8M06}YUfoQBf
zNY~BI7Z(+|cCEF#7Cu=UOb`yC(w@SuMz2#j`Q<<l>8jfh7ee;wR{xB5UmHQ+Zsm|W
z=M=atZdO*G<6@kyt*cBY=}`=bT7G%HEME@2mh2QPd#?|o+%*}S;Ut)-rA!?+;UO?p
zr#4w8XA^sj!=B|`m&*wrYJ79?Uf&{ME;iCfABBS6>?=MQRoj7k+VVvHBRj?S^S5~V
zZb}F{87K#1dX{U{5PQNm&I4`M66`;q5u}5b%y*#_ydxel4_qzp;KwDGL4y3sI)W!|
z%+Chi&(*e#f#qPNap_KrO)~K(33xHjtwj!!y8*KCrRC6T)^f8x5t_h7_k}mtkDa=9
z3}{xouYa&?J<!=B`LCx*NgnZiLF$23RkAk17xqW#H3V2JR($v07;}J|;6n1pAigmU
z@qod?pok)nMGQ}^7^l$bOlhn0GZ!#H`+TG$ew+?H(NvLF?Q5AE8(fGEnVgEG;YT@y
zZ)Qkt#dI?c$-7X=vpq23i#;x<HG=R#*161@YS)&ZwTx3LH9>}OF%dbLZ!$s&K5n#n
z#PQ|Hz@*>y9WY-}uZTYp;*Z&!UU)yO9Yp3wvwdECCGqn5$9_?-SJVO4C(;kry$SLo
zwRC7`?JXy9k$#WPF{r+n$TQCjc0DBa3C`YW!j~WO2~MmNL;pEtcl)m<I+q}OLQc6P
zVADy^JQbZaK41yauL#wj@!I|#v_=ZiJ3XjrRa8VH7|mJp=s>T_-F+mYb05FyB#5>x
zq9%Q^CpshXqda1L;C$oyAny|tFW$$vgrg0`{3JOT;QXQZaUUT(B0jK=n2O^!HZ?Yq
zbpfg;F|u#?l(NZjSxorij;FUzIMYUSjqysA^<4@~h<t<fGcFh*yf{7*2b$APW)FO+
z{BAv?yis?y_Uy3KBs!%thK2Z@3I)OTjvTKaQh+DFlBlL(2gXA$UYFe*0}}s8yB&33
zNuR<z;XZ-+rnLJmavHme^eZEjPeY_Tk|$(Gfa1Y=#(f$07haQY>GalCGU9k~KjA6;
zI*>e*x<k6fxOgii>r=wd6Mm_SN&2Zdia4U&Mo()g$9X1oN8(hzH`=@V3wkdITz))c
z)Vmz?U&-DMZFU9<<w1&g;37Yo`^ObD{hmPbPGi2&*ki*R6Me_8z(sus^Tx3IXdfS+
zkGrjacGTExZXgBy&!0v`gt(A?F4Qx!zxiq`iCZ1vGsOLX6Ru}5HiXoZA=U%RFOHjk
zuFxSfI>q%%n}bc~V+N=xvs)aJ&Xf4rbx!_&#P*!wnjxz|&nltg)x&h40?a19nO;iP
z$-j5L;b#3UUL!6%Hd3zmr61?-Kfa?y&)D!;k!Yebdg0v2h{W*3==eCaq&+G=cJ7?;
z=(t2VTIuZ*zbJf8;v%;7h&kbMY#lFZ&j?QpA2>5X;h1$?D<M8<AP(q_;`z@_y%~`+
zBNGxLXN1WU6Qbj0v9{Hxhsz_;T3_Y*H?Li2jcrahLV+PXA~Ec56p{13?e_Z0vd|Y<
h`1@0+C&YjINW!03ctmIL9XwY){|Cpw>jM`d000eE;gA3T

literal 0
HcmV?d00001

diff --git a/tests/testthat/test-unstandardize.R b/tests/testthat/test-unstandardize.R
new file mode 100644
index 00000000..4d1ab28e
--- /dev/null
+++ b/tests/testthat/test-unstandardize.R
@@ -0,0 +1,36 @@
+context("SEMinR correctly unstandardizes model elements\n")
+
+# First order model
+measurements <- constructs(
+  composite("Image",       multi_items("IMAG", 1:5)),
+  composite("Expectation", multi_items("CUEX", 1:3)),
+  composite("Loyalty",     multi_items("CUSL", 1:3)),
+  composite("Complaints",  single_item("CUSCO"))
+)
+
+structure <- relationships(
+  paths(from = c("Image", "Expectation"), to = c("Complaints", "Loyalty"))
+)
+
+simple_pls_model <- estimate_pls(data = mobi, measurements, structure)
+unstd_simple <- unstandardize_scores(simple_pls_model)
+
+# correct_unstd_simple <- unstd_simple
+# save(correct_unstd_simple, file="tests/fixtures/V_3_6_0/unstandardized.RData")
+
+# Load correct result objects
+load("../fixtures/V_3_6_0/unstandardized.RData")
+
+test_that("Unstandardized scores are reproduced as previously", {
+  expect_equal(all(unstd_simple == correct_unstd_simple), TRUE)
+})
+
+test_that("Unstandardized scores are in correct scale", {
+  complaints_unstd <- summary(unstd_simple$Complaints)
+  expect_equal(as.numeric(complaints_unstd["Min."]), 1)
+  expect_equal(as.numeric(complaints_unstd["Max."]), 10)
+
+  expectation_unstd <- summary(unstd_simple$Expectation)
+  expect_gte(as.numeric(expectation_unstd["Min."]), 1)
+  expect_equal(as.numeric(expectation_unstd["Max."]), 10)
+})