! NPML/normal macros for overdispersed GLMs, by Brian Francis and MA.
!
! Macro remz provides Gaussian quadrature for the specified number of
! mass-points from 1 to 10 and 20 (in $use mass1$...$use mass20$).
! Macro remnp provides nonparametric maximum likelihood estimation of 
! the mixing distribution of the random effects.
! Using one masspoint ($use mass1$) is equivalent to fitting the 
! regular GLM without overdispersion.
!
! Fitted values of the mean function can be constructed by tabulating ! the fitted values from the model with the weight vector p_ :
! $tab the %fv mean with p_ for i_ into fv_ $
!
! The remnp and remz macros require one or two arguments:
! 1) the y-variate;
! 2) If the data are binomial, the second argument is the binomial
! denominator. In this case the link function has to be set in the ! macro "setlink" (as in $macro setlink p $endm) - by default it is the ! logit.        
! Note to user: this version of REMNP uses a scalar scale_ which sets 
! the positions of the mass-points in the NPML estimation. It is set to ! 0.1 at the end of this listing; this is the value we have found to 
! work best for binomial and Poisson models. For normal models we have ! found that a value of 1 works better in locating the global maximum 
! and the user should try resetting scale_ to this (or a larger) value ! for these models (by $ca scale_=1$).
!
$macro mass1!
  $num k__=1$del dz_ dp_ $dat k__ dz_ dp_ !
   $read!  
    0 1.0!
$$endmac!
!   
$macro mass2!
   $num k__=2$del dz_ dp_ $dat k__ dz_ dp_ !
   $read !
   1.0 0.5     -1.0 0.5!
$$endmac!
!
$macro mass3!
   $num k__=3$del dz_ dp_ $dat k__ dz_ dp_ !
   $read!
   1.732 0.1667   0.0   0.6666  -1.732 0.1667!
$$endmac!
!
$macro mass4!
   $num k__=4$del dz_ dp_ $dat k__ dz_ dp_ !
   $read!
   2.3344 0.0459   0.7420 0.4541!
  -0.7420 0.4541  -2.3344 0.0459!
$$endmac!
!
$macro mass5!
   $num k__=5$del dz_ dp_ $dat k__ dz_ dp_ !
   $read!
   2.8570 0.0113   1.3556 0.2221   0.   0.5332!
  -1.3556 0.2221  -2.8570 0.0113!
$$endmac!
!
$macro mass6!
   $num k__=6$del dz_ dp_ $dat k__ dz_ dp_ !
   $read!
   3.3243 0.0025   1.8892 0.0886   0.6167 0.4089!
  -0.6167 0.4089  -1.8892 0.0886  -3.3243 0.0025!
$$endm!
!
$macro mass7!
   $num k__=7 $del dz_ dp_ pp_ $dat k__ dz_ dp_ !
   $read!       
   3.7504 .0005    2.3667 .0308    1.1544 .2401   0      .4572!   
  
  -1.1544 .2401   -2.3667 .0308   -3.7504 .0005!
$$endmac
!
$macro mass8!
  $num k__=8 $del dz_ dp_ pp_ $dat k__ dz_ dp_ !
   $read!
   4.1446 .0001    2.8025 .0096    1.6365 .1173  0.5391 .3730!
  -0.5391 .3730   -1.6365 .1173   -2.8025 .0096 -4.1446 .0001!
$$endmac
!
$macro mass9!
   $num k__=9 $del dz_ dp_ pp_ $dat k__ dz_ dp_ !
   $read!
   4.5127 .00002   3.2054 .00279   2.0768 .04992  1.0232 .24410!
   0      .40634  -1.0232 .24410  -2.0768 .04992 -3.2054 .00279!
  -4.5127 .00002!
$$endmac
!
$macro mass10!
   $num k__=10 $del dz_ dp_ pp_ $dat k__ dz_ dp_ !
   $read!
   4.8594 .000005   3.5818 .000758   2.4843 .019111   1.4660 .135484!
   0.4849 .344642  -0.4849 .344642  -1.4660 .135484  -2.4843 .019111!
  -3.5818 .000758  -4.8594 .000005!
$$endmac
!
$macro mass20!
   $num k__=14 $del dz_ dp_ pp_ $dat k__ dz_ dp_ ! 
   $read1
   4.7346 .000004   3.9440 .000129   3.1890 .001830   2.4587 .013998!
   1.7453 .061506   1.0429 .161739   0.3470 .260792  -0.3470 .260792!
  -1.0429 .161739  -1.7453 .061506  -2.4587 .013998  -3.1890 .001830!
  -3.9440 .000129  -4.7346 .000004!
$$endmac
!
$macro remz!
  $use startup %1 %2$!
  $output$!
  $while s__ emz$!
  $output %poc$!
  $warn on$use emz$use tidyup$!
$endmac!
!
$macro remnp!
  $use startup %1 %2$!
  $output$!
  $while s__ emnp$!
  $output %poc $!
  $warn on$use emnp$use tidyup$!
$endmac!
!
$macro refitz!
  $num s__=500 : r__=0$!
  $while s__ emz$!
  $warn on$use emz$use tidyup$!
$endmac!
!
$macro refitnp!
  $num s__=500 : r__=0$!
  $while s__ emnp$!
  $warn on$use emnp$use tidyup$!
$endmac
!
$macro startup!
  $use setup %1 %2$use initial %1$!
  $ca s__=500$!
$endm!
!
$macro setup!
  $num a__ c__ d__ e__ f__ k__ l__ m__ n__ r__ s__ scale_ sd__ t__ $!
  $warn off$
  $del y_ z_ p_ pp_ w_ wb_ wc_ i_ k_ h_ hw_ tlp_ %lp %fv ! 
       numpp_ lnumpp_ n_ ofs_$!
  $calc n__=%len(%1) : m__=n__*k__! Extended sample size
  $var m__  z_ p_ wb_ wc_ i_ k_ tlp_ numpp_  h_ n_ ofs_!
    : n__  w_ hw_ lnumpp_ y_ : k__ pp_$!
 $gfac k_ k__ i_ n__$ !
  $calc w_=1 : y_=%1 : z_=dz_(k_) : p_=dp_(k_) : n_=1$!
  $yvar %1$!
  $calc %z2=1-(%err==3) : %z3=0 $exit %z2$!
  $err b %2$!
$$endmac!
!
$macro(loc= scale) initial !
  $num scale$calc scale=(%err>1) : sd__=1$!
  $use checklnk$scale scale$! Initial fit
  $output$cycl $wei w_$offset! %os$!
  $fit #fixed $d e$!
  $swi %err sdmac$!
  $ca a__=-(%err==2)*2*%cu(%yv*(%log(%yv)-1))! Poisson
       +(%err==4)*2*%cu(1+%log(%yv))         ! Exponential
  $ca res_=%rs$! Residuals from GLM
  $calc tlp_=%lp(i_)!
  $del %fv %lp w_ y_$var m__ w_ y_$!
  $calc %z2=(%err==3)$switch %z2 bino$link #setlink$!
  $calc y_=%1(i_)!:ofs_=%os(i_)
  $yvar y_ $sca scale$wei w_ $offset !ofs_
  $recy!
  $calc %lp=tlp_+scale_*z_$!
  :%fv=(%lin==1)*%lp+                        !identity link
       (%lin==2)*%exp(%lp)+                  !log link
       (%lin==3)*n_*%exp(%lp)/(1+%exp(%lp))+ !logit link
       (%lin==6)*n_*%np(%lp)+                !probit link
       (%lin==7)*n_*(1-%exp(-%exp(%lp)))$    !CLL link
  : c__=0.001 : r__=0 : d__=0$!
  $use wei$!
$$endmac!
!
$macro wei!
  $calc numpp_=%log(p_) !
  +(%err==1)*(-0.5*((y_-%fv)/sd__)**2-%log(sd__)-0.5*%log(2*%pi))!
  +(%err==2)*(y_*%lp-%exp(%lp)) !
  +(%err==3)*((%lin==3)*(y_*%lp-n_*%log(1+%exp(%lp)))!logit 
   +(%lin==6)*(y_*%log(%np(%lp))+(n_-y_)*%log(1-%np(%lp)))!
   +(%lin==7)*(y_*%log(1-%exp(-%exp(%lp)))+(n_-y_)*(-%exp(%lp))))!
  +(%err==4)*(-y_*%exp(-%lp)-%lp)$!
  $tab the numpp_ largest for i_ into lnumpp_$!
  $calc wc_=numpp_-lnumpp_(i_)!
  :     wb_=%exp(wc_)!
  :     hw_=0!
  :     hw_(i_)=hw_(i_)+wb_!
  :     h_=hw_(i_)!
  :     w_=wb_/h_ $!
$$endmac!
!
$macro dev!
   $calc e__=-2*%cu(lnumpp_+%log(hw_))! -2 log L max             
   :t__=%ge(d__-e__,c__)+%ge(e__-d__,c__)!
   :d__=e__!
   :s__=%if(%le(t__,0),0,s__-1)! Check convergence
   :r__=r__+1!
   :f__=e__-a__$! Correction gives deviance
  !$output %poc$! 
 $print '-2 log L='*r e__,8,2' , deviance = '*r f__,8,2
         ', after ' *i r__' iterations'!$
  $calc %z3=(s__<=0)*%poc$ ! output indicator
  !$output$ 
$$endm
!
$macro emz!
   $fit (#fixed)(i_)+z_+(#random)(i_).z_$!
   !$output %z3$d e$!
   $swi %err sdmac$!
   $use wei$!
   $use dev!
$$endm
!
$macro emnp!
   $fit (#fixed)(i_)+k_+(#random)(i_).k_ - 1 $!
   $d e$!
   $swi %err sdmac$!
   $calc pp_=0 : pp_(k_)=(pp_(k_)+w_) : pp_=pp_/n__ :!
        p_=pp_(k_)! Update mixture proportions
   $pri 'mixture proportions :' pp_ $!
   $use wei$!
   $use dev!
$$endm!
!                                                         
$macro sdmac ! for normal distn.
   $cal sd__=%sqrt(%cu(w_*(y_-%fv)**2)/%cu(w_))$!
   $pr 'MLE of sigma = 'sd__$!
$endm
!
$macro(loc=i,l,g,r,s,p,c,lnklst) checklnk !
   $calc %z1=(%err>4)$!
   $fault %z1 'Invalid error distribution for macro'$!
   $list lnklst=i,l,g,r,s,p,c$!
   $calc l__=(%lin==3)?(%lin==6)?(%lin==7)!
   :     l__=(%err==1)*1 + ((%err==2)?(%err==4))*2 +! 
          (%err==3)*l__*%lin + (%err==3)*(1-l__)*3!
   $print(store=setlink)*n lnklst[l__] $!
   $calc %z1=(l__==%lin)$link #setlink$!
   $tidy lnklst$del lnklist$!
   $exit %z1$print '--- link reset to ' setlink$!
$endmac
!
$macro bino !
   $calc n_=%bd(i_)! 
   : a__=-2*%cu(%yv*%log(%yv)+(%bd-%yv)*%log(%bd-%yv)!
                -%bd*%log(%bd))$!
   $err b n_$!
$endmac
!
$macro tidyup !
   $tidy checklnk : initial$!
   $del z_  wb_ wc_  h_ hw_ tlp_  numpp_ lnumpp_ $!
   $del  l__ m__  r__  setlink$!
   $output %poc$print $!
$$endmac
!
$num scale_=0.1$!
$return$
$return$

