diff --git a/Modules/gausshermite.ado b/Modules/gausshermite.ado new file mode 100644 index 0000000..e277a17 --- /dev/null +++ b/Modules/gausshermite.ado @@ -0,0 +1,181 @@ +*! version 2 15jan2013 +************************************************************************************************************ +* gausshermite : Estimate an integral of the form |f(x)g(x/mu,sigma)dx or f(x,y)g(x,y/mu,Sigma)dxdy where g(x/mu,sigma) is the distribution function +* of the gaussian distribution of mean mu and variance sigma^2 and g(x,y/mu,Sigma) is the distribution function +* of the bivariate normal distribution of mean mu and covariance matrix Sigma by Gauss Hermite quadratures +* +* Version 1 : May 5, 2005 (Jean-Benoit Hardouin) +* Version 1.1: June 14, 2012 /*name option*/ (Jean-Benoit Hardouin) +* Version 2: January 15, 2013 /*bivariate normal distribution*/ (Jean-Benoit Hardouin, Mohand-Larbi Feddag, Myriam Blanchin) +* +* Jean-Benoit Hardouin, jean-benoit.hardouin@univ-nantes.fr +* EA 4275 "Biostatistics, Pharmacoepidemiology and Subjectives Measures in Health" +* Faculty of Pharmaceutical Sciences - University of Nantes - France +* http://www.sphere-nantes.org +* +* News about this program : http://anaqol.free.fr +* FreeIRT Project : http://freeirt.free.fr +* +* Copyright 2005, 2013 Jean-Benoit Hardouin, Mohand-Larbi Feddag, Myriam Blanchin +* +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program; if not, write to the Free Software +* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +* +************************************************************************************************************ + + +program define gausshermite,rclass +version 7 +syntax anything [, Sigma(real -1) Var(string) MU(string) Nodes(integer 12) Display Name(string)] +tempfile gauss +qui capture save `gauss',replace +local save=0 +if _rc==0 { + qui save `gauss',replace + local save=1 +} + +tokenize `anything' +drop _all +tempname mean variance C + +qui set obs `=`nodes'*`nodes'' +if "`name'"=="" { + if `sigma'!=-1{ + if "`var'"==""{ + local name x + local nb=1 + } + else{ + di in red "{p}Please fill in the {hi:name} option{p_end}" + error 198 + exit + } + } + else{ + if "`var'"!=""{ + local name1 x1 + local name2 x2 + local nb=2 + } + else{ + di in red "{p}Please fill in the {hi:name} option{p_end}" + error 198 + exit + } + } +} +else { + local nb=wordcount("`name'") + if `nb'==2{ + local name1=word("`name'",1) + local name2=word("`name'",2) + } +} + + +if `nb'==2{ + capture confirm matrix `var' + if !_rc{ + if colsof(`var')==2 & rowsof(`var')==2{ + matrix `C'=cholesky(`var') + } + else{ + di in red "{p}The covariance matrix in the {hi:var} option should be a 2x2 matrix for a bivariate distribution{p_end}" + error 198 + exit + } + } + else{ + matrix `variance'=(1,0\0,1) + matrix `C'=cholesky(`variance') + } +} +else{ + if `sigma'==-1{ + local sig=1 + } + else{ + local sig=`sigma' + } +} + +capture confirm matrix `mu' +if !_rc{ + if colsof(`mu')==1 & rowsof(`mu')==1{ + local `mean'=`mu'[1,1] + } + else{ + matrix `mean'=`mu' + } +} +else{ + if "`mu'"==""{ + if `nb'==1{ + local `mean'=0 + } + else{ + matrix `mean'=(0,0) + } + } + else{ + local `mean'=`mu' + } +} + +tempname noeuds poids +qui ghquadm `nodes' `noeuds' `poids' + +if `nb'==1{ + qui gen `name'=. + qui gen poids=. + forvalues i=1/`nodes' { + qui replace `name'=`noeuds'[1,`i'] in `i' + qui replace poids=`poids'[1,`i'] in `i' + } + qui replace `name'=`name'*(sqrt(2)*`sig')+``mean'' + qui gen f=poids/sqrt(_pi)*(`1') + *list `name' poids f in 1/5 +} +else{ + forvalues i=1/`nb'{ + qui gen `name`i''=. + qui gen poids`i'=. + } + local line=1 + forvalues i=1/`nodes' { + forvalues j=1/`nodes' { + qui replace `name1'=`noeuds'[1,`i'] *(sqrt(2)*`C'[1,1])+`mean'[1,1] in `line' + qui replace `name2'=`noeuds'[1,`i'] *(sqrt(2)*`C'[2,1])+`noeuds'[1,`j'] *(sqrt(2)*`C'[2,2])+`mean'[1,2] in `line' + qui replace poids1=`poids'[1,`i'] in `line' + qui replace poids2=`poids'[1,`j'] in `line' + local ++line + } + } + qui gen f=poids1*poids2*(`1')/(_pi) + *list `name1' `name2' poids1 poids2 f in 10/20 +} + +qui su f +return scalar int=r(sum) +if "`display'"!="" { + di in green "int_R (`1')g(`name'/sigma=`sig')d`name'=" in yellow %12.8f `r(sum)' +} +drop _all +if `save'==1 { + qui use `gauss',clear +} +end + + diff --git a/Modules/ghquadm.ado b/Modules/ghquadm.ado new file mode 100644 index 0000000..c64290f --- /dev/null +++ b/Modules/ghquadm.ado @@ -0,0 +1,85 @@ +program define ghquadm +* stolen from gllamm6 who stole it from rfprobit (Bill Sribney) + version 4.0 + + parse "`*'", parse(" ") + local n = `1' + if `n' + 2 > _N { + di in red /* + */ "`n' + 2 observations needed to compute quadrature points" + exit 2001 + } + + tempname x w xx ww a b + local i 1 + local m = int((`n' + 1)/2) + matrix x = J(1,`m',0) + matrix w = x + while `i' <= `m' { + if `i' == 1 { + scalar `xx' = sqrt(2*`n'+1)-1.85575*(2*`n'+1)^(-1/6) + } + else if `i' == 2 { scalar `xx' = `xx'-1.14*`n'^0.426/`xx' } + else if `i' == 3 { scalar `xx' = 1.86*`xx'-0.86*x[1,1] } + else if `i' == 4 { scalar `xx' = 1.91*`xx'-0.91*x[1,2] } + else { + local im2 = `i' -2 + scalar `xx' = 2*`xx'-x[1,`im2'] + } + hermite `n' `xx' `ww' + matrix x[1,`i'] = `xx' + matrix w[1,`i'] = `ww' + local i = `i' + 1 + } + if mod(`n', 2) == 1 { matrix x[1,`m'] = 0} +/* start in tails */ + matrix `b' = (1,1) + matrix w = w#`b' + matrix w = w[1,1..`n'] + matrix `b' = (1,-1) + matrix x = x#`b' + matrix x = x[1,1..`n'] +/* other alternative (left to right) */ +/* + above: matrix x = J(1,`n',0) + while ( `i'<=`n'){ + matrix x[1, `i'] = -x[1, `n'+1-`i'] + matrix w[1, `i'] = w[1, `n'+1-`i'] + local i = `i' + 1 + } +*/ + matrix `2' = x + matrix `3' = w +end + + +program define hermite /* integer n, scalar x, scalar w */ +* stolen from gllamm6 who stole it from rfprobit (Bill Sribney) + version 4.0 + local n "`1'" + local x "`2'" + local w "`3'" + local last = `n' + 2 + tempname i p + matrix `p' = J(1,`last',0) + scalar `i' = 1 + while `i' <= 10 { + matrix `p'[1,1]=0 + matrix `p'[1,2] = _pi^(-0.25) + local k = 3 + while `k'<=`last'{ + matrix `p'[1,`k'] = `x'*sqrt(2/(`k'-2))*`p'[1,`k'-1] /* + */ - sqrt((`k'-3)/(`k'-2))*`p'[1,`k'-2] + local k = `k' + 1 + } + scalar `w' = sqrt(2*`n')*`p'[1,`last'-1] + scalar `x' = `x' - `p'[1,`last']/`w' + if abs(`p'[1,`last']/`w') < 3e-14 { + scalar `w' = 2/(`w'*`w') + exit + } + scalar `i' = `i' + 1 + } + di in red "hermite did not converge" + exit 499 +end diff --git a/Modules/gllam_ll.ado b/Modules/gllam_ll.ado new file mode 100644 index 0000000..813d3ec --- /dev/null +++ b/Modules/gllam_ll.ado @@ -0,0 +1,1534 @@ +*! version 2.2.21 SRH 7 Sept 2011 +program define gllam_ll +version 7.0 +*disp in re "version 7.0" +args todo bo lnf junk1 junk2 what res +* what = 1: update posterior means and standard deviations +* what = 2: posterior probabilities +* what = 3: cluster likelihood contributions*cluster frequency weights +* what = 4: cluster likelihood contributions +* what = 5-7: posterior mean of statistic +/* +noi disp " " +noi disp $HG_SD1[$which] +noi disp $HG_SD2[$which] +noi disp $HG_C21[$which] +noi disp " " +*/ + +if "`what'"==""{ + local what = 0 +} +if `what' == 1 { + global HG_zip zipg1 + if $HG_free{ + global HG_zip zipf1 + } +} +else if $HG_adapt{ + global HG_zip zipga +} + +*matrix list `bo' +if $HG_dots { + noi disp in gr "." _c +} + +/* ----------------------------------------------------------------------------- */ +/* set up variables and macros needed */ + +tempname b mzlc + +local toplev = $HG_tplv +local topi = $HG_tpi +local clus $HG_clus + +sort `clus' + +* reset the the clock and reset znow +local i = 1 +matrix M_ip[1,1] = 1 /* in case topi=0 */ +while (`i' <= `topi'){ + matrix M_ip[1,`i'] = 1 + local i = `i' + 1 +} + +/* -------------------------------------------------------------------------------- */ +/* set up lprod1 ... lint1 */ + +local i=1 +tempvar extra +quietly gen double `extra'=0 +while `i' <= `toplev'{ + tempvar lint`i' + gen double `lint`i'' = 0.0 /* used to integrate, therefore must be zero */ + tempvar lfac`i' + quietly gen double `lfac`i'' = 0 + if (`i'>1){ + tempvar lprod`i' + quietly gen double `lprod`i'' = . + tempvar lfac`i' + quietly gen double `lfac`i'' = 0 + } + local i = `i' + 1 +} + +/* set up names for HG_xb`i' */ +local i = 1 +while (`i' <= $HG_tpff){ + tempname junk + global HG_xb`i' "`junk'" + local i = `i' + 1 +} +/* set up names for HG_s`i' */ +local i = 1 +while (`i'<=$HG_tprf){ + tempname junk + global HG_s`i' "`junk'" + local i = `i'+1 +} + + +if $HG_free{ +/* set up names for HG_p`lev'`k' */ + local lev = 2 + while `lev'<=$HG_tplv{ + local npar = M_np[1,`lev'] + if `npar'>0{ + local k = 1 + while `k'<=M_nip[1, `lev']{ + * disp in re "creating HG_p`lev'`k'" + tempname junk + global HG_p`lev'`k' "`junk'" + local k = `k' + 1 + } + } + local lev = `lev' + 1 + } +} + + +/* set up names for HG_E`rf'`lev' and HG_V`rf'`lev' */ +if `what'==1{ + local lev = 1 + while `lev'<=$HG_tplv{ + if `lev'<$HG_tplv{ + local maxrf =M_nrfc[2,`lev'+1] + } + else{ + local maxrf =M_nrfc[2,$HG_tplv] + } + + local rf = 1 + while `rf'<`maxrf'{ + * disp in re "creating HG_V`rf'`rf'`lev'" + tempname junk + global HG_E`rf'`lev' "`junk'" + gen double ${HG_E`rf'`lev'}=0 + tempname junk + global HG_V`rf'`rf'`lev' "`junk'" + gen double ${HG_V`rf'`rf'`lev'}=0 + local rf2 = `rf' + 1 + while `rf2'<$HG_tprf{ /* lower diagonal elements */ + * disp in re "creating HG_V`rf2'`rf'`lev'" + tempname junk + global HG_V`rf2'`rf'`lev' "`junk'" + gen double ${HG_V`rf2'`rf'`lev'}=0 + local rf2 = `rf2' + 1 + } + local rf = `rf' + 1 + } + + local lev = `lev' + 1 + } +} +else if $HG_adapt{ + local llev = 1 + while `llev'<$HG_tplv{ + local lrf = M_nrfc[2,`llev'] + while `lrf'=5{ + tempvar lpred + local lev = 1 + while `lev'<=$HG_tplv{ + tempname junk + global HG_stat`lev' "`junk'" + gen double ${HG_stat`lev'}=0 + local lev =`lev' + 1 + } +} + + +qui remcor "`bo'" + +if $HP_prior{ + qui calc_prior +} + +*noi matrix list `bo' +/* +if `npar'>0{ +disp in re "after remcor: HG_p21[$which] = " $HG_p21[$which] +disp in re "after remcor: HG_p22[$which] = " $HG_p22[$which] +} +*/ + +if $HG_error==1{ + disp in re "error in remcor" + scalar `lnf' = . + exit +} + +if "$HG_post"!=""{ /* for predictions */ + *noi tab $HG_ind + tempvar mssvls + * disp in re "`mssvls'" + qui gen byte `mssvls' = 0 + qui replace `mssvls' = 1 if ($ML_y1>=.) & $HG_ind>0 + local ffs = 1 + while `ffs' <= $HG_tpff { + qui replace `mssvls' = 1 if ${HG_xb`ffs'} >=. & $HG_ind>0 + local ffs = `ffs' + 1 + } + if M_nbrf[1,1]>0{ + qui replace `mssvls' = 1 if $HG_s1>=. & $HG_ind>0 + } +} + +* disp "HG_xb1 after remcor: HG_xb1[$which] = " $HG_xb1[$which] +* disp "HG_s2 after remcor: HG_s2[$which] = " $HG_s2[$which] +* disp "HG_s1 after remcor: HG_s1[$which] = $HG_s1 = " $HG_s1[$which] + +if $HG_adapt{ + *noi disp " " + local i = $HG_tprf - 1 + while `i' >= 1 { + local ip = `i' + 1 + local k = `i' - 1 + while `k' >= 1 { + local kp = `k' + 1 + * disp in re "replace HG_s`ip' = HG_s`ip' + HG_C`i'`k'*HG_s`kp'" + qui replace ${HG_s`ip'} = ${HG_s`ip'} + ${HG_C`i'`k'}*${HG_s`kp'} + local k = `k' - 1 + } + local i = `i' - 1 + } + + local i = 2 + tempname junk + global HG_zuoff "`junk'" + qui gen double $HG_zuoff = 0 + while `i'<=$HG_tprf{ + local im = `i' - 1 + * disp in re "replace HG_zuoff = HG_zuoff + HG_s`i'*HG_MU`im'" + qui replace $HG_zuoff = $HG_zuoff + ${HG_s`i'}*${HG_MU`im'} + + * disp in re "replace HG_s`i' = HG_SD`im'*HG_s`i'" + qui replace ${HG_s`i'} = ${HG_SD`im'}*${HG_s`i'} + + local i = `i' + 1 + } + *dis in re "HG_zuoff[$which] = " $HG_zuoff[$which] +} + + +local i = `toplev' +while `i' > 1 { + *noi disp "$HG_zip `i'$ + quietly $HG_zip `i' + local i = `i' - 1 +} + + +timer on 2 +* disp "STARTING LOOP" +/* --------------------------------------------------------------------------------- */ +/* recursive loop through r.effs (levels) */ +/* topi nested loops: irf from 1 ro nip(rf) */ +/* ip is "clock": (irf) stages of loops */ + +local levno = `toplev' +local rf = `topi' +while (`rf' <= `topi') { /* for each r.eff */ + +/* ----------------------------------------------------------------------------------*/ +/* reset ip to 1st point for all lower r.effs... */ +/* update znow */ + * disp "reset ip up to random effect " `rf' + while (`rf' > 1) { + local rf = `rf' - 1 + * disp `rf' + matrix M_ip[1,`rf'] = 1 + } + while (`levno' > 1){ + /* update znow for all new ips */ + *noi disp "$HG_zip `levno'$ + $HG_zip `levno' + local levno = `levno' - 1 + } +/* --------------------------------------------------------------------------------- */ +/* set lint1 to lpyz for new znow */ + + local rf = 1 + local levno = 1 + local sortlst `clus' /* cluster variables to aggregate over */ + + *matrix list M_ip + timer on 3 + qui lpyz `lint1' + timer off 3 + + * noi disp in re " after lpyz lint1[" $which "] = " `lint1'[$which] " and HG_ind = " $HG_ind[$which] + + if "$HG_post"!=""{/* for presictions */ + qui replace `lint1' = 0 if `mssvls'==1 + } + + * noi disp in re " after lpyz lint1 = " `lint1'[$which] " and HG_ind = " $HG_ind[$which] + + if `what'>=5{ + if $HG_tplv>1{ + matrix score double `lpred' = M_znow + } + else{ + qui gen double `lpred' = 0 + } + if $HG_adapt{ + qui replace `lpred' = $HG_xb1 + $HG_zuoff + `lpred' - $HG_offs + } + else{ + qui replace `lpred' = $HG_xb1 + `lpred' - $HG_offs + } + timer on 5 + gllas_yu $HG_stat1 `lpred' `res' `what' + sort `sortlst' /* added Oct 2004 */ + timer off 5 + qui drop `lpred' + } + + *noi summ `lint1' if `lint1'==-100 + quietly count if `lint1'==.& $HG_ind>0 + + * noi disp in re "number missing: " r(N) + if r(N) > 0{ + * overflow problem + * disp in re "overflow at level 1 ( " r(N) " missing values)" + * list $HG_clus if `lint1'==. + *matrix list `bo' + *lpyz `lint1' + if `what'!=3 { /* what = 3 used by robust & need valid ll contributions */ + scalar `lnf' = . + exit + } + } + quietly replace `lint1' = `lint1' * $HG_wt1 + +/* --------------------------------------------------------------------------------- */ +/* update lint for all completed levels up to */ +/* highest completed level, reset lower lints */ +/* to zero (for models including a random effect) */ + + while (M_ip[1,`rf'] == M_nip[1,`rf'] & `rf' <= `topi'){ + * digit equals its max => increment next digit + if (`rf' == M_nrfc[1,`levno'] & `levno' < `toplev'){ + * done last r.eff of current level + * disp "********** level " `levno' " complete ************" + + * next level + local lprev = `levno' + local levno = `levno' + 1 + + /* change sortlst */ + local prvsort `sortlst' + local l = `toplev' - `levno' + 2 + tokenize "`sortlst'" + * take away var. of level to sum over + local `l' " " + local sortlst "`*'" +/*------------------------------------------------------------------------------------ */ +/* change lprod`levno' and */ +/* update lint`levno' */ + + if "`f`levno''"==""{ /* first term for lint`levno' */ + local f`levno'=1 + * disp "first term for level `levno'" + } + else{ + local f`levno'=0 + * disp "next term for level `levno'" + } +timer on 4 +if $HG_noC1 { + lnupdate `levno' `lint`levno'' `lint`lprev'' `lprod`levno'' /* + */ `lfac`levno'' `lfac`lprev'' `extra' /* + */ `lnf' "`prvsort'" "`sortlst'" `f`levno'' `what' +} +else { + _gllamm_lnu, levno(`levno') lintlv(`lint`levno'') /* + */ lintprv(`lint`lprev'') lprodlv(`lprod`levno'') /* + */ lfaclv(`lfac`levno'') lfacprv(`lfac`lprev'') extra(`extra') /* + */ lnf(`lnf') prvsort(`prvsort') sortlst(`sortlst') /* + */ first(`f`levno'') what(`what') +} +timer off 4 + + local f`lprev' + +*args levno lintlv lintprv lprodlv lfaclv lfacprv extra lnf prevsort sortlst first +/* ------------------------------------------------------------------------------------------- */ + } /* next digit */ + local rf = `rf' + 1 + } + * rf is first r.eff that is not complete + * increase clock in lowest incomplete digit + * disp "update rf = " `rf' + matrix M_ip[1,`rf'] = M_ip[1,`rf'] + 1 +} +timer off 2 +*quietly{ + *now rf too high + *!! disp "********** level " `toplev' " complete ************" + * noi disp "lint" `toplev' "[" $which "] = " `lint`toplev''[$which] + if(`toplev'>1){ + if `what'==1{ + local rf = 1 + while `rf'< $HG_tprf{ + * disp in re "setting HG_MU`rf' and HG_SD`rf'" + * disp in re "by `sortlst': replace HG_MU`rf' = HG_E`rf'`toplev'/lint`toplev'[_N]" + qui by `sortlst': replace ${HG_MU`rf'} = ${HG_E`rf'`toplev'}/`lint`toplev''[_N] + qui by `sortlst': replace ${HG_SD`rf'} = ${HG_V`rf'`rf'`toplev'}/`lint`toplev''[_N] - ${HG_MU`rf'}^2 + qui replace ${HG_SD`rf'} = cond(${HG_SD`rf'}>0,sqrt(${HG_SD`rf'}),0) + *noi disp " " + *noi disp "HG_MU`rf'[$which] = " ${HG_MU`rf'}[$which] + *summ ${HG_MU`rf'} + *noi disp "HG_SD`rf'[$which] = " ${HG_SD`rf'}[$which] + *summ ${HG_SD`rf'} + local rf2 = 1 + while `rf2' < `rf'{ /* must use MU's that are already calculated */ + qui by `sortlst': replace ${HG_C`rf'`rf2'} = ${HG_V`rf'`rf2'`toplev'}/`lint`toplev''[_N] - (${HG_MU`rf2'}*${HG_MU`rf'}) + *noi disp "HG_C`rf'`rf2'[$which] = " ${HG_C`rf'`rf2'}[$which] + *summ ${HG_C`rf'`rf2'} + local rf2 = `rf2' + 1 + } + local rf = `rf' + 1 + } + if $HG_adapt==1{ /* have recalculated means and covariances and need diff. ones for adaptive */ + prepadpt + } + } + else if `what'>=5{ + if $HG_post{ + qui by `sortlst': replace ${HG_stat`toplev'} = ${HG_stat`toplev'}/`lint`toplev''[_N] + } + } + else if `what'==2{ + local i = 1 + while `i'<= M_nip[1,2] { + qui by `sortlst': replace ${HG_p`i'} = ${HG_p`i'}/`lint`toplev''[_N] + local i = `i' + 1 + } + } + *a disp "taking log of lint" `toplev' " = " `lint`toplev''[$which] + *a disp "subtracting " `lfac`toplev''[$which] + + ** begin junk (conditional log-likelihood for capture-recapture) +/* + qui replace `lint`toplev'' = exp(ln(`lint`toplev'')-`lfac`toplev'') + qui summ `lint`toplev'', meanonly + qui replace `lint`toplev'' = ${HG_wt`toplev'}*(ln(`lint`toplev'') - ln(r(sum))) +*/ + ** end junk + + quietly replace `lint`toplev'' = (ln(`lint`toplev'')-`lfac`toplev'')* ${HG_wt`toplev'} + } + * noi display "lint" `toplev' "[" $which "] = " `lint`toplev''[$which] + if `what'==3{ + if `toplev'==1{ /* by sorlst won't work for composite link */ + qui replace `res' = `lint`toplev'' + } + else{ + qui by `sortlst': replace `res' = `lint`toplev''[_N] + } + if $HP_prior { + qui replace `res' = `res' + $HP_res/ M_nu[1,$HG_tplv] + } + } + else if `what'==4{ + if `toplev'==1{ /* by sorlst won't work for composite link */ + qui replace `res' = `lint`toplev''/ ${HG_wt`toplev'} + } + else{ + qui by `sortlst': replace `res' = `lint`toplev''[_N]/ ${HG_wt`toplev'} + } + if $HP_prior { + qui replace `res' = `res' + $HP_res / M_nu[1,$HG_tplv] + } + } + else if `what'>=5{ + qui replace `res' = ${HG_stat`toplev'} + } + qui by `sortlst': replace `extra' = cond(_n==_N,1,0) + *mlsum `lnf' = `lint`toplev'' if `extra' == 1 /* can only use this when program called by ML */ + *noi summ `lint`toplev'' if `extra' == 1 + *list $HG_clus `lint`toplev'' if `extra' ==1 & `lint`toplev''< -300 + + qui count if `extra' == 1 + local n = r(N) + summarize `lint`toplev'', meanonly + if `n' > r(N) { + * noi disp "there are " r(N) " values of likelihood, should be " `n' + * noi list $HG_clus if `extra' == 1& `lint`toplev''==. + * noi matrix list `bo' + * noi disp "lnf equal to missing in last step" + scalar `lnf' = . + exit + } + scalar `lnf' = r(sum) + if $HP_prior{ + if $HP_sprd == 1 & `what'== 0 { + scalar `lnf' = `lnf' + $HP_res / M_nu[1,$HG_tplv] + } + else{ + * disp in re $HP_res + scalar `lnf' = `lnf' + $HP_res + } + } + * display in re "total lnf = " `lnf' + * capture drop lint`toplev' + * gen double lint`toplev' = `lint`toplev'' +*} /* qui */ +end + +program define prepadpt +*qui replace $HG_C21 = 0 +*qui replace $HG_MU1 = 0 +*qui replace $HG_MU2 = 0 +*qui replace $HG_SD1 = 1 +*qui replace $HG_SD2 = 1 +*qui replace $HG_C31 = 0 +*qui replace $HG_C32 = 0 +*disp in re " " + + local tplv = $HG_tplv + + local i = $HG_tprf - 1 + while `i' >= 1 { + * disp in re " " + qui replace ${HG_MU`i'} = 0 if ${HG_MU`i'} ==. + *qui replace ${HG_SD`i'} = 1e-05 if ${HG_SD`i'} < 1e-25 | ${HG_SD`i'} ==. + qui replace ${HG_SD`i'} = 1e-05 if ${HG_SD`i'} < 1e-05 | ${HG_SD`i'} ==. +* variance + * disp in re "HG_V`i'`i'`tplv' = HG_SD`i'^2" + qui replace ${HG_V`i'`i'`tplv'} = ${HG_SD`i'}^2 + local j = $HG_tprf - 1 + while `j' > `i'{ + * disp in re "HG_V`i'`i'`tplv' = HG_V`i'`i'`tplv' - HG_C`j'`i'*HG_V`j'`i'`tplv' " + ** new + qui replace ${HG_C`j'`i'} = 0 if ${HG_V`i'`i'`tplv'} - ${HG_C`j'`i'}*${HG_V`j'`i'`tplv'} < 0 + qui replace ${HG_V`i'`i'`tplv'} = ${HG_V`i'`i'`tplv'} - ${HG_C`j'`i'}*${HG_V`j'`i'`tplv'} + + qui replace ${HG_MU`i'} = ${HG_MU`i'} - ${HG_C`j'`i'}*${HG_MU`j'} + * disp in re "HG_MU`i' = HG_MU`i' - HG_C`j'`i'*HG_MU`j' = " in ye ${HG_MU`i'}[$which] + * noi summ ${HG_MU`i'} + local j = `j' - 1 + } + + * disp in re "negative variances" + * noi summ ${HG_V`i'`i'`tplv'} if ${HG_V`i'`i'`tplv'} <0 + * noi list $HG_clus ${HG_V`i'`i'`tplv'} if ${HG_V`i'`i'`tplv'} <0 + * qui replace ${HG_V`i'`i'`tplv'} = 1e-10 if ${HG_V`i'`i'`tplv'} <0 + qui replace ${HG_SD`i'} = sqrt(${HG_V`i'`i'`tplv'}) + *disp in re "HG_MU`i' = " in ye in ye ${HG_MU`i'}[$which] + *disp in re "HG_SD`i' = " in ye ${HG_SD`i'}[$which] + * noi summ ${HG_SD`i'} + +* covariances and betas + local k = `i' - 1 + while `k' >= 1 { + qui replace ${HG_V`i'`k'`tplv'} = ${HG_C`i'`k'} + * disp in re "HG_V`i'`k'`tplv' = HG_C`k'`i'" + local j = $HG_tprf - 1 + while `j' > `i'{ + *disp in re "HG_V`i'`k'`tplv' = HG_V`i'`k'`tplv' - HG_C`j'`i'*HG_V`j'`k'`tplv'" + + qui replace ${HG_V`i'`k'`tplv'} = ${HG_V`i'`k'`tplv'} - ${HG_C`j'`i'}*${HG_V`j'`k'`tplv'} + local j = `j' - 1 + } + qui replace ${HG_C`i'`k'} = ${HG_V`i'`k'`tplv'}/${HG_V`i'`i'`tplv'} + * noi summ ${HG_C`i'`k'} + *disp in re "HG_C`i'`k' = " in ye ${HG_C`i'`k'}[$which] + local k = `k' - 1 + } + + local i = `i' - 1 + } +*qui replace $HG_C21 = 0 +/* +qui replace $HG_MU2 = .57022599 +qui replace $HG_SD2 = .83303331 +qui replace $HG_MU1 = -.55565732 +qui replace $HG_SD1 = .65728191 +*/ +end + +program define lnupdate +version 7.0 +args levno lintlv lintprv lprodlv lfaclv lfacprv extra lnf prvsort sortlst first what +tempvar lpkpl +quietly{ + * disp in re "!!! update level " `levno' + * noi matrix list M_znow + + /* set previous lint to ln(lint) */ + local lprev = `levno' - 1 + if(`levno' > 2){ + *!! disp " replace lint" `lprev' " by ln(lint" `lprev' ")" + quietly count if `lintprv' < 1e-308 + if r(N) > 0{ + /* overflow problem */ + * noi disp "overflow at level " `lprev' + scalar `lnf' = . + exit + } + if `what'==1{ + local rf = 1 + while `rf'< M_nrfc[2,`lprev']{ + * disp "by `prvsort': replace HG_E`rf'`lprev' = HG_E`rf'`lprev'/lintprv[_N]" + qui by `prvsort': replace ${HG_E`rf'`lprev'} = ${HG_E`rf'`lprev'}/`lintprv'[_N] + * disp in re "by `prvsort': replace HG_V`rf'`rf'`lprev' = HG_V`rf'`rf'`lprev'/lintprv[_N]" + qui by `prvsort': replace ${HG_V`rf'`rf'`lprev'} = ${HG_V`rf'`rf'`lprev'}/`lintprv'[_N] + local rf2 = `rf' + 1 + while `rf2' < $HG_tprf{ + * disp in re "by `prvsort': replace HG_V`rf2'`rf'`lprev' = HG_V`rf2'`rf'`lprev'/lintprv[_N]" + qui by `prvsort': replace ${HG_V`rf2'`rf'`lprev'} = ${HG_V`rf2'`rf'`lprev'}/`lintprv'[_N] + local rf2 = `rf2' + 1 + } + local rf = `rf' + 1 + } + + } + if `what'>=5{ + if $HG_post{ + qui by `prvsort': replace ${HG_stat`lprev'} = ${HG_stat`lprev'}/`lintprv'[_N] + } + } + quietly replace `lintprv' = ln(`lintprv') + quietly replace `lintprv' = (`lintprv'-`lfacprv')*${HG_wt`lprev'} + } + + /* sum previous lprod within cluster at current level */ + *!! disp " " + * noi disp "by `sortlst': replace lprod" `levno' "=cond(_n==N, sum(lint" `lprev' "))" + * noi summ `lintprv' + quietly by `sortlst': replace `lprodlv' = cond(_n==_N,sum(`lintprv'),.) + * noi disp " " + * noi disp "lprod" `levno' " = " `lprodlv'[$which] + * noi disp "lintprv[" $which "]= " `lintprv'[$which] + + /* accumulate terms for integral */ + + /* get lpkpl: log of product of r.effs at level */ + qui $HG_lzpr `levno' `lpkpl' + * noi disp "exp(lprod`leno'+lpkpl) = " exp(`lpkpl'[$which]+`lprodlv'[$which]) + + if `first' { /* first term for lint`levno' */ + quietly replace `extra' = 0 + quietly replace `lfaclv' = -`lprodlv' - `lpkpl' + *a noi disp " " + * noi disp "lfac`levno' = " `lfaclv'[$which] + * noi disp "lintlv = 1" + qui replace `lintlv' = 1 + } + else{ + local max = 500 + quietly replace `extra' = cond(`lprodlv'+ `lpkpl'+`lfaclv'>`max', /* + */ -(`lprodlv'+`lpkpl'+`lfaclv')+`max',0) + * noi disp "extra = " `extra'[$which] + quietly replace `lfaclv'=`lfaclv'+`extra' + * noi disp "lfac`levno' = " `lfaclv'[$which] + + /* increment lint at current level using lprod at previous level */ + * noi disp "increase lint" `levno' " by exp(lprodlv + lpkpl +lfaclv)" + quietly replace `lintlv' = exp(`extra')*`lintlv' + exp(`lprodlv'+ `lpkpl'+`lfaclv') + * noi disp "increase by " exp(`lprodlv'[$which]+`lpkpl'[$which]+`lfaclv'[$which]) " to " `lintlv'[$which] + } + + +/* posterior means and variances*/ + if `what'==1{ + local rf = 1 + while `rf'< M_nrfc[2,`levno'] { + * noi disp "update `rf' `levno'" + quietly by `sortlst': replace ${HG_E`rf'`levno'}=/* + */ exp(`extra'[_N])*${HG_E`rf'`levno'}+ ${HG_E`rf'`lprev'}*exp(`lprodlv'[_N]+`lpkpl'+`lfaclv'[_N]) + * noi disp "HG_E" `rf' `levno' "[" $which "] = " ${HG_E`rf'`levno'}[$which] + quietly by `sortlst': replace ${HG_V`rf'`rf'`levno'}=/* + */ exp(`extra'[_N])*${HG_V`rf'`rf'`levno'}+ ${HG_V`rf'`rf'`lprev'}*exp(`lprodlv'[_N]+`lpkpl'+`lfaclv'[_N]) + *noi disp "HG_V" `rf' `rf' `levno' "[" $which "] = " ${HG_V`rf'`rf'`levno'}[$which] + local rf2 = `rf' + 1 + while `rf2' < $HG_tprf { + * noi disp "HG_V`rf2'`rf'`levno' is ${HG_V`rf2'`rf'`levno'}" + quietly by `sortlst': replace ${HG_V`rf2'`rf'`levno'}=/* + */ exp(`extra'[_N])*${HG_V`rf2'`rf'`levno'}+ ${HG_V`rf2'`rf'`lprev'}*exp(`lprodlv'[_N]+`lpkpl'+`lfaclv'[_N]) + * noi disp "HG_V" `rf2' `rf' `levno' "[" $which "] = " ${HG_V`rf2'`rf'`levno'}[$which] + local rf2 = `rf2' + 1 + } + local rf = `rf' + 1 + } + + } + if `what'>=5{ + if $HG_post{ + * disp in re "sortlist: `sortlst'" + *sort `sortlst' /* removed oct 2004 */ + quietly by `sortlst': replace ${HG_stat`levno'}=/* + */ exp(`extra'[_N])*${HG_stat`levno'}+ /* + */ ${HG_stat`lprev'}*exp(`lprodlv'[_N]+`lpkpl'+`lfaclv'[_N]) + } + else{ + *disp in re "HG_stat`levno'[1] = " ${HG_stat`levno'}[1] " + " ${HG_stat`lprev'}[1] " * " exp(`lpkpl') + qui replace ${HG_stat`levno'} = ${HG_stat`levno'} + ${HG_stat`lprev'}*exp(`lpkpl') + } + } + + else if `what'==2{ + * noi matrix list M_ip + local i = M_ip[1,2] + local j = 1 + while `j'<`i'{ + quietly by `sortlst': replace ${HG_p`j'} = exp(`extra'[_N])*${HG_p`j'} + local j = `j' + 1 + } + quietly by `sortlst': replace ${HG_p`i'} = exp(`lprodlv'[_N]+`lpkpl'+`lfaclv'[_N]) + } + /* reset previous lint to zero */ + if `levno'>2{ + if `what'==1{ + local rf = 1 + while `rf'=5{ + *disp in re "setting HG_stat" `lprev' " to zero" + quietly replace ${HG_stat`lprev'} = 0 + } + } + } /* qui */ +end + +program define zipf + version 7.0 + * updates znow + * matrix list M_ip + args levno + + * disp "in zip, levno is " `levno' + local i = M_nrfc[2,`levno'-1] + 1 + + *!! disp "update" + * same class for all random effects + local k = M_nrfc[1,`levno'] + local k = M_ip[1,`k'] + local last = M_nrfc[2,`levno'] + while `i' <= `last'{ + local npt = M_nip[2,`i'] + local im = `i' - 1 + * disp " "`im' "th z to " `which' "th location" + * disp " using M_zlc`npt' " + matrix M_znow[1,`im'] = M_zlc`npt'[1,`k'] + local i = `i' + 1 + } +end + +program define zipf1 + version 7.0 + * updates znow + * matrix list M_ip + args levno + tempname mzlc + + * disp "in zip, levno is " `levno' + local i = M_nrfc[2,`levno'-1] + 1 + + *!! disp "update" + * same class for all random effects + local k = M_nrfc[1,`levno'] + local k = M_ip[1,`k'] + local last = M_nrfc[2,`levno'] + while `i' <= `last'{ + local npt = M_nip[2,`i'] + local im = `i' - 1 + * disp " "`im' "th z to " `which' "th location" + * disp " using M_zlc`npt' " + matrix M_znow[1,`im'] = M_zlc`npt'[1,`k'] + local i = `i' + 1 + } + local llev = `levno' - 1 + local im = M_nrfc[2,`llev'] + while `im' < `last'{ +* change HG_E and HG_V + scalar `mzlc' = M_znow[1,`im'] + qui replace ${HG_E`im'`llev'} = ${HG_MU`im'} + ${HG_SD`im'}*`mzlc' + local im2 = $HG_tprf - 1 + while `im2' > `im'{ + scalar `mzlc' = M_znow[1,`im2'] + * disp in re "replace HG_E`im'`llev' = HG_E`im'`llev' + HG_C`im2'`im'*(HG_MU`im2' + HG_SD`im2'*`mzlc')" + qui replace ${HG_E`im'`llev'} = ${HG_E`im'`llev'} + ${HG_C`im2'`im'}*(${HG_MU`im2'} + ${HG_SD`im2'}*`mzlc') + local im2 = `im2' - 1 + } + * noi disp "HG_E`im'`llev'[$which] = " ${HG_E`im'`llev'}[$which] + qui replace ${HG_V`im'`im'`llev'} = ${HG_E`im'`llev'}^2 + + local im = `im' + 1 + } + local im = M_nrfc[2,`llev'] + while `im' < `last'{ +* covariances with same level and higher level effects + local llev2 = `llev' + local im2 = `im' + 1 + while `llev2'<$HG_tplv{ + while `im2' < M_nrfc[2,`llev2' + 1]{ + qui replace ${HG_V`im2'`im'`llev'} = ${HG_E`im'`llev'}*${HG_E`im2'`llev2'} + * disp in re "HG_V`im2'`im'`llev' = HG_E`im'`llev'*HG_E`im2'`llev2' = " in ye ${HG_V`im2'`im'`llev'}[$which] + local im2 = `im2' + 1 + } + local llev2 = `llev2' + 1 + } + local im = `im' + 1 + } +end + +program define zipg + version 7.0 + * updates znow + * matrix list M_ip + args levno + + * disp "in zip, levno is " `levno' + local i = M_nrfc[2,`levno'-1] + 1 + + *!! disp "update" + if $HG_mult{ + *local npt = M_nip[2,`i'] + local npt = M_nip[2,`levno'] + local k = M_nrfc[1,`levno'] + local k = M_ip[1,`k'] + local f = M_nrfc[2,`levno'-1] + } + + local last = M_nrfc[2,`levno'] + while `i' <= `last'{ + local im = `i' - 1 + + if $HG_mult{ + matrix M_znow[1,`im'] = M_zlc`npt'[`i'-`f',`k'] + } + else{ + local npt = M_nip[2,`i'] + local which = M_ip[1,`i'] + * disp " "`im' "th z to " `which' "th location" + * disp " using M_zlc`npt' " + matrix M_znow[1,`im'] = M_zlc`npt'[1,`which'] + } + + *!! disp M_znow[1,`im'] + local i = `i' + 1 + } +end + + +program define zipga + version 7.0 + * updates znow + * matrix list M_ip + args levno + tempname mzlc + + * disp "in zip, levno is " `levno' + local llev = `levno' - 1 + local i = M_nrfc[2,`llev'] + 1 + + *!! disp "update" + if $HG_mult{ + *local npt = M_nip[2,`i'] + local npt = M_nip[2,`levno'] + local k = M_nrfc[1,`levno'] + local k = M_ip[1,`k'] + local f = M_nrfc[2,`levno'-1] + } + local last = M_nrfc[2,`levno'] + + while `i' <= `last'{ + *local npt = M_nip[2,`i'] + local im = `i' - 1 + + if $HG_mult{ + matrix M_znow[1,`im'] = M_zlc`npt'[`i'-`f',`k'] + } + else{ + local npt = M_nip[2,`i'] + local which = M_ip[1,`i'] + * disp " "`im' "th z to " `which' "th location" + * disp " using M_zlc`npt' " + matrix M_znow[1,`im'] = M_zlc`npt'[1,`which'] + } + local i = `i' + 1 + } + local im = M_nrfc[2,`llev'] + while `im' < `last'{ + +* change HG_E + scalar `mzlc' = M_znow[1,`im'] + qui replace ${HG_E`im'`llev'} = ${HG_MU`im'} + ${HG_SD`im'}*`mzlc' + *local im2 = M_nrfc[2,`llev'] + + local im2 = $HG_tprf - 1 + while `im2' > `im'{ + scalar `mzlc' = M_znow[1,`im2'] + * disp in re "replace HG_E`im'`llev' = HG_E`im'`llev' + HG_C`im2'`im'*(HG_MU`im2' + HG_SD`im2'*`mzlc')" + qui replace ${HG_E`im'`llev'} = ${HG_E`im'`llev'} + ${HG_C`im2'`im'}*(${HG_MU`im2'} + ${HG_SD`im2'}*`mzlc') + local im2 = `im2' - 1 + } + * noi disp "HG_E`im'`llev'[$which] = " ${HG_E`im'`llev'}[$which] + + *!! disp M_znow[1,`im'] + local im = `im' + 1 + } +end + + +program define zipg1 + version 7.0 + * updates znow + * matrix list M_ip + args levno + tempname mzlc + + * noi disp "in zip, levno is " `levno' + local llev = `levno' - 1 + local i = M_nrfc[2,`llev'] + 1 + + *!! disp "update" + if $HG_mult{ + *local npt = M_nip[2,`i'] + local npt = M_nip[2,`levno'] + local k = M_nrfc[1,`levno'] + local k = M_ip[1,`k'] + local f = M_nrfc[2,`levno'-1] + } + local last = M_nrfc[2,`levno'] + + while `i' <= `last'{ + local im = `i' - 1 + *local npt = M_nip[2,`i'] + if $HG_mult{ + * disp in re "M_znow[1,`im'] = M_zlc`npt'[`i'-`f',`k']" + matrix M_znow[1,`im'] = M_zlc`npt'[`i'-`f',`k'] + } + else{ + local npt = M_nip[2,`i'] + local which = M_ip[1,`i'] + * disp " "`im' "th z to " `which' "th location" + * disp " using M_zlc`npt' " + matrix M_znow[1,`im'] = M_zlc`npt'[1,`which'] + } + + local i = `i' + 1 + } + local im = M_nrfc[2,`llev'] + while `im' < `last'{ +* change HG_E and HG_V + scalar `mzlc' = M_znow[1,`im'] + qui replace ${HG_E`im'`llev'} = ${HG_MU`im'} + ${HG_SD`im'}*`mzlc' + local im2 = $HG_tprf - 1 + while `im2' > `im'{ + scalar `mzlc' = M_znow[1,`im2'] + * disp in re "replace HG_E`im'`llev' = HG_E`im'`llev' + HG_C`im2'`im'*(HG_MU`im2' + HG_SD`im2'*`mzlc')" + qui replace ${HG_E`im'`llev'} = ${HG_E`im'`llev'} + ${HG_C`im2'`im'}*(${HG_MU`im2'} + ${HG_SD`im2'}*`mzlc') + local im2 = `im2' - 1 + } + * noi disp "HG_E`im'`llev'[$which] = " ${HG_E`im'`llev'}[$which] + qui replace ${HG_V`im'`im'`llev'} = ${HG_E`im'`llev'}^2 + + local im = `im' + 1 + } + local im = M_nrfc[2,`llev'] + while `im' < `last'{ +* covariances with same level and higher level effects + local llev2 = `llev' + local im2 = `im' + 1 + while `llev2'<$HG_tplv{ + while `im2' < M_nrfc[2,`llev2' + 1]{ + qui replace ${HG_V`im2'`im'`llev'} = ${HG_E`im'`llev'}*${HG_E`im2'`llev2'} + * disp in re "HG_V`im2'`im'`llev' = HG_E`im'`llev'*HG_E`im2'`llev2' = " in ye ${HG_V`im2'`im'`llev'}[$which] + local im2 = `im2' + 1 + } + local llev2 = `llev2' + 1 + } + local im = `im' + 1 + } +end + + +program define lzprobf + version 7.0 + * for free masses + * returns product of pk needed for integration at level lev for current ip + args levno lpkpl + tempname mzps mznow + * disp in re "in zprob, levno is " `levno' + + local i=M_nrfc[1,`levno'-1] + 1 + + *!! disp "-----------lpkpl: sum of log of" + + local npt = M_nip[2,`i'] + * disp " prob for " `i' "th r.eff: " `which' "th weight" + * disp " using M_zps`npt' " + + local which = M_ip[1,`i'] + if M_np[1,`levno']>0{ + qui gen double `lpkpl' = ${HG_p`npt'`which'} + } + else{ + qui gen double `lpkpl' = M_zps`npt'[1,`which'] + } + + * disp in re "lpkpl[$which] = " `lpkpl'[$which] +end + +program define lzprobg + version 7.0 + * product gaussian quadrature + * returns product of pk needed for integration at level lev for current ip + args levno lpkpl + tempname mzps mznow + * disp in re "in zprob, levno is " `levno' + qui gen double `lpkpl' = 0 + local lv = `levno' - 1 + local i=M_nrfc[1,`lv'] + 1 + + *!! disp "-----------lpkpl: sum of log of" + local last = M_nrfc[1,`levno'] + while `i' <= `last'{ + local npt = M_nip[2,`i'] + * disp " prob for " `i' "th r.eff: " `which' "th weight" + * disp " using M_zps`npt' " + + local which = M_ip[1,`i'] + local im = `i' - 1 + scalar `mzps' = M_zps`npt'[1,`which'] + qui replace `lpkpl' = `lpkpl'+ `mzps' + if $HG_adapt{ + scalar `mznow' = M_znow[1,`im'] + *qui replace `lpkpl' = `lpkpl' + ln(${HG_SD`im'}) + `mznow'^2/2 - (${HG_MU`im'} + ${HG_SD`im'}*`mznow')^2/2 + qui replace `lpkpl' = `lpkpl' + ln(${HG_SD`im'}) + `mznow'^2/2 - (${HG_E`im'`lv'})^2/2 + } + local i=`i'+1 + } + * disp in re "lpkpl[$which] = " `lpkpl'[$which] +end + +program define lzprobm + version 7.0 + * mult version + * returns product of pk needed for integration at level lev for current ip + args levno lpkpl + tempname mzps mznow + * disp in re "in zprob, levno is " `levno' + + local lv = `levno' - 1 + local i=M_nrfc[1,`lv'] + 1 + + *!! disp "-----------lpkpl: sum of log of" + + local npt = M_nip[2,`i'] + * disp " prob for " `i' "th r.eff: " `which' "th weight" + * disp " using M_zps`npt' " + + local which = M_ip[1,`i'] + scalar `mzps' = M_zps`npt'[1,`which'] + qui gen double `lpkpl' = `mzps' + + if $HG_adapt{ + local i=M_nrfc[2,`lv'] + 1 + local last = M_nrfc[2,`levno'] + while `i' <= `last'{ + local im = `i' - 1 + scalar `mznow' = M_znow[1,`im'] + qui replace `lpkpl' = `lpkpl' + ln(${HG_SD`im'}) + `mznow'^2/2 - (${HG_E`im'`lv'})^2/2 + *disp in re "HG_E`im'`lv'[$which] = " ${HG_E`im'`lv'}[$which] + local i = `i' + 1 + } + } + *disp in re "lpkpl[$which] = " `lpkpl'[$which] +end + + +program define lpyz + version 7.0 +* returns log of prob of obs. given znow + args lpyz + + * disp "-----------------called lpyz" + + tempvar zu xb mu /* linear predictor and zu: r.eff*design matrix for r.eff */ + +/* ----------------------------------------------------------------------------- */ +*quietly{ + + + if $HG_tprf>1{ + + matrix score double `zu' = M_znow + if $HG_adapt{ + qui replace `zu' = $HG_zuoff + `zu' + *qui replace `zu' = $HG_E11*$HG_s2 + $HG_E21*$HG_s3 + } + + + } + else{ + qui gen double `zu' = 0 + } + + * matrix list M_znow + * disp "ML_y1: $ML_y1 " $ML_y1[$which] + * matrix list M_ip + disp " xb1 = " $HG_xb1[$which] + disp " zu = " `zu'[$which] + + + if $HG_mlog>0{ + nominal `lpyz' `zu' + } + + if $HG_oth{ + local myand + if "$HG_lv"~=""&($HG_nolog>0|$HG_mlog>0){ + local myand $HG_lvolo~=1 + } + quietly gen double `mu' = 0 + *if $HG_noC|$HG_comp>0 { + if $HG_noC { + link "$HG_link" `mu' $HG_xb1 `zu' $HG_s1 + if $HG_comp>0 { + compos `mu' "`myand'" + } + *disp " mu = " `mu'[$which] + if $HG_comp>0{ + if "`myand'"~=""{ + local myand `myand' & $HG_ind>0 + } + else{ + local myand $HG_ind>0 + } + } + family "$HG_famil" `lpyz' `mu' "`myand'" + } + + else { + if $HG_lev1 != 0 { + local s1opt "st($HG_s1)" + } + if "$HG_denom" != "" { + local denopt "denom($HG_denom)" + } + if "$HG_fv" != "" { + local fvopt "fv($HG_fv)" + } + if "$HG_lv" != "" { + local lvopt "lv($HG_lv)" + local othopt "oth(M_oth)" + } + if "`myand'" != "" { + local ifopt "if `myand'" + } + if $HG_comp > 0 { /* only got here if new Stata 8 */ + local comp "comp($HG_comp)" + local cclus "cluster($HG_clus)" + } + noi _gllamm_fl `lpyz' `mu' `ifopt', `s1opt' /* + */ link($HG_link) family($HG_famil) `denopt' `fvopt' /* + */ `lvopt' xb($HG_xb1) zu(`zu') /* + */ y($ML_y1) `othopt' `comp' `cclus' + } + disp " mu = " `mu'[$which] + } + + if $HG_nolog>0{ + if $HG_noC { + ordinal `lpyz' `zu' + } + else { + if $HG_lev1 != 0 { + local stopt st($HG_s1) + } + if "$HG_lv"!="" { + local lvopt lv($HG_lv) + } + local j 1 + while `j'<=$HG_tpff { + local xbeta `xbeta' ${HG_xb`j'} + local j = `j' + 1 + } + _gllamm_ord `lpyz', y($ML_y1) xb(`xbeta') /* + */ zu(`zu') link($HG_linko) nlog($HG_nolog) /* + */ olog(M_olog) nresp(M_nresp) resp(M_resp) /* + */ `stopt' `lvopt' + } + } + +*} /* qui */ +end + +program define compos + version 7.0 + args mu und + + tempvar junk mu2 + local ifs + if "`und'"~=""{ + local ifs if `und' + } + gen double `junk'=0 + gen double `mu2'=. + local i = 1 + *disp in re "in compos: HG_clus is: $HG_clus" + while `i'<= $HG_comp{ + *disp in re "in compos: variable HG_co`i' is: ${HG_co`i'}" + replace `junk' = `mu'*${HG_co`i'} + qui by $HG_clus: replace `junk' = sum(`junk') + qui by $HG_clus: replace `mu2' = `junk'[_N] if $HG_ind==`i' + local i = `i' + 1 + } + qui replace `mu' = `mu2' `ifs' +end + +program define nominal + version 7.0 + args lpyz zu + tempvar mu + + if $HG_smlog{ + local s $HG_s1 + } + else{ + local s = 1 + } + local and + if "$HG_lv"~=""{ + local and & $HG_lv == $HG_mlog + local mlif if $HG_lv == $HG_mlog + } + disp "mlogit link `mlif'" + if $HG_exp==1&$HG_expf==0{ + qui gen double `mu' = exp(`zu'/`s') if $ML_y1==M_respm[1,1] `and' + local n=rowsof(M_respm) + local i=2 + while `i'<=`n'{ + local prev = `i' - 1 + * disp "xb`prev':" ${HG_xb`prev'}[$which] + qui replace `mu' = exp((${HG_xb`prev'} + `zu')/`s') if $ML_y1==M_respm[`i',1] `and' + local i = `i' + 1 + } + + sort $HG_clus $HG_ind + qui by $HG_clus: replace `lpyz'=cond(_n==_N,sum(`mu'),.) `mlif' + qui replace `lpyz' = ln(`mu'/`lpyz') `mlif' +/* skip sort + qui by $HG_clus: replace `lpyz' = sum(`mu') `mlif' + qui by $HG_clus: replace `lpyz' = cond($HG_ind>0,ln(`mu'/`lpyz'[_N]),.) `mlif' + +*/ + } + else if $HG_exp==1&$HG_expf==1{ + qui gen double `mu' = exp(($HG_xb1 + `zu')/`s') `mlif' + sort $HG_clus $HG_ind + * disp "sort $HG_clus $HG_ind" + qui by $HG_clus: replace `lpyz'=cond(_n==_N,sum(`mu'),.) `mlif' + * disp "denom = " `lpyz'[$which] + qui replace `lpyz' = ln(`mu'/`lpyz') `mlif' + } + else{ + tempvar den tmp + local n=rowsof(M_respm) + local i = 2 + qui gen double `mu' = 1 if $ML_y1==M_respm[1,1] `mlif' + qui gen double `den' = 1 + qui gen double `tmp' = 0 + while `i'<= `n'{ + local prev = `i' - 1 + qui replace `tmp' = exp((${HG_xb`prev'} + `zu')/`s') `mlif' + qui replace `mu' = `tmp' if $ML_y1==M_respm[`i',1] `mlif' + replace `den' = `den' + `tmp' `mlif' + local i = `i' + 1 + } + replace `lpyz' = ln(`mu'/`den') `mlif' + } +end + +program define ordinal + version 7.0 + args lpyz zu + local no = 1 + local xbind = 2 + tempvar mu p1 p2 + qui gen double `p1' = 0 + qui gen double `p2' = 0 + qui gen double `mu' = 0 + + while `no' <= $HG_nolog{ + local olog = M_olog[1,`no'] + local lnk: word `no' of $HG_linko + + if "`lnk'"=="ologit"{ + local func logitl + } + else if "`lnk'"=="oprobit"{ + local func probitl + } + else if "`lnk'"=="ocll"{ + local func cll + } + else if "`lnk'"=="soprobit"{ + local func sprobitl + } + local and + if "$HG_lv"~=""&$HG_nolog>0{ + local and & $HG_lv == `olog' + } + * disp "ordinal link is `lnk', and = `and'" + local n=M_nresp[1,`no'] + + * disp "HG_xb1: " $HG_xb1 + * disp "xbind = " `xbind' + * disp ${HG_xb`xbind'}[$which] + + qui replace `mu' = $HG_xb1+`zu'-${HG_xb`xbind'} + `func' `mu' `p1' + qui replace `lpyz' = ln(1-`p1') /* + */ if $ML_y1==M_resp[1,`no'] `and' + qui replace `p2' = `p1' + local i = 2 + while `i' < `n'{ + local nxt = `xbind' + `i' - 1 + + * disp "nxt = " `nxt' + * disp ${HG_xb`nxt'}[$which] + + qui replace `mu' = $HG_xb1+`zu'-${HG_xb`nxt'} + `func' `mu' `p2' + + * disp "p1 and p2: " `p1'[$which] " " `p2'[$which] + + qui replace `lpyz' = ln(`p1' -`p2') /* + */ if $ML_y1==M_resp[`i',`no'] `and' + qui replace `p1' = `p2' + local i = `i' + 1 + } + local xbind = `xbind' + `n' -1 + qui replace `lpyz' = ln(`p2') /* + */ if $ML_y1==M_resp[`n',`no'] `and' + local no = `no' + 1 + } /* next ordinal response */ + *tab $ML_y1 if `lpyz'==. `and' + qui replace `lpyz' = -100 if `lpyz'==. `and' +end + +program define logitl + version 7.0 + args mu p + qui replace `p' = 1/(1+exp(-`mu')) +end + +program define cll + version 7.0 + args mu p + qui replace `p' = 1-exp(-exp(`mu')) +end + +program define probitl + version 7.0 + args mu p + qui replace `p' = normprob(`mu') +end + +program define sprobitl + version 7.0 + args mu p + qui replace `p' = normprob(`mu'/$HG_s1) +end + + +program define link + version 7.0 +* returns mu for requested link + args which mu xb zu s1 + * disp " in link, which is `which' " + + tokenize "`which'" + local i=1 + local ifs + while "`1'"~=""{ + if "$HG_lv" ~= ""{ + local oth = M_oth[1,`i'] + local ifs if $HG_lv==`oth' + } + * disp "`1' link `ifs'" + + if ("`1'" == "logit"){ + quietly replace `mu' = 1/(1+exp(-`xb'-`zu')) `ifs' + } + else if ("`1'" == "probit"){ + * disp "doing probit " + quietly replace `mu' = normprob((`xb'+`zu')) `ifs' + } + else if ("`1'" == "sprobit"){ + quietly replace `mu' = normprob((`xb'+`zu')/`s1') `ifs' + } + else if ("`1'" == "log"){ + * disp "doing log " + quietly replace `mu' = exp(`xb'+`zu') `ifs' + } + else if ("`1'" == "recip"){ + * disp "doing recip " + quietly replace `mu' = 1/(`xb'+`zu') `ifs' + } + else if ("`1'" == "cll"){ + * disp "doing cll " + quietly replace `mu' = 1 - exp(-exp(`xb'+`zu')) `ifs' + } + else if ("`1'" == "ll"){ + quietly replace `mu' = exp(-exp(`xb'+`zu')) `ifs' + } + else if ("`1'" == "ident"){ + quietly replace `mu' = `xb'+`zu' `ifs' + } + local i = `i' + 1 + mac shift + } + +end + +program define family + version 7.0 + args which lpyz mu und + + tokenize "`which'" + local i=1 + * disp "in family, und = `und'" + if "$HG_fv" == ""{ + local ifs + if "`und'"~=""{local und if `und'} + } + else{ + if "`und'"~=""{local und & `und'} + } + while "`1'"~=""{ + if "$HG_fv" ~=""{ + local ifs if $HG_fv == `i' + } + if ("`1'" == "binom"){ + famb `lpyz' `mu' "`ifs'" "`und'" + } + else if ("`1'" == "poiss"){ + famp `lpyz' `mu' "`ifs'" "`und'" + } + else if ("`1'" == "gauss") { + *disp in re "famg lpyz mu $HG_s1 `ifs' `und'" + famg `lpyz' `mu' $HG_s1 "`ifs'" "`und'" /* get log of conditional prob. */ + } + else if ("`1'" == "gamma"){ + famga `lpyz' `mu' $HG_s1 "`ifs'" "`und'" + } + else{ + disp in re "unknown family in gllam_ll" + exit 198 + } + local i = `i' + 1 + mac shift + } +end + +program define famg + version 7.0 +* returns log of normal density conditional on r.effs + args lpyz mu s1 if and + * disp "running famg `if' `and'" + * disp "s1 = " `s1'[$which] ", mu = " `mu'[$which] " and Y = " $ML_y1[$which] + quietly replace `lpyz' = /* + */ -(ln(2*_pi*`s1'^2) + (($ML_y1-`mu')/`s1')^2)/2 `if' `and' +end + +program define famb + version 7.0 +* returns log of binomial density conditional on r.effs +* $HG_denom is denominator + args lpyz mu if and + * disp "running famb `if' `and'" + * disp "mu = " `mu'[$which] " and Y = " $ML_y1[$which] + qui replace `lpyz' = cond($ML_y1>0,$ML_y1*ln(`mu'),0) /* + */ + cond($HG_denom-$ML_y1>0,($HG_denom-$ML_y1)*ln(1-`mu'),0) /* + */ + cond($HG_denom>1,lngamma($HG_denom+1)-lngamma($ML_y1+1) /* + */ - lngamma($HG_denom-$ML_y1+1),0) `if' `and' + *tab $ML_y1 `if' `and' & `lpyz'==. + qui replace `lpyz' = cond(`lpyz'==.,-100,`lpyz') `if' `and' + * disp "done famb" +end + +program define famp + version 7.0 +* returns log of poisson density conditional on r.effs + args lpyz mu if and + *!! disp "running famp `if'" + * disp in re "if and: `if' `and'" + quietly replace `lpyz' = /* + */ $ML_y1*(ln(`mu'))-`mu'-lngamma($ML_y1+1) `if' `and' + * qui replace `lpyz' = cond(`lpyz'==.,-100,`lpyz') `if' `and' + * disp "done famp" +end + +program define famga + version 7.0 +* returns log of gamma density conditional on r.effs + args lpyz mu s1 if and + *!! disp "running famg `if'" + *!! disp "mu = " `mu'[$which] + *!! disp "s1 = " `s1'[$which] + qui replace `mu' = 0.0001 if `mu' <= 0 + tempvar nu + qui gen double `nu' = `s1'^(-2) + quietly replace `lpyz' = /* + */ `nu'*(ln(`nu')-ln(`mu')) - lngamma(`nu')/* + */ + (`nu'-1)*ln($ML_y1) - `nu'*$ML_y1/`mu' `if' `and' +end + +program define timer +version 7.0 +end diff --git a/Modules/gllamm.ado b/Modules/gllamm.ado new file mode 100644 index 0000000..fbfc2b4 --- /dev/null +++ b/Modules/gllamm.ado @@ -0,0 +1,4749 @@ +*! version 2.3.20 SRH 7 Sept 2011 +program define gllamm, eclass + version 7.0 + timer on 1 + + if replay() { + if "`e(cmd)'" ~= "gllamm" { + di in red "gllamm was not the last command" + error 301 + } + Replay `0' + } + else { + Estimate `0' + } + timer off 1 +end + +program define procstr, eclass + version 6.0 + tempname bc b Vc Vr V ll esamp + noi disp "processing constraints" + + scalar `ll' = e(ll) + local df = e(df_m) + local dof + if "`df'"~="."{ + local dof "dof(`df')" + } + local k = e(k) + capture matrix `Vr' = e(Vr) + capture robclus "`e(robclus)'" + matrix `bc' = e(b) + matrix `Vc' = e(V) + local y = "`e(depvar)'" + matrix `b' = `bc'*M_T' + M_a + matrix colnames `b' = $HG_coln + matrix coleq `b' = $HG_cole + * matrix list `b' + * matrix list `Vc' + matrix `V' = M_T*`Vc'*M_T' + * disp "computed V" + * matrix list `V' + estimates post `b' `V' M_C, $HG_obs `dof' + est local ll =`ll' + est local k = `k' + est local depvar "`y'" + capture est matrix Vr `Vr' + capture est local robclus "`robclus'" + * disp "posted results" +end + +program define Replay, eclass + version 6.0 + syntax [, Level(real $S_level) EFORM ALLC ROBUST CLUSTER(varname) DOTS SCorefil(passthru) noROb noDISplay EVAL] + tempname M_nffc M_nu Vs + + if "`eval'"==""{ + if "`e(pweight)'"~="" { + local robust robust + } + if "`robust'"~=""|"`cluster'"~=""{ + if "`cluster'"~=""{ + local cluster cluster(`cluster') + } + gllarob, `cluster' `dots' `scorefil' `rob' + } + if ("`robust'"==""|"`rob'"~="")&"`cluster'"==""{ + * disp "reposting model-based standard errors" + matrix `Vs' = e(Vs) + estimates repost V =`Vs' + } + } + + if "`display'"==""{ + + local const = e(const) + local tplv = e(tplv) + matrix `M_nffc' = e(nffc) + capture matrix `M_nu' = e(nu) + * capture matrix list `M_nu' + if _rc == 0{ + disp " " + local j = 1 + while `j' <= `tplv'{ + disp in gr "number of level `j' units = " in ye `M_nu'[1,`j'] + local j = `j' + 1 + } + disp " " + } + local cn = e(cn) + if `cn'>0{ + disp in gr "Condition Number = " in ye `cn' + } + else{ + disp in gr "Condition Number could not be computed" + } + disp " " + + + * matrix list `M_nffc' + local numeq = colsof(`M_nffc') + if `M_nffc'[1,1]==0{ + local numeq = `numeq' -1 + } + if `numeq' > 1{ + local first neq(`numeq') + } + else{ + local first first + } + local primess + if `e(prior)' == 1 { + local primess "with prior " + } + if e(ll_0)==.|`M_nffc'[1,1]==0{ + local nohead "noheader" + if `const'==0{ + disp in gr "gllamm model `primess'" + } + else{ + disp in gre "gllamm model `primess'with constraints" + *matrix dispCns + } + disp " " + if `e(prior)' == 1 { + disp in gr "log posterior = " in ye e(ll) + disp in gr "log likelihood = " in ye e(a_ll) + } + else{ + disp in gr "log likelihood = " in ye e(ll) + } + } + if "`eform'"~=""{ + local eform "eform(exp(b))" + } + disp " " + if "`cluster'"~=""|("`robust'"~=""&"`rob'"==""){ + if "`cluster'"~=""{ + disp "Robust standard errors for clustered data: `cluster'" + } + else{ + disp "Robust standard errors" + } + } + + if `M_nffc'[1,1]>0|`numeq'>0 { + quietly q born + if $S_1>15502{ /* version 8 or later */ + _coef_table, level(`level') `first' `eform' + } + else{ /* older versions */ + if `const' == 0{ + noi ml display, level(`level') `nohead' `first' `eform' + } + else{ + matrix dispCns + noi estimates display, level(`level') `first' `eform' + } + } + } + else{ + disp in gr "No fixed effects" + } + noi disprand + if "`allc'"~=""{ + if `const' == 0{ + noi ml display, level(`level') `nohead' + } + else{ + noi estimates display, level(`level') + } + } + } +end + +program define Estimate, eclass + version 6.0 + syntax varlist(min=1) [if] [in] , I(string) [NRf(numlist integer min=1 >=1) /* + */ Eqs(string) GEqs(string) PEqs(string) /* + */ noCORrel noCOnstant BMATrix(string) INTER(string) FRLoad(numlist integer min=1 >=1) /* + */ Family(string) DEnom(varname numeric min=1) Link(string) EXpanded(string) /* + */ Offset(varname numeric) Basecategory(integer 999) /* + */ THresh(string) ETHresh(string) COMPosite(varlist numeric min=3) * ] + *disp in re "`opt'" + *disp in re "1: `varlist'" + local origif `"`if'"' + local origin `"`in'"' + local origvar `"`varlist'"' + local opt "`options'" + local 0 "`origvar' `origif' `origin', `opt'" + syntax varlist(min=1) [if] [in] [, /* + */ Weightf(string) LV(varname numeric min=1) FV(varname numeric min=1) S(string) /* + */ NATS IP(string) NIp(numlist integer min=1 >=1) ADapt Constraints(numlist) /* + */ FRom(string) LONG Gateaux(passthru) LF0(passthru) SEarch(passthru) /* + */ ROBust CLuster(varname) PWeight(string) ITerate(passthru)/* + */ DOts noLOg TRace noDISplay noESt EVal Level(real $S_level) INit noDIFficult /* + */ EFORM ALLC ADOONLY SKIP COPY PRior(passthru) ] /* does not allow extra options! */ + *disp in re "2: `varlist'" + *disp in re "i: `i'" + *disp in re "frload: `frload'" + *disp in re "display: `display'" + *disp in re "iterate: `iterate'" + + tempname mat mnip mnbrf + global HG_error=0 + +/* deal with adoonly */ + + global HG_noC = 0 + global HG_noC1 = 0 + global HG_noC2 = 0 + if "`adoonly'"=="" { + qui q born + if $S_1 < 16350 { + global HG_noC2 = 1 + if $S_1 < 15722 { + noi di + noi di in gr "You must have the Stata 8 executable updated on or after " _c + noi di in ye %d 15722 + noi di in gr "in order to use all internal routines" + global HG_noC1 = 1 + if $S_1 < 15274 { + global HG_noC = 1 + noi di in gr "Option adoonly assumed." + noi di + } + } + } + } + + if "`adoonly'"!="" { + global HG_noC = 1 /* link and family */ + global HG_noC1 = 1 /* lnupdate */ + global HG_noC2 = 1 /* don't want to set HG_noC to 0 */ + } + + +/* deal with trace */ + + if "`trace'"!="" { local noi "noisily" } + +/* deal with dots */ + + global HG_dots = 0 + if "`dots'"!="" { + global HG_dots = 1 + } + +/* deal with init */ + + global HG_init=0 + if "`init'"~="" { + global HG_init=1 + } + +/* deal with if and in */ + marksample touse + + qui count if `touse' + if _result(1) <= 1 { + di in red "insufficient observations" + exit 2001 + } + + /* deal with varlist */ + tokenize `varlist' + local y "`1'" + + macro shift /* `*' is list of dependent variables */ + local indep "`*'" + + local num: word count `indep' /* number of independent variables */ + + markout `touse' `y' `indep' + +/* deal with Link and Family */ + global HG_lev1=0 + global HG_famil + global HG_linko + global HG_link + matrix M_olog=(0) + capture matrix drop M_oth + global HG_mlog=0 + global HG_nolog = 0 + global HG_lv + global HG_fv + global HG_smlog=0 + global HG_oth = 0 + local l: word count `family' + if `l'>1 { + `noi' qui disp "more than one family" + if "`fv'"==""{ + disp in re "need fv option" + exit 198 + } + else{ + confirm variable `fv' + global HG_fv `fv' + } + parse "`family'", parse(" ") + local n=1 + while "`1'"~=""{ + qui count if `fv'==`n' + if _result(1)==0{ + disp "family `1' not used" + } + fm "`1'" + if "$S_2"=="gauss"{ + if $HG_lev1==0{ + global HG_lev1=1 + } + else if $HG_lev1==2{ + global HG_lev1=3 + } + } + else if "$S_2"=="gamma"{ + if $HG_lev1==0{ + global HG_lev1=2 + } + else if $HG_lev1==1{ + global HG_lev1=3 + } + } + global HG_famil "$HG_famil $S_2" + local n = `n'+1 + mac shift + } + + } + + local k: word count `link' + local mll = 0 + if `k'>1{ + `noi' qui disp "more than one link" + if "`lv'"==""{ + disp in re "need lv option" + exit 198 + } + else{ + confirm variable `lv' + global HG_lv `lv' + } + parse "`link'", parse(" ") + local n=1 + while "`1'"~=""{ + qui count if $HG_lv==`n' + if _result(1)==0{ + disp "link `1' not used" + } + lnk "`1'" + if "$S_1"=="sprobit"|"$S_1"=="soprobit"{ + if $HG_lev1 == 2{ + global HG_lev1 = 3 + } + else{ + global HG_lev1 = 1 + } + } + if "$S_1"=="ll"{ + global HG_noC = $HG_noC2 + } +/* nominal */ + if "$S_1"=="mlogit"|"$S_1"=="smlogit"{ + if $HG_mlog>0{ + disp in re "can only have one mlogit link" + exit 198 + } + global HG_mlog=`n' + if "$S_1"=="smlogit"{ + if $HG_lev1 == 2{ + global HG_lev1 = 3 + } + else{ + global HG_lev1 = 1 + } + } + tempvar first + sort `touse' $HG_lv `y' + qui by `touse' $HG_lv `y': gen byte `first' = cond(_n==1,1,0) + mkmat `y' if `first' == 1 & `touse' & $HG_lv == `n', mat(M_respm) + if "$S_1"=="smlogit"{global HG_smlog=1} + } +/* ordinal */ + else if "$S_1"=="ologit"|"$S_1"=="oprobit"|"$S_1"=="ocll"|"$S_1"=="soprobit"{ + global HG_linko "$HG_linko $S_1" + if $HG_nolog>0{ + * disp "more than one ordinal response" + matrix M_olog = M_olog,`n' + } + else{ + capture matrix drop M_nresp + matrix M_olog[1,1] = `n' + tempvar first + sort `touse' $HG_lv `y' + qui by `touse' $HG_lv `y': gen byte `first' = cond(_n==1,1,0) + } + mkmat `y' if `first' == 1 & `touse' & $HG_lv == `n', mat(`mat') + local ll = rowsof(`mat') + * matrix list `mat' + * disp "adding `ll' to M_nresp" + matrix M_nresp = nullmat(M_nresp),`ll' + if `ll'>`mll'{ + local mll = `ll' + } + global HG_nolog = $HG_nolog + 1 + } +/* other */ + else { + global HG_link "$HG_link $S_1" + matrix M_oth = nullmat(M_oth),`n' + global HG_oth=1 + } + local n = `n'+1 + mac shift + } + if $HG_nolog>0{ + tempname junk + global HG_lvolo "`junk'" + qui gen byte $HG_lvolo = 0 + matrix M_resp = J(`mll',$HG_nolog,0) + local no = 1 + local totresp = 0 + while `no'<=$HG_nolog{ + local olog = M_olog[1,`no'] + qui replace $HG_lvolo = 1 if $HG_lv == `olog' + mkmat `y' if `first' == 1 & `touse' & $HG_lv == `olog', mat(`mat') + local ii = 1 + while `ii'<= M_nresp[1,`no']{ + * disp "M_resp[`ii',`no'] = mat[`ii',1]" + matrix M_resp[`ii',`no'] = `mat'[`ii',1] + local ii = `ii' + 1 + } + local totresp = `totresp' + M_nresp[1,`no'] + local no = `no' + 1 + } + } + if $HG_mlog>0{ + if $HG_nolog==0{ + tempname junk + global HG_lvolo "`junk'" + qui gen byte $HG_lvolo = 0 + } + qui replace $HG_lvolo = 1 if $HG_lv == $HG_mlog + } + } + else if `k'<=1&`l'<=1{ /* no more than one link and one family given */ + lnkfm "`link'" "`family'" + global HG_link = "$S_1" + global HG_famil = "$S_2" + if "$HG_link"=="ologit"|"$HG_link"=="oprobit"|"$HG_link"=="ocll"|"$HG_link"=="soprobit"{ + global HG_linko = "$HG_link" + global HG_nolog = 1 + matrix M_olog[1,1] = 1 + } + if "$HG_link"=="smlogit"|"$HG_link"=="mlogit"{global HG_mlog=1} + if "$HG_famil"=="gauss"{global HG_lev1=1} + if "$HG_famil"=="gamma"{global HG_lev1=2} + if "$HG_link"=="sprobit"{global HG_lev1=1} + if "$HG_link"=="soprobit"{global HG_lev1=1} + if "$HG_link"=="smlogit"{global HG_lev1=1} + if "$HG_link"=="ll"{global HG_noC = $HG_noC2 } + if $HG_mlog==0&$HG_nolog==0{global HG_oth = 1} + } + else if `k'==1{ + lnk "`lnk'" + global HG_link = "$S_1" + if "$HG_link"=="ologit"|"$HG_link"=="oprobit"|"$HG_link"=="ocll"|"$HG_link"=="soprobit"{ + global HG_nolog = 1 + matrix M_olog[1,1] = 1 + global HG_linko = "$HG_link" + } + if "$HG_link"=="smlogit"|"$HG_link"=="mlogit"{global HG_mlog=1} + if "$HG_link"=="sprobit"{global HG_lev1=1} + if "$HG_link"=="smlogit"{global HG_lev1=1} + if "$HG_link"=="soprobit"{global HG_lev1=1} + if "$HG_link"=="ll"{global HG_noC = $HG_noC2 } + if $HG_mlog==0&$HG_nolog==0{global HG_oth = 1} + } + if `l'==1{ + fm "`family'" + global HG_famil = "$S_2" + if "$HG_famil"=="gauss"{global HG_lev1=1} + if "$HG_famil"=="gamma"{global HG_lev1=2} + if $HG_mlog==0&$HG_nolog==0{global HG_oth = 1} + } + if ((`k'>1&`l'==0)|(`l'>1&`k'==0))&$HG_oth==1{ + disp in re /* + */ "both link() and fam() required for multiple links or families" + exit 198 + } + + markout `touse' $HG_lv $HG_fv + + +/* deal with noCORrel */ + global HG_cor = 1 + if "`correl'"~=""{ + global HG_cor = 0 + } + +/* deal with DEnom */ + global HG_denom + local f=0 + parse "$HG_famil", parse(" ") + while "`1'"~=""&`f'==0{ + if "`1'"=="binom"{ + local f=1 + } + mac shift + } + if `f'==1{ + if "`denom'"~=""{ + confirm variable `denom' + global HG_denom "`denom'" + } + else{ + tempvar den + quietly gen byte `den'=1 + global HG_denom "`den'" + } + } + else{ + if "`denom'"~=""{ + disp in blue/* + */"option denom(`denom') given but binomial family not used" + } + } + + markout `touse' `denom' + +/* deal with offset */ + global HG_off + if "`offset'"~=""{ + global HG_off "`offset'" + local offset "offset(`offset')" + } + + markout `touse' $HG_off + +/* deal with ip */ + global HG_gauss = 1 + global HG_free = 0 + global HG_cip = 1 + global HG_mult = 0 + if "`ip'"~=""{ + if "`ip'"=="g"{ + global HG_gauss = 1 + } + else if "`ip'"=="l"{ + global HG_gauss = 0 + } + else if "`ip'"=="f"{ + global HG_free = 1 + } + else if "`ip'"=="m"{ + global HG_mult = 1 + global HG_gauss = 0 + } + else if "`ip'"=="fn"{ + global HG_free = 1 + global HG_cip = 0 + } + else { + disp in re "ip option `ip' not valid" + exit 198 + } + } + + global HG_lzpr lzprobg + global HG_zip zipg + + * disp in re "HG_mult = " $HG_mult + if $HG_mult{ + global HG_lzpr lzprobm + } + else if $HG_free{ + global HG_lzpr lzprobf + global HG_zip zipf + } + + +/* deal with expanded */ + global HG_ind + global HG_exp = 0 + global HG_expf = 0 + if "`expanded'"~=""{ + global HG_exp = 1 + if $HG_mlog==0{ + disp in re "expanded option only valid with mlogit link" + exit 198 + } + local k: word count `expanded' + if `k'~=3{ + disp in re "expanded option must have three arguments" + } + local exp: word 1 of `expanded' + confirm variable `exp' + global HG_mlg `exp' + local k: word 2 of `expanded' + * 11/11/06 + confirm variable `k' + global HG_ind `k' + local k: word 3 of `expanded' + if "`k'"=="o"{ + global HG_expf=1 + } + else{ + if "$HG_link"~="mlogit"&"$HG_link"~="smlogit"{ + disp in re "must use o in expanded option when combining mlogit with other links" + exit 198 + } + } + * 11/11/06 + markout `touse' $HG_mlg $HG_ind + } + else{ + if $HG_mlog>0&"$HG_link"~="mlogit"&"$HG_link"~="smlogit"{ + disp in re "must use expanded option when combining mlogit with other links" + exit 198 + } + tempvar ind + gen byte `ind' = 1 + global HG_ind `ind' + global HG_exp = 0 + } + + +/* deal with composite */ + global HG_comp = 0 + global HG_coall + if "`composite'"~=""{ + local k: word count `composite' + global HG_comp = `k' - 2 + local k: word 1 of `composite' + global HG_mlg `k' + local k: word 2 of `composite' + global HG_ind `k' + local kk = 1 + while `kk'<= $HG_comp { + local jj = `kk' + 2 + local k: word `jj' of `composite' + global HG_co`kk' `k' + global HG_coall $HG_coall `k' + local kk = `kk' + 1 + } + global HG_noC = $HG_noC2 /* use ado-code for link if not latest Stata 8 */ + } + + + +/* deal with I (turn list around)*/ + if ("`i'"==""){ + disp in red "i() required" + global HG_error=1 + exit 198 + + } + + local tplv: word count `i' + global HG_tplv = `tplv'+1 + global HG_clus + local k = `tplv' + while `k'>=1{ + local clus: word `k' of `i' + confirm numeric variable `clus' + markout `touse' `clus', strok + local k=`k'-1 + global HG_clus "$HG_clus `clus'" + } + + + if "`expanded'"==""&"`composite'"==""{ + tempvar id + gen long `id'=_n + global HG_clus "$HG_clus `id'" + } + else{ + global HG_clus "$HG_clus $HG_mlg" + } + +/* deal with weightf */ + tempvar wt + quietly gen double `wt'=1 + local j = 1 + if "`weightf'"==""{ + while (`j'<=$HG_tplv){ + tempname junk + global HG_wt`j' "`junk'" + gen double ${HG_wt`j'}=1 + local j = `j' + 1 + } + global HG_weigh + } + else{ + global HG_weigh "`weightf'" + local wtvars + local found = 0 + while (`j'<=$HG_tplv){ + capture confirm variable `weightf'`j' /* frequency weight */ + if _rc ~= 0 { + tempname junk + global HG_wt`j' "`junk'" + gen double ${HG_wt`j'} = 1 /* can become non-integeger later */ + } + else{ + tempname junk + global HG_wt`j' "`junk'" + gen double ${HG_wt`j'}=`weightf'`j' + local wtvars `wtvars' `weightf'`j' + quietly replace `wt'=`wt'*${HG_wt`j'} + local found = `found' + 1 + } + local j = `j' + 1 + } + if `found' == 0 { + disp in red "weight variables `weightf' not found" + global HG_error=1 + exit 111 + } + markout `touse' `wtvars' + } + +/* deal with probability weights */ + local pw + local wtvars + if "`pweight'"~=""{ + local robust robust + tempname wtp + local pw pweight + global HG_pwt "`pweight'" + quietly gen double `wtp' = 1 + local j = 1 + local found = 0 + while (`j'<=$HG_tplv){ + capture confirm variable `pweight'`j' /* probability weight */ + if _rc == 0 { + quietly replace `wtp'=`wtp'*`pweight'`j' + local wtvars `wtvars' `pweight'`j' + local found = `found' + 1 + } + local j = `j' + 1 + } + if `found' == 0 { + disp in red "probability weight variables not found" + global HG_error=1 + exit 111 + } + markout `touse' `wtvars' + } + +/* deal with cluster */ + + if "`cluster'"~=""{ +* check that top-level cluster does not vary within cluster? + local k: word count $HG_clus + local top: word 1 of $HG_clus + qui sort `top' `cluster' + capture qui by `top' : assert `cluster'[1]==`cluster'[_N] + if _rc>0{ + disp in re "`cluster' varies within `top'" + exit 198 + } + markout `touse' `cluster' + local cluster cluster(`cluster') + } + +/* deal with categorical response variables */ + + if "$HG_link" == "mlogit"|"$HG_link" == "smlogit"{ + sort `touse' `y' + tempvar first + qui by `touse' `y': gen byte `first' = cond(_n==1,1,0) + mkmat `y' if `first' == 1 & `touse', mat(M_respm) + } + else if /* + */ "$HG_link" == "ologit"|"$HG_link" == "ocll"|"$HG_link" == "oprobit"|"$HG_link"=="soprobit"{ + sort `touse' `y' + tempvar first + qui by `touse' `y': gen byte `first' = cond(_n==1,1,0) + mkmat `y' if `first' == 1 & `touse', mat(M_resp) + local totresp = rowsof(M_resp) + matrix M_nresp = (`totresp') + } + +/* deal with base-category */ + + if `basecategory'~=999{ + if "$HG_link" ~= "mlogit"&"$HG_link" ~= "smlogit"{ + disp in red "basecategory ignored because response not nominal" + } + } + if $HG_mlog>0&$HG_expf==0{ + tempname bas + if `basecategory'==999{ + scalar `bas' = M_respm[1,1] + matrix `bas' = (`bas') + local basecat = M_respm[1,1] + * disp in re "`basecat'" + } + else{ + matrix `bas' = (`basecategory') + local basecat = `basecategory' + } + + local n = rowsof(M_respm) + local j = 1 + local found = 0 + while `j'<=`n'{ + local el = M_respm[`j',1] + if `el'==`basecat'{ + local found = 1 + } + else{ + matrix `bas' = `bas'\ `el' + } + local j = `j' + 1 + } + if `found' == 0 { + disp in re "basecategory = `basecat' not one of the categories" + exit 198 + } + matrix M_respm = `bas' + local el = M_respm[1,1] + local basecat basecat(`el') + } + + +/* deal with noCOns */ + + if "`constant'"~=""{ + if $HG_nolog>0{ + disp in re "noconstant option not allowed for ordinal links:" _n "This is the default because all thresholds estimated" + exit 198 + } + local cns + } + else{ + if $HG_cip == 0{ + disp in re "are you sure you need a constant with ip(fn) option?" + } + + local num=`num'+1 + local cns "_cons" + } + matrix M_nffc=(`num') + + + if `num'>0 { + global HG_fixe (`y': `y'=`indep', `constant') + local dep + } + else{ + global HG_fixe + local dep "`y'=" + } + +/* fixed effects matrix */ + + global HG_ethr = 0 + + if `num' > 0 { + matrix M_initf=J(1,`num',0) + matrix coleq M_initf=`y' + matrix colnames M_initf=`indep' `cns' + } + else{ + cap matrix drop M_initf + } + + if $HG_nolog==0{ + if "`thresh'"~=""{ disp in re "thresh option ignored" } + if "`ethresh'"~=""{ disp in re "ethresh option ignored" } + } + else if $HG_nolog>0{ + + if "`ethresh'"~=""{ + if "`thresh'"~=""{ + disp in re "cannot use both ethresh() and thresh() options! + exit 198 + } + global HG_ethr = 1 + local thresh `ethresh' + + } + if "`thresh'"~=""{ + local k: word count `thresh' + if `k'~=$HG_nolog{ + disp in re "number of threshold equations should be " $HG_nolog + exit 198 + } + + } + global HG_fixe + local n = rowsof(M_resp) + matrix M_nffc[1,1] = `num'-1 + if `num'>1{ + global HG_fixe (`y': `y'=`indep', nocons) + matrix `mat' = M_initf[1,1..`num'-1] + local ce: coleq(`mat') + local cn `indep' + matrix M_initf=J(1,`num'-1,0) + } + else{ + capture matrix drop M_initf + } + local el = M_nffc[1,1] + local ii = 1 + local nxt = M_nffc[1,1] + 1 + local ntr = 1 + local vars + local rhs "_cons" + while `ii'<= $HG_nolog{ + local j = 1 + if "`thresh'"~=""{ + local eqnam: word `ii' of `thresh' + eq ? "`eqnam'" + local vars "$S_1" + markout `touse' `vars' + local ntr: word count `vars' + local ntr = `ntr' + 1 + local rhs "`vars' _cons" + } + while `j'< M_nresp[1,`ii']{ + * disp "`ii'th ordinal response, level `j'" + local el = `el' + `ntr' + matrix M_nffc = M_nffc, `el' + matrix `mat'=J(1,`ntr',0) + matrix coleq `mat' = _cut`ii'`j' + local cee: coleq(`mat') + local ce `ce' `cee' + local cn `cn' `rhs' + global HG_fixe $HG_fixe (_cut`ii'`j':`vars') + if `j' == 1 & `ii'==1 & `num' == 1{ + global HG_fixe (_cut`ii'`j':`y'= `vars') + } + local j = `j' + 1 + if $HG_ethr{ + matrix `mat'[1,`ntr'] = - 0.5 + } + else{ + matrix `mat'[1,`ntr'] = `j' - (M_nresp[1,`ii']+1)/2 + } + matrix M_initf = nullmat(M_initf), `mat' + local nxt = `nxt' + 1 + } + local ii = `ii' + 1 + } + matrix colnames M_initf=`cn' + matrix coleq M_initf=`ce' + * matrix list M_initf + } + + if ($HG_mlog>0)&$HG_expf==0{ + global HG_fixe + local n = rowsof(M_respm) + matrix `bas'=M_initf + matrix drop M_initf + matrix drop M_nffc + local j = 2 + while `j'<=`n'{ + local el = M_respm[`j',1] + matrix coleq `bas' = c`el' + matrix M_initf = nullmat(M_initf), `bas' + matrix M_nffc = nullmat(M_nffc), (`j'-1)*`num' + if `j' == 2{ + global HG_fixe $HG_fixe ( c`el':`y' = `indep', `constant') + } + else{ + global HG_fixe $HG_fixe ( c`el':`indep', `constant') + } + local j = `j' + 1 + } + local num = `num'*(`n' - 1) + } + + * matrix list M_nffc + * matrix list M_initf + + +/* display information */ + quietly `noi'{ + disp " " + disp in gr "General model information" + *disp in smcl in gr "{hline 78}" _n + di in gr _dup(78) "-" _n + disp in gr "dependent variable:" in ye " `y'" + if $HG_oth{ + disp in gr "family:" in ye " $HG_famil" + disp in gr "link:" in ye " $HG_link" + } + if "$HG_linko"~=""{ + disp in gr "ordinal responses:" in ye " $HG_linko" + } + if $HG_mlog>0{ + if $HG_smlog==1 { + disp in gr "nominal responses:" in ye " smlogit" + } + else{ + disp in gr "nominal responses:" in ye " mlogit" + } + } + if "$HG_denom"~=""{ + if "`denom'"~=""{ + disp in gr "denominator:" in ye " `denom'" + } + else{ + disp in gr "denominator:" in ye " 1" + } + } + if "`offset'"~=""{ + disp in gr "offset:" in ye " $HG_off" + } + local m = colsof(M_nffc) + if `m'==1&M_nffc[1,1]>0{ + local cuts: colnames(M_initf) + disp in gr "equation for fixed effects " in ye " `cuts'" + } + else if `m'==1{ + disp in gr "equation for fixed effects " in ye " none" + } + else{ + disp in gr "equations for fixed effects" + local j = 1 + local nxt = 1 + local prev = 0 + while `j'<=`m'{ + local n = M_nffc[1,`j'] - `prev' + if `n'>0{ + local prev = M_nffc[1,`j'] + matrix `mat' = M_initf[1,`nxt'..`nxt'+`n'-1] + local nxt = `nxt' + `n' + local ce: coleq(`mat') + local ce: word 1 of `ce' + local cn: colnames(`mat') + disp in gr " `ce': " in ye " `cn'" + } + local j = `j' + 1 + } + disp " " + } + } /* end qui `noi' */ + + +/* deal with inter */ + + global HG_inter = 0 + if "`inter'"~=""{ + global HG_inter=1 + local j: word count `inter' + if `j'~=2{ + disp in red "inter should have two arguments" + exit 198 + } + local j: word 1 of `inter' + capture confirm number `j' + if _rc>0{ + disp in red "arguments of inter must be numbers" + exit 198 + } + global HG_l = `j' + local j: word 2 of `inter' + capture confirm number `j' + if _rc>0{ + disp in red "arguments of inter must be numbers" + exit 198 + } + global HG_r = `j' + } + +/* initialise macros */ + quietly `noi' initmacs "`nrf'" "`nip'" "`eqs'" "`geqs'" "`peqs'" "`s'" "`nats'" "`bmatrix'" "`touse'" "`dep'" "`frload'" + qui count if `touse' + if _result(1) <= 1 { + di in red "insufficient observations" + exit 2001 + } + +/* deal with noESt */ + if "`est'"~=""{ + exit 0 + } +/* only use observations satisfying if and in and having nonmissing values */ + preserve + quietly keep if `touse' + +/* work out number of units at each level */ + + qui summ `wt' if `touse', meanonly + local lobs = r(sum) + tempvar cw f + qui gen double `cw' = `wt' + qui gen byte `f' = 1 + matrix M_nu=J(1,$HG_tplv,0) + matrix M_nu[1,1]=`lobs' + local sortlst $HG_clus + local j = 1 + local k = $HG_tplv + quietly `noi' disp in gr "number of level 1 units = " in ye `lobs' + while `j'<$HG_tplv{ + *disp "sort `sortlst'" + sort `sortlst' + tokenize "`sortlst'" + local `k' " " + local sortlst "`*'" + *disp "replace cw = cw/wt`j'" + qui replace `cw' = `cw'/${HG_wt`j'} + *disp "by `sortlst': replace f=_n==1" + qui by `sortlst': replace `f' = _n==1 + qui summ `cw' if `f' ==1, meanonly + local lobs = r(sum) + quietly `noi' disp in gr "number of level " `j'+1 " units = " in ye `lobs' + matrix M_nu[1,`j'+1] = `lobs' + local j = `j' + 1 + local k = `k' - 1 + } + +/* use pweights */ + + if "`pw'"~=""{ + local j = 1 + while (`j'<=$HG_tplv){ + capture confirm variable `pweight'`j' /* probability weight */ + if _rc == 0 { + quietly replace ${HG_wt`j'}=${HG_wt`j'}*`pweight'`j' + } + local j = `j' + 1 + } + } + +/* check if weights are integer */ + + qui cap summ `y' if `touse' [fweight=`wt'], meanonly + if _rc>0 { + global HG_obs + local ftype pweight + disp in re "weights are non-integer" + } + else { + local lobs = M_nu[1,1] + global HG_obs obs(`lobs') + local ftype fweight + } + if "`pweight'"~=""{ + quietly replace `wt' = `wt'*`wtp' + local ftype pweight + + } + + +/* deal with from */ + if "`from'"~=""{ + capture qui matrix list `from' /* do not comment out this line! */ + local rc=_rc + if `rc'>1{ + disp in red "`from' not a matrix" + exit 111 + } + tempname amat + matrix `amat' = `from' + local from "`amat'" + } + +/* deal with eval */ + if "`eval'"~=""{ + if "`from'"==""{ + disp in re "eval not valid without from option" + exit 198 + } + } + +/* deal with constraints (and from long) */ + + global HG_const = 0 + if "`constra'"~=""{ + global HG_const = 1 + if $HG_init==0{ + tempname b V + matrix `b' = nullmat(M_initf), nullmat(M_initr) + * noi matrix list `b' + if "`from'"~=""& "`long'"~=""{ + local nb = colsof(`b') + local nf = colsof("`from'") + * disp "nb = " `nb' + * disp "nf = " `nf' + if "`gateaux'"~=""{ + local tprf=M_nrfc[2,$HG_tplv]-M_nrfc[2,$HG_tplv-1] + local nnf = `nf' + `tprf' + 1 + if `nnf'~=`nb'{ + disp in re "from matrix has `nf' columns and should have " `nb'-`tprf'-1 + exit 198 + } + matrix `from' = `from',`b'[1,`nf'+1...] +** +* local lfix = `M_nffc'[1,colsof(`M_nffc')] +* matrix `from' = `from'[1,1..`lfix'],`b'[1,`nf'+1..`nf'+`tprf'+1],`from'[1,`lfix'+1...] +* noi matrix list `from' + } + else{ + capture ml model d0 gllam_ll $HG_fixe $HG_eqs, /* + */ noscvars waldtest(0) nopreserve missing collinear + + * disp "ml init from, `skip' `copy'" + ml init `from', `skip' `copy' + matrix `from' = ML_b + } + matrix `b' = `from' + * matrix list `b' + } + global HG_coln: colnames(`b') + global HG_cole: coleq(`b') + * matrix list `b' + matrix `V' = `b''*`b' + estimates post `b' `V' + matrix `b' = e(b) + matrix makeCns `constra' + qui `noi' disp in gr "Constraints:" + qui `noi' matrix dispCns + qui `noi' disp " " + matcproc M_T M_a M_C + matrix M_inshrt = `b'*M_T + local n = colsof(M_inshrt) + qui `noi' disp "estimating `n' parameters" + local i = 1 + local lst "`y'" + gen byte __0066 = 1 + while `i'< `n'{ + local lst `lst' "eq`i'" + local i = `i' + 1 + } + global HG_eqs + matrix coleq M_inshrt = `lst' + matrix colnames M_inshrt = __0066 + + *matrix list M_inshrt + *matrix `b' = M_inshrt*M_T' + M_a + *matrix list `b' + if "`gateaux'"~=""{ + local nf = `nf' - (`nb' - `n') + matrix `from' = M_inshrt[1,1..`nf'] + } + else if "`from'"~=""&"`long'"~=""{ + matrix `from' = M_inshrt + } + } + } + + if "`from'"~=""{ + local from "from(`from')" + } + +/* deal with prior */ + + global HP_prior = 0 + + if "`prior'"!=""{ + if "`noi'"!=""{ local loud "loud" } + *disp in re "prior loud is `prior' `loud'" + init_prior, `prior' `loud' + global HP_sprd = 0 + } + + * disp in re "HP_prior: " $HP_prior + +/* deal with adapt */ + global HG_adapt=0 + if "`adapt'"~=""{ + if $HG_free==1|($HG_gauss==0&$HG_mult==0){ + disp in re "adapt can only be used with ip(g) or ip(m) option" + exit 198 + } + global HG_adapt = 1 + } + + /* Nothing to estimate if init option and no fixed effects or level-1 variance */ + if $HG_init==1&M_nffc[1,$HG_tpff]==0&$HG_lev1==0{ + disp in re "Nothing to estimate" + exit 498 + } + + local fit = 0 + if (M_nffc[1,$HG_tpff]>0|$HG_lev1>0)&$HG_init==0&"`from'"==""&$HG_comp==0{ +/* initial values for fixed effects using Stata's commands */ + local lnk $HG_link + if "$HG_link"=="recip"{ + local lnk pow -1 + } + qui `noi' disp " " + qui `noi' disp in gr "Initial values for fixed effects" + if $HG_const&$HG_init==0 { + qui `noi' disp in gr "(Not applying constraints at this point)" + } + qui `noi' disp " " + if ("$HG_famil"=="gauss")&("$HG_link"=="ident")& "`s'"==""{ + tempvar yn + if "`offset'"~=""{ + quietly gen double `yn' = `y' - $HG_off + } + else{ + gen `yn' = `y' + } + quietly `noi' reg `yn' `indep' [`ftype'=`wt'], `constant' + matrix M_initr[1,1]=ln(_result(9)) + local fit = 1 + qui drop `yn' + } + else if ($HG_nolog+$HG_oth+$HG_mlog==1)&("$HG_famil"=="binom"|$HG_nolog==1|/* + */ $HG_mlog==1)&$HG_exp==0{ + local fit = 1 + local mnd = 1 + if "$HG_denom"~=""{ + qui summ $HG_denom, meanonly + local mnd = r(mean) + } + if `mnd'>1 { + if $HG_mlog>0 { + disp in re "can't have denominator > 1 for mlogit" + exit 198 + } + if ($HG_nolog>0) { + disp in re "can't have denominator > 1 for ordinal response" + exit 198 + } + qui `noi' glm `y' `indep' [`ftype'=`wt'], link(`lnk') /* + */ fam(binom `denom') `constant' `offset' `log' + } + else{ + if "$HG_link"=="logit"{ + qui `noi' logit `y' `indep' [`ftype'=`wt'], `constant' `offset' `log' + } + else if "$HG_link"=="probit"{ + qui `noi' probit `y' `indep' [`ftype'=`wt'], `constant' `offset' `log' + } + else if "$HG_link"=="cll"{ + qui `noi' cloglog `y' `indep' [`ftype'=`wt'], `constant' `offset' `log' + } + else if "$HG_link"=="ll"{ + tempvar yn + qui gen `yn' = 1-`y' + qui `noi' cloglog `yn' `indep' [`ftype'=`wt'], `constant' `offset' `log' + } + else if $HG_mlog==1{ + qui `noi' mlogit `y' `indep' [`ftype'=`wt'] if $HG_ind==1, `constant' `basecat' `log' + } + else if "$HG_linko"=="ologit"&"`thresh'"==""{ + qui `noi' ologit `y' `indep' [`ftype'=`wt'], `offset' `log' + } + else if "$HG_linko"=="oprobit"&"`thresh'"==""{ + qui `noi' oprobit `y' `indep' [`ftype'=`wt'], `offset' `log' + } + else if "$HG_linko"=="ocll"|"$HG_link"=="sprobit"|"$HG_linko"=="soprobit"|$HG_nolog>1|"`thresh'"~=""{ + local fit = 0 + } + else{ + qui `noi' glm `y' `indep' [`ftype'=`wt'], link(`lnk') /* + */ fam(binom `denom') `constant' `offset' `log' + local fit = 1 + } + + } + } + else if ("$HG_famil"=="poiss")&("$HG_link"=="log"){ + qui `noi' poisson `y' `indep' [`ftype'=`wt'], `constant' `offset' `log' + local fit = 1 + } + else if ("$HG_famil"=="gamma"& M_nbrf[1,1]==1){ + qui `noi' glm `y' `indep' [`ftype'=`wt'], link(`lnk')/* + */ fam(gamma) `constant' `offset' `log' + matrix M_initr[1,1]= -ln($S_E_dc) + local fit = 1 + } + } + if `fit' == 0 &("`from'"==""|$HG_init==1)& (M_nffc[1,$HG_tpff]>0|$HG_lev1>0) { +/* fit level 1 model using gllamm */ + /* preserve macros */ + qui `noi' disp in green "(using gllamm for inital values)" + local eqs "$HG_eqs" + local tprf = $HG_tprf + local tplv = $HG_tplv + local tpi = $HG_tpi + local const = $HG_const + local link $HG_link + local linko $HG_linko + local lev1 = $HG_lev1 + local ngeqs = $HG_ngeqs + local sprior = $HP_prior + tempvar keep + quietly gen int `keep' = $HG_wt1 + quietly replace $HG_wt1 = `wt' + matrix `mnip' = M_nip + matrix `mnbrf' = M_nbrf + local adapt = $HG_adapt + + + /* change global macros */ + local frm + if $HG_init==0{ + global HG_const = 0 + } + global HG_ngeqs = 0 + + if $HG_init==0{ + /* scale of probit usually not identified without random effects */ + global HG_link + local k: word count `link' + local kk = 1 + while `kk' <= `k'{ + local ll: word `kk' of `link' + + if "`ll'" == "sprobit"{ + global HG_link "$HG_link probit" + } + else{ + global HG_link $HG_link `ll' + } + local kk = `kk' + 1 + } + *disp in re "links were `link' and are $HG_link" + + + global HG_linko + local k: word count `linko' + local kk = 1 + while `kk' <= `k'{ + local ll: word `kk' of `linko' + + if "`ll'" == "soprobit"{ + global HG_linko "$HG_linko oprobit" + } + else{ + global HG_linko "$HG_linko `ll'" + } + local kk = `kk' + 1 + } + *disp in re "ordinal links were `linko' and are $HG_linko" + + if $HG_lev1>0{ /* check if any of the families is the normal or gamma*/ + local found = 0 + local k: word count $HG_famil + local kk = 1 + while `kk'<= `k'{ + local ll: word `kk' of $HG_famil + if "`ll'"=="gauss"| "`ll'"=="gamma"{ + local found = 1 + } + local kk = `kk' + 1 + } + if `found'==0{ + global HG_lev1 = 0 + matrix M_nbrf = (0) + } + } + } + + matrix M_nip=(1,1\1,1) + if $HG_lev1>0{ + global HG_eqs $HG_s1 + global HG_tprf=1 + global HG_tpi=1 + global HP_prior=0 + } + else{ + global HG_eqs + global HG_tprf=0 + global HG_tpi=1 + } + if "`from'"~=""{ + local frm `from' + } + + global HG_adapt = 0 + + /* fit model for initial values */ + global HG_tplv=1 /* Level 1 model */ + local opt + if $HG_init{ /* apply constraints if init option is used */ + if $HG_const==1{ + tempname b V + matrix `b' = M_initf, M_initr + + capture ml model d0 gllam_ll $HG_fixe $HG_eqs, /* + */ noscvars waldtest(0) nopreserve missing collinear + + *matrix list `b' + ml init `b', skip /* uses parameters needed for model above */ + matrix `b' = ML_b /* unconstrained param., no random effects */ + + global HG_coln: colnames(`b') + global HG_cole: coleq(`b') + + if "`from'"~=""& "`long'"~=""{ /* assumes copy option */ + local nb = colsof(`b') + local nf = colsof(`amat') + if `nb'~=`nf'{ + disp in re "from matrix must be dimension " `nb' + exit 189 + } + disp in gr "(copy option assumed for from matrix)" + matrix `b' = `amat' + matrix coleq `b' = $HG_cole + matrix coln `b' = $HG_coln + } + + matrix `V' = `b''*`b' + estimates post `b' `V' + matrix `b' = e(b) + matrix makeCns `constra' + qui `noi' disp in gr "Constraints:" + qui `noi' matrix dispCns + qui `noi' disp " " + matcproc M_T M_a M_C + matrix M_inshrt = `b'*M_T /* constrained parameters, no r. effects */ + local n = colsof(M_inshrt) + qui `noi' disp "estimating `n' parameters" + if "`from'"~=""&"`long'"==""{ + local nf = colsof(`amat') + if `n'~=`nf'{ + disp in re "from matrix must be dimension " `n' + exit 189 + } + matrix M_inshrt = `amat' + } + local i = 1 + local lst "`y'" + gen byte __0066 = 1 + while `i'< `n'{ + local lst `lst' "eq`i'" + local i = `i' + 1 + } + global HG_eqs + matrix coleq M_inshrt = `lst' + matrix colnames M_inshrt = __0066 + + local frm "from(M_inshrt)" + + matrix coleq M_inshrt = `lst' + matrix colnames M_inshrt = __0066 + local n = colsof(M_inshrt) + global HG_fixe (`y': `y' =__0066, nocons) + local i = 1 + while `i'< `n'{ + global HG_fixe $HG_fixe (eq`i': __0066, nocons) + local i = `i' + 1 + } + } + local opt `options' + } + + * noi + qui `noi' hglm_ml `y', /* + */ $HG_obs `log' title("fixed effects model") /* + */ `frm' `trace' skip `difficult' `opt' `copy' `iterate' `eval' + local fit = 1 + if $HG_init==0 { + quietly `noi' ml display, level(`level') nohead + } + + if $HG_init{ + if $HG_error==0{ + if "`eval'"~=""{ + local robust + local cluster + local pw + } + noi prepare, `robust' `cluster' `pw' `dots' `noi' + * disp in re "running delmacs" + delmacs + restore + estimates repost, esample(`touse') + estimate local cmd "gllamm" + estimate local predict "gllapred" + * disp in re "running replay" + noi Replay, level(`level') `eform' `allc' `robust' `cluster' `display' `eval' + exit 0 + } + } + + if $HG_lev1>0{ + local num=M_nbrf[1,1] + matrix `mat'=e(b) + if $HG_nats{ + matrix `mat'=`mat'[1,"s1:"] + } + else{ + matrix `mat'=`mat'[1,"lns1:"] + } + local i=1 + while `i'<=`num'{ + matrix M_initr[1,`i']=`mat'[1,`i'] + local i=`i'+1 + } + } + if $HG_init{ + delmacs + restore + estimates repost, esample(`touse') + estimate local cmd "gllamm" + estimate local predict "gllapred" + exit 0 + } + + /* restore global macros */ + global HG_tplv=`tplv' + global HG_eqs "`eqs'" + global HG_tprf=`tprf' + global HP_prior=`sprior' + global HG_tpi=`tpi' + global HG_link "`link'" + global HG_linko "`linko'" + global HG_ngeqs = `ngeqs' + quietly replace $HG_wt1=`keep' + matrix M_nip=`mnip' + matrix M_nbrf = `mnbrf' + global HG_const = `const' + global HG_lev1 = `lev1' + global HG_adapt = `adapt' + + } + if `fit'{ + /* put estimates in `b' */ + local cn: colnames(M_initf) + local ce: coleq(M_initf) + matrix M_initf=e(b) + capture matrix colnames M_initf = `cn' + capture matrix coleq M_initf = `ce' + local num=M_nffc[1,$HG_tpff] + if `num'>0 { + local nn=colsof(M_initf) + if `nn'<`num'{ + disp in re "variables have been dropped, can't continue" + exit 198 + } + matrix M_initf=M_initf[1,1..`num'] + * matrix list M_initf + } + if $HG_const==1{ + matrix `b' = nullmat(M_initf), nullmat(M_initr) + matrix M_inshrt = `b'*M_T + } + if $HG_error==1{ + exit + } + } +/* estimation */ + + *qui `noi' disp in smcl in gr "{hline 78}" _n + qui `noi' di in gr _dup(78) "-" _n + qui `noi' dis + qui `noi' dis "start running on $S_DATE at $S_TIME" + +* check this: + *local skip + if $HG_const==1{ + matrix coleq M_inshrt = `lst' + matrix colnames M_inshrt = __0066 + local n = colsof(M_inshrt) + global HG_fixe (`y': `y' =__0066, nocons) + local i = 1 + while `i'< `n'{ + global HG_fixe $HG_fixe (eq`i': __0066, nocons) + local i = `i' + 1 + } + } + + * disp "`trace' `options' " + * disp "$HG_obs `log' `from'" + * disp "`search' `lf0' `gateaux' `skip' `difficult' `eval' " + +/* means and sds for adapt */ + if $HG_adapt{ + local rf = 1 + while `rf'<=$HG_tprf{ + tempname junk + global HG_MU`rf' "`junk'" + tempname junk + global HG_SD`rf' "`junk'" + gen double ${HG_MU`rf'}=0 + gen double ${HG_SD`rf'}=1 + local rf2 = `rf' + 1 + while `rf2' < $HG_tprf { + tempname junk + global HG_C`rf2'`rf' "`junk'" + gen double ${HG_C`rf2'`rf'}=0 + local rf2 = `rf2' + 1 + } + local rf = `rf' + 1 + } + + } + + * noi capture noi + capture noi hglm_ml `y', `trace' `options' /* + */ $HG_obs `log' title("gllamm model") `from' `iterate'/* + */ `search' `lf0' `gateaux' `skip' `copy' `difficult' `eval' + if _rc>0{ global HG_error=1 } + + qui `noi' dis "finish running on $S_DATE at $S_TIME" + qui `noi' dis " " + if $HG_error==0{ + if "`eval'"~=""{ /* do not want to compute robust standard errors */ + local robust + local cluster + local pw + } + noi prepare, `robust' `cluster' `pw' `dots' `noi' + * disp "running delmacs" + delmacs + * disp "restore" + restore + estimates repost, esample(`touse') + estimate local cmd "gllamm" + estimate local predict "gllapred" + * disp "running replay" + noi Replay, level(`level') `eform' `allc' `robust' `cluster' `display' `eval' + } +end + +program define prepare +syntax [, ROBUST CLUSTER(varname) PWEIGHT DOTS NOISILY] +* disp "options are: `robust' `cluster' `pweight' `dots' `noisily'" + tempname b v X U + matrix `b' = e(b) + local n = colsof(`b') + matrix M_Vs = e(V) + capture matrix `v' = inv(M_Vs) + if _rc==0{ + matrix symeigen `X' `U' = `v' + global HG_cn = sqrt(`U'[1,1]/`U'[1,`n']) + } + else{ + global HG_cn = -1 + } + if $HG_const { + matrix M_Vs = M_T*M_Vs*M_T' + } + +/* deal with robust */ + + if "`robust'"~=""|"`cluster'"~=""|"`pweight'"~=""{ + if "`cluster'"~=""{ + global HG_rbcls "`cluster'" + *disp "HG_rbcls is $HG_rbcls" + local cluster cluster(`cluster') + } + * disp "calling gllarob" + qui `noisily' gllarob, first macs `cluster' `dots' + } + * disp "HG_const = " $HG_const + * disp "running remcor" + + qui remcor `b' + + if $HG_const { + * disp "running procstr" + qui procstr + } +end + +program define hglm_ml + version 6.0 + syntax varlist(min=1)[, TITLE(passthru) LF0(numlist) noLOg TRace /* + */ OBS(passthru) FROM(string) SEarch(integer 0) Gateaux(numlist min=3 max=3) skip copy/* + */ noDIFficult EVal ITerate(numlist) *] + + *disp in re "running hglm_ml" + *disp in re "iterate: `iterate'" + + if "`log'"=="" { + local log "noisily" + } + else{ + local log + } + + if "`trace'"~="" { + local noi "noisily" + } + + parse "`varlist'", parse(" ") + local y "`1'" + + tempvar mysamp + tempname b f V M_init M_initr a lnf mlnf ip deriv + + local adapt = $HG_adapt + + if "`from'"~=""{ + matrix `M_init'=`from' + if "`eval'"~=""|`adapt'==1{ + + *noi disp "$HG_fixe $HG_eqs" + ml model d0 gllam_ll $HG_fixe $HG_eqs, /* + */ noscvars waldtest(0) nopreserve missing collinear + + *disp "ml init M_init, `skip' `copy'" + ml init `M_init', `skip' `copy' + matrix ML_g=ML_b + + if `adapt'==0{ + qui `noi' capture ml maximize, search(off) /* + */ iterate(0) novce nooutput nowarn /* `options' */ + disp in gr "log-likelihood = " in ye e(ll) + exit 0 + } + else{ + matrix `M_init' = ML_b + global ML_y1 `y' + noi gllam_ll 1 "`M_init'" "`lnf'" "junk" "junk" 1 + } + * matrix list `M_init' + } + if "`gateaux'"~=""&$HG_free==0{ + disp in re "option gateaux not allowed (ignored) for fixed integration points" + } + else if "`gateaux'"~=""&$HG_free==1{ + qui `noi' disp in gr "Gateaux derivative" + if $HG_tplv>2{ + disp "searching for additional point at level " $HG_tplv + } + local ll=$HG_tplv-1 + local tprf=M_nrfc[2,$HG_tplv]-M_nrfc[2,`ll'] /* number of locations */ + capture local mf = colsof(M_initf) + if _rc>0 {local mf = 0} + capture local mr = colsof(M_initr) + if _rc>0 {local mr = 0} + if $HG_const{ + local nreq = colsof(M_inshrt) - `tprf' - 1 + local cn: colnames(M_inshrt) + local ce: coleq(M_inshrt) + } + else{ + local nreq = `mf'+`mr'-`tprf'-1 + } + + if `nreq'~=colsof(`M_init'){ + disp in re "initial value vector should have length `nreq'" + matrix list `from' + global HG_error=1 + exit 198 + } + + *set trace on + local l = `mr' - `tprf'-1 /* length of previous M_initr */ + local locp = $HG_befB - `mf' + local beg = `locp'-`tprf' /* position of first new mass-point parameter */ + * matrix list M_initr + matrix `a' = M_initr[1,`beg'..`locp'] /* new mass-point parameters */ + * noi disp "new mass-point par" + * matrix list `a' + + if $HG_cip==0{ /* new point is one before last since last has no prob. par. */ + local locp = `locp' - `tprf' + } + + local befB = $HG_befB - `tprf' - 1 /* befB for previous parameter vector */ + global HG_befB + if `nreq' > `befB' { + matrix `M_init' = `M_init'[1,1..`befB'],`a',`M_init'[1,`befB'+1...] + } + else { + matrix `M_init' = `M_init'[1,1..`befB'],`a' + } + * matrix list `M_init' + local locp = `mf' + `locp' + *disp "position of new p-parameter = " `locp' + local nreq = `locp' - `tprf' -1 + *disp "position of first new location parameter = " `nreq'+1 + + if $HG_cip==0{ + * new point must be one before last since new probability tiny + local jl = 1 + while `jl'<=`tprf'{ + matrix `M_init'[1,`locp'+`jl']=`M_init'[1,`nreq'+`jl'] + local jl = `jl' + 1 + } + } + *matrix list `M_init' + + + tokenize "`gateaux'" + local min = `1' + local max = `2' + local num = `3' + local stp = (`max'-`min')/(`num'-1) + matrix `M_init'[1,`locp']=-6 /* mass of new masspoint */ + scalar `mlnf'=0 + matrix `ip'=M_ip + matrix `ip'[1,1]=1 + *recursive loop + matrix `ip'[1,`tprf']=1 + local k = `nreq' + `tprf' + matrix `M_init'[1,`k']=`min' + local nxtrf = `tprf'+1 + matrix `ip'[1,`nxtrf']=`num' + local rf = `tprf' + while `rf' <= `tprf'{ + *reset ip up to random effect `rf' + while (`rf'>1) { + local rf = `rf'-1 + matrix `ip'[1,`rf'] = 1 + local k = `nreq' + `rf' + matrix `M_init'[1,`k']=`min' + } + * update lowest digit + local rf = 1 + while `ip'[1,`rf'] <= `num'{ + local k = `nreq' + `rf' + matrix `M_init'[1,`k'] = `min' + (`ip'[1,`rf']-1)*`stp' + * matrix list `M_init' + global ML_y1 `y' + gllam_ll 0 "`M_init'" "`lnf'" + noi di in gr "." _c + * noisily disp "likelihood=" `lnf' + if (`lnf'>`mlnf'|`mlnf'==0)&`lnf'~=.{ + scalar `mlnf'=`lnf' + matrix M_initr=`M_init' + } + matrix `ip'[1,`rf'] = `ip'[1,`rf'] + 1 + } + matrix `ip'[1,`rf'] = `num' /* lowest digit has reached the top */ + while `ip'[1,`rf']==`num'&`rf'<=`tprf'{ + local rf = `rf' + 1 + } + * rf is first r.eff that is not complete or rf>nrf + if `rf'<=`tprf'{ + matrix `ip'[1,`rf'] = `ip'[1,`rf'] + 1 + local k = `nreq' + `rf' + matrix `M_init'[1,`k'] = `min' + (`ip'[1,`rf']-1)*`stp' + } + } + if "`lf0'"~=""{ + local junk: word 2 of `lf0' + * disp in re "junk = " `junk' + * disp in re "mlnf - lf0 is " `mlnf' " - " `junk' + scalar `deriv' = `mlnf'-`junk' + disp " " + disp in ye "maximum gateaux derivative is " `deriv' + * matrix list `M_initr' + if `deriv'<0.00001{ + disp in re "maximum gateaux derivative less than 0.00001" + global HG_error=1 + exit + } + } + else{ + disp in ye "no gateaux derivarives could be calculated without lf0() option" + matrix list `M_initr' + } + + matrix `M_init' = M_initr +* starting log odds for new location + matrix `M_init'[1,`locp']=-3 + if $HG_const{ + matrix colnames `M_init' = `cn' + matrix coleq `M_init' = `ce' + } + * matrix list `M_init' + } /* end if gateaux */ + } /* end if from */ + else{ /* no from() */ + if "`gateaux'"~=""{ + disp in red "gateaux can't be used without option from()" + exit 198 + } + if "`eval'"~=""{ + disp in red "eval option only allowed with from()" + exit 198 + } + capture matrix `M_init'=M_initf + if $HG_tprf|$HG_lev1>1{ + matrix `M_initr'=M_initr + local max=3 + local min=0 + scalar `mlnf' = 0 + local f1= M_nbrf[1,1]+1 + local l=colsof(M_initr) + local m=1 + if `search'>1{ + if $HG_const==1{ + disp in re "search option does not work yet with constraints" + exit 198 + } + else{ + qui `noi' disp in gr /* + */ "searching for initial values for random effects" + qui `noi' disp "likelihood:" + } + } + while `m'<=`search'{ /* begin search */ + * matrix list M_initr + matrix `a'=`M_init',M_initr + *matrix list `a' + global ML_y1 `y' + noisily gllam_ll 0 "`a'" "`lnf'" + + qui `noi' disp in ye %10.0g `lnf' " " _c + if mod(`m',6)==0 {qui `noi' disp } + + *qui `noi' disp "likelihood=" `lnf' + if (`lnf'>`mlnf'|`m'==1)&`lnf'~=. { + scalar `mlnf'=`lnf' + matrix `M_initr'=M_initr + } + local k=`f1' + while `k'<=`l'{ + matrix M_initr[1,`k']=`min' + (`max'-`min')*uniform() + local k=`k'+1 + } + local m = `m' + 1 + } /* end search */ + matrix `M_init' = nullmat(`M_init'),`M_initr' + } + if $HG_const{ + matrix `M_init' = M_inshrt + } + } + if "`difficult'"~=""{ + local difficu /* erase macro */ + } + else{ + local difficu "difficult" /* default */ + } + * disp "$HG_fixe $HG_eqs, init(`M_init',`skip') " + * disp "`lf0' `obs' `trace' `difficu' `options'" + *matrix list `M_init' + if "`lf0'"~="" { local lf0 "lf0(`lf0')" } + + * matrix list `M_init' + + if `adapt'{ + tempname pa1 + tempname pa2 + tempname ad1 + tempname ad2 ad0 + + * global HG_adapt=0 + global ML_y1 `y' + if "`from'"==""{ + noi gllam_ll 1 "`M_init'" "`lnf'" "junk" "junk" 1 + } + scalar `ad2' = `lnf' + + scalar `ad1' = 0 + local i = 2 + + qui `log' di in gr _n "Running adaptive quadrature" + qui `noi' di in gr _dup(78) "-" _n "Iteration 0 of adaptive quadrature:" + *qui `noi' di in smcl in gr "{hline 78}" _n "Iteration 0 of adaptive quadrature:" + qui `noi' di in gr "Initial parameters:" _n + qui `noi' mat list `M_init', noheader noblank format(%9.0g) + +/* first calculation of adaptive quadrature points ==> ad2 */ + + global HG_adapt=1 + qui `noi' disp in gr _n "Updated log likelihood:" + qui `noi' disp in ye %10.0g `ad2' " " _c + while abs((`ad1'-`ad2')/`ad2')>1e-8&`i'<120&`ad2'~=.{ + scalar `ad1' = `ad2' + noi gllam_ll 1 "`M_init'" "`ad2'" "junk" "junk" 1 + qui `noi' disp in ye %10.0g `ad2' " " _c + if mod(`i',6)==0 {qui `noi' disp } + local i = `i' + 1 + } + if `i'>=120{ + disp in re "Convergence not achieved: try with more quadrature points" + global HG_error=1 + exit + } + if `ad2'==.{ + disp in re "Log-likelihood cannot be computed" + global HG_error=1 + exit + } + + qui `noi' di in gr _n _col(52) "log likelihood = " in ye %10.0g /* + */ scalar(`ad2') + + if "`noi'"==""{ + qui `log' di in gr "Iteration 0: log likelihood = " in ye %10.0g /* + */ scalar(`ad2') + } + + if "`eval'"~=""{ + qui `noi' di in gr _dup(78) "-" + *qui `noi' di in smcl in gr "{hline 78}" + di in gr "log likelihood = " in ye %10.0g /* + */ scalar(`ad2') _n + + qui `noi' capture ml maximize, search(off) /* + */ iterate(0) novce nooutput nowarn /* `options' */ + + *delmacs + *exit 1 + exit 0 + } + + if "`iterate'"~=""{ + local iter=`iterate' + } + else{ + local iter=150 + } + + + global HG_adapt=1 + + +/* loop, update parameters then adaptive quadrature */ + + capture `log' ml model d0 gllam_ll $HG_fixe $HG_eqs, /* + */ noscvars `lf0' `obs' `title' /* + */ waldtest(0) nopreserve missing collinear + + if `iter'==0{ + qui `noi' di in gr _dup(78) "-" + disp in green "Adaptive quadrature has not converged" + + ml init `M_init', `skip' `copy' + + capture ml maximize, search(off) `difficu' /* + */ `trace' iterate(0) nolog /* + */ nooutput noclear /* `options' */ + exit 0 + } + + local it = 0 + scalar `ad0' = `ad2'*1.2 + scalar `pa2' = 0 + local only1 iteronly1 + local fst = 0 + + while abs((`ad0'-`ad2')/`ad0')>1e-6&`it'<`iter'{ + scalar `ad0' = `ad2' + local it = `it' + 1 + qui `noi' di in gr _dup(78) "-" _n "Iteration `it' of adaptive quadrature:" + *qui `noi' di in smcl in gr "{hline 78}" _n "Iteration `it' of adaptive quadrature:" + qui `noi' disp in gr "Updated parameters:" _n + +/* update parameters ==> pa2 */ + + ml init `M_init', `skip' `copy' + *ml report + + * noi capture noi + capture ml maximize, search(off) `difficu' /* + */ `trace' iterate(1) nolog /* + */ nooutput noclear `only1' hessian gradient /* `options' */ + * + + local rc = _rc + if `rc' == 198&`fst'==0{ + local only1 + *noi capture noi + capture ml maximize, search(off) `difficu' /* + */ `trace' iterate(1) nolog /* + */ nooutput noclear `only1' /* `options' technique(bfgs) */ + local rc = _rc + local fst = 1 + } + if `rc'>1 { + di in red "(error occurred in ML computation)" + di in red "(use trace option and check correctness " /* + */ "of initial model)" + global HG_error=1 + exit `rc' + } + + qui `noi' mat list $ML_b, noheader noblank format(%9.0g) + qui `noi' di /* blank line */ + + scalar `pa1' = `pa2' + scalar `pa2' = e(ll) + matrix `M_init'=e(b) + +/* update adaptive quadrature ==> ad2 */ + + local j = 2 + scalar `ad1' = `pa2' + + qui `noi' disp in gr "Updated log likelihood: " + qui `noi' disp in ye %10.0g `ad1' " " _c + + while (abs((`ad1'-`ad2')/`ad2')>1e-8)&`j'<120&`ad2'~=.{ + global ML_y1 `y' + scalar `ad1' = `ad2' + noi gllam_ll 1 "`M_init'" "`ad2'" "junk" "junk" 1 + qui `noi' disp in ye %10.0g `ad2' " " _c + if mod(`j',6)==0 { qui `noi' disp } + local j = `j' + 1 + } + if `ad2'==.{ + disp in re "Log-likelihood cannot be computed" + global HG_error=1 + exit + } + qui `noi' di in gr _n _col(52) "log likelihood = " in ye %10.0g /* + */ scalar(`ad2') + + if "`noi'"==""{ + qui `log' di in gr "Iteration " `it' ": log likelihood = " in ye %10.0g /* + */ scalar(`ad2') + } + + *qui `noi' disp in gr "log-likelihood is " in ye `ad2' in gre /* + */ " and was " in ye `ad0' in gre ", relative change: " /* + */ in ye abs((`ad2'-`ad0')/`ad0') + } + qui `noi' di in gr _dup(78) "-" _n + *qui `noi' di in smcl in gr "{hline 78}" _n + + *tempname v + *capture matrix `v'=e(V) + *capture matrix `v' = inv(`v') + *if _rc>0{ + if `it'==`iter'&((`ad0'-`ad2')/`ad0')>1e-6 { + disp in green "Adaptive quadrature did not converge in `iter' iterations" + exit 0 + } + qui `log' disp in gr _n _n "Adaptive quadrature has converged, running Newton-Raphson" _c + ml init `M_init', skip copy + capture `log' ml maximize, search(off) `difficu' /* + */ `trace' nooutput iterate(`iter') /* `options' */ + local rc = _rc + if `rc'>1 { + di in red "(error occurred in ML computation)" + di in red "(use trace option and check correctness " /* + */ "of initial model)" + global HG_error=1 + exit `rc' + } + *} + } + else{ /* not adaptive */ + if "`iterate'"~=""{ + local iter "iterate(`iterate')" + } + else{ + local iter + } + capture `log' ml model d0 gllam_ll $HG_fixe $HG_eqs, /* + */ maximize search(off) /* + */ init(`M_init', `skip' `copy') noscvars `lf0' `obs' `title' `trace' /* + */ waldtest(0) nopreserve missing `difficu' collinear `iter'/* `options' */ + * technique(bfgs) gtol(1e-4) + } + + local rc = _rc + if `rc'>1 { + di in red "(error occurred in ML computation)" + di in red "(use trace option and check correctness " /* + */ "of initial model)" + global HG_error=1 + exit `rc' + } + if `rc'==1 { + di in red /* + */ "(Maximization aborted)" + delmacs + global HG_error=1 + exit 1 + } + else if $HG_error==1{ + disp in red "some error has occurred" + exit + } +end + +program define lnkfm + version 6.0 + args link fam + + global S_1 /* link */ + global S_2 /* family */ + + + lnk "`1'" + fm "`2'" + + if "$S_1" == "" { + if "$S_2" == "gauss" { global S_1 "ident" } + if "$S_2" == "poiss" { global S_1 "log" } + if "$S_2" == "binom" { global S_1 "logit" } + if "$S_2" == "gamma" { global S_1 "recip" } + } + +/* + if ("$S_1"=="mlogit"|"$S_1"=="smlogit")&"$S_2"~="binom"{ + disp in red "mlogit link must be combined with binomial probability" + exit 198 + } +*/ + if ("$S_1"=="mlogit"|"$S_1"=="smlogit"|"$S_1"=="ologit"|"$S_1"=="oprobit"|"$S_1"=="soprobit"|"$S_1"=="ocll"){ + global S_2 + } +end + +program define fm + version 6.0 + args fam + local f = lower(trim("`fam'")) + local l = length("`f'") + + if "`f'" == substr("gaussian",1,max(`l',3)) { global S_2 "gauss" } + else if "`f'" == substr("normal",1,max(`l',3)) { global S_2 "gauss" } + else if "`f'" == substr("poisson",1,max(`l',3)) { global S_2 "poiss" } + else if "`f'" == substr("binomial",1,max(`l',3)) { global S_2 "binom" } + else if "`f'" == substr("gamma",1,max(`l',3)) { global S_2 "gamma" } + else if "`f'" != "" { + noi di in red "unknown family() `fam'" + exit 198 + } + + if "$S_2" == "" { + global S_2 "gauss" + } +end + +program define lnk + version 6.0 + args link + local f = lower(trim("`link'")) + local l = length("`f'") + + if "`f'" == substr("identity",1,max(`l',2)) { global S_1 "ident" } + else if "`f'" == substr("log",1,max(`l',3)) { global S_1 "log" } + else if "`f'" == substr("logit",1,max(`l',4)) { global S_1 "logit" } + else if "`f'" == substr("mlogit",1,max(`l',3)) { global S_1 "mlogit" } + else if "`f'" == substr("smlogit",1,max(`l',3)) { global S_1 "smlogit" } + else if "`f'" == substr("ologit",1,max(`l',3)) { global S_1 "ologit" } + else if "`f'" == substr("oprobit",1,max(`l',3)) { global S_1 "oprobit" } + else if "`f'" == substr("probit",1,max(`l',3)) { global S_1 "probit"} + else if "`f'" == substr("ocll",1,max(`l',3)) { global S_1 "ocll"} + else if "`f'" == substr("cll",1,max(`l',3)) { global S_1 "cll"} + else if "`f'" == substr("ll",1,max(`l',2)) { global S_1 "ll"} + else if "`f'" == substr("sprobit",1,max(`l',3)) { global S_1 "sprobit"} + else if "`f'" == substr("soprobit",1,max(`l',3)) { global S_1 "soprobit"} + else if "`f'"==substr("reciprocal",1,max(`l',3)) { global S_1 "recip" } + else if "`f'" != "" { + noi di in red "unknown link() `link'" + exit 198 + } +end + +program define delmacs, eclass + version 6.0 +/* deletes all global macros and matrices and store some results in e()*/ + tempname var + if "$HG_tplv"==""{ + * macros already gone + exit + } + local nrfold = M_nrfc[2,1] + local lev = 2 + while (`lev'<=$HG_tplv){ + local i2 = M_nrfc[2,`lev'] + local i1 = `nrfold'+1 + local i = `i1' + local nrfold = M_nrfc[2,`lev'] + local n = M_nrfc[1,`lev'] + local n = M_nip[2,`n'] + capture est matrix zps`n' M_zps`n' + while `i' <= `i2'{ + local n = M_nip[2,`i'] + capture est matrix zlc`n' M_zlc`n' + capture est matrix zps`n' M_zps`n' + local i = `i' + 1 + } + local lev = `lev' + 1 + } + + + if $HG_free==0&$HG_init==0{ + est matrix chol CHmat + } + if $HG_free{ + est matrix mnp M_np + } + est matrix nrfc M_nrfc + est matrix nffc M_nffc + est matrix nbrf M_nbrf + est matrix nu M_nu + capture est matrix Vs M_Vs + capture est matrix mresp M_resp + capture est matrix mrespm M_respm + capture est matrix frld M_frld + if $HG_ngeqs>0{ + est matrix mngeqs M_ngeqs + } + matrix drop M_ip + est matrix nip M_nip + capture est matrix mb M_b + matrix drop M_znow + capture matrix drop M_initf + capture matrix drop M_initr + capture matrix drop M_chol + capture est matrix mb M_b + est matrix olog M_olog + capture est matrix moth M_oth + if $HG_const == 1{ + capture drop __0066 + est matrix a M_a + * est matrix C M_C + est matrix T M_T + est local coln $HG_coln + est local cole $HG_cole + global HG_coln + global HG_cole + } + + /* globals defined in gllam_ll */ + local i=1 + while (`i'<=$HG_tpff){ + global HG_xb`i' + local i= `i'+1 + } + local i = 1 + while (`i'<=$HG_tprf){ + global HG_s`i' + local i= `i'+1 + } + local i = 1 + while (`i'<=$HG_tplv){ + global HG_wt`i' + local i = `i' + 1 + } + if $HG_adapt{ + macro drop HG_zuoff + macro drop HG_SD* + macro drop HG_MU* + macro drop HG_E* + macro drop HG_V* + macro drop HG_C* + } + + macro drop HG_zip + macro drop HG_lzpr + est local nats=$HG_nats + global HG_nats + est local noC=$HG_noC + global HG_noC + est local noC1=$HG_noC1 + global HG_noC1 + global HG_noC2 + est local adapt=$HG_adapt + global HG_adapt + est local const = $HG_const + global HG_const + global HG_fixe + est local inter = $HG_inter + global HG_inter + global HG_dots + est local ngeqs = $HG_ngeqs + global HG_ngeqs + est local nolog = $HG_nolog + if $HG_nolog>0{ + est local k_eform = 1 /* controls how many eqns are exponentiated */ + } + else{ + est local k_eform = $HG_tpff + } + global HG_nolog + est local ethr = $HG_ethr + global HG_ethr + est local mlog = $HG_mlog + global HG_mlog + est local smlog = $HG_smlog + global HG_smlog + global HG_lvolo + est local oth = $HG_oth + global HG_oth + est local lev1 = $HG_lev1 + global HG_lev1 + est local bmat = $HG_bmat + global HG_bmat + est local tplv = $HG_tplv + global HG_tplv + est local tprf = $HG_tprf + global HG_tprf + est local prior = $HP_prior + if $HP_prior == 1{ + local a_ll = `e(ll)' - $HP_res + est local a_ll = `a_ll' + est local lpr = $HP_res + global HP_res + + if $HP_invga==1{ + est local invga $HP_invga + est local shape $shape + est local rate $rate + global HP_invga + global shape + global rate + } + if $HP_invwi==1{ + est local invwi $HP_invwi + est local df $df + est matrix scale scale + global HP_invwi + global df + } + if $HP_foldt==1{ + est local foldt $HP_foldt + est local df $df + est local scale $scale + est local location $location + global HP_foldt + global df + global scale + global location + } + if $HP_logno==1{ + est local logno $HP_logno + est local meanlog $meanlong + est local sdlog $sdlog + global HP_logno + global meanlog + global sdlog + } + if $HP_gamma==1{ + est local gamma $HP_gamma + est local scale $HP_scale + est local var $HP_var + est local shape $HP_shape + global HP_gamma + global HP_scale + global HP_var + global HP_shape + } + if $HP_corre==1{ + est local corre $HP_corre + est local alpha $alpha + est local beta $beta + global HP_corre + global alpha + global beta + } + if $HP_boxco==1{ + est local boxdo $HP_boxco + est local scale $scale + est local lambda $lambda + global HP_boxco + global scale + global lambda + } + if $HP_spect==1{ + est local spect $HP_spect + est local alpha $alpha + est local beta $beta + global HP_spect + global alpha + global beta + } + if $HP_wisha==1{ + est local wisha $HP_wisha + est local df $df + est matrix scale scale + global HP_wisha + global df + } + + } + global HP_prior + est local tpi = $HG_tpi + global HG_tpi + est local tpff = $HG_tpff + global HG_tpff + est local clus "$HG_clus" + global HG_clus + est local weight "$HG_weigh" + global HG_weigh + est local pweight "$HG_pwt" + global HG_pwt + global which + global HG_gauss + est local free = $HG_free + global HG_free + est local mult = $HG_mult + global HG_mult + est local cip = $HG_cip + est local famil "$HG_famil" + global HG_famil + est local link "$HG_link" + global HG_link + est local linko "$HG_linko" + global HG_linko + capture est local exp $HG_exp + global HG_exp + capture est local expf $HG_expf + global HG_expf + est local lv "$HG_lv" + global HG_lv + est local fv "$HG_fv" + global HG_fv + global HG_nump + global HG_eqs + global HG_obs + est local offset "$HG_off" + global HG_off + est local denom "$HG_denom" + global HG_denom + est local cor = $HG_cor + global HG_cor + est local s1 "$HG_s1" + global HG_s1 + capture est local init $HG_init + global HG_init + capture est local ind "$HG_ind" + global HG_ind + capture est local comp $HG_comp + global HG_comp + capture est local coall "$HG_coall" + global HG_coall + capture est local cn = $HG_cn + global HG_cn + capture est local robclus "$HG_rbcls" + global HG_rbcls + global HG_befB + global HG_cip +end + +program define initmacs +version 6.0 +/* defines all global macros */ +args nrf nip eqs geqs peqs s nats bmatrix touse dep frload + +tempname mat + +disp " " +disp in gr "Random effects information for" in ye " $HG_tplv" in gr " level model" +*disp in smcl in gr "{hline 78}" _n +di in gr _dup(78) "-" _n + +/* deal with nrf */ + matrix M_nrfc=J(2,$HG_tplv,1) + if "`nrf'"==""|$HG_free|$HG_mult{ + local k=1 + while (`k'<=$HG_tplv){ + matrix M_nrfc[1,`k']=`k' + matrix M_nrfc[2,`k']=`k' + local k=`k'+1 + } + } + if "`nrf'"~=""{ + local greater = 0 + local k: word count `nrf' + if `k'~=$HG_tplv-1 { + if $HG_tplv==1{ + disp in red "option nrf is meaningless for 1-level model" + } + else{ + disp in red "option nrf() does not contain " $HG_tplv-1 " argument(s)" + } + exit 198 + } + parse "`nrf'", parse(" ") + local k=2 + while (`k'<=$HG_tplv){ + matrix M_nrfc[2,`k']=`1' + if `1'>1{ + local greater=1 + } + local k=`k'+1 + mac shift + } + /* make cumulative */ + local k=2 + while (`k'<=$HG_tplv){ + matrix M_nrfc[2,`k']=M_nrfc[2,`k'-1]+M_nrfc[2,`k'] + if $HG_free==0&$HG_mult==0{matrix M_nrfc[1,`k']=M_nrfc[2,`k']} + local k=`k'+1 + } + if `greater'>0{ + if "`eqs'"==""{ + disp in re "eqs() option required" + exit 198 + } + } + } + * matrix list M_nrfc + global HG_tprf=M_nrfc[2,$HG_tplv] /* number of random effects */ + global HG_tpi=M_nrfc[1,$HG_tplv] /* number of integration loops + 1 */ + if $HG_tplv==$HG_tprf{ + if $HG_cor==0{ + disp "option nocorrel ignored because no multiple r. effects per level" + } + } + + +/* deal with nip and set up zloc and zps */ + + if "`nip'"~=""{ + local k: word count `nip' + if `k'==1{ + if `nip' == 1{ + matrix M_nip=J(2,$HG_tprf,1) + if $HG_free { + if $HG_cip==1 { + global HG_init=1 + } + } + else{ + disp in re "(co)variances of latent variables will not be identified with nip(1)" + ghquad 1 + } + } + } + + if `k'>1 | $HG_tpi == 2 { + if `k'~=$HG_tpi-1{ + disp in red "option nip() has `k' arguments, need 1 or " $HG_tpi-1 + exit 198 + } + matrix M_nip=J(2,$HG_tprf,1) + local i=1 + while `i'<$HG_tpi{ + local k: word `i' of `nip' + local l = `i' + 1 + matrix M_nip[1,`l']= `k' + if $HG_mult{ + * disp in re "k = `k'" + local n = M_nrfc[2,`l'] - M_nrfc[2,`l'-1] + if `n'>1 { + mint `n' `k' + matrix M_nip[1,`l'] = $S_1 + } + else{ + local kk = (`k' + 1)/2 + if int(`kk')~=`kk'{ + disp in re "arguments in nip() option must be odd with ip(m)" + exit 198 + } + ghquad `kk' + matrix M_nip[1,`l']= `kk' + } + } + else if $HG_free==0{ + if $HG_gauss{ + ghquad `k' + } + else{ + lebesque `k' + } + } + local i = `i' + 1 + } /* end i */ + } + else{ /* one argument given for more than one loop */ + matrix M_nip=J(2,$HG_tprf,`nip') + matrix M_nip[1,1] = 1 + if $HG_mult{ + local l = 2 + while `l' <= $HG_tpi{ + local n = M_nrfc[2,`l'] - M_nrfc[2,`l'-1] + if `n'>1{ + mint `n' `nip' + matrix M_nip[1,`l'] = $S_1 + } + else{ + local kk = (`nip' + 1)/2 + if int(`kk')~=`kk'{ + disp in re "arguments in nip() option must be odd with ip(m)" + exit 198 + } + ghquad `kk' + matrix M_nip[1,`l']= `kk' + } + local l = `l' + 1 + } + } + else if $HG_free==0{ + if $HG_gauss{ + ghquad `nip' + } + else{ + lebesque `nip' + } + } + } + } + else{ /* no nip argument given */ + matrix M_nip=J(2,$HG_tprf,8) + matrix M_nip[1,1] = 1 + if $HG_mult{ + local l = 2 + while `l' <= $HG_tpi{ + local n = M_nrfc[2,`l'] - M_nrfc[2,`l'-1] + if `n'>1{ + sphern `n' + matrix M_nip[1,`l'] = $S_1 + } + else{ + matrix M_nip[1,`l'] = 8 + ghquad 8 + } + local l = `l' + 1 + } + } + else if $HG_free==0{ + if $HG_gauss{ + ghquad 8 + } + else{ + lebesque 8 + } + } + } + + local i = M_nrfc[2,1]+1 + while `i'<= $HG_tprf{ + if $HG_free{ + matrix M_nip[2,`i'] = `i' + } + else{ + matrix M_nip[2,`i'] = M_nip[1,`i'] + } + local i = `i' + 1 + } + + * noi matrix list M_nip + capture matrix drop M_initr + + *matrix M_zlc8 = J(1,8,1) + *matrix M_zps8 = J(1,8,ln(1/8)) + +/* deal with Eqs */ + matrix M_frld = J(1,$HG_tprf,0) + local depv `dep' + matrix M_nbrf=(0) + global HG_eqs + global HG_nats = 0 + local lns1 lns1 + local log log + if $HG_lev1>0{ + if "`nats'"~=""{ + global HG_nats = 1 + local lns1 s1 + local log + } + disp in gr "***level 1 equation:" + if "`s'"~=""{ + eq ? "`s'" + local vars "$S_1" + markout `touse' `vars' + global HG_eqs "$HG_eqs (`lns1': `depv' `vars',nocons)" + global HG_s1 "(`lns1': `depv' `vars',nocons)" + + } + else{ + local vars "_cons" + global HG_eqs "$HG_eqs (`lns1': `depv')" + global HG_s1 "(`lns1': `depv')" + } + local depv + disp " " + if $HG_lev1==1{disp in gr " `log' standard deviation"} + else if $HG_lev1==2{disp in gr " `log' coefficient of variation"} + else if $HG_lev1==3{disp in gr " `log'(sqrt(phi))"} + disp in ye " `lns1': `vars'" + local num: word count `vars' + matrix M_nbrf=(`num') + matrix `mat'=J(1,`num',-1) + matrix colnames `mat'=`vars' + matrix coleq `mat'=`lns1' + matrix M_initr=nullmat(M_initr),`mat' + } + else{ + matrix M_nbrf=(0) + if "`s'"~=""{ + disp in re "s() option ignored because families do not include dispersion parameters" + } + if "`nats'"~=""{ + disp in re "nats option ignored because families do not include dispersion parameters" + } + } + + matrix M_np = J(1,$HG_tpi,0) + if "`peqs'" ~= ""{ + local k: word count `peqs' + if $HG_free == 0 { + disp in re "peqs() argument meaningless for quadrature estimation, ignored" + } + else if `k'~=$HG_tpi-1{ + disp in red `k' " equations specified for prior probabilities: `peqs', need" $HG_tpi - 1 + exit 198 + } + global HG_noC1 = $HG_noC2 + } + + if "`eqs'"~=""{ + local k: word count `eqs' + if `k'~=$HG_tprf-1{ + disp in red `k' " equations specified: `eqs', need " $HG_tprf-1 + exit 198 + } + * check that they are equations and find number of variables in each: nbrf + local lev=2 + local l=1 + local ic=0 + while (`lev'<=$HG_tplv){ + disp " " + local m=$HG_tplv-`lev'+1 + local clusnam: word `m' of $HG_clus + disp " " + disp in gr "***level `lev' (" in ye "`clusnam'" in gr ") equation(s):" + if $HG_init==1{ + di in gr "(init option: parameters will not be estimated)" + di " " + } + local clusnam=substr("`clusnam'",1,3) + local lv = `lev'-1 + local clusnam "`clusnam'`lv'_" + local i1=M_nrfc[2, `lev'-1] + local j1=M_nrfc[2, `lev'] + local nrf=`j1'-`i1' + disp " (`nrf' random effect(s))" + disp " " + local rfl = 1 +/* MASS POINTS */ + if $HG_free { + tempname pmat + if $HG_cor==0{ + disp "option nocorrel irrelevant for free masses" + } + local k = 1 + local nloc = M_nip[1, `lev'] + if $HG_cip{ local nloc = `nloc' - 1} +* new + local pnum = 0 + local pvars _cons + matrix `pmat' = J(1,1,0) + if "`peqs'"~=""{ + local levm = `lev' - 1 + local peqn: word `levm' of `peqs' + eq ? "`peqn'" + local pvars "$S_1" + markout `touse' `pvars' + local pnum: word count `pvars' + matrix M_np[1,`lev'] = `pnum' + 1 + matrix `pmat' = J(1, `pnum', 0) + } + matrix colnames `pmat' = `pvars' +* end new + + while `k' <= `nloc'{ + disp " " + disp in gre "class `k'" + local j = `i1' + while `j'< `j1'{ + local eqnam: word `j' of `eqs' + eq ? "`eqnam'" + local vars "$S_1" + markout `touse' `vars' + local num: word count `vars' + + local ex = 0 + if "`frload'"~=""{ + local nex: word count `frload' + local iex = 1 + while `iex'<=`nex'{ + local aex: word `iex' of `frload' + if `aex' == `j'{ + local ex = 1 + } + local iex = `iex' + 1 + } + if `ex'{ + matrix M_frld[1,`j'+1] = 1 + local num = `num' + 1 + } + } + + + matrix `mat'=(`num') + matrix M_nbrf=M_nbrf,`mat' + if (`num'>1){ + parse "`vars'", parse(" ") + local vars1 "`1'" + if `k'==1{ + if `ex'==0{ + mac shift + } + local vars2 "`*'" + local eqnaml "`clusnam'`rfl'l" + eq "`eqnaml': `vars2'" + eq ? "`eqnaml'" + disp " " + disp in gr " lambdas for random effect " in ye `j' + disp in ye " `eqnaml': `vars2'" + global HG_eqs "$HG_eqs (`eqnaml': `depv' `vars2', nocons)" + local depv + local num=`num'-1 + * initial loading on masspoints + local lod = 1.1 + (`j'-1)*(-1)^(`j')/5 + matrix `mat'=J(1,`num',`lod') + matrix colnames `mat'= `vars2' + matrix coleq `mat'=`eqnaml' + matrix M_initr = nullmat(M_initr), `mat' + } + + } + else{local vars1 `vars'} + disp " " + disp in gr " location for random effect " in ye `j' + local eqnam "z`lev'_`j'_`k'" + if `nrf'==1{ + local eqnam "z`lev'_1_`k'" + } + eq "`eqnam'":`vars1' + eq ? "`eqnam'" + disp in ye " `eqnam': `vars1'" + global HG_eqs "$HG_eqs (`eqnam': `depv' `vars1', nocons)" + local depv + markout `touse' `vars1' + * initial locations of mass points + *local val = int((`k'+1)/2)*(-1)^`k'/10 + local val = int((`k'+1)/2)*(-1)^`k' + matrix `mat'=(`val') + matrix colnames `mat'=`vars1' + matrix coleq `mat'=`eqnam' + matrix M_initr=nullmat(M_initr),`mat' + local j = `j' + 1 + local rfl = `rfl' + 1 + } + if `k'< M_nip[1, `lev']{ + local eqnam "p`lev'_`k'" + eq "`eqnam'": + eq ? "`eqnam'" + disp " " + disp in gr " log odds for level " in ye `lev' + + if `pnum'>0{ + disp in ye " `eqnam': `pvars' _cons" + global HG_eqs "$HG_eqs (`eqnam':`pvars')" + matrix coleq `pmat'=`eqnam' + matrix M_initr=nullmat(M_initr),`pmat' + } + else{ + disp in ye " `eqnam': _cons" + global HG_eqs "$HG_eqs (`eqnam': `depv')" + local depv + * initial log odds for masspoints + } + * set constant + matrix `mat'=(-.4) + matrix colnames `mat'=_cons + matrix coleq `mat'=`eqnam' + matrix M_initr=nullmat(M_initr),`mat' + } + local k = `k' + 1 + } + * matrix list M_initr + * disp "$HG_eqs" + } +/* STD DEVS */ + else{ + local j = `i1' + while (`j'<`j1'){ + local eqnam: word `l' of `eqs' + eq ? "`eqnam'" + local vars "$S_1" + local num: word count `vars' + local ex = 0 + if "`frload'"~=""{ + local nex: word count `frload' + local iex = 1 + while `iex'<=`nex'{ + local aex: word `iex' of `frload' + if `aex' == `j'{ + local ex = 1 + } + local iex = `iex' + 1 + } + if `ex'{ + matrix M_frld[1,`j'+1] = 1 + local num = `num' + 1 + } + } + matrix `mat'=(`num') + matrix M_nbrf=M_nbrf,`mat' + markout `touse' `vars' + if "`vars'"==""{ local vars "_cons"} + if `num'>1{ + * vars1 is variable of first loading (fix at one) + parse "`vars'", parse(" ") + local vars1 "`1'" + if `ex'==0{ + mac shift + } + local vars "`*'" + local eqnaml "`clusnam'`rfl'l" + eq "`eqnaml'": `vars' + eq ? "`eqnaml'" + disp " " + disp in gr " lambdas for random effect " in ye `j' + disp in ye " `eqnaml': `vars'" + global HG_eqs "$HG_eqs (`eqnaml': `depv' `vars', nocons)" + local depv + * initial values of loadings + local lod = 1.1 + (`j'-1)*(-1)^(`j')/5 /*different loading for diff r.eff*/ + matrix `mat'=J(1,`num'-1,`lod') + matrix colnames `mat'=`vars' + matrix coleq `mat'=`eqnaml' + matrix M_initr=nullmat(M_initr),`mat' + } + else{ + local vars1 `vars' + } + * variance + local eqnam "`clusnam'`rfl'" + eq "`eqnam'": `vars1' + if `nrf'==1|$HG_cor==0{ + disp in gr " standard deviation for random effect " in ye `j' + } + else{ + disp " " + disp in gr /* + */" diagonal element of cholesky decomp. of covariance matrix" + } + disp in ye " `eqnam' : `vars1'" + global HG_eqs "$HG_eqs (`eqnam': `depv' `vars1', nocons)" + local depv + * initial value of standard deviation + matrix `mat' = (0.5) + matrix colnames `mat' = `vars1' + matrix coleq `mat' = `eqnam' + matrix M_initr=nullmat(M_initr),`mat' + local l=`l'+1 + local j=`j'+1 + local rfl = `rfl' + 1 + } + if `nrf' > 1&$HG_cor==1{ + /* generate equations for covariance parameters */ + disp " " + disp in gr " off-diagonal elements" + local ii=2 + *local num = $HG_tplv-`lev'+1 + *local eqnam: word `num' of $HG_clus + *local eqnam = substr("`eqnam'",1,4) + while (`ii'<=`nrf'){ + local jj=1 + while (`jj'<`ii'){ + local eqnaml "`clusnam'`ii'_`jj'" + eq "`eqnaml'": + eq ? "`eqnaml'" + disp in ye " `eqnaml': _cons" + global HG_eqs "$HG_eqs (`eqnaml':)" + matrix `mat'=(0) + matrix colnames `mat'=_cons + matrix coleq `mat'=`eqnaml' + matrix M_initr=nullmat(M_initr),`mat' + local jj = `jj' + 1 + } + local ii=`ii'+1 + } + } + } /* end else $HG_free */ + local lev=`lev'+1 + } /* lev loop */ + + } /* endif equ given */ + else{ + /* random intercepts */ + if M_nrfc[1,$HG_tplv]~=$HG_tplv{ + "must specify equations for random effects" + exit 198 + } + local k=$HG_tprf-1 + matrix `mat'=J(1,`k',1) + matrix M_nbrf=M_nbrf,`mat' + local lev=2 + disp " " + while (`lev'<=$HG_tplv){ + local l=$HG_tplv-`lev'+1 + local clusnam: word `l' of $HG_clus + disp " " + disp in gr "***level `lev' (" in ye "`clusnam'" in gr ") equation(s):" + if $HG_init==1{ + di in gr "(init option: parameters will not be estimated)" + di " " + } + local clusnam = substr("`clusnam'",1,4) + local lv = `lev' - 1 + local clusnam "`clusnam'`lv'" +/*MASS POINTS */ + if ($HG_free){ + local k = 1 + local nloc = M_nip[1, `lev'] + if $HG_cip{ local nloc = `nloc' - 1} + +* new + local pnum = 0 + local pvars _cons + tempname pmat + matrix `pmat' = J(1,1,0) + if "`peqs'"~=""{ + local levm = `lev' - 1 + local peqn: word `levm' of `peqs' + eq ? "`peqn'" + local pvars "$S_1" + markout `touse' `pvars' + local pnum: word count `pvars' + matrix M_np[1,`lev'] = `pnum' + 1 + matrix `pmat' = J(1, `pnum', 0) + } + matrix colnames `pmat' = `pvars' +* end new + while `k' <= `nloc'{ + disp " " + disp in gre "class `k'" + local j = 1 + + local eqnam "z`lev'_1_`k'" + disp in gr " location for random effect" + disp in ye " `eqnam': _cons" + global HG_eqs "$HG_eqs (`eqnam': `depv')" + local depv + * initial locations of mass points + *local val = int((`k'+1)/2)*(-1)^`k'/10 + local val = int((`k'+1)/2)*(-1)^`k' + matrix `mat'=(`val') + matrix colnames `mat'=_cons + matrix coleq `mat'=`eqnam' + matrix M_initr=nullmat(M_initr),`mat' + + if `k'0{ + disp in ye " `eqnam': `pvars' _cons" + global HG_eqs "$HG_eqs (`eqnam':`pvars')" + matrix coleq `pmat'=`eqnam' + matrix M_initr=nullmat(M_initr),`pmat' + } + else{ + disp in ye " `eqnam': _cons" + global HG_eqs "$HG_eqs (`eqnam':)" + * initial log odds for masspoints + } + * set constant + matrix `mat'=(-.4) + matrix colnames `mat'=_cons + matrix coleq `mat'=`eqnam' + matrix M_initr=nullmat(M_initr),`mat' + } + local k = `k' + 1 + } + } +/* ST. DEVS */ + else{ + local eqnam "`clusnam'" + disp " " + disp in gr " standard deviation of random effect" + disp in ye " `eqnam': _cons" + global HG_eqs "$HG_eqs (`eqnam':`depv')" + local depv + * initial value for sd + matrix `mat'=(0.5) + matrix colnames `mat'=_cons + matrix coleq `mat'=`eqnam' + matrix M_initr=nullmat(M_initr),`mat' + local cons `cons'1 + } + local lev=`lev'+1 + } + } + disp " " + + matrix `mat' = nullmat(M_initr), nullmat(M_initf) /* M_initr may not exist */ + global HG_befB = colsof(`mat') +/* deal with Bmatrix */ + + global HG_bmat = 0 + if "`bmatrix'"~=""{ + if $HG_tprf<2{ + disp in re "bmatrix can only be used for more than 1 random effect" + exit 198 + } + * capture matrix list `bmatrix' + if _rc>0{ + disp in re "bmatrix is not a matrix" + exit 198 + } + local bn = colsof(`bmatrix') + if rowsof(`bmatrix')~=`bn'{ + disp in re "bmatrix must be square" + exit 198 + } + if `bn'~=$HG_tprf-1{ + disp in re "number of rows and columns of B matrix must be " $HG_tprf-1 + exit 198 + } + matrix M_b=`bmatrix' + global HG_bmat = 1 + disp in gr "B-matrix:" + local i = 1 + while `i' <= `bn'{ + local j = 1 + while `j'<= `bn'{ + if M_b[`i',`j']>0{ + local eqnam b`i'_`j' + disp " " + disp in ye " `eqnam': _cons" + global HG_eqs "$HG_eqs (`eqnam':)" + * initial value for sd + matrix `mat'=(0.5) + matrix colnames `mat'=_cons + matrix coleq `mat'=`eqnam' + matrix M_initr=nullmat(M_initr),`mat' + local cons `cons'1 + } + local j = `j' + 1 + } + local i = `i' + 1 + } + disp " " + } + +/* total number of fixed linear predictors */ + global HG_tpff = colsof(M_nffc) + +/* deal with geqs */ + global HG_ngeqs = 0 + if "`geqs'"~=""{ + * M_ngeqs: first row says which random effect, second how many terms + local num: word count `geqs' + global HG_ngeqs = `num' + matrix M_ngeqs=J(3,`num',0) + local nxt = M_nffc[1,$HG_tpff] + colsof(M_initr) + 1 + disp in gr "Regressions of random effects on covariates:" + tokenize `geqs' + local i = 1 + while "`1'"~="" { + local k = substr("`1'",2,1) + local k = `k' + 1 + if `k'>$HG_tprf { + disp in red "eq `1' refers to a random effects that does not exist" + exit 198 + } + local j = 1 + while `j'<=`i'{ + if M_ngeqs[1,`j']==`k' { + disp in red "more than one geq given for random effect" `k'-1 + exit 198 + } + local j = `j' + 1 + } + eq ? "`1'" + local vars "$S_1" + local num: word count `vars' + matrix `mat'=J(1,`num',0) + matrix colnames `mat'=`vars' + matrix coleq `mat'=`1' + matrix M_initr=nullmat(M_initr),`mat' + markout `touse' `vars' + disp in gr " equation for random effect " in ye `k'-1 + disp in ye " `1': `vars'" + global HG_eqs "$HG_eqs (`1': `vars', nocons)" + matrix M_ngeqs[1,`i']=`k' + matrix M_ngeqs[2,`i']=`num' + matrix M_ngeqs[3,`i']=`nxt' + local nxt = `nxt' + `num' + local i = `i' + 1 + mac shift + } + disp " " + } + + global which = 15 + +/* the "clock" ip and znow*/ + local k = $HG_tprf+2 + matrix M_ip = J(1,`k',1) + local k = $HG_tprf - 1 + matrix M_znow =J(1,`k',1) + +end + + + +program define mint +args n k + if `k' == 5 { + multn `n' + } + else if `k' == 7 { + sphern `n' + } + else if `n'==2&(`k' == 9|`k' == 11|`k' == 15){ + int2k `k' + } + else{ + disp in re "nip must be 5 or 7 if dim >2 and 5, 7, 9, 11 or 15 if dim=2" + exit 198 + } +end + +program define sphern +version 6.0 +/* degree 7 rule for n>=3 used by Naylor and Smith */ +args n + if `n' == 2 { + spher2 + } + else if `n' == 3{ + spher3 + } + else if `n' == 6{ + spher6 + } +/* + else if `n' == 4{ + spher4 + } +*/ + else{ + tempname r s t B C D r1 r2 A1 A2 x X y a norm im + + local num =2*( 2^`n' + 2*`n'^2) + +* generate U_n: 7-1 page 295 + scalar `r' = sqrt(2) + scalar `s' = sqrt(2/`n') + scalar `t' = 1 + scalar `B' = ln(8-`n') - ln(`n') - ln(`n'+2) - ln(`n'+4) + ln(2) - lngamma(`n'/2) + scalar `C' = -`n'*ln(2) + 3*ln(`n') - ln(`n') - ln(`n'+2) - ln(`n'+4) + ln(2) - lngamma(`n'/2) + scalar `D' = ln(4) - ln(`n') - ln(`n'+2) - ln(`n'+4) + ln(2) - lngamma(`n'/2) + scalar `r2' = sqrt( (`n' + 2 - sqrt(2*(`n'+2)))/2 ) + scalar `r1' = sqrt( (`n' + 2 + sqrt(2*(`n'+2)))/2 ) + scalar `A2' = ln( ( `n' + 2 + sqrt(2*(`n'+2)) )/(4*(`n'+2)) )+ lngamma(`n'/2) + scalar `A1' = ln( ( `n' + 2 - sqrt(2*(`n'+2)) )/(4*(`n'+2)) )+ lngamma(`n'/2) + + +* Do r and B + matrix `x' = J(1,`n',0) + local ir = 1 + while `ir' <= `n'{ + local j = 1 + while `j' <= 2 { + matrix `x'[1,`ir'] = (-1)^`j'*`r' + matrix `X' = nullmat(`X')\ `x' + matrix `y' = nullmat(`y'),`B' + matrix `x'[1,`ir'] = 0 + local j = `j' + 1 + } + local ir = `ir' + 1 + } + +* Do t and D + matrix `x' = J(1,`n',0) + local it1 = 1 + while `it1' <= `n'{ + local j1 = 1 + while `j1' <= 2{ + matrix `x'[1,`it1'] = (-1)^`j1'*`t' + local it2 = `it1' + 1 + while `it2' <= `n'{ + local j2 = 1 + while `j2' <= 2{ + * disp "it1 = `it1' and it2 = `it2'" + matrix `x'[1,`it2'] = (-1)^`j2'*`t' + matrix `X' = `X'\ `x' + matrix `y' = `y', `D' + matrix `x'[1,`it2'] = 0 + local j2 = `j2' + 1 + } + local it2 = `it2' + 1 + } + matrix `x'[1,`it1'] = 0 + local j1 = `j1' + 1 + + } + local it1 = `it1' + 1 + } + +* Do s and C + matrix `x' = J(1,`n',`s') + matrix `im' = J(1,`n'+1,0) + matrix `im'[1,1] = 1 + + local pm = `n'+1 + while `pm' <= `n'+1{ + /* set previous digits to 0 */ + while `pm'>1{ + matrix `x'[1,`pm'-1] = `s' + matrix `im'[1,`pm'] = 0 + local pm = `pm' - 1 + } + matrix `X' = `X'\ `x' + matrix `y' = `y', `C' + * matrix list `im' + + local pm = 1 + while `im'[1,`pm'] == 1{ + local pm = `pm' + 1 + } + * disp "pm = " `pm' + /* pm is first incomplete digit */ + if `pm'<= `n' + 1{ + matrix `im'[1,`pm'] = 1 + matrix `x'[1,`pm'-1] = -`s' + local pm = `pm' - 1 + } + } + + *matrix list `X' + *matrix list `y' + matrix M_zlc`num' = `X'*`r1'\ `X'*`r2' + matrix M_zlc`num' = M_zlc`num'' + matrix `a'= J(1,`num'/2,`A1'),J(1,`num'/2,`A2') + matrix M_zps`num' = `y',`y' + matrix M_zps`num' = M_zps`num'+`a' + global S_1 = `num' + } /* end else */ +end + + +program define spher2 +version 6.0 +*p. 324, 7-1 + tempname r s t A B C x + capture matrix drop M_zlc12 + capture matrix drop M_zps12 + + scalar `r' = sqrt(6) + scalar `s' = sqrt((9-3*sqrt(5))/4) + scalar `t' = sqrt((9+3*sqrt(5))/4) + scalar `A' = ln(1/36) + scalar `B' = ln(5 + 2*sqrt(5)) - ln(45) + scalar `C' = ln(5 - 2*sqrt(5)) - ln(45) + +*r + matrix `x' = J(1,2,0) + local ir = 1 + while `ir' <= 2{ + local j = 1 + while `j' <= 2{ + matrix `x'[1,`ir'] = (-1)^`j'*`r' + matrix M_zlc12 = nullmat(M_zlc12)\ `x' + matrix M_zps12 = nullmat(M_zps12), `A' + matrix `x'[1,`ir'] = 0 + local j = `j' + 1 + } + local ir = `ir' + 1 + } + +*t + matrix `x' = J(1,2,`t') + matrix M_zlc12 = M_zlc12\ `x' + matrix M_zps12 = M_zps12, `C' + local m = 1 /* number of - */ + while `m' <= 2{ + local i = 1 /* pos of first - */ + while `i'<= 2{ + matrix `x'[1,`i'] = -`t' + local j = `i' + 1 + if `m'>1{ + while `j' <= 2 { + matrix `x'[1,`j'] = -`t' + matrix M_zlc12 = M_zlc12\ `x' + matrix M_zps12 = M_zps12, `C' + matrix `x'[1,`j'] = `t' + local j = `j' + 1 + } + } + else{ + matrix M_zlc12 = M_zlc12\ `x' + matrix M_zps12 = M_zps12, `C' + } + matrix `x'[1, `i'] = `t' + local i = `i' + 1 + } + local m = `m' + 1 + } + +* s + matrix `x' = J(1,2,`s') + matrix M_zps12 = M_zps12, `B' + matrix M_zlc12 = M_zlc12\ `x' + + local m = 1 /* number of - */ + while `m' <= 2{ + local i = 1 /* pos of first - */ + while `i'<= 2{ + matrix `x'[1,`i'] = -`s' + local j = `i' + 1 + if `m'>1{ + while `j' <= 2 { + matrix `x'[1,`j'] = -`s' + matrix M_zlc12 = M_zlc12\ `x' + matrix M_zps12 = M_zps12, `B' + matrix `x'[1,`j'] = `s' + local j = `j' + 1 + } + } + else{ + matrix M_zlc12 = M_zlc12\ `x' + matrix M_zps12 = M_zps12, `B' + } + matrix `x'[1, `i'] = `s' + local i = `i' + 1 + } + local m = `m' + 1 + } + matrix M_zlc12 = M_zlc12' + global S_1 = 12 +end + +program define spher3 + version 6.0 +* Stroud (1971) p. 327, E_3^{r^2} 7-1 + args n + tempname r s t A B C D x im + local num = 27 + capture matrix drop M_zlc27 + capture matrix drop M_zps27 + + scalar `r' = sqrt((15 + sqrt(15))/2) + scalar `s' = sqrt(6 - sqrt(15)) + scalar `t' = sqrt(9 + 2*sqrt(15)) + scalar `A' = ln(720 + 8*sqrt(15)) - ln(2205) + scalar `B' = ln(270 - 46*sqrt(15)) - ln(15435) + scalar `C' = ln(162 + 41*sqrt(15)) - ln(6174) + scalar `D' = ln(783 - 202*sqrt(15)) - ln(24696) + + local n = 3 +* D + matrix `x' = J(1,`n',`t') + matrix `im' = J(1,`n'+1,0) + matrix `im'[1,1] = 1 + + local pm = `n'+1 + while `pm' <= `n'+1{ + /* set previous digits to 0 */ + while `pm'>1{ + matrix `x'[1,`pm'-1] = `t' + matrix `im'[1,`pm'] = 0 + local pm = `pm' - 1 + } + matrix M_zlc`num' = nullmat(M_zlc`num')\ `x' + matrix M_zps`num' = nullmat(M_zps`num'), `D' + * matrix list `im' + + local pm = 1 + while `im'[1,`pm'] == 1{ + local pm = `pm' + 1 + } + * disp "pm = " `pm' + /* pm is first incomplete digit */ + if `pm'<= `n' + 1{ + matrix `im'[1,`pm'] = 1 + matrix `x'[1,`pm'-1] = -`t' + local pm = `pm' - 1 + } + } + +* B + matrix `x' = J(1,`n',0) + local ir = 1 + while `ir' <= `n'{ + local j = 1 + while `j' <= 2{ + matrix `x'[1,`ir'] = (-1)^`j'*`r' + matrix M_zlc`num' = M_zlc`num'\ `x' + matrix M_zps`num' = M_zps`num',`B' + matrix `x'[1,`ir'] = 0 + local j = `j' + 1 + } + local ir = `ir' + 1 + } + +* C + matrix `x' = J(1,`n',0) + local is1 = 1 + while `is1' <= `n'{ + local j1 = 1 + while `j1' <= 2{ + matrix `x'[1,`is1'] = (-1)^`j1'*`s' + local is2 = `is1' + 1 + while `is2' <= `n'{ + local j2 = 1 + while `j2' <= 2{ + * disp "is1 = `is1' and is2 = `is2'" + matrix `x'[1,`is2'] = (-1)^`j2'*`s' + matrix M_zlc`num' = M_zlc`num'\ `x' + matrix M_zps`num' = M_zps`num',`C' + matrix `x'[1,`is2'] = 0 + local j2 = `j2' + 1 + } + local is2 = `is2' + 1 + } + matrix `x'[1,`is1'] = 0 + local j1 = `j1' + 1 + + } + local is1 = `is1' + 1 + } +* A + matrix M_zps`num' = M_zps`num',`A' + matrix `x' = J(1,`n',0) + matrix M_zlc`num' = M_zlc`num'\ `x' + matrix M_zlc`num' = M_zlc`num'' + global S_1 = `num' +end + + +program define spher4 + version 6.0 +* Stroud (1971) p. 329, E_4^{r^2} 7-1 + args n + tempname r s t A B C D x im + local num = 49 + capture matrix drop M_zlc`num' + capture matrix drop M_zps`num' + + scalar `s' = sqrt(3 - sqrt(3)) + scalar `r' = 2*`s' + scalar `t' = sqrt(6 + 2*sqrt(3)) + scalar `A' = -ln(4) + scalar `B' = ln(9 + 5*sqrt(3)) - ln(576) + scalar `C' = ln(9 + -5*sqrt(3)) - ln(576) + + local n = 4 +* C and t + matrix `x' = J(1,`n',0) + local is1 = 1 + while `is1' <= `n'{ + local j1 = 1 + while `j1' <= 2{ + matrix `x'[1,`is1'] = (-1)^`j1'*`t' + local is2 = `is1' + 1 + while `is2' <= `n'{ + local j2 = 1 + while `j2' <= 2{ + * disp "is1 = `is1' and is2 = `is2'" + matrix `x'[1,`is2'] = (-1)^`j2'*`t' + matrix M_zlc`num' = nullmat(M_zlc`num')\ `x' + matrix M_zps`num' = nullmat(M_zps`num'),`C' + matrix `x'[1,`is2'] = 0 + local j2 = `j2' + 1 + } + local is2 = `is2' + 1 + } + matrix `x'[1,`is1'] = 0 + local j1 = `j1' + 1 + + } + local is1 = `is1' + 1 + } + +* B and s + matrix `x' = J(1,`n',`s') + matrix `im' = J(1,`n'+1,0) + matrix `im'[1,1] = 1 + + local pm = `n'+1 + while `pm' <= `n'+1{ + /* set previous digits to 0 */ + while `pm'>1{ + matrix `x'[1,`pm'-1] = `s' + matrix `im'[1,`pm'] = 0 + local pm = `pm' - 1 + } + matrix M_zlc`num' = nullmat(M_zlc`num')\ `x' + matrix M_zps`num' = nullmat(M_zps`num'), `B' + * matrix list `im' + + local pm = 1 + while `im'[1,`pm'] == 1{ + local pm = `pm' + 1 + } + * disp "pm = " `pm' + /* pm is first incomplete digit */ + if `pm'<= `n' + 1{ + matrix `im'[1,`pm'] = 1 + matrix `x'[1,`pm'-1] = -`s' + local pm = `pm' - 1 + } + } + +* B and r + matrix `x' = J(1,`n',0) + local ir = 1 + while `ir' <= `n'{ + local j = 1 + while `j' <= 2{ + matrix `x'[1,`ir'] = (-1)^`j'*`r' + matrix M_zlc`num' = M_zlc`num'\ `x' + matrix M_zps`num' = M_zps`num',`B' + matrix `x'[1,`ir'] = 0 + local j = `j' + 1 + } + local ir = `ir' + 1 + } +* A + matrix M_zps`num' = M_zps`num',`A' + matrix `x' = J(1,`n',0) + matrix M_zlc`num' = M_zlc`num'\ `x' + matrix M_zlc`num' = M_zlc`num'' + global S_1 = `num' +end + + +capture program drop spher6 +program define spher6 +* Stroud 7-1 (p. 318) + tempname r s t B C D A x X y a norm im + + local n = 6 + local num = 2^`n' + 2*`n'^2 + 1 + + capture matrix drop M_zlc`num' + capture matrix drop M_zps`num' +/* + scalar `r' = sqrt( (3*(8-`n')-(`n'-2)*sqrt(3*(8-`n')))/(2*(5-`n')) ) + scalar `s' = sqrt( (3*`n' - 2*sqrt(3*(8-`n')))/(2*(3*`n' - 8)) ) + scalar `t' = sqrt( (6+sqrt(3*(8-`n')))/2 ) + scalar `B' = (8-`n')/( 8*`r'^6) *2/exp(lngamma(`n'/2)) + scalar `C' = 1 /( 2^(`n'+3)*`s'^6) *2/exp(lngamma(`n'/2)) + scalar `D' = 1/(16*`t'^6) *2/exp(lngamma(`n'/2)) + scalar `A' = 2/exp(lngamma(`n'/2)) - 2*`n'*`B' - 2^`n'*`C' - 2*`n'*(`n'-1)*`D' + disp in re "r = " `r' " s = " `s' " t = " `t' + disp in re "A = " `A' " B = " `B' " C = " `C' " D = " `D' +*/ + +* - - + + scalar `r' = sqrt( (3*(8-`n')-(`n'-2)*sqrt(3*(8-`n')))/(5-`n') ) + scalar `s' = sqrt( (3*`n' - 2*sqrt(3*(8-`n')))/(3*`n' - 8) ) + scalar `t' = sqrt( 6+sqrt(3*(8-`n')) ) + scalar `B' = ln(8-`n') - ln(8) - 6*( ln(`r') - ln(2)/2 ) + ln(2) - lngamma(`n'/2) + scalar `C' = -(`n'+ 3)*ln(2)-6*( ln(`s') - ln(2)/2 ) + ln(2) - lngamma(`n'/2) + scalar `D' = -ln(16) - 6*( ln(`t') - ln(2)/2 ) + ln(2) - lngamma(`n'/2) + scalar `A' = ln( 2/exp(lngamma(`n'/2)) - 2*`n'*exp(`B') - 2^`n'*exp(`C') - 2*`n'*(`n'-1)*exp(`D') ) + *disp in re "r = " `r' " s = " `s' " t = " `t' + *disp in re "A = " `A' " B = " `B' " C = " `C' " D = " `D' + + + +* A + matrix `X' = J(1,`n',0) + matrix `y' = (`A') + +* Do r and B + matrix `x' = J(1,`n',0) + local ir = 1 + while `ir' <= `n'{ + local j = 1 + while `j' <= 2 { + matrix `x'[1,`ir'] = (-1)^`j'*`r' + matrix `X' = nullmat(`X')\ `x' + matrix `y' = nullmat(`y'),`B' + matrix `x'[1,`ir'] = 0 + local j = `j' + 1 + } + local ir = `ir' + 1 + } + +* Do t and D + matrix `x' = J(1,`n',0) + local it1 = 1 + while `it1' <= `n'{ + local j1 = 1 + while `j1' <= 2{ + matrix `x'[1,`it1'] = (-1)^`j1'*`t' + local it2 = `it1' + 1 + while `it2' <= `n'{ + local j2 = 1 + while `j2' <= 2{ + * disp "it1 = `it1' and it2 = `it2'" + matrix `x'[1,`it2'] = (-1)^`j2'*`t' + matrix `X' = `X'\ `x' + matrix `y' = `y', `D' + matrix `x'[1,`it2'] = 0 + local j2 = `j2' + 1 + } + local it2 = `it2' + 1 + } + matrix `x'[1,`it1'] = 0 + local j1 = `j1' + 1 + + } + local it1 = `it1' + 1 + } + +* Do s and C + matrix `x' = J(1,`n',`s') + matrix `im' = J(1,`n'+1,0) + matrix `im'[1,1] = 1 + + local pm = `n'+1 + while `pm' <= `n'+1{ + /* set previous digits to 0 */ + while `pm'>1{ + matrix `x'[1,`pm'-1] = `s' + matrix `im'[1,`pm'] = 0 + local pm = `pm' - 1 + } + matrix `X' = `X'\ `x' + matrix `y' = `y', `C' + * matrix list `im' + + local pm = 1 + while `im'[1,`pm'] == 1{ + local pm = `pm' + 1 + } + * disp "pm = " `pm' + /* pm is first incomplete digit */ + if `pm'<= `n' + 1{ + matrix `im'[1,`pm'] = 1 + matrix `x'[1,`pm'-1] = -`s' + local pm = `pm' - 1 + } + } + + matrix M_zlc`num' = `X' + matrix M_zps`num' = `y' + matrix M_zlc`num' = M_zlc`num'' + global S_1 = `num' +end + + +program define fsrs + version 6.0 + args r s x n + if abs(`s')<1e-10&abs(`r')<1e-10{ + matrix `x' = (0,0) + scalar `n' = 1 + } + else if abs(`s')<1e-10{ + matrix `x' = (`r',0\ -`r',0\ 0,`r'\ 0,-`r') + scalar `n' = 4 + } + else if abs(`r'-`s')<1e-10{ + matrix `x' = (`r',`s'\ -`r',`s'\ `r',-`s'\ -`r',-`s') + scalar `n' = 4 + } + else{ + matrix `x' = (`r',`s'\ -`r',`s'\ `r',-`s'\ -`r',-`s'\ `s',`r'\ -`s',`r'\ `s',-`r'\ -`s',-`r') + scalar `n' = 8 + } +end + +program define int2k + version 6.0 + args k + if `k' == 9{ + *E_2^{r^2}: 9-1 + local l = 4 + local num = 20 + tempname r1 r2 r3 r4 s1 s2 s3 s4 B1 B2 B3 B4 +/* + scalar `r1' = 1.538189001320852*sqrt(2) + scalar `r2' = 1.224744871391589*sqrt(2) + scalar `r3' = 0.4817165220011443*sqrt(2) + scalar `r4' = 2.607349811958554*sqrt(2) + scalar `s4' = 0.9663217712794149*sqrt(2) + scalar `s1' = 0 + scalar `s2' = `r2' + scalar `s3' = `r3' + scalar `B1' = ln(0.1237222328857347) - ln(_pi) + scalar `B2' = ln(0.06544984694978697) - ln(_pi) + scalar `B3' = ln(0.5935280476180875) - ln(_pi) + scalar `B4' = ln(0.001349017971918148) - ln(_pi) +*/ + scalar `r3' = 1.538189001320852*sqrt(2) + scalar `r2' = 1.224744871391589*sqrt(2) + scalar `r4' = 0.4817165220011443*sqrt(2) + scalar `r1' = 2.607349811958554*sqrt(2) + scalar `s1' = 0.9663217712794149*sqrt(2) + scalar `s3' = 0 + scalar `s2' = `r2' + scalar `s4' = `r4' + scalar `B3' = ln(0.1237222328857347) - ln(_pi) + scalar `B2' = ln(0.06544984694978697) - ln(_pi) + scalar `B4' = ln(0.5935280476180875) - ln(_pi) + scalar `B1' = ln(0.001349017971918148) - ln(_pi) + } + if `k' == 11{ + *E_2^{r^2}: 11-1 + local l = 5 + local num = 28 + tempname r1 r2 r3 r4 r5 s1 s2 s3 s4 s5 B1 B2 B3 B4 B5 +/* + scalar `r1' = 2.757816396257008*sqrt(2) + scalar `r2' = 1.732050807568877*sqrt(2) + scalar `r3' = 0.6280515301597559*sqrt(2) + scalar `r4' = 1.224744871391589*sqrt(2) + scalar `r5' = 0.7071067811865475*sqrt(2) + scalar `s4' = 2.121320343559643*sqrt(2) + scalar `s5' = 1.224744871391589*sqrt(2) + scalar `s1' = 0 + scalar `s2' = 0 + scalar `s3' = 0 + scalar `B1' = ln(0.0008176645817675417) - ln(_pi) + scalar `B2' = ln(0.04363323129985824) - ln(_pi) + scalar `B3' = ln(0.5373255214498174) - ln(_pi) + scalar `B4' = ln(0.003636102608321520) - ln(_pi) + scalar `B5' = ln(0.09817477042468103) - ln(_pi) +*/ + scalar `r1' = 2.757816396257008*sqrt(2) + scalar `r3' = 1.732050807568877*sqrt(2) + scalar `r5' = 0.6280515301597559*sqrt(2) + scalar `r2' = 1.224744871391589*sqrt(2) + scalar `r4' = 0.7071067811865475*sqrt(2) + scalar `s2' = 2.121320343559643*sqrt(2) + scalar `s4' = 1.224744871391589*sqrt(2) + scalar `s1' = 0 + scalar `s3' = 0 + scalar `s5' = 0 + scalar `B1' = ln(0.0008176645817675417) - ln(_pi) + scalar `B3' = ln(0.04363323129985824) - ln(_pi) + scalar `B5' = ln(0.5373255214498174) - ln(_pi) + scalar `B2' = ln(0.003636102608321520) - ln(_pi) + scalar `B4' = ln(0.09817477042468103) - ln(_pi) + } + if `k' == 15{ + *E_2^{r^2}: 15-1 + local l = 9 + local num = 44 + tempname r1 r2 r3 r4 r5 r6 r7 r8 r9 s1 s2 s3 s4 s5 s6 s7 s8 s9 B1 B2 B3 B4 B5 B6 B7 B8 B9 +/* + scalar `r1' = 3.538388728121807*sqrt(2) + scalar `r2' = 2.359676416877929*sqrt(2) + scalar `r3' = 1.312801844620926*sqrt(2) + scalar `r4' = 0.5389559482114205*sqrt(2) + scalar `r5' = 2.300279949805658*sqrt(2) + scalar `r6' = 1.581138830084189*sqrt(2) + scalar `r7' = 0.8418504335819279*sqrt(2) + scalar `r8' = 2.685533581755341*sqrt(2) + scalar `r9' = 1.740847514397403*sqrt(2) + scalar `s8' = 1.112384431771456*sqrt(2) + scalar `s9' = 0.7210826504868960*sqrt(2) + scalar `s1' = 0 + scalar `s2' = 0 + scalar `s3' = 0 + scalar `s4' = 0 + scalar `s5' = `r5' + scalar `s6' = `r6' + scalar `s7' = `r7' + scalar `B1' = ln(0.000008006483569659628) - ln(_pi) + scalar `B2' = ln(0.003604577420838264) - ln(_pi) + scalar `B3' = ln(0.1187609330759137) - ln(_pi) + scalar `B4' = ln(0.4372488543791402) - ln(_pi) + scalar `B5' = ln(0.00003671735075832989) - ln(_pi) + scalar `B6' = ln(0.005654866776461627) - ln(_pi) + scalar `B7' = ln(0.1777774268424240) - ln(_pi) + scalar `B8' = ln(0.0002735449647853290) - ln(_pi) + scalar `B9' = ln(0.02087984556938594) - ln(_pi) +*/ + scalar `r1' = 3.538388728121807*sqrt(2) + scalar `r4' = 2.359676416877929*sqrt(2) + scalar `r7' = 1.312801844620926*sqrt(2) + scalar `r9' = 0.5389559482114205*sqrt(2) + scalar `r2' = 2.300279949805658*sqrt(2) + scalar `r5' = 1.581138830084189*sqrt(2) + scalar `r8' = 0.8418504335819279*sqrt(2) + scalar `r3' = 2.685533581755341*sqrt(2) + scalar `r6' = 1.740847514397403*sqrt(2) + scalar `s3' = 1.112384431771456*sqrt(2) + scalar `s6' = 0.7210826504868960*sqrt(2) + scalar `s1' = 0 + scalar `s4' = 0 + scalar `s7' = 0 + scalar `s9' = 0 + scalar `s2' = `r2' + scalar `s5' = `r5' + scalar `s8' = `r8' + scalar `B1' = ln(0.000008006483569659628) - ln(_pi) + scalar `B4' = ln(0.003604577420838264) - ln(_pi) + scalar `B7' = ln(0.1187609330759137) - ln(_pi) + scalar `B9' = ln(0.4372488543791402) - ln(_pi) + scalar `B2' = ln(0.00003671735075832989) - ln(_pi) + scalar `B5' = ln(0.005654866776461627) - ln(_pi) + scalar `B8' = ln(0.1777774268424240) - ln(_pi) + scalar `B3' = ln(0.0002735449647853290) - ln(_pi) + scalar `B6' = ln(0.02087984556938594) - ln(_pi) + } + tempname x n + capture matrix drop M_zlc`num' + local i = 1 + while `i'<=`l'{ + fsrs `r`i'' `s`i'' `x' `n' + * matrix list `x' + matrix M_zlc`num' = nullmat(M_zlc`num')\ `x' + matrix `x' = J(1,`n',`B`i'') + matrix M_zps`num' = nullmat(M_zps`num'), `x' + local i = `i' + 1 + } + matrix M_zlc`num' = M_zlc`num'' + global S_1 = `num' +end + +program define multn +version 6.0 +* Stroud (1971) p. 317, 5-2 + args n + tempname r s A B C x + local num = 2*`n'^2 + 1 + + capture matrix drop M_zlc`num' + capture matrix drop M_zps`num' + + scalar `r' = sqrt((`n'+2)) + scalar `s' = sqrt((`n'+2)/2) + scalar `A' = ln(2) - ln(`n'+2) + scalar `B' = ln(4-`n')-ln(2) -2*ln(`n'+2) + scalar `C' = -2*ln(`n'+2) + + matrix M_zps`num' = (`A') + matrix `x' = J(1,`n',0) + matrix M_zlc`num' = `x' + local ir = 1 + while `ir' <= `n'{ + local j = 1 + while `j' <= 2{ + matrix `x'[1,`ir'] = (-1)^`j'*`r' + matrix M_zlc`num' = M_zlc`num'\ `x' + matrix M_zps`num' = M_zps`num',`B' + matrix `x'[1,`ir'] = 0 + local j = `j' + 1 + } + local ir = `ir' + 1 + } + + local is1 = 1 + while `is1' <= `n'{ + local j1 = 1 + while `j1' <= 2{ + matrix `x'[1,`is1'] = (-1)^`j1'*`s' + local is2 = `is1' + 1 + while `is2' <= `n'{ + local j2 = 1 + while `j2' <= 2{ + * disp "is1 = `is1' and is2 = `is2'" + matrix `x'[1,`is2'] = (-1)^`j2'*`s' + matrix M_zlc`num' = M_zlc`num'\ `x' + matrix M_zps`num' = M_zps`num',`C' + matrix `x'[1,`is2'] = 0 + local j2 = `j2' + 1 + } + local is2 = `is2' + 1 + } + matrix `x'[1,`is1'] = 0 + local j1 = `j1' + 1 + + } + local is1 = `is1' + 1 + } + matrix M_zlc`num' = M_zlc`num'' + global S_1 = `num' +end + +program define ghquad +* stolen from rfprobit (Bill Sribney) + version 4.0 + local n `1' + tempname xx ww a b + local i 1 + local m = int((`n' + 1)/2) + matrix M_zlc`n' = J(1,`m',0) + matrix M_zps`n' = M_zlc`n' + while `i' <= `m' { + if `i' == 1 { + scalar `xx' = sqrt(2*`n'+1)-1.85575*(2*`n'+1)^(-1/6) + } + else if `i' == 2 { scalar `xx' = `xx'-1.14*`n'^0.426/`xx' } + else if `i' == 3 { scalar `xx' = 1.86*`xx'-0.86*M_zlc`n'[1,1] } + else if `i' == 4 { scalar `xx' = 1.91*`xx'-0.91*M_zlc`n'[1,2] } + else { + local im2 = `i' -2 + scalar `xx' = 2*`xx'-M_zlc`n'[1,`im2'] + } + hermite `n' `xx' `ww' + matrix M_zlc`n'[1,`i'] = `xx' + matrix M_zps`n'[1,`i'] = ln(`ww') - ln(_pi)/2 + local i = `i' + 1 + } + if mod(`n', 2) == 1 { matrix M_zlc`n'[1,`m'] = 0} +/* start in tails */ + matrix `b' = (1,1) + matrix M_zps`n' = M_zps`n'#`b' + matrix M_zps`n' = M_zps`n'[1,1..`n'] + matrix `b' = (1,-1) + matrix M_zlc`n' = M_zlc`n'#`b' + matrix M_zlc`n' = M_zlc`n'[1,1..`n'] + +/* other alternative (start in centre) */ +/* + matrix `b' = J(1,`n',0) + local i = 1 + while ( `i'<=`n'){ + matrix `b'[1, `i'] = M_zlc`n'[1, `n'+1-`i'] + local i = `i' + 1 + } + matrix M_zlc`n' = `b' + local i = 1 + while ( `i'<=`n'){ + matrix `b'[1, `i'] = M_zps`n'[1, `n'+1-`i'] + local i = `i' + 1 + } + matrix M_zps`n' = `b' +*/ +/* end other alternative */ + matrix M_zlc`n' = M_zlc`n'* sqrt(2) +end + + +program define hermite /* integer n, scalar x, scalar w */ +* stolen from rfprobit (Bill Sribney) + version 4.0 + local n "`1'" + local x "`2'" + local w "`3'" + local last = `n' + 2 + tempname i p + matrix `p' = J(1,`last',0) + scalar `i' = 1 + while `i' <= 10 { + matrix `p'[1,1]=0 + matrix `p'[1,2] = _pi^(-0.25) + local k = 3 + while `k'<=`last'{ + matrix `p'[1,`k'] = `x'*sqrt(2/(`k'-2))*`p'[1,`k'-1] /* + */ - sqrt((`k'-3)/(`k'-2))*`p'[1,`k'-2] + local k = `k' + 1 + } + scalar `w' = sqrt(2*`n')*`p'[1,`last'-1] + scalar `x' = `x' - `p'[1,`last']/`w' + if abs(`p'[1,`last']/`w') < 3e-14 { + scalar `w' = 2/(`w'*`w') + exit + } + scalar `i' = `i' + 1 + } + di in red "hermite did not converge" + exit 499 +end + + +program define lebesque + version 5.0 + local n `1' + tempname pt a b + scalar `a' = 1/`n' + matrix M_zps`n' = J(1,`n',`a') + local i = 1 + local m = int((`n' + 1)/2) + matrix M_zlc`n' = J(1,`m',0) + while(`i'<=`m'){ + scalar `pt' = `i'/`n' -1/(2*`n') + matrix M_zlc`n'[1,`i']=invnorm(`pt') + local i = `i' + 1 + } +/* start in tails */ + matrix `b' = (1,-1) + matrix M_zlc`n' = M_zlc`n'#`b' + matrix M_zlc`n' = M_zlc`n'[1,1..`n'] +/* other alternative: left to right */ +/* + while ( `i'<=`n'){ + matrix M_zlc`n'[1, `i'] = -M_zlc`n'[1, `n'+1-`i'] + local i = `i' + 1 + } +*/ +end + +program define disprand +version 6.0 +* displays additional information about random effects +* disp "running disprand " +disp " " +if "e(tplv)" == ""{ + * estimates not found + exit +} +tempname var b se cor mn0 mm0 +matrix `b' = e(b) +local names: colnames(`b') +tempname M_nrfc M_nip M_nbrf M_nffc M_b V M_frld + +matrix `V' = e(V) +matrix `M_nrfc' = e(nrfc) +matrix `M_nip' = e(nip) +matrix `M_nbrf' = e(nbrf) +matrix `M_nffc' = e(nffc) +matrix `M_frld' = e(frld) +local ngeqs = e(ngeqs) +local bmat = e(bmat) +if `bmat' ==1{matrix `M_b' = e(mb)} +local bmat = e(bmat) +local iscor = e(cor) +local nxt = `M_nffc'[1,colsof(`M_nffc')]+1 +local free = e(free) +local tplv = e(tplv) +local lev1 = e(lev1) +local tprf = e(tprf) +local cip = e(cip) +local nats = e(nats) +if `free'{ + tempname M_np + matrix `M_np' = e(mnp) +} + +local nrfold = `M_nrfc'[2,1] +if `M_nbrf'[1,1]>0{ + if `lev1' == 1 {disp in gr "Variance at level 1"} + else if `lev1' == 2 {disp in gr "Squared Coefficient of Variation"} + else if `lev1' == 3 {disp in gr "Dispersion at level 1"} + *disp in smcl in gr "{hline 78}" _n + di in gr _dup(78) "-" _n + if `M_nbrf'[1,1]==1{ + if `nats'{ + scalar `var' = `b'[1, `nxt']^2 + scalar `se' = 2*sqrt(`var'*`V'[`nxt',`nxt']) + disp in gr " " in ye `var' " (" `se' ")" + } + else{ + scalar `var' = exp(2*`b'[1, `nxt']) + scalar `se' = 2*`var'*sqrt(`V'[`nxt',`nxt']) + disp in gr " " in ye `var' " (" `se' ")" + } + local nxt = `nxt' + 1 + } + else{ + local log "log " + if `nats'{ + local log + } + disp " " + if `lev1'==1{disp in gr " equation for `log'standard deviation: "} + else if `lev1'==2{disp in gr " equation for `log'coefficient of variation"} + else if `lev1'==3{disp in gr " equation for `log'(sqrt(phi))"} + disp " " + local i = 1 + while `i' <= `M_nbrf'[1,1]{ + scalar `var' = `b'[1,`nxt'] + scalar `se' = sqrt(`V'[`nxt',`nxt']) + local nna: word `nxt' of `names' + disp in gr " `nna': " in ye `var' " (" `se' ")" + local i = `i' + 1 + local nxt = `nxt' + 1 + } + } +} + +if `tplv' > 1{ +local lev = 2 +if `free' == 1{ + disp " " + disp in gr "Probabilities and locations of random effects" +} +else{ + disp " " + disp in gr "Variances and covariances of random effects" +} +*disp in smcl in gr "{hline 78}" _n +di in gr _dup(78) "-" _n +*disp in gr "-----------------------------------------------------------------------------" +while (`lev' <= `tplv'){ + local nip = `M_nip'[1,`lev'] + local sof = `M_nrfc'[2,`lev'-1] /* `M_nrfc'[1,`lev'-1] */ + disp " " + local cl = `tplv' - `lev' + 1 + local cl: word `cl' of `e(clus)' + disp in gr "***level `lev' (" in ye "`cl'" in gr ")" + if `free' == 1{ + tempname M_zps`lev' + matrix `M_zps`lev'' = e(zps`lev') + } + local i2 = `M_nrfc'[2,`lev'] + local i1 = `nrfold'+1 + local num = `i2' -`i1' + 1 /* number of random effects */ + if `free'==0{ + * get standard errors of variances from those of cholesky decomp. + *disp "sechol `lev' `num' `nxt'" + qui sechol `lev' `num' `nxt' + } + local k = 1 + local i = `i1' + local ii = 1 + local nrfold = `M_nrfc'[2,`lev'] + while `i'<= `i2'{ + local n=`M_nip'[2,`i'] + if `free'==1{ + tempname M_zlc`n' + matrix `M_zlc`n'' = e(zlc`n') + local j = 2 + local zz=string(`M_zlc`n''[1,1],"%7.0gc") + local mm "`zz'" + scalar `mn0' = `M_zlc`n''[1,1]*exp(`M_zps`lev''[1,1]) + while `j'<=`nip'{ + scalar `mn0' = `mn0' + `M_zlc`n''[1,`j']*exp(`M_zps`lev''[1,`j']) + local zz=string(`M_zlc`n''[1,`j'],"%7.0gc") + local mm "`mm'" ", " "`zz'" + local j = `j' + 1 + } + disp " " + disp in gr " loc`ii': " in ye "`mm'" + } + local j = `i1' + local jj = 1 + while (`j'<=`i'){ + if `free'==1{ + local m = `M_nip'[2,`j'] + capture tempname M_zlc`m' + matrix `M_zlc`m'' = e(zlc`m') + scalar `mm0'=0 + local mm = 1 + while `mm'<=`nip'{ + scalar `mm0' = `mm0' + `M_zlc`m''[1,`mm']*exp(`M_zps`lev''[1,`mm']) + local mm = `mm' + 1 + } + + local l = 1 + scalar `var' = 0 + while `l'<=`nip'{ + scalar `var' = `var' + /* + */ (`M_zlc`n''[1,`l']-`mn0')*(`M_zlc`m''[1,`l']-`mm0')*exp(`M_zps`lev''[1,`l']) + local l = `l' + 1 + } + if `i' == `j'{ + disp in gr " var(`ii'): " in ye `var' + local nb = `M_nbrf'[1,`ii'+`sof'] + if `nb'>1{ + disp " " + disp in gr " loadings for random effect " `ii' + local load = `nxt' + `nb' - 1 + if `M_frld'[1,`j']==0{ + local nna: word `load' of `names' + disp in gr " `nna': " in ye 1 " (fixed)" + } + + *disp in gr " coefficient of" + local load = 1 + while `load'<=`nb'-1{ + local nna: word `nxt' of `names' + scalar `var'=`b'[1,`nxt'] + scalar `se' = sqrt(`V'[`nxt',`nxt']) + disp in gr " `nna': " in ye `var' " (" `se' ")" + local nxt = `nxt' + 1 + local load = `load' + 1 + } + disp " " + } + local nxt = `nxt' + 1 /* skip location parameter */ + * disp "increased nxt to" `nxt' + if `i'==`i2'{ + local l = 2 + local zz=string(exp(`M_zps`lev''[1,1]),"%6.0gc") + if `nip'>1{ + local mm "0`zz'" + } + else{ + local mm "1" + } + + while `l'<=`nip'{ + local zz=string(exp(`M_zps`lev''[1,`l']),"%6.0gc") + local mm "`mm'" ", " "0`zz'" + local l = `l' + 1 + } + disp in gr " prob: " in ye "`mm'" + + *new + *** display log odds with standard errors + local npar = `M_np'[1,`lev'] + if `npar' == 0 { local npar = 1} + if `npar'>1{ + disp " " + disp in gr " log odds parameters" + } + local l = 1 + while `l'< `nip'{ + if `npar'>1{ + if `l'>1 { + disp " " + } + disp in gr " class `l'" + } + local load = 1 + local ncur = `nxt' + (`l' - 1)*`num' + (`l' - 1)*`npar' - 1 + while `load'<=`npar'{ + local ncur = `ncur' + 1 + * disp "nxt = `nxt', nb = `nb', num = `num' and ncur = `ncur'" + local nna: word `ncur' of `names' + scalar `var'=`b'[1,`ncur'] + scalar `se' = sqrt(`V'[`ncur',`ncur']) + if `npar'>1{ + disp in gr " `nna': " in ye `var' " (" `se' ")" + } + local load = `load' + 1 + } + local l = `l' + 1 + } + local nxt = `ncur' + 1 + } +* end new + } + else{ + disp in gr "cov(`ii',`jj'): " in ye `var' + } + } + else{/* free=0 */ + * disp "k= " `k' ", i= " `i' ", j= " `j' ", ii= " `ii' ", jj= " `jj' + + scalar `var' = M_cov[`ii', `jj'] + scalar `se' = sqrt(M_se[`k', `k']) + if `i' == `j'{ + disp " " + disp in gr " var(`ii'): " in ye `var' " (" `se' ")" + local nb = `M_nbrf'[1,`ii'+`sof'] + if `nb'>1{ + disp " " + disp in gr " loadings for random effect " `ii' + local load = `nxt' + `nb' -1 + if `M_frld'[1,`j']==0{ + local nna: word `load' of `names' + disp in gr " `nna': " in ye 1 " (fixed)" + } + + * disp in gr " coefficient of" + local load = 1 + while `load'<=`nb'-1{ + local nna: word `nxt' of `names' + * disp "nxt = " `nxt' + scalar `var'=`b'[1,`nxt'] + scalar `se' = sqrt(`V'[`nxt',`nxt']) + disp in gr " `nna': " in ye `var' " (" `se' ")" + local nxt = `nxt' + 1 + local load = `load' + 1 + } + disp " " + } + * skip variance parameter + local nxt = `nxt' + 1 + } + else{ + if `iscor'==0{ + disp in gr " cov(`ii',`jj'): " in ye "fixed at 0" + } + else{ + scalar `cor' = `var'/sqrt(M_cov[`ii',`ii']*M_cov[`jj',`jj']) + disp in gr " cov(`ii',`jj'): " in ye `var' " (" `se' ")" /* + */ " cor(`ii',`jj'): " `cor' + *local nxt = `nxt' + 1 + } + } + } + + local j = `j' + 1 + local jj = `jj' + 1 + local k = `k' + 1 + } + local i = `i' + 1 + local ii = `ii' + 1 + } +local lev = `lev' + 1 +/* skip off-diagonal cholesky parameters */ +if `iscor'~=0&`free'==0{local nxt = `nxt' + `num'*(`num'-1)/2} /* -1? */ +*disp "next nxt is " `nxt' +/* +if `free'{ + local nxt = `nxt'+(`nip'-1)*(`num'+1) + if `cip'==0{ + local nxt = `nxt'+`num' + } + local nxt = `nxt' - 1 +} +*/ +*disp "next nxt is " `nxt' +} +if `tprf'>1&`bmat'==1{ + disp " " + disp in gr "B-matrix:" + *disp in smcl in gr "{hline 78}" _n + di in gr _dup(78) "-" _n + disp " " + disp " " + * disp "nxt = " `nxt' + local i = 1 + while `i'<`tprf'{ + local j = 1 + while `j' < `tprf'{ + if `M_b'[`i',`j']>0{ + scalar `var' =`b'[1,`nxt'] + scalar `se' = sqrt(`V'[`nxt',`nxt']) + disp in gr " B(`i',`j'): " in ye `var' " (" `se' ")" + local nxt = `nxt' + 1 + } + local j = `j' + 1 + } + local i = `i' + 1 + } +} +if `ngeqs'>0{ + disp " " + disp in gr "Regressions of latent variables on covariates" + *disp in smcl in gr "{hline 78}" _n + di in gr _dup(78) "-" _n + disp " " + tempname mngeqs + matrix `mngeqs' = e(mngeqs) + local i = 1 + while `i'<=`ngeqs'{ + local k = `mngeqs'[1,`i'] + local n = `mngeqs'[2,`i'] + disp in gr " random effect " in ye `k'-1 in gr " has " in ye `n' in gr " covariates:" + local nxt2 = `nxt'+`n'-1 + local j = 1 + while `j' <= `n'{ + local nna: word `nxt' of `names' + scalar `var'=`b'[1,`nxt'] + scalar `se' = sqrt(`V'[`nxt',`nxt']) + disp in gr " `nna': " in ye `var' " (" `se' ")" + local nxt = `nxt' + 1 + local j = `j' + 1 + } + local i = `i' + 1 + } +} +*disp in smcl in gr "{hline 78}" _n +di in gr _dup(78) "-" _n +disp " " +} /* endif toplv >1 */ +end + +program define sechol + version 6.0 + args lev num nxt + * num is number of random effects + local l = `num'*(`num' + 1)/2 + *disp "lev = `lev' num = `num' nxt = `nxt' l= `l'" + tempname b V C L zero a H M_nbrf M_nrfc ind + + matrix `M_nbrf' = e(nbrf) + matrix `M_nrfc' = e(nrfc) + local iscor = e(cor) + matrix `b' = e(b) + matrix `V' = e(V) + local sof = `M_nrfc'[2,`lev'-1] /* was `M_nrfc'[1,`lev'-1] */ + local i = 1 + local k = 1 + matrix `C' = J(`l',`l',0) + matrix `L' = J(`num',`num',0) + matrix `ind' = `L' + * get L matrix + while `i' <= `num'{ + * skip loading parameters + local nb = `M_nbrf'[1,`i'+`sof'] + local nxt = `nxt' + `nb' -1 + disp "nxt = " `nxt' + matrix `L'[`i',`i'] = `b'[1, `nxt'] + * matrix list `L' + matrix `ind'[`i',`i'] = `nxt' + local nxt = `nxt' + 1 + local i = `i' + 1 + } + local i = 2 + while `i' <= `num'&`iscor'==1{ + local j = 1 + while `j' < `i'{ + matrix `L'[`i',`j'] = `b'[1, `nxt'] + matrix `ind'[`i',`j'] = `nxt' + local nxt = `nxt' + 1 + local j = `j' + 1 + } + local i = `i' + 1 + } + * disp "L and ind" + * matrix list `L' + * matrix list `ind' + * get C matrix + local ll1 = 1 + local i = 1 + while `i' <= `num'{ + local j = 1 + while `j' <= `i'{ + local nxt1 = `ind'[`i', `j'] + local ll2 = 1 + local ii = 1 + while `ii' <= `num'{ + local jj = 1 + while `jj' <= `ii'{ + local nxt2 = `ind'[`ii', `jj'] + disp "ll1 = " `ll1' " ll2 = " `ll2' " nxt1 = " `nxt1' " nxt2 = " `nxt2' + if `iscor' == 1{ + matrix `C'[`ll1', `ll2'] = `V'[`nxt1',`nxt2'] + matrix `C'[`ll2', `ll1'] = `C'[`ll1', `ll2'] + } + else if `i'==`j'&`ii'==`jj'{ + matrix `C'[`ll1', `ll2'] = `V'[`nxt1',`nxt2'] + matrix `C'[`ll2', `ll1'] = `C'[`ll1', `ll2'] + } + local ll2 = `ll2' + 1 + local jj = `jj' + 1 + } + local ii = `ii' + 1 + } + local ll1 = `ll1' + 1 + local j = `j' + 1 + } + local i = `i' + 1 + } + + * disp "C" + * matrix list `C' + matrix `zero' = J(`num', `num', 0) + local k = 1 + local i = 1 + local n = `num' * (`num' + 1)/2 + matrix `H' = J(`n',`n',0) + while `i' <= `num' { + local j = 1 + while `j' <= `i'{ + * derivative of LL' with respect to i,j th element of L + mat `a' = `zero' + mat `a'[`i',`j'] = 1 + mat `a' = `a'*(`L')' + mat `a' = `a' + (`a')' + disp "a" + * matrix list `a' + local ii = 1 + local kk = 1 + while `ii'<=`num'{ + local jj = 1 + while `jj' <= `ii'{ + matrix `H'[`kk',`k'] = `a'[`ii',`jj'] + local jj = `jj' + 1 + local kk = `kk' + 1 + } + local ii= `ii' + 1 + } + local j = `j' + 1 + local k = `k' + 1 + } + local i = `i' + 1 + } + * disp "H" + * matrix list `H' + matrix M_se = `H'*`C'*(`H')' + matrix M_cov = `L'*(`L')' + * matrix list M_se + * matrix list M_cov + +end + +program define timer +version 6.0 +end diff --git a/Modules/raschpower.ado b/Modules/raschpower.ado new file mode 100644 index 0000000..1345c66 --- /dev/null +++ b/Modules/raschpower.ado @@ -0,0 +1,908 @@ +*! version 5.12 : Novembre 19, 2021 +*! Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot +************************************************************************************************************ +* raschpower: Estimation of the power of the Wald test in order to compare the means of the latent trait in two groups of individuals +* +* Version 1 : January 25th, 2010 (Jean-Benoit Hardouin) +* Version 1.1 : January 26th, 2010 (Jean-Benoit Hardouin) +* Version 1.2 : November 1st, 2010 (Jean-Benoit Hardouin) +* version 1.3 : May 2nd, 2011 (Jean-Benoit Hardouin) +* version 1.4 : July 7th, 2011 (Jean-Benoit Hardouin) : minor corrections +* version 1.5 : July 11th, 2011 (Jean-Benoit Hardouin) : minor corrections +* version 2 : August 30th, 2011 (Jean-Benoit Hardouin, Myriam Blanchin) : corrections +* version 3 : October 18th, 2011 (Jean-Benoit Hardouin, Myriam Blanchin) : Extension to the PCM, -method- option, -nbpatterns- options, changes in the presentation of the results +* version 3.1 : October 25th, 2011 (Jean-Benoit Hardouin, Myriam Blanchin) : POPULATION+GH method +* version 3.2 : February 6th, 2012 (Jean-Benoit Hardouin, Myriam Blanchin) : minor corrections +* version 4 : January 30th, 2013 (Jean-Benoit Hardouin, Myriam Blanchin) : Extension to longitudinal design +* version 4.1 : June 3rd, 2013 (Jean-Benoit Hardouin, Myriam Blanchin) : detail option +* version 5 : October 22th, 2013 (Jean-Benoit Hardouin, Myriam Blanchin) : Extension to longitudinal design with polytomous items +* version 5.1 : January 21th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin) : unequal variance between groups +* version 5.2 : January 22th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin) : unequal variance between groups +* version 5.3 : January 29th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin) : correction of a bug +* version 5.4 : April 4th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot) : HTML option, graph option, minor corrections for results display +* version 5.5 : April 9th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot) : graph option for longitudinal design +* version 5.6 : April 10th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot) : corrections of bugs +* version 5.7 : June 21th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot) : minor corrections +* version 5.8 : July 9th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot) : correction of a bug when the variances are different in the 2 groups (transversal) +* version 5.9 : September 26th, 2014 (Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot) : fixed of a bug with the graph option (correlation could be greater than one) +* version 5.10 : July 18th, 2019 (Jean-Benoit Hardouin) : filesave and dirsave options +* version 5.11 : July 24th, 2019 (Jean-Benoit Hardouin) : pcm->pcmold +* version 5.12 : July 24th, 2019 (Myriam Blanchin) : correction of bug (essai.dta) + +* Jean-benoit Hardouin, jean-benoit.hardouin@univ-nantes.fr +* Myriam Blanchin, myriam.blanchin@univ-nantes.fr +* Bastien Perrot, Bastien.perrot@univ-nantes.fr +* INSERM UMR 1246-SPHERE "Methods in Patient Centered Outcomes and Health Research", Nantes University, University of Tours +* http://www.sphere-nantes.org +* +* News about this program : http://www.anaqol.org - anaqol@sphere-nantes.fr +* +* Copyright 2010-2014, 2019 Jean-Benoit Hardouin, Myriam Blanchin, Bastien Perrot +* +* This program is free software; you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation; either version 2 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program; if not, write to the Free Software +* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +************************************************************************************************************/ + +program define raschpower,rclass +syntax [varlist] [, n0(int 100) n1(int 100) Gamma(real .5) Difficulties(string) Var(string) Method(string) NBPatterns(int 2) nodata EXPectedpower(real -1) LONGitudinal freevar freeitems DETail HTML(string) graph gvar(real -1) gcorr(real -1) min(real 0.25) step(real 1) max(real 9) FILESave DIRSave(string) pro] +version 11 + +if "`pro'"!="" { + di "START" +} + +if "`html'" != "" { + set scheme sj + local htmlregion "graphregion(fcolor(white) ifcolor(white))" + di "" + di "
"
+}
+
+tempfile raschpowerfile
+capture qui save "`raschpowerfile'",replace
+tempname db d dlong matvar
+
+/*******************************************************************************
+DEFINITION DES PARAMETRES
+*******************************************************************************/
+
+if "`graph'" != "" & "`longitudinal'" != "" {
+	if `gvar' != -1 & `gcorr' != -1 {
+		di in red "You cannot use both {hi:gvar} and {hi:gcorr}"
+		error 198
+	}
+	if `gvar' == -1 & `gcorr' == -1 {
+		di in red "You must precise values for {hi:gvar} or {hi:gcorr} if you use the {hi:graph} option"
+		error 198
+	}
+}
+
+if "`difficulties'"=="" {
+   matrix `d'=[-1\-0.5\0\0.5\1]
+}
+else {
+   matrix `d'=`difficulties'
+}
+local nbitems=rowsof(`d')
+local nbmodat=colsof(`d')+1
+
+if "`longitudinal'"==""{ /*CAS TRANSVERSAL*/
+	local nbt=1
+	local nbtotitems=`nbitems'
+	local nbpatmax=2*`nbmodat'^`nbitems'
+	if "`var'"==""{
+		local var=1
+		local var0=1
+		local var1=1
+	}
+	else{
+		capture confirm number `var'
+		if !_rc {
+			local var0=`var'
+			local var1=`var'
+		}
+		else{
+		   local nbw:word count `var'
+		   local grp=1
+		   if `nbw'==2 {
+				local t1: word 1 of `var'
+                capture confirm number `t1'
+				if !_rc {
+					local t2: word 2 of `var'
+                    capture confirm number `t2'
+                    if !_rc {
+                       local var0=`t1'
+                       local var1=`t2'
+                       local grp=2
+                    }
+				}
+			}
+			if `nbw'!=2|`grp'==1 {
+				capture confirm matrix `var'
+			    if !_rc & colsof(`matvar')==1 & rowsof(`matvar')==1{
+				    matrix `matvar'=`var'
+					local var0=`matvar'[1,1]
+					local var1=`matvar'[1,1]
+			    }
+			    else{
+					di in red "{p}The {hi:var} option should contain a number or a 1x1 matrix for transversal studies{p_end}"
+					error 198
+					exit
+			    }
+		    }
+		}
+	}
+	matrix `dlong'=`d' /*DEMANDER A MYRIAM A QUOI CA SERT CAR ON EST EN TRANSVERSAL*/
+    local varc=((`n0'-1)*`var0'+(`n1'-1)*`var1')/(`n0'+`n1'-2)
+
+	local sumd=0
+	forvalues numit=1/`nbitems'{
+		local sumd=`sumd'+`d'[`numit',1]
+	}
+	local sumd=`sumd'/`nbitems'
+	if `=abs(`sumd')'>=`=2*sqrt(`varc')'{
+		if "`html'" == "" {
+			di  "{p}WARNING: It is not recommended to use Raschpower when the gap between the global mean of the latent trait (fixed to 0) and the mean of the item parameters is greater than or equal to 2 standard deviation of the latent trait. {p_end}"
+		}
+	}
+
+}
+else{ /*CAS LONGITUDINAL*/
+	local nbt=2
+	local nbtotitems=2*`nbitems'
+	local nbpatmax=`nbmodat'^(`nbitems'*2)
+	local n1=0
+	local mean1=0
+	local mean2=`mean1'+`gamma'
+	if "`var'"==""{
+		matrix `matvar'=(1,0\0,1)
+	}
+	else{
+		matrix `matvar'=`var'
+		capture confirm matrix `matvar'
+		if _rc | colsof(`matvar')!=2 | rowsof(`matvar')!=2{
+			di in red "{p}The {hi:var} option should contain a 2x2 matrix for longitudinal studies{p_end}"
+			error 198
+			exit
+		}
+	}
+	matrix `dlong'=J(`nbtotitems',`=`nbmodat'-1',.)
+	matrix `dlong'[1,1]=`d'
+	matrix `dlong'[`=`nbitems'+1',1]=`d'
+}
+
+/*
+if "`max'" == "" {
+	local max = 9 + `step'/2
+}
+else {
+	local max = `max' + `step'/2
+}*/
+
+forval v = `min'(`step')`max' {
+	local w = `v'
+}
+if `w' < `max' {
+	local max = `max' + `step'
+}
+if "`longitudinal'"!="" & `gvar'!=-1 {                
+	local max = min(`max',0.99999)    /* pour avoir des corrélations < 1 */
+}
+
+/*******************************************************************************
+DEFINITION DE LA METHODE
+*******************************************************************************/
+
+if substr("`method'",1,3)=="pop" | substr("`method'",1,3)=="POP"{
+	local method POPULATION+GH
+}
+
+if "`method'"=="MEAN+GH"&`nbpatterns'*(`n1'+`n0')>=`nbpatmax' {
+   di in gr "The MEAN+GH will be inefficient compared to GH since the maximal number of pattern's responses"
+   di in gr "is lesser than the number of pattern retained by the MEAN+GH method."
+   di in gr "The -method- option is replaced by GH."
+   local method GH
+}
+else if ("`method'"=="MEAN+GH" | "`method'"=="MEAN") & `nbpatmax'>1000000{
+	di in red "The number of patterns is too high for the chosen method"
+	exit
+}
+else if "`method'"=="" {
+    if `nbpatmax'<2000 {
+        local method GH
+    }
+    else  {
+        local method POPULATION+GH
+    }
+}
+
+if "`method'"!="MEAN+GH" & "`method'"!="MEAN" & "`method'"!="GH" & "`method'"!="POPULATION+GH"{
+	di in red "Invalid method name"
+	exit
+}
+
+/*******************************************************************************
+AFFICHAGE DES PARAMETRES
+*******************************************************************************/
+
+if "`longitudinal'"==""{
+	di in gr "Number of individuals in the first group: " in ye `n0'
+	di in gr "Number of individuals in the second group: " in ye `n1'
+	di in green "Group effect: " in ye `gamma'
+	di in  gr "Variance of the latent trait in the first group: " in ye `var0'
+	di in  gr "Variance of the latent trait in the second group: " in ye `var1'
+}
+else{
+	di in gr "Number of individuals at each time:  " in ye `n0'
+	di in green "Time effect: " in ye `gamma'
+	di in  gr "Variance matrix of the latent trait: " 
+	matrix list `matvar',noheader
+	di
+}
+di in gr "Number of items: " in ye `nbitems'
+di in green "Difficulties parameters of the items: "
+tempname dd
+matrix `dd'=`d''
+local items
+forvalues i=1/`nbitems' {
+   local items "`items' item`i'"
+}
+local modalities
+forvalues i=1/`=`nbmodat'-1' {
+   local modalities "`modalities' delta_`i'"
+}
+
+matrix colnames `dd'=`items'
+matrix rownames `dd'=`modalities'
+
+
+di
+tempname ddt
+matrix `ddt' = `dd''
+matrix colnames `ddt'=`modalities'
+matrix rownames `ddt'=`items'
+if "`html'" != "" {
+	matrix list `ddt',noblank nohalf noheader /* affiche la matrice des difficultés dans l'autre sens */
+}
+else {
+	matrix list `dd',noblank nohalf noheader
+}
+di
+
+if "`detail'"!="" & "`html'" == ""{
+	di in gr "Method:  " in ye "`method'"
+	di in gr "Number of studied response's patterns: " in ye `nbpatmax'
+}
+matrix `dd'=`d'
+local gamma=`gamma'
+
+local tmp=1
+qui matrix `db'=J(`=`nbitems'*(`nbmodat'-1)',1,.)
+forvalues j=1/`nbitems' {
+	forvalues m=1/`=`nbmodat'-1' {
+		qui matrix `db'[`tmp',1]=`d'[`j',`m']
+		local ++tmp
+	}
+}
+
+
+/*******************************************************************************
+CREATION DU DATASET ATTENDU 
+*******************************************************************************/
+
+if "`data'"=="" {
+	clear
+	if "`method'"!="POPULATION+GH"{
+		local temp=`nbmodat'^(`nbtotitems')
+		qui range x 0 `=`temp'-1' `temp'
+		qui g t=x
+		loc i=`nbtotitems'
+		qui count if t>0
+		loc z=r(N)
+		qui while `z'>0 {
+			qui gen item`=`nbtotitems'-`i'+1'=floor(t/`nbmodat'^`=`i'-1')
+			qui replace t=mod(t,`nbmodat'^`=`i'-1')
+			qui count if t>0
+			loc z=r(N)
+			loc i=`i'-1
+		}
+		drop t
+		if "`longitudinal'"==""{
+			qui expand 2
+			qui gen group=0 in 1/`temp'
+			qui replace group=1 in `=`temp'+1'/`=2*`temp''
+		}	
+	}
+	else { /*METHODE POPULATION (SIMULATION)*/
+		if "`longitudinal'"==""{
+			*qui simirt, clear pcm(`d') cov(`var') group(`=`n1'*`gamma'/(`n1'+`n0')') deltagroup(`gamma') nbobs(1000000)
+			qui simirt, clear pcm(`d') cov(`var1') mu(`=`n0'*`gamma'/(`n1'+`n0')') nbobs(`=round(`n1'/(`n1'+`n0')*1000000)')
+			qui gen group=1
+			tempfile save1
+			qui save `save1',replace
+			qui simirt, clear pcm(`d') cov(`var0') mu(`=-`n1'*`gamma'/(`n1'+`n0')') nbobs(`=round(`n0'/(`n1'+`n0')*1000000)')
+			qui gen group=0
+			qui append using `save1'
+			*qui save d:\tmp,replace
+            bysort group:su lt
+			qui drop lt1
+			qui contract item* group, freq(freq)
+			qui count
+			local patobs=r(N)
+			if `patobs'>=`=(`n0'+`n1')*`nbpatterns''{
+				qui gen keep=0
+				qui gsort +group -freq
+				qui replace keep=1 in 1/`=`nbpatterns'*`n0''
+				qui gsort -group -freq
+				qui replace keep=1 in 1/`=`nbpatterns'*`n1''
+			}
+			else{
+				qui gen keep=1
+			}
+		}
+		else{
+			qui simirt, clear pcm(`dlong') covmat(`matvar') mu(`mean1' `mean2') dim(`nbitems' `nbitems') nbobs(1000000)
+			forvalues j=1/`nbitems'{
+				rename itemA`j' item`j'
+				rename itemB`j' item`=`nbitems'+`j''
+			}
+			qui drop lt1 lt2
+			qui contract item*, freq(freq)
+			local patobs=r(N)
+			if `patobs'>=`=`n0'*`nbpatterns''{
+				qui gen keep=0
+				qui gsort -freq
+				qui replace keep=1 in 1/`=`nbpatterns'*`n0''
+			}
+			else{
+			  qui gen keep=1
+			}
+		}
+		qui keep if keep==1
+		qui count
+		local retain=r(N)
+		di "Number of kept patterns:`retain'"
+		local method GH
+	}
+	if "`longitudinal'"==""{
+		qui gen mean1=-`n1'*`gamma'/(`n0'+`n1') if group==0
+		qui replace mean1=`n0'*`gamma'/(`n0'+`n1') if group==1
+		qui gen var1=`var0' if group==0
+		qui replace var1=`var1' if group==1
+	}
+	else{
+		qui gen mean1=`mean1'
+		qui gen mean2=`mean2'
+	}
+	/*CALCUL DES PROBAS PAR PATTERNS DE REPONSE*/
+	if "`method'"=="GH" {
+		local temp=`nbmodat'^(`nbtotitems')
+		local diff0=0
+		qui gen proba=.
+		local dixj=10
+		qui count
+		local tmp=r(N)
+
+		forvalues i=1/`tmp' {
+			local dix=floor(`tmp'/10)
+			if mod(`i',`dix')==0 & "`html'"=="" {
+			    qui su proba
+				local tmpprob=r(sum)
+				if "`dixj'"!="10" {
+					di ".." _c
+				}
+				*di "`dixj'% (`tmpprob')" _c
+				di "`dixj'%" _c
+				local dixj=`dixj'+10
+			}
+			forvalues t=1/`nbt'{
+				local int`t'=1			 
+				forvalues j=`=(`t'-1)*`nbitems'+1'/`=`t'*`nbitems'' {
+					qui su item`j' in `i'
+					local rep=r(mean)
+					local diff0=0
+					local diff1=`dlong'[`j',1]
+					local sum "1+exp(x`t'-`diff1')"
+					forvalues m=2/`=`nbmodat'-1' {
+					   local diff`m'=`diff`=`m'-1''+`dlong'[`j',`m']
+					   local sum "`sum'+exp(`m'*x`t'-`diff`m'')"
+					}
+					local int`t' "(`int`t''*exp(`rep'*x`t'-`diff`rep''))/(`sum')"
+				}
+			}	
+			if "`longitudinal'"==""{
+				qui su mean1 in `i'
+				local mean=r(mean)
+				qui su var1 in `i'
+				local vart=r(mean)
+				*di "gausshermite `int1',mu(`mean') sigma(`=sqrt(`vart')') display name(x1)"
+				*prout
+				qui gausshermite `int1',mu(`mean') sigma(`=sqrt(`vart')') display name(x1)
+				qui replace proba=r(int) in `i'
+			}
+			else{
+				local int "`int1'*`int2'"
+				matrix mean=(`mean1',`mean2')
+				qui gausshermite `int',mu(mean) var(`matvar') display name(x1 x2)
+				qui replace proba=r(int) in `i'
+			}
+		}
+		di
+	}
+	else { /*if "`method'"!="GH"*/
+		qui gen proba=1
+		forvalues t=1/`nbt'{
+			forvalues i=`=(`t'-1)*`nbitems'+1'/`=`t'*`nbitems'' {
+				local diff0=0
+				local diff1=`dlong'[`i',1]
+				qui gen eps0=1
+				qui gen eps1=exp(mean`t'-`diff1')
+				qui gen d=eps0+eps1
+				forvalues m=2/`=`nbmodat'-1' {
+					local diff`m'=`diff`=`m'-1''+`dlong'[`i',`m']
+					qui gen eps`m'=exp(`m'*mean`t'-`diff`m'')
+					qui replace d=d+eps`m'
+				}
+				local listeps
+				forvalues m=0/`=`nbmodat'-1' {
+					qui replace proba=proba*eps`m'/d if item`i'==`m'
+					local listeps `listeps' eps`m'
+				}
+				qui drop `listeps' d
+			}
+		}
+		if "`method'"=="MEAN+GH" {
+			set tracedepth 1
+			if "`longitudinal'"==""{
+				qui gen keep=0
+				qui gsort -group -proba
+				local min=min(`=`nbmodat'^`nbitems'',`=`n1'*`nbpatterns'')
+				qui replace keep=1 in 1/`min'
+				qui gsort +group -proba
+				local min=min(`=`nbmodat'^`nbitems'',`=`n0'*`nbpatterns'')
+				qui replace keep=1 in 1/`min'
+				qui keep if keep==1
+				qui su proba if group==0
+				local sumproba0=r(sum)*100
+				qui su proba if group==1
+				local sumproba1=r(sum)*100
+			}
+			else{
+				qui gen keep=0
+				qui gsort -proba
+				local min=min(`nbpatmax',`=`n0'*`nbpatterns'')
+				qui replace keep=1 in 1/`min'
+				qui keep if keep==1
+			}
+
+			qui drop keep proba
+			local diff0=0
+			qui gen proba=.
+			qui count
+			local nnew=r(N)
+			di in gr "Number of studied response's patterns for the GH step: " in ye `nnew'
+			if "`longitudinal'"==""{
+				di in gr "(" in ye %6.2f `sumproba0' in gr "% of the group 0 and " in ye %6.2f `sumproba1' in gr "% of the group 1)"
+			}
+			local dixj=10
+			forvalues i=1/`nnew' {
+				local dix=floor(`nnew'/10)
+				if mod(`i',`dix')==0 & "`html'"=="" {
+				    qui su proba
+					local sum=r(sum)
+					if "`dixj'"!="10" {
+						di ".." _c
+					}
+					di "`dixj'% (`sum')" _c
+					local dixj=`dixj'+10
+				}
+				forvalues t=1/`nbt'{
+					local int`t'=1
+					forvalues j=`=(`t'-1)*`nbitems'+1'/`=`t'*`nbitems'' {
+						qui su item`j' in `i'
+						local rep=r(mean)
+						local diff0=0
+						local diff1=`dlong'[`j',1]
+						local sum "1+exp(x`t'-`diff1')"
+						forvalues m=2/`=`nbmodat'-1' {
+							local diff`m'=`diff`=`m'-1''+`dlong'[`j',`m']
+							local sum "`sum'+exp(`m'*x`t'-`diff`m'')"
+						}
+						local int`t' "(`int`t''*exp(`rep'*x`t'-`diff`rep''))/(`sum')"
+					}
+				}
+				if "`longitudinal'"==""{
+					qui su mean1 in `i'
+					local mean=r(mean)
+					qui su var1 in `i'
+					local vart=r(mean)
+					*di "qui gausshermite `int1',mu(`mean') sigma(`=sqrt(`vart')') display name(x1)"
+					qui gausshermite `int1',mu(`mean') sigma(`=sqrt(`vart')') display name(x1)
+					qui replace proba=r(int) in `i'
+				}
+				else{
+					local int "`int1'*`int2'"
+					matrix mean=(`mean1',`mean2')
+					qui gausshermite `int',mu(mean) var(`matvar') display
+					qui replace proba=r(int) in `i'
+				}
+			}
+		}
+	}
+	qui gen eff=proba
+	qui gen eff2=.  
+   
+	if "`longitudinal'"==""{
+		qui keep item* eff* group proba
+		local p1=1/`n1'
+		local p0=1/`n0'
+		qui replace eff2=floor(eff/`p1') if group==1
+		qui replace eff2=floor(eff/`p0') if group==0
+		qui replace eff=eff-eff2*(`p1'*group+`p0'*(1-group))
+		qui su eff2 if group==1
+		local aff1=r(sum)
+		qui su eff2 if group==0
+		local aff0=r(sum)
+
+		local unaff1=`n1'-`aff1'
+		local unaff0=`n0'-`aff0'
+		qui gen efftmp=eff2
+		qui gsort + group - eff
+		qui replace eff2=eff2+1 in 1/`unaff0'
+		qui gsort - group - eff
+		qui replace eff2=eff2+1 in 1/`unaff1'
+
+		qui drop if eff2==0
+		qui gsort group item*
+		qui expand eff2
+	}
+	else{
+		qui keep item* eff* proba
+		local p0=1/`n0'
+		qui replace eff2=floor(eff/`p0')
+		qui replace eff=eff-eff2*`p0'
+		qui su eff2
+		local aff0=r(sum)
+
+		local unaff0=`n0'-`aff0'
+		qui gen efftmp=eff2
+		qui gsort - eff
+		qui replace eff2=eff2+1 in 1/`unaff0'
+
+		qui drop if eff2==0
+		qui gsort item*
+		qui expand eff2
+	}
+   qui drop proba eff eff2
+}
+/*
+if "`html'" == "" {
+	qui save "d:\essai.dta", replace
+}*/
+qui alpha item*
+local alpha=r(alpha)
+
+if "`longitudinal'"==""{ /*TRANSVERSAL*/
+	qui gen groupc=-`n1'/(`n0'+`n1') if group==0
+	qui replace groupc=`n0'/(`n0'+`n1') if group==1
+	if `nbmodat'==2 {   /*DICHOTOMOUS CASE*/
+        if "`freeitems'"=="" {
+		      local offset "offset(offset)"
+			  local items
+        }
+        else {
+		      local offset
+		      local items "item1-item`nbitems'"
+        }
+		qui gen i=_n
+
+		tempname diff
+		matrix `diff'=`dd''
+
+		qui reshape long item, i(i)
+		qui rename item rep
+		qui rename _j item
+
+		qui gen  offset=0
+		forvalues i=1/`nbitems' {
+			qui replace offset=-`diff'[1,`i'] if item==`i'
+			qui gen item`i'=item==`i'
+			qui replace item`i'=-item`i'
+		}
+        if `var0'==`var1' { /*EQUAL VARIANCES*/
+	       *constraint 1 _cons=`=ln(`var')'
+		   *qui xtlogit rep groupc ,nocons i(i) offset(offset) constraint(1)
+	       if  "`freevar'"=="" {
+		      constraint 1 _cons=`=sqrt(`var0')'
+		      local constvar "constraint(1)"
+		   }
+		   qui gllamm rep groupc `items',nocons i(i) `offset' `constvar' fam(bin) link(logit) nrf(1) trace iterate(100)
+		}
+		else {/*UNEQUAL VARIANCES*/
+		   tempvar G0 G1
+		   qui gen `G0'=group==0
+		   qui gen `G1'=group==1
+		   qui eq B0: `G0'
+		   qui eq B1: `G1'
+	       constraint 1 _cons=0
+	       if  "`freevar'"=="" { /*FIXED UNEQUAL VARIANCE*/
+			   constraint 2 `G0'=`=sqrt(`var0')'
+			   constraint 3 `G1'=`=sqrt(`var1')'
+		       constraint 1 _cons=`=sqrt(`var0')'
+		       local constvar "constraint(1 2 3)"
+		   }
+		   else { /*FREE UNEQUAL VARIANCES*/
+		       local constvar "constraint(1)"
+		   }
+		   qui gllamm rep groupc `items',nocons i(i) `offset' `constvar' fam(bin) link(logit) eqs(B0 B1) nrf(2) trace iterate(100)
+		}
+		tempname b V/*LONGITUDINAL*/
+		local row = 1
+	}
+	else { /*POLYTOMOUS CASE*/
+		matrix `db'=`db''
+		if "`freeitems'"=="" {
+		   local fi "fixed(`db') fixedmu"
+		   local row=1
+		}
+		else {
+		   local fi
+		   local row=(`nbmodat'-1)*`nbitems'+1
+		}
+	    if `var0'==`var1' {
+	       if  "`freevar'"=="" {
+		       local fv "fixedvar(`var0')"
+		   }
+		   else {
+		       local fv 
+			   *noi pcm item*, `fi' covariates(groupc) 
+
+		   }
+		}
+		else {
+	       if  "`freevar'"=="" {
+		       local fv "fixedvargroupc(`var')"
+		   }
+		   else {
+		       local fv "vargroupc"
+		   }
+        }
+	      *di "jk pcm item*, `fi' covariates(groupc) `fv'"
+		   	/********************************ESSAI 23 mai 2014*/
+			qui simirt, clear pcm(`d') cov(`var1') mu(`=`n0'*`gamma'/(`n1'+`n0')') nbobs(`n1')
+			qui gen group=1
+			tempfile save1
+			qui save `save1',replace
+			qui simirt, clear pcm(`d') cov(`var0') mu(`=-`n1'*`gamma'/(`n1'+`n0')') nbobs(`n0')
+			qui gen group=0
+			qui append using `save1'
+			qui gen groupc=group-0.5
+			*di "ON A SIMULE"
+			**********************************FIN ESSAI 23 mai 2014*/
+
+		 qui pcmold item*, `fi' covariates(groupc) `fv'
+	}
+	tempname b V
+	matrix `b'=e(b)
+	matrix `V'=e(V)
+	local gammaest=`b'[1,`row']
+	local se=`V'[`row',`row']^.5
+}
+else{ /*LONGITUDINAL*/ 
+	qui raschlong item*, nbt(`nbt') diff(`d') var(`matvar')
+	tempname b V
+	matrix `b'=e(b)
+	matrix `V'=e(V)
+	local gammaest=`b'[1,1]
+	local se=`V'[1,1]^.5
+	local n1=`n0'
+}
+local poweruni=1-normal(1.96-`gamma'/`se')
+
+if "`html'" == "" {
+	di
+	di
+}
+if "`detail'"!=""{
+	di in gr "{hline 91}"
+	di _col(60)  "Estimation with the "
+	di _col(50)  "Cramer-Rao bound" _col(75) "classical formula"
+	di in gr "{hline 91}"
+}
+
+if "`longitudinal'"==""{
+	local power=1-normal(1.96-`gamma'/`se')+normal(-1.96-`gamma'/`se')
+	local nbw:word count `var'
+	if `nbw' == 2 { /* variance commune */
+		local varc = ((`n0'-1)*`var0'+(`n1'-1)*`var1')/(`n0'+`n1'-2)
+	}
+	else {
+		local varc = `var'
+	}
+	local clpower=normal(sqrt(`n1'*`gamma'^2/((`n1'/`n0'+1)*`varc'))-1.96)
+	local clnsn=(`n1'/`n0'+1)/((`n1'/`n0')*(`gamma'/sqrt(`varc'))^2)*(1.96+invnorm(`poweruni'))^2
+	local ratio=(`n0'+`n1')/(`clnsn'*(1+`n1'/`n0'))
+	if "`detail'"==""{
+		di in gr "{hline 65}"
+		di in green "Estimation of the variance of the group effect" _col(56) in ye %10.4f `=`se'^2'
+		di in green "Estimation of the power" _col(60) in ye %6.4f `poweruni'
+		di in gr "{hline 65}"
+	}
+	else{
+		if "`gammafixed'"==""  {
+		   di in green "Estimated value of the group effect" _col(59) in ye  %7.2f `gammaest'
+		}
+		di in green "Estimation of the s.e. of the group effect" _col(59) in ye %7.2f `se'
+		di in green "Estimation of the variance of the group effect" _col(56) in ye %10.4f `=`se'^2'
+		di in green "Estimation of the power" _col(60) in ye %6.4f `poweruni' _col(86) in ye %6.4f `clpower'
+		di in green "Number of patients for a power of" %6.2f `=`poweruni'*100' "%" _col(59) in ye `n0' "/" `n1' _col(77) in ye %7.2f `clnsn' "/" %7.2f `=`clnsn'*`n1'/`n0''
+		di in green "Ratio of the number of patients" in ye %6.2f _col(68)`ratio'
+		di in gr "{hline 91}"
+	}
+}
+else{
+	local clpower=normal(sqrt(`n0'*`gamma'^2)/(2*(`=`matvar'[1,1]'-`=`matvar'[2,1]'))-1.96)
+	local clnsn=2*(`=`matvar'[1,1]'-`=`matvar'[2,1]')*(1.96+invnorm(`poweruni'))^2/(`gamma'^2)
+	local ratio=(`n0'+`n1')/(`clnsn'*(1+`n1'/`n0'))
+	if "`detail'"==""{
+		di in gr "{hline 65}"
+		di in green "Estimation of the variance of the group effect" _col(56) in ye %10.4f `=`se'^2'
+		di in green "Estimation of the power" _col(60) in ye %6.4f `poweruni'
+		di in gr "{hline 65}"
+	}
+	else{
+		if "`gammafixed'"==""  {
+		   di in green "Estimated value of the time effect" _col(59) in ye  %7.2f `gammaest'
+		}
+		di in green "Estimation of the s.e. of the time effect" _col(59) in ye %7.2f `se'
+		di in green "Estimation of the variance of the time effect" _col(56) in ye %10.4f `=`se'^2'
+		di in green "Estimation of the power" _col(60) in ye %6.4f `poweruni' _col(86) in ye %6.4f `clpower'
+		di in green "Number of patients for a power of" %6.2f `=`poweruni'*100' "%" _col(63) in ye `n0' _col(85) in ye %7.2f `clnsn'
+		di in green "Ratio of the number of patients" in ye %6.2f _col(68)`ratio'
+		di in gr "{hline 91}"
+	}
+}
+
+if `expectedpower'!=-1 {
+   qui sampsi `=-`gamma'/2' `=`gamma'/2', sd1(`=sqrt(`var')') sd2(`=sqrt(`var')') alpha(0.05) power(`expectedpower') ratio(`=`n1'/`n0'')
+   local expn_1=r(N_1)
+   local expn_2=r(N_2)
+   local expn2=`expn_1'*`ratio'
+   di in green "Number of patients for a power of" %6.2f `=`expectedpower'*100' "%" _col(51) in ye %7.2f `expn2' "/" %7.2f `=`expn2'*`n1'/`n0'' _c
+   if "`detail'"!="" {
+      di _col(77) in ye %7.2f `expn_1' "/" %7.2f `expn_2'
+   }
+}
+
+
+return scalar EstGamma=`gammaest'
+return scalar CRbound=`=`se'^2'
+return scalar CRPower=`poweruni'
+return scalar ClPower=`clpower'
+return scalar ClSS=`clnsn'
+return scalar Ratio=`ratio'
+return scalar CronbachAlpha=`alpha'
+
+
+if "`graph'" != "" {
+	local x = "`min'(`step')`max'"
+	matrix res=J(15,5,.)
+	matrix colnames res= n0 n1 gamma variance power
+	local l=1
+
+	if "`longitudinal'"==""{
+		forval var = `x' {
+			qui raschpower, n0(`n0') n1(`n1') gamma(`gamma') difficulties(`d') var(`var') html(`html')
+			qui matrix res[`l',1]=(`n0', `n1', `gamma',`var',r(CRPower))
+			local ++l
+		}
+		clear
+		qui svmat res,names(col)
+		
+		if "`html'" != "" {
+			qui local saving "saving(`c(tmpdir)'/`html'_planif_graph,replace) nodraw"
+			qui graph twoway (connected power variance,sort), title("n0=`n0', n1=`n1', {&gamma}=`gamma'") ylabel(0(0.2)1) xlabel(`x') xtitle(Variance of the latent variable, margin(top)) ytitle(Power) name(planif_graph,replace) xscale(range(`min' `=`max'+`step'')) `saving'
+			qui graph use `c(tmpdir)'/`html'_planif_graph.gph
+			qui graph export `c(tmpdir)'/`html'_planif_graph.eps, replace
+			di "
"
+			di " _char(34) "
+		}
+		else {
+		    if "`filesave'"!="" {
+			    qui local saving "saving(`dirsave'//planif,replace) nodraw"
+		    }
+		    else {
+			    qui local saving	
+		    }
+			twoway (connected power variance,sort), title("n0=`n0', n1=`n1', {&gamma}=`gamma'") ylabel(0(0.2)1) xlabel(`x') xtitle(Variance of the latent variable, margin(top)) ytitle(Power) name(planif_graph,replace) xscale(range(`min' `=`max'+`step'')) `saving'
+		}
+	}
+
+	else {
+		if `gcorr' != -1  {
+			local l=1
+			forval var = `x'  {
+				local cov = `gcorr'*`var'
+				local matv "`var',`cov'" " \ `cov',`var'"
+				qui raschpower, n0(`n0') n1(`n1') gamma(`gamma') difficulties(`d') var("`matv'") html(`html') `longitudinal'
+				qui matrix res[`l',1]=(`n0', `n1', `gamma',`var',r(CRPower))
+				local ++l
+			}
+			clear
+			qui svmat res,names(col)
+			if "`html'" != "" {
+				qui local saving "saving(`c(tmpdir)'/`html'_planif_graph,replace) nodraw"
+				qui graph twoway (connected power variance,sort), title("n=`n0', {&gamma}=`gamma', corr=`gcorr'") ylabel(0(0.2)1) xlabel(`x') xtitle(Variance of the latent variable, margin(top)) ytitle(Power) name(planif_graph,replace) `saving'
+				qui graph use `c(tmpdir)'/`html'_planif_graph.gph
+				qui graph export `c(tmpdir)'/`html'_planif_graph.eps, replace
+				di "
"
+				di " _char(34) "
+			}
+			else {
+				if "`filesave'"!="" {
+					qui local saving "saving(`dirsave'//planif,replace) nodraw"
+				}
+				else {
+					qui local saving	
+				}
+				twoway (connected power variance,sort), title("n=`n0', {&gamma}=`gamma', corr=`gcorr'") ylabel(0(0.2)1) xlabel(`x') xtitle(Variance of the latent variable, margin(top)) ytitle(Power) name(planif_graph,replace) xscale(range(`min' `=`max'+`step'')) `saving'
+			}
+		}
+		
+		if `gvar' != -1  {
+			matrix res=J(9,5,.)
+			matrix colnames res= n0 n1 gamma corr power
+			local l=1
+			forvalues corr = `x' {
+				local cov = `corr'*`gvar'
+				local matv "`gvar',`cov'" " \ `cov',`gvar'"
+				qui raschpower, n0(`n0') n1(`n1') gamma(`gamma') difficulties(`d') var("`matv'") html(`html') `longitudinal'
+				qui matrix res[`l',1]=(`n0', `n1', `gamma',`corr',r(CRPower))
+				local ++l
+			}
+			clear
+			qui svmat res,names(col)
+			if "`html'" != "" {
+				qui local saving "saving(`c(tmpdir)'/`html'_planif_graph,replace) nodraw"
+				qui graph twoway (connected power corr,sort), title("n=`n0', {&gamma}=`gamma', var=`gvar'") ylabel(0(0.2)1) xlabel(`x') xtitle(Correlation, margin(top)) ytitle(Power) name(planif_graph,replace) `saving'
+				qui graph use `c(tmpdir)'/`html'_planif_graph.gph
+				qui graph export `c(tmpdir)'/`html'_planif_graph.eps, replace
+				di "
"
+				di " _char(34) "
+			}
+			else {
+				if "`filesave'"!="" {
+					qui local saving "saving(`dirsave'//planif,replace) nodraw"
+				}
+				else {
+					qui local saving	
+				}
+				twoway (connected power corr,sort), title("n=`n0', {&gamma}=`gamma', var=`gvar'") ylabel(0(0.2)1) xlabel(`x') xtitle(Correlation) ytitle(Power) name(planif_graph,replace) xscale(range(`min' `=`max'+`step''))
+			}
+		}
+	}
+
+//di in gr "Method: " in ye "`method'"
+
+	if "`html'" != "" {
+		di "
" + } +} + +capture qui use `raschpowerfile',clear + +end diff --git a/Modules/raschpower.hlp b/Modules/raschpower.hlp new file mode 100644 index 0000000..b15f494 --- /dev/null +++ b/Modules/raschpower.hlp @@ -0,0 +1,78 @@ +{smcl} +{* 6february2012}{...} +{hline} +help for {hi:raschpower}{right:Jean-Benoit Hardouin, Myriam Blanchin} +{hline} + +{title:Estimation of the power of the Wald test in order to compare the means of the latent trait in two groups of individuals} + +{p 8 14 2}{cmd:raschpower} [{cmd:,} {cmdab:n0}({it:#}) {cmdab:n1}({it:#}) +{cmdab:gamma}({it:#}) {cmdab:var}({it:# [#]}) {cmdab:d:ifficulties}({it:matrix}) {cmdab:m:ethod}({it:method}) {cmdab:det:ail} {cmdab:exp:ectedpower}({it:#})] + + +{title:Description} + +{p 4 8 2}{cmd:raschpower} allows estimating the power of the Wald test comparing the means of two groups of patients in the context of the Rasch model or the partial-credit model. The estimation is based + on the estimation of the variance of the difference of the means based on the Cramer-Rao bound. + +{title:Options} + +{p 4 8 2}{cmd:n0} and {cmd:n1} indicates the numbers of individuals in the two groups [100 by default]. + +{p 4 8 2}{cmd:gamma} indicates the group effect (difference between the two means) [0.5 by default]. + +{p 4 8 2}{cmd:var} is the expected values of the variances of the latent trait (1 by default): if this option contains only one value, variances are considered as equal between the two groups; if this option contains two values, variances are considered as unequal between the two groups. + +{p 4 8 2}{cmdab:d:ifficulties} is a matrix containing the item parameters [one row per item, one column per positive modality - (-1.151, -0.987\-0.615, -0.325\-0.184, -0.043\0.246, 0.554\0.782, 1.724) by default]. + +{p 4 8 2}{cmd:method}({it:method}) indicates the method for constructing data. ({it:method}) may be GH, MEAN, MEAN+GH or POPULATION+GH [default is method(GH) if number of patterns<500, method(MEAN+GH) if 500<=number of patterns<10000, +method(MEAN) if 10000<=number of patterns<1000000, method(POPULATION+GH) otherwise]. + +{p 8 14 2} {bf:GH}: The probability of all possible response patterns is estimated by Gauss-Hermite quadratures. + +{p 8 14 2} {bf:MEAN}: The mean of the latent trait for each group is used instead of Gauss-Hermite quadratures. + +{p 8 14 2} {bf:MEAN+GH}: In a first step, the MEAN method is used to determine the most probable patterns. In a second step, the probability of response patterns is estimated by Gauss-Hermite quadratures on the most probable patterns. + +{p 8 14 2} {bf:POPULATION+GH}: The most frequent response patterns are selected from a simulated population of 1,000,000 of individuals. The probability of the selected response patterns is estimated by Gauss-Hermite quadratures. + +{p 4 8 2}{cmd:detail} allows a comparison with the classical formula (for manifest variable). + +{p 4 8 2}{cmd:expectedpower} allows searching for a sample size in order to reach a fixed level of power (the obtained sample sizes take into account the ratio between $n0$ and $n1$). + + +{title:Example} + + {p 4 8 2}{cmd:. raschpower} + + {p 4 8 2}{cmd:. raschpower, n0(200) n1(200) gamma(0.4) var(1.3)} + + {p 4 8 2}{cmd:. matrix diff=(-1.47\-0.97\-.23\-0.12\0.02\0.1)}{p_end} + {p 4 8 2}{cmd:. raschpower, n0(127) n1(134) gamma(0.23) d(diff) var(2.58)}{p_end} + + {p 4 8 2}{cmd:. matrix diff=(-0.328,-0.811,0.329\ 0.556,0.818,1.409\ 1.394,1.049,1.288\ 0.560,0.363,0.950)}{p_end} + {p 4 8 2}{cmd:. raschpower, d(diff) n0(167) n1(205) gamma(0.178) var(0.77) exp(0.8)}{p_end} + + +{title:References} + + {p 4 8 2}Hardouin J.B., Amri S., Feddag M., Sébille V. (2012) Towards Power And Sample Size Calculations For The Comparison Of Two Groups Of Patients With Item Response Theory Models. Statistics in Medicine, 31(11): 1277-1290.{p_end} + {p 4 8 2}Blanchin M., Hardouin J.B., Guillemin F., Falissard B., Sébille V. (2013) Power and sample size determination for the group comparison of patient-reported outcomes with Rasch family models. PLoS ONE, 8(2): e57279.{p_end} + {p 4 8 2}Feddag M.L., Blanchin M., Hardouin J.B., Sébille V. (2014) Power analysis on the time effect for the longitudinal Rasch model. Journal of Applied Measurement: (under press).{p_end} + {p 4 8 2}Guilleux A., Blanchin M., Hardouin J.B., Sébille V. (2014) Power and sample size determination in the Rasch model: Evaluation of the robustness of a numerical method to non-normality of the latent trait. Plos One, 9(1): e0083652.{p_end} + + +{title:Author} + +{p 4 8 2}Jean-Benoit Hardouin, PhD, assistant professor{p_end} +{p 4 8 2}Myriam Blanchin, PhD, research assistant{p_end} +{p 4 8 2}Bastien Perrot, biostatistician{p_end} +{p 4 8 2}EA4275 "Biostatistics, Pharmacoepidemiology and Subjective Measures in Health Sciences"{p_end} +{p 4 8 2}University of Nantes - Faculty of Pharmaceutical Sciences{p_end} +{p 4 8 2}1, rue Gaston Veil - BP 53508{p_end} +{p 4 8 2}44035 Nantes Cedex 1 - FRANCE{p_end} +{p 4 8 2}Emails: +{browse "mailto:jean-benoit.hardouin@univ-nantes.fr":jean-benoit.hardouin@univ-nantes.fr}{p_end} +{p 13 8 2}{browse "mailto:myriam.blanchin@univ-nantes.fr":myriam.blanchin@univ-nantes.fr}{p_end} +{p 4 8 2}Websites {browse "http://www.anaqol.org":AnaQol} +and {browse "http://www.freeirt.org":FreeIRT} diff --git a/Modules/remcor.ado b/Modules/remcor.ado new file mode 100644 index 0000000..4c02feb --- /dev/null +++ b/Modules/remcor.ado @@ -0,0 +1,405 @@ +*! version 2.0.3 SRH 1 June 2003 +program define remcor + version 6.0 + * takes b and transform set of r.effs at same level using choleski + * returns bi where the r.effs are independent and correlation equations + * have been removed + * also takes exponential of sd parameters + * and evaluates contributions to linear predictor that don't change + args b stop + + tempname b2 s1 cov t r d dd u denom mean mzps + tempvar junk + gen double `junk'=0 + global HG_error=0 + + disp "*********in remcor:" + + /* fixed effects $HG_xb1, $HG_xb2 etc. (tempnames stored in global macros-list) */ + qui disp "fixed parameters: " + qui matrix list `b' + if $HG_const==1{ + matrix `b2' = `b'*M_T' + M_a + matrix coleq `b2' = $HG_cole + matrix colnames `b2' = $HG_coln + noi matrix list `b2' + } + else{ + matrix `b2' = `b' + } + local nffold=0 + local ff = 1 + local nxt = 1 + while(`ff' <= $HG_tpff){ + matrix `b2' = `b2'[1, `nxt'...] + local np = M_nffc[1, `ff'] - `nffold' + qui disp "np = " `np' + if `np'>0{ + local nxt = `np' + 1 + local nffold = M_nffc[1,`ff'] + matrix `s1' = `b2'[1,1..`np'] + qui matrix list `s1' + qui disp "tempname: ${HG_xb`ff'}" + matrix score double ${HG_xb`ff'} = `s1' /* nontemp */ + } + else{ + qui gen double ${HG_xb`ff'} = 0 + } + qui disp ${HG_xb`ff'}[$which] + local ff=`ff'+1 + } + if "$HG_off"~=""{qui replace $HG_xb1=$HG_xb1+$HG_off} + qui disp "HG_xb1 = " $HG_xb1[$which] + + if $HG_ethr{ + local j = 1 + local ii = 1 + while `ii'<=$HG_nolog{ + local j = `j' + 1 + local jm = `j' + M_nresp[1,`ii']-3 + while `j' <= `jm'{ + local jp = `j' + 1 + * disp in re "replace HG_xb`jp' = HG_xb`j' + exp(HG_xb`jp')" + qui replace ${HG_xb`jp'} = ${HG_xb`j'} + exp(${HG_xb`jp'}) + local j = `j' + 1 + } + local ii = `ii' + 1 + } + + } + + /* random effects */ +/* level 1 */ + local np = M_nbrf[1,1] + if `np'>0{ + matrix `b2' = `b2'[1, `nxt'...] + local nxt = 1 + matrix `s1' = `b2'[1,1..`np'] + qui matrix list `s1' + matrix score double $HG_s1 = `s1' + if $HG_nats{ + qui replace $HG_s1 = abs($HG_s1) + } + else{ + qui replace $HG_s1=exp($HG_s1) + } + qui disp "s1 = $HG_s1 = " $HG_s1[$which] + local nxt = `nxt' + `np' + } + local lev = 2 + local rf = 2 + local nrfold = M_nrfc[2,1] + +/* MASS POINTS */ +if($HG_free){ + tempname pdenom + gen double `pdenom' = 1.0 + while(`lev'<=$HG_tplv&`rf'<=$HG_tprf){ + local j1 = M_nrfc[2, `lev'] + local nrf = `j1' - `nrfold' + local nip = M_nip[1, `lev'] + scalar `denom' = 1 /* =exp(0) */ + qui replace `pdenom' = 1.0 + matrix M_zps`lev' = J(1,`nip',0) + local k = 1 + qui disp "`nip' integration points at level `lev'" + local nloc = `nip' + local npar = M_np[1,`lev'] + if $HG_cip|`nip'>1{ local nloc = `nloc'-1} + while `k' <= `nloc' { + local j = `nrfold'+1 + while `j'<=`j1'{ + qui disp "level `lev', class `k' and random effect `j'" + qui disp " nxt = " `nxt' + matrix `b2' = `b2'[1, `nxt'...] + qui matrix list `b2' + local nxt = 1 + if `k'==1{ + /* linear predictors come before first masspoint */ + local np = M_nbrf[1,`j']-1 + if `np'>0 { + qui disp "extracting coefficients for r.eff" + matrix `s1' = `b2'[1,1..`np'] + matrix score double ${HG_s`j'} = `s1' + qui disp "HG_s`j' = ${HG_s`j'} = " ${HG_s`j'}[$which] + local nxt = `nxt' + `np' + } + /* first coeff fixed at one */ + if M_frld[1,`rf']~=1{ + matrix `s1' = (1) + local lab: colnames `b2' + local lab: word `nxt' of `lab' + matrix colnames `s1'=`lab' + qui matrix list `s1' + capture drop `junk' + matrix score double `junk' = `s1' + if `np'>0{ + qui replace ${HG_s`j'}=${HG_s`j'}+`junk' + } + else{ + qui gen double ${HG_s`j'}=`junk' + } + qui matrix list `s1' + } + qui disp "HG_s`j' = ${HG_s`j'} = " ${HG_s`j'}[$which] + qui disp "making M_zlc`j'" + matrix M_zlc`j' = J(1,`nip',0) + } + matrix M_zlc`j'[1,`k'] = `b2'[1,`nxt'] + local nxt = `nxt' + 1 + local j = `j' + 1 + } + if `k'<`nip'{ + if `npar'>0{ + qui disp "extract probability parameters for HG_p`cl' (npar=`npar')" + matrix `s1' = `b2'[1,`nxt'..(`nxt'+`npar'-1)] + qui matrix list `s1' + capture drop `junk' + matrix score double `junk' = `s1' + qui gen double ${HG_p`lev'`k'} = `junk' + local nxt = `nxt' + `npar' - 1 + qui replace `pdenom' = `pdenom' + exp(${HG_p`lev'`k'}) + } + + scalar `mzps' = exp(`b2'[1,`nxt']) + if `mzps' == . { + global HG_error=1 + exit + } + matrix M_zps`lev'[1,`k'] = `b2'[1,`nxt'] + local nxt = `nxt' + 1 + scalar `denom' = `denom' + `mzps' + } + local k = `k' + 1 + } + + if `npar'>0{ + qui gen double ${HG_p`lev'`nip'} = 0.0 + local k = 1 + while `k' <= `nip'{ + qui disp "divide HG_p`lev'`k'" + qui replace ${HG_p`lev'`k'} = ${HG_p`lev'`k'} - ln(`pdenom') + local k = `k' + 1 + } + } + + local k = 1 + while `k' <= `nip'{ + matrix M_zps`lev'[1,`k'] = M_zps`lev'[1,`k'] - ln(`denom') + local k = `k' + 1 + } + local j = `nrfold' + 1 + while `j' <= `j1'{ /* define last location */ + if $HG_cip == 1{ + local k = 1 + scalar `mean' = 0 + while `k'<`nip'{ + scalar `mean' = `mean' + M_zlc`j'[1,`k']*exp(M_zps`lev'[1,`k']) + local k = `k' + 1 + } + scalar `mzps' = exp(M_zps`lev'[1,`nip']) + matrix M_zlc`j'[1,`nip'] = -`mean'/`mzps' + } + else if `nip'>1{ + matrix M_zlc`j'[1,`nip'] = `b2'[1,`nxt'] + local nxt = `nxt' + 1 + } + qui disp "M_zlc`j'" + qui matrix list M_zlc`j' + local j = `j' + 1 + } + qui disp "M_zps`lev'" + qui matrix list M_zps`lev' + local nrfold = `j1' + local lev = `lev' + 1 + } +}/*endif HG_free */ +else{ +/* ST. DEVS */ + qui disp "random parameters: " + if $HG_tprf>1{matrix CHmat = J($HG_tprf-1,$HG_tprf-1,0)} + while(`lev'<=$HG_tplv&`rf'<=$HG_tprf){ + local np = M_nbrf[1,`rf'] + qui disp "np = " `np' + local nrf = M_nrfc[2, `lev'] - `nrfold' + matrix `t' = J(`nrf',`nrf',0) + local i = 1 + while (`i' <= `nrf'){ + qui disp " nxt = " `nxt' + matrix `b2' = `b2'[1, `nxt'...] + local nxt = 1 + qui matrix list `b2' + local np = M_nbrf[1, `rf'] - 1 + qui disp `np' " loadings at random effect " `rf' ", level " `lev' + if `np'>0{ + matrix `s1' = `b2'[1,1..`np'] +/* + * fudge: exponentiate s1 + local ij = 1 + while `ij'<=`np'{ + matrix `s1'[1,`ij'] = exp(`s1'[1,`ij']) + local ij = `ij' + 1 + } + * end fudge +*/ + + qui matrix list `s1' + matrix score double ${HG_s`rf'} = `s1' + local nxt = `nxt' + `np' + } + /* first (single non-) loading fixed at one, label in st. dev */ + if M_frld[1,`rf']~=1{ + matrix `s1' = (1) + local lab: colnames `b2' + local lab: word `nxt' of `lab' + matrix colnames `s1' = `lab' + capture drop `junk' + tempname junk + matrix score double `junk' = `s1' + if `np'>0{ + qui replace ${HG_s`rf'} = ${HG_s`rf'} + `junk' + } + else{ + matrix score double ${HG_s`rf'} = `s1' + *qui replace ${HG_s`rf'} = `junk' + } + } + + qui disp "HG_s`rf' = ${HG_s`rf'} = " ${HG_s`rf'}[$which] + * extract standard deviation + * fudge: take exponential + * matrix `t'[`i',`i'] = exp(`b2'[1, `nxt']) + matrix `t'[`i',`i'] = `b2'[1, `nxt'] + matrix CHmat[`rf'-1,`rf'-1]=`t'[`i',`i'] + local nxt = `nxt' + 1 + local i = `i' + 1 + local rf = `rf' + 1 + } + if (`nrf'>1&$HG_cor==1){ /* deal with correlations */ + /* extract correlation parameters */ + local i = 2 + while (`i' <= `nrf'){ + local k = `i' + `nrfold' - 1 + local j = 1 + while (`j' < `i'){ + local l = `j' + `nrfold' - 1 + qui disp "i = " `i' " j = " `j' " nxt = " `nxt' + matrix `t'[`i',`j'] = `b2'[1,`nxt'] + matrix CHmat[`k',`l'] = `t'[`i',`j'] + local j = `j' + 1 + local nxt = `nxt' + 1 + } + local i = `i' + 1 + } + } + qui matrix list `t' + matrix M_chol = `t' + /* unpacked parameters */ + local nrfold = M_nrfc[2,`lev'] + local lev = `lev' + 1 + } /* loop through levels */ +}/*endelse HG_free */ +if "`stop'"~=""{ + exit +} +local nrfold = M_nrfc[2,1] +/* use B-matrix */ +if $HG_tprf>1&$HG_bmat==1{ + qui disp "dealing with B-matrix" + local i = 1 + matrix Bmat = J($HG_tprf-1,$HG_tprf-1,0) + while `i'<$HG_tprf{ + local j = 1 + while `j' < $HG_tprf{ + if M_b[`i',`j']>0{ + matrix Bmat[`i',`j']=`b2'[1,`nxt'] + local nxt = `nxt' + 1 + } + local j = `j' + 1 + } + local i = `i' + 1 + } + qui matrix list Bmat + +/* only works if B-matrix is upper diagonal */ + local i=2 + while `i'<$HG_tprf{ + local k = `i' + `nrfold' + local j = 1 + qui disp "making s`k'" + while `j'<`i'{ + local l = `j' + `nrfold' + qui replace ${HG_s`k'} = ${HG_s`k'} + Bmat[`j',`i']*${HG_s`l'} + qui disp " adding Bmat[`j',`i']s`l'" + local j = `j' + 1 + } + local i = `i' + 1 + } +} + +/* deal with geqs */ + + +if $HG_ngeqs>0{ +qui disp "dealing with geqs" + local i = 1 + while `i'<=$HG_ngeqs{ + local k = M_ngeqs[1,`i'] + local n = M_ngeqs[2,`i'] + qui disp "random effect `k' has `n' covariates" + local nxt2 = `nxt'+`n'-1 + matrix `s1' = `b2'[1,`nxt'..`nxt2'] + qui matrix list `s1' + local nxt = `nxt2' + 1 + capture drop `junk' + matrix score double `junk' = `s1' + qui disp "multiply " `junk'[$which] " by HG_s`k' and add to HG_xb1" + qui replace $HG_xb1 = $HG_xb1 + `junk'*${HG_s`k'} + qui disp "HG_xb1:" $HG_xb1[$which] + local i = `i' + 1 + } +} + +/* use inter */ + +if $HG_inter~=0{ + local k = $HG_l + 1 + local j = $HG_r + 1 + qui disp "HG_s`k' = HG_s`k'*HG_s`j' + qui replace ${HG_s`k'} = ${HG_s`k'}*${HG_s`j'} +} + +/* use CHmat */ +if $HG_free==0&$HG_tprf>1{ + qui disp "dealing with Cholesky matrix" + qui matrix list CHmat + local i = 1 + while (`i'<$HG_tprf){ + local k = `i' + `nrfold' + qui replace `junk'=0 + local j = `i' + qui disp "making s`k'" + while `j'<$HG_tprf{ + local l = `j' + `nrfold' + qui replace `junk' = `junk' + CHmat[`j',`i']*${HG_s`l'} + qui disp " adding CHmat[`j',`i']s`l'" + local j = `j' + 1 + } + qui replace ${HG_s`k'}=`junk' + qui disp "s`k' = ${HG_s`k'} = " ${HG_s`k'}[$which] + local i = `i' + 1 + } +} + +* label M_znow +local i=2 +local lab +while `i'<=$HG_tprf{ + local lab "`lab' ${HG_s`i'}" + local i = `i' + 1 +} +matrix colnames M_znow=`lab' +qui disp "M_znow:" +qui matrix list M_znow +end + diff --git a/RProject/.RData b/RProject/.RData index 5faaf71..b83f6ee 100644 Binary files a/RProject/.RData and b/RProject/.RData differ diff --git a/RProject/.Rhistory b/RProject/.Rhistory index 7d87e1c..5839882 100644 --- a/RProject/.Rhistory +++ b/RProject/.Rhistory @@ -1,359 +1,3 @@ -View(res.dat) -res.dat.simple <- res.dat[,c(1:7,12,15:17)] -res.dat.simple -res.dat.simple$m.beta <- round(res.dat.simple$m.beta,3) -res.dat.simple -compile_simulation <- function(scenario) { -name <- as.numeric(gsub("[^0-9.-]", "", substr(scenario,start=0,stop=2))) -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name<=4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name>4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'_nodif.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name<=4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name>4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'_nodif.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name<=4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name>4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'_nodif.csv')) -} -if (unique(s$J)==4) { -if (unique(s$M)==2) { -a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4)) -} else { -a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), -m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), -m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), -m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3) -) -} -} else { -if (unique(s$M)==2) { -a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4), -m.item5=mean(s$item5),m.item6=mean(s$item6),m.item7=mean(s$item7)) -} else { -a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), -m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), -m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), -m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3), -m.item5_1=mean(s$item5_1),m.item5_2=mean(s$item5_2),m.item5_3=mean(s$item5_3), -m.item6_1=mean(s$item6_1),m.item6_2=mean(s$item6_2),m.item6_3=mean(s$item6_3), -m.item7_1=mean(s$item7_1),m.item7_2=mean(s$item7_2),m.item7_3=mean(s$item7_3) -) -} -} -zz <- substr(scenario,start=0,stop=nchar(scenario)-4) -b <- data.frame(scenario=zz, -scenario.type=substr(zz,start=0,stop=nchar(zz)-1), -N=substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario)), -J=unique(s$J), -M=unique(s$M), -eff.size=unique(s$eff.size), -nb.dif=unique(s$nb.dif), -dif.size=unique(s$dif.size) -) -z <- data.frame(m.beta=mean(s$beta), -m.low.ci.beta=mean(s$low.ci.beta), -m.high.ci.beta=mean(s$high.ci.beta), -true.value.in.ci.p=mean(s$true.value.in.ci), -h0.rejected.p=mean(s$h0.rejected), -beta.same.sign.truebeta.p=mean(s$beta.same.sign.truebeta,na.rm=T)) -d <- cbind(b,a,z) -d$prop. -return(d) -} -res.dat <- compile_simulation('1A_100') -for (x in results[seq(2,length(results))]) { -y <- compile_simulation(x) -res.dat <- bind_rows(res.dat,y) -} -View(res.dat) -res.dat.simple <- res.dat[,c(1:7,12,15:17)] -res.dat.simple$m.beta <- round(res.dat.simple$m.beta,3) -res.dat.simple <- res.dat[,c(1:8,13,16:18)] -res.dat.simple$m.beta <- round(res.dat.simple$m.beta,3) -res.dat.simple -compile_simulation <- function(scenario) { -name <- as.numeric(gsub("[^0-9.-]", "", substr(scenario,start=0,stop=2))) -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name<=4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name>4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'_nodif.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name<=4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name>4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'_nodif.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name<=4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'.csv')) -} -if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name>4) { -s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'_nodif.csv')) -} -if (unique(s$J)==4) { -if (unique(s$M)==2) { -a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4)) -} else { -a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), -m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), -m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), -m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3) -) -} -} else { -if (unique(s$M)==2) { -a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4), -m.item5=mean(s$item5),m.item6=mean(s$item6),m.item7=mean(s$item7)) -} else { -a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), -m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), -m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), -m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3), -m.item5_1=mean(s$item5_1),m.item5_2=mean(s$item5_2),m.item5_3=mean(s$item5_3), -m.item6_1=mean(s$item6_1),m.item6_2=mean(s$item6_2),m.item6_3=mean(s$item6_3), -m.item7_1=mean(s$item7_1),m.item7_2=mean(s$item7_2),m.item7_3=mean(s$item7_3) -) -} -} -zz <- substr(scenario,start=0,stop=nchar(scenario)-4) -b <- data.frame(scenario=zz, -scenario.type=substr(zz,start=nchar(zz),stop=nchar(zz)), -N=substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario)), -J=unique(s$J), -M=unique(s$M), -eff.size=unique(s$eff.size), -nb.dif=unique(s$nb.dif), -dif.size=unique(s$dif.size) -) -z <- data.frame(m.beta=mean(s$beta), -m.low.ci.beta=mean(s$low.ci.beta), -m.high.ci.beta=mean(s$high.ci.beta), -true.value.in.ci.p=mean(s$true.value.in.ci), -h0.rejected.p=mean(s$h0.rejected), -beta.same.sign.truebeta.p=mean(s$beta.same.sign.truebeta,na.rm=T)) -d <- cbind(b,a,z) -d$prop. -return(d) -} -res.dat <- compile_simulation('1A_100') -for (x in results[seq(2,length(results))]) { -y <- compile_simulation(x) -res.dat <- bind_rows(res.dat,y) -} -View(res.dat) -res.dat.simple <- res.dat[,c(1:8,13,16:18)] -res.dat.simple$m.beta <- round(res.dat.simple$m.beta,3) -res.dat.simple -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null) -res.dat[is.na(res.dat$dif.size),'dif.size'] <- 0 -res.dat.simple <- res.dat[,c(1:8,13,16:18)] -res.dat.simple$m.beta <- round(res.dat.simple$m.beta,3) -res.dat.simple -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null) -plot(h0.rejected.p~dif.size,data=res.null) -boxplot(h0.rejected.p~dif.size,data=res.null)+points(h0.rejected.p~dif.size,data=res.null) -boxplot(h0.rejected.p~dif.size,data=res.null) -points(h0.rejected.p~dif.size,data=res.null) -points(h0.rejected.p~1.dif.size,data=res.null) -points(h0.rejected.p~1+dif.size,data=res.null) -boxplot(h0.rejected.p~dif.size,data=res.null) -points(h0.rejected.p~1+dif.size,data=res.null) -points(y=h0.rejected.p,x=0,data=res.null) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null) -points(y=h0.rejected.p,x=0,data=res.null) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null) -points(y=res.null$h0.rejected.p,x=0) -points(y=res.null$h0.rejected.p,x=rep(0,nrow(res.null))) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null) -points(y=res.null$h0.rejected.p,x=rep(0,nrow(res.null))) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null) -points(y=res.null$h0.rejected.p,x=rep(1,nrow(res.null))) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0))) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0))) -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3))) -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3))) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0))) -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col=2) -res.null5 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(2,nrow(res.null5)),col=3) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0))) -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col=2) -res.null5 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col=3) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),'gray') -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray') -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='darkred') -res.null5 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col='darkgreen') -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray',pty=2) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray',pty=2) -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='darkred',pty=2) -res.null5 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col='darkgreen',pty=2) -res.null <- res.dat[res.dat$eff.size==0,] -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray',pch=3) -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='darkred',pch=3) -res.null5 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col='darkgreen',pch=3) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3)) -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray',pch=3) -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) -res.null5 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col='#053305',pch=3) -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') -res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray',pch=3) -res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) -res.null5 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col='#053305',pch=3) -par(mfrow=c(2,2)) -# 1 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==1,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 1 item') -res.null0 <- res.null[res.null$dif.size==0,] -points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray',pch=3) -res.null3 <- res.null[res.null$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) -res.null5 <- res.null[res.null$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col='#053305',pch=3) -# 2 items -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==2,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 2 items') -# 1 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==1,] -res.null -par(mfrow=c(2,2)) -# 1 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==1,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 1 item') -res.null3 <- res.null[res.null$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) -res.null5 <- res.null[res.null$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(3,nrow(res.null5)),col='#053305',pch=3) -par(mfrow=c(2,2)) -# 1 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==1,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 1 item') -res.null3 <- res.null[res.null$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(1,nrow(res.null3)),col='#590b0c',pch=3) -res.null5 <- res.null[res.null$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(2,nrow(res.null5)),col='#053305',pch=3) -par(mfrow=c(2,2)) -# 0 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='No DIF') -points(y=res.null$h0.rejected.p,x=rep(1,nrow(res.null)),col='#590b0c',pch=3) -par(mfrow=c(2,2)) -# 0 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='No DIF',ylim=c(0,1)) -points(y=res.null$h0.rejected.p,x=rep(1,nrow(res.null)),col='#590b0c',pch=3) -# 1 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==1,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 1 item',ylim=c(0,1)) -res.null3 <- res.null[res.null$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(1,nrow(res.null3)),col='#590b0c',pch=3) -res.null5 <- res.null[res.null$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(2,nrow(res.null5)),col='#053305',pch=3) -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==2,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 2 items',ylim=c(0,1)) -par(mfrow=c(2,2)) -# 0 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='No DIF',ylim=c(0,1)) -points(y=res.null$h0.rejected.p,x=rep(1,nrow(res.null)),col='#590b0c',pch=3) -# 1 item -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==1,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 1 item',ylim=c(0,1)) -res.null3 <- res.null[res.null$dif.size==0.3,] -points(y=res.null3$h0.rejected.p,x=rep(1,nrow(res.null3)),col='#590b0c',pch=3) -res.null5 <- res.null[res.null$dif.size==0.5,] -points(y=res.null5$h0.rejected.p,x=rep(2,nrow(res.null5)),col='#053305',pch=3) -# 2 items -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==2,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 2 items',ylim=c(0,1)) -# 2 items -res.null <- res.dat[res.dat$eff.size==0 & res.dat$nb.dif==2,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(2,3),xlab='DIF size', -ylab='H0 rejection proportion in target scenario',main='DIF on 2 items',ylim=c(0,1)) -res.null -res.dat$nb.dif -table(res.dat$scenario) -cumsum(table(res.dat$scenario)) -table(res.dat[1:132]$scenario) -table(res.dat[1:132,]$scenario) -nrow(res.dat) -res.dat[132:300,'nb.dif'] <- 2 -res.dat[300:396,'nb.dif'] <- 3 -View(res.dat) -res.dat.simple <- res.dat[,c(1:8,13,16:18)] -res.dat.simple$m.beta <- round(res.dat.simple$m.beta,3) -res.dat.simple -#### plots -## Proportion of rejected h0 per dif value in h0 scenarios (A) by DIF size -res.null <- res.dat[res.dat$eff.size==0,] -boxplot(h0.rejected.p~dif.size,data=res.null,col=c(1,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') res.null0 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0,] points(y=res.null0$h0.rejected.p,x=rep(1,nrow(res.null0)),col='gray',pch=3) res.null3 <- res.dat[res.dat$eff.size==0 & res.dat$dif.size==0.3,] @@ -510,3 +154,359 @@ points(y=res.null3$h0.rejected.p,x=rep(1,nrow(res.null3)),col='#590b0c',pch=3) res.null5 <- res.null[res.null$dif.size==0.5,] points(y=res.null5$h0.rejected.p,x=rep(2,nrow(res.null5)),col='#053305',pch=3) par(mfrow=c(1,1)) +# Overall +boxplot(beta.same.sign.truebeta.p~dif.size,data=res.dat,col=c(2,3),xlab='DIF size', +ylab='Proportion of estimates with same sign as true value in target scenario',main='DIF on 3 items',ylim=c(0,1)) +res.null3 <- res.dat[res.dat$dif.size==-0.5,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(1,nrow(res.null3)),col='#590b0c',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0.5,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(5,nrow(res.null3)),col='#590b0c',pch=3) +res.null3 <- res.dat[res.dat$dif.size==-0.3,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(2,nrow(res.null3)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0.3,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(4,nrow(res.null3)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(3,nrow(res.null3)),col='gray',pch=3) +#### Create data.frame +results <- c(sapply(1:4,function(x) paste0(x,c('A','B','C','D','E'))),sapply(5:9,function(x) paste0(x,c('A','B','C','D','E','F','G')))) +results2 <- c(sapply(10:20,function(x) paste0(x,c('A','B','C','D','E','F','G')))) +results <- c(sapply(c(100,200,300),function(x) paste0(results,'_',x))) +results2 <- c(sapply(c(100,200,300),function(x) paste0(results2,'_',x))) +results <- sort(results) +results2 <- sort(results2) +results <- c(results,results2) +#### Compiler function +compile_simulation <- function(scenario) { +name <- as.numeric(gsub("[^0-9.-]", "", substr(scenario,start=0,stop=2))) +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name<=4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name>4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'_nodif.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name<=4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name>4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'_nodif.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name<=4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name>4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'_nodif.csv')) +} +if (unique(s$J)==4) { +if (unique(s$M)==2) { +a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4)) +} else { +a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), +m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), +m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), +m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3) +) +} +} else { +if (unique(s$M)==2) { +a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4), +m.item5=mean(s$item5),m.item6=mean(s$item6),m.item7=mean(s$item7)) +} else { +a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), +m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), +m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), +m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3), +m.item5_1=mean(s$item5_1),m.item5_2=mean(s$item5_2),m.item5_3=mean(s$item5_3), +m.item6_1=mean(s$item6_1),m.item6_2=mean(s$item6_2),m.item6_3=mean(s$item6_3), +m.item7_1=mean(s$item7_1),m.item7_2=mean(s$item7_2),m.item7_3=mean(s$item7_3) +) +} +} +zz <- substr(scenario,start=0,stop=nchar(scenario)-4) +b <- data.frame(scenario=zz, +scenario.type=substr(zz,start=nchar(zz),stop=nchar(zz)), +N=substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario)), +J=unique(s$J), +M=unique(s$M), +eff.size=unique(s$eff.size), +nb.dif=unique(s$nb.dif), +dif.size=unique(s$dif.size) +) +z <- data.frame(m.beta=mean(s$beta), +se.empirical.beta=sd(s$beta), +se.analytical.beta=mean(s$se.beta), +m.low.ci.beta=mean(s$low.ci.beta), +m.high.ci.beta=mean(s$high.ci.beta), +true.value.in.ci.p=mean(s$true.value.in.ci), +h0.rejected.p=mean(s$h0.rejected), +beta.same.sign.truebeta.p=mean(s$beta.same.sign.truebeta,na.rm=T), +beta.same.sign.truebeta.signif.p=mean(s[s$h0.rejected==1,]$beta.same.sign.truebeta,na.rm=T)) +d <- cbind(b,a,z) +d$prop. +return(d) +} +#### Compiled results +res.dat <- compile_simulation('1A_100') +for (x in results[seq(2,length(results))]) { +y <- compile_simulation(x) +res.dat <- bind_rows(res.dat,y) +} +library(TAM) +library(doMC) +library(parallel) +library(pbmcapply) +library(funprog) +library(dplyr) +#### Create data.frame +results <- c(sapply(1:4,function(x) paste0(x,c('A','B','C','D','E'))),sapply(5:9,function(x) paste0(x,c('A','B','C','D','E','F','G')))) +results2 <- c(sapply(10:20,function(x) paste0(x,c('A','B','C','D','E','F','G')))) +results <- c(sapply(c(100,200,300),function(x) paste0(results,'_',x))) +results2 <- c(sapply(c(100,200,300),function(x) paste0(results2,'_',x))) +results <- sort(results) +results2 <- sort(results2) +results <- c(results,results2) +#### Compiler function +compile_simulation <- function(scenario) { +name <- as.numeric(gsub("[^0-9.-]", "", substr(scenario,start=0,stop=2))) +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name<=4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="100" & name>4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N100/scenario_',scenario,'_nodif.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name<=4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="200" & name>4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N200/scenario_',scenario,'_nodif.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name<=4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'.csv')) +} +if (substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario))=="300" & name>4) { +s <- read.csv(paste0('/home/corentin/Documents/These/Recherche/Simulations/Analysis/NoDIF/N300/scenario_',scenario,'_nodif.csv')) +} +if (unique(s$J)==4) { +if (unique(s$M)==2) { +a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4)) +} else { +a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), +m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), +m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), +m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3) +) +} +} else { +if (unique(s$M)==2) { +a <- data.frame(m.item1=mean(s$item1),m.item2=mean(s$item2),m.item3=mean(s$item3),m.item4=mean(s$item4), +m.item5=mean(s$item5),m.item6=mean(s$item6),m.item7=mean(s$item7)) +} else { +a <- data.frame(m.item1_1=mean(s$item1_1),m.item1_2=mean(s$item1_2),m.item1_3=mean(s$item1_3), +m.item2_1=mean(s$item2_1),m.item2_2=mean(s$item2_2),m.item2_3=mean(s$item2_3), +m.item3_1=mean(s$item3_1),m.item3_2=mean(s$item3_2),m.item3_3=mean(s$item3_3), +m.item4_1=mean(s$item4_1),m.item4_2=mean(s$item4_2),m.item4_3=mean(s$item4_3), +m.item5_1=mean(s$item5_1),m.item5_2=mean(s$item5_2),m.item5_3=mean(s$item5_3), +m.item6_1=mean(s$item6_1),m.item6_2=mean(s$item6_2),m.item6_3=mean(s$item6_3), +m.item7_1=mean(s$item7_1),m.item7_2=mean(s$item7_2),m.item7_3=mean(s$item7_3) +) +} +} +zz <- substr(scenario,start=0,stop=nchar(scenario)-4) +b <- data.frame(scenario=zz, +scenario.type=substr(zz,start=nchar(zz),stop=nchar(zz)), +N=substr(scenario,start=nchar(scenario)-2,stop=nchar(scenario)), +J=unique(s$J), +M=unique(s$M), +eff.size=unique(s$eff.size), +nb.dif=unique(s$nb.dif), +dif.size=unique(s$dif.size) +) +z <- data.frame(m.beta=mean(s$beta), +se.empirical.beta=sd(s$beta), +se.analytical.beta=mean(s$se.beta), +m.low.ci.beta=mean(s$low.ci.beta), +m.high.ci.beta=mean(s$high.ci.beta), +true.value.in.ci.p=mean(s$true.value.in.ci), +h0.rejected.p=mean(s$h0.rejected), +beta.same.sign.truebeta.p=mean(s$beta.same.sign.truebeta,na.rm=T), +beta.same.sign.truebeta.signif.p=mean(s[s$h0.rejected==1,]$beta.same.sign.truebeta,na.rm=T)) +d <- cbind(b,a,z) +d$prop. +return(d) +} +#### Compiled results +res.dat <- compile_simulation('1A_100') +for (x in results[seq(2,length(results))]) { +y <- compile_simulation(x) +res.dat <- bind_rows(res.dat,y) +} +res.dat[res.dat$scenario.type=='A','dif.size'] <- -res.dat[res.dat$scenario.type=='A','dif.size'] +res.dat[is.na(res.dat$dif.size),'dif.size'] <- 0 +res.dat[132:300,'nb.dif'] <- 2 +res.dat[300:396,'nb.dif'] <- 3 +res.dat.simple <- res.dat[,c(1:8,13,16:18)] +res.dat.simple$m.beta <- round(res.dat.simple$m.beta,3) +res.dat.simple +boxplot(beta.same.sign.truebeta.signif.p~dif.size,data=res.dat,col=c(2,3),xlab='DIF size', +ylab='Proportion of estimates with same sign as true value in target scenario',main='DIF on 3 items',ylim=c(0,1)) +res.null3 <- res.dat[res.dat$dif.size==-0.5,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(1,nrow(res.null3)),col='#590b0c',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0.5,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(5,nrow(res.null3)),col='#590b0c',pch=3) +res.null3 <- res.dat[res.dat$dif.size==-0.3,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(2,nrow(res.null3)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0.3,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(4,nrow(res.null3)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0,] +points(y=res.null3$beta.same.sign.truebeta.p,x=rep(3,nrow(res.null3)),col='gray',pch=3) +boxplot(beta.same.sign.truebeta.signif.p~dif.size,data=res.dat,col=c(2,3),xlab='DIF size', +ylab='Proportion of estimates with same sign as true value in target scenario',main='DIF on 3 items',ylim=c(0,1)) +res.null3 <- res.dat[res.dat$dif.size==-0.5,] +points(y=res.null3$beta.same.sign.truebeta.signif.p,x=rep(1,nrow(res.null3)),col='#590b0c',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0.5,] +points(y=res.null3$beta.same.sign.truebeta.signif.p,x=rep(5,nrow(res.null3)),col='#590b0c',pch=3) +res.null3 <- res.dat[res.dat$dif.size==-0.3,] +points(y=res.null3$beta.same.sign.truebeta.signif.p,x=rep(2,nrow(res.null3)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0.3,] +points(y=res.null3$beta.same.sign.truebeta.signif.p,x=rep(4,nrow(res.null3)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$dif.size==0,] +points(y=res.null3$beta.same.sign.truebeta.signif.p,x=rep(3,nrow(res.null3)),col='gray',pch=3) +## Proportion of rejected h0 per dif value in h0 scenarios (A) by DIF size +res.null <- res.dat[res.dat$eff.size!=0,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,1),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size!=0 & res.dat$dif.size==0,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='gray',pch=3) +res.null3 <- res.dat[res.dat$eff.size!=0 & res.dat$dif.size==-0.3,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size!=0 & res.dat$dif.size==-0.5,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size>0,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,1),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='gray',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.3,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.5,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size>0,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='gray',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.3,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.5,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size>0,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.3,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.5,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size>0,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.3,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.5,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.3,] +points(y=res.null3$h0.rejected.p,x=rep(4,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.5,] +points(y=res.null5$h0.rejected.p,x=rep(5,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size>0 & res.dat$N==100,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0 & res.dat$N==100,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.3 & res.dat$N==100,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.5 & res.dat$N==100,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.3 & res.dat$N==100,] +points(y=res.null3$h0.rejected.p,x=rep(4,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.5 & res.dat$N==100,] +points(y=res.null5$h0.rejected.p,x=rep(5,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size>0 & res.dat$N==300,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0 & res.dat$N==300,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.3 & res.dat$N==300,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==-0.5 & res.dat$N==300,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.3 & res.dat$N==300,] +points(y=res.null3$h0.rejected.p,x=rep(4,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.5 & res.dat$N==300,] +points(y=res.null5$h0.rejected.p,x=rep(5,nrow(res.null5)),col='#053305',pch=3) +############# By N // EFF SIZE NEGATIVE +####### N=100 +res.null <- res.dat[res.dat$eff.size<0 & res.dat$N==100,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0 & res.dat$N==100,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.3 & res.dat$N==100,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.5 & res.dat$N==100,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0.3 & res.dat$N==100,] +points(y=res.null3$h0.rejected.p,x=rep(4,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0.5 & res.dat$N==100,] +points(y=res.null5$h0.rejected.p,x=rep(5,nrow(res.null5)),col='#053305',pch=3) +####### N=300 // DIF Ă  0.5 - QUELS SONT LES SCENARIOS EN HAUT +res.null <- res.dat[res.dat$eff.size<0 & res.dat$N==300,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0 & res.dat$N==300,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.3 & res.dat$N==300,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.5 & res.dat$N==300,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0.3 & res.dat$N==300,] +points(y=res.null3$h0.rejected.p,x=rep(4,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0.5 & res.dat$N==300,] +points(y=res.null5$h0.rejected.p,x=rep(5,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size<0 & res.dat$N==100,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0 & res.dat$N==100,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.3 & res.dat$N==100,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.5 & res.dat$N==100,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size<0 & res.dat$N==300,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0 & res.dat$N==300,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.3 & res.dat$N==300,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.5 & res.dat$N==300,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +res.null <- res.dat[res.dat$eff.size<0 & res.dat$N==100,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0 & res.dat$N==100,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.3 & res.dat$N==100,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.5 & res.dat$N==100,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) +muA=5 +muB=10 +kappa=1 +sd=10 +alpha=0.05 +beta=0.20 +(nB=(1+1/kappa)*(sd*(qnorm(1-alpha/2)+qnorm(1-beta))/(muA-muB))^2) +ceiling(nB) # 63 +z=(muA-muB)/(sd*sqrt((1+1/kappa)/nB)) +(Power=pnorm(z-qnorm(1-alpha/2))+pnorm(-z-qnorm(1-alpha/2))) +muA=5 +muB=10 +kappa=1 +sd=10 +alpha=0.05 +beta=0.20 +(nB=(1+1/kappa)*(sd*(qnorm(1-alpha/2)+qnorm(1-beta))/(muA-muB))^2) +ceiling(nB) # 63 +z=(muA-muB)/(sd*sqrt((1+1/kappa)/nB)) +(Power=pnorm(z-qnorm(1-alpha/2))+pnorm(-z-qnorm(1-alpha/2))) diff --git a/RProject/desc_analysis.R b/RProject/desc_analysis.R index 9093daa..dd4efd2 100644 --- a/RProject/desc_analysis.R +++ b/RProject/desc_analysis.R @@ -246,6 +246,8 @@ par(mfrow=c(1,1)) #----------------------------------------------------------------------------# ############################################################################## +#### CALCULER LA PUISSANCE THEORIQUE AVEC RASCHPOWER + ## Proportion of rejected h0 per dif value in h1 scenarios by DIF size // eff.size positive res.null <- res.dat[res.dat$eff.size>0,] @@ -262,7 +264,7 @@ res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.5,] points(y=res.null5$h0.rejected.p,x=rep(5,nrow(res.null5)),col='#053305',pch=3) -############# By N +############# By N // EFF SIZE POSITIVE ####### N=100 @@ -295,6 +297,32 @@ res.null5 <- res.dat[res.dat$eff.size>0 & res.dat$dif.size==0.5 & res.dat$N==300 points(y=res.null5$h0.rejected.p,x=rep(5,nrow(res.null5)),col='#053305',pch=3) +############# By N // EFF SIZE NEGATIVE + +####### N=100 + +res.null <- res.dat[res.dat$eff.size<0 & res.dat$N==100,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0 & res.dat$N==100,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.3 & res.dat$N==100,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.5 & res.dat$N==100,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) + + +####### N=300 // DIF Ă  0.5 - QUELS SONT LES SCENARIOS EN HAUT + +res.null <- res.dat[res.dat$eff.size<0 & res.dat$N==300,] +boxplot(h0.rejected.p~dif.size,data=res.null,col=c(3,2,4,2,3),xlab='DIF size',ylab='H0 rejection proportion in target scenario') +res.null0 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==0 & res.dat$N==300,] +points(y=res.null0$h0.rejected.p,x=rep(3,nrow(res.null0)),col='darkblue',pch=3) +res.null3 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.3 & res.dat$N==300,] +points(y=res.null3$h0.rejected.p,x=rep(2,nrow(res.null3)),col='#590b0c',pch=3) +res.null5 <- res.dat[res.dat$eff.size<0 & res.dat$dif.size==-0.5 & res.dat$N==300,] +points(y=res.null5$h0.rejected.p,x=rep(1,nrow(res.null5)),col='#053305',pch=3) + + ############################################################################## #----------------------------------------------------------------------------# ########################## SYSTEMATIC ERROR BOXPLOTS #########################