swh:1:snp:3aec91c51d538d62f3f51f6a0af59fe452f330ab
Tip revision: ec4ba561accfa7ac51509e5fb581b6584ee6a425 authored by Zhu Wang on 15 April 2019, 06:42:38 UTC
version 0.3-12
version 0.3-12
Tip revision: ec4ba56
midloop.f
CCC ONLY used for family=1; compare with midloopGLM for other family
C Middle loop: Update the quadratic approximation likelihood
C input:
C n
C m
C x
C y
C mu
C family
C nlambda
C lamk
C alpha
C gam
C maxit
C del
C thresh
C wt used only for family=1
C trace
C innermaxit: not used except for family=1
C maxit: not used (and maxit=1) for family=1
C output:
C beta
C b0
C yhat
C dev
subroutine midloop(n,m,x,y,xold,yold,weights, mu, eta, offset,
+ family,
+ penalty,lamk,
+ alpha, gam, theta, rescale, standardize,eps,innermaxit,
+ maxit, thresh, nulldev, wt, beta, b0,yhat,dev,trace,convmid,
+ ep, normx, xd, avg, activeset, jk, fullset)
implicit none
integer standardize, trace, penalty, maxit, i, j, nmid, n,
+ family, innermaxit, m,converged,convmid, satu, rescale,
+ fullset(m),activeset(m), jk
double precision x(n,m),y(n), mu(n), z(n), eta(n), wt(n), w(n),
+ del,olddev,weights(n),xold(n,m), yold(n),normx(m),xd(m),
+ thresh, nulldev, dev, theta, wtw(n),lamk(m),alpha,
+ gam, eps, beta(m), b0, yhat(n),avg, ep,
+ pll(maxit), offset(n)
C innermaxit = maxit
maxit = 1
C innermaxit serves as maxit here
C do 5 jj=1, maxit
C pll(jj)=0
C 5 enddo
dev = nulldev
call glmlink(n,mu,family,theta,w, ep)
call zeval(n, y, eta, mu, w, family, z)
do 10 i=1, n
wtw(i)=wt(i) * w(i)
z(i)=z(i) - offset(i)
10 continue
call preprocess(x, z, n, m, wtw, family, standardize,
+ normx, xd, avg)
call lmnetGaus(x, z, n, m, wtw, lamk, alpha, gam, thresh,
+ innermaxit, eps, standardize, penalty, xd,
+ beta, b0, avg, nmid,rescale, converged, activeset, jk,
+ fullset)
do 220 i = 1, n
yhat(i) = b0
do 230 j = 1, m
if(family .EQ. 1)then
yhat(i) = yhat(i) + xold(i,j) * beta(j)
else
yhat(i) = yhat(i) + x(i,j) * beta(j)
endif
230 continue
220 continue
call DCOPY(n, yhat, 1, eta, 1)
do 350 i = 1, n
eta(i) = eta(i) + offset(i)
350 continue
call linkinv(n, eta, family, mu)
olddev = dev
C compute deviance dev
call deveval(n, yold, mu, theta, weights, family, dev)
del = dabs(dev - olddev)
convmid = converged
if(trace.EQ.1)then
call dblepr("deviance difference at the end of middle loop "
+ , -1, del, 1)
endif
return
end