gam/0000755000176000001440000000000013507061371011051 5ustar ripleyusersgam/inst/0000755000176000001440000000000011665556374012045 5ustar ripleyusersgam/inst/ratfor/0000755000176000001440000000000013324234205013316 5ustar ripleyusersgam/inst/ratfor/splsm.r0000644000176000001440000001564712176062444014664 0ustar ripleyuserssubroutine sknotl(x,n,knot,k) implicit double precision(a-h,o-z) double precision x(n),knot(n+6),a1,a2,a3,a4 integer n,k,ndk,j # Allocate knots acording to the cutoffs given below # Cutoff constants a1 = log(50d0)/log(2d0) ; a2 = log(100d0)/log(2d0) a3 = log(140d0)/log(2d0) ; a4 = log(200d0)/log(2d0) # Cutoff Criteria if(n<50) { ndk = n } else if (n>=50 & n<200) { ndk = 2.**(a1+(a2-a1)*(n-50.)/150.) } else if (n>=200 & n<800) { ndk = 2.**(a2+(a3-a2)*(n-200.)/600.) } else if (n>=800 & n<3200) { ndk = 2.**(a3+(a4-a3)*(n-800.)/2400.) } else if (n>=3200) { ndk = 200. + float(n-3200)**.2 } k = ndk + 6 # Allocate Knots ( note no account is taken of any weighting vector ) do j=1,3 { knot(j) = x(1) } do j=1,ndk { knot(j+3) = x( 1 + (j-1)*(n-1)/(ndk-1) ) } do j=1,3 { knot(ndk+3+j) = x(n) } return end subroutine splsm(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,work) #This subroutine performs a smoothing spline fit # This was written by Trevor Hastie in 1990 # It has been modified from the S3 version by Trevor Hastie # in July 2004, to accommodate the modified sbart routine in R # and also to accommodate only the gam bakfit routine. # Note that spar has changed, and we change it here to conform with # the smooth.spline routine in R #All arguments are either double precision or integer #INPUT # #x double length n ; x variable for smoothing #y double length n ; y variable for smoothing #w double length n ; weights for smoothing, > 0 #n integer length above #match integer length n -- in S language x[i] == sort(unique(x)[match[i]] # match is produced by subroutine namat #nef number of unique elements in x; so match has values between 1 and nef+1 # missing data are given the match number nef+1 #spar double smoothing parameter -1.5 =1, dof is used # note: dof does not use the constant term #ifcov integer if 1, the unscaled variance information is computed #work double workspace of length (10+2*4)*(nef+2)+5*nef+n+15 # #OUTPUT # #x,y,w,n,match,nef are untouched #spar if dof > 1, then spar is that which achieves dof #dof the dof of the fitted smooth. Note: even if dof was given # as 4, it will be returned as say 3.995 which is what # spar produces #smo double length n the fitted values, with weighted average 0 #s0 double weighted mean of y #cov double length nef the unscaled variance elements for the NONLINEAR # and UNIQUE part of smo, in the order of sort(unique(x)) # cov is lev(i)/w(i) -h(i)/w where h(i) is the hat element from # the simple weighted least squares fit. This is passed on # to bakfit and used in gamcov # # splsm calls (eventually after some memory management dummy calls) # sbart, the spline routine of Finbarr O'Sullivan, slightly modified # by Trevor Hastie, 8/2/89 implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,cov(*),work(*) integer n,match(*),nef integer ifcov # work should be (10+2*ld4)*nk+5*nef+n+15 double # ld4 =4 nk<= nef+2 call splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov, # xin(nef+1),yin(nef+1), win(nef+1), knot(n+6), work(1), work(nef+2),work(2*nef+3),work(3*nef+4), work(3*nef+n+10)) return end subroutine splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,win,knot, work) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*),work(*) integer n,match(*),nef integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nef+6) integer nk,ldnk,ld4,k double precision xmin,xrange call suff(n,nef,match,x,y,w,xin,yin,win,work(1)) xmin=xin(1) xrange=xin(nef)-xin(1) do i=1,nef {xin(i)=(xin(i)-xmin)/xrange} call sknotl(xin,nef,knot,k) nk=k-4 ld4=4 ldnk=1 # p21p nd ldnk is not used call splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,win,knot, # coef(nk),sout(nef+1), levout(nef+1), xwy(nk), # hs0(nk), hs1(nk), hs2(nk), # hs3(nk), # sg0(nk), sg1(nk), sg2(nk), # sg3(nk), # abd(ld4,nk), p1ip(ld4,nk), # p2ip(ldnk,nk) work(1), work(nk+1), work(nk+nef+2),work(nk+2*nef+3), work(2*nk+2*nef+3),work(3*nk+2*nef+3),work(4*nk+2*nef+3), work(5*nk+2*nef+3), work(6*nk+2*nef+3),work(7*nk+2*nef+3),work(8*nk+2*nef+3), work(9*nk+2*nef+3), work(10*nk+2*nef+3),work((10+ld4)*nk+2*nef+3), work((10+2*ld4)*nk+2*nef+3), ld4,ldnk,nk) return end subroutine splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,win,knot, coef,sout,levout,xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,nk) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*) integer n,match(*),nef integer nk,ldnk,ld4 integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nk+4) double precision coef(nk),sout(nef+1),levout(nef+1),xwy(nk), hs0(nk),hs1(nk),hs2(nk),hs3(nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(ld4,nk),p1ip(ld4,nk),p2ip(ldnk,*) # local variables integer ispar,icrit,isetup,ier double precision lspar,uspar,tol,penalt, sumwin,dofoff,crit,xbar,dsum,xsbar double precision yssw, eps integer maxit # yssw is an additional parameter introduced in R version of sbart double precision wmean crit=0d0 # Note we only allow limited options here if(dof <= 0d0){ # use spar ispar=1 icrit=3 dofoff=0d0 } else{ if( dof < 1d0 )dof=1d0 ispar=0 icrit=3 dofoff=dof+1d0 } #Here we set some default parameters similar to the smooth.spline in R isetup=0 ier=1 penalt=1d0 lspar= -1.5 uspar= 2.0 tol=1d-4 eps=2d-8 maxit=200 do i=1,nef sout(i)=yin(i)*yin(i) sumwin=0d0 do i=1,nef sumwin=sumwin+win(i) yssw=wmean(nef,sout,win) s0=wmean(n,y,w) # which should be equal to wmean(nef,yin,win) yssw=yssw*(sumwin-s0*s0) call sbart(penalt,dofoff,xin,yin,win,yssw,nef,knot,nk, coef,sout,levout,crit, icrit,spar,ispar,maxit, lspar,uspar,tol,eps, isetup, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier) #return #now clean up do i=1,nef { win(i)=win(i)*win(i) #we sqrted them in sbart } sbar=wmean(nef,sout,win) xbar=wmean(nef,xin,win) #now remove the linear leverage from the leverage for the smooths # will be altered at this stage do i=1,nef {lev(i)=(xin(i)-xbar)*sout(i) } xsbar=wmean(nef,lev,win) do i=1,nef {lev(i)=(xin(i)-xbar)**2 } dsum=wmean(nef,lev,win) do i=1,nef { if(win(i)>0d0) { lev(i)=levout(i)/win(i)-1d0/sumwin -lev(i)/(sumwin*dsum) } else {lev(i)=0d0} } dof=0d0 do i=1,nef {dof=dof+lev(i)*win(i)} dof=dof+1d0 do i=1,nef sout(i)=sout(i)-sbar -(xin(i)-xbar)*xsbar/dsum call unpck(n,nef,match,sout,smo) return end double precision function wmean(n,y,w) integer n double precision y(n),w(n),wtot,wsum wtot=0d0 wsum=0d0 do i=1,n{ wsum=wsum+y(i)*w(i) wtot=wtot+w(i) } if(wtot > 0d0) {wmean=wsum/wtot} else {wmean=0d0} return end gam/inst/ratfor/linear.r0000644000176000001440000013671712135622704014776 0ustar ripleyuserssubroutine dqrls(x,dx,pivot,qraux,y,dy,beta,res,qt,tol,scrtch,rank) integer pivot(*),dx(2),dy(2),rank double precision x(*), qraux(*), y(*), beta(*),res(*),qt(*),tol(*), scrtch(*) integer n,p,q,kn,kp,k,info n=dx(1); p=dx(2); q=dy(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1)) kn=1; kp=1 if(rank>0)for(k=1;k<=q;k=k+1){ call dqrsl(x,n,n,rank,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn),scrtch,00110,info) kn = kn+n; kp=kp+p } return end #apply the qr decomposition to do various jobs subroutine dqrsl1(qr,dq,qra,rank,y,k,qy,qb,job,info) double precision qr(*),qra(*),y(*),qy(*),qb(*); integer dq(2),job,k,rank integer n,kn,kb,j double precision ourqty(1), ourqy(1), ourb(1), ourrsd(1), ourxb(1) ourqty(1) = 0d0 ourqy(1) = 0d0 ourb(1) = 0d0 ourrsd(1) = 0d0 ourxb(1) = 0d0 n = dq(1) kn = 1; kb = 1 switch(job) { case 10000: #qy for(j=0; j 0.)t = nrmxl/t if(t < eps){ call dshift(x,ldx,n,l,curpvt) jp = jpvt(l); t=qraux(l); tt=work(l); ww = work(l+p) for(j=l+1; j<=curpvt; j=j+1){ jj=j-1 jpvt(jj)=jpvt(j); qraux(jj)=qraux(j) work(jj)=work(j); work(jj+p) = work(j+p) } jpvt(curpvt)=jp; qraux(curpvt)=t; work(curpvt)=tt; work(curpvt+p) = ww curpvt=curpvt-1; if(lup>curpvt)lup=curpvt } else { if(l==n)break if (x(l,l)!=0.0d0) nrmxl = dsign(nrmxl,x(l,l)) call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1) x(l,l) = 1.0d0+x(l,l) for(j=l+1; j<=curpvt; j=j+1) { t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) if (qraux(j)!=0.0d0) { tt = 1.0d0-(dabs(x(l,j))/qraux(j))**2 tt = dmax1(tt,0.0d0) t = tt tt = 1.0d0+0.05d0*tt*(qraux(j)/work(j))**2 if (tt!=1.0d0) qraux(j) = qraux(j)*dsqrt(t) else { qraux(j) = dnrm2(n-l,x(l+1,j),1) work(j) = qraux(j) } } } qraux(l) = x(l,l) x(l,l) = -nrmxl l=l+1 } } rank = lup return end subroutine dchdc(a,lda,p,work,jpvt,job,info) integer lda,p,jpvt(p),job,info double precision a(lda,p),work(p) integer pu,pl,plp1,j,jp,jt,k,kb,km1,kp1,l,maxl double precision temp double precision maxdia logical swapk,negk pl = 1 pu = 0 info = p if (job!=0) { do k = 1,p { swapk = jpvt(k)>0 negk = jpvt(k)<0 jpvt(k) = k if (negk) jpvt(k) = -jpvt(k) if (swapk) { if (k!=pl) { call dswap(pl-1,a(1,k),1,a(1,pl),1) temp = a(k,k) a(k,k) = a(pl,pl) a(pl,pl) = temp plp1 = pl+1 if (p>=plp1) do j = plp1,p if (j=pl) do kb = pl,p { k = p-kb+pl if (jpvt(k)<0) { jpvt(k) = -jpvt(k) if (pu!=k) { call dswap(k-1,a(1,k),1,a(1,pu),1) temp = a(k,k) a(k,k) = a(pu,pu) a(pu,pu) = temp kp1 = k+1 if (p>=kp1) do j = kp1,p if (j=pl&&kmaxdia) { maxdia = a(l,l) maxl = l } # quit if the pivot element is not positive. if (maxdia<=0.0d0) go to 10 if (k!=maxl) { # start the pivoting and update jpvt. km1 = k-1 call dswap(km1,a(1,k),1,a(1,maxl),1) a(maxl,maxl) = a(k,k) a(k,k) = maxdia jp = jpvt(maxl) jpvt(maxl) = jpvt(k) jpvt(k) = jp } # reduction step. pivoting is contained across the rows. work(k) = dsqrt(a(k,k)) a(k,k) = work(k) if (p>=kp1) do j = kp1,p { if (k!=maxl) if (jnm) ierr = 10*n else { call balanc(nm,n,a,is1,is2,fv1) call elmhes(nm,n,is1,is2,a,iv1) if (matz==0) # .......... find eigenvalues only .......... call hqr(nm,n,is1,is2,a,wr,wi,ierr) else { # .......... find both eigenvalues and eigenvectors .......... call eltran(nm,n,is1,is2,a,iv1,z) call hqr2(nm,n,is1,is2,a,wr,wi,z,ierr) if (ierr==0) call balbak(nm,n,is1,is2,fv1,n,z) } } return end subroutine chol(a,p,work,jpvt,job,info) integer p,jpvt(*),job,info(*) double precision a(p,*),work(*) integer i,j for(j =2; j<=p; j = j+1) for(i=1; i0; j=j-1 ){ do i = 1,l if (i!=j) if (a(j,i)!=0.0d0) next 2 go to 10 } go to 20 10 m = l iexc = 1 repeat { # .......... in-line procedure for row and # column exchange .......... scale(m) = j if (j!=m) { do i = 1,l { f = a(i,j) a(i,j) = a(i,m) a(i,m) = f } do i = k,n { f = a(j,i) a(j,i) = a(m,i) a(m,i) = f } } switch(iexc) { case 1: # .......... search for rows isolating an eigenvalue # and push them down .......... if (l==1) go to 40 l = l-1 break 1 case 2: # .......... search for columns isolating an eigenvalue # and push them left .......... k = k+1 20 do j = k,l { do i = k,l if (i!=j) if (a(i,j)!=0.0d0) next 2 go to 30 } break 2 30 m = k iexc = 2 } } } # .......... now balance the submatrix in rows k to l .......... do i = k,l scale(i) = 1.0d0 repeat { # .......... iterative loop for norm reduction .......... noconv = .false. do i = k,l { c = 0.0d0 r = 0.0d0 do j = k,l if (j!=i) { c = c+dabs(a(j,i)) r = r+dabs(a(i,j)) } # .......... guard against zero c or r due to underflow .......... if (c!=0.0d0&&r!=0.0d0) { g = r/radix f = 1.0d0 s = c+r while (c=g) { f = f/radix c = c/b2 } # .......... now balance .......... if ((c+r)/f<0.95d0*s) { g = 1.0d0/f scale(i) = scale(i)*f noconv = .true. do j = k,n a(i,j) = a(i,j)*g do j = 1,l a(j,i) = a(j,i)*f } } } } until(!noconv) 40 low = k igh = l return end subroutine balbak(nm,n,low,igh,scale,m,z) integer i,j,k,m,n,ii,nm,igh,low double precision scale(n),z(nm,m) double precision s if (m!=0) { if (igh!=low) do i = low,igh { s = scale(i) # .......... left hand eigenvectors are back transformed # if the foregoing statement is replaced by # s=1.0d0/scale(i). .......... do j = 1,m z(i,j) = z(i,j)*s } # ......... for i=low-1 step -1 until 1, # igh+1 step 1 until n do -- .......... do ii = 1,n { i = ii if (iigh) { if (i=kp1) do m = kp1,la { mm1 = m-1 x = 0.0d0 i = m do j = m,igh if (dabs(a(j,mm1))>dabs(x)) { x = a(j,mm1) i = j } int(m) = i if (i!=m) { # .......... interchange rows and columns of a .......... do j = mm1,n { y = a(i,j) a(i,j) = a(m,j) a(m,j) = y } do j = 1,igh { y = a(j,i) a(j,i) = a(j,m) a(j,m) = y } } # .......... end interchange .......... if (x!=0.0d0) { mp1 = m+1 do i = mp1,igh { y = a(i,mm1) if (y!=0.0d0) { y = y/x a(i,mm1) = y do j = m,n a(i,j) = a(i,j)-y*a(m,j) do j = 1,igh a(j,m) = a(j,m)+y*a(j,i) } } } } return end subroutine eltran(nm,n,low,igh,a,int,z) integer i,j,n,kl,mp,nm,igh,low,mp1 double precision a(nm,igh),z(nm,n) integer int(igh) # .......... initialize z to identity matrix .......... do j = 1,n { do i = 1,n z(i,j) = 0.0d0 z(j,j) = 1.0d0 } kl = igh-low-1 if (kl>=1) for(mp = igh-1; mp > low; mp = mp -1) { mp1 = mp+1 do i = mp1,igh z(i,mp) = a(i,mp-1) i = int(mp) if (i!=mp) { do j = mp,igh { z(mp,j) = z(i,j) z(i,j) = 0.0d0 } z(i,mp) = 1.0d0 } } return end subroutine hqr(nm,n,low,igh,h,wr,wi,ierr) integer i,j,k,l,m,n,en,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n) double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2 logical notlas ierr = 0 norm = 0.0d0 k = 1 # .......... store roots isolated by balanc # and compute matrix norm .......... do i = 1,n { do j = k,n norm = norm+dabs(h(i,j)) k = i if (iigh) { wr(i) = h(i,i) wi(i) = 0.0d0 } } en = igh t = 0.0d0 itn = 30*n repeat { # .......... search for next eigenvalues .......... if (en low; l = l-1){ s = dabs(h(l-1,l-1))+dabs(h(l,l)) if (s==0.0d0) s = norm tst1 = s tst2 = tst1+dabs(h(l,l-1)) if (tst2==tst1) break 1 } # .......... form shift .......... x = h(en,en) if (l==en) go to 50 y = h(na,na) w = h(en,na)*h(na,en) if (l==na) break 1 if (itn==0) break 2 if (its==10||its==20) { # .......... form exceptional shift .......... t = t+x do i = low,en h(i,i) = h(i,i)-x s = dabs(h(en,na))+dabs(h(na,enm2)) x = 0.75d0*s y = x w = -0.4375d0*s*s } its = its+1 itn = itn-1 # .......... look for two consecutive small # sub-diagonal elements. # for m=en-2 step -1 until l do -- .......... do mm = l,enm2 { m = enm2+l-mm zz = h(m,m) r = x-zz s = y-zz p = (r*s-w)/h(m+1,m)+h(m,m+1) q = h(m+1,m+1)-zz-r-s r = h(m+2,m+1) s = dabs(p)+dabs(q)+dabs(r) p = p/s q = q/s r = r/s if (m==l) break 1 tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1))) tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r)) if (tst2==tst1) break 1 } mp2 = m+2 do i = mp2,en { h(i,i-2) = 0.0d0 if (i!=mp2) h(i,i-3) = 0.0d0 } # .......... double qr step involving rows l to en and # columns m to en .......... do k = m,na { notlas = k!=na if (k!=m) { p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if (notlas) r = h(k+2,k-1) x = dabs(p)+dabs(q)+dabs(r) if (x==0.0d0) next 1 p = p/x q = q/x r = r/x } s = dsign(dsqrt(p*p+q*q+r*r),p) if (k!=m) h(k,k-1) = -s*x else if (l!=m) h(k,k-1) = -h(k,k-1) p = p+s x = p/s y = q/s zz = r/s q = q/p r = r/p if (!notlas) { # .......... row modification .......... do j = k,n { p = h(k,j)+q*h(k+1,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y } j = min0(en,k+3) # .......... column modification .......... do i = 1,j { p = x*h(i,k)+y*h(i,k+1) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q } } else { # .......... row modification .......... do j = k,n { p = h(k,j)+q*h(k+1,j)+r*h(k+2,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y h(k+2,j) = h(k+2,j)-p*zz } j = min0(en,k+3) # .......... column modification .......... do i = 1,j { p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q h(i,k+2) = h(i,k+2)-p*r } } } } # .......... two roots found .......... p = (y-x)/2.0d0 q = p*p+w zz = dsqrt(dabs(q)) x = x+t if (q<0.0d0) { # .......... complex pair .......... wr(na) = x+p wr(en) = x+p wi(na) = zz wi(en) = -zz } else { # .......... real pair .......... zz = p+dsign(zz,p) wr(na) = x+zz wr(en) = wr(na) if (zz!=0.0d0) wr(en) = x-w/zz wi(na) = 0.0d0 wi(en) = 0.0d0 } en = enm2 next 1 # .......... one root found .......... 50 wr(en) = x+t wi(en) = 0.0d0 en = na } # .......... set error -- all eigenvalues have not # converged after 30*n iterations .......... ierr = en return end subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr) integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn,igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n),z(nm,n) double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2 logical notlas ierr = 0 norm = 0.0d0 k = 1 # .......... store roots isolated by balanc # and compute matrix norm .......... do i = 1,n { do j = k,n norm = norm+dabs(h(i,j)) k = i if (iigh) { wr(i) = h(i,i) wi(i) = 0.0d0 } } en = igh t = 0.0d0 itn = 30*n repeat { # .......... search for next eigenvalues .......... if (enigh) do j = i,n z(i,j) = h(i,j) # .......... multiply by transformation matrix to give # vectors of original full matrix. # for j=n step -1 until low do -- .......... do jj = low,n { j = n+low-jj m = min0(j,igh) do i = low,igh { zz = 0.0d0 do k = low,m zz = zz+z(i,k)*h(k,j) z(i,j) = zz } } } return end subroutine cdiv(ar,ai,br,bi,cr,ci) double precision ar,ai,br,bi,cr,ci # complex division, (cr,ci) = (ar,ai)/(br,bi) double precision s,ars,ais,brs,bis s = dabs(br)+dabs(bi) ars = ar/s ais = ai/s brs = br/s bis = bi/s s = brs**2+bis**2 cr = (ars*brs+ais*bis)/s ci = (ais*brs-ars*bis)/s return end subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr) integer n,nm,ierr,matz double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n) if (n>nm) ierr = 10*n else if (matz!=0) { # .......... find both eigenvalues and eigenvectors .......... call tred2(nm,n,a,w,fv1,z) call tql2(nm,n,w,fv1,z,ierr) } else { # .......... find eigenvalues only .......... call tred1(nm,n,a,w,fv1,fv2) call tqlrat(n,w,fv2,ierr) } return end subroutine tql2(nm,n,d,e,z,ierr) integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr double precision d(n),e(n),z(nm,n) double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag ierr = 0 if (n!=1) { do i = 2,n e(i-1) = e(i) f = 0.0d0 tst1 = 0.0d0 e(n) = 0.0d0 do l = 1,n { j = 0 h = dabs(d(l))+dabs(e(l)) if (tst1=d(i-1)) go to 10 d(i) = d(i-1) } i = 1 10 d(i) = p } return # .......... set error -- no convergence to an # eigenvalue after 30 iterations .......... 20 ierr = l } return end subroutine tred1(nm,n,a,d,e,e2) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),e2(n) double precision f,g,h,scale do i = 1,n { d(i) = a(n,i) a(n,i) = a(i,i) } # .......... for i=n step -1 until 1 do -- .......... do ii = 1,n { i = n+1-ii l = i-1 h = 0.0d0 scale = 0.0d0 if (l>=1) { # .......... scale row (algol tol then not needed) .......... do k = 1,l scale = scale+dabs(d(k)) if (scale==0.0d0) do j = 1,l { d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = 0.0d0 } else { do k = 1,l { d(k) = d(k)/scale h = h+d(k)*d(k) } e2(i) = scale*scale*h f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g if (l!=1) { # .......... form a*u .......... do j = 1,l e(j) = 0.0d0 do j = 1,l { f = d(j) g = e(j)+a(j,j)*f jp1 = j+1 if (l>=jp1) do k = jp1,l { g = g+a(k,j)*d(k) e(k) = e(k)+a(k,j)*f } e(j) = g } # .......... form p .......... f = 0.0d0 do j = 1,l { e(j) = e(j)/h f = f+e(j)*d(j) } h = f/(h+h) # .......... form q .......... do j = 1,l e(j) = e(j)-h*d(j) # .......... form reduced a .......... do j = 1,l { f = d(j) g = e(j) do k = j,l a(k,j) = a(k,j)-f*e(k)-g*d(k) } } do j = 1,l { f = d(j) d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = f*scale } next 1 } } e(i) = 0.0d0 e2(i) = 0.0d0 } return end subroutine tred2(nm,n,a,d,e,z) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),z(nm,n) double precision f,g,h,hh,scale do i = 1,n { do j = i,n z(j,i) = a(j,i) d(i) = a(n,i) } if (n!=1) { # .......... for i=n step -1 until 2 do -- .......... do ii = 2,n { i = n+2-ii l = i-1 h = 0.0d0 scale = 0.0d0 if (l>=2) { # .......... scale row (algol tol then not needed) .......... do k = 1,l scale = scale+dabs(d(k)) if (scale!=0.0d0) { do k = 1,l { d(k) = d(k)/scale h = h+d(k)*d(k) } f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g # .......... form a*u .......... do j = 1,l e(j) = 0.0d0 do j = 1,l { f = d(j) z(j,i) = f g = e(j)+z(j,j)*f jp1 = j+1 if (l>=jp1) do k = jp1,l { g = g+z(k,j)*d(k) e(k) = e(k)+z(k,j)*f } e(j) = g } # .......... form p .......... f = 0.0d0 do j = 1,l { e(j) = e(j)/h f = f+e(j)*d(j) } hh = f/(h+h) # .......... form q .......... do j = 1,l e(j) = e(j)-hh*d(j) # .......... form reduced a .......... do j = 1,l { f = d(j) g = e(j) do k = j,l z(k,j) = z(k,j)-f*e(k)-g*d(k) d(j) = z(l,j) z(i,j) = 0.0d0 } go to 10 } } e(i) = d(l) do j = 1,l { d(j) = z(l,j) z(i,j) = 0.0d0 z(j,i) = 0.0d0 } 10 d(i) = h } # .......... accumulation of transformation matrices .......... do i = 2,n { l = i-1 z(n,l) = z(l,l) z(l,l) = 1.0d0 h = d(i) if (h!=0.0d0) { do k = 1,l d(k) = z(k,i)/h do j = 1,l { g = 0.0d0 do k = 1,l g = g+z(k,i)*z(k,j) do k = 1,l z(k,j) = z(k,j)-g*d(k) } } do k = 1,l z(k,i) = 0.0d0 } } do i = 1,n { d(i) = z(n,i) z(n,i) = 0.0d0 } z(n,n) = 1.0d0 e(1) = 0.0d0 return end subroutine dmatp(x,dx,y,dy,z) integer dx(2),dy(2) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j n=dx(1); p=dx(2); q=dy(2) do i = 1,n { jj = 1; ij = i do j = 1, q { z(ij) = ddot(p,x(i),n,y(jj),1) # x[i,1] & y[1,j] if(j0) if (da!=0.0d0) if (incx!=1||incy!=1) { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dy(iy) = dy(iy)+da*dx(ix) ix = ix+incx iy = iy+incy } } else { m = mod(n,4) if (m!=0) { do i = 1,m dy(i) = dy(i)+da*dx(i) if (n<4) return } mp1 = m+1 do i = mp1,n,4 { dy(i) = dy(i)+da*dx(i) dy(i+1) = dy(i+1)+da*dx(i+1) dy(i+2) = dy(i+2)+da*dx(i+2) dy(i+3) = dy(i+3)+da*dx(i+3) } } return end subroutine dcopy(n,dx,incx,dy,incy) double precision dx(*),dy(*) integer i,incx,incy,ix,iy,m,mp1,n if (n>0) if (incx!=1||incy!=1) { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dy(iy) = dx(ix) ix = ix+incx iy = iy+incy } } else { m = mod(n,7) if (m!=0) { do i = 1,m dy(i) = dx(i) if (n<7) return } mp1 = m+1 do i = mp1,n,7 { dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) } } return end double precision function ddot(n,dx,incx,dy,incy) double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n ddot = 0.0d0 dtemp = 0.0d0 if (n>0) if (incx==1&&incy==1) { m = mod(n,5) if (m!=0) { do i = 1,m dtemp = dtemp+dx(i)*dy(i) if (n<5) go to 10 } mp1 = m+1 do i = mp1,n,5 dtemp = dtemp+dx(i)*dy(i)+dx(i+1)*dy(i+1)+dx(i+2)*dy(i+2)+dx(i+3)*dy(i+3)+dx(i+4)*dy(i+4) 10 ddot = dtemp } else { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dtemp = dtemp+dx(ix)*dy(iy) ix = ix+incx iy = iy+incy } ddot = dtemp } return end double precision function dnrm2(n,dx,incx) integer nst double precision dx(*),cutlo,cuthi,hitest,sum,xmax,zero,one data zero,one/0.0d0,1.0d0/ data cutlo,cuthi/8.232d-11,1.304d19/ if (n<=0) dnrm2 = zero else { nst = 20 sum = zero nn = n*incx i = 1 repeat { if (nst == 20) { goto 20 } else if (nst == 30) { goto 30 } else if (nst == 40) { goto 40 } else if (nst == 80) { goto 80 } 20 if (dabs(dx(i))>cutlo) go to 50 nst = 30 xmax = zero 30 if (dx(i)==zero) go to 100 if (dabs(dx(i))>cutlo) go to 50 nst = 40 go to 70 40 if (dabs(dx(i))<=cutlo) go to 80 sum = (sum*xmax)*xmax 50 hitest = cuthi/float(n) do j = i,nn,incx { if (dabs(dx(j))>=hitest) go to 60 sum = sum+dx(j)**2 } break 1 60 i = j nst = 80 sum = (sum/dx(i))/dx(i) 70 xmax = dabs(dx(i)) go to 90 80 if (dabs(dx(i))>xmax) { sum = one+sum*(xmax/dx(i))**2 xmax = dabs(dx(i)) go to 100 } 90 sum = sum+(dx(i)/xmax)**2 100 i = i+incx if (i>nn) go to 110 } dnrm2 = dsqrt(sum) return 110 dnrm2 = xmax*dsqrt(sum) } return end subroutine dscal(n,da,dx,incx) double precision da,dx(*) integer i,incx,m,mp1,n,nincx if (n>0) if (incx!=1) { nincx = n*incx do i = 1,nincx,incx dx(i) = da*dx(i) } else { m = mod(n,5) if (m!=0) { do i = 1,m dx(i) = da*dx(i) if (n<5) return } mp1 = m+1 do i = mp1,n,5 { dx(i) = da*dx(i) dx(i+1) = da*dx(i+1) dx(i+2) = da*dx(i+2) dx(i+3) = da*dx(i+3) dx(i+4) = da*dx(i+4) } } return end subroutine dswap(n,dx,incx,dy,incy) double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n if (n>0) if (incx!=1||incy!=1) { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dtemp = dx(ix) dx(ix) = dy(iy) dy(iy) = dtemp ix = ix+incx iy = iy+incy } } else { m = mod(n,3) if (m!=0) { do i = 1,m { dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp } if (n<3) return } mp1 = m+1 do i = mp1,n,3 { dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp dtemp = dx(i+1) dx(i+1) = dy(i+1) dy(i+1) = dtemp dtemp = dx(i+2) dx(i+2) = dy(i+2) dy(i+2) = dtemp } } return end subroutine dshift(x,ldx,n,j,k) integer ldx,n,j,k double precision x(ldx,k),tt integer i,jj if (k>j) do i = 1,n { tt = x(i,j) do jj = j+1,k x(i,jj-1) = x(i,jj) x(i,k) = tt } return end subroutine rtod(dx,dy,n) real dx(*) double precision dy(*) integer i,m,mp1,n if (n>0) { m = mod(n,7) if (m!=0) { do i = 1,m dy(i) = dx(i) if (n<7) return } mp1 = m+1 do i = mp1,n,7 { dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) } } return end subroutine dtor(dx,dy,n) double precision dx(*) real dy(*) integer i,m,mp1,n if (n>0) { m = mod(n,7) if (m!=0) { do i = 1,m dy(i) = dx(i) if (n<7) return } mp1 = m+1 do i = mp1,n,7 { dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) } } return end subroutine drot(n,dx,incx,dy,incy,c,s) double precision dx(*),dy(*),dtemp,c,s integer i,incx,incy,ix,iy,n if (n>0) if (incx==1&&incy==1) do i = 1,n { dtemp = c*dx(i)+s*dy(i) dy(i) = c*dy(i)-s*dx(i) dx(i) = dtemp } else { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dtemp = c*dx(ix)+s*dy(iy) dy(iy) = c*dy(iy)-s*dx(ix) dx(ix) = dtemp ix = ix+incx iy = iy+incy } } return end subroutine drotg(da,db,c,s) double precision da,db,c,s,roe,scale,r,z roe = db if (dabs(da)>dabs(db)) roe = da scale = dabs(da)+dabs(db) if (scale==0.0d0) { c = 1.0d0 s = 0.0d0 r = 0.0d0 } else { r = scale*dsqrt((da/scale)**2+(db/scale)**2) r = dsign(1.0d0,roe)*r c = da/r s = db/r } z = 1.0d0 if (dabs(da)>dabs(db)) z = s if (dabs(db)>=dabs(da)&&c!=0.0d0) z = 1.0d0/c da = r db = z return end subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) integer ldx,n,k,job,info double precision x(ldx,*),qraux(*),y(*),qy(*),qty(*),b(*),rsd(*),xb(*) integer i,j,jj,ju,kp1 double precision ddot,t,temp logical cb,cqy,cqty,cr,cxb info = 0 cqy = job/10000!=0 cqty = mod(job,10000)!=0 cb = mod(job,1000)/100!=0 cr = mod(job,100)/10!=0 cxb = mod(job,10)!=0 ju = min0(k,n-1) if (ju==0) { if (cqy) qy(1) = y(1) if (cqty) qty(1) = y(1) if (cxb) xb(1) = y(1) if (cb) if (x(1,1)!=0.0d0) b(1) = y(1)/x(1,1) else info = 1 if (cr) rsd(1) = 0.0d0 } else { if (cqy) call dcopy(n,y,1,qy,1) if (cqty) call dcopy(n,y,1,qty,1) if (cqy) do jj = 1,ju { j = ju-jj+1 if (qraux(j)!=0.0d0) { temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qy(j),1) x(j,j) = temp } } if (cqty) do j = 1,ju if (qraux(j)!=0.0d0) { temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qty(j),1) x(j,j) = temp } if (cb) call dcopy(k,qty,1,b,1) kp1 = k+1 if (cxb) call dcopy(k,qty,1,xb,1) if (cr&&k1) ncu = min0(n,p) if (jobu!=0) wantu = .true. if (mod(job,10)!=0) wantv = .true. info = 0 nct = min0(n-1,p) nrt = max0(0,min0(p-2,n)) lu = max0(nct,nrt) if (lu>=1) do l = 1,lu { lp1 = l+1 if (l<=nct) { s(l) = dnrm2(n-l+1,x(l,l),1) if (s(l)!=0.0d0) { if (x(l,l)!=0.0d0) s(l) = dsign(s(l),x(l,l)) call dscal(n-l+1,1.0d0/s(l),x(l,l),1) x(l,l) = 1.0d0+x(l,l) } s(l) = -s(l) } if (p>=lp1) do j = lp1,p { if (l<=nct) if (s(l)!=0.0d0) { t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) } e(j) = x(l,j) } if (wantu&&l<=nct) do i = l,n u(i,l) = x(i,l) if (l<=nrt) { e(l) = dnrm2(p-l,e(lp1),1) if (e(l)!=0.0d0) { if (e(lp1)!=0.0d0) e(l) = dsign(e(l),e(lp1)) call dscal(p-l,1.0d0/e(l),e(lp1),1) e(lp1) = 1.0d0+e(lp1) } e(l) = -e(l) if (lp1<=n&&e(l)!=0.0d0) { do i = lp1,n work(i) = 0.0d0 do j = lp1,p call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) do j = lp1,p call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) } if (wantv) do i = lp1,p v(i,l) = e(i) } } m = min0(p,n+1) nctp1 = nct+1 nrtp1 = nrt+1 if (nct=nctp1) do j = nctp1,ncu { do i = 1,n u(i,j) = 0.0d0 u(j,j) = 1.0d0 } if (nct>=1) do ll = 1,nct { l = nct-ll+1 if (s(l)==0.0d0) { do i = 1,n u(i,l) = 0.0d0 u(l,l) = 1.0d0 } else { lp1 = l+1 if (ncu>=lp1) do j = lp1,ncu { t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) call daxpy(n-l+1,t,u(l,l),1,u(l,j),1) } call dscal(n-l+1,-1.0d0,u(l,l),1) u(l,l) = 1.0d0+u(l,l) lm1 = l-1 if (lm1>=1) do i = 1,lm1 u(i,l) = 0.0d0 } } } if (wantv) do ll = 1,p { l = p-ll+1 lp1 = l+1 if (l<=nrt) if (e(l)!=0.0d0) do j = lp1,p { t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) } do i = 1,p v(i,l) = 0.0d0 v(l,l) = 1.0d0 } mm = m iter = 0 repeat { if (m==0) return if (iter>=maxit) break 1 do ll = 1,m { l = m-ll if (l==0) break 1 test = dabs(s(l))+dabs(s(l+1)) ztest = test+dabs(e(l)) if (ztest==test) go to 150 } go to 160 150 e(l) = 0.0d0 160 if (l==m-1) kase = 4 else { lp1 = l+1 mp1 = m+1 do lls = lp1,mp1 { ls = m-lls+lp1 if (ls==l) break 1 test = 0.0d0 if (ls!=m) test = test+dabs(e(ls)) if (ls!=l+1) test = test+dabs(e(ls-1)) ztest = test+dabs(s(ls)) if (ztest==test) go to 170 } go to 180 170 s(ls) = 0.0d0 180 if (ls==l) kase = 3 else if (ls==m) kase = 1 else { kase = 2 l = ls } } l = l+1 switch(kase) { case 1: mm1 = m-1 f = e(m-1) e(m-1) = 0.0d0 do kk = l,mm1 { k = mm1-kk+l t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 if (k!=l) { f = -sn*e(k-1) e(k-1) = cs*e(k-1) } if (wantv) call drot(p,v(1,k),1,v(1,m),1,cs,sn) } case 2: f = e(l-1) e(l-1) = 0.0d0 do k = l,m { t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 f = -sn*e(k) e(k) = cs*e(k) if (wantu) call drot(n,u(1,k),1,u(1,l-1),1,cs,sn) } case 3: scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),dabs(s(l)),dabs(e(l))) sm = s(m)/scale smm1 = s(m-1)/scale emm1 = e(m-1)/scale sl = s(l)/scale el = e(l)/scale b = ((smm1+sm)*(smm1-sm)+emm1**2)/2.0d0 c = (sm*emm1)**2 shift = 0.0d0 if (b!=0.0d0||c!=0.0d0) { shift = dsqrt(b**2+c) if (b<0.0d0) shift = -shift shift = c/(b+shift) } f = (sl+sm)*(sl-sm)+shift g = sl*el mm1 = m-1 do k = l,mm1 { call drotg(f,g,cs,sn) if (k!=l) e(k-1) = f f = cs*s(k)+sn*e(k) e(k) = cs*e(k)-sn*s(k) g = sn*s(k+1) s(k+1) = cs*s(k+1) if (wantv) call drot(p,v(1,k),1,v(1,k+1),1,cs,sn) call drotg(f,g,cs,sn) s(k) = f f = cs*e(k)+sn*s(k+1) s(k+1) = -sn*e(k)+cs*s(k+1) g = sn*e(k+1) e(k+1) = cs*e(k+1) if (wantu&&k=s(l+1)) break 1 t = s(l) s(l) = s(l+1) s(l+1) = t if (wantv&&l0; j = j-1) { if (x(j,j)==0.0d0) {info = j; break} for(l=1; l<=q; l = l+1) { b(j,l) = b(j,l)/x(j,j) if (j!=1) { t = -b(j,l) call daxpy(j-1,t,x(1,j),1,b(1,l),1) } } } return end subroutine dtrsl(t,ldt,n,b,job,info) integer ldt,n,job,info double precision t(ldt,*),b(*) double precision ddot,temp integer which,j,jj # check for zero diagonal elements. do info = 1,n if (t(info,info)==0.0d0) return info = 0 # determine the task and go to it. which = 1 if (mod(job,10)!=0) which = 2 if (mod(job,100)/10!=0) which = which+2 switch(which) { case 1: b(1) = b(1)/t(1,1) if (n>=2) do j = 2,n { temp = -b(j-1) call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) b(j) = b(j)/t(j,j) } case 2: b(n) = b(n)/t(n,n) if (n>=2) do jj = 2,n { j = n-jj+1 temp = -b(j+1) call daxpy(j,temp,t(1,j+1),1,b(1),1) b(j) = b(j)/t(j,j) } case 3: b(n) = b(n)/t(n,n) if (n>=2) do jj = 2,n { j = n-jj+1 b(j) = b(j)-ddot(jj-1,t(j+1,j),1,b(j+1),1) b(j) = b(j)/t(j,j) } case 4: b(1) = b(1)/t(1,1) if (n>=2) do j = 2,n { b(j) = b(j)-ddot(j-1,t(1,j),1,b(1),1) b(j) = b(j)/t(j,j) } } return end gam/inst/ratfor/backlo.r0000644000176000001440000001062612135572301014742 0ustar ripleyuserssubroutine baklo(x,y,w,npetc,wddnfl,spatol,match, etal,s,eta,beta,var,dof, qr,qraux,qpivot,effect,iv,v,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,nit,maxit,qrank integer npetc(7),wddnfl(*),match(*),qpivot(*),iv(*),iwork(*) ##integer which(q),dwhich(q),degree(q),nef(q),liv(q),lv(q),nvmax(q) double precision x(*),y(*),w(*),spatol(*), etal(*),s(*),eta(*),beta(*),var(*),dof(*), qr(*),qraux(*),v(*),effect(*),work(*) #work size: 4*n + sum( nef(k)*(pj+dj+4)+5+3*pj ) +5*n # = 9*n + sum( nef(k)*(pj+dj+4)+5+3*pj ) n=npetc(1) p=npetc(2) q=npetc(3) maxit=npetc(5) qrank=npetc(6) call baklo0(x,n,p,y,w,q,wddnfl(1),wddnfl(q+1),wddnfl(2*q+1), spatol(1),wddnfl(3*q+1),dof,match,wddnfl(4*q+1), etal,s,eta,beta,var,spatol(q+1), nit,maxit,qr,qraux,qrank,qpivot,effect, work(1),work(n+1),work(2*n+1),work(3*n+1), iv,wddnfl(5*q+1),wddnfl(6*q+1),v,wddnfl(7*q+1), iwork(1),work(4*n+1)) npetc(4)=nit npetc(6)=qrank return end subroutine baklo0(x,n,p,y,w,q,which,dwhich,pwhich,span,degree,dof,match,nef, etal,s,eta,beta,var,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,z,old,sqwt,sqwti, iv,liv,lv,v,nvmax,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,which(q),dwhich(q),pwhich(q),degree(q),match(n,q),nef(q),nit, maxit,qrank,qpivot(p),iv(*),liv(q),lv(q),nvmax(q),iwork(q) double precision x(n,p),y(n),w(n),span(q),dof(q), etal(n),s(n,q),eta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),v(*),effect(n),work(*) #work should be sum( nef(k)*(pj+dj+4)+5+3*pj ) +5*n double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info,slv,sliv,iw,j,dj,pj onedm7=1d-7 job=1101;info=1 if(q==0)maxit=1 ratio=1d0 # fix up sqy's for weighted problems. anyzwt=.false. do i=1,n{ if(w(i)>0d0){ sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) } else{ sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. } } # if qrank > 0 then qr etc contain the qr decomposition # else baklo computes it. if(qrank==0){ do i=1,n{ do j=1,p{ qr(i,j)=x(i,j)*sqwt(i) } } do j=1,p{qpivot(j)=j} call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) } do i=1,n{ eta(i)=0d0 for(j=1;j<=q;j=j+1){ eta(i)=eta(i)+s(i,j) } } nit=0 while ((ratio > tol )&(nit < maxit)){ # first the linear fit deltaf=0d0 nit=nit+1 do i=1,n{ z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) } # call dqrsl1(qr,dq,qraux,qrank,sqz,one,work(1),etal,two,three) #job=1101 -- computes fits, effects and beta call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),etal,job,info) # now unsqrt the fits #Note: we dont have to fix up the zero weights till the end, since their fits #are always immaterial to the computation do i=1,n{ etal(i)=etal(i)*sqwti(i) } # now a single non-linear backfitting loop sliv=1 slv=1 iw=5*n+1 for(k=1;k<=q;k=k+1){ j=which(k) dj=dwhich(k) pj=pwhich(k) do i=1,n{ old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) } call lo1(x(1,j),z,w,n,dj,pj,nvmax(k),span(k),degree(k),match(1,k), nef(k),nit,dof(k),s(1,k),var(1,k),work(iw), # xin,win work(iw+pj+1),work(iw+nef(k)*dj+pj+1), # sqwin,sqwini, work(iw+nef(k)*(dj+1)+pj+2),work(iw + nef(k)*(dj+2)+pj+2), # xqr,qrank, work(iw+nef(k)*(dj+3)+pj+2),work(iw+nef(k)*(pj+dj+4)+pj+2), # qpivot,qraux, # work(iw+nef(k)*(pj+dj+4)+pj+3),work(iw+nef(k)*(pj+dj+4)+4+2*pj), iwork(1),work(iw+nef(k)*(pj+dj+4)+4+2*pj), iv(sliv),liv(k),lv(k),v(slv), work(1) ) #work should be sum( nef(k)*(pj+dj+4)+5+3*pj ) +5*n # In the call above I give lo1 pieces of work to use for storing # the qr decomposition, and it gets the same undisturbed portion # each time. The fact that it is given a double work word for qrank # is irrelevant but convenient; it still stores the integer qrank there. # I do this because there is a partition like this for each lo() term # in the model, and the number of them is variable sliv=sliv+liv(k) slv=slv+lv(k) iw=iw+nef(k)*(pj+dj+4)+5+3*pj do i=1,n{ eta(i)=eta(i)+s(i,k)-old(i) } deltaf=deltaf+dwrss(n,old,s(1,k),w) } normf=0d0 do i=1,n{ normf=normf+w(i)*eta(i)*eta(i) } if(normf>0d0){ ratio=dsqrt(deltaf/normf) } else {ratio = 0d0} } #now package up the results do j=1,p {work(j)=beta(j)} do j=1,p {beta(qpivot(j))=work(j)} if(anyzwt){ do i=1,n { if(w(i) <= 0d0){ etal(i)=0d0 do j=1,p{ etal(i)=etal(i)+beta(j)*x(i,j) } } } } do i=1,n eta(i)=eta(i)+etal(i) return end gam/inst/ratfor/lo.r0000644000176000001440000001053212135607157014125 0ustar ripleyuserssubroutine lo0(x,y,w,n,d,p,nvmax,span,degree,match,nef,dof,s,var, beta,iv,liv,lv,v,iwork,work) integer n,d,p,nvmax,degree,match(*),nef,liv,lv,iv(liv),iwork(*) double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),v(lv),work(*) double precision beta(p+1) #work should be nef*(p+d+8) + 2*p + n +8 integer qrank call lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,0,dof,s,var,beta, # xin,win,sqwin,sqwini, work(1),work(nef*d+1),work(nef*(d+1)+2),work(nef*(d+2)+2), # xqr,qrank,qpivot,qraux, work(nef*(d+3)+2),qrank,iwork(1),work(nef*(p+d+4)+3+p), iv,liv,lv,v, work(nef*(p+d+4)+4+2*p) ) return end subroutine lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p+1),v(lv), work(*) #work should have size n +4*(nef+1) call lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, work(1),work(nef+2),work(2*nef+3),work(3*nef+4)) return end subroutine lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, levout,sout,yin,work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p+1),v(lv), levout(nef+1), sout(nef+1),yin(nef+1),work(*) #work should be length n double precision junk, onedm7 integer job, info logical setLf, ifvar job=110;info=1 ifvar=.true. onedm7=1d-7 if(nit<=1){ call pck(n,nef,match,w,win) do i=1,nef{ if(win(i)>0d0){ sqwin(i)=dsqrt(win(i)) sqwini(i)=1d0/sqwin(i) } else{ sqwin(i)=1d-5 sqwini(i)=1d5 } } do i=1,n{ k=match(i) if(k<=nef){ do j=1,d xin(k,j)=x(i,j) for(j=d+1;j<=p;j=j+1) xqr(k,j+1)=x(i,j) } } do i=1,nef{ xqr(i,1)=sqwin(i) do j=1,d xqr(i,j+1)=xin(i,j)*sqwin(i) for(j=d+2;j<=p+1;j=j+1) xqr(i,j)=xqr(i,j)*sqwin(i) } for(j=1;j<=p+1;j=j+1) qpivot(j)=j call dqrdca(xqr,nef,nef,p+1,qraux,qpivot,work,qrank,onedm7) setLf = (nit==1) call lowesd(106,iv,liv,lv,v,d,nef,span,degree,nvmax,setLf) v(2)=span/5d0 } do i=1,n work(i)=y(i)*w(i) call pck(n,nef,match,work,yin) do i=1,nef yin(i)=yin(i)*sqwini(i)*sqwini(i) if(nit<=1)call lowesb(xin,yin,win,levout,ifvar,iv,liv,lv,v) else call lowesr(yin,iv,liv,lv,v) call lowese(iv,liv,lv,v,nef,xin,sout) #now remove the parametric piece do i=1,nef sout(i)=sout(i)*sqwin(i) call dqrsl(xqr,nef,nef,qrank,qraux,sout,work(1),work(1),beta, sout,work(1),job,info) #####dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) do i=1,nef sout(i)=sout(i)*sqwini(i) #now clean up if(nit<=1){ #get rid of the parametric component of the leverage job=10000 for(j=1;j<=p+1;j=j+1){ do i=1,nef work(i)=0d0 work(j)=1d0 call dqrsl(xqr,nef,nef,qrank,qraux,work,var,junk,junk, junk,junk,job,info) do i=1,nef levout(i)=levout(i) - var(i)**2 } dof=0d0 do i=1,nef { if(win(i)>0d0) { levout(i)=levout(i)/win(i) } else {levout(i)=0d0} } do i=1,nef {dof=dof+levout(i)*win(i)} call unpck(n,nef,match,levout,var) for(j=1;j<=p+1;j=j+1){work(j)=beta(j)} for(j=1;j<=p+1;j=j+1){beta(qpivot(j))=work(j)} } call unpck(n,nef,match,sout,s) return end subroutine pck(n,p,match,x,xbar) integer match(n),p,n double precision x(n),xbar(n) do i=1,p xbar(i)=0d0 do i=1,n xbar(match(i))=xbar(match(i))+x(i) return end subroutine suff(n,p,match,x,y,w,xbar,ybar,wbar,work) integer match(n),p,n double precision x(n),xbar(n),y(n),ybar(n),w(n),wbar(n),work(n) call pck(n,p,match,w,wbar) do i=1,n xbar(match(i))=x(i) do i=1,n work(i)=y(i)*w(i) call pck(n,p,match,work,ybar) do i=1,p{ if(wbar(i)>0d0) ybar(i)=ybar(i)/wbar(i) else ybar(i)=0d0 } return end subroutine unpck(n,p,match,xbar,x) integer match(n),p,n double precision x(n),xbar(p+1) if(p 0d0) {dwrss=wsum/wtot} else {dwrss=0d0} return end gam/inst/ratfor/backfit.r0000644000176000001440000001554112135607366015125 0ustar ripleyuserssubroutine bakfit(x,npetc,y,w,which,spar,dof,match,nef, etal,s,eta,beta,var,tol, qr,qraux,qpivot,effect,work) #integer npetc(7) #1:n #2:p #3:q #4:ifvar #5:nit #6:maxit #7:qrank #subroutine bakfit(x,n,p,y,w,q,which,spar,dof,match,nef, # etal,s,eta,beta,var,ifvar,tol,nit,maxit, # qr,qraux,qrank,qpivot,work) #This subroutine fits an additive spline fit to y #All arguments are either double precision or integer # bakfit uses the modified backfitting algorithm described in Buja, Hastie # and Tibshirani, Annals of Statistics, 1989. It calls splsm, and some # linpack based routines # This was written by Trevor Hastie in 1990 # It has been modified from the S3 version by Trevor Hastie # in March 2005, to accommodate the modified sbart routine in R # Note that spar has changed, and we change it here to conform with # the smooth.spline routine in R #INPUT # #x double dim n by p ; x variables, includes constant #n integer number of rows in x #p integer number of columns of x #y double length n ; y variable for smoothing #w double length n ; prior weights for smoothing, > 0 #q integer number of nonlinear terms #which integer length q indices of columns of x for nonlinear fits #spar double length q spars for smoothing; see below #dof double length q dof for/from smoothing; see below #match integer n by q matrix of match'es; see below #nef integer q vector of nef's; see below #s double n by q nonlinear part of the smooth functions # used as starting values. the linear part is # irrelevant #ifvar logical should the variance information be computed #tol double tolerance for backfitting convergence; 0.0005 is good #maxit integer maximum number of iterations; 15 is good #qr double n by p weighted qr decomposition of x #qraux double p belongs with qr #qrank integer rank of x ; if qrank=0, then bakfit computes qr and qraux #qpivot integer p the columns of qr are rearranged according to pivot #effec double n effect vector #work double # Let nk=max(nef)+2, then # work should be (10+2*4)*nk+5*nef+5*n+15 +q double #BELOW #the following comments come from documentation for splsm # they apply to each element of spar,dof match etc #spar double smoothing parameter -1.5 =1, dof is used # note: dof does not use the constant term #match integer length n -- in S language x[i] == sort(unique(x)[match[i]] # match is produced by subroutine namat #nef number of unique elements in x; so match has values between 1 and nef+1 # missing data are given the match number nef+1 #work double workspace of length (10+2*4)*(nef+2)+5*nef+n+15 # #OUTPUT # #x,y,w,n,p,which,q,maxit,match,nef are untouched #spar for each element of spar: # if spar was 0 and dof was 0, then spar is that spar # that minimized gcv # if spar was 0 and dof > 0, then spar is that which achieves dof #dof the dof of the fitted smooth. Note: even if dof was given # as 4, it will be returned as say 3.995 which is what # spar produces #etal double length n linear component of the fit #s double n by q nonlinear part of the smooth functions #eta double length n fitted values #beta double length p linear coefficients # So, the centered fitted functions are: # b(j)*(x(i,j)-mean(x(.,j)) +s(i,j) # where j is an element of which #var double n by q # if ifvar was .true. # the unscaled variance elements for the NONLINEAR # and UNIQUE part of s, in the order of sort(unique(x)) # var is lev(i)/w(i) -h(i)/w where h(i) is the hat element from # the simple weighted least squares fit. This is used in gamcov # #nit number of iterations used #qr etc the qr is returned implicit double precision(a-h,o-z) logical ifvar integer npetc(7),iter integer n,p,q,which(*),match(*),nef(*),nit,maxit,qrank,qpivot(*) double precision x(*),y(*),w(*),spar(*),dof(*), etal(*),s(*),eta(*),beta(*),var(*),tol, qr(*),qraux(*),effect(*),work(*) n=npetc(1) p=npetc(2) q=npetc(3) ifvar=.false. if(npetc(4)==1)ifvar=.true. maxit=npetc(6) qrank=npetc(7) do i=1,q{work(i)=dof(i)} call backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta,beta,var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,work(q+1),work(q+n+1), work(q+2*n+1),work(q+3*n+1),work(q+4*n+1)) npetc(7)=qrank return end subroutine backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta,beta,var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,z,old,sqwt,sqwti,work) implicit double precision(a-h,o-z) logical ifvar integer n,p,q,which(q),match(n,q),nef(q),nit,maxit,qrank,qpivot(p) double precision x(n,p),y(n),w(n),spar(q),dof(q), etal(n),s(n,q),eta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),effect(n),work(*) double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info onedm7=1d-7 job=1101;info=1 if(q==0)maxit=1 ratio=1d0 # fix up sqy's for weighted problems. anyzwt=.false. do i=1,n{ if(w(i)>0d0){ sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) } else{ sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. } } # if qrank > 0 then qr etc contain the qr decomposition # else bakfit computes it. if(qrank==0){ do i=1,n{ do j=1,p{ qr(i,j)=x(i,j)*sqwt(i) } } do j=1,p{qpivot(j)=j} call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) } do i=1,n{ eta(i)=0d0 for(j=1;j<=q;j=j+1){ eta(i)=eta(i)+s(i,j) } } nit=0 while ((ratio > tol )&(nit < maxit)){ # first the linear fit deltaf=0d0 nit=nit+1 do i=1,n{ z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) } # call dqrsl1(qr,dq,qraux,qrank,sqz,one,work(1),etal,two,three) #job=1101 -- computes fits, effects and beta call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),etal,job,info) # now unsqrt the fits #Note: we dont have to fix up the zero weights till the end, since their fits #are always immaterial to the computation do i=1,n{ etal(i)=etal(i)*sqwti(i) } # now a single non-linear backfitting loop for(k=1;k<=q;k=k+1){ j=which(k) do i=1,n{ old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) } # this uses spar to set smoothing after iteration 1 if(nit>1){dof(k)=0d0} call splsm(x(1,j),z,w,n,match(1,k),nef(k),spar(k), dof(k),s(1,k),s0,var(1,k),ifvar,work) do i=1,n{ eta(i)=eta(i)+s(i,k)-old(i) etal(i)=etal(i)+s0 } deltaf=deltaf+dwrss(n,old,s(1,k),w) } normf=0d0 do i=1,n{ normf=normf+w(i)*eta(i)*eta(i) } if(normf>0d0){ ratio=dsqrt(deltaf/normf) } else {ratio = 0d0} # call DBLEPR("ratio",-1,ratio,1) } #now package up the results do j=1,p {work(j)=beta(j)} do j=1,p {beta(qpivot(j))=work(j)} if(anyzwt){ do i=1,n { if(w(i) <= 0d0){ etal(i)=0d0 do j=1,p{ etal(i)=etal(i)+beta(j)*x(i,j) } } } } do i=1,n eta(i)=eta(i)+etal(i) do j=1,q { call unpck(n,nef(j),match(1,j),var(1,j),old) do i=1,n {var(i,j)=old(i)} } return end gam/src/0000755000176000001440000000000013507054520011636 5ustar ripleyusersgam/src/gam_init.c0000644000176000001440000000744613324234205013601 0ustar ripleyusers// Automatically generated, editing not advised. #ifndef R_GAM_H #define R_GAM_H #include #include #include #ifdef ENABLE_NLS #include #define _(String) dgettext ("gam", String) #else #define _(String) (String) #endif #define FDEF(name) {#name, (DL_FUNC) &F77_SUB(name), sizeof(name ## _t)/sizeof(name ## _t[0]), name ##_t} void F77_SUB(lo0)( double *x, double *y, double *z, int *n, int *d, int *p, int *nvmax, double *span, int *degree, int *match, int *nef, double *dof, double *s, double *var, double *beta, int *iv, int *liv, int *lv, double *v, int *iwork, double *work ); static R_NativePrimitiveArgType lo0_t[] = { REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, REALSXP }; void F77_SUB(lowese)( int *iv, int *liv, int *lv, double *wv, int *m, double *z, double *s ); static R_NativePrimitiveArgType lowese_t[] = { INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, REALSXP, REALSXP }; void F77_SUB(sknotl)( double *x, int *n, double *knot, int *k ); static R_NativePrimitiveArgType sknotl_t[] = { REALSXP, INTSXP, REALSXP, INTSXP }; void F77_SUB(splsm)( double *x, double *y, double *w, int *n, int *match, int *nef, double *spar, double *dof, double *smo, double *s0, double *cov, int *ifcov, double *work ); static R_NativePrimitiveArgType splsm_t[] = { REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, LGLSXP, REALSXP }; void F77_SUB(bvalus)( int *n, double *knot, double *coef, int *nk, double *x, double *s, int *order ); static R_NativePrimitiveArgType bvalus_t[] = { INTSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, INTSXP }; void F77_SUB(baklo)( double *x, double *y, double *w, int *npetc, int *wddnfl, double *spatol, int *match, double *etal, double *s, double *eta, double *beta, double *var, double *dof, double *qr, double *qraux, int *qpivot, double *effect, int *iv, double *v, int *iwork, double *work ); static R_NativePrimitiveArgType baklo_t[] = { REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, REALSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, REALSXP, INTSXP, REALSXP, INTSXP, REALSXP }; void F77_SUB(bakfit)( double *x, int *npetc, double *y, double *w, int *which, double *spar, double *dof, int *match, int *nef, double *etal, double *s, double *eta, double *beta, double *var, double *tol, double *qr, double *qraux, int *qpivot, double *effect, double *work ); static R_NativePrimitiveArgType bakfit_t[] = { REALSXP, INTSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP }; static R_FortranMethodDef fMethods[] = { FDEF(lo0) , FDEF(lowese) , FDEF(sknotl) , FDEF(splsm) , FDEF(bvalus) , FDEF(baklo) , FDEF(bakfit) , {NULL, NULL, 0} }; void R_init_gam(DllInfo *dll){ R_registerRoutines(dll, NULL, NULL, fMethods, NULL); R_useDynamicSymbols(dll, FALSE); } #endif gam/src/Makevars0000644000176000001440000000004313324234205013324 0ustar ripleyusersPKG_LIBS = $(BLAS_LIBS) $(FLIBS) gam/src/sinerp.f0000644000176000001440000000530413324234205013304 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,flag) c C Purpose : Computes Inner Products between columns of L^{-1} C where L = abd is a Banded Matrix with 3 subdiagonals C The algorithm works in two passes: C C Pass 1 computes (cj,ck) k=j,j-1,j-2,j-3 ; j=nk, .. 1 C Pass 2 computes (cj,ck) k <= j-4 (If flag == 1 ). C C A refinement of Elden's trick is used. c Args integer ld4,nk,ldnk,flag DOUBLE precision abd(ld4,nk),p1ip(ld4,nk), p2ip(ldnk,nk) c Locals integer i,j,k DOUBLE precision wjm3(3),wjm2(2),wjm1(1),c0,c1,c2,c3 c c unnecessary initialization of c1 c2 c3 to keep g77 -Wall happy c c1 = 0.0d0 c2 = 0.0d0 c3 = 0.0d0 C C Pass 1 wjm3(1)=0d0 wjm3(2)=0d0 wjm3(3)=0d0 wjm2(1)=0d0 wjm2(2)=0d0 wjm1(1)=0d0 do 100 i=1,nk j=nk-i+1 c0 = 1d0/abd(4,j) if(j.le.nk-3)then c1 = abd(1,j+3)*c0 c2 = abd(2,j+2)*c0 c3 = abd(3,j+1)*c0 else if(j.eq.nk-2)then c1 = 0d0 c2 = abd(2,j+2)*c0 c3 = abd(3,j+1)*c0 else if(j.eq.nk-1)then c1 = 0d0 c2 = 0d0 c3 = abd(3,j+1)*c0 else if(j.eq.nk)then c1 = 0d0 c2 = 0d0 c3 = 0d0 endif p1ip(1,j) = 0d0- (c1*wjm3(1)+c2*wjm3(2)+c3*wjm3(3)) p1ip(2,j) = 0d0- (c1*wjm3(2)+c2*wjm2(1)+c3*wjm2(2)) p1ip(3,j) = 0d0- (c1*wjm3(3)+c2*wjm2(2)+c3*wjm1(1)) p1ip(4,j) = c0**2 + c1**2*wjm3(1) + 2d0*c1*c2*wjm3(2)+ & 2d0*c1*c3*wjm3(3) + c2**2*wjm2(1) + 2d0*c2*c3*wjm2(2) + & c3**2*wjm1(1) wjm3(1)=wjm2(1) wjm3(2)=wjm2(2) wjm3(3)=p1ip(2,j) wjm2(1)=wjm1(1) wjm2(2)=p1ip(3,j) wjm1(1)=p1ip(4,j) 100 continue if(flag.ne.0)then C ____ Pass 2 _____ C Compute p2ip do 120 i=1,nk j=nk-i+1 C for(k=1;k<=4 & j+k-1<=nk;k=k+1) { p2ip(.) = .. }: do 160 k=1,4 if(j+k-1 .gt. nk)goto 120 p2ip(j,j+k-1) = p1ip(5-k,j) 160 continue 120 continue do 170 i=1,nk j=nk-i+1 c for(k=j-4;k>=1;k=k-1){ if(j-4 .ge. 1) then do 210 k= j-4,1, -1 c0 = 1d0/abd(4,k) c1 = abd(1,k+3)*c0 c2 = abd(2,k+2)*c0 c3 = abd(3,k+1)*c0 p2ip(k,j)= 0d0 - ( c1*p2ip(k+3,j) + c2*p2ip(k+2,j) + & c3*p2ip(k+1,j) ) 210 continue endif 170 continue endif return end gam/src/lo.f0000644000176000001440000001402313324234205012414 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine lo0(x,y,w,n,d,p,nvmax,span,degree,match,nef,dof,s,var, *beta,iv,liv,lv,v,iwork,work) integer n,d,p,nvmax,degree,match(*),nef,liv,lv,iv(liv),iwork(*) double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),v(lv),work( **) double precision beta(p+1) integer qrank call lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,0,dof,s,var,beta, * work(1),work(nef*d+1),work(nef*(d+1)+2),work(nef*(d+2)+2), work(n *ef*(d+3)+2),qrank,iwork(1),work(nef*(p+d+4)+3+p), iv,liv,lv,v, wor *k(nef*(p+d+4)+4+2*p) ) return end subroutine lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,v *ar,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, * work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), *xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p *+1),v(lv), work(*) call lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,bet *a, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, work( *1),work(nef+2),work(2*nef+3),work(3*nef+4)) return end subroutine lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,v *ar,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, * levout,sout,yin,work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), *xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p *+1),v(lv), levout(nef+1), sout(nef+1),yin(nef+1),work(*) double precision junk, onedm7 integer job, info logical setlf, ifvar job=110 info=1 ifvar=.true. onedm7=1d-7 if(nit.le.1)then call pck(n,nef,match,w,win) do23002 i=1,nef if(win(i).gt.0d0)then sqwin(i)=dsqrt(win(i)) sqwini(i)=1d0/sqwin(i) else sqwin(i)=1d-5 sqwini(i)=1d5 endif 23002 continue 23003 continue do23006 i=1,n k=match(i) if(k.le.nef)then do23010 j=1,d xin(k,j)=x(i,j) 23010 continue 23011 continue j=d+1 23012 if(.not.(j.le.p))goto 23014 xqr(k,j+1)=x(i,j) 23013 j=j+1 goto 23012 23014 continue endif 23006 continue 23007 continue do23015 i=1,nef xqr(i,1)=sqwin(i) do23017 j=1,d xqr(i,j+1)=xin(i,j)*sqwin(i) 23017 continue 23018 continue j=d+2 23019 if(.not.(j.le.p+1))goto 23021 xqr(i,j)=xqr(i,j)*sqwin(i) 23020 j=j+1 goto 23019 23021 continue 23015 continue 23016 continue j=1 23022 if(.not.(j.le.p+1))goto 23024 qpivot(j)=j 23023 j=j+1 goto 23022 23024 continue call dqrdca(xqr,nef,nef,p+1,qraux,qpivot,work,qrank,onedm7) setlf = (nit.eq.1) call lowesd(106,iv,liv,lv,v,d,nef,span,degree,nvmax,setlf) v(2)=span/5d0 endif do23025 i=1,n work(i)=y(i)*w(i) 23025 continue 23026 continue call pck(n,nef,match,work,yin) do23027 i=1,nef yin(i)=yin(i)*sqwini(i)*sqwini(i) 23027 continue 23028 continue if(nit.le.1)then call lowesb(xin,yin,win,levout,ifvar,iv,liv,lv,v) else call lowesr(yin,iv,liv,lv,v) endif call lowese(iv,liv,lv,v,nef,xin,sout) do23031 i=1,nef sout(i)=sout(i)*sqwin(i) 23031 continue 23032 continue call dqrsl(xqr,nef,nef,qrank,qraux,sout,work(1),work(1),beta, sout *,work(1),job,info) do23033 i=1,nef sout(i)=sout(i)*sqwini(i) 23033 continue 23034 continue if(nit.le.1)then job=10000 j=1 23037 if(.not.(j.le.p+1))goto 23039 do23040 i=1,nef work(i)=0d0 23040 continue 23041 continue work(j)=1d0 call dqrsl(xqr,nef,nef,qrank,qraux,work,var,junk,junk, junk,junk,j *ob,info) do23042 i=1,nef levout(i)=levout(i) - var(i)**2 23042 continue 23043 continue 23038 j=j+1 goto 23037 23039 continue dof=0d0 do23044 i=1,nef if(win(i).gt.0d0)then levout(i)=levout(i)/win(i) else levout(i)=0d0 endif 23044 continue 23045 continue do23048 i=1,nef dof=dof+levout(i)*win(i) 23048 continue 23049 continue call unpck(n,nef,match,levout,var) j=1 23050 if(.not.(j.le.p+1))goto 23052 work(j)=beta(j) 23051 j=j+1 goto 23050 23052 continue j=1 23053 if(.not.(j.le.p+1))goto 23055 beta(qpivot(j))=work(j) 23054 j=j+1 goto 23053 23055 continue endif call unpck(n,nef,match,sout,s) return end subroutine pck(n,p,match,x,xbar) integer match(n),p,n double precision x(n),xbar(n) do23056 i=1,p xbar(i)=0d0 23056 continue 23057 continue do23058 i=1,n xbar(match(i))=xbar(match(i))+x(i) 23058 continue 23059 continue return end subroutine suff(n,p,match,x,y,w,xbar,ybar,wbar,work) integer match(n),p,n double precision x(n),xbar(n),y(n),ybar(n),w(n),wbar(n),work(n) call pck(n,p,match,w,wbar) do23060 i=1,n xbar(match(i))=x(i) 23060 continue 23061 continue do23062 i=1,n work(i)=y(i)*w(i) 23062 continue 23063 continue call pck(n,p,match,work,ybar) do23064 i=1,p if(wbar(i).gt.0d0)then ybar(i)=ybar(i)/wbar(i) else ybar(i)=0d0 endif 23064 continue 23065 continue return end subroutine unpck(n,p,match,xbar,x) integer match(n),p,n double precision x(n),xbar(p+1) if(p.lt.n)then xbar(p+1)=0d0 endif do23070 i = 1,n x(i)=xbar(match(i)) 23070 continue 23071 continue return end double precision function dwrss(n,y,eta,w) integer n double precision y(n),w(n),wtot,wsum,work,eta(n) wsum=0d0 wtot=0d0 do23072 i = 1,n work=y(i)-eta(i) wsum=wsum+w(i)*work*work wtot=wtot+w(i) 23072 continue 23073 continue if(wtot .gt. 0d0)then dwrss=wsum/wtot else dwrss=0d0 endif return end gam/src/bsplvd.f0000644000176000001440000002102413324234205013273 0ustar ripleyusers subroutine bsplvd ( t, lent, k, x, left, a, dbiatx, nderiv ) c -------- ------ c implicit none C calculates value and deriv.s of all b-splines which do not vanish at x C calls bsplvb c c****** i n p u t ****** c t the knot array, of length left+k (at least) c k the order of the b-splines to be evaluated c x the point at which these values are sought c left an integer indicating the left endpoint of the interval of c interest. the k b-splines whose support contains the interval c (t(left), t(left+1)) c are to be considered. c a s s u m p t i o n - - - it is assumed that c t(left) < t(left+1) c division by zero will result otherwise (in b s p l v b ). c also, the output is as advertised only if c t(left) <= x <= t(left+1) . c nderiv an integer indicating that values of b-splines and their c derivatives up to but not including the nderiv-th are asked c for. ( nderiv is replaced internally by the integer in (1,k) c closest to it.) c c****** w o r k a r e a ****** c a an array of order (k,k), to contain b-coeff.s of the derivat- c ives of a certain order of the k b-splines of interest. c c****** o u t p u t ****** c dbiatx an array of order (k,nderiv). its entry (i,m) contains c value of (m-1)st derivative of (left-k+i)-th b-spline of c order k for knot sequence t , i=m,...,k; m=1,...,nderiv. c c****** m e t h o d ****** c values at x of all the relevant b-splines of order k,k-1,..., c k+1-nderiv are generated via bsplvb and stored temporarily c in dbiatx . then, the b-coeffs of the required derivatives of the c b-splines of interest are generated by differencing, each from the c preceding one of lower order, and combined with the values of b- c splines of corresponding order in dbiatx to produce the desired c values. C Args integer lent,k,left,nderiv double precision t(lent),x, dbiatx(k,nderiv), a(k,k) C Locals double precision factor,fkp1mm,sum integer i,ideriv,il,j,jlow,jp1mid, kp1,kp1mm,ldummy,m,mhigh mhigh = max0(min0(nderiv,k),1) c mhigh is usually equal to nderiv. kp1 = k+1 call bsplvb(t,lent,kp1-mhigh,1,x,left,dbiatx) if (mhigh .eq. 1) go to 99 c the first column of dbiatx always contains the b-spline values c for the current order. these are stored in column k+1-current c order before bsplvb is called to put values for the next c higher order on top of it. ideriv = mhigh do 15 m=2,mhigh jp1mid = 1 do 11 j=ideriv,k dbiatx(j,ideriv) = dbiatx(jp1mid,1) 11 jp1mid = jp1mid + 1 ideriv = ideriv - 1 call bsplvb(t,lent,kp1-ideriv,2,x,left,dbiatx) 15 continue c c at this point, b(left-k+i, k+1-j)(x) is in dbiatx(i,j) for c i=j,...,k and j=1,...,mhigh ('=' nderiv). in particular, the c first column of dbiatx is already in final form. to obtain cor- c responding derivatives of b-splines in subsequent columns, gene- c rate their b-repr. by differencing, then evaluate at x. c jlow = 1 do 20 i=1,k do 19 j=jlow,k 19 a(j,i) = 0e0 jlow = i 20 a(i,i) = 1e0 c at this point, a(.,j) contains the b-coeffs for the j-th of the c k b-splines of interest here. c do 40 m=2,mhigh kp1mm = kp1 - m fkp1mm = dble(kp1mm) il = left i = k c c for j=1,...,k, construct b-coeffs of (m-1)st derivative of c b-splines from those for preceding derivative by differencing c and store again in a(.,j) . the fact that a(i,j) = 0 for c i < j is used.sed. do 25 ldummy=1,kp1mm factor = fkp1mm/(t(il+kp1mm) - t(il)) c the assumption that t(left) < t(left+1) makes denominator c in factor nonzero. do 24 j=1,i 24 a(i,j) = (a(i,j) - a(i-1,j))*factor il = il - 1 25 i = i - 1 c c for i=1,...,k, combine b-coeffs a(.,i) with b-spline values c stored in dbiatx(.,m) to get value of (m-1)st derivative of c i-th b-spline (of interest here) at x , and store in c dbiatx(i,m). storage of this value over the value of a b-spline c of order m there is safe since the remaining b-spline derivat- c ive of the same order do not use this value due to the fact c that a(j,i) = 0 for j < i . 30 do 40 i=1,k sum = 0. jlow = max0(i,m) do 35 j=jlow,k 35 sum = a(j,i)*dbiatx(j,m) + sum 40 dbiatx(i,m) = sum 99 return end subroutine bsplvb ( t, lent,jhigh, index, x, left, biatx ) c implicit none c ------------- calculates the value of all possibly nonzero b-splines at x of order c c jout = dmax( jhigh , (j+1)*(index-1) ) c c with knot sequence t . c c****** i n p u t ****** c t.....knot sequence, of length left + jout , assumed to be nonde- c creasing. c a s s u m p t i o n : t(left) < t(left + 1) c d i v i s i o n b y z e r o will result if t(left) = t(left+1) c c jhigh, c index.....integers which determine the order jout = max(jhigh, c (j+1)*(index-1)) of the b-splines whose values at x are to c be returned. index is used to avoid recalculations when seve- c ral columns of the triangular array of b-spline values are nee- c ded (e.g., in bvalue or in bsplvd ). precisely, c if index = 1 , c the calculation starts from scratch and the entire triangular c array of b-spline values of orders 1,2,...,jhigh is generated c order by order , i.e., column by column . c if index = 2 , c only the b-spline values of order j+1, j+2, ..., jout are ge- c nerated, the assumption being that biatx , j , deltal , deltar c are, on entry, as they were on exit at the previous call. c in particular, if jhigh = 0, then jout = j+1, i.e., just c the next column of b-spline values is generated. c c w a r n i n g . . . the restriction jout <= jmax (= 20) is c imposed arbitrarily by the dimension statement for deltal and c deltar below, but is n o w h e r e c h e c k e d for . c c x.....the point at which the b-splines are to be evaluated. c left.....an integer chosen (usually) so that c t(left) <= x <= t(left+1) . c c****** o u t p u t ****** c biatx.....array of length jout , with biatx(i) containing the val- c ue at x of the polynomial of order jout which agrees with c the b-spline b(left-jout+i,jout,t) on the interval (t(left), c t(left+1)) . c c****** m e t h o d ****** c the recurrence relation c c x - t(i) t(i+j+1) - x c b(i,j+1)(x) = ----------- b(i,j)(x) + --------------- b(i+1,j)(x) c t(i+j)-t(i) t(i+j+1)-t(i+1) c c is used (repeatedly) to generate the c (j+1)-vector b(left-j,j+1)(x),...,b(left,j+1)(x) c from the j-vector b(left-j+1,j)(x),...,b(left,j)(x), c storing the new values in biatx over the old. the facts that c b(i,1) = 1 if t(i) <= x < t(i+1) c and that c b(i,j)(x) = 0 unless t(i) <= x < t(i+j) c are used. the particular organization of the calculations follows c algorithm (8) in chapter x of the text. c C Arguments integer lent, jhigh, index, left double precision t(lent),x, biatx(jhigh) c dimension t(left+jout), biatx(jout) c ----------------------------------- c current fortran standard makes it impossible to specify the length of c t and of biatx precisely without the introduction of otherwise c superfluous additional arguments. C Local Variables integer jmax parameter(jmax = 20) integer i,j,jp1 double precision deltal(jmax), deltar(jmax),saved,term save j,deltal,deltar data j/1/ c go to (10,20), index 10 j = 1 biatx(1) = 1e0 if (j .ge. jhigh) go to 99 c 20 jp1 = j + 1 deltar(j) = t(left+j) - x deltal(j) = x - t(left+1-j) saved = 0e0 do 26 i=1,j term = biatx(i)/(deltar(i) + deltal(jp1-i)) biatx(i) = saved + deltar(i)*term 26 saved = deltal(jp1-i)*term biatx(jp1) = saved j = jp1 if (j .lt. jhigh) go to 20 c 99 return end gam/src/sslvrg.f0000644000176000001440000000731613324234205013331 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine sslvrg(penalt,dofoff,x,y,w,ssw, n, knot,nk,coef, * sz,lev, crit,icrit, lambda, xwy, hs0,hs1,hs2,hs3, * sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,info) C Purpose : C Compute smoothing spline for smoothing parameter lambda C and compute one of three `criteria' (OCV , GCV , "df match"). C See comments in ./sbart.f from which this is called integer n,nk,icrit,ld4,ldnk,info DOUBLE precision penalt,dofoff,x(n),y(n),w(n),ssw, & knot(nk+4), coef(nk),sz(n),lev(n), crit, lambda, * xwy(nk), hs0(nk),hs1(nk),hs2(nk),hs3(nk), * sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(ld4,nk), & p1ip(ld4,nk),p2ip(ldnk,nk) EXTERNAL bvalue double precision bvalue C local variables double precision vnikx(4,1),work(16) integer i,icoef,ileft,j,mflag, lenkno double precision b0,b1,b2,b3,eps, xv,rss,df, sumw c integer interv external interv lenkno = nk+4 ileft = 1 eps = 1d-11 C compute the coefficients coef() of estimated smooth do 1 i=1,nk coef(i) = xwy(i) abd(4,i) = hs0(i)+lambda*sg0(i) 1 continue do 4 i=1,(nk-1) abd(3,i+1) = hs1(i)+lambda*sg1(i) 4 continue do 6 i=1,(nk-2) 6 abd(2,i+2) = hs2(i)+lambda*sg2(i) do 8 i=1,(nk-3) 8 abd(1,i+3) = hs3(i)+lambda*sg3(i) c factorize banded matrix abd: call dpbfa(abd,ld4,nk,3,info) if(info.ne.0) then C matrix could not be factorized -> ier := info return endif c solve linear system (from factorize abd): call dpbsl(abd,ld4,nk,3,coef) C Value of smooth at the data points icoef = 1 do 12 i=1,n xv = x(i) 12 sz(i) = bvalue(knot,lenkno,coef, nk,4,xv,0) C Compute the criterion function if requested if(icrit .eq. 0)then return else C --- Ordinary or Generalized CV or "df match" --- C Get Leverages First call sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,0) do 16 i=1,n xv = x(i) ileft = interv(knot(1), nk+1, xv, 0,0, ileft, mflag) if(mflag .eq. -1) then ileft = 4 xv = knot(4)+eps else if(mflag .eq. 1) then ileft = nk xv = knot(nk+1) - eps endif j=ileft-3 C call bspvd(knot,4,1,xv,ileft,4,vnikx,work) call bsplvd(knot,lenkno,4,xv,ileft,work,vnikx,1) b0=vnikx(1,1) b1=vnikx(2,1) b2=vnikx(3,1) b3=vnikx(4,1) lev(i) = ( & p1ip(4,j)*b0**2 + 2.*p1ip(3,j)*b0*b1 + * 2.*p1ip(2,j)*b0*b2 + 2.*p1ip(1,j)*b0*b3 + * p1ip(4,j+1)*b1**2 + 2.*p1ip(3,j+1)*b1*b2 + * 2.*p1ip(2,j+1)*b1*b3 + p1ip(4,j+2)*b2**2 + & 2.*p1ip(3,j+2)*b2*b3 + p1ip(4,j+3)*b3**2 & )*w(i)**2 16 continue C Evaluate Criterion if(icrit .eq. 1)then C Generalized CV rss = ssw df = 0d0 sumw = 0d0 c w(i) are sqrt( wt[i] ) weights scaled in ../R/smspline.R such c that sumw = number of observations with w(i) > 0 do 24 i=1,n rss = rss + ((y(i)-sz(i))*w(i))**2 df = df + lev(i) sumw = sumw + w(i)**2 24 continue crit = (rss/sumw)/((1d0-(dofoff + penalt*df)/sumw)**2) c call dblepr("spar", 4, spar, 1) c call dblepr("crit", 4, crit, 1) else if(icrit .eq. 2) then C Ordinary CV crit = 0d0 do 30 i = 1,n 30 crit = crit + (((y(i)-sz(i))*w(i))/(1-lev(i)))**2 crit = crit/n c call dblepr("spar", 4, spar, 1) c call dblepr("crit", 4, crit, 1) else C df matching crit = 0d0 do 32 i=1,n 32 crit = crit+lev(i) crit = 3d0 + (dofoff-crit)**2 endif return endif C Criterion evaluation end gam/src/loessc.c0000644000176000001440000003200113507054520013266 0ustar ripleyusers/* * The authors of this software are Cleveland, Grosse, and Shyu. * Copyright (c) 1989, 1992 by AT&T. * Permission to use, copy, modify, and distribute this software for any * purpose without fee is hereby granted, provided that this entire notice * is included in all copies of any software which is or includes a copy * or modification of this software and in all copies of the supporting * documentation for such software. * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED * WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE ANY * REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY * OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE. */ /* * Altered by B.D. Ripley to use F77_*, declare routines before use. * * 'protoize'd to ANSI C headers; indented: M.Maechler */ #include #define USE_FC_LEN_T #include /* Forward declarations */ static void loess_workspace(Sint *d, Sint *n, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, Sint *setLf); static void loess_prune(Sint *parameter, Sint *a, double *xi, double *vert, double *vval); static void loess_grow (Sint *parameter, Sint *a, double *xi, double *vert, double *vval); /* These (and many more) are in ./loessf.f : */ void F77_NAME(lowesa)(); void F77_NAME(lowesb)(); void F77_NAME(lowesc)(); void F77_NAME(lowesd)(); void F77_NAME(lowese)(); void F77_NAME(lowesf)(); void F77_NAME(lowesl)(); void F77_NAME(ehg169)(); void F77_NAME(ehg196)(); /* exported (for loessf.f) : */ void F77_SUB(ehg182)(int *i); #ifdef FC_LEN_T # include void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc, FC_LEN_T c1); void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc, FC_LEN_T c1); #else void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc); void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc); #endif #undef min #undef max #define min(x,y) ((x) < (y) ? (x) : (y)) #define max(x,y) ((x) > (y) ? (x) : (y)) #define GAUSSIAN 1 #define SYMMETRIC 0 static Sint *iv, liv, lv, tau; static double *v; /* these are set in an earlier call to loess_workspace or loess_grow */ static void loess_free(void) { Free(v); Free(iv); } void loess_raw(double *y, double *x, double *weights, double *robust, Sint *d, Sint *n, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, double *cell, char **surf_stat, double *surface, Sint *parameter, Sint *a, double *xi, double *vert, double *vval, double *diagonal, double *trL, double *one_delta, double *two_delta, Sint *setLf) { Sint zero = 0, one = 1, two = 2, nsing, i, k; double *hat_matrix, *LL; *trL = 0; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, setLf); v[1] = *cell;/* = v(2) in Fortran (!) */ if(!strcmp(*surf_stat, "interpolate/none")) { F77_CALL(lowesb)(x, y, robust, &zero, &zero, iv, &liv, &lv, v); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "direct/none")) { F77_CALL(lowesf)(x, y, robust, iv, &liv, &lv, v, n, x, &zero, &zero, surface); } else if (!strcmp(*surf_stat, "interpolate/1.approx")) { F77_CALL(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); nsing = iv[29]; for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i]; F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "interpolate/2.approx")) { F77_CALL(lowesb)(x, y, robust, &zero, &zero, iv, &liv, &lv, v); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); nsing = iv[29]; F77_CALL(ehg196)(&tau, d, span, trL); F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "direct/approximate")) { F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, n, x, diagonal, &one, surface); nsing = iv[29]; for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i]; F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta); } else if (!strcmp(*surf_stat, "interpolate/exact")) { hat_matrix = (double *) R_alloc((*n)*(*n), sizeof(double)); LL = (double *) R_alloc((*n)*(*n), sizeof(double)); F77_CALL(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v); F77_CALL(lowesl)(iv, &liv, &lv, v, n, x, hat_matrix); F77_CALL(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "direct/exact")) { hat_matrix = (double *) R_alloc((*n)*(*n), sizeof(double)); LL = (double *) R_alloc((*n)*(*n), sizeof(double)); F77_CALL(lowesf)(x, y, weights, iv, liv, lv, v, n, x, hat_matrix, &two, surface); F77_CALL(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta); k = (*n) + 1; for(i = 0; i < (*n); i++) diagonal[i] = hat_matrix[i * k]; } loess_free(); } void loess_dfit(double *y, double *x, double *x_evaluate, double *weights, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, Sint *d, Sint *n, Sint *m, double *fit) { Sint zero = 0; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, &zero); F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate, &zero, &zero, fit); loess_free(); } void loess_dfitse(double *y, double *x, double *x_evaluate, double *weights, double *robust, Sint *family, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, Sint *d, Sint *n, Sint *m, double *fit, double *L) { Sint zero = 0, two = 2; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, &zero); if(*family == GAUSSIAN) F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate, L, &two, fit); else if(*family == SYMMETRIC) { F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate, L, &two, fit); F77_CALL(lowesf)(x, y, robust, iv, &liv, &lv, v, m, x_evaluate, &zero, &zero, fit); } loess_free(); } void loess_ifit(Sint *parameter, Sint *a, double *xi, double *vert, double *vval, Sint *m, double *x_evaluate, double *fit) { loess_grow(parameter, a, xi, vert, vval); F77_CALL(lowese)(iv, &liv, &lv, v, m, x_evaluate, fit); loess_free(); } void loess_ise(double *y, double *x, double *x_evaluate, double *weights, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, double *cell, Sint *d, Sint *n, Sint *m, double *fit, double *L) { Sint zero = 0, one = 1; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, &one); v[1] = *cell; F77_CALL(lowesb)(x, y, weights, &zero, &zero, iv, &liv, &lv, v); F77_CALL(lowesl)(iv, &liv, &lv, v, m, x_evaluate, L); loess_free(); } void loess_workspace(Sint *d, Sint *n, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, Sint *setLf) { Sint D, N, tau0, nvmax, nf, version = 106, i; D = *d; N = *n; nvmax = max(200, N); nf = min(N, floor(N * (*span) + 1e-5)); if(nf <= 0) error("span is too small"); tau0 = ((*degree) > 1) ? ((D + 2) * (D + 1) * 0.5) : (D + 1); tau = tau0 - (*sum_drop_sqr); lv = 50 + (3 * D + 3) * nvmax + N + (tau0 + 2) * nf; liv = 50 + ((Sint)pow((double)2, (double)D) + 4) * nvmax + 2 * N; if(*setLf) { lv = lv + (D + 1) * nf * nvmax; liv = liv + nf * nvmax; } iv = Calloc(liv, Sint); v = Calloc(lv, double); F77_CALL(lowesd)(&version, iv, &liv, &lv, v, d, n, span, degree, &nvmax, setLf); iv[32] = *nonparametric; for(i = 0; i < D; i++) iv[i + 40] = drop_square[i]; } static void loess_prune(Sint *parameter, Sint *a, double *xi, double *vert, double *vval) { Sint d, vc, a1, v1, xi1, vv1, nc, nv, nvmax, i, k; d = iv[1]; vc = iv[3] - 1; nc = iv[4]; nv = iv[5]; a1 = iv[6] - 1; v1 = iv[10] - 1; xi1 = iv[11] - 1; vv1 = iv[12] - 1; nvmax = iv[13]; for(i = 0; i < 5; i++) parameter[i] = iv[i + 1]; parameter[5] = iv[21] - 1; parameter[6] = iv[14] - 1; for(i = 0; i < d; i++){ k = nvmax * i; vert[i] = v[v1 + k]; vert[i + d] = v[v1 + vc + k]; } for(i = 0; i < nc; i++) { xi[i] = v[xi1 + i]; a[i] = iv[a1 + i]; } k = (d + 1) * nv; for(i = 0; i < k; i++) vval[i] = v[vv1 + i]; } static void loess_grow(Sint *parameter, Sint *a, double *xi, double *vert, double *vval) { Sint d, vc, nc, nv, a1, v1, xi1, vv1, i, k; d = parameter[0]; vc = parameter[2]; nc = parameter[3]; nv = parameter[4]; liv = parameter[5]; lv = parameter[6]; iv = Calloc(liv, Sint); v = Calloc(lv, double); iv[1] = d; iv[2] = parameter[1]; iv[3] = vc; iv[5] = iv[13] = nv; iv[4] = iv[16] = nc; iv[6] = 50; iv[7] = iv[6] + nc; iv[8] = iv[7] + vc * nc; iv[9] = iv[8] + nc; iv[10] = 50; iv[12] = iv[10] + nv * d; iv[11] = iv[12] + (d + 1) * nv; iv[27] = 173; v1 = iv[10] - 1; xi1 = iv[11] - 1; a1 = iv[6] - 1; vv1 = iv[12] - 1; for(i = 0; i < d; i++) { k = nv * i; v[v1 + k] = vert[i]; v[v1 + vc - 1 + k] = vert[i + d]; } for(i = 0; i < nc; i++) { v[xi1 + i] = xi[i]; iv[a1 + i] = a[i]; } k = (d + 1) * nv; for(i = 0; i < k; i++) v[vv1 + i] = vval[i]; F77_CALL(ehg169)(&d, &vc, &nc, &nc, &nv, &nv, v+v1, iv+a1, v+xi1, iv+iv[7]-1, iv+iv[8]-1, iv+iv[9]-1); } /* begin ehg's FORTRAN-callable C-codes */ void F77_SUB(ehg182)(int *i) { char *msg, msg2[100]; #define MSG(_m_) msg = _m_ ; break ; switch(*i){ case 100:MSG("wrong version number in lowesd. Probably typo in caller.") case 101:MSG("d>dMAX in ehg131. Need to recompile with increased dimensions.") case 102:MSG("liv too small. (Discovered by lowesd)") case 103:MSG("lv too small. (Discovered by lowesd)") case 104:MSG("span too small. fewer data values than degrees of freedom.") case 105:MSG("k>d2MAX in ehg136. Need to recompile with increased dimensions.") case 106:MSG("lwork too small") case 107:MSG("invalid value for kernel") case 108:MSG("invalid value for ideg") case 109:MSG("lowstt only applies when kernel=1.") case 110:MSG("not enough extra workspace for robustness calculation") case 120:MSG("zero-width neighborhood. make span bigger") case 121:MSG("all data on boundary of neighborhood. make span bigger") case 122:MSG("extrapolation not allowed with blending") case 123:MSG("ihat=1 (diag L) in l2fit only makes sense if z=x (eval=data).") case 171:MSG("lowesd must be called first.") case 172:MSG("lowesf must not come between lowesb and lowese, lowesr, or lowesl.") case 173:MSG("lowesb must come before lowese, lowesr, or lowesl.") case 174:MSG("lowesb need not be called twice.") case 175:MSG("need setLf=.true. for lowesl.") case 180:MSG("nv>nvmax in cpvert.") case 181:MSG("nt>20 in eval.") case 182:MSG("svddc failed in l2fit.") case 183:MSG("didnt find edge in vleaf.") case 184:MSG("zero-width cell found in vleaf.") case 185:MSG("trouble descending to leaf in vleaf.") case 186:MSG("insufficient workspace for lowesf.") case 187:MSG("insufficient stack space") case 188:MSG("lv too small for computing explicit L") case 191:MSG("computed trace L was negative; something is wrong!") case 192:MSG("computed delta was negative; something is wrong!") case 193:MSG("workspace in loread appears to be corrupted") case 194:MSG("trouble in l2fit/l2tr") case 195:MSG("only constant, linear, or quadratic local models allowed") case 196:MSG("degree must be at least 1 for vertex influence matrix") case 999:MSG("not yet implemented") default: sprintf(msg=msg2,"Assert failed; error code %d\n",*i); } warning(msg); } #undef MSG #ifdef FC_LEN_T void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc, FC_LEN_T c1) #else void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc) #endif { char mess[4000], num[20]; int j; strncpy(mess,s,*nc); mess[*nc] = '\0'; for (j=0; j<*n; j++) { sprintf(num," %d",i[j * *inc]); strcat(mess,num); } strcat(mess,"\n"); warning(mess); } #ifdef FC_LEN_T void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc, FC_LEN_T c1) #else void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc) #endif { char mess[4000], num[30]; int j; strncpy(mess,s,*nc); mess[*nc] = '\0'; for (j=0; j<*n; j++) { sprintf(num," %.5g",x[j * *inc]); strcat(mess,num); } strcat(mess,"\n"); warning(mess); } gam/src/backlo.f0000644000176000001440000001063213324234205013237 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine baklo(x,y,w,npetc,wddnfl,spatol,match, etal,s,eta,beta, *var,dof, qr,qraux,qpivot,effect,iv,v,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,nit,maxit,qrank integer npetc(7),wddnfl(*),match(*),qpivot(*),iv(*),iwork(*) double precision x(*),y(*),w(*),spatol(*), etal(*),s(*),eta(*),bet *a(*),var(*),dof(*), qr(*),qraux(*),v(*),effect(*),work(*) n=npetc(1) p=npetc(2) q=npetc(3) maxit=npetc(5) qrank=npetc(6) call baklo0(x,n,p,y,w,q,wddnfl(1),wddnfl(q+1),wddnfl(2*q+1), spato *l(1),wddnfl(3*q+1),dof,match,wddnfl(4*q+1), etal,s,eta,beta,var,sp *atol(q+1), nit,maxit,qr,qraux,qrank,qpivot,effect, work(1),work(n+ *1),work(2*n+1),work(3*n+1), iv,wddnfl(5*q+1),wddnfl(6*q+1),v,wddnf *l(7*q+1), iwork(1),work(4*n+1)) npetc(4)=nit npetc(6)=qrank return end subroutine baklo0(x,n,p,y,w,q,which,dwhich,pwhich,span,degree,dof, *match,nef, etal,s,eta,beta,var,tol,nit,maxit, qr,qraux,qrank,qpivo *t,effect,z,old,sqwt,sqwti, iv,liv,lv,v,nvmax,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,which(q),dwhich(q),pwhich(q),degree(q),match(n,q),ne *f(q),nit, maxit,qrank,qpivot(p),iv(*),liv(q),lv(q),nvmax(q),iwork( *q) double precision x(n,p),y(n),w(n),span(q),dof(q), etal(n),s(n,q),e *ta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),v(*),effect(n),work(* *) double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info,slv,sliv,iw,j,dj,pj onedm7=1d-7 job=1101 info=1 if(q.eq.0)then maxit=1 endif ratio=1d0 anyzwt=.false. do23002 i=1,n if(w(i).gt.0d0)then sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) else sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. endif 23002 continue 23003 continue if(qrank.eq.0)then do23008 i=1,n do23010 j=1,p qr(i,j)=x(i,j)*sqwt(i) 23010 continue 23011 continue 23008 continue 23009 continue do23012 j=1,p qpivot(j)=j 23012 continue 23013 continue call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) endif do23014 i=1,n eta(i)=0d0 j=1 23016 if(.not.(j.le.q))goto 23018 eta(i)=eta(i)+s(i,j) 23017 j=j+1 goto 23016 23018 continue 23014 continue 23015 continue nit=0 23019 if((ratio .gt. tol ).and.(nit .lt. maxit))then deltaf=0d0 nit=nit+1 do23021 i=1,n z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) 23021 continue 23022 continue call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),et *al,job,info) do23023 i=1,n etal(i)=etal(i)*sqwti(i) 23023 continue 23024 continue sliv=1 slv=1 iw=5*n+1 k=1 23025 if(.not.(k.le.q))goto 23027 j=which(k) dj=dwhich(k) pj=pwhich(k) do23028 i=1,n old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) 23028 continue 23029 continue call lo1(x(1,j),z,w,n,dj,pj,nvmax(k),span(k),degree(k),match(1,k), * nef(k),nit,dof(k),s(1,k),var(1,k),work(iw), work(iw+pj+1),work(iw *+nef(k)*dj+pj+1), work(iw+nef(k)*(dj+1)+pj+2),work(iw + nef(k)*(dj *+2)+pj+2), work(iw+nef(k)*(dj+3)+pj+2),work(iw+nef(k)*(pj+dj+4)+pj *+2), iwork(1),work(iw+nef(k)*(pj+dj+4)+4+2*pj), iv(sliv),liv(k),lv *(k),v(slv), work(1) ) sliv=sliv+liv(k) slv=slv+lv(k) iw=iw+nef(k)*(pj+dj+4)+5+3*pj do23030 i=1,n eta(i)=eta(i)+s(i,k)-old(i) 23030 continue 23031 continue deltaf=deltaf+dwrss(n,old,s(1,k),w) 23026 k=k+1 goto 23025 23027 continue normf=0d0 do23032 i=1,n normf=normf+w(i)*eta(i)*eta(i) 23032 continue 23033 continue if(normf.gt.0d0)then ratio=dsqrt(deltaf/normf) else ratio = 0d0 endif goto 23019 endif 23020 continue do23036 j=1,p work(j)=beta(j) 23036 continue 23037 continue do23038 j=1,p beta(qpivot(j))=work(j) 23038 continue 23039 continue if(anyzwt)then do23042 i=1,n if(w(i) .le. 0d0)then etal(i)=0d0 do23046 j=1,p etal(i)=etal(i)+beta(j)*x(i,j) 23046 continue 23047 continue endif 23042 continue 23043 continue endif do23048 i=1,n eta(i)=eta(i)+etal(i) 23048 continue 23049 continue return end gam/src/bvalue.f0000644000176000001440000001333613324234205013266 0ustar ripleyusers double precision function bvalue(t,lent,bcoef,n,k,x,jderiv) c Calculates value at x of jderiv-th derivative of spline from B-repr. c The spline is taken to be continuous from the right. c C calls interv c c****** i n p u t ****** c t, bcoef, n, k......forms the b-representation of the spline f to c be evaluated. specifically, c t.....knot sequence, of length n+k, assumed nondecreasing. c bcoef.....b-coefficient sequence, of length n . c n.....length of bcoef and dimension of s(k,t), c a s s u m e d positive . c k.....order of the spline . c c w a r n i n g . . . the restriction k <= kmax (=20) is imposed c arbitrarily by the dimension statement for aj, dm, dm below, c but is n o w h e r e c h e c k e d for. c however in R, this is only called from bvalus() with k=4 anyway! c c x.....the point at which to evaluate . c jderiv.....integer giving the order of the derivative to be evaluated c a s s u m e d to be zero or positive. c c****** o u t p u t ****** c bvalue.....the value of the (jderiv)-th derivative of f at x . c c****** m e t h o d ****** c the nontrivial knot interval (t(i),t(i+1)) containing x is lo- c cated with the aid of interv(). the k b-coeffs of f relevant for c this interval are then obtained from bcoef (or taken to be zero if c not explicitly available) and are then differenced jderiv times to c obtain the b-coeffs of (d^jderiv)f relevant for that interval. c precisely, with j = jderiv, we have from x.(12) of the text that c c (d^j)f = sum ( bcoef(.,j)*b(.,k-j,t) ) c c where c / bcoef(.), , j .eq. 0 c / c bcoef(.,j) = / bcoef(.,j-1) - bcoef(.-1,j-1) c / ----------------------------- , j > 0 c / (t(.+k-j) - t(.))/(k-j) c c then, we use repeatedly the fact that c c sum ( a(.)*b(.,m,t)(x) ) = sum ( a(.,x)*b(.,m-1,t)(x) ) c with c (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1) c a(.,x) = --------------------------------------- c (x - t(.)) + (t(.+m-1) - x) c c to write (d^j)f(x) eventually as a linear combination of b-splines c of order 1 , and the coefficient for b(i,1,t)(x) must then c be the desired number (d^j)f(x). (see x.(17)-(19) of text). c C Arguments integer lent, n,k, jderiv DOUBLE precision t(*),bcoef(n),x c dimension t(n+k) c current fortran standard makes it impossible to specify the length of c t precisely without the introduction of otherwise superfluous c additional arguments. C Local Variables integer kmax parameter(kmax = 20) DOUBLE precision aj(kmax),dm(kmax),dp(kmax),fkmj integer i,ilo,imk,j,jc,jcmin,jcmax,jj,km1,kmj,mflag,nmi, jdrvp1 c integer interv external interv c initialize data i/1/ bvalue = 0. if (jderiv .ge. k) go to 99 c c *** find i s.t. 1 <= i < n+k and t(i) < t(i+1) and c t(i) <= x < t(i+1) . if no such i can be found, x lies c outside the support of the spline f and bvalue = 0. c {this case is handled in the calling R code} c (the asymmetry in this choice of i makes f rightcontinuous) if( (x.ne.t(n+1)) .or. (t(n+1).ne.t(n+k)) ) then i = interv ( t, n+k, x, 0, 0, i, mflag) if (mflag .ne. 0) then call rwarn("bvalue() mflag != 0: should never happen!") go to 99 endif else i = n endif c *** if k = 1 (and jderiv = 0), bvalue = bcoef(i). km1 = k - 1 if (km1 .le. 0) then bvalue = bcoef(i) go to 99 endif c c *** store the k b-spline coefficients relevant for the knot interval c (t(i),t(i+1)) in aj(1),...,aj(k) and compute dm(j) = x - t(i+1-j), c dp(j) = t(i+j) - x, j=1,...,k-1 . set any of the aj not obtainable c from input to zero. set any t.s not obtainable equal to t(1) or c to t(n+k) appropriately. jcmin = 1 imk = i - k if (imk .ge. 0) then 8 do 9 j=1,km1 dm(j) = x - t(i+1-j) 9 continue else jcmin = 1 - imk do 5 j=1,i dm(j) = x - t(i+1-j) 5 continue do 6 j=i,km1 aj(k-j) = 0. dm(j) = dm(i) 6 continue endif c jcmax = k nmi = n - i if (nmi .ge. 0) then do 19 j=1,km1 C the following if() happens; e.g. in pp <- predict(cars.spl, xx) c - if( (i+j) .gt. lent) write(6,9911) i+j,lent c - 9911 format(' i+j, lent ',2(i6,1x)) dp(j) = t(i+j) - x 19 continue else jcmax = k + nmi do 15 j=1,jcmax dp(j) = t(i+j) - x 15 continue do 16 j=jcmax,km1 aj(j+1) = 0. dp(j) = dp(jcmax) 16 continue endif c do 21 jc=jcmin,jcmax aj(jc) = bcoef(imk + jc) 21 continue c c *** difference the coefficients jderiv times. if (jderiv .ge. 1) then do 23 j=1,jderiv kmj = k-j fkmj = dble(kmj) ilo = kmj do 24 jj=1,kmj aj(jj) = ((aj(jj+1) - aj(jj))/(dm(ilo) + dp(jj)))*fkmj ilo = ilo - 1 24 continue 23 continue endif c c *** compute value at x in (t(i),t(i+1)) of jderiv-th derivative, c given its relevant b-spline coeffs in aj(1),...,aj(k-jderiv). 30 if (jderiv .ne. km1) then jdrvp1 = jderiv + 1 do 33 j=jdrvp1,km1 kmj = k-j ilo = kmj do 34 jj=1,kmj aj(jj) = (aj(jj+1)*dm(ilo) + aj(jj)*dp(jj)) / * (dm(ilo)+dp(jj)) ilo = ilo - 1 34 continue 33 continue endif 39 bvalue = aj(1) c 99 return end gam/src/splsm.f0000644000176000001440000001240213324234205013137 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine sknotl(x,n,knot,k) implicit double precision(a-h,o-z) double precision x(n),knot(n+6),a1,a2,a3,a4 integer n,k,ndk,j a1 = log(50d0)/log(2d0) a2 = log(100d0)/log(2d0) a3 = log(140d0)/log(2d0) a4 = log(200d0)/log(2d0) if(n.lt.50)then ndk = n else if(n.ge.50 .and. n.lt.200)then ndk = 2.**(a1+(a2-a1)*(n-50.)/150.) else if(n.ge.200 .and. n.lt.800)then ndk = 2.**(a2+(a3-a2)*(n-200.)/600.) else if(n.ge.800 .and. n.lt.3200)then ndk = 2.**(a3+(a4-a3)*(n-800.)/2400.) else if(n.ge.3200)then ndk = 200. + float(n-3200)**.2 endif endif endif endif endif k = ndk + 6 do23010 j=1,3 knot(j) = x(1) 23010 continue 23011 continue do23012 j=1,ndk knot(j+3) = x( 1 + (j-1)*(n-1)/(ndk-1) ) 23012 continue 23013 continue do23014 j=1,3 knot(ndk+3+j) = x(n) 23014 continue 23015 continue return end subroutine splsm(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,work) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,cov(*),work(*) integer n,match(*),nef integer ifcov call splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov, work(1), *work(nef+2),work(2*nef+3),work(3*nef+4), work(3*nef+n+10)) return end subroutine splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin *,yin,win,knot, work) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*),work(*) integer n,match(*),nef integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nef+6) integer nk,ldnk,ld4,k double precision xmin,xrange call suff(n,nef,match,x,y,w,xin,yin,win,work(1)) xmin=xin(1) xrange=xin(nef)-xin(1) do23016 i=1,nef xin(i)=(xin(i)-xmin)/xrange 23016 continue 23017 continue call sknotl(xin,nef,knot,k) nk=k-4 ld4=4 ldnk=1 call splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,w *in,knot, work(1), work(nk+1), work(nk+nef+2),work(nk+2*nef+3), wor *k(2*nk+2*nef+3),work(3*nk+2*nef+3),work(4*nk+2*nef+3), work(5*nk+2 **nef+3), work(6*nk+2*nef+3),work(7*nk+2*nef+3),work(8*nk+2*nef+3), * work(9*nk+2*nef+3), work(10*nk+2*nef+3),work((10+ld4)*nk+2*nef+3) *, work((10+2*ld4)*nk+2*nef+3), ld4,ldnk,nk) return end subroutine splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin *,yin,win,knot, coef,sout,levout,xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2, *sg3, abd,p1ip,p2ip,ld4,ldnk,nk) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*) integer n,match(*),nef integer nk,ldnk,ld4 integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nk+4) double precision coef(nk),sout(nef+1),levout(nef+1),xwy(nk), hs0(n *k),hs1(nk),hs2(nk),hs3(nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(l *d4,nk),p1ip(ld4,nk),p2ip(ldnk,*) integer ispar,icrit,isetup,ier double precision lspar,uspar,tol,penalt, sumwin,dofoff,crit,xbar,d *sum,xsbar double precision yssw, eps integer maxit double precision wmean crit=0d0 if(dof .le. 0d0)then ispar=1 icrit=3 dofoff=0d0 else if( dof .lt. 1d0 )then dof=1d0 endif ispar=0 icrit=3 dofoff=dof+1d0 endif isetup=0 ier=1 penalt=1d0 lspar= -1.5 uspar= 2.0 tol=1d-4 eps=2d-8 maxit=200 do23022 i=1,nef sout(i)=yin(i)*yin(i) 23022 continue 23023 continue sumwin=0d0 do23024 i=1,nef sumwin=sumwin+win(i) 23024 continue 23025 continue yssw=wmean(nef,sout,win) s0=wmean(n,y,w) yssw=yssw*(sumwin-s0*s0) call sbart(penalt,dofoff,xin,yin,win,yssw,nef,knot,nk, coef,sout,l *evout,crit, icrit,spar,ispar,maxit, lspar,uspar,tol,eps, isetup, x *wy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier) do23026 i=1,nef win(i)=win(i)*win(i) 23026 continue 23027 continue sbar=wmean(nef,sout,win) xbar=wmean(nef,xin,win) do23028 i=1,nef lev(i)=(xin(i)-xbar)*sout(i) 23028 continue 23029 continue xsbar=wmean(nef,lev,win) do23030 i=1,nef lev(i)=(xin(i)-xbar)**2 23030 continue 23031 continue dsum=wmean(nef,lev,win) do23032 i=1,nef if(win(i).gt.0d0)then lev(i)=levout(i)/win(i)-1d0/sumwin -lev(i)/(sumwin*dsum) else lev(i)=0d0 endif 23032 continue 23033 continue dof=0d0 do23036 i=1,nef dof=dof+lev(i)*win(i) 23036 continue 23037 continue dof=dof+1d0 do23038 i=1,nef sout(i)=sout(i)-sbar -(xin(i)-xbar)*xsbar/dsum 23038 continue 23039 continue call unpck(n,nef,match,sout,smo) return end double precision function wmean(n,y,w) integer n double precision y(n),w(n),wtot,wsum wtot=0d0 wsum=0d0 do23040 i=1,n wsum=wsum+y(i)*w(i) wtot=wtot+w(i) 23040 continue 23041 continue if(wtot .gt. 0d0)then wmean=wsum/wtot else wmean=0d0 endif return end gam/src/stxwx.f0000644000176000001440000000374513324234205013210 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine stxwx(x,z,w,k,xknot,n,y,hs0,hs1,hs2,hs3) c implicit none integer k,n DOUBLE precision x(k),z(k),w(k), xknot(n+4),y(n), & hs0(n),hs1(n),hs2(n),hs3(n) C local DOUBLE precision eps,vnikx(4,1),work(16) integer lenxk, i,j, ileft,mflag c integer interv external interv lenxk=n+4 C Initialise the output vectors do 1 i=1,n y(i)=0d0 hs0(i)=0d0 hs1(i)=0d0 hs2(i)=0d0 hs3(i)=0d0 1 continue C Compute X' W^2 X -> hs0,hs1,hs2,hs3 and X' W^2 Z -> y C Note that here the weights w(i) == sqrt(wt[i]) where wt[] where original weights ileft=1 eps= .1d-9 do 100 i=1,k ileft= interv(xknot(1), n+1, x(i), 0,0, ileft, mflag) C if(mflag==-1) {write(6,'("Error in hess ",i2)')mflag;stop} C if(mflag==-1) {return} if(mflag.eq. 1)then if(x(i).le.(xknot(ileft)+eps))then ileft=ileft-1 else return endif C else{write(6,'("Error in hess ",i2)')mflag;stop}} endif call bsplvd (xknot,lenxk,4,x(i),ileft,work,vnikx,1) j= ileft-4+1 y(j) = y(j)+w(i)**2*z(i)*vnikx(1,1) hs0(j)=hs0(j)+w(i)**2*vnikx(1,1)**2 hs1(j)=hs1(j)+w(i)**2*vnikx(1,1)*vnikx(2,1) hs2(j)=hs2(j)+w(i)**2*vnikx(1,1)*vnikx(3,1) hs3(j)=hs3(j)+w(i)**2*vnikx(1,1)*vnikx(4,1) j= ileft-4+2 y(j) = y(j)+w(i)**2*z(i)*vnikx(2,1) hs0(j)=hs0(j)+w(i)**2*vnikx(2,1)**2 hs1(j)=hs1(j)+w(i)**2*vnikx(2,1)*vnikx(3,1) hs2(j)=hs2(j)+w(i)**2*vnikx(2,1)*vnikx(4,1) j= ileft-4+3 y(j) = y(j)+w(i)**2*z(i)*vnikx(3,1) hs0(j)=hs0(j)+w(i)**2*vnikx(3,1)**2 hs1(j)=hs1(j)+w(i)**2*vnikx(3,1)*vnikx(4,1) j= ileft-4+4 y(j) = y(j)+w(i)**2*z(i)*vnikx(4,1) hs0(j)=hs0(j)+w(i)**2*vnikx(4,1)**2 100 continue return end gam/src/loessf.f0000644000176000001440000015550413324234205013307 0ustar ripleyusersC C The authors of this software are Cleveland, Grosse, and Shyu. C Copyright (c) 1989, 1992 by AT&T. C Permission to use, copy, modify, and distribute this software for any C purpose without fee is hereby granted, provided that this entire notice C is included in all copies of any software which is or includes a copy C or modification of this software and in all copies of the supporting C documentation for such software. C THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED C WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE ANY C REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY C OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE. C altered by B.D. Ripley to C C remove unused variables C make phi in ehg139 double precision to match calling sequence C C Note that ehg182(errormsg_code) is in ./loessc.c subroutine ehg126(d,n,vc,x,v,nvmax) integer d,execnt,i,j,k,n,nvmax,vc DOUBLE PRECISION machin,alpha,beta,mu,t DOUBLE PRECISION v(nvmax,d),x(n,d) DOUBLE PRECISION D1MACH external D1MACH save machin,execnt data execnt /0/ c MachInf -> machin execnt=execnt+1 if(execnt.eq.1)then c initialize d1mach(2) === DBL_MAX: machin=D1MACH(2) end if c fill in vertices for bounding box of $x$ c lower left, upper right do 3 k=1,d alpha=machin beta=-machin do 4 i=1,n t=x(i,k) alpha=min(alpha,t) beta=max(beta,t) 4 continue c expand the box a little mu=0.005D0*max(beta-alpha,1.d-10*max(DABS(alpha),DABS(beta))+ + 1.d-30) alpha=alpha-mu beta=beta+mu v(1,k)=alpha v(vc,k)=beta 3 continue c remaining vertices do 5 i=2,vc-1 j=i-1 do 6 k=1,d v(i,k)=v(1+mod(j,2)*(vc-1),k) j=DBLE(j)/2.D0 6 continue 5 continue return end subroutine ehg125(p,nv,v,vhit,nvmax,d,k,t,r,s,f,l,u) logical i1,i2,match integer d,execnt,h,i,i3,j,k,m,mm,nv,nvmax,p,r,s integer f(r,0:1,s),l(r,0:1,s),u(r,0:1,s),vhit(nvmax) DOUBLE PRECISION t DOUBLE PRECISION v(nvmax,d) external ehg182 save execnt data execnt /0/ execnt=execnt+1 h=nv do 3 i=1,r do 4 j=1,s h=h+1 do 5 i3=1,d v(h,i3)=v(f(i,0,j),i3) 5 continue v(h,k)=t c check for redundant vertex match=.false. m=1 c top of while loop 6 if(.not.match)then i1=(m.le.nv) else i1=.false. end if if(.not.(i1))goto 7 match=(v(m,1).eq.v(h,1)) mm=2 c top of while loop 8 if(match)then i2=(mm.le.d) else i2=.false. end if if(.not.(i2))goto 9 match=(v(m,mm).eq.v(h,mm)) mm=mm+1 goto 8 c bottom of while loop 9 m=m+1 goto 6 c bottom of while loop 7 m=m-1 if(match)then h=h-1 else m=h if(vhit(1).ge.0)then vhit(m)=p end if end if l(i,0,j)=f(i,0,j) l(i,1,j)=m u(i,0,j)=m u(i,1,j)=f(i,1,j) 4 continue 3 continue nv=h if(.not.(nv.le.nvmax))then call ehg182(180) end if return end integer function ehg138(i,z,a,xi,lo,hi,ncmax) logical i1 integer execnt,i,j,ncmax integer a(ncmax),hi(ncmax),lo(ncmax) DOUBLE PRECISION xi(ncmax),z(8) save execnt data execnt /0/ execnt=execnt+1 c descend tree until leaf or ambiguous j=i c top of while loop 3 if(a(j).ne.0)then i1=(z(a(j)).ne.xi(j)) else i1=.false. end if if(.not.(i1))goto 4 if(z(a(j)).lt.xi(j))then j=lo(j) else j=hi(j) end if goto 3 c bottom of while loop 4 ehg138=j return end subroutine ehg106(il,ir,k,nk,p,pi,n) c Partial sorting of p(1, il:ir) returning the sort indices pi() only c such that p(1, pi(k)) is correct c implicit none c Arguments c Input: integer il,ir,k,nk,n DOUBLE PRECISION p(nk,n) c using only p(1, pi(*)) c Output: integer pi(n) c Variables DOUBLE PRECISION t integer i,ii,j,l,r c find the $k$-th smallest of $n$ elements c Floyd+Rivest, CACM Mar '75, Algorithm 489 l=il r=ir c while (l < r ) 3 if(.not.(l.lt.r))goto 4 c to avoid recursion, sophisticated partition deleted c partition $x sub {l..r}$ about $t$ t=p(1,pi(k)) i=l j=r ii=pi(l) pi(l)=pi(k) pi(k)=ii if(t.lt.p(1,pi(r)))then ii=pi(l) pi(l)=pi(r) pi(r)=ii end if c top of while loop 5 if(.not.(i.lt.j))goto 6 ii=pi(i) pi(i)=pi(j) pi(j)=ii i=i+1 j=j-1 c top of while loop 7 if(.not.(p(1,pi(i)).lt.t))goto 8 i=i+1 goto 7 c bottom of while loop 8 continue c top of while loop 9 if(.not.(t.lt.p(1,pi(j))))goto 10 j=j-1 goto 9 c bottom of while loop 10 goto 5 c bottom of while loop 6 if(p(1,pi(l)).eq.t)then ii=pi(l) pi(l)=pi(j) pi(j)=ii else j=j+1 ii=pi(r) pi(r)=pi(j) pi(j)=ii end if if(j.le.k)then l=j+1 end if if(k.le.j)then r=j-1 end if goto 3 c bottom of while loop 4 return end subroutine ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w, + rcond,sing,sigma,u,e,dgamma,qraux,work,tol,dd,tdeg,cdeg,s) integer column,d,dd,execnt,i,i3,i9,info,inorm2,j,jj,jpvt,k,kernel, + n,nf,od,sing,tdeg integer cdeg(8),psi(n) double precision machep,f,i1,i10,i2,i4,i5,i6,i7,i8,rcond,rho,scal, + tol double precision g(15),sigma(15),u(15,15),e(15,15),b(nf,k), + colnor(15),dist(n),eta(nf),dgamma(15),q(d),qraux(15),rw(n), + s(0:od),w(nf),work(15),x(n,d),y(n) integer idamax double precision d1mach, ddot external ehg106,ehg182,ehg184,dqrdc,dqrsl,dsvdc external idamax, d1mach, ddot save machep,execnt data execnt /0/ c colnorm -> colnor c E -> g c MachEps -> machep c V -> e c X -> b execnt=execnt+1 if(execnt.eq.1)then c initialize d1mach(4) === 1 / DBL_EPSILON === 2^52 : machep=d1mach(4) end if c sort by distance do 3 i3=1,n dist(i3)=0 3 continue do 4 j=1,dd i4=q(j) do 5 i3=1,n dist(i3)=dist(i3)+(x(i3,j)-i4)**2 5 continue 4 continue call ehg106(1,n,nf,1,dist,psi,n) rho=dist(psi(nf))*max(1.d0,f) if(rho .le. 0)then call ehg182(120) end if c compute neighborhood weights if(kernel.eq.2)then do 6 i=1,nf if(dist(psi(i)).lt.rho)then i1=dsqrt(rw(psi(i))) else i1=0 end if w(i)=i1 6 continue else do 7 i3=1,nf w(i3)=dsqrt(dist(psi(i3))/rho) 7 continue do 8 i3=1,nf w(i3)=dsqrt(rw(psi(i3))*(1-w(i3)**3)**3) 8 continue end if if(dabs(w(idamax(nf,w,1))).eq.0)then call ehg184('at ',q(1),dd,1) call ehg184('radius ',rho,1,1) if(.not..false.)then call ehg182(121) end if end if c fill design matrix column=1 do 9 i3=1,nf b(i3,column)=w(i3) 9 continue if(tdeg.ge.1)then do 10 j=1,d if(cdeg(j).ge.1)then column=column+1 i5=q(j) do 11 i3=1,nf b(i3,column)=w(i3)*(x(psi(i3),j)-i5) 11 continue end if 10 continue end if if(tdeg.ge.2)then do 12 j=1,d if(cdeg(j).ge.1)then if(cdeg(j).ge.2)then column=column+1 i6=q(j) do 13 i3=1,nf b(i3,column)=w(i3)*(x(psi(i3),j)-i6)**2 13 continue end if do 14 jj=j+1,d if(cdeg(jj).ge.1)then column=column+1 i7=q(j) i8=q(jj) do 15 i3=1,nf b(i3,column)=w(i3)*(x(psi(i3),j)-i7)*(x(psi(i3), +jj)-i8) 15 continue end if 14 continue end if 12 continue k=column end if do 16 i3=1,nf eta(i3)=w(i3)*y(psi(i3)) 16 continue c equilibrate columns do 17 j=1,k scal=0 do 18 inorm2=1,nf scal=scal+b(inorm2,j)**2 18 continue scal=dsqrt(scal) if(0.lt.scal)then do 19 i3=1,nf b(i3,j)=b(i3,j)/scal 19 continue colnor(j)=scal else colnor(j)=1 end if 17 continue c singular value decomposition call dqrdc(b,nf,nf,k,qraux,jpvt,work,0) call dqrsl(b,nf,nf,k,qraux,eta,work,eta,eta,work,work,1000,info) do 20 i9=1,k do 21 i3=1,k u(i3,i9)=0 21 continue 20 continue do 22 i=1,k do 23 j=i,k u(i,j)=b(i,j) 23 continue 22 continue call dsvdc(u,15,k,k,sigma,g,u,15,e,15,work,21,info) if(.not.(info.eq.0))then call ehg182(182) end if tol=sigma(1)*(100*machep) rcond=min(rcond,sigma(k)/sigma(1)) if(sigma(k).le.tol)then sing=sing+1 if(sing.eq.1)then call ehg184('pseudoinverse used at',q(1),d,1) call ehg184('neighborhood radius',dsqrt(rho),1,1) call ehg184('reciprocal condition number ',rcond,1,1) else if(sing.eq.2)then call ehg184('There are other near singularities as well.' +,rho,1,1) end if end if end if c compensate for equilibration do 24 j=1,k i10=colnor(j) do 25 i3=1,k e(j,i3)=e(j,i3)/i10 25 continue 24 continue c solve least squares problem do 26 j=1,k if(tol.lt.sigma(j))then i2=ddot(k,u(1,j),1,eta,1)/sigma(j) else i2=0.d0 end if dgamma(j)=i2 26 continue do 27 j=0,od s(j)=ddot(k,e(j+1,1),15,dgamma,1) 27 continue return end subroutine ehg131(x,y,rw,trl,diagl,kernel,k,n,d,nc,ncmax,vc,nv, + nvmax,nf,f,a,c,hi,lo,pi,psi,v,vhit,vval,xi,dist,eta,b,ntol, + fd,w,vval2,rcond,sing,dd,tdeg,cdeg,lq,lf,setlf) logical setlf integer identi,d,dd,execnt,i1,i2,j,k,kernel,n,nc,ncmax,nf,ntol,nv, + nvmax,sing,tdeg,vc integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),cdeg(8),hi(ncmax), + lo(ncmax),pi(n),psi(n),vhit(nvmax) double precision f,fd,rcond,trl double precision lf(0:d,nvmax,nf),b(*),delta(8),diagl(n),dist(n), + eta(nf),rw(n),v(nvmax,d),vval(0:d,nvmax),vval2(0:d,nvmax), + w(nf),x(n,d),xi(ncmax),y(n) external ehg126,ehg182,ehg139,ehg124 double precision dnrm2 external dnrm2 save execnt data execnt /0/ c Identity -> identi c X -> b execnt=execnt+1 if(.not.(d.le.8))then call ehg182(101) end if c build $k$-d tree call ehg126(d,n,vc,x,v,nvmax) nv=vc nc=1 do 3 j=1,vc c(j,nc)=j vhit(j)=0 3 continue do 4 i1=1,d delta(i1)=v(vc,i1)-v(1,i1) 4 continue fd=fd*dnrm2(d,delta,1) do 5 identi=1,n pi(identi)=identi 5 continue call ehg124(1,n,d,n,nv,nc,ncmax,vc,x,pi,a,xi,lo,hi,c,v,vhit,nvmax, +ntol,fd,dd) c smooth if(trl.ne.0)then do 6 i2=1,nv do 7 i1=0,d vval2(i1,i2)=0 7 continue 6 continue end if call ehg139(v,nvmax,nv,n,d,nf,f,x,pi,psi,y,rw,trl,kernel,k,dist, + dist,eta,b,d,w,diagl,vval2,nc,vc,a,xi,lo,hi,c,vhit,rcond, + sing,dd,tdeg,cdeg,lq,lf,setlf,vval) return end subroutine ehg133(n,d,vc,nvmax,nc,ncmax,a,c,hi,lo,v,vval,xi,m,z,s) integer n,d,vc,nvmax,nc,ncmax, m integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax) double precision v(nvmax,d),vval(0:d,nvmax),xi(ncmax),z(m,d),s(m) c Var double precision delta(8) integer i,i1 double precision ehg128 external ehg128 do 3 i=1,m do 4 i1=1,d delta(i1)=z(i,i1) 4 continue s(i)=ehg128(delta,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax,vval) 3 continue return end subroutine ehg140(iw,i,j) integer execnt,i,j integer iw(i) save execnt data execnt /0/ execnt=execnt+1 iw(i)=j return end subroutine ehg141(trl,n,deg,k,d,nsing,dk,delta1,delta2) double precision trl,delta1,delta2 integer n,deg,k,d,nsing,dk double precision c(48), c1, c2, c3, c4, corx,z integer i external ehg176 double precision ehg176 double precision ourz(1) c coef, d, deg, del data c / .2971620d0,.3802660d0,.5886043d0,.4263766d0,.3346498d0, +.6271053d0,.5241198d0,.3484836d0,.6687687d0,.6338795d0,.4076457d0, +.7207693d0,.1611761d0,.3091323d0,.4401023d0,.2939609d0,.3580278d0, +.5555741d0,.3972390d0,.4171278d0,.6293196d0,.4675173d0,.4699070d0, +.6674802d0,.2848308d0,.2254512d0,.2914126d0,.5393624d0,.2517230d0, +.3898970d0,.7603231d0,.2969113d0,.4740130d0,.9664956d0,.3629838d0, +.5348889d0,.2075670d0,.2822574d0,.2369957d0,.3911566d0,.2981154d0, +.3623232d0,.5508869d0,.3501989d0,.4371032d0,.7002667d0,.4291632d0, +.4930370d0 / if(deg.eq.0) dk=1 if(deg.eq.1) dk=d+1 if(deg.eq.2) dk=dble((d+2)*(d+1))/2.d0 corx=dsqrt(k/dble(n)) z=(dsqrt(k/trl)-corx)/(1-corx) if(nsing .eq. 0 .and. 1 .lt. z) call ehg184('Chernobyl! trLn',trl,1,1) z=min(1.0d0,max(0.0d0,z)) ourz(1) = z c4=dexp(ehg176(ourz)) i=1+3*(min(d,4)-1+4*(deg-1)) if(d.le.4)then c1=c(i) c2=c(i+1) c3=c(i+2) else c1=c(i)+(d-4)*(c(i)-c(i-3)) c2=c(i+1)+(d-4)*(c(i+1)-c(i-2)) c3=c(i+2)+(d-4)*(c(i+2)-c(i-1)) endif delta1=n-trl*dexp(c1*z**c2*(1-z)**c3*c4) i=i+24 if(d.le.4)then c1=c(i) c2=c(i+1) c3=c(i+2) else c1=c(i)+(d-4)*(c(i)-c(i-3)) c2=c(i+1)+(d-4)*(c(i+1)-c(i-2)) c3=c(i+2)+(d-4)*(c(i+2)-c(i-1)) endif delta2=n-trl*dexp(c1*z**c2*(1-z)**c3*c4) return end subroutine lowesc(n,l,ll,trl,delta1,delta2) integer execnt,i,j,n double precision delta1,delta2,trl double precision l(n,n),ll(n,n) double precision ddot external ddot save execnt data execnt /0/ execnt=execnt+1 c compute $LL~=~(I-L)(I-L)'$ do 3 i=1,n l(i,i)=l(i,i)-1 3 continue do 4 i=1,n do 5 j=1,i ll(i,j)=ddot(n,l(i,1),n,l(j,1),n) 5 continue 4 continue do 6 i=1,n do 7 j=i+1,n ll(i,j)=ll(j,i) 7 continue 6 continue do 8 i=1,n l(i,i)=l(i,i)+1 8 continue c accumulate first two traces trl=0 delta1=0 do 9 i=1,n trl=trl+l(i,i) delta1=delta1+ll(i,i) 9 continue c $delta sub 2 = "tr" LL sup 2$ delta2=0 do 10 i=1,n delta2=delta2+ddot(n,ll(i,1),n,ll(1,i),1) 10 continue return end subroutine ehg169(d,vc,nc,ncmax,nv,nvmax,v,a,xi,c,hi,lo) integer d,vc,nc,ncmax,nv,nvmax integer a(ncmax), c(vc,ncmax), hi(ncmax), lo(ncmax) DOUBLE PRECISION v(nvmax,d),xi(ncmax) integer novhit(1),i,j,k,mc,mv,p external ehg125,ehg182 integer ifloor external ifloor c as in bbox c remaining vertices do 3 i=2,vc-1 j=i-1 do 4 k=1,d v(i,k)=v(1+mod(j,2)*(vc-1),k) j=ifloor(DBLE(j)/2.D0) 4 continue 3 continue c as in ehg131 mc=1 mv=vc novhit(1)=-1 do 5 j=1,vc c(j,mc)=j 5 continue c as in rbuild p=1 c top of while loop 6 if(.not.(p.le.nc))goto 7 if(a(p).ne.0)then k=a(p) c left son mc=mc+1 lo(p)=mc c right son mc=mc+1 hi(p)=mc call ehg125(p,mv,v,novhit,nvmax,d,k,xi(p),2**(k-1),2**(d-k), + c(1,p),c(1,lo(p)),c(1,hi(p))) end if p=p+1 goto 6 c bottom of while loop 7 if(.not.(mc.eq.nc))then call ehg182(193) end if if(.not.(mv.eq.nv))then call ehg182(193) end if return end DOUBLE PRECISION function ehg176(z) c DOUBLE PRECISION z(*) c integer d,vc,nv,nc integer a(17), c(2,17) integer hi(17), lo(17) DOUBLE PRECISION v(10,1) DOUBLE PRECISION vval(0:1,10) DOUBLE PRECISION xi(17) double precision ehg128 external ehg128 data d,vc,nv,nc /1,2,10,17/ data a(1) /1/ data hi(1),lo(1),xi(1) /3,2,0.3705D0/ data c(1,1) /1/ data c(2,1) /2/ data a(2) /1/ data hi(2),lo(2),xi(2) /5,4,0.2017D0/ data c(1,2) /1/ data c(2,2) /3/ data a(3) /1/ data hi(3),lo(3),xi(3) /7,6,0.5591D0/ data c(1,3) /3/ data c(2,3) /2/ data a(4) /1/ data hi(4),lo(4),xi(4) /9,8,0.1204D0/ data c(1,4) /1/ data c(2,4) /4/ data a(5) /1/ data hi(5),lo(5),xi(5) /11,10,0.2815D0/ data c(1,5) /4/ data c(2,5) /3/ data a(6) /1/ data hi(6),lo(6),xi(6) /13,12,0.4536D0/ data c(1,6) /3/ data c(2,6) /5/ data a(7) /1/ data hi(7),lo(7),xi(7) /15,14,0.7132D0/ data c(1,7) /5/ data c(2,7) /2/ data a(8) /0/ data c(1,8) /1/ data c(2,8) /6/ data a(9) /0/ data c(1,9) /6/ data c(2,9) /4/ data a(10) /0/ data c(1,10) /4/ data c(2,10) /7/ data a(11) /0/ data c(1,11) /7/ data c(2,11) /3/ data a(12) /0/ data c(1,12) /3/ data c(2,12) /8/ data a(13) /0/ data c(1,13) /8/ data c(2,13) /5/ data a(14) /0/ data c(1,14) /5/ data c(2,14) /9/ data a(15) /1/ data hi(15),lo(15),xi(15) /17,16,0.8751D0/ data c(1,15) /9/ data c(2,15) /2/ data a(16) /0/ data c(1,16) /9/ data c(2,16) /10/ data a(17) /0/ data c(1,17) /10/ data c(2,17) /2/ data vval(0,1) /-9.0572D-2/ data v(1,1) /-5.D-3/ data vval(1,1) /4.4844D0/ data vval(0,2) /-1.0856D-2/ data v(2,1) /1.005D0/ data vval(1,2) /-0.7736D0/ data vval(0,3) /-5.3718D-2/ data v(3,1) /0.3705D0/ data vval(1,3) /-0.3495D0/ data vval(0,4) /2.6152D-2/ data v(4,1) /0.2017D0/ data vval(1,4) /-0.7286D0/ data vval(0,5) /-5.8387D-2/ data v(5,1) /0.5591D0/ data vval(1,5) /0.1611D0/ data vval(0,6) /9.5807D-2/ data v(6,1) /0.1204D0/ data vval(1,6) /-0.7978D0/ data vval(0,7) /-3.1926D-2/ data v(7,1) /0.2815D0/ data vval(1,7) /-0.4457D0/ data vval(0,8) /-6.4170D-2/ data v(8,1) /0.4536D0/ data vval(1,8) /3.2813D-2/ data vval(0,9) /-2.0636D-2/ data v(9,1) /0.7132D0/ data vval(1,9) /0.3350D0/ data vval(0,10) /4.0172D-2/ data v(10,1) /0.8751D0/ data vval(1,10) /-4.1032D-2/ ehg176=ehg128(z,d,nc,vc,a,xi,lo,hi,c,v,nv,vval) end subroutine lowesa(trl,n,d,tau,nsing,delta1,delta2) integer n,d,tau,nsing double precision trl, delta1,delta2 integer dka,dkb double precision alpha,d1a,d1b,d2a,d2b external ehg141 call ehg141(trl,n,1,tau,d,nsing,dka,d1a,d2a) call ehg141(trl,n,2,tau,d,nsing,dkb,d1b,d2b) alpha=dble(tau-dka)/dble(dkb-dka) delta1=(1-alpha)*d1a+alpha*d1b delta2=(1-alpha)*d2a+alpha*d2b return end subroutine ehg191(m,z,l,d,n,nf,nv,ncmax,vc,a,xi,lo,hi,c,v,nvmax, + vval2,lf,lq) c Args integer m,d,n,nf,nv,ncmax,nvmax,vc double precision z(m,d), l(m,n), xi(ncmax), v(nvmax,d), + vval2(0:d,nvmax), lf(0:d,nvmax,nf) integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),lo(ncmax),hi(ncmax) c Var integer lq1,execnt,i,i1,i2,j,p double precision zi(8) double precision ehg128 external ehg128 save execnt data execnt /0/ execnt=execnt+1 do 3 j=1,n do 4 i2=1,nv do 5 i1=0,d vval2(i1,i2)=0 5 continue 4 continue do 6 i=1,nv c linear search for i in Lq lq1=lq(i,1) lq(i,1)=j p=nf c top of while loop 7 if(.not.(lq(i,p).ne.j))goto 8 p=p-1 goto 7 c bottom of while loop 8 lq(i,1)=lq1 if(lq(i,p).eq.j)then do 9 i1=0,d vval2(i1,i)=lf(i1,i,p) 9 continue end if 6 continue do 10 i=1,m do 11 i1=1,d zi(i1)=z(i,i1) 11 continue l(i,j)=ehg128(zi,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax,vval2) 10 continue 3 continue return end subroutine ehg196(tau,d,f,trl) integer d,dka,dkb,execnt,tau double precision alpha,f,trl,trla,trlb external ehg197 save execnt data execnt /0/ execnt=execnt+1 call ehg197(1,tau,d,f,dka,trla) call ehg197(2,tau,d,f,dkb,trlb) alpha=dble(tau-dka)/dble(dkb-dka) trl=(1-alpha)*trla+alpha*trlb return end subroutine ehg197(deg,tau,d,f,dk,trl) integer deg,tau,d,dk double precision f, trl double precision g1 dk = 0 if(deg.eq.1) dk=d+1 if(deg.eq.2) dk=dble((d+2)*(d+1))/2.d0 g1 = (-0.08125d0*d+0.13d0)*d+1.05d0 trl = dk*(1+max(0.d0,(g1-f)/f)) return end subroutine ehg192(y,d,n,nf,nv,nvmax,vval,lf,lq) integer d,i,i1,i2,j,n,nf,nv,nvmax integer lq(nvmax,nf) DOUBLE PRECISION i3 DOUBLE PRECISION lf(0:d,nvmax,nf),vval(0:d,nvmax),y(n) do 3 i2=1,nv do 4 i1=0,d vval(i1,i2)=0 4 continue 3 continue do 5 i=1,nv do 6 j=1,nf i3=y(lq(i,j)) do 7 i1=0,d vval(i1,i)=vval(i1,i)+i3*lf(i1,i,j) 7 continue 6 continue 5 continue return end DOUBLE PRECISION function ehg128(z,d,ncmax,vc,a,xi,lo,hi,c,v, + nvmax,vval) c implicit none c Args integer d,ncmax,nvmax,vc integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax) DOUBLE PRECISION z(d),xi(ncmax),v(nvmax,d), vval(0:d,nvmax) c Vars logical i2,i3,i4,i5,i6,i7,i8,i9,i10 integer execnt,i,i1,i11,i12,ig,ii,j,lg,ll,m,nt,ur integer t(20) DOUBLE PRECISION ge,gn,gs,gw,gpe,gpn,gps,gpw,h,phi0,phi1, + psi0,psi1,s,sew,sns,v0,v1,xibar DOUBLE PRECISION g(0:8,256),g0(0:8),g1(0:8) external ehg182,ehg184 save execnt data execnt /0/ execnt=execnt+1 c locate enclosing cell nt=1 t(nt)=1 j=1 c top of while loop 3 if(.not.(a(j).ne.0))goto 4 nt=nt+1 if(z(a(j)).lt.xi(j))then i1=lo(j) else i1=hi(j) end if t(nt)=i1 if(.not.(nt.lt.20))then call ehg182(181) end if j=t(nt) goto 3 c bottom of while loop 4 continue c tensor do 5 i12=1,vc do 6 i11=0,d g(i11,i12)=vval(i11,c(i12,j)) 6 continue 5 continue lg=vc ll=c(1,j) ur=c(vc,j) do 7 i=d,1,-1 h=(z(i)-v(ll,i))/(v(ur,i)-v(ll,i)) if(h.lt.-.001D0)then call ehg184('eval ',z(1),d,1) call ehg184('lowerlimit ',v(ll,1),d,nvmax) else if(1.001D0.lt.h)then call ehg184('eval ',z(1),d,1) call ehg184('upperlimit ',v(ur,1),d,nvmax) end if end if if(-.001D0.le.h)then i2=(h.le.1.001D0) else i2=.false. end if if(.not.i2)then call ehg182(122) end if lg=DBLE(lg)/2.D0 do 8 ig=1,lg c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) g(0,ig)=phi0*g(0,ig) + phi1*g(0,ig+lg) + + (psi0*g(i,ig)+psi1*g(i,ig+lg)) * (v(ur,i)-v(ll,i)) do 9 ii=1,i-1 g(ii,ig)=phi0*g(ii,ig)+phi1*g(ii,ig+lg) 9 continue 8 continue 7 continue s=g(0,1) c blending if(d.eq.2)then c ----- North ----- v0=v(ll,1) v1=v(ur,1) do 10 i11=0,d g0(i11)=vval(i11,c(3,j)) 10 continue do 11 i11=0,d g1(i11)=vval(i11,c(4,j)) 11 continue xibar=v(ur,2) m=nt-1 c top of while loop 12 if(m.eq.0)then i4=.true. else if(a(t(m)).eq.2)then i3=(xi(t(m)).eq.xibar) else i3=.false. end if i4=i3 end if if(.not.(.not.i4))goto 13 m=m-1 c voidp junk goto 12 c bottom of while loop 13 if(m.ge.1)then m=hi(t(m)) c top of while loop 14 if(.not.(a(m).ne.0))goto 15 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 14 c bottom of while loop 15 if(v0.lt.v(c(1,m),1))then v0=v(c(1,m),1) do 16 i11=0,d g0(i11)=vval(i11,c(1,m)) 16 continue end if if(v(c(2,m),1).lt.v1)then v1=v(c(2,m),1) do 17 i11=0,d g1(i11)=vval(i11,c(2,m)) 17 continue end if end if h=(z(1)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) gn=phi0*g0(0)+phi1*g1(0)+(psi0*g0(1)+psi1*g1(1))*(v1-v0) gpn=phi0*g0(2)+phi1*g1(2) c ----- South ----- v0=v(ll,1) v1=v(ur,1) do 18 i11=0,d g0(i11)=vval(i11,c(1,j)) 18 continue do 19 i11=0,d g1(i11)=vval(i11,c(2,j)) 19 continue xibar=v(ll,2) m=nt-1 c top of while loop 20 if(m.eq.0)then i6=.true. else if(a(t(m)).eq.2)then i5=(xi(t(m)).eq.xibar) else i5=.false. end if i6=i5 end if if(.not.(.not.i6))goto 21 m=m-1 c voidp junk goto 20 c bottom of while loop 21 if(m.ge.1)then m=lo(t(m)) c top of while loop 22 if(.not.(a(m).ne.0))goto 23 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 22 c bottom of while loop 23 if(v0.lt.v(c(3,m),1))then v0=v(c(3,m),1) do 24 i11=0,d g0(i11)=vval(i11,c(3,m)) 24 continue end if if(v(c(4,m),1).lt.v1)then v1=v(c(4,m),1) do 25 i11=0,d g1(i11)=vval(i11,c(4,m)) 25 continue end if end if h=(z(1)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) gs=phi0*g0(0)+phi1*g1(0)+(psi0*g0(1)+psi1*g1(1))*(v1-v0) gps=phi0*g0(2)+phi1*g1(2) c ----- East ----- v0=v(ll,2) v1=v(ur,2) do 26 i11=0,d g0(i11)=vval(i11,c(2,j)) 26 continue do 27 i11=0,d g1(i11)=vval(i11,c(4,j)) 27 continue xibar=v(ur,1) m=nt-1 c top of while loop 28 if(m.eq.0)then i8=.true. else if(a(t(m)).eq.1)then i7=(xi(t(m)).eq.xibar) else i7=.false. end if i8=i7 end if if(.not.(.not.i8))goto 29 m=m-1 c voidp junk goto 28 c bottom of while loop 29 if(m.ge.1)then m=hi(t(m)) c top of while loop 30 if(.not.(a(m).ne.0))goto 31 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 30 c bottom of while loop 31 if(v0.lt.v(c(1,m),2))then v0=v(c(1,m),2) do 32 i11=0,d g0(i11)=vval(i11,c(1,m)) 32 continue end if if(v(c(3,m),2).lt.v1)then v1=v(c(3,m),2) do 33 i11=0,d g1(i11)=vval(i11,c(3,m)) 33 continue end if end if h=(z(2)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) ge=phi0*g0(0)+phi1*g1(0)+(psi0*g0(2)+psi1*g1(2))*(v1-v0) gpe=phi0*g0(1)+phi1*g1(1) c ----- West ----- v0=v(ll,2) v1=v(ur,2) do 34 i11=0,d g0(i11)=vval(i11,c(1,j)) 34 continue do 35 i11=0,d g1(i11)=vval(i11,c(3,j)) 35 continue xibar=v(ll,1) m=nt-1 c top of while loop 36 if(m.eq.0)then i10=.true. else if(a(t(m)).eq.1)then i9=(xi(t(m)).eq.xibar) else i9=.false. end if i10=i9 end if if(.not.(.not.i10))goto 37 m=m-1 c voidp junk goto 36 c bottom of while loop 37 if(m.ge.1)then m=lo(t(m)) c top of while loop 38 if(.not.(a(m).ne.0))goto 39 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 38 c bottom of while loop 39 if(v0.lt.v(c(2,m),2))then v0=v(c(2,m),2) do 40 i11=0,d g0(i11)=vval(i11,c(2,m)) 40 continue end if if(v(c(4,m),2).lt.v1)then v1=v(c(4,m),2) do 41 i11=0,d g1(i11)=vval(i11,c(4,m)) 41 continue end if end if h=(z(2)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) gw=phi0*g0(0)+phi1*g1(0)+(psi0*g0(2)+psi1*g1(2))*(v1-v0) gpw=phi0*g0(1)+phi1*g1(1) c NS h=(z(2)-v(ll,2))/(v(ur,2)-v(ll,2)) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) sns=phi0*gs+phi1*gn+(psi0*gps+psi1*gpn)*(v(ur,2)-v(ll,2)) c EW h=(z(1)-v(ll,1))/(v(ur,1)-v(ll,1)) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) sew=phi0*gw+phi1*ge+(psi0*gpw+psi1*gpe)*(v(ur,1)-v(ll,1)) s=(sns+sew)-s end if ehg128=s return end integer function ifloor(x) DOUBLE PRECISION x ifloor=x if(ifloor.gt.x) ifloor=ifloor-1 end c DSIGN is unused, causes conflicts on some platforms c DOUBLE PRECISION function DSIGN(a1,a2) c DOUBLE PRECISION a1, a2 c DSIGN=DABS(a1) c if(a2.ge.0)DSIGN=-DSIGN c end c ehg136() is the workhorse of lowesf(.) c n = number of observations c m = number of x values at which to evaluate c f = span c nf = min(n, floor(f * n)) subroutine ehg136(u,lm,m,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b, + od,o,ihat,w,rcond,sing,dd,tdeg,cdeg,s) integer identi,d,dd,execnt,i,i1,ihat,info,j,k,kernel,l,lm,m,n,nf, + od,sing,tdeg integer cdeg(8),psi(n) double precision f,i2,rcond,scale,tol double precision o(m,n),sigma(15),e(15,15),g(15,15),b(nf,k), $ dist(n),eta(nf),dgamma(15),q(8),qraux(15),rw(n),s(0:od,m), $ u(lm,d),w(nf),work(15),x(n,d),y(n) external ehg127,ehg182,dqrsl double precision ddot external ddot save execnt data execnt /0/ c V -> g c U -> e c Identity -> identi c L -> o c X -> b execnt=execnt+1 if(k .gt. nf-1) call ehg182(104) if(k .gt. 15) call ehg182(105) do 3 identi=1,n psi(identi)=identi 3 continue do 4 l=1,m do 5 i1=1,d q(i1)=u(l,i1) 5 continue call ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w, + rcond,sing,sigma,e,g,dgamma,qraux,work,tol,dd,tdeg,cdeg, + s(0,l)) if(ihat.eq.1)then c $L sub {l,l} = c V sub {1,:} SIGMA sup {+} U sup T c (Q sup T W e sub i )$ if(.not.(m.eq.n))then call ehg182(123) end if c find $i$ such that $l = psi sub i$ i=1 c top of while loop 6 if(.not.(l.ne.psi(i)))goto 7 i=i+1 if(.not.(i.lt.nf))then call ehg182(123) goto 7 end if goto 6 c bottom of while loop 7 do 8 i1=1,nf eta(i1)=0 8 continue eta(i)=w(i) c $eta = Q sup T W e sub i$ call dqrsl(b,nf,nf,k,qraux,eta,eta,eta,eta,eta,eta,1000, + info) c $gamma = U sup T eta sub {1:k}$ do 9 i1=1,k dgamma(i1)=0 9 continue do 10 j=1,k i2=eta(j) do 11 i1=1,k dgamma(i1)=dgamma(i1)+i2*e(j,i1) 11 continue 10 continue c $gamma = SIGMA sup {+} gamma$ do 12 j=1,k if(tol.lt.sigma(j))then dgamma(j)=dgamma(j)/sigma(j) else dgamma(j)=0.d0 end if 12 continue c voidp junk c voidp junk o(l,1)=ddot(k,g(1,1),15,dgamma,1) else if(ihat.eq.2)then c $L sub {l,:} = c V sub {1,:} SIGMA sup {+} c ( U sup T Q sup T ) W $ do 13 i1=1,n o(l,i1)=0 13 continue do 14 j=1,k do 15 i1=1,nf eta(i1)=0 15 continue do 16 i1=1,k eta(i1)=e(i1,j) 16 continue call dqrsl(b,nf,nf,k,qraux,eta,eta,work,work,work,work + ,10000,info) if(tol.lt.sigma(j))then scale=1.d0/sigma(j) else scale=0.d0 end if do 17 i1=1,nf eta(i1)=eta(i1)*(scale*w(i1)) 17 continue do 18 i=1,nf o(l,psi(i))=o(l,psi(i))+g(1,j)*eta(i) 18 continue 14 continue end if end if 4 continue return end c called from lowesb() ... compute fit ..?..?... c somewhat similar to ehg136 subroutine ehg139(v,nvmax,nv,n,d,nf,f,x,pi,psi,y,rw,trl,kernel,k, + dist,phi,eta,b,od,w,diagl,vval2,ncmax,vc,a,xi,lo,hi,c,vhit, + rcond,sing,dd,tdeg,cdeg,lq,lf,setlf,s) logical setlf integer identi,d,dd,execnt,i,i2,i3,i5,i6,ii,ileaf,info,j,k,kernel, + l,n,ncmax,nf,nleaf,nv,nvmax,od,sing,tdeg,vc integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),cdeg(8),hi(ncmax), + leaf(256),lo(ncmax),pi(n),psi(n),vhit(nvmax) DOUBLE PRECISION f,i1,i4,i7,rcond,scale,term,tol,trl DOUBLE PRECISION lf(0:d,nvmax,nf),sigma(15),u(15,15),e(15,15), + b(nf,k),diagl(n),dist(n),eta(nf),DGAMMA(15),q(8),qraux(15), + rw(n),s(0:od,nv),v(nvmax,d),vval2(0:d,nv),w(nf),work(15), + x(n,d),xi(ncmax),y(n),z(8) DOUBLE PRECISION phi(n) external ehg127,ehg182,DQRSL,ehg137 DOUBLE PRECISION ehg128 external ehg128 DOUBLE PRECISION DDOT external DDOT save execnt data execnt /0/ c V -> e c Identity -> identi c X -> b execnt=execnt+1 c l2fit with trace(L) if(k .gt. nf-1) call ehg182(104) if(k .gt. 15) call ehg182(105) if(trl.ne.0)then do 3 i5=1,n diagl(i5)=0 3 continue do 4 i6=1,nv do 5 i5=0,d vval2(i5,i6)=0 5 continue 4 continue end if do 6 identi=1,n psi(identi)=identi 6 continue do 7 l=1,nv do 8 i5=1,d q(i5)=v(l,i5) 8 continue call ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w, + rcond,sing,sigma,u,e,DGAMMA,qraux,work,tol,dd,tdeg,cdeg, + s(0,l)) if(trl.ne.0)then c invert $psi$ do 9 i5=1,n phi(i5)=0 9 continue do 10 i=1,nf phi(psi(i))=i 10 continue do 11 i5=1,d z(i5)=v(l,i5) 11 continue call ehg137(z,vhit(l),leaf,nleaf,d,nv,nvmax,ncmax,a,xi, + lo,hi) do 12 ileaf=1,nleaf do 13 ii=lo(leaf(ileaf)),hi(leaf(ileaf)) i=phi(pi(ii)) if(i.ne.0)then if(.not.(psi(i).eq.pi(ii)))then call ehg182(194) end if do 14 i5=1,nf eta(i5)=0 14 continue eta(i)=w(i) c $eta = Q sup T W e sub i$ call DQRSL(b,nf,nf,k,qraux,eta,work,eta,eta,work, + work,1000,info) do 15 j=1,k if(tol.lt.sigma(j))then i4=DDOT(k,u(1,j),1,eta,1)/sigma(j) else i4=0.D0 end if DGAMMA(j)=i4 15 continue do 16 j=1,d+1 vval2(j-1,l)=DDOT(k,e(j,1),15,DGAMMA,1) 16 continue do 17 i5=1,d z(i5)=x(pi(ii),i5) 17 continue term=ehg128(z,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax, + vval2) diagl(pi(ii))=diagl(pi(ii))+term do 18 i5=0,d vval2(i5,l)=0 18 continue end if 13 continue 12 continue end if if(setlf)then c $Lf sub {:,l,:} = V SIGMA sup {+} U sup T Q sup T W$ if(.not.(k.ge.d+1))then call ehg182(196) end if do 19 i5=1,nf lq(l,i5)=psi(i5) 19 continue do 20 i6=1,nf do 21 i5=0,d lf(i5,l,i6)=0 21 continue 20 continue do 22 j=1,k do 23 i5=1,nf eta(i5)=0 23 continue do 24 i5=1,k eta(i5)=u(i5,j) 24 continue call DQRSL(b,nf,nf,k,qraux,eta,eta,work,work,work,work, + 10000,info) if(tol.lt.sigma(j))then scale=1.D0/sigma(j) else scale=0.D0 end if do 25 i5=1,nf eta(i5)=eta(i5)*(scale*w(i5)) 25 continue do 26 i=1,nf i7=eta(i) do 27 i5=0,d lf(i5,l,i)=lf(i5,l,i)+e(1+i5,j)*i7 27 continue 26 continue 22 continue end if 7 continue if(trl.ne.0)then if(n.le.0)then trl=0.D0 else i3=n i1=diagl(i3) do 28 i2=i3-1,1,-1 i1=diagl(i2)+i1 28 continue trl=i1 end if end if return end subroutine lowesb(xx,yy,ww,diagl,infl,iv,liv,lv,wv) logical infl integer liv, lv integer iv(*) DOUBLE PRECISION xx(*),yy(*),ww(*),diagl(*),wv(*) c Var DOUBLE PRECISION trl logical setlf integer execnt integer ifloor external ifloor external ehg131,ehg182,ehg183 save execnt data execnt /0/ execnt=execnt+1 if(.not.(iv(28).ne.173))then call ehg182(174) end if if(iv(28).ne.172)then if(.not.(iv(28).eq.171))then call ehg182(171) end if end if iv(28)=173 if(infl)then trl=1.D0 else trl=0.D0 end if setlf=(iv(27).ne.iv(25)) call ehg131(xx,yy,ww,trl,diagl,iv(20),iv(29),iv(3),iv(2),iv(5), + iv(17),iv(4),iv(6),iv(14),iv(19),wv(1),iv(iv(7)),iv(iv(8)), + iv(iv(9)),iv(iv(10)),iv(iv(22)),iv(iv(27)),wv(iv(11)), + iv(iv(23)),wv(iv(13)),wv(iv(12)),wv(iv(15)),wv(iv(16)), + wv(iv(18)),ifloor(iv(3)*wv(2)),wv(3),wv(iv(26)),wv(iv(24)), + wv(4),iv(30),iv(33),iv(32),iv(41),iv(iv(25)),wv(iv(34)), + setlf) if(iv(14).lt.iv(6)+DBLE(iv(4))/2.D0)then call ehg183('k-d tree limited by memory; nvmax=', + iv(14),1,1) else if(iv(17).lt.iv(5)+2)then call ehg183('k-d tree limited by memory. ncmax=', + iv(17),1,1) end if end if return end c lowesd() : Initialize iv(*) and v(1:4) c ------ called only by loess_workspace() in ./loessc.c subroutine lowesd(versio,iv,liv,lv,v,d,n,f,ideg,nvmax,setlf) integer versio,liv,lv,d,n,ideg,nvmax integer iv(liv) logical setlf double precision f, v(lv) integer bound,execnt,i,i1,i2,j,ncmax,nf,vc external ehg182 integer ifloor external ifloor save execnt data execnt /0/ c c unnecessary initialization of i1 to keep g77 -Wall happy c i1 = 0 c version -> versio execnt=execnt+1 if(.not.(versio.eq.106))then call ehg182(100) end if iv(28)=171 iv(2)=d iv(3)=n vc=2**d iv(4)=vc if(.not.(0.lt.f))then call ehg182(120) end if nf=min(n,ifloor(n*f)) iv(19)=nf iv(20)=1 if(ideg.eq.0)then i1=1 else if(ideg.eq.1)then i1=d+1 else if(ideg.eq.2)then i1=dble((d+2)*(d+1))/2.d0 end if end if end if iv(29)=i1 iv(21)=1 iv(14)=nvmax ncmax=nvmax iv(17)=ncmax iv(30)=0 iv(32)=ideg if(.not.(ideg.ge.0))then call ehg182(195) end if if(.not.(ideg.le.2))then call ehg182(195) end if iv(33)=d do 3 i2=41,49 iv(i2)=ideg 3 continue iv(7)=50 iv(8)=iv(7)+ncmax iv(9)=iv(8)+vc*ncmax iv(10)=iv(9)+ncmax iv(22)=iv(10)+ncmax c initialize permutation j=iv(22)-1 do 4 i=1,n iv(j+i)=i 4 continue iv(23)=iv(22)+n iv(25)=iv(23)+nvmax if(setlf)then iv(27)=iv(25)+nvmax*nf else iv(27)=iv(25) end if bound=iv(27)+n if(.not.(bound-1.le.liv))then call ehg182(102) end if iv(11)=50 iv(13)=iv(11)+nvmax*d iv(12)=iv(13)+(d+1)*nvmax iv(15)=iv(12)+ncmax iv(16)=iv(15)+n iv(18)=iv(16)+nf iv(24)=iv(18)+iv(29)*nf iv(34)=iv(24)+(d+1)*nvmax if(setlf)then iv(26)=iv(34)+(d+1)*nvmax*nf else iv(26)=iv(34) end if bound=iv(26)+nf if(.not.(bound-1.le.lv))then call ehg182(103) end if v(1)=f v(2)=0.05d0 v(3)=0.d0 v(4)=1.d0 return end subroutine lowese(iv,liv,lv,wv,m,z,s) integer liv,lv,m integer iv(*) double precision s(m),wv(*),z(m,1) integer execnt external ehg133,ehg182 save execnt data execnt /0/ execnt=execnt+1 if(.not.(iv(28).ne.172))then call ehg182(172) end if if(.not.(iv(28).eq.173))then call ehg182(173) end if call ehg133(iv(3),iv(2),iv(4),iv(14),iv(5),iv(17),iv(iv(7)),iv(iv( +8)),iv(iv(9)),iv(iv(10)),wv(iv(11)),wv(iv(13)),wv(iv(12)),m,z,s) return end c "direct" (non-"interpolate") fit aka predict() : subroutine lowesf(xx,yy,ww,iv,liv,lv,wv,m,z,l,ihat,s) integer liv,lv,m,ihat c m = number of x values at which to evaluate integer iv(*) double precision xx(*),yy(*),ww(*),wv(*),z(m,1),l(m,*),s(m) logical i1 integer execnt external ehg182,ehg136 save execnt data execnt /0/ execnt=execnt+1 if(171.le.iv(28))then i1=(iv(28).le.174) else i1=.false. end if if(.not.i1)then call ehg182(171) end if iv(28)=172 if(.not.(iv(14).ge.iv(19)))then call ehg182(186) end if c do the work; in ehg136() give the argument names as they are there: c ehg136(u,lm,m, n, d, nf, f, x, psi, y ,rw, call ehg136(z,m,m,iv(3),iv(2),iv(19),wv(1),xx,iv(iv(22)),yy,ww, c kernel, k, dist, eta, b, od,o,ihat, + iv(20),iv(29),wv(iv(15)),wv(iv(16)),wv(iv(18)),0,l,ihat, c w, rcond,sing, dd, tdeg,cdeg, s) + wv(iv(26)),wv(4),iv(30),iv(33),iv(32),iv(41),s) return end subroutine lowesl(iv,liv,lv,wv,m,z,l) integer liv,lv,m integer iv(*) double precision l(m,*),wv(*),z(m,1) integer execnt external ehg182,ehg191 save execnt data execnt /0/ execnt=execnt+1 if(.not.(iv(28).ne.172))then call ehg182(172) end if if(.not.(iv(28).eq.173))then call ehg182(173) end if if(.not.(iv(26).ne.iv(34)))then call ehg182(175) end if call ehg191(m,z,l,iv(2),iv(3),iv(19),iv(6),iv(17),iv(4),iv(iv(7)), + wv(iv(12)),iv(iv(10)),iv(iv(9)),iv(iv(8)),wv(iv(11)),iv(14), + wv(iv(24)),wv(iv(34)),iv(iv(25))) return end subroutine lowesr(yy,iv,liv,lv,wv) integer liv,lv integer iv(*) DOUBLE PRECISION yy(*),wv(*) integer execnt external ehg182,ehg192 save execnt data execnt /0/ execnt=execnt+1 if(.not.(iv(28).ne.172))then call ehg182(172) end if if(.not.(iv(28).eq.173))then call ehg182(173) end if call ehg192(yy,iv(2),iv(3),iv(19),iv(6),iv(14),wv(iv(13)), + wv(iv(34)),iv(iv(25))) return end subroutine lowesw(res,n,rw,pi) c Tranliterated from Devlin's ratfor c implicit none c Args integer n double precision res(n),rw(n) integer pi(n) c Var integer identi,i,i1,nh double precision cmad,rsmall integer ifloor double precision d1mach external ehg106 external ifloor external d1mach c Identity -> identi c find median of absolute residuals do 3 i1=1,n rw(i1)=dabs(res(i1)) 3 continue do 4 identi=1,n pi(identi)=identi 4 continue nh=ifloor(dble(n)/2.d0)+1 c partial sort to find 6*mad call ehg106(1,n,nh,1,rw,pi,n) if((n-nh)+1.lt.nh)then call ehg106(1,nh-1,nh-1,1,rw,pi,n) cmad=3*(rw(pi(nh))+rw(pi(nh-1))) else cmad=6*rw(pi(nh)) end if rsmall=d1mach(1) if(cmad.lt.rsmall)then do 5 i1=1,n rw(i1)=1 5 continue else do 6 i=1,n if(cmad*0.999d0.lt.rw(i))then rw(i)=0 else if(cmad*0.001d0.lt.rw(i))then rw(i)=(1-(rw(i)/cmad)**2)**2 else rw(i)=1 end if end if 6 continue end if return end subroutine lowesp(n,y,yhat,pwgts,rwgts,pi,ytilde) integer n integer pi(n) double precision y(n),yhat(n),pwgts(n),rwgts(n),ytilde(n) c Var double precision c,i1,i4,mad integer identi,execnt,i2,i3,i5,m external ehg106 integer ifloor external ifloor save execnt data execnt /0/ c Identity -> identi execnt=execnt+1 c median absolute deviation do 3 i5=1,n ytilde(i5)=dabs(y(i5)-yhat(i5))*dsqrt(pwgts(i5)) 3 continue do 4 identi=1,n pi(identi)=identi 4 continue m=ifloor(dble(n)/2.d0)+1 call ehg106(1,n,m,1,ytilde,pi,n) if((n-m)+1.lt.m)then call ehg106(1,m-1,m-1,1,ytilde,pi,n) mad=(ytilde(pi(m-1))+ytilde(pi(m)))/2 else mad=ytilde(pi(m)) end if c magic constant c=(6*mad)**2/5 do 5 i5=1,n ytilde(i5)=1-((y(i5)-yhat(i5))**2*pwgts(i5))/c 5 continue do 6 i5=1,n ytilde(i5)=ytilde(i5)*dsqrt(rwgts(i5)) 6 continue if(n.le.0)then i4=0.d0 else i3=n i1=ytilde(i3) do 7 i2=i3-1,1,-1 i1=ytilde(i2)+i1 7 continue i4=i1 end if c=n/i4 c pseudovalues do 8 i5=1,n ytilde(i5)=yhat(i5)+(c*rwgts(i5))*(y(i5)-yhat(i5)) 8 continue return end subroutine ehg124(ll,uu,d,n,nv,nc,ncmax,vc,x,pi,a,xi,lo,hi,c,v, + vhit,nvmax,fc,fd,dd) integer ll,uu,d,n,nv,nc,ncmax,vc,nvmax,fc,dd integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax),pi(n),vhit(nvmax) DOUBLE PRECISION fd, v(nvmax,d),x(n,d),xi(ncmax) logical i1,i2,i3,leaf integer execnt,i4,inorm2,k,l,m,p,u DOUBLE PRECISION diam,diag(8),sigma(8) external ehg125,ehg106,ehg129 integer IDAMAX external IDAMAX save execnt data execnt /0/ execnt=execnt+1 p=1 l=ll u=uu lo(p)=l hi(p)=u c top of while loop 3 if(.not.(p.le.nc))goto 4 do 5 i4=1,dd diag(i4)=v(c(vc,p),i4)-v(c(1,p),i4) 5 continue diam=0 do 6 inorm2=1,dd diam=diam+diag(inorm2)**2 6 continue diam=DSQRT(diam) if((u-l)+1.le.fc)then i1=.true. else i1=(diam.le.fd) end if if(i1)then leaf=.true. else if(ncmax.lt.nc+2)then i2=.true. else i2=(nvmax.lt.nv+DBLE(vc)/2.D0) end if leaf=i2 end if if(.not.leaf)then call ehg129(l,u,dd,x,pi,n,sigma) k=IDAMAX(dd,sigma,1) m=DBLE(l+u)/2.D0 call ehg106(l,u,m,1,x(1,k),pi,n) c all ties go with hi son c top of while loop 7 if(1.lt.m)then i3=(x(pi(m-1),k).eq.x(pi(m),k)) else i3=.false. end if if(.not.(i3))goto 8 m=m-1 goto 7 c bottom of while loop 8 if(v(c(1,p),k).eq.x(pi(m),k))then leaf=.true. else leaf=(v(c(vc,p),k).eq.x(pi(m),k)) end if end if if(leaf)then a(p)=0 else a(p)=k xi(p)=x(pi(m),k) c left son nc=nc+1 lo(p)=nc lo(nc)=l hi(nc)=m c right son nc=nc+1 hi(p)=nc lo(nc)=m+1 hi(nc)=u call ehg125(p,nv,v,vhit,nvmax,d,k,xi(p),2**(k-1),2**(d-k), + c(1,p),c(1,lo(p)),c(1,hi(p))) end if p=p+1 l=lo(p) u=hi(p) goto 3 c bottom of while loop 4 return end subroutine ehg129(l,u,d,x,pi,n,sigma) integer d,execnt,i,k,l,n,u integer pi(n) DOUBLE PRECISION machin,alpha,beta,t DOUBLE PRECISION sigma(d),x(n,d) DOUBLE PRECISION D1MACH external D1MACH save machin,execnt data execnt /0/ c MachInf -> machin execnt=execnt+1 if(execnt.eq.1)then c initialize d1mach(2) === DBL_MAX: machin=D1MACH(2) end if do 3 k=1,d alpha=machin beta=-machin do 4 i=l,u t=x(pi(i),k) alpha=min(alpha,x(pi(i),k)) beta=max(beta,t) 4 continue sigma(k)=beta-alpha 3 continue return end c {called only from ehg127} purpose...?... subroutine ehg137(z,kappa,leaf,nleaf,d,nv,nvmax,ncmax,a,xi,lo,hi) integer kappa,d,nv,nvmax,ncmax,nleaf integer leaf(256),a(ncmax),hi(ncmax),lo(ncmax),pstack(20) DOUBLE PRECISION z(d),xi(ncmax) integer execnt,p,stackt external ehg182 save execnt data execnt /0/ c stacktop -> stackt execnt=execnt+1 c find leaf cells affected by $z$ stackt=0 p=1 nleaf=0 c top of while loop 3 if(.not.(0.lt.p))goto 4 if(a(p).eq.0)then c leaf nleaf=nleaf+1 leaf(nleaf)=p c Pop if(stackt.ge.1)then p=pstack(stackt) else p=0 end if stackt=max(0,stackt-1) else if(z(a(p)).eq.xi(p))then c Push stackt=stackt+1 if(.not.(stackt.le.20))then call ehg182(187) end if pstack(stackt)=hi(p) p=lo(p) else if(z(a(p)).lt.xi(p))then p=lo(p) else p=hi(p) end if end if end if goto 3 c bottom of while loop 4 if(.not.(nleaf.le.256))then call ehg182(185) end if return end C-- For Error messaging, call the "a" routines at the bottom of ./loessc.c : subroutine ehg183(s, i, n, inc) character s*(*) integer i, n, inc call ehg183a(s, len(s), i, n, inc) end subroutine ehg184(s, x, n, inc) character s*(*) double precision x integer n, inc call ehg184a(s, len(s), x, n, inc) end gam/src/linear.f0000644000176000001440000015205013507054071013263 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine dqrls(x,dx,pivot,qraux,y,dy,beta,res,qt,tol,scrtch,rank *) integer pivot(*),dx(2),dy(2),rank double precision x(*), qraux(*), y(*), beta(*),res(*),qt(*),tol(*) *, scrtch(*) integer n,p,q,kn,kp,k,info n=dx(1) p=dx(2) q=dy(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1)) kn=1 kp=1 if(rank.gt.0)then k=1 23002 if(.not.(k.le.q))goto 23004 call dqrsl(x,n,n,rank,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn), *scrtch,00110,info) kn = kn+n kp=kp+p 23003 k=k+1 goto 23002 23004 continue endif return end subroutine dqrsl1(qr,dq,qra,rank,y,k,qy,qb,job,info) double precision qr(*),qra(*),y(*),qy(*),qb(*) integer dq(2),job,k,rank integer n,kn,kb,j double precision ourqty(1), ourqy(1), ourb(1), ourrsd(1), ourxb(1) ourqty(1) = 0d0 ourqy(1) = 0d0 ourb(1) = 0d0 ourrsd(1) = 0d0 ourxb(1) = 0d0 n = dq(1) kn = 1 kb = 1 I23005=(job) goto 23005 23007 continue j=0 23008 if(.not.(j.lt.k))goto 23010 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),qy(kn),ourqty,ourb,ourrsd *,ourxb,job,info) kn = kn +n 23009 j = j+1 goto 23008 23010 continue goto 23006 23011 continue j=0 23012 if(.not.(j.lt.k))goto 23014 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd, *ourxb,job,info) kn = kn +n 23013 j = j+1 goto 23012 23014 continue goto 23006 23015 continue j=0 23016 if(.not.(j.lt.k))goto 23018 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),qb(kb),ourrs *d,ourxb,job,info) kn = kn +n kb = kb +rank 23017 j = j+1 goto 23016 23018 continue goto 23006 23019 continue j=0 23020 if(.not.(j.lt.k))goto 23022 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,qb(kn), *ourxb,job,info) kn = kn +n 23021 j = j+1 goto 23020 23022 continue goto 23006 23023 continue j=0 23024 if(.not.(j.lt.k))goto 23026 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd, *qb(kn),job,info) kn = kn +n 23025 j = j+1 goto 23024 23026 continue goto 23006 23027 continue info = -1 goto 23006 23005 continue if (I23005.eq.1)goto 23023 if (I23005.eq.10)goto 23019 if (I23005.eq.100)goto 23015 if (I23005.eq.1000)goto 23011 if (I23005.eq.10000)goto 23007 goto 23027 23006 continue return end subroutine dqr(x,dx,pivot,qraux,tol,scrtch,rank) integer pivot(*),dx(2),rank double precision x(*), qraux(*), tol(*), scrtch(*) integer n,p n=dx(1) p=dx(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1)) return end subroutine dqrdca(x,ldx,n,p,qraux,jpvt,work,rank,eps) integer ldx,n,p,rank integer jpvt(*) double precision x(ldx,*),qraux(*),work(*),eps integer j,jj,jp,l,lup,curpvt double precision dnrm2,tt double precision ddot,nrmxl,t,ww do23028 j=1,p qraux(j) = dnrm2(n,x(1,j),1) work(j) = qraux(j) work(j+p) = qraux(j) 23028 continue 23029 continue l=1 lup = min0(n,p) curpvt = p 23030 if(l.le.lup)then qraux(l) = 0.0d0 nrmxl = dnrm2(n-l+1,x(l,l),1) t = work(l+p) if(t .gt. 0.)then t = nrmxl/t endif if(t .lt. eps)then call dshift(x,ldx,n,l,curpvt) jp = jpvt(l) t=qraux(l) tt=work(l) ww = work(l+p) j=l+1 23036 if(.not.(j.le.curpvt))goto 23038 jj=j-1 jpvt(jj)=jpvt(j) qraux(jj)=qraux(j) work(jj)=work(j) work(jj+p) = work(j+p) 23037 j=j+1 goto 23036 23038 continue jpvt(curpvt)=jp qraux(curpvt)=t work(curpvt)=tt work(curpvt+p) = ww curpvt=curpvt-1 if(lup.gt.curpvt)then lup=curpvt endif else if(l.eq.n)then goto 23031 endif if(x(l,l).ne.0.0d0)then nrmxl = dsign(nrmxl,x(l,l)) endif call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1) x(l,l) = 1.0d0+x(l,l) j=l+1 23045 if(.not.(j.le.curpvt))goto 23047 t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) if(qraux(j).ne.0.0d0)then tt = 1.0d0-(dabs(x(l,j))/qraux(j))**2 tt = dmax1(tt,0.0d0) t = tt tt = 1.0d0+0.05d0*tt*(qraux(j)/work(j))**2 if(tt.ne.1.0d0)then qraux(j) = qraux(j)*dsqrt(t) else qraux(j) = dnrm2(n-l,x(l+1,j),1) work(j) = qraux(j) endif endif 23046 j=j+1 goto 23045 23047 continue qraux(l) = x(l,l) x(l,l) = -nrmxl l=l+1 endif goto 23030 endif 23031 continue rank = lup return end subroutine dchdc(a,lda,p,work,jpvt,job,info) integer lda,p,jpvt(p),job,info double precision a(lda,p),work(p) integer pu,pl,plp1,j,jp,jt,k,kb,km1,kp1,l,maxl double precision temp double precision maxdia logical swapk,negk pl = 1 pu = 0 info = p if(job.ne.0)then do23054 k = 1,p swapk = jpvt(k).gt.0 negk = jpvt(k).lt.0 jpvt(k) = k if(negk)then jpvt(k) = -jpvt(k) endif if(swapk)then if(k.ne.pl)then call dswap(pl-1,a(1,k),1,a(1,pl),1) temp = a(k,k) a(k,k) = a(pl,pl) a(pl,pl) = temp plp1 = pl+1 if(p.ge.plp1)then do23064 j = plp1,p if(j.lt.k)then temp = a(pl,j) a(pl,j) = a(j,k) a(j,k) = temp else if(j.ne.k)then temp = a(k,j) a(k,j) = a(pl,j) a(pl,j) = temp endif endif 23064 continue 23065 continue endif jpvt(k) = jpvt(pl) jpvt(pl) = k endif pl = pl+1 endif 23054 continue 23055 continue pu = p if(p.ge.pl)then do23072 kb = pl,p k = p-kb+pl if(jpvt(k).lt.0)then jpvt(k) = -jpvt(k) if(pu.ne.k)then call dswap(k-1,a(1,k),1,a(1,pu),1) temp = a(k,k) a(k,k) = a(pu,pu) a(pu,pu) = temp kp1 = k+1 if(p.ge.kp1)then do23080 j = kp1,p if(j.lt.pu)then temp = a(k,j) a(k,j) = a(j,pu) a(j,pu) = temp else if(j.ne.pu)then temp = a(k,j) a(k,j) = a(pu,j) a(pu,j) = temp endif endif 23080 continue 23081 continue endif jt = jpvt(k) jpvt(k) = jpvt(pu) jpvt(pu) = jt endif pu = pu-1 endif 23072 continue 23073 continue endif endif do23086 k = 1,p maxdia = a(k,k) kp1 = k+1 maxl = k if(k.ge.pl.and.k.lt.pu)then do23090 l = kp1,pu if(a(l,l).gt.maxdia)then maxdia = a(l,l) maxl = l endif 23090 continue 23091 continue endif if(maxdia.le.0.0d0)then go to 10 endif if(k.ne.maxl)then km1 = k-1 call dswap(km1,a(1,k),1,a(1,maxl),1) a(maxl,maxl) = a(k,k) a(k,k) = maxdia jp = jpvt(maxl) jpvt(maxl) = jpvt(k) jpvt(k) = jp endif work(k) = dsqrt(a(k,k)) a(k,k) = work(k) if(p.ge.kp1)then do23100 j = kp1,p if(k.ne.maxl)then if(j.lt.maxl)then temp = a(k,j) a(k,j) = a(j,maxl) a(j,maxl) = temp else if(j.ne.maxl)then temp = a(k,j) a(k,j) = a(maxl,j) a(maxl,j) = temp endif endif endif a(k,j) = a(k,j)/work(k) work(j) = a(k,j) temp = -a(k,j) call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1) 23100 continue 23101 continue endif 23086 continue 23087 continue return 10 info = k-1 return end double precision function epslon(x) double precision x double precision a,b,c,eps a = 4.0d0/3.0d0 23108 continue b = a-1.0d0 c = b+b+b eps = dabs(c-1.0d0) 23109 if(.not.(eps.ne.0.0d0))goto 23108 23110 continue epslon = eps*dabs(x) return end double precision function pythag(a,b) double precision a,b double precision p,r,s,t,u p = dmax1(dabs(a),dabs(b)) if(p.ne.0.0d0)then r = (dmin1(dabs(a),dabs(b))/p)**2 23113 continue t = 4.0d0+r if(t.eq.4.0d0)then goto 23115 endif s = r/t u = 1.0d0+2.0d0*s p = u*p r = (s/u)**2*r 23114 goto 23113 23115 continue endif pythag = p return end subroutine rg(nm,n,a,wr,wi,matz,z,iv1,fv1,ierr) integer n,nm,is1,is2,ierr,matz double precision a(nm,n),wr(n),wi(n),z(nm,n),fv1(n) integer iv1(n) if(n.gt.nm)then ierr = 10*n else call balanc(nm,n,a,is1,is2,fv1) call elmhes(nm,n,is1,is2,a,iv1) if(matz.eq.0)then call hqr(nm,n,is1,is2,a,wr,wi,ierr) else call eltran(nm,n,is1,is2,a,iv1,z) call hqr2(nm,n,is1,is2,a,wr,wi,z,ierr) if(ierr.eq.0)then call balbak(nm,n,is1,is2,fv1,n,z) endif endif endif return end subroutine chol(a,p,work,jpvt,job,info) integer p,jpvt(*),job,info(*) double precision a(p,*),work(*) integer i,j j =2 23124 if(.not.(j.le.p))goto 23126 i=1 23127 if(.not.(i.lt.j))goto 23129 if(a(i,j).ne.a(j,i))then info(1) = -1 return endif 23128 i = i+1 goto 23127 23129 continue 23125 j = j+1 goto 23124 23126 continue call dchdc(a,p,p,work,jpvt,job,info(1)) j =2 23132 if(.not.(j.le.p))goto 23134 i=1 23135 if(.not.(i.lt.j))goto 23137 a(j,i) = 0. 23136 i = i+1 goto 23135 23137 continue 23133 j = j+1 goto 23132 23134 continue return end subroutine crs(x,dmx,matz,w,z,fv1,fv2,ierr) double precision x(*),w(*),z(*),fv1(*),fv2(*) integer dmx(2),nx,nv,ierr,matz nx=dmx(1) nv=dmx(2) call rs(nx,nv,x,w,matz,z,fv1,fv2,ierr) return end subroutine dqrls2(x,dx,pivot,qraux,y,dy,beta,res,qt,scrtch,eps) integer pivot(*),dx(2),dy(2) double precision x(*), qraux(*), y(*), beta(*),res(*),qt(*), scrtc *h(*),eps integer n,p,q,kn,kp,k,info,rank n=dx(1) p=dx(2) q=dy(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,eps) kn=1 kp=1 k=1 23138 if(.not.(k.le.q))goto 23140 call dqrsl(x,n,n,p,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn),scr *tch,00110,info) kn = kn+n kp=kp+p 23139 k=k+1 goto 23138 23140 continue return end subroutine dsvdc1(x,dmx,job,work,e,s,u,v,info) double precision x(*),work(*),s(*),e(*),u(*),v(*) integer dmx(2),nx,nv,job,info nx=dmx(1) nv=dmx(2) call dsvdc(x,nx,nx,nv,s,e,u,nx,v,nv,work,job,info) return end subroutine balanc(nm,n,a,low,igh,scale) integer i,j,k,l,m,n,nm,igh,low,iexc double precision a(nm,n),scale(n) double precision c,f,g,r,s,b2,radix logical noconv radix = 16.0d0 b2 = radix*radix k = 1 l = n 23141 continue j=l 23144 if(.not.(j.gt.0))goto 23146 do23147 i = 1,l if(i.ne.j)then if(a(j,i).ne.0.0d0)then goto 23145 endif endif 23147 continue 23148 continue go to 10 23145 j=j-1 goto 23144 23146 continue go to 20 10 m = l iexc = 1 23153 continue scale(m) = j if(j.ne.m)then do23158 i = 1,l f = a(i,j) a(i,j) = a(i,m) a(i,m) = f 23158 continue 23159 continue do23160 i = k,n f = a(j,i) a(j,i) = a(m,i) a(m,i) = f 23160 continue 23161 continue endif I23162=(iexc) goto 23162 23164 continue if(l.eq.1)then go to 40 endif l = l-1 goto 23155 goto 23163 23167 continue k = k+1 20 do23168 j = k,l do23170 i = k,l if(i.ne.j)then if(a(i,j).ne.0.0d0)then goto 23168 endif endif 23170 continue 23171 continue go to 30 23168 continue 23169 continue goto 23143 30 m = k iexc = 2 goto 23163 23162 continue if (I23162.eq.1)goto 23164 if (I23162.eq.2)goto 23167 23163 continue 23154 goto 23153 23155 continue 23142 goto 23141 23143 continue do23176 i = k,l scale(i) = 1.0d0 23176 continue 23177 continue 23178 continue noconv = .false. do23181 i = k,l c = 0.0d0 r = 0.0d0 do23183 j = k,l if(j.ne.i)then c = c+dabs(a(j,i)) r = r+dabs(a(i,j)) endif 23183 continue 23184 continue if(c.ne.0.0d0.and.r.ne.0.0d0)then g = r/radix f = 1.0d0 s = c+r 23189 if(c.lt.g)then f = f*radix c = c*b2 goto 23189 endif 23190 continue g = r*radix 23191 if(c.ge.g)then f = f/radix c = c/b2 goto 23191 endif 23192 continue if((c+r)/f.lt.0.95d0*s)then g = 1.0d0/f scale(i) = scale(i)*f noconv = .true. do23195 j = k,n a(i,j) = a(i,j)*g 23195 continue 23196 continue do23197 j = 1,l a(j,i) = a(j,i)*f 23197 continue 23198 continue endif endif 23181 continue 23182 continue 23179 if(.not.(.not.noconv))goto 23178 23180 continue 40 low = k igh = l return end subroutine balbak(nm,n,low,igh,scale,m,z) integer i,j,k,m,n,ii,nm,igh,low double precision scale(n),z(nm,m) double precision s if(m.ne.0)then if(igh.ne.low)then do23203 i = low,igh s = scale(i) do23205 j = 1,m z(i,j) = z(i,j)*s 23205 continue 23206 continue 23203 continue 23204 continue endif do23207 ii = 1,n i = ii if(i.lt.low.or.i.gt.igh)then if(i.lt.low)then i = low-ii endif k = scale(i) if(k.ne.i)then do23215 j = 1,m s = z(i,j) z(i,j) = z(k,j) z(k,j) = s 23215 continue 23216 continue endif endif 23207 continue 23208 continue endif return end subroutine elmhes(nm,n,low,igh,a,int) integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1 double precision a(nm,n) double precision x,y integer int(igh) la = igh-1 kp1 = low+1 if(la.ge.kp1)then do23219 m = kp1,la mm1 = m-1 x = 0.0d0 i = m do23221 j = m,igh if(dabs(a(j,mm1)).gt.dabs(x))then x = a(j,mm1) i = j endif 23221 continue 23222 continue int(m) = i if(i.ne.m)then do23227 j = mm1,n y = a(i,j) a(i,j) = a(m,j) a(m,j) = y 23227 continue 23228 continue do23229 j = 1,igh y = a(j,i) a(j,i) = a(j,m) a(j,m) = y 23229 continue 23230 continue endif if(x.ne.0.0d0)then mp1 = m+1 do23233 i = mp1,igh y = a(i,mm1) if(y.ne.0.0d0)then y = y/x a(i,mm1) = y do23237 j = m,n a(i,j) = a(i,j)-y*a(m,j) 23237 continue 23238 continue do23239 j = 1,igh a(j,m) = a(j,m)+y*a(j,i) 23239 continue 23240 continue endif 23233 continue 23234 continue endif 23219 continue 23220 continue endif return end subroutine eltran(nm,n,low,igh,a,int,z) integer i,j,n,kl,mp,nm,igh,low,mp1 double precision a(nm,igh),z(nm,n) integer int(igh) do23241 j = 1,n do23243 i = 1,n z(i,j) = 0.0d0 23243 continue 23244 continue z(j,j) = 1.0d0 23241 continue 23242 continue kl = igh-low-1 if(kl.ge.1)then mp = igh-1 23247 if(.not.(mp .gt. low))goto 23249 mp1 = mp+1 do23250 i = mp1,igh z(i,mp) = a(i,mp-1) 23250 continue 23251 continue i = int(mp) if(i.ne.mp)then do23254 j = mp,igh z(mp,j) = z(i,j) z(i,j) = 0.0d0 23254 continue 23255 continue z(i,mp) = 1.0d0 endif 23248 mp = mp -1 goto 23247 23249 continue endif return end subroutine hqr(nm,n,low,igh,h,wr,wi,ierr) integer i,j,k,l,m,n,en,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n) double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2 logical notlas ierr = 0 norm = 0.0d0 k = 1 do23256 i = 1,n do23258 j = k,n norm = norm+dabs(h(i,j)) 23258 continue 23259 continue k = i if(i.lt.low.or.i.gt.igh)then wr(i) = h(i,i) wi(i) = 0.0d0 endif 23256 continue 23257 continue en = igh t = 0.0d0 itn = 30*n 23262 continue if(en.lt.low)then return endif its = 0 na = en-1 enm2 = na-1 23267 continue l=en 23270 if(.not.(l .gt. low))goto 23272 s = dabs(h(l-1,l-1))+dabs(h(l,l)) if(s.eq.0.0d0)then s = norm endif tst1 = s tst2 = tst1+dabs(h(l,l-1)) if(tst2.eq.tst1)then goto 23272 endif 23271 l = l-1 goto 23270 23272 continue x = h(en,en) if(l.eq.en)then go to 50 endif y = h(na,na) w = h(en,na)*h(na,en) if(l.eq.na)then goto 23269 endif if(itn.eq.0)then goto 23264 endif if(its.eq.10.or.its.eq.20)then t = t+x do23285 i = low,en h(i,i) = h(i,i)-x 23285 continue 23286 continue s = dabs(h(en,na))+dabs(h(na,enm2)) x = 0.75d0*s y = x w = -0.4375d0*s*s endif its = its+1 itn = itn-1 do23287 mm = l,enm2 m = enm2+l-mm zz = h(m,m) r = x-zz s = y-zz p = (r*s-w)/h(m+1,m)+h(m,m+1) q = h(m+1,m+1)-zz-r-s r = h(m+2,m+1) s = dabs(p)+dabs(q)+dabs(r) p = p/s q = q/s r = r/s if(m.eq.l)then goto 23288 endif tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1))) tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r)) if(tst2.eq.tst1)then goto 23288 endif 23287 continue 23288 continue mp2 = m+2 do23293 i = mp2,en h(i,i-2) = 0.0d0 if(i.ne.mp2)then h(i,i-3) = 0.0d0 endif 23293 continue 23294 continue do23297 k = m,na notlas = k.ne.na if(k.ne.m)then p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if(notlas)then r = h(k+2,k-1) endif x = dabs(p)+dabs(q)+dabs(r) if(x.eq.0.0d0)then goto 23297 endif p = p/x q = q/x r = r/x endif s = dsign(dsqrt(p*p+q*q+r*r),p) if(k.ne.m)then h(k,k-1) = -s*x else if(l.ne.m)then h(k,k-1) = -h(k,k-1) endif endif p = p+s x = p/s y = q/s zz = r/s q = q/p r = r/p if(.not.notlas)then do23311 j = k,n p = h(k,j)+q*h(k+1,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y 23311 continue 23312 continue j = min0(en,k+3) do23313 i = 1,j p = x*h(i,k)+y*h(i,k+1) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q 23313 continue 23314 continue else do23315 j = k,n p = h(k,j)+q*h(k+1,j)+r*h(k+2,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y h(k+2,j) = h(k+2,j)-p*zz 23315 continue 23316 continue j = min0(en,k+3) do23317 i = 1,j p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q h(i,k+2) = h(i,k+2)-p*r 23317 continue 23318 continue endif 23297 continue 23298 continue 23268 goto 23267 23269 continue p = (y-x)/2.0d0 q = p*p+w zz = dsqrt(dabs(q)) x = x+t if(q.lt.0.0d0)then wr(na) = x+p wr(en) = x+p wi(na) = zz wi(en) = -zz else zz = p+dsign(zz,p) wr(na) = x+zz wr(en) = wr(na) if(zz.ne.0.0d0)then wr(en) = x-w/zz endif wi(na) = 0.0d0 wi(en) = 0.0d0 endif en = enm2 goto 23263 50 wr(en) = x+t wi(en) = 0.0d0 en = na 23263 goto 23262 23264 continue ierr = en return end subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr) integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn,igh,itn,its,low,mp2,en *m2,ierr double precision h(nm,n),wr(n),wi(n),z(nm,n) double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2 logical notlas ierr = 0 norm = 0.0d0 k = 1 do23323 i = 1,n do23325 j = k,n norm = norm+dabs(h(i,j)) 23325 continue 23326 continue k = i if(i.lt.low.or.i.gt.igh)then wr(i) = h(i,i) wi(i) = 0.0d0 endif 23323 continue 23324 continue en = igh t = 0.0d0 itn = 30*n 23329 continue if(en.lt.low)then go to 70 endif its = 0 na = en-1 enm2 = na-1 23334 continue do23337 ll = low,en l = en+low-ll if(l.eq.low)then goto 23338 endif s = dabs(h(l-1,l-1))+dabs(h(l,l)) if(s.eq.0.0d0)then s = norm endif tst1 = s tst2 = tst1+dabs(h(l,l-1)) if(tst2.eq.tst1)then goto 23338 endif 23337 continue 23338 continue x = h(en,en) if(l.eq.en)then go to 60 endif y = h(na,na) w = h(en,na)*h(na,en) if(l.eq.na)then goto 23336 endif if(itn.eq.0)then goto 23331 endif if(its.eq.10.or.its.eq.20)then t = t+x do23353 i = low,en h(i,i) = h(i,i)-x 23353 continue 23354 continue s = dabs(h(en,na))+dabs(h(na,enm2)) x = 0.75d0*s y = x w = -0.4375d0*s*s endif its = its+1 itn = itn-1 do23355 mm = l,enm2 m = enm2+l-mm zz = h(m,m) r = x-zz s = y-zz p = (r*s-w)/h(m+1,m)+h(m,m+1) q = h(m+1,m+1)-zz-r-s r = h(m+2,m+1) s = dabs(p)+dabs(q)+dabs(r) p = p/s q = q/s r = r/s if(m.eq.l)then goto 23356 endif tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1))) tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r)) if(tst2.eq.tst1)then goto 23356 endif 23355 continue 23356 continue mp2 = m+2 do23361 i = mp2,en h(i,i-2) = 0.0d0 if(i.ne.mp2)then h(i,i-3) = 0.0d0 endif 23361 continue 23362 continue do23365 k = m,na notlas = k.ne.na if(k.ne.m)then p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if(notlas)then r = h(k+2,k-1) endif x = dabs(p)+dabs(q)+dabs(r) if(x.eq.0.0d0)then goto 23365 endif p = p/x q = q/x r = r/x endif s = dsign(dsqrt(p*p+q*q+r*r),p) if(k.ne.m)then h(k,k-1) = -s*x else if(l.ne.m)then h(k,k-1) = -h(k,k-1) endif endif p = p+s x = p/s y = q/s zz = r/s q = q/p r = r/p if(.not.notlas)then do23379 j = k,n p = h(k,j)+q*h(k+1,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y 23379 continue 23380 continue j = min0(en,k+3) do23381 i = 1,j p = x*h(i,k)+y*h(i,k+1) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q 23381 continue 23382 continue do23383 i = low,igh p = x*z(i,k)+y*z(i,k+1) z(i,k) = z(i,k)-p z(i,k+1) = z(i,k+1)-p*q 23383 continue 23384 continue else do23385 j = k,n p = h(k,j)+q*h(k+1,j)+r*h(k+2,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y h(k+2,j) = h(k+2,j)-p*zz 23385 continue 23386 continue j = min0(en,k+3) do23387 i = 1,j p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q h(i,k+2) = h(i,k+2)-p*r 23387 continue 23388 continue do23389 i = low,igh p = x*z(i,k)+y*z(i,k+1)+zz*z(i,k+2) z(i,k) = z(i,k)-p z(i,k+1) = z(i,k+1)-p*q z(i,k+2) = z(i,k+2)-p*r 23389 continue 23390 continue endif 23365 continue 23366 continue 23335 goto 23334 23336 continue p = (y-x)/2.0d0 q = p*p+w zz = dsqrt(dabs(q)) h(en,en) = x+t x = h(en,en) h(na,na) = y+t if(q.lt.0.0d0)then wr(na) = x+p wr(en) = x+p wi(na) = zz wi(en) = -zz else zz = p+dsign(zz,p) wr(na) = x+zz wr(en) = wr(na) if(zz.ne.0.0d0)then wr(en) = x-w/zz endif wi(na) = 0.0d0 wi(en) = 0.0d0 x = h(en,na) s = dabs(x)+dabs(zz) p = x/s q = zz/s r = dsqrt(p*p+q*q) p = p/r q = q/r do23395 j = na,n zz = h(na,j) h(na,j) = q*zz+p*h(en,j) h(en,j) = q*h(en,j)-p*zz 23395 continue 23396 continue do23397 i = 1,en zz = h(i,na) h(i,na) = q*zz+p*h(i,en) h(i,en) = q*h(i,en)-p*zz 23397 continue 23398 continue do23399 i = low,igh zz = z(i,na) z(i,na) = q*zz+p*z(i,en) z(i,en) = q*z(i,en)-p*zz 23399 continue 23400 continue endif en = enm2 goto 23330 60 h(en,en) = x+t wr(en) = h(en,en) wi(en) = 0.0d0 en = na 23330 goto 23329 23331 continue ierr = en return 70 if(norm.ne.0.0d0)then do23403 nn = 1,n en = n+1-nn p = wr(en) q = wi(en) na = en-1 if(q.lt.0)then m = na if(dabs(h(en,na)).le.dabs(h(na,en)))then call cdiv(0.0d0,-h(na,en),h(na,na)-p,q,h(na,na),h(na,en)) else h(na,na) = q/h(en,na) h(na,en) = -(h(en,en)-p)/h(en,na) endif h(en,na) = 0.0d0 h(en,en) = 1.0d0 enm2 = na-1 if(enm2.ne.0)then do23411 ii = 1,enm2 i = na-ii w = h(i,i)-p ra = 0.0d0 sa = 0.0d0 do23413 j = m,en ra = ra+h(i,j)*h(j,na) sa = sa+h(i,j)*h(j,en) 23413 continue 23414 continue if(wi(i).lt.0.0d0)then zz = w r = ra s = sa else m = i if(wi(i).eq.0.0d0)then call cdiv(-ra,-sa,w,q,h(i,na),h(i,en)) else x = h(i,i+1) y = h(i+1,i) vr = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i)-q*q vi = (wr(i)-p)*2.0d0*q if(vr.eq.0.0d0.and.vi.eq.0.0d0)then tst1 = norm*(dabs(w)+dabs(q)+dabs(x)+dabs(y)+dabs(zz)) vr = tst1 23421 continue vr = 0.01d0*vr tst2 = tst1+vr 23422 if(.not.(tst2.le.tst1))goto 23421 23423 continue endif call cdiv(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi,h(i,na),h(i,en)) if(dabs(x).le.dabs(zz)+dabs(q))then call cdiv(-r-y*h(i,na),-s-y*h(i,en),zz,q,h(i+1,na),h(i+1,en)) else h(i+1,na) = (-ra-w*h(i,na)+q*h(i,en))/x h(i+1,en) = (-sa-w*h(i,en)-q*h(i,na))/x endif endif t = dmax1(dabs(h(i,na)),dabs(h(i,en))) if(t.ne.0.0d0)then tst1 = t tst2 = tst1+1.0d0/tst1 if(tst2.le.tst1)then do23430 j = i,en h(j,na) = h(j,na)/t h(j,en) = h(j,en)/t 23430 continue 23431 continue endif endif endif 23411 continue 23412 continue endif else if(q.eq.0)then m = en h(en,en) = 1.0d0 if(na.ne.0)then do23436 ii = 1,na i = en-ii w = h(i,i)-p r = 0.0d0 do23438 j = m,en r = r+h(i,j)*h(j,en) 23438 continue 23439 continue if(wi(i).lt.0.0d0)then zz = w s = r else m = i if(wi(i).ne.0.0d0)then x = h(i,i+1) y = h(i+1,i) q = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i) t = (x*s-zz*r)/q h(i,en) = t if(dabs(x).le.dabs(zz))then h(i+1,en) = (-s-y*t)/zz else h(i+1,en) = (-r-w*t)/x endif else t = w if(t.eq.0.0d0)then tst1 = norm t = tst1 23448 continue t = 0.01d0*t tst2 = norm+t 23449 if(.not.(tst2.le.tst1))goto 23448 23450 continue endif h(i,en) = -r/t endif t = dabs(h(i,en)) if(t.ne.0.0d0)then tst1 = t tst2 = tst1+1.0d0/tst1 if(tst2.le.tst1)then do23455 j = i,en h(j,en) = h(j,en)/t 23455 continue 23456 continue endif endif endif 23436 continue 23437 continue endif endif endif 23403 continue 23404 continue do23457 i = 1,n if(i.lt.low.or.i.gt.igh)then do23461 j = i,n z(i,j) = h(i,j) 23461 continue 23462 continue endif 23457 continue 23458 continue do23463 jj = low,n j = n+low-jj m = min0(j,igh) do23465 i = low,igh zz = 0.0d0 do23467 k = low,m zz = zz+z(i,k)*h(k,j) 23467 continue 23468 continue z(i,j) = zz 23465 continue 23466 continue 23463 continue 23464 continue endif return end subroutine cdiv(ar,ai,br,bi,cr,ci) double precision ar,ai,br,bi,cr,ci double precision s,ars,ais,brs,bis s = dabs(br)+dabs(bi) ars = ar/s ais = ai/s brs = br/s bis = bi/s s = brs**2+bis**2 cr = (ars*brs+ais*bis)/s ci = (ais*brs-ars*bis)/s return end subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr) integer n,nm,ierr,matz double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n) if(n.gt.nm)then ierr = 10*n else if(matz.ne.0)then call tred2(nm,n,a,w,fv1,z) call tql2(nm,n,w,fv1,z,ierr) else call tred1(nm,n,a,w,fv1,fv2) call tqlrat(n,w,fv2,ierr) endif endif return end subroutine tql2(nm,n,d,e,z,ierr) integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr double precision d(n),e(n),z(nm,n) double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag ierr = 0 if(n.ne.1)then do23475 i = 2,n e(i-1) = e(i) 23475 continue 23476 continue f = 0.0d0 tst1 = 0.0d0 e(n) = 0.0d0 do23477 l = 1,n j = 0 h = dabs(d(l))+dabs(e(l)) if(tst1.lt.h)then tst1 = h endif do23481 m = l,n tst2 = tst1+dabs(e(m)) if(tst2.eq.tst1)then goto 23482 endif 23481 continue 23482 continue if(m.ne.l)then 23487 continue if(j.eq.30)then go to 10 endif j = j+1 l1 = l+1 l2 = l1+1 g = d(l) p = (d(l1)-g)/(2.0d0*e(l)) r = pythag(p,1.0d0) d(l) = e(l)/(p+dsign(r,p)) d(l1) = e(l)*(p+dsign(r,p)) dl1 = d(l1) h = g-d(l) if(l2.le.n)then do23494 i = l2,n d(i) = d(i)-h 23494 continue 23495 continue endif f = f+h p = d(m) c = 1.0d0 c2 = c el1 = e(l1) s = 0.0d0 mml = m-l do23496 ii = 1,mml c3 = c2 c2 = c s2 = s i = m-ii g = c*e(i) h = c*p r = pythag(p,e(i)) e(i+1) = s*r s = e(i)/r c = p/r p = c*d(i)-s*g d(i+1) = h+s*(c*g+s*d(i)) do23498 k = 1,n h = z(k,i+1) z(k,i+1) = s*z(k,i)+c*h z(k,i) = c*z(k,i)-s*h 23498 continue 23499 continue 23496 continue 23497 continue p = -s*s2*c3*el1*e(l)/dl1 e(l) = s*p d(l) = c*p tst2 = tst1+dabs(e(l)) 23488 if(.not.(tst2.le.tst1))goto 23487 23489 continue endif d(l) = d(l)+f 23477 continue 23478 continue do23500 ii = 2,n i = ii-1 k = i p = d(i) do23502 j = ii,n if(d(j).lt.p)then k = j p = d(j) endif 23502 continue 23503 continue if(k.ne.i)then d(k) = d(i) d(i) = p do23508 j = 1,n p = z(j,i) z(j,i) = z(j,k) z(j,k) = p 23508 continue 23509 continue endif 23500 continue 23501 continue return 10 ierr = l endif return end subroutine tqlrat(n,d,e2,ierr) integer i,j,l,m,n,ii,l1,mml,ierr double precision d(n),e2(n) double precision b,c,f,g,h,p,r,s,t,epslon,pythag ierr = 0 if(n.ne.1)then do23512 i = 2,n e2(i-1) = e2(i) 23512 continue 23513 continue f = 0.0d0 t = 0.0d0 e2(n) = 0.0d0 do23514 l = 1,n j = 0 h = dabs(d(l))+dsqrt(e2(l)) if(t.le.h)then t = h b = epslon(t) c = b*b endif do23518 m = l,n if(e2(m).le.c)then goto 23519 endif 23518 continue 23519 continue if(m.ne.l)then 23524 continue if(j.eq.30)then go to 20 endif j = j+1 l1 = l+1 s = dsqrt(e2(l)) g = d(l) p = (d(l1)-g)/(2.0d0*s) r = pythag(p,1.0d0) d(l) = s/(p+dsign(r,p)) h = g-d(l) do23529 i = l1,n d(i) = d(i)-h 23529 continue 23530 continue f = f+h g = d(m) if(g.eq.0.0d0)then g = b endif h = g s = 0.0d0 mml = m-l do23533 ii = 1,mml i = m-ii p = g*h r = p+e2(i) e2(i+1) = s*r s = e2(i)/r d(i+1) = h+s*(h+d(i)) g = d(i)-e2(i)/g if(g.eq.0.0d0)then g = b endif h = g*p/r 23533 continue 23534 continue e2(l) = s*g d(l) = h if(h.eq.0.0d0)then goto 23526 endif if(dabs(e2(l)).le.dabs(c/h))then goto 23526 endif e2(l) = h*e2(l) 23525 if(.not.(e2(l).eq.0.0d0))goto 23524 23526 continue endif p = d(l)+f if(l.ne.1)then do23543 ii = 2,l i = l+2-ii if(p.ge.d(i-1))then go to 10 endif d(i) = d(i-1) 23543 continue 23544 continue endif i = 1 10 d(i) = p 23514 continue 23515 continue return 20 ierr = l endif return end subroutine tred1(nm,n,a,d,e,e2) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),e2(n) double precision f,g,h,scale do23547 i = 1,n d(i) = a(n,i) a(n,i) = a(i,i) 23547 continue 23548 continue do23549 ii = 1,n i = n+1-ii l = i-1 h = 0.0d0 scale = 0.0d0 if(l.ge.1)then do23553 k = 1,l scale = scale+dabs(d(k)) 23553 continue 23554 continue if(scale.eq.0.0d0)then do23557 j = 1,l d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = 0.0d0 23557 continue 23558 continue else do23559 k = 1,l d(k) = d(k)/scale h = h+d(k)*d(k) 23559 continue 23560 continue e2(i) = scale*scale*h f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g if(l.ne.1)then do23563 j = 1,l e(j) = 0.0d0 23563 continue 23564 continue do23565 j = 1,l f = d(j) g = e(j)+a(j,j)*f jp1 = j+1 if(l.ge.jp1)then do23569 k = jp1,l g = g+a(k,j)*d(k) e(k) = e(k)+a(k,j)*f 23569 continue 23570 continue endif e(j) = g 23565 continue 23566 continue f = 0.0d0 do23571 j = 1,l e(j) = e(j)/h f = f+e(j)*d(j) 23571 continue 23572 continue h = f/(h+h) do23573 j = 1,l e(j) = e(j)-h*d(j) 23573 continue 23574 continue do23575 j = 1,l f = d(j) g = e(j) do23577 k = j,l a(k,j) = a(k,j)-f*e(k)-g*d(k) 23577 continue 23578 continue 23575 continue 23576 continue endif do23579 j = 1,l f = d(j) d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = f*scale 23579 continue 23580 continue goto 23549 endif endif e(i) = 0.0d0 e2(i) = 0.0d0 23549 continue 23550 continue return end subroutine tred2(nm,n,a,d,e,z) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),z(nm,n) double precision f,g,h,hh,scale do23581 i = 1,n do23583 j = i,n z(j,i) = a(j,i) 23583 continue 23584 continue d(i) = a(n,i) 23581 continue 23582 continue if(n.ne.1)then do23587 ii = 2,n i = n+2-ii l = i-1 h = 0.0d0 scale = 0.0d0 if(l.ge.2)then do23591 k = 1,l scale = scale+dabs(d(k)) 23591 continue 23592 continue if(scale.ne.0.0d0)then do23595 k = 1,l d(k) = d(k)/scale h = h+d(k)*d(k) 23595 continue 23596 continue f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g do23597 j = 1,l e(j) = 0.0d0 23597 continue 23598 continue do23599 j = 1,l f = d(j) z(j,i) = f g = e(j)+z(j,j)*f jp1 = j+1 if(l.ge.jp1)then do23603 k = jp1,l g = g+z(k,j)*d(k) e(k) = e(k)+z(k,j)*f 23603 continue 23604 continue endif e(j) = g 23599 continue 23600 continue f = 0.0d0 do23605 j = 1,l e(j) = e(j)/h f = f+e(j)*d(j) 23605 continue 23606 continue hh = f/(h+h) do23607 j = 1,l e(j) = e(j)-hh*d(j) 23607 continue 23608 continue do23609 j = 1,l f = d(j) g = e(j) do23611 k = j,l z(k,j) = z(k,j)-f*e(k)-g*d(k) 23611 continue 23612 continue d(j) = z(l,j) z(i,j) = 0.0d0 23609 continue 23610 continue go to 10 endif endif e(i) = d(l) do23613 j = 1,l d(j) = z(l,j) z(i,j) = 0.0d0 z(j,i) = 0.0d0 23613 continue 23614 continue 10 d(i) = h 23587 continue 23588 continue do23615 i = 2,n l = i-1 z(n,l) = z(l,l) z(l,l) = 1.0d0 h = d(i) if(h.ne.0.0d0)then do23619 k = 1,l d(k) = z(k,i)/h 23619 continue 23620 continue do23621 j = 1,l g = 0.0d0 do23623 k = 1,l g = g+z(k,i)*z(k,j) 23623 continue 23624 continue do23625 k = 1,l z(k,j) = z(k,j)-g*d(k) 23625 continue 23626 continue 23621 continue 23622 continue endif do23627 k = 1,l z(k,i) = 0.0d0 23627 continue 23628 continue 23615 continue 23616 continue endif do23629 i = 1,n d(i) = z(n,i) z(n,i) = 0.0d0 23629 continue 23630 continue z(n,n) = 1.0d0 e(1) = 0.0d0 return end subroutine dmatp(x,dx,y,dy,z) integer dx(2),dy(2) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j n=dx(1) p=dx(2) q=dy(2) do23631 i = 1,n jj = 1 ij = i do23633 j = 1, q z(ij) = ddot(p,x(i),n,y(jj),1) if(j.lt.q)then jj = jj + p ij = ij + n endif 23633 continue 23634 continue 23631 continue 23632 continue return end subroutine dmatpt(x,dx,y,dy,z) integer dx(2),dy(2) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j,ii n=dx(1) p=dx(2) q=dy(2) ii=1 do23637 i = 1,p jj = 1 ij = i do23639 j = 1, q z(ij) = ddot(n,x(ii),1,y(jj),1) if(j.lt.q)then jj = jj + n ij = ij + p endif 23639 continue 23640 continue ii = ii +n 23637 continue 23638 continue return end subroutine matpm(x,dx,mmx,mx,y,dy,mmy,my,z) integer dx(2),dy(2) integer mmx(*), mmy(*) integer mx(*), my(*) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j n=dx(1) p=dx(2) q=dy(2) call rowmis(mmx,dx(1),dx(2),mx) call colmis(mmy,dy(1),dy(2),my) do23643 i = 1,n jj = 1 ij = i do23645 j = 1, q if(.not.(mx(i).ne.0 .or. my(j).ne.0))then z(ij) = ddot(p,x(i),n,y(jj),1) endif if(j.lt.q)then jj = jj + p ij = ij + n endif 23645 continue 23646 continue 23643 continue 23644 continue return end subroutine matptm(x,dx,mmx,mx,y,dy,mmy,my,z) integer dx(2),dy(2) integer mmx(*), mmy(*) integer mx(*), my(*) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j call colmis(mmx,dx(1),dx(2),mx) call colmis(mmy,dy(1),dy(2),my) n=dx(1) p=dx(2) q=dy(2) ii=1 do23651 i = 1,p jj = 1 ij = i do23653 j = 1, q if(.not.(mx(i).ne.0 .or. my(j).ne.0))then z(ij) = ddot(n,x(ii),1,y(jj),1) endif if(j.lt.q)then jj = jj + n ij = ij + p endif 23653 continue 23654 continue ii = ii +n 23651 continue 23652 continue return end subroutine rowmis(m,n,p,vec) integer n,p integer m(n,p) integer vec(*) do23659 i = 1,n vec(i)=0 do23661 j = 1,p if(m(i,j).ne.0)then vec(i) = 1 endif 23661 continue 23662 continue 23659 continue 23660 continue return end subroutine colmis(m,n,p,vec) integer n,p integer m(n,p) integer vec(*) do23665 j = 1,p vec(j)=0 do23667 i = 1,n if(m(i,j).ne.0)then vec(j) = 1 endif 23667 continue 23668 continue 23665 continue 23666 continue return end subroutine dshift(x,ldx,n,j,k) integer ldx,n,j,k double precision x(ldx,k),tt integer i,jj if(k.gt.j)then do23790 i = 1,n tt = x(i,j) do23792 jj = j+1,k x(i,jj-1) = x(i,jj) 23792 continue 23793 continue x(i,k) = tt 23790 continue 23791 continue endif return end subroutine rtod(dx,dy,n) real dx(*) double precision dy(*) integer i,m,mp1,n if(n.gt.0)then m = mod(n,7) if(m.ne.0)then do23798 i = 1,m dy(i) = dx(i) 23798 continue 23799 continue if(n.lt.7)then return endif endif mp1 = m+1 do23802 i = mp1,n,7 dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) 23802 continue 23803 continue endif return end subroutine dtor(dx,dy,n) double precision dx(*) real dy(*) integer i,m,mp1,n if(n.gt.0)then m = mod(n,7) if(m.ne.0)then do23808 i = 1,m dy(i) = dx(i) 23808 continue 23809 continue if(n.lt.7)then return endif endif mp1 = m+1 do23812 i = mp1,n,7 dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) 23812 continue 23813 continue endif return end subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) integer ldx,n,k,job,info double precision x(ldx,*),qraux(*),y(*),qy(*),qty(*),b(*),rsd(*),x *b(*) integer i,j,jj,ju,kp1 double precision ddot,t,temp logical cb,cqy,cqty,cr,cxb info = 0 cqy = job/10000.ne.0 cqty = mod(job,10000).ne.0 cb = mod(job,1000)/100.ne.0 cr = mod(job,100)/10.ne.0 cxb = mod(job,10).ne.0 ju = min0(k,n-1) if(ju.eq.0)then if(cqy)then qy(1) = y(1) endif if(cqty)then qty(1) = y(1) endif if(cxb)then xb(1) = y(1) endif if(cb)then if(x(1,1).ne.0.0d0)then b(1) = y(1)/x(1,1) else info = 1 endif endif if(cr)then rsd(1) = 0.0d0 endif else if(cqy)then call dcopy(n,y,1,qy,1) endif if(cqty)then call dcopy(n,y,1,qty,1) endif if(cqy)then do23854 jj = 1,ju j = ju-jj+1 if(qraux(j).ne.0.0d0)then temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qy(j),1) x(j,j) = temp endif 23854 continue 23855 continue endif if(cqty)then do23860 j = 1,ju if(qraux(j).ne.0.0d0)then temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qty(j),1) x(j,j) = temp endif 23860 continue 23861 continue endif if(cb)then call dcopy(k,qty,1,b,1) endif kp1 = k+1 if(cxb)then call dcopy(k,qty,1,xb,1) endif if(cr.and.k.lt.n)then call dcopy(n-k,qty(kp1),1,rsd(kp1),1) endif if(cxb.and.kp1.le.n)then do23872 i = kp1,n xb(i) = 0.0d0 23872 continue 23873 continue endif if(cr)then do23876 i = 1,k rsd(i) = 0.0d0 23876 continue 23877 continue endif if(cb)then do23880 jj = 1,k j = k-jj+1 if(x(j,j).eq.0.0d0)then go to 130 endif b(j) = b(j)/x(j,j) if(j.ne.1)then t = -b(j) call daxpy(j-1,t,x(1,j),1,b,1) endif 23880 continue 23881 continue go to 140 130 info = j endif 140 if(cr.or.cxb)then do23888 jj = 1,ju j = ju-jj+1 if(qraux(j).ne.0.0d0)then temp = x(j,j) x(j,j) = qraux(j) if(cr)then t = -ddot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,rsd(j),1) endif if(cxb)then t = -ddot(n-j+1,x(j,j),1,xb(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,xb(j),1) endif x(j,j) = temp endif 23888 continue 23889 continue endif endif return end subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) integer ldx,n,p,ldu,ldv,job,info double precision x(ldx,*),s(*),e(*),u(ldu,*),v(ldv,*),work(*) integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit,mm, *mm1,mp1,nct,nctp1,ncu,nrt,nrtp1 double precision ddot,t double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn,smm *1,t1,test,ztest logical wantu,wantv maxit = 30 wantu = .false. wantv = .false. jobu = mod(job,100)/10 ncu = n if(jobu.gt.1)then ncu = min0(n,p) endif if(jobu.ne.0)then wantu = .true. endif if(mod(job,10).ne.0)then wantv = .true. endif info = 0 nct = min0(n-1,p) nrt = max0(0,min0(p-2,n)) lu = max0(nct,nrt) if(lu.ge.1)then do23904 l = 1,lu lp1 = l+1 if(l.le.nct)then s(l) = dnrm2(n-l+1,x(l,l),1) if(s(l).ne.0.0d0)then if(x(l,l).ne.0.0d0)then s(l) = dsign(s(l),x(l,l)) endif call dscal(n-l+1,1.0d0/s(l),x(l,l),1) x(l,l) = 1.0d0+x(l,l) endif s(l) = -s(l) endif if(p.ge.lp1)then do23914 j = lp1,p if(l.le.nct)then if(s(l).ne.0.0d0)then t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) endif endif e(j) = x(l,j) 23914 continue 23915 continue endif if(wantu.and.l.le.nct)then do23922 i = l,n u(i,l) = x(i,l) 23922 continue 23923 continue endif if(l.le.nrt)then e(l) = dnrm2(p-l,e(lp1),1) if(e(l).ne.0.0d0)then if(e(lp1).ne.0.0d0)then e(l) = dsign(e(l),e(lp1)) endif call dscal(p-l,1.0d0/e(l),e(lp1),1) e(lp1) = 1.0d0+e(lp1) endif e(l) = -e(l) if(lp1.le.n.and.e(l).ne.0.0d0)then do23932 i = lp1,n work(i) = 0.0d0 23932 continue 23933 continue do23934 j = lp1,p call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) 23934 continue 23935 continue do23936 j = lp1,p call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) 23936 continue 23937 continue endif if(wantv)then do23940 i = lp1,p v(i,l) = e(i) 23940 continue 23941 continue endif endif 23904 continue 23905 continue endif m = min0(p,n+1) nctp1 = nct+1 nrtp1 = nrt+1 if(nct.lt.p)then s(nctp1) = x(nctp1,nctp1) endif if(n.lt.m)then s(m) = 0.0d0 endif if(nrtp1.lt.m)then e(nrtp1) = x(nrtp1,m) endif e(m) = 0.0d0 if(wantu)then if(ncu.ge.nctp1)then do23952 j = nctp1,ncu do23954 i = 1,n u(i,j) = 0.0d0 23954 continue 23955 continue u(j,j) = 1.0d0 23952 continue 23953 continue endif if(nct.ge.1)then do23958 ll = 1,nct l = nct-ll+1 if(s(l).eq.0.0d0)then do23962 i = 1,n u(i,l) = 0.0d0 23962 continue 23963 continue u(l,l) = 1.0d0 else lp1 = l+1 if(ncu.ge.lp1)then do23966 j = lp1,ncu t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) call daxpy(n-l+1,t,u(l,l),1,u(l,j),1) 23966 continue 23967 continue endif call dscal(n-l+1,-1.0d0,u(l,l),1) u(l,l) = 1.0d0+u(l,l) lm1 = l-1 if(lm1.ge.1)then do23970 i = 1,lm1 u(i,l) = 0.0d0 23970 continue 23971 continue endif endif 23958 continue 23959 continue endif endif if(wantv)then do23974 ll = 1,p l = p-ll+1 lp1 = l+1 if(l.le.nrt)then if(e(l).ne.0.0d0)then do23980 j = lp1,p t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) 23980 continue 23981 continue endif endif do23982 i = 1,p v(i,l) = 0.0d0 23982 continue 23983 continue v(l,l) = 1.0d0 23974 continue 23975 continue endif mm = m iter = 0 23984 continue if(m.eq.0)then return endif if(iter.ge.maxit)then goto 23986 endif do23991 ll = 1,m l = m-ll if(l.eq.0)then goto 23992 endif test = dabs(s(l))+dabs(s(l+1)) ztest = test+dabs(e(l)) if(ztest.eq.test)then go to 150 endif 23991 continue 23992 continue go to 160 150 e(l) = 0.0d0 160 if(l.eq.m-1)then kase = 4 else lp1 = l+1 mp1 = m+1 do23999 lls = lp1,mp1 ls = m-lls+lp1 if(ls.eq.l)then goto 24000 endif test = 0.0d0 if(ls.ne.m)then test = test+dabs(e(ls)) endif if(ls.ne.l+1)then test = test+dabs(e(ls-1)) endif ztest = test+dabs(s(ls)) if(ztest.eq.test)then go to 170 endif 23999 continue 24000 continue go to 180 170 s(ls) = 0.0d0 180 if(ls.eq.l)then kase = 3 else if(ls.eq.m)then kase = 1 else kase = 2 l = ls endif endif endif l = l+1 I24013=(kase) goto 24013 24015 continue mm1 = m-1 f = e(m-1) e(m-1) = 0.0d0 do24016 kk = l,mm1 k = mm1-kk+l t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 if(k.ne.l)then f = -sn*e(k-1) e(k-1) = cs*e(k-1) endif if(wantv)then call drot(p,v(1,k),1,v(1,m),1,cs,sn) endif 24016 continue 24017 continue goto 24014 24022 continue f = e(l-1) e(l-1) = 0.0d0 do24023 k = l,m t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 f = -sn*e(k) e(k) = cs*e(k) if(wantu)then call drot(n,u(1,k),1,u(1,l-1),1,cs,sn) endif 24023 continue 24024 continue goto 24014 24027 continue scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),dabs(s(l)),dabs *(e(l))) sm = s(m)/scale smm1 = s(m-1)/scale emm1 = e(m-1)/scale sl = s(l)/scale el = e(l)/scale b = ((smm1+sm)*(smm1-sm)+emm1**2)/2.0d0 c = (sm*emm1)**2 shift = 0.0d0 if(b.ne.0.0d0.or.c.ne.0.0d0)then shift = dsqrt(b**2+c) if(b.lt.0.0d0)then shift = -shift endif shift = c/(b+shift) endif f = (sl+sm)*(sl-sm)+shift g = sl*el mm1 = m-1 do24032 k = l,mm1 call drotg(f,g,cs,sn) if(k.ne.l)then e(k-1) = f endif f = cs*s(k)+sn*e(k) e(k) = cs*e(k)-sn*s(k) g = sn*s(k+1) s(k+1) = cs*s(k+1) if(wantv)then call drot(p,v(1,k),1,v(1,k+1),1,cs,sn) endif call drotg(f,g,cs,sn) s(k) = f f = cs*e(k)+sn*s(k+1) s(k+1) = -sn*e(k)+cs*s(k+1) g = sn*e(k+1) e(k+1) = cs*e(k+1) if(wantu.and.k.lt.n)then call drot(n,u(1,k),1,u(1,k+1),1,cs,sn) endif 24032 continue 24033 continue e(m-1) = f iter = iter+1 goto 24014 24040 continue if(s(l).lt.0.0d0)then s(l) = -s(l) if(wantv)then call dscal(p,-1.0d0,v(1,l),1) endif endif 24045 if(l.ne.mm)then if(s(l).ge.s(l+1))then goto 24046 endif t = s(l) s(l) = s(l+1) s(l+1) = t if(wantv.and.l.lt.p)then call dswap(p,v(1,l),1,v(1,l+1),1) endif if(wantu.and.l.lt.n)then call dswap(n,u(1,l),1,u(1,l+1),1) endif l = l+1 goto 24045 endif 24046 continue iter = 0 m = m-1 goto 24014 24013 continue if (I24013.eq.1)goto 24015 if (I24013.eq.2)goto 24022 if (I24013.eq.3)goto 24027 if (I24013.eq.4)goto 24040 24014 continue 23985 goto 23984 23986 continue info = m return end subroutine dbksl(x,p,k,b,q,info) integer p,k,q,info double precision x(p,p),b(p,q) double precision t integer j,l info = 0 j=k 24053 if(.not.(j.gt.0))goto 24055 if(x(j,j).eq.0.0d0)then info = j goto 24055 endif l=1 24058 if(.not.(l.le.q))goto 24060 b(j,l) = b(j,l)/x(j,j) if(j.ne.1)then t = -b(j,l) call daxpy(j-1,t,x(1,j),1,b(1,l),1) endif 24059 l = l+1 goto 24058 24060 continue 24054 j = j-1 goto 24053 24055 continue return end subroutine dtrsl(t,ldt,n,b,job,info) integer ldt,n,job,info double precision t(ldt,*),b(*) double precision ddot,temp integer which,j,jj do24063 info = 1,n if(t(info,info).eq.0.0d0)then return endif 24063 continue 24064 continue info = 0 which = 1 if(mod(job,10).ne.0)then which = 2 endif if(mod(job,100)/10.ne.0)then which = which+2 endif I24071=(which) goto 24071 24073 continue b(1) = b(1)/t(1,1) if(n.ge.2)then do24076 j = 2,n temp = -b(j-1) call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) b(j) = b(j)/t(j,j) 24076 continue 24077 continue endif goto 24072 24078 continue b(n) = b(n)/t(n,n) if(n.ge.2)then do24081 jj = 2,n j = n-jj+1 temp = -b(j+1) call daxpy(j,temp,t(1,j+1),1,b(1),1) b(j) = b(j)/t(j,j) 24081 continue 24082 continue endif goto 24072 24083 continue b(n) = b(n)/t(n,n) if(n.ge.2)then do24086 jj = 2,n j = n-jj+1 b(j) = b(j)-ddot(jj-1,t(j+1,j),1,b(j+1),1) b(j) = b(j)/t(j,j) 24086 continue 24087 continue endif goto 24072 24088 continue b(1) = b(1)/t(1,1) if(n.ge.2)then do24091 j = 2,n b(j) = b(j)-ddot(j-1,t(1,j),1,b(1),1) b(j) = b(j)/t(j,j) 24091 continue 24092 continue endif goto 24072 24071 continue if (I24071.eq.1)goto 24073 if (I24071.eq.2)goto 24078 if (I24071.eq.3)goto 24083 if (I24071.eq.4)goto 24088 24072 continue return end gam/src/sgram.f0000644000176000001440000001156513324234205013123 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 C PURPOSE C Calculation of the cubic B-spline smoothness prior C for "usual" interior knot setup. C Uses BSPVD and INTRV in the CMLIB C sgm[0-3](nb) Symmetric matrix C whose (i,j)'th element contains the integral of C B''(i,.) B''(j,.) , i=1,2 ... nb and j=i,...nb. C Only the upper four diagonals are computed. subroutine sgram(sg0,sg1,sg2,sg3,tb,nb) c implicit none C indices integer nb DOUBLE precision sg0(nb),sg1(nb),sg2(nb),sg3(nb), tb(nb+4) c ------------- integer ileft,mflag, i,ii,jj, lentb DOUBLE precision vnikx(4,3),work(16),yw1(4),yw2(4), wpt c integer interv external interv lentb=nb+4 C Initialise the sigma vectors do 1 i=1,nb sg0(i)=0. sg1(i)=0. sg2(i)=0. sg3(i)=0. 1 continue ileft = 1 do 2 i=1,nb C Calculate a linear approximation to the C second derivative of the non-zero B-splines C over the interval [tb(i),tb(i+1)]. C call intrv(tb(1),(nb+1),tb(i),ilo,ileft,mflag) ileft = interv(tb(1), nb+1,tb(i), 0,0, ileft, mflag) C Left end second derivatives C call bspvd (tb,4,3,tb(i),ileft,4,vnikx,work) call bsplvd (tb,lentb,4,tb(i),ileft,work,vnikx,3) C Put values into yw1 do 4 ii=1,4 yw1(ii) = vnikx(ii,3) 4 continue C Right end second derivatives C call bspvd (tb,4,3,tb(i+1),ileft,4,vnikx,work) call bsplvd (tb,lentb,4,tb(i+1),ileft,work,vnikx,3) C Slope*(length of interval) in Linear Approximation to B'' do 6 ii=1,4 yw2(ii) = vnikx(ii,3) - yw1(ii) 6 continue wpt = tb(i+1) - tb(i) C Calculate Contributions to the sigma vectors if(ileft.ge.4) then do 10 ii=1,4 jj=ii sg0(ileft-4+ii) = sg0(ileft-4+ii) + & wpt*(yw1(ii)*yw1(jj)+ & (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & + yw2(ii)*yw2(jj)*.3330) jj=ii+1 if(jj.le.4)then sg1(ileft+ii-4) = sg1(ileft+ii-4) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif jj=ii+2 if(jj.le.4)then sg2(ileft+ii-4) = sg2(ileft+ii-4) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif jj=ii+3 if(jj.le.4)then sg3(ileft+ii-4) = sg3(ileft+ii-4) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif 10 continue else if(ileft.eq.3)then do 20 ii=1,3 jj=ii sg0(ileft-3+ii) = sg0(ileft-3+ii) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) jj=ii+1 if(jj.le.3)then sg1(ileft+ii-3) = sg1(ileft+ii-3) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif jj=ii+2 if(jj.le.3)then sg2(ileft+ii-3) = sg2(ileft+ii-3) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif 20 continue else if(ileft.eq.2)then do 28 ii=1,2 jj=ii sg0(ileft-2+ii) = sg0(ileft-2+ii) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) jj=ii+1 if(jj.le.2)then sg1(ileft+ii-2) = sg1(ileft+ii-2) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif 28 continue else if(ileft.eq.1)then do 34 ii=1,1 jj=ii sg0(ileft-1+ii) = sg0(ileft-1+ii) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) 34 continue endif 2 continue return end gam/src/sbart.c0000644000176000001440000002677513324234205013133 0ustar ripleyusers/* sbart.f -- translated by f2c (version 20010821). * ------- and f2c-clean,v 1.9 2000/01/13 * * According to the GAMFIT sources, this was derived from code by * Finbarr O'Sullivan. */ #include #include #include #include "modreg.h" /* sbart() : The cubic spline smoother ------- Calls sgram (sg0,sg1,sg2,sg3,knot,nk) stxwx (xs,ys,ws,n,knot,nk,xwy,hs0,hs1,hs2,hs3) sslvrg (penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, coef,sz,lev,crit,icrit, lambda, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier) is itself called from qsbart() [./qsbart.f] which has only one work array */ void F77_SUB(sbart) (double *penalt, double *dofoff, double *xs, double *ys, double *ws, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *icrit, double *spar, int *ispar, int *iter, double *lspar, double *uspar, double *tol, double *eps, int *isetup, double *xwy, double *hs0, double *hs1, double *hs2, double *hs3, double *sg0, double *sg1, double *sg2, double *sg3, double *abd, double *p1ip, double *p2ip, int *ld4, int *ldnk, int *ier) { /* A Cubic B-spline Smoothing routine. The algorithm minimises: (1/n) * sum ws(i)^2 * (ys(i)-sz(i))^2 + lambda* int ( s"(x) )^2 dx lambda is a function of the spar which is assumed to be between 0 and 1 INPUT ----- penalt A penalty > 1 to be used in the gcv criterion dofoff either `df.offset' for GCV or `df' (to be matched). n number of data points ys(n) vector of length n containing the observations ws(n) vector containing the weights given to each data point xs(n) vector containing the ordinates of the observations ssw `centered weighted sum of y^2' nk number of b-spline coefficients to be estimated nk <= n+2 knot(nk+4) vector of knot points defining the cubic b-spline basis. To obtain full cubic smoothing splines one might have (provided the xs-values are strictly increasing) spar penalised likelihood smoothing parameter ispar indicating if spar is supplied (ispar=1) or to be estimated lspar, uspar lower and upper values for spar search; 0.,1. are good values tol, eps used in Golden Search routine isetup setup indicator [initially 0 icrit indicator saying which cross validation score is to be computed 0: none ; 1: GCV ; 2: CV ; 3: 'df matching' ld4 the leading dimension of abd (ie ld4=4) ldnk the leading dimension of p2ip (not referenced) OUTPUT ------ coef(nk) vector of spline coefficients sz(n) vector of smoothed z-values lev(n) vector of leverages crit either ordinary or generalized CV score spar if ispar != 1 lspar == lambda (a function of spar and the design) iter number of iterations needed for spar search (if ispar != 1) ier error indicator ier = 0 ___ everything fine ier = 1 ___ spar too small or too big problem in cholesky decomposition Working arrays/matrix xwy X'Wy hs0,hs1,hs2,hs3 the diagonals of the X'WX matrix sg0,sg1,sg2,sg3 the diagonals of the Gram matrix SIGMA abd (ld4,nk) [ X'WX + lambda*SIGMA ] in diagonal form p1ip(ld4,nk) inner products between columns of L inverse p2ip(ldnk,nk) all inner products between columns of L inverse where L'L = [X'WX + lambda*SIGMA] NOT REFERENCED */ #define CRIT(FX) (*icrit == 3 ? FX - 3. : FX) /* cancellation in (3 + eps) - 3, but still...informative */ #define BIG_f (1e100) /* c_Gold is the squared inverse of the golden ratio */ static const double c_Gold = 0.381966011250105151795413165634; /* == (3. - sqrt(5.)) / 2. */ /* Local variables */ static double ratio;/* must be static (not needed in R) */ double a, b, d, e, p, q, r, u, v, w, x; double ax, fu, fv, fw, fx, bx, xm; double t1, t2, tol1, tol2; int i, maxit; Rboolean Fparabol = FALSE, tracing = (*ispar < 0); /* unnecessary initializations to keep -Wall happy */ d = 0.; fu = 0.; u = 0.; ratio = 1.; /* Compute SIGMA, X' W X, X' W z, trace ratio, s0, s1. SIGMA -> sg0,sg1,sg2,sg3 X' W X -> hs0,hs1,hs2,hs3 X' W Z -> xwy */ /* trevor fixed this 4/19/88 * Note: sbart, i.e. stxwx() and sslvrg() {mostly, not always!}, use * the square of the weights; the following rectifies that */ for (i = 0; i < *n; ++i) if (ws[i] > 0.) ws[i] = sqrt(ws[i]); if (*isetup == 0) { /* SIGMA[i,j] := Int B''(i,t) B''(j,t) dt {B(k,.) = k-th B-spline} */ F77_CALL(sgram)(sg0, sg1, sg2, sg3, knot, nk); F77_CALL(stxwx)(xs, ys, ws, n, knot, nk, xwy, hs0, hs1, hs2, hs3); /* Compute ratio := tr(X' W X) / tr(SIGMA) */ t1 = t2 = 0.; for (i = 3 - 1; i < (*nk - 3); ++i) { t1 += hs0[i]; t2 += sg0[i]; } ratio = t1 / t2; *isetup = 1; } /* Compute estimate */ if (*ispar == 1) { /* Value of spar supplied */ *lspar = ratio * R_pow(16., *spar * 6. - 2.); F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n, knot, nk, coef, sz, lev, crit, icrit, lspar, xwy, hs0, hs1, hs2, hs3, sg0, sg1, sg2, sg3, abd, p1ip, p2ip, ld4, ldnk, ier); /* got through check 2 */ return; } /* ELSE ---- spar not supplied --> compute it ! --------------------------- Use Forsythe Malcom and Moler routine to MINIMIZE criterion f denotes the value of the criterion an approximation x to the point where f attains a minimum on the interval (ax,bx) is determined. */ ax = *lspar; bx = *uspar; /* INPUT ax left endpoint of initial interval bx right endpoint of initial interval f function subprogram which evaluates f(x) for any x in the interval (ax,bx) tol desired length of the interval of uncertainty of the final result ( >= 0 ) OUTPUT fmin abcissa approximating the point where f attains a minimum */ /* The method used is a combination of golden section search and successive parabolic interpolation. convergence is never much slower than that for a fibonacci search. if f has a continuous second derivative which is positive at the minimum (which is not at ax or bx), then convergence is superlinear, and usually of the order of about 1.324.... the function f is never evaluated at two points closer together than eps*abs(fmin) + (tol/3), where eps is approximately the square root of the relative machine precision. if f is a unimodal function and the computed values of f are always unimodal when separated by at least eps*abs(x) + (tol/3), then fmin approximates the abcissa of the global minimum of f on the interval ax,bx with an error less than 3*eps*abs(fmin) + tol. if f is not unimodal, then fmin may approximate a local, but perhaps non-global, minimum to the same accuracy. this function subprogram is a slightly modified version of the algol 60 procedure localmin given in richard brent, algorithms for minimization without derivatives, prentice - hall, inc. (1973). Double a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v,w Double fu,fv,fw,fx,x */ /* eps is approximately the square root of the relative machine precision. - eps = 1e0 - 10 eps = eps/2e0 - tol1 = 1e0 + eps - if (tol1 > 1e0) go to 10 - eps = sqrt(eps) R Version <= 1.3.x had eps = .000244 ( = sqrt(5.954 e-8) ) -- now eps is passed as argument */ /* initialization */ maxit = *iter; *iter = 0; a = ax; b = bx; v = a + c_Gold * (b - a); w = v; x = v; e = 0.; *spar = x; *lspar = ratio * R_pow(16., *spar * 6. - 2.); F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n, knot, nk, coef, sz, lev, crit, icrit, lspar, xwy, hs0, hs1, hs2, hs3, sg0, sg1, sg2, sg3, abd, p1ip, p2ip, ld4, ldnk, ier); fx = *crit; fv = fx; fw = fx; /* main loop --------- */ while(*ier == 0) { /* L20: */ xm = (a + b) * .5; tol1 = *eps * fabs(x) + *tol / 3.; tol2 = tol1 * 2.; ++(*iter); if(tracing) { if(*iter == 1) {/* write header */ Rprintf("sbart (ratio = %15.8g) iterations;" " initial tol1 = %12.6e :\n" "%11s %14s %9s %11s Kind %11s %12s\n%s\n", ratio, tol1, "spar", ((*icrit == 1) ? "GCV" : (*icrit == 2) ? "CV" : (*icrit == 3) ?"(df0-df)^2" : /*else (should not happen) */"?f?"), "b - a", "e", "NEW lspar", "crit", " ---------------------------------------" "----------------------------------------"); } Rprintf("%11.8f %14.9g %9.4e %11.5g", x, CRIT(fx), b - a, e); Fparabol = FALSE; } /* Check the (somewhat peculiar) stopping criterion: note that the RHS is negative as long as the interval [a,b] is not small:*/ if (fabs(x - xm) <= tol2 - (b - a) * .5 || *iter > maxit) goto L_End; /* is golden-section necessary */ if (fabs(e) <= tol1 || /* if had Inf then go to golden-section */ fx >= BIG_f || fv >= BIG_f || fw >= BIG_f) goto L_GoldenSect; /* Fit Parabola */ if(tracing) { Rprintf(" FP"); Fparabol = TRUE; } r = (x - w) * (fx - fv); q = (x - v) * (fx - fw); p = (x - v) * q - (x - w) * r; q = (q - r) * 2.; if (q > 0.) p = -p; q = fabs(q); r = e; e = d; /* is parabola acceptable? Otherwise do golden-section */ if (fabs(p) >= fabs(.5 * q * r) || q == 0.) /* above line added by BDR; * [the abs(.) >= abs() = 0 should have branched..] * in FTN: COMMON above ensures q is NOT a register variable */ goto L_GoldenSect; if (p <= q * (a - x) || p >= q * (b - x)) goto L_GoldenSect; /* Parabolic Interpolation step */ if(tracing) Rprintf(" PI "); d = p / q; if(!R_FINITE(d)) REprintf(" !FIN(d:=p/q): ier=%d, (v,w, p,q)= %g, %g, %g, %g\n", *ier, v,w, p, q); u = x + d; /* f must not be evaluated too close to ax or bx */ if (u - a < tol2 || b - u < tol2) d = fsign(tol1, xm - x); goto L50; /*------*/ L_GoldenSect: /* a golden-section step */ if(tracing) Rprintf(" GS%s ", Fparabol ? "" : " --"); if (x >= xm) e = a - x; else/* x < xm*/ e = b - x; d = c_Gold * e; L50: u = x + ((fabs(d) >= tol1) ? d : fsign(tol1, d)); /* tol1 check : f must not be evaluated too close to x */ *spar = u; *lspar = ratio * R_pow(16., *spar * 6. - 2.); F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n, knot, nk, coef, sz, lev, crit, icrit, lspar, xwy, hs0, hs1, hs2, hs3, sg0, sg1, sg2, sg3, abd, p1ip, p2ip, ld4, ldnk, ier); fu = *crit; if(tracing) Rprintf("%11g %12g\n", *lspar, CRIT(fu)); if(!R_FINITE(fu)) { REprintf("spar-finding: non-finite value %g; using BIG value\n", fu); fu = 2. * BIG_f; } /* update a, b, v, w, and x */ if (fu <= fx) { if (u >= x) a = x; else b = x; v = w; fv = fw; w = x; fw = fx; x = u; fx = fu; } else { if (u < x) a = u; else b = u; if (fu <= fw || w == x) { /* L70: */ v = w; fv = fw; w = u; fw = fu; } else if (fu <= fv || v == x || v == w) { /* L80: */ v = u; fv = fu; } } }/* end main loop -- goto L20; */ L_End: if(tracing) Rprintf(" >>> %12g %12g\n", *lspar, CRIT(fx)); *spar = x; *crit = fx; return; } /* sbart */ gam/src/qsbart.f0000644000176000001440000000224013324234205013274 0ustar ripleyusersC An interface to sbart() --- fewer arguments BUT unspecified scrtch() dimension C subroutine qsbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, & coef,sz,lev, & crit,iparms,spar,parms, & isetup, scrtch, ld4,ldnk,ier) c integer n,nk,isetup, iparms(3), ld4,ldnk,ier double precision penalt,dofoff, xs(n),ys(n),ws(n),ssw, & knot(nk+4), coef(nk),sz(n),lev(n), & crit, spar, parms(4), & scrtch(*) C ^^^^^^^^ dimension (9+2*ld4+nk)*nk = (17 + nk)*nk call sbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, & coef,sz,lev, crit, & iparms(1),spar,iparms(2),iparms(3), c = icrit spar ispar iter & parms(1),parms(2),parms(3),parms(4), c = lspar uspar tol eps & isetup, scrtch(1), c = 0 xwy & scrtch( nk+1),scrtch(2*nk+1),scrtch(3*nk+1),scrtch(4*nk+1), c = hs0 hs1 hs2 hs3 & scrtch(5*nk+1),scrtch(6*nk+1),scrtch(7*nk+1),scrtch(8*nk+1), c = sg0 sg1 sg2 sg3 & scrtch(9*nk+1),scrtch(9*nk+ ld4*nk+1),scrtch(9*nk+2*ld4*nk), c = abd p1ip p2ip & ld4,ldnk,ier) return end gam/src/Makevars.win0000644000176000001440000000004113324234205014116 0ustar ripleyusersPKG_LIBS = $(BLAS_LIBS) $(FLIBS) gam/src/modreg.h0000644000176000001440000001235613324234205013270 0ustar ripleyusers/* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 2001-2 The R Development Core Team. * Copyright (C) 2003 The R Foundation * * 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 */ #ifndef R_MODREG_H #define R_MODREG_H #include /* for Sint .. */ #include SEXP R_isoreg(SEXP y); void BDRksmooth(double *x, double *y, int *n, double *xp, double *yp, int *np, int *kern, double *bandwidth); void loess_raw(double *y, double *x, double *weights, double *robust, Sint *d, Sint *n, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, double *cell, char **surf_stat, double *surface, Sint *parameter, Sint *a, double *xi, double *vert, double *vval, double *diagonal, double *trL, double *one_delta, double *two_delta, Sint *setLf); void loess_dfit(double *y, double *x, double *x_evaluate, double *weights, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, Sint *d, Sint *n, Sint *m, double *fit); void loess_dfitse(double *y, double *x, double *x_evaluate, double *weights, double *robust, Sint *family, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, Sint *d, Sint *n, Sint *m, double *fit, double *L); void loess_ifit(Sint *parameter, Sint *a, double *xi, double *vert, double *vval, Sint *m, double *x_evaluate, double *fit); void loess_ise(double *y, double *x, double *x_evaluate, double *weights, double *span, Sint *degree, Sint *nonparametric, Sint *drop_square, Sint *sum_drop_sqr, double *cell, Sint *d, Sint *n, Sint *m, double *fit, double *L); void Srunmed(double *y, double *smo, Sint *n, Sint *band, Sint *end_rule, Sint *debug); void Trunmed(Sint *nn,/* = length(data) */ Sint *kk,/* is odd <= nn */ const double *data, double *median, /* (n) */ Sint *outlist,/* (k+1) */ Sint *nrlist,/* (2k+1) */ double *window,/* (2k+1) */ Sint *end_rule, Sint *print_level); /* Fortran : */ void F77_SUB(lowesw)(double *res, int *n, double *rw, int *pi); void F77_SUB(lowesp)(int *n, double *y, double *yhat, double *pwgts, double *rwgts, int *pi, double *ytilde); void F77_SUB(setppr)(double *span1, double *alpha1, int *optlevel, int *ism, double *df1, double *gcvpen1); void F77_SUB(smart)(int *m, int *mu, int *p, int * q, int *n, double *w, double *x, double *y, double *ww, double *smod, int *nsmod, double *sp, int *nsp, double *dp, int *ndp, double *edf); void F77_SUB(pppred)(int *np, double *x, double *smod, double *y, double *sc); void F77_SUB(qsbart)(double *penalt, double *dofoff, double *xs, double *ys, double *ws, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *iparms, double *spar, double *parms, int *isetup, double *scrtch, int *ld4, int *ldnk, int *ier); void F77_NAME(sbart) (double *penalt, double *dofoff, double *xs, double *ys, double *ws, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *icrit, double *spar, int *ispar, int *iter, double *lspar, double *uspar, double *tol, double *eps, int *isetup, double *xwy, double *hs0, double *hs1, double *hs2, double *hs3, double *sg0, double *sg1, double *sg2, double *sg3, double *abd, double *p1ip, double *p2ip, int *ld4, int *ldnk, int *ier); void F77_NAME(sgram)(double *sg0, double *sg1, double *sg2, double *sg3, double *tb, int *nb); void F77_NAME(stxwx)(double *x, double *z, double *w, int *k, double *xknot, int *n, double *y, double *hs0, double *hs1, double *hs2, double *hs3); void F77_NAME(sslvrg)(double *penalt, double *dofoff, double *x, double *y, double *w, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *icrit, double *lambda, double *xwy, double *hs0, double *hs1, double *hs2, double *hs3, double *sg0, double *sg1, double *sg2, double *sg3, double *abd, double *p1ip, double *p2ip, int *ld4, int *ldnk, int *info); void F77_SUB(bvalus)(int *n, double *knot, double *coef, int *nk, double *x, double *s, int *order); void F77_SUB(supsmu)(int *n, double *x, double *y, double *w, int *iper, double *span, double *alpha, double *smo, double *sc, double *edf); #endif gam/src/backfit.f0000644000176000001440000001013713324234205013407 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine bakfit(x,npetc,y,w,which,spar,dof,match,nef, etal,s,eta *,beta,var,tol, qr,qraux,qpivot,effect,work) implicit double precision(a-h,o-z) logical ifvar integer npetc(7),iter integer n,p,q,which(*),match(*),nef(*),nit,maxit,qrank,qpivot(*) double precision x(*),y(*),w(*),spar(*),dof(*), etal(*),s(*),eta(* *),beta(*),var(*),tol, qr(*),qraux(*),effect(*),work(*) n=npetc(1) p=npetc(2) q=npetc(3) ifvar=.false. if(npetc(4).eq.1)then ifvar=.true. endif maxit=npetc(6) qrank=npetc(7) do23002 i=1,q work(i)=dof(i) 23002 continue 23003 continue call backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta,beta, *var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,work(q+1),wo *rk(q+n+1), work(q+2*n+1),work(q+3*n+1),work(q+4*n+1)) npetc(7)=qrank return end subroutine backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta *,beta,var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,z,old, *sqwt,sqwti,work) implicit double precision(a-h,o-z) logical ifvar integer n,p,q,which(q),match(n,q),nef(q),nit,maxit,qrank,qpivot(p) double precision x(n,p),y(n),w(n),spar(q),dof(q), etal(n),s(n,q),e *ta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),effect(n),work(*) double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info onedm7=1d-7 job=1101 info=1 if(q.eq.0)then maxit=1 endif ratio=1d0 anyzwt=.false. do23006 i=1,n if(w(i).gt.0d0)then sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) else sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. endif 23006 continue 23007 continue if(qrank.eq.0)then do23012 i=1,n do23014 j=1,p qr(i,j)=x(i,j)*sqwt(i) 23014 continue 23015 continue 23012 continue 23013 continue do23016 j=1,p qpivot(j)=j 23016 continue 23017 continue call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) endif do23018 i=1,n eta(i)=0d0 j=1 23020 if(.not.(j.le.q))goto 23022 eta(i)=eta(i)+s(i,j) 23021 j=j+1 goto 23020 23022 continue 23018 continue 23019 continue nit=0 23023 if((ratio .gt. tol ).and.(nit .lt. maxit))then deltaf=0d0 nit=nit+1 do23025 i=1,n z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) 23025 continue 23026 continue call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),et *al,job,info) do23027 i=1,n etal(i)=etal(i)*sqwti(i) 23027 continue 23028 continue k=1 23029 if(.not.(k.le.q))goto 23031 j=which(k) do23032 i=1,n old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) 23032 continue 23033 continue if(nit.gt.1)then dof(k)=0d0 endif call splsm(x(1,j),z,w,n,match(1,k),nef(k),spar(k), dof(k),s(1,k),s *0,var(1,k),ifvar,work) do23036 i=1,n eta(i)=eta(i)+s(i,k)-old(i) etal(i)=etal(i)+s0 23036 continue 23037 continue deltaf=deltaf+dwrss(n,old,s(1,k),w) 23030 k=k+1 goto 23029 23031 continue normf=0d0 do23038 i=1,n normf=normf+w(i)*eta(i)*eta(i) 23038 continue 23039 continue if(normf.gt.0d0)then ratio=dsqrt(deltaf/normf) else ratio = 0d0 endif goto 23023 endif 23024 continue do23042 j=1,p work(j)=beta(j) 23042 continue 23043 continue do23044 j=1,p beta(qpivot(j))=work(j) 23044 continue 23045 continue if(anyzwt)then do23048 i=1,n if(w(i) .le. 0d0)then etal(i)=0d0 do23052 j=1,p etal(i)=etal(i)+beta(j)*x(i,j) 23052 continue 23053 continue endif 23048 continue 23049 continue endif do23054 i=1,n eta(i)=eta(i)+etal(i) 23054 continue 23055 continue do23056 j=1,q call unpck(n,nef(j),match(1,j),var(1,j),old) do23058 i=1,n var(i,j)=old(i) 23058 continue 23059 continue 23056 continue 23057 continue return end gam/src/bvalus.f0000644000176000001440000000054213324234205013277 0ustar ripleyusers subroutine bvalus(n,knot,coef,nk,x,s,order) C Args integer n, nk, order double precision knot(*),coef(*),x(*),s(*) C Local double precision bvalue integer i do 10 i=1,n s(i)=bvalue(knot,n+4,coef,nk,4,x(i),order) C ---- typo corrected from gamfit 10 continue return end gam/NAMESPACE0000644000176000001440000000211413236317022012262 0ustar ripleyusersuseDynLib("gam") import(stats) import(splines) import(foreach) importFrom("graphics", "axis", "lines", "mtext", "persp", "plot", "points", "rug", "segments") importFrom(utils,head,tail,packageDescription,menu,assignInMyNamespace) export(general.wam,anova.Gamlist,as.anova,as.data.frame.lo.smooth,assign.list,gam,gam.control,gam.exact,gam.fit,Gamlist,gam.lo,gam.match,gam.nlchisq,gam.random,gam.s,gam.scope,gam.smooth.list,gam.smoothers,gam.sp,gplot,gplot.default,gplot.factor,gplot.list,gplot.matrix,gplot.numeric,lo,lo.wam,na.gam.replace,newdata.predict.Gam,plot.Gam,polylo,predict.Gam,random,s,s.wam,ylim.scale,step.Gam,summary.Gam) S3method("[",smooth) S3method(labels,Gam) S3method(plot,Gam) S3method(summary,Gam) S3method(print,summary.Gam) S3method(print,Gamex) S3method(print,Gam) S3method(print,stepanova) S3method(predict,Gam) S3method(plot,preplot.Gam) S3method(plot,Gam) S3method(preplot,Gam) S3method(anova,Gam) S3method(anova,Gamlist) S3method(as.data.frame,lo.smooth) S3method(gplot,default) S3method(gplot,factor) S3method(gplot,list) S3method(gplot,matrix) S3method(gplot,numeric) gam/data/0000755000176000001440000000000010543334047011762 5ustar ripleyusersgam/data/gam.newdata.RData0000644000176000001440000000031110543334047015060 0ustar ripleyusers‹ r‰0âŠàb```b`b’Ì@& `d`àÒÜ鉹zy©å)‰%‰ ÌÂ`¥ |@Ìe¿s&̲? ¥/ƒýM(ÿØ?†Š?Kû—Pù7g@à¬ý ‘¹(^bÍKÌM-2 ž 2VÀUhÊ9‹òËõµpÁTÂF0†1Œac˜Âf0†9ŒacXBL†èNMÎI,†ÙËUÆŠ ½´" “€¼ ãõ(®Ègam/data/kyphosis.RData0000644000176000001440000000134110543334047014547 0ustar ripleyusers‹•½kQÅggf?²f’ñ -,ÔÆ"˜yó±"B@E&Dp’Lb0É®³k4…(Úl+µµýìý“¢g6÷î.$¢ÅÙ{fß»ç÷Þ›ÍËâÜRÔ^j;Žã:®OÖwñQsœpµõx·÷¨Ûßè;Žw²D Pæ å*?.÷/ãGÍÿ—¾ñµÆuñ‡ñÆçÿÏšŽ`œuc³Ø)6qÒN(3†ßæËýb{ OÍ^Y<Ž´ÖW6ó¾í¬Ùε|eÐ-áö!ûÖn@Ÿ¡Wc+º]„ž@W¡EètBÆ¿J‡¾Aw ³Ðihz½¦…Þ‚Vá/Æùƒ^@¯¡ôz ™1t ºÝ‚ÎCïeM9´½•ü]è;4'œ=ÙG•wSüsÈ@kÂ+eï;¢ãÐOè‹ìoZÎä%túƒ~@Ÿ 3’y º ÎÒU{¬Kµ¿OjCÆ<5ÇöÙ1ÝÛP½MÕë©ïmÕ¹žò:דsÒ\_Ùœª¶¥úcÙMÕ×TY¾Z·¯úêêYÏõ¤ßU9ö,«ž)©5y'¡¼«P4)sìßǤ¼¿Pæâ'¤ÖeŽÝg g3¥2Cy×ò6£!uRÖHVMæ´דܶ¬¹!uZÍiI^ -•ªÞ@­cJøšgó¬uôJØη {%ønÝæu>|ö®¯v¯óO·–‹Ržêwy)·Œ÷Û½XÚ«ù ŸY+ƒN”Ýg3¼ -µYk"kŒ5±5‰5©5™5k®ˆqg/ÓÍÒEt†.¦Ké2º“#&GLŽ˜19br”Б‘1Ù0Ù0Ù0Ù0Ù0Ù0Ù0Ù0Ùpõ†Œ˜Œ˜Œ˜Œ˜Œ˜Œ˜Œ˜Œ˜Œ˜Œ˜Œ„Œ„Œ„Œ„Œ„Œ„Œ„Œ„Œ„Œ„Œ”Œ”Œ”Œ”Œ”Œ”Œ”Œ”Œ”Œ”ŒŒŒŒŒŒŒŒŒŒŒŒŒŒŒŒŒŒŒŒŒ2:dt*Fõïyÿ}Œ gam/data/gam.data.RData0000644000176000001440000001004310543334047014351 0ustar ripleyusers‹­™ \ÌéúÀG‰J„¤„J±Z¦æRÒS”KYrÝÐ] ¥\Rn)aIè²-»l.Eµ¤¢%´ýT"J5Ý蓮š©¹¦$TãÌûû›÷sÎü³Çùœù|¦çò>Ïó}ß÷7ïûÌgZãèFÕtÓ¤P(*•áò¿ªru¸ŠüÏ0 e¬†\ªoó °ðñÜçI¡¨êÈí‘ò÷ùÛ8I#›Bœõ³ähq]áøD.; îV#ÿƒmÛ½ÿ5#ûŽ½\ ÅeŒ«rÉý-Å±Õ SѸˆ±¡ÛH.%K3mQ^ã¬Ü±Èßengê!—íy™‘äÞrKGþ†-WN YœöãÉ=/²GùwJv üš®ÔXd7Ý2Ö 9v62T¿ëŠÓ$7³óP^ù^A Š>O*A6OH³@ù¢¯!»Ê‹™òùBW4ï®áizd^±%Iq¬Ûh¼ë¬ëSd?ÓÒðCõ:¥Q‘-œí¼Ù ©œ9hýošŠç…Œ%ëšh ¡º”M»l7=Ò„âØ.Ü$E‰êCh¾¥~Cuî—\c£ºuÝÛÙ(Ÿ“tx=Êcµ\0 ÷WuÍ;'¥|¬BëàêNÿ„üõ»ÏO"Ç{^– },ÙÍùʼnl'Ç"»R5.Õ¬_\êwÌ¿°ž\ÿqýäs8×BÆqí ‘Í=ôÊÕ/ÊÿNîÃF"ÊÏ]=Œ\—q` YÇ÷ÒT2O¶ÉIÉå%‘H6W!çïà„d›`hšßËýje(¯vQ[(ò SÖù“~^ùœš´fk!?kÁàòs“WíˆÖo–Úbd—<Š(B²iڬϕ¡ýãŒØ–‡¤ðÈBrßXfŸ^’õ5ŠF±É}ÿqªÓTÆöEyi é~¨gç²Vä’öx7Y×bï}4þpx4 ÙA!™HÖ?æòy_X¶qø™Þ–r‰ÏI;÷oV»¯åÀ;¿ýß&ŸÖ„÷÷^ã©^DuJwM81ú$០T sƒ=ÃG¥“àœó*\q±ºÇmÛ“Og eLöòʉB­#ûõomºˆ%Ëúah{î‡×V1§s>á““pgr†7Em€Ž•:©ñçà]í…˜àè)>gcz½ú«2%™W;‰6Zw¯lYH_\9'è4ô‹kþL › =Rm³¼uVðhÀh}ó"]E2ͱd*›?Xˆßœæ¥[Cö ¯Å—ž” Þ©•™yqx¯/²;h"Ñpåô¾'ôZ"»rsðÛ7èó|`_ÔF°nÐþÆì*Q0·aq²¡ôÒÿ½Ø@RŠŠO;ÆÅÍ»e²jx?ÚZ;p§!8!ù}geDÕçEƒ‰S¡yÎÙëóu¡þ^~ßc¿Pèع½NŸš¢ƒþ‡Æ%ºöŽ¾ôH׆Ü-îo8;Ýj•Ðf ²_Ôn,-§BûMW‘GÁ4øtaÓÐÂwL¢þzWø)^2AäÎoÔ]uSóæ.Öé±áv>—€à|òˆf9o†}YÁïyaDºÞE/æâ æ¨ÿx܃¨<½lnž<ïЭëb[èU…ڵΒrû# ¡OS5âNt„ö÷„kƒ•qærõ"õÔÚƤh{"{…A­_äüÙ±eBñó¦øÓ#íÍöMX­vŒh|´Uü¦·ú;3Œ½·BÏåCZ9jÁÐpæKƒÁU‡Å sYÌ?OT³&Õ§ü "–HÖÓï=Y–/§í·Å×b T‰c¼}é >Þ7I×4ÎVCßÓØ‹ÂRÈo›7Ú] Íç ´ÍŽhäÜ¿-?IdŽ>{ôù;7ø˜¡“u;1Šh{»Íª7©Äzvm" Ïô˜ØvX3‹®½Ý ½ŽÉÇ͡۸ݥº!ÞNiu{/Šƒžƒ·# « 9²C-üÆM„wE|ˆÞA4Æ]Ðã9… „=©øœÜr/ˆC稴S£¼çc¶¾Aç­Ô‡ö ÙmÝ·Ðyl³Y`OÞÇð‡:oÕfž#ûÌÎÃÈûy‹ã ”'x^H°ÉóNwEç½Ú¶jyŽ™WиX•s…¼Ïž … ñö£öä=ír†¼?“‹Æ ÉÎÖ¯Dœú›B*9?Ÿç2”_ßÐoIÆß¾Žî5‘˜õ+òÿ‘s’ìÅ¡Yä:®G QC…Ö¸—žˆÓq|¶ª[še;ÅGæùê£ñÊòT¯ƒ3by/æ?C²Ó§nyïg Qüó•H>SI$mAÊÝV÷Ìrœ;Š«®×!ïåãkšÉ{’÷ Í¿ä`Êkd³ÆKÜQ^K–ÐÉ’€/ÈûrýÇ-h^¼EIHv¾j&ã =É~Ðh(ñ ç¡¡S…d{jq¹¿Õg Èýo)9H®Cðs¹Î§iˆ›e{ ùÉû•½Re=Ú¯«í»î"¿ô£o"ªS8Å¥œì;¯šÉ8ŸÈ_Ñ¥Ÿ†ö¥¢~Ჯ8kD¡ú…“íÉ>#=Ÿ ê½bÇ“ûÁîØúŠg×½×GŸ“ú¸†«(®âže¹¿Œµ¿¶€›Kî¯zœ Ê+Ô°#ûÌyãÈ_¹·ŒìçÜ1ý2’oø£?òÿ®·‘¼ïEÄÊ4¿ì³….ä<2MÉÏMÓ›(O2·eâT®Ý¨FÆ;¯³Eùuì‘GP½vm—shÞB‡U (O|9´”œ·yaòóDûÉü£¦±Oþ¡Ÿê°g'9вëŠ5Ƴ¡s¼÷Ç·6…DÇ’™G=¶ÄB3Ì6:ª>Úïíx*ï'˜)þò~RMÕ[~¼É¸Ú1¶¨ŸHN¯–m;9‡Ê¢^Ž÷QØô¦ÖíÓ Þ£©Õ#ÀgfúÈÚ?qíñËA ^gÐ iÁ’_›ÄN©ÀOÝ•0ÝEHÛ/O3DýäΙÒò~"ˆ÷6¨´Ž¹drnê6¢Ó™™ÛçèGWÕ\÷vHLôÓ6ñ q…kVÝ~Ñd“QÏ­%$}YûÊv´§·“ž#¿w5=¦ì$xÌ‘/d¿ì”?,;•r¦€¶¤Op%:µ·¹KÌ D‡0Ž2ê~!:_t/åè«ÜI¬µ…Š‰·¦ uFÍò~B´8\|µÝNHp\Òû®»<%/qyÉS íÍ™&y?‘êxråýDtëè¸ÑSÞË?¢þ§e£@¿˜è ¯ôW«Eª‘÷‹ò7 DA„ˆÖë³w !ÍyÀIë…§^¹”?´ÌAba¶;YÞO$š‰±ò~"šÒ&-Ô!DN*U÷’*‰Ã›È°‚Ç ðdÈ Ë}¡ÜfHwqg-T¤›=®¸1¸ÞÑ^i÷f€ÐVÛtwÃLhÕäYärŸBmí57yƒd±Ä´AÞOÄÁ³“„½3¶ŒúÔYÅ Ÿ“¶c¯4Fhíîo±/Ú@Q»uCý÷P“;°j£ïYàîÁwƒöO^+Ï…ëcòRŸë›Þ{Q=8 Ú¯á/"ÊUÂÙ%XôκEù뀗Á³ ^÷jô¾[:•ï­~‹Ü'<ö™ëu*³Ì€×TVs*ÜxÖÓÇ´DŽÔûŸÖNÉ–ÃÔ=«GÝóBSK·Ügò7i— ÝßîjèÌ ÚoM¶i TMå›å·Óä|}Tê6}üîƒ\Lú7þܬ+µíÝïå8|~Û-¨ƒˆ†ûmPã*Ó[«?šñbõ °ïØÁȄꈫßDýR%ŒX‹y9P³WõO¿*¨¼(ª];lx¥{<ŽŸ¤Ç€i‘ K3Šƒ_;C}yÔ˜|óçP§'·,c¼ææN­ƒö-ô[>É€ÿéŠÙÔà=„k£Þ³ës)`Èÿ7àø7>~¸ÚÊOþ|ìÛ௘þ°àP;Tæéš6ÖßžÃ=Ðætèžänà«kY^9_ ¬~F¬ß)ð.ÑKÖMVñÝÝ•zÀ_µb¢ù9PuC;›ðZV|èýH‹¾·ab>/ªnmŸrï4´M…ÓáÀ~V°|’otü9ùqWØS`1²Î¸4Ë}¥~P™ÔWTlÿ•0„æ2GA”I°5zzk€e÷ýæà>½ôŽ‘-ÿà°ö õ मîŠò{ ¼ƒ…l§¢ÉÀÿn àÝó¨´pqf?x§/…ì1: ¼ýö2Òok§©¬Ú×ÄSÓ>Óyõ³Và%Oí6÷hÞnýÉx.°oÏÈÍœœS/ƒÈïyWMQ®»=ðm&õ~wýT>(K1ù}»|ß“ÓrûïÏ®(ßÈÔL~O1Ú»gü ·ŸL¾‡ölÇô,÷߀çÏôð’÷«Ì‰²×ìeÀ6ëžfnj |­ÀfºY"TÚð[v,Ѓº»—%×nš+Î EéÝÿ^*Ç}éõ¥ñ¯­ÿWÜÿµý¥××Îó¯x_»?_ª÷µœÿÔþOŸïû<¿Vþ·óÿÚyü‹ºä9±Ÿð–3þ9ÎÞèŸÇ±ìgiðYR”üŠ 1) warning(paste("lo.wam convergence not obtained in ", maxit, " iterations")) names(fit$df) <- dimnames(s)[[2]] names(fit$beta) <- labels(x)[[2]] qrx <- structure(list(qr = fit$qr,qraux = fit$qraux, rank = qrank, pivot = fit$qpivot,tol=1e-7),class="qr") effects<-fit$effects r1 <- seq(len = qrx$rank) dn <- colnames(x) if (is.null(dn)) dn <- paste("x", 1:p, sep = "") names(effects) <- c(dn[qrx$pivot[r1]], rep.int("", n - qrx$rank)) rl <- list(coefficients = fit$beta, residuals = fit$y - fit$eta, fitted.values = fit$eta, effects=effects, weights=w, rank=qrank, assign=attr(x,"assign"), qr=qrx, smooth = fit$s, nl.df = fit$df ) rl$df.residual <- n - qrank - sum(rl$nl.df) - sum(fit$w == 0) if(se) rl <- c(rl, list(var = fit$var)) c(list(smooth.frame = smooth.frame), rl) } gam/R/as.anova.R0000644000176000001440000000065011012713777013107 0ustar ripleyusers"as.anova" <- function(df, heading) { if(!inherits(df, "data.frame")) stop("df must be a data frame") attr(df, "heading") <- heading #if the "class" attribute of df already starts with "anova" return(df) if(inherits(df, "anova")) { dfClasses <- attr(df, "class") if(dfClasses[1] == "anova") return(df) } class(df) <- unique(c("anova", class(df))) df } gam/R/as.data.frame.lo.smooth.R0000644000176000001440000000115211012713777015724 0ustar ripleyusers"as.data.frame.lo.smooth" <- function(x, row.names = NULL, optional = FALSE,...) { d <- dim(x) nrows <- d[[1.]] dn <- dimnames(x) row.names <- dn[[1.]] value <- list(x) if(length(row.names)) { row.names <- as.character(row.names) if(length(row.names) != nrows) stop(paste("supplied", length(row.names), "names for a data frame with", nrows, "rows")) } else if(optional) row.names <- character(nrows) else row.names <- as.character(seq(length = nrows)) if(!optional) names(value) <- deparse(substitute(x))[[1.]] attr(value, "row.names") <- row.names oldClass(value) <- "data.frame" value } gam/R/newdata.predict.gam.R0000644000176000001440000000455113236315525015223 0ustar ripleyusers"newdata.predict.Gam" <- function(object, newdata, type = c("link", "response", "terms"), dispersion=NULL, se.fit = FALSE, na.action=na.pass,terms=labels(object), ...) { out.attrs <- attr(newdata, "out.attrs") is.Gam<-inherits(object, "Gam") && !is.null(object$smooth) if(is.Gam) { if(se.fit){ se.fit<-FALSE warning("No standard errors (currently) for gam predictions with newdata") } ##First get the linear predictions type <- match.arg(type) local.type<-type if(type=="response")local.type<-"link" pred<-predict.glm(object,newdata,type=local.type,dispersion=dispersion,se.fit=FALSE,terms=terms) ##Build up the smooth.frame for the new data tt <- terms(object) Terms <- delete.response(tt) smooth.frame <- model.frame(Terms, newdata, na.action = na.action, xlev = object$xlevels) nrows<-nrow(smooth.frame) old.smooth<-object$smooth data<-object$smooth.frame # this was the old smooth frame smooth.labels<-names(data) n.smooths<-length(smooth.labels) if (!is.null(cl <- attr(Terms, "dataClasses"))) .checkMFClasses(cl, smooth.frame) out.attrs <- attr(newdata, "out.attrs") w <- object$weights pred.s <- array(0, c(nrows, n.smooths), list(row.names(smooth.frame), smooth.labels)) smooth.wanted <- smooth.labels[match(smooth.labels, terms, 0) > 0] pred.s<-pred.s[,smooth.wanted,drop=FALSE] residuals <- object$residuals for(TT in smooth.wanted) { Call <- attr(data[[TT]], "call") Call$xeval <- substitute(smooth.frame[[TT]], list(TT = TT)) z <- residuals + object$smooth[, TT] pred.s[, TT] <- eval(Call) } if(type == "terms") pred[, smooth.wanted] <- pred[, smooth.wanted] + pred.s[ , smooth.wanted] else pred <- pred + rowSums(pred.s) if(type == "response") { famob <- family(object) pred <- famob$linkinv(pred) } } else { pred<-predict.glm(object,newdata,type=type,dispersion=dispersion,se.fit=se.fit,terms=terms) } if(type != "terms" && !is.null(out.attrs)) { if(!is.null(out.attrs)) { if(se.fit) { attributes(pred$fit) <- out.attrs attributes(pred$se.fit) <- out.attrs } else attributes(pred) <- out.attrs } } pred } gam/R/random.R0000644000176000001440000000072713271731646012672 0ustar ripleyusers"random" <- function (f, df = NULL, lambda = 0, intercept = TRUE) { scall <- deparse(sys.call()) if (!inherits(f, "factor")) stop("random() expects a factor or category as its first argument") newf=rep(0,length(f)) attr(newf,"values")=f attr(newf, "call") <- substitute(gam.random(data[[scall]], z, w, df = df, lambda = lambda, intercept = intercept)) oldClass(newf) <- "smooth" newf } gam/R/onAttach.R0000644000176000001440000000021213236315525013133 0ustar ripleyusers.onAttach=function(libname,pkgname){ packageStartupMessage("Loaded gam ", as.character(packageDescription("gam")[["Version"]]),"\n") } gam/R/gamlist.R0000644000176000001440000000013513236320226013030 0ustar ripleyusers"Gamlist" <- function(...) { gl <- list(...) oldClass(gl) <- c("Gamlist", "glmlist") gl } gam/R/ylim.scale.R0000644000176000001440000000024111012714000013411 0ustar ripleyusers"ylim.scale" <- function(ylim, scale = 0.) { scale2 <- diff(ylim) if(scale2 < scale) rep(mean(ylim), 2.) + ((ylim - mean(ylim)) * scale)/scale2 else ylim } gam/R/anova.gamlist.R0000644000176000001440000000024013236315525014136 0ustar ripleyusers"anova.Gamlist" <- function(object, ..., test = c("none", "Chisq", "F", "Cp")){ test=match.arg(test) class(object)="glmlist" anova(object, test = test) } gam/R/gplot.numeric.R0000644000176000001440000000276111012713777014174 0ustar ripleyusers"gplot.numeric" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, xlim = NULL, ylim = NULL, fit = TRUE, ...) { if(length(x) != length(y)) stop("x and y do not have the same length; possibly a consequence of an na.action" ) ### Here we check if its a simple linear term; if so, we include a point at the mean of x if(se && !is.null(se.y) && ylab==paste("partial for",xlab)){ x=c(x,mean(x)) y=c(y,0) se.y=c(se.y,0) } ux <- unique(sort(x)) o <- match(ux, x) uy <- y[o] xlim <- range(xlim, ux) ylim <- range(ylim, uy) if(rugplot) { jx <- jitter(x[!is.na(x)]) xlim <- range(c(xlim, jx)) } if(se && !is.null(se.y)) { se.upper <- uy + 2 * se.y[o] se.lower <- uy - 2 * se.y[o] ylim <- range(c(ylim, se.upper, se.lower)) } if(!is.null(residuals)) { if(length(residuals) == length(y)) { residuals <- y + residuals ylim <- range(c(ylim, residuals)) } else { residuals <- NULL warning(paste("Residuals do not match x in \"", ylab, "\" preplot object", sep = "")) } } ylim <- ylim.scale(ylim, scale) if(!is.null(residuals)) { plot(x, residuals, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, ...) if(fit) lines(ux, uy) } else { if(fit) plot(ux, uy, type = "l", xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, ...) } if(rugplot) rug(jx) if(se) { lines(ux, se.upper, lty = 3) lines(ux, se.lower, lty = 3) } invisible(diff(ylim)) } gam/R/gam.nlchisq.R0000644000176000001440000000023611012713777013605 0ustar ripleyusers"gam.nlchisq" <- function(qr, resid, w, s) { wt <- sqrt(w) s <- s * wt resid <- wt * resid Rsw <- qr.resid(qr, s) apply(Rsw^2 + 2 * s * resid, 2, sum) } gam/R/general.wam.R0000644000176000001440000000561212524243303013574 0ustar ripleyusers"general.wam" <- function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE, se = TRUE, ...) { if(inherits(smooth.frame, "data.frame")) { data <- smooth.frame ### Note; the lev component of the smooths is the diagonal hat matrix elements ### for the NONLINEAR part of the fit. ###The smoother can return both the linear and nonlinear parts, although only ### the nonlinear part is strictly necessary. ### oldClass(data) <- NULL names.calls <- names(which) smooth.calls <- lapply(data[names.calls], attr, "call") names(smooth.calls) <- names.calls smooth.frame <- list(data = data, smooth.calls = smooth.calls) } else { data <- smooth.frame$data smooth.calls <- smooth.frame$smooth.calls } names.calls <- names(smooth.calls) y <- as.vector(y) residuals <- as.vector(y - s %*% rep(1., ncol(s))) n <- length(y) fit <- list(fitted.values = 0.) rss <- weighted.mean(residuals^2., w) rssold <- rss * 10. nit <- 0. df <- rep(NA, length(which)) var <- s if(trace) cat("\nWAM iter rss/n term\n") ndig <- - log10(tol) + 1. RATIO <- tol + 1. while(RATIO > tol & nit < maxit) { rssold <- rss nit <- nit + 1. z <- residuals + fit$fitted.values fit <- lm.wfit(x, z, w, method = "qr", singular.ok = TRUE, ...) residuals <- fit$residuals rss <- weighted.mean(residuals^2., w) if(trace) cat("\n ", nit, " ", format(round(rss, ndig)), " Parametric -- lm.wfit\n", sep = "") deltaf <- 0. for(j in seq(names.calls)) { old <- s[, j] z <- residuals + s[, j] fit.call <- eval(smooth.calls[[j]]) residuals <- as.double(fit.call$residuals) if(length(residuals) != n) stop(paste(names.calls[j], "returns a vector of the wrong length") ) s[, j] <- z - residuals deltaf <- deltaf + weighted.mean((s[, j] - old)^2., w) rss <- weighted.mean(residuals^2., w) if(trace) { cat(" ", nit, " ", format(round( rss, ndig)), " Nonparametric -- ", names.calls[j], "\n", sep = "") } df[j] <- fit.call$nl.df if(se) var[, j] <- fit.call$var } RATIO <- sqrt(deltaf/sum(w * apply(s, 1., sum)^2.)) if(trace) cat("Relative change in functions:", format(round( RATIO, ndig)), "\n") } if((nit == maxit) & maxit > 1.) warning(paste("general.wam convergence not obtained in ", maxit, " iterations")) names(df) <- names.calls if(trace) cat("\n") fit$fitted.values <- y - residuals rl <- c(fit, list(smooth = s, nl.df = df)) rl$df.residual <- rl$df.residual - sum(df) if(se) rl <- c(rl, list(var = var)) c(list(smooth.frame = smooth.frame), rl) } gam/R/gam.scope.R0000644000176000001440000000103211012713777013250 0ustar ripleyusers"gam.scope" <- function(frame, response = 1, smoother = "s", arg = NULL, form = TRUE) { vnames <- names(frame) vnames <- vnames[ - response] step.list <- as.list(vnames) names(step.list) <- vnames for(vname in vnames) { junk <- c("1", vname) if(is.vector(frame[[vname]])) junk <- c(junk, paste(smoother, "(", vname, if(is.null( arg)) ")" else paste(",", arg, ")", sep = ""), sep = "")) if(form) junk <- eval(parse(text = paste("~", paste(junk, collapse = "+")))) step.list[[vname]] <- junk } step.list } gam/R/plot.gam.R0000644000176000001440000000651613236315525013130 0ustar ripleyusers"plot.Gam" <- function(x, residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, ask = FALSE, terms=labels.Gam(x), ...) { if(!is.null(x$na.action)) x$na.action <- NULL preplot.object <- x$preplot if(is.null(preplot.object)) preplot.object <- preplot.Gam(x,terms=terms) x$preplot <- preplot.object Residuals <- resid(x) if(!is.null(residuals)) { if(length(residuals) == 1) if(residuals) residuals <- Residuals else residuals <- NULL else Residuals <- residuals } if(!ask) { plot.preplot.Gam(preplot.object, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = TRUE, ...) invisible(x) } else{ nterms <- names(preplot.object) tterms <- substring(nterms, 1, 40) #truncate long names residualsmenu <- if(!is.null(residuals)) "residuals off" else "residuals on" rugmenu <- if(rugplot) "rug off" else "rug on" semenu <- if(se) "se off" else "se on" scalemenu <- paste("scale (", round(scale, 1), ")", sep = "") scales <- numeric() tmenu <- c(paste("plot:", tterms), "plot all terms", residualsmenu, rugmenu, semenu, scalemenu) tnames <- character() pick <- 1 while(pick > 0 && pick <= length(tmenu)) { pick <- menu(tmenu, title = "Make a plot selection (or 0 to exit):\n") if(pick > 0 && pick <= length(nterms)) { tscale <- plot.preplot.Gam(preplot.object[[pick]], residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = TRUE, ...) names(tscale) <- nterms[pick] scales <- c(scales, tscale) cat("Plots performed:\n ") print(scales) } else switch(pick - length(nterms), { scales <- plot.preplot.Gam( preplot.object, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = TRUE, ...) print(scales) } , { residuals <- if(is.null(residuals)) Residuals else NULL residualsmenu <- if(!is.null(residuals) ) "residuals off" else "residuals on" } , { rugplot <- !rugplot rugmenu <- if(rugplot) "rug off" else "rug on" } , { se <- !se semenu <- if(se) "se off" else "se on" } , { cat("Type in a new scale\n") scale <- eval(parse(n=1)) scalemenu <- paste("scale (", round( scale, 1), ")", sep = "") } , invisible(return(x))) tmenu <- c(paste("plot:", tterms), "plot all terms", residualsmenu, rugmenu, semenu, scalemenu) } invisible(x) } } gam/R/gam.fit.R0000644000176000001440000001273013075273743012735 0ustar ripleyusers"gam.fit" <- function (x, y, smooth.frame, weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(), control = gam.control()) { ynames <- if (is.matrix(y)) dimnames(y)[[1]] else names(y) xnames <- dimnames(x)[[2]] nobs <- NROW(y) nvars <- ncol(x) maxit <- control$maxit bf.maxit <- control$bf.maxit epsilon <- control$epsilon bf.epsilon <- control$bf.epsilon trace <- control$trace digits <- -log10(epsilon) + 1 if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) variance <- family$variance dev.resids <- family$dev.resids aic <- family$aic linkinv <- family$linkinv mu.eta <- family$mu.eta if (!is.function(variance) || !is.function(linkinv)) stop("illegal `family' argument") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE eval(family$initialize) if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } eta <- if (!is.null(etastart)) etastart else if (!is.null(start)) if (length(start) != nvars) stop("Length of start should equal ", nvars, " and correspond to initial coefs for ", deparse(xnames)) else { coefold <- start offset + as.vector(if (NCOL(x) == 1) x * start else x %*% start) } else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("Can't find valid starting values: please specify some") new.dev <- sum(dev.resids(y, mu, weights)) a <- attributes(attr(smooth.frame, "terms")) smoothers <- a$specials if (length(smoothers) > 0) { smoothers <- smoothers[sapply(smoothers, length) > 0] for (i in seq(along = smoothers)) { tt <- smoothers[[i]] ff <- apply(a$factors[tt, , drop = FALSE], 2, any) smoothers[[i]] <- if (any(ff)) seq(along = ff)[a$order == 1 & ff] else NULL } } if (length(smoothers) > 0) { gam.wlist=gam.smoothers()$wlist smooth.labels <- a$term.labels[unlist(smoothers)] assignx <- attr(x, "assign") assignx <- assign.list(assignx, a$term.labels) which <- assignx[smooth.labels] if (length(smoothers) > 1) bf <- "general.wam" else { sbf <- match(names(smoothers), gam.wlist, FALSE) bf <- if (sbf) paste(gam.wlist[sbf], "wam", sep = ".") else "general.wam" } bf.call <- parse(text = paste(bf, "(x, z, wz, fit$smooth, which, fit$smooth.frame,bf.maxit,bf.epsilon, trace)", sep = ""))[[1]] s <- matrix(0, length(y), length(which)) dimnames(s) <- list(names(y), names(which)) fit <- list(smooth = s, smooth.frame = smooth.frame) } else { bf.call <- expression(lm.wfit(x, z, wz, method = "qr", singular.ok = TRUE)) bf <- "lm.wfit" } old.dev <- 10 * new.dev + 10 for (iter in 1:maxit) { good <- weights > 0 varmu <- variance(mu) if (any(is.na(varmu[good]))) stop("NAs in V(mu)") if (any(varmu[good] == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) z <- eta - offset z[good] <- z[good] + (y - mu)[good]/mu.eta.val[good] wz <- weights wz[!good] <- 0 wz[good] <- wz[good] * mu.eta.val[good]^2/varmu[good] fit <- eval(bf.call) eta <- fit$fitted.values + offset mu <- linkinv(eta) old.dev <- new.dev new.dev <- sum(dev.resids(y, mu, weights)) if (trace) cat("GAM ", bf, " loop ", iter, ": deviance = ", format(round(new.dev, digits)), " \n", sep = "") if (is.na(new.dev)) { one.more <- FALSE warning("iterations terminated prematurely because of singularities") } else one.more <- abs(old.dev - new.dev)/(old.dev + 0.1) > epsilon if (!one.more) break } fitqr <- fit$qr xxnames <- xnames[fitqr$pivot] nr <- min(sum(good), nvars) if (nr < nvars) { Rmat <- diag(nvars) Rmat[1:nr, 1:nvars] <- fitqr$qr[1:nr, 1:nvars] } else Rmat <- fitqr$qr[1:nvars, 1:nvars] Rmat <- as.matrix(Rmat) Rmat[row(Rmat) > col(Rmat)] <- 0 dimnames(Rmat) <- list(xxnames, xxnames) names(fit$residuals) <- ynames names(mu) <- ynames names(eta) <- ynames fit$additive.predictors <- eta fit$fitted.values <- mu names(fit$weights) <- ynames names(fit$effects) <- c(xxnames[seq(len = fitqr$rank)], rep.int("", sum(good) - fitqr$rank)) if (length(fit$smooth) > 0) fit$smooth.frame <- smooth.frame[smooth.labels] wtdmu <- if (a$intercept) sum(weights * y)/sum(weights) else linkinv(offset) nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(a$intercept) rank <- n.ok - fit$df.residual aic.model <- aic(y, nobs, mu, weights, new.dev) + 2 * rank if (!is.null(fit$smooth)) { nonzeroWt <- (wz > 0) nl.chisq <- gam.nlchisq(fit$qr, fit$residuals, wz, fit$smooth) } else nl.chisq <- NULL fit <- c(fit, list(R = Rmat, rank = fitqr$rank, family = family, deviance = new.dev, aic = aic.model, null.deviance = nulldev, iter = iter, prior.weights = weights, y = y, df.null = nulldf, nl.chisq = nl.chisq)) fit } gam/R/anova.gam.R0000644000176000001440000000037413236315525013252 0ustar ripleyusers"anova.Gam" <- function(object, ..., test = c("Chisq", "F", "Cp")) { test=match.arg(test) margs <- function(...) nargs() if(margs(...)) anova(structure(list(object, ...),class="glmlist"), test = test) else summary.Gam(object)$anova } gam/R/gam.s.R0000644000176000001440000000313513074257710012407 0ustar ripleyusers"gam.s" <- function(x, y, w = rep(1, length(x)), df = 4, spar = 1, xeval) { storage.mode(x) <- storage.mode(y) <- storage.mode(w) <- storage.mode( spar) <- storage.mode(df) <- "double" n <- as.integer(length(x)) x <- signif(x, 6) mat <- gam.match(x) omat <- mat$o nef <- mat$nef ## ## in rgam.r, splsm calls both splsm1 and splsm2. ## splsm2 needs (10+2*4)*(nef+2)+5*nef+n+15 doubles for work. ## splsm1 needs 3*nef+2*n+10. work.len <- max(3 * nef + 2 * n + 10, (10 + 2 * 4) * (nef + 2) + 5 * nef + n + 15) fit <- .Fortran("splsm", x, y, w, n, omat, nef, spar = spar, df = df, s = double(n), s0 = double(1), var = double(nef), FALSE, work = double(work.len), PACKAGE="gam") if(missing(xeval)) list(residuals = y - fit$s, nl.df = fit$df - 1, var = fit$ var[omat]) else { skn <- .Fortran("sknotl", fit$work[seq(nef)], nef, knot = double(nef + 6), k = integer(1), PACKAGE="gam") smallest <- x[omat == 1][1] largest <- x[omat == nef][1] k <- skn$k gam.sp(xeval, skn$knot[seq(k)], k - 4, fit$work[seq(3 * nef + n + 10, length = k - 4)], smallest, largest - smallest) } } gam/R/plot.preplot.gam.R0000644000176000001440000000150513236315525014605 0ustar ripleyusers"plot.preplot.Gam" <- function(x, y = NULL, residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, fit = TRUE, ...) { listof <- inherits(x[[1]], "preplot.Gam") if(listof) { TT <- names(x) scales <- rep(0, length(TT)) names(scales) <- TT for(i in TT) scales[i] <- plot.preplot.Gam(x[[i]], y = NULL, residuals, rugplot, se, scale, fit, ...) # scales[i] <- UseMethod("plot",x[[i]]) invisible(scales) } else { dummy <- function(residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, fit = TRUE, ...) c(list(residuals = residuals, rugplot = rugplot, se = se, scale = scale, fit = fit), list(...)) d <- dummy(residuals, rugplot, se, scale, fit, ...) uniq.comps <- unique(c(names(x), names(d))) Call <- c(as.name("gplot"), c(d, x)[uniq.comps]) mode(Call) <- "call" invisible(eval(Call)) } } gam/R/lo.R0000644000176000001440000000330211664767363012025 0ustar ripleyuserslo <- function (..., span = 0.5, degree = 1) { vars <- list(...) locall <- sys.call() chcall <- deparse(locall) nvars <- length(vars) if (degree > 2) stop("degrees 1 or 2 are implemented") if (nvars == 1) { xvar <- as.matrix(vars[[1]]) xnames <- deparse(locall[[2]]) if(is.null(dimnames(xvar)[[2]])){ nc=ncol(xvar) dxnames=xnames if(nc>1)dxnames=paste(xnames,1:nc,sep=".") dimnames(xvar)=list(NULL,dxnames) } } else { nobs <- length(vars[[1]]) xvar <- matrix(0, nobs, nvars) xnames <- character(nvars) for (i in seq(nvars)) { tt <- vars[[i]] if (!is.null(dd <- dim(tt)) && dd[2] > 1) stop("either call lo with a matrix argument, or else a comma separated list x1, x2") exptt <- locall[[i + 1]] xnames[i] <- deparse(exptt) xvar[, i] <- as.numeric(tt) } dimnames(xvar) <- list(NULL, xnames) } polyx <- polylo(xvar, degree = degree) pd <- attr(polyx, "degree") opd <- order(pd) if (length(pd) > 1) { polyx <- polyx[, opd] p <- sum(pd == 1) } else p <- 1 nobs <- dim(polyx)[1] nas <- is.na(polyx[, 1:p]) if (any(nas)) { if (p > 1) nas <- nas %*% array(1, c(p, 1)) attr(polyx, "NAs") <- seq(nobs)[nas > 0] } real.call <- substitute(gam.lo(data[[chcall]], z, w, span = span, degree = degree, ncols = p), list(span = span, degree = degree, chcall = chcall, p = p)) atts <- c(attributes(polyx), list(span = span, degree = degree, ncols = p, call = real.call)) attributes(polyx) <- atts class(polyx) <- c("smooth", "matrix") polyx } gam/R/na.gam.replace.R0000644000176000001440000000246713116644007014160 0ustar ripleyusersna.gam.replace <- function (frame) { vars <- names(frame) ##See if there is a response if(!is.null(tt <- attr(frame, "terms"))){ if (0 < (resp <- attr(tt, "response"))) { vars <- vars[-resp] x <- frame[[resp]] pos <- is.na(x) if (any(pos)) { frame <- frame[!pos, , drop = FALSE] warning(paste(sum(pos), "observations omitted due to missing values in the response")) } } } for (j in vars) { x <- frame[[j]] pos <- is.na(x) if (any(pos)) { if (length(levels(x))) { xx <- as.character(x) xx[pos] <- "NA" x <- factor(xx, exclude = NULL) } else if (is.matrix(x)) { ats <- attributes(x) w <- !pos x[pos] <- 0 n <- nrow(x) TT <- array(1, c(1, n)) xbar <- (TT %*% x)/(TT %*% w) xbar <- t(TT) %*% xbar x[pos] <- xbar[pos] attributes(x) <- ats } else { ats <- attributes(x) x[pos] <- mean(x[!pos]) attributes(x) <- ats } frame[[j]] <- x } } frame } gam/R/gam.R0000644000176000001440000000653413236315525012153 0ustar ripleyusers"gam" <- function(formula, family = gaussian, data, weights, subset, na.action, start = NULL, etastart, mustart, control = gam.control(...), model = TRUE, method="glm.fit", x = FALSE, y = TRUE, ...) { call <- match.call() if (is.character(family)) family <- get(family, mode = "function", envir = parent.frame()) if (is.function(family)) family <- family() if (is.null(family$family)) { print(family) stop("`family' not recognized") } if (missing(data)) data <- environment(formula) mf <- match.call(expand.dots = FALSE) ## m <- match(c("formula", "data", "subset", "weights", "na.action", ## "etastart", "mustart", "offset"), names(mf), 0L) m <- match(c("formula", "data", "subset", "weights", "etastart", "mustart", "offset"), names(mf), 0L) mf <- mf[c(1L, m)] mf$na.action=quote(na.pass)## need to do this because model frame is not subsetting properly mf$drop.unused.levels <- TRUE mf[[1L]] <- quote(stats::model.frame) gam.slist <- gam.smoothers()$slist mt <- if(missing(data)) terms(formula, gam.slist) else terms(formula,gam.slist,data = data) mf$formula<-mt mf <- eval(mf, parent.frame()) if(missing(na.action)){ naa=getOption("na.action","na.fail") na.action=get(naa) } mf=na.action(mf)###because this was not done properly before mt=attributes(mf)[["terms"]]# the predvars are added here, while not before switch(method, model.frame = return(mf), glm.fit = 1, glm.fit.null = 1, stop("invalid `method': ", method)) Y <- model.response(mf, "any") X <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else matrix(, NROW(Y), 0) weights <- model.weights(mf) offset <- model.offset(mf) if (!is.null(weights) && any(weights < 0)) stop("Negative wts not allowed") if (!is.null(offset) && length(offset) != NROW(Y)) stop("Number of offsets is ", length(offset), ", should equal ", NROW(Y), " (number of observations)") mustart <- model.extract(mf, "mustart") etastart <- model.extract(mf, "etastart") fit<-gam.fit(x=X,y=Y,smooth.frame=mf,weights=weights,start=start, etastart=etastart,mustart=mustart, offset=offset,family=family,control=control) ### If both an offset and intercept are present, iterations are needed to ### compute the Null deviance; these are done here ### if(length(offset) && attr(mt, "intercept")>0) { fit$null.dev <- glm.fit(x = X[, "(Intercept)", drop = FALSE], y = Y, weights = weights, offset = offset, family = family, control = control[c("epsilon","maxit","trace")], intercept = TRUE)$deviance } if(model) fit$model <- mf fit$na.action <- attr(mf, "na.action") if(x) fit$x <- X if(!y) fit$y <- NULL fit <- c(fit, list(call = call, formula = formula, terms = mt, data = data, offset = offset, control = control, method = method, contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt, mf))) class(fit) <- c("Gam","glm", "lm") if(!is.null(fit$df.residual) && !(fit$df.residual > 0)) warning("Residual degrees of freedom are negative or zero. This occurs when the sum of the parametric and nonparametric degrees of freedom exceeds the number of observations. The model is probably too complex for the amount of data available." ) fit } gam/R/print.stepanova.R0000644000176000001440000000104512176002721014523 0ustar ripleyusers"print.stepanova"<- function(x, digits = .Options$digits, quote = F, drop = F, ...) { heading <- attr(x, "heading") if(!is.null(heading)) cat(heading, sep = "\n") attr(x, "heading") <- NULL d <- dim(x) for(i in 1:d[2]) { xx <- x[[i]] if(!length(levels(xx)) && is.numeric(xx)) { xna <- is.na(xx) xx <- format(zapsmall(xx, digits)) xx[xna] <- "" x[[i]] <- xx } } if(d[1] == 1 && drop) { x <- t(as.matrix(x)) dn <- dimnames(x) dn <- paste(dn[[1]], ":", sep = "") dimnames(x) <- list(dn, "") } NextMethod("print") } gam/R/step.gam.R0000644000176000001440000001607713236315525013130 0ustar ripleyusersstep.Gam <- function (object, scope, scale, direction = c("both", "backward", "forward"), trace = TRUE, keep = NULL, steps = 1000, parallel=FALSE,...) { trace=as.numeric(trace) get.visit <- function(trial, visited){ match(paste(trial,collapse=""),apply(visited,2,paste,collapse=""),FALSE) } deviancelm <- function(object, ...) if(is.null(w <- object$weights)) sum(object$residuals^2) else sum(w * object$ residuals^2) scope.char <- function(formula) { formula = update(formula, ~-1 + .) tt <- terms(formula) tl <- attr(tt, "term.labels") if (attr(tt, "intercept")) c("1", tl) else tl } re.arrange <- function(keep) { namr <- names(k1 <- keep[[1]]) namc <- names(keep) nc <- length(keep) nr <- length(k1) array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr, namc)) } untangle.scope <- function(terms, regimens) { a <- attributes(terms) response <- deparse(a$variables[[2]]) term.labels <- a$term.labels if (!is.null(a$offset)) { off1 <- deparse(a$variables[[a$offset]]) } nt <- length(regimens) select <- integer(nt) for (i in seq(nt)) { j <- match(regimens[[i]], term.labels, 0) if (any(j)) { if (sum(j > 0) > 1) stop(paste("The elements of a regimen", i, "appear more than once in the initial model", sep = " ")) select[i] <- seq(j)[j > 0] term.labels <- term.labels[-sum(j)] } else { if (!(j <- match("1", regimens[[i]], 0))) stop(paste("regimen", i, "does not appear in the initial model", sep = " ")) select[i] <- j } } if (length(term.labels)) term.labels <- paste(term.labels, "+") if (!is.null(a$offset)) term.labels <- paste(off1, term.labels, sep = " + ") return(list(response = paste(response, term.labels, sep = " ~ "), select = select)) } make.step <- function(models, fit, scale, object) { chfrom <- sapply(models, "[[", "from") chfrom[chfrom == "1"] <- "" chto <- sapply(models, "[[", "to") chto[1]="" chto[chto == "1"] <- "" dev <- sapply(models, "[[", "deviance") df <- sapply(models, "[[", "df.resid") ddev <- c(NA, diff(dev)) ddf <- c(NA, diff(df)) AIC <- sapply(models, "[[", "AIC") heading <- c("Stepwise Model Path \nAnalysis of Deviance Table", "\nInitial Model:", deparse(as.vector(formula(object))), "\nFinal Model:", deparse(as.vector(formula(fit))), paste("\nScale: ", format(scale), "\n", sep = "")) # rowns=paste(chfrom,chto,sep=" -> ") # rowns[1]="" # rowns=paste(seq(rowns)-1,rowns,sep=": ") aod <- data.frame(From=chfrom,To=chto, Df = ddf, Deviance = ddev, `Resid. Df` = df, `Resid. Dev` = dev, AIC = AIC, check.names = FALSE) aod <- as.anova(aod, heading) class(aod)=c("stepanova","data.frame") fit$anova=aod fit } direction <- match.arg(direction) if (missing(scope)) stop("you must supply a scope argument to step.Gam(); the gam.scope() function might be useful") if (!is.character(scope[[1]])) scope <- lapply(scope, scope.char) response <- untangle.scope(object$terms, scope) form.y <- response$response backward <- direction == "both" | direction == "backward" forward <- direction == "both" | direction == "forward" items <- response$select family <- family(object) Call <- object$call term.lengths <- sapply(scope, length) n.items <- length(items) visited <- matrix(items) form.vector <- character(n.items) for (i in seq(n.items)) form.vector[i] <- scope[[i]][items[i]] form <- deparse(object$formula) if (trace>0) cat("Start: ", form) fit <- object n <- length(fit$fitted) if (missing(scale)) { famname <- family$family["name"] scale <- switch(famname, Poisson = 1, Binomial = 1, deviancelm(fit)/fit$df.resid) } else if (scale == 0) scale <- deviancelm(fit)/fit$df.resid bAIC <- fit$aic if (trace>0) cat("; AIC=", format(round(bAIC, 4)), "\n") models <- list( list(deviance = deviance(fit), df.resid = fit$df.resid, AIC = bAIC, from = "", to = "") ) if (!is.null(keep)) { keep.list <- list(keep(fit,...)) keep.it=TRUE} else keep.it=FALSE AIC <- bAIC + 1 stepnum=0 while (bAIC < AIC & steps > 0) { steps <- steps - 1 stepnum=stepnum+1 AIC <- bAIC form.list=NULL ###First some prelimenaries to see what formulas to try for (i in seq(n.items)) { if (backward) { trial <- items trial[i] <- trial[i] - 1 if (trial[i] > 0 && !get.visit(trial,visited)) { visited<-cbind(visited,trial) tform.vector <- form.vector tform.vector[i] <- scope[[i]][trial[i]] form.list=c(form.list,list(list(trial=trial, form.vector=tform.vector, which=i))) } } if (forward) { trial <- items trial[i] <- trial[i] + 1 if (trial[i] <= term.lengths[i] && !get.visit(trial,visited)){ visited<-cbind(visited,trial) tform.vector <- form.vector tform.vector[i] <- scope[[i]][trial[i]] form.list=c(form.list,list(list(trial=trial, form.vector=tform.vector, which=i))) } } } if(is.null(form.list))break ### Now we are ready for the expensive loop ### Parallel is set up #if(parallel&&require(foreach)){ if(parallel){ # step.list=foreach(i=1:length(form.list),.inorder=FALSE,.packages="gam",.verbose=trace>1)%dopar% step.list=foreach(i=1:length(form.list),.inorder=FALSE,.verbose=trace>1)%dopar% { tform=paste(form.y, paste(form.list[[i]]$form.vector, collapse = " + ")) update(object, eval(parse(text = tform)),trace = FALSE, ...) } } ### No parallel else { step.list=as.list(sequence(length(form.list))) for(i in 1:length(form.list)){ tform=paste(form.y, paste(form.list[[i]]$form.vector, collapse = " + ")) step.list[[i]]=update(object, eval(parse(text = tform)),trace = FALSE, ...) if(trace>1)cat("Trial: ", tform,"; AIC=", format(round(step.list[[i]]$aic, 4)), "\n") } } ### end expensive loop taic.vec=sapply(step.list,"[[","aic") if(keep.it) keep.list=c(keep.list, lapply(step.list,keep,...)) bAIC=min(taic.vec) if (bAIC >= AIC | steps == 0) { if (keep.it) fit$keep <- re.arrange(keep.list) return(make.step(models, fit, scale, object)) } else { o1=order(taic.vec)[1] fit=step.list[[o1]] form.list=form.list[[o1]] bwhich=form.list$which bfrom=form.vector[bwhich] form.vector=form.list$form.vector #this is the new one bto=form.vector[bwhich] if (trace>0) cat(paste("Step:",stepnum,sep=""), deparse(fit$formula), "; AIC=", format(round(bAIC, 4)), "\n") items <- form.list$trial models <- c(models,list(list(deviance = deviance(fit), df.resid = fit$df.resid, AIC = bAIC, from = bfrom, to = bto))) } } } gam/R/gam.match.R0000644000176000001440000000231711012713777013242 0ustar ripleyusers"gam.match" <- function(x) { if(is.list(x)) { junk <- Recall(x[[1]]) if((nvar <- length(x)) == 1) return(list(o = junk$o, nef = junk$nef)) else { o <- matrix(junk$o, length(junk$o), nvar) nef <- rep(junk$nef, nvar) for(i in 2:nvar) { junk <- Recall(x[[i]]) o[, i] <- junk$o nef[i] <- junk$nef } names(nef) <- nn <- names(x) dimnames(o) <- list(NULL, nn) return(list(o = o, nef = nef)) } } if(is.matrix(x)) { ats <- attributes(x) a <- ats$NAs ncols <- ats$ncols d <- dim(x) if(is.null(ncols)) ncols <- d[2] if(ncols == 1) return(Recall(structure(x[, 1, drop = TRUE], NAs = a))) if(is.null(a)) { o <- seq(d[1]) nef <- d[1] } else { nef <- d[1] - length(a) o <- rep(nef + 1, d[1]) o[ - a] <- seq(nef) } return(list(o = as.integer(o), nef = as.integer(nef))) } else { a <- attributes(x)$NAs if(!is.null(a)) x[a] <- NA xr <- signif(as.vector(x), 6) sx <- unique(sort(xr)) nef <- as.integer(length(sx)) if(nef <= 3) stop("A smoothing variable encountered with 3 or less unique values; at least 4 needed" ) o <- match(xr, sx, nef + 1) o[is.na(o)] <- nef + 1 return(list(o = as.integer(o), nef = as.integer(nef))) } } gam/R/assign.list.R0000644000176000001440000000033011012713777013632 0ustar ripleyusersassign.list<-function(assignx,term.labels){ ass<-as.list(seq(term.labels)) names(ass)<-term.labels indexset<-seq(along=assignx) lapply(ass,function(i,indexset,assignx)indexset[assignx==i],indexset,assignx) } gam/R/gplot.list.R0000644000176000001440000000073511012713777013504 0ustar ripleyusers"gplot.list" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, fit = TRUE, ...) { if(length(x) != 2) { warning(paste("A perspective plot was requested for \"", ylab, "\" but the \"x\" variable has dimension other than 2", sep = "")) invisible(return(0)) } names(x) <- xlab x <- data.matrix(data.frame(x)) # UseMethod("gplot") gplot.matrix(x, y, se.y, xlab, ylab, residuals, rugplot, scale, se, fit, ...) } gam/R/gam.sp.R0000644000176000001440000000207011012713777012564 0ustar ripleyusers"gam.sp" <- function(x, knots, nknots, coef, smallest, scale) { nas <- is.na(x) xs <- as.double((x[!nas] - smallest)/scale) bad.left <- xs < 0 bad.right <- xs > 1 good <- !(bad.left | bad.right) y <- xs if(any(good)) { junk <- .Fortran("bvalus", as.integer(sum(good)), knots, coef, as.integer(nknots), xs[good], s = double(sum(good)), as.integer(0), PACKAGE="gam") y[good] <- junk$s } if(any(!good)) { end.fit <- .Fortran("bvalus", as.integer(2), knots, coef, as.integer(nknots), as.double(c(0, 1)), s = double(2), as.integer(0), PACKAGE="gam")$s end.slopes <- .Fortran("bvalus", as.integer(2), knots, coef, as.integer(nknots), as.double(c(0, 1)), s = double(2), as.integer(1), PACKAGE="gam")$s if(any(bad.left)) y[bad.left] <- end.fit[1] + end.slopes[1] * (xs[ bad.left]) if(any(bad.right)) y[bad.right] <- end.fit[2] + end.slopes[2] * (xs[ bad.right] - 1) } pred <- x * 0 pred[!nas] <- y pred } gam/R/predict.gam.R0000644000176000001440000000461213236315525013577 0ustar ripleyusers"predict.Gam" <- function(object, newdata, type = c("link", "response", "terms"), dispersion=NULL, se.fit = FALSE, na.action=na.pass, terms = labels(object),...) { type <- match.arg(type) if(missing(newdata)) { if(inherits(object, "Gam") && !is.null(object$smooth)) { if(se.fit) switch(type, response = { out <- predict.Gam(object, type = "link", se.fit = TRUE, ...) famob <- family(object) out$se.fit <- drop(out$se.fit*abs(famob$mu.eta(out$fit))) out$fit <- fitted(object) out } , link = { out <- NextMethod("predict") out$fit <- object$additive.predictors TS <- out$residual.scale^2 TT <- ncol(object$var) out$se.fit <- sqrt(out$se.fit^ 2 + TS * object$var %*% rep(1, TT)) out } , terms = { out <- NextMethod("predict") TT <- dimnames(s <- object$smooth)[[2]] TT=intersect(terms,TT)##added to protect subsets out$fit[, TT] <- out$fit[, TT] + s[,TT] TS <- out$residual.scale^2 out$se.fit[, TT] <- sqrt(out$ se.fit[, TT]^2 + TS * object$var[,TT]) out } ) else switch(type, terms = { out <- NextMethod("predict") TT <- dimnames(s <- object$smooth)[[2]] TT=intersect(terms,TT)##added to protect subsets out[, TT] <- out[, TT] + s[,TT] out } , link = object$additive.predictors, response = object$fitted) } else { if(inherits(object, "Gam")) { if(type == "link" && !se.fit) object$additive.predictors else NextMethod("predict") } else UseMethod("predict") } } else newdata.predict.Gam(object, newdata, type, dispersion,se.fit, na.action, terms, ...) } gam/R/gplot.matrix.R0000644000176000001440000000256112524236043014027 0ustar ripleyusers"gplot.matrix" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, fit, ...) { if(ncol(x) != 2) { warning(paste("A perspective plot was requested for \"", ylab, "\" but the \"x\" variable has dimension other than 2", sep = "")) invisible(return(0)) } bivar.dup <- function(x) { if(is.null(dx <- dim(x)) || dx[2] > 2) stop("x must be bivariate") duplicated(x[, 1] + (1i) * x[, 2]) } # interp.loaded<-require("akima") interp.loaded<-TRUE # if(!interp.loaded) xname <- dimnames(x)[[2]] dups <- bivar.dup(x) if (requireNamespace("akima", quietly = TRUE)) { xyz <- akima::interp(x[!dups, 1], x[!dups, 2], y[!dups]) } else { stop("You need to install the package 'akima' from the R contributed libraries to use this plotting method for bivariate functions") } zmin <- min(xyz$z[!is.na(xyz$z)]) z <- ifelse(is.na(xyz$z), zmin, xyz$z) scale2 <- diff(range(z)) # Adjust scale scale <- max(scale, scale2) # persp(xyz$x, xyz$y, (z - zmin)/scale, xlab = xname[1], ylab = xname[ # 2], zlab = ylab, ...) persp(xyz$x, xyz$y, z, xlab = xname[1], ylab = xname[2], zlab = ylab, ...) invisible(scale) } gam/R/gam.random.R0000644000176000001440000000175413076246340013431 0ustar ripleyusers"gam.random" <- function(f, y, w, df = sum(non.zero), lambda = 0,intercept=TRUE, xeval) { df.inv <- function(n, df, lambda = sum(n)/df - mean(n), iterations = 10 ) { if(df > length(n)) return(0) current.df <- sum(n/(n + lambda)) if(abs((df - current.df)/df) < 0.0001 | iterations == 1) lambda else { lambda <- exp(log(lambda) + (current.df - df)/(sum(( n * lambda)/(n + lambda)^2))) Recall(n, df, lambda, iterations - 1) } } f=attr(f,"values") nw <- tapply(w, f, sum) non.zero <- !is.na(nw) if(is.null(df)) df <- sum(non.zero) if(lambda == 0) lambda <- df.inv(nw[non.zero], df) df <- sum(nw[non.zero]/(nw[non.zero] + lambda)) fit <- tapply(w * y, f, sum)/(nw + lambda) if(intercept)fit=fit-mean(fit) var <- as.vector(w/(nw[f] + lambda)) residuals <- as.vector(y - fit[f]) if(missing(xeval)) list(x = seq(along = nw), y = fit, residuals = residuals, var = var, nl.df = df, lambda = lambda) else fit[xeval] } gam/R/s.wam.R0000644000176000001440000000522312515157141012423 0ustar ripleyusers"s.wam" <- function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE, se = TRUE, ...) { if(is.data.frame(smooth.frame)) { first <- TRUE # first call to wam; set up some things #on first entry, smooth.frame is a data frame with elements the terms to be #smoothed in which data <- smooth.frame[, names(which), drop = FALSE] smooth.frame <- gam.match(data) dx <- as.integer(dim(x)) smooth.frame$n <- dx[1] smooth.frame$p <- dx[2] oldClass(data) <- NULL smooth.frame$spar <- unlist(lapply(data, attr, "spar")) smooth.frame$df <- unlist(lapply(data, attr, "df")) } else first <- FALSE storage.mode(tol) <- "double" storage.mode(maxit) <- "integer" which <- unlist(which) storage.mode(which) <- "integer" storage.mode(y) <- "double" storage.mode(w) <- "double" p <- smooth.frame$p n <- smooth.frame$n ### Need to do the signif hack on the which columns of x for(ich in which)x[,ich]=signif(x[,ich],6) ### fit <- .Fortran("bakfit", x, npetc = as.integer(c(n, p, length(which), se, 0, maxit, 0)), y = y, w = w, which, spar = as.double(smooth.frame$spar), df = as.double(smooth.frame$df), as.integer(smooth.frame$o), as.integer(smooth.frame$nef), etal = double(n), s = s, eta = double(n), beta = double(p), var = s, tol, qr = x, qraux = double(p), qpivot = as.integer(1:p), effects=double(n), double((10 + 2 * 4 + 5) * (max(smooth.frame$nef) + 2) + 15 * n + 15 + length(which)), PACKAGE="gam") nit <- fit$npetc[5] qrank <- fit$npetc[7] if((nit == maxit) & maxit > 1) warning(paste("s.wam convergence not obtained in ", maxit, " iterations")) if(first) { smooth.frame$spar <- fit$spar first <- FALSE } names(fit$df) <- dimnames(s)[[2]] names(fit$beta) <- labels(x)[[2]] qrx <- structure(list(qr = fit$qr,qraux = fit$qraux, rank = qrank, pivot = fit$qpivot,tol=1e-7),class="qr") effects<-fit$effects #qr.qty(qrx,fit$y) r1 <- seq(len = qrx$rank) dn <- colnames(x) if (is.null(dn)) dn <- paste("x", 1:p, sep = "") names(effects) <- c(dn[qrx$pivot[r1]], rep.int("", n - qrx$rank)) rl <- list(coefficients = fit$beta, residuals = fit$y - fit$eta, fitted.values = fit$eta, effects=effects, weights=w, rank=qrank, assign=attr(x,"assign"), qr=qrx, smooth = fit$s, nl.df = fit$df - 1 ) rl$df.residual <- n - qrank - sum(rl$nl.df) - sum(fit$w == 0.) if(se) rl <- c(rl, list(var = fit$var)) c(list(smooth.frame = smooth.frame), rl) } gam/R/summary.gam.R0000644000176000001440000000654013236315525013644 0ustar ripleyusers"summary.Gam" <- function (object, dispersion = NULL, ...) { object.lm=object class(object.lm)="lm" paod=anova(object.lm,...) attr(paod,"heading")="Anova for Parametric Effects" save.na.action <- object$na.action object$na.action <- NULL fun <- function(assign, coeff) sum(!is.na(coeff[assign])) wt <- object$weights coef <- object$coef dresid <- residuals(object, "deviance") resid <- object$residuals n <- length(resid) s <- object$s nl.chisq <- object$nl.chisq assg <- object$assign if (is.null(assg)) assg <- attributes(object$terms)$assign df <- rep(1, length(assg)) df[is.na(object$coef)] <- 0 df <- tapply(df, assg, sum) dfnames <- attr(object$terms, "term.labels") if (attr(object$terms, "intercept")) dfnames <- c("(Intercept)", dfnames) names(df) <- dfnames df <- unlist(df) nldf <- object$nl.df n <- length(object$residuals) if (is.null(rdf <- object$df.resid)) { rdf <- n - sum(df) if (!is.null(nldf)) rdf <- rdf - sum(nldf) } if (!is.null(wt)) { wt <- wt^0.5 resid <- resid * wt excl <- wt == 0 if (any(excl)) { warning(paste(sum(excl), "rows with zero weights not counted")) resid <- resid[!excl] dresid <- dresid[!excl] if (is.null(object$df.residual)) rdf <- rdf - sum(excl) } } if (rdf > 0) phihat <- sum(resid^2)/rdf else { phihat <- Inf warning("Residual degrees of freedom are negative or zero. This occurs when the sum of the parametric and nonparametric degrees of freedom exceeds the number of observations. The model is probably too complex for the amount of data available.") } famname <- object$family[["family"]] if (is.null(famname)) famname <- "gaussian" chiorf <- TRUE if (!is.null(dispersion) && dispersion == 0) dispersion <- phihat if (is.null(dispersion)) dispersion <- switch(famname, poisson = 1, binomial = 1, { chiorf <- FALSE phihat }) names(dispersion) <- famname if (length(nldf)) { aod <- as.matrix(round(df, 1)) dimnames(aod) <- list(names(df), "Df") if (!is.null(nl.chisq)) { aod <- cbind(aod, NA, NA, NA) nl.chisq <- nl.chisq/dispersion snames <- names(nldf) aod[snames, 2] <- round(nldf, 1) aod[snames, 3] <- if (!chiorf) nl.chisq/nldf else nl.chisq aod[snames, 4] <- if (chiorf) 1 - pchisq(nl.chisq, nldf) else if (rdf > 0) 1 - pf(nl.chisq/nldf, nldf, rdf) else NA rnames <- c("Df", "Npar Df", "Npar Chisq", "P(Chi)") if (!chiorf) rnames[3:4] <- c("Npar F", "Pr(F)") dimnames(aod) <- list(names(df), rnames) heading <- "Anova for Nonparametric Effects" } else heading <- "DF for Nonparametric Terms" aod <- as.anova(data.frame(aod[,-1], check.names = FALSE), heading) } else aod <- NULL structure(list(call = object$call, terms = object$terms, anova = aod, parametric.anova=paod, dispersion = dispersion, df = c(sum(df) + sum(nldf), rdf), deviance.resid = dresid, deviance = deviance(object), null.deviance = object$null.deviance, aic = object$aic, iter = object$iter, na.action = save.na.action), class = "summary.Gam") } gam/R/gplot.default.R0000644000176000001440000000206711012713777014155 0ustar ripleyusers"gplot.default" <- function(x, y, se.y = NULL, xlab = "", ylab = "", residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, fit = TRUE, ...) switch(data.class(x)[1], AsIs = { class(x)<-NULL gplot.default(x , y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...) }, logical = gplot.factor(x = factor(x), y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...), list = gplot.list(x = x, y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...), if(is.numeric(x)) gplot.numeric(x = as.vector(x), y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...) else warning(paste("The \"x\" component of \"", ylab, "\" has class \"", paste(class(x), collapse = "\", \""), "\"; no gplot() methods available", sep = "" ))) gam/R/preplot.gam.R0000644000176000001440000000630413236315525013632 0ustar ripleyusers"preplot.Gam" <- function(object, newdata, terms = labels.Gam(object),...) { ## this labels.Gam above is because there does not seem to be a label method for glms Terms <- object$terms a <- attributes(Terms) Call <- object$call all.terms <- labels(Terms) xvars <- parse(text=all.terms) names(xvars) <- all.terms terms <- sapply(terms,match.arg, all.terms) Interactions <- a$order > 1 if(any(Interactions)) { all.terms <- all.terms[!Interactions] TM <- match(terms, all.terms, 0) if(!all(TM)) { terms <- terms[TM > 0] warning("No terms saved for \"a:b\" style interaction terms" ) } } xvars <- xvars[terms] xnames <- as.list(terms) names(xnames) <- terms modes <- sapply(xvars, mode) for(term in terms[modes != "name"]) { evars <- all.names(xvars[term], functions = FALSE, unique = TRUE) if(!length(evars)) next xnames[[term]] <- evars evars <- parse(text = evars) if(length(evars) == 1) evars <- evars[[1]] else { evars <- c(as.name("list"), evars) mode(evars) <- "call" } xvars[[term]] <- evars } xvars <- c(as.name("list"), xvars) mode(xvars) <- "call" if(!missing(newdata)) xvars <- eval(xvars, newdata) else { if(!is.null(Call$subset) | !is.null(Call$na.action) | !is.null( options("na.action")[[1]])) { Rownames <- names(object$fitted) if(!(Rl <- length(Rownames))) stop("need to have names for fitted.values when call has a subset or na.action argument" ) form<-paste("~",unlist(xnames),collapse="+") Mcall <- c(as.name("model.frame"), list(formula = terms(as.formula(form)), subset = Rownames, na.action = function(x) x)) mode(Mcall) <- "call" Mcall$data <- Call$data env <- environment(Terms)##added 7/28/13 if (is.null(env)) ## env <- parent.frame()## xvars <- eval(xvars, eval(Mcall,env)) } else { ecall <- substitute(eval(expression(xvars))) ecall$local <- Call$data xvars <- eval(ecall) } } if(missing(newdata)) pred <- predict(object, type = "terms", terms = terms, se.fit = TRUE) else pred <- predict(object, newdata, type = "terms", terms = terms, se.fit = TRUE) if(is.list(pred)){# oneday predict might return se.fit with newdata fits <- pred$fit se.fits <- pred$se.fit } else{ fits <- pred se.fits <- NULL } gamplot <- xnames for(term in terms) { x <- xvars[[term]] ## oldClass(x) <- unique(c(oldClass(x), data.class(unclass(x)))) xlab <- xnames[[term]] ## Fix ylab for linear terms: ylab <- if(length(xlab) == 1 && term == xlab) paste( "partial for", term) else term TT <- list(x = x, y = fits[, term], se.y = if(is.null(se.fits) ) NULL else se.fits[, term], xlab = xlab, ylab = ylab) oldClass(TT) <- "preplot.Gam" gamplot[[term]] <- TT } oldClass(gamplot) <- "preplot.Gam" gamplot } gam/R/print.summary.gam.R0000644000176000001440000000234213236315525014773 0ustar ripleyusers"print.summary.Gam" <- function(x, digits = max(3, getOption("digits") - 3), quote = TRUE, prefix = "", ...) { cat("\nCall: ") dput(x$call) dresid <- x$deviance.resid n <- length(dresid) rdf <- x$df[2] if(rdf > 5) { cat("Deviance Residuals:\n") rq <- quantile(as.vector(dresid)) names(rq) <- c("Min", "1Q", "Median", "3Q", "Max") print(rq, digits = digits) } else if(rdf > 0) { cat("Deviance Residuals:\n") print(dresid, digits = digits) } cat(paste("\n(Dispersion Parameter for ", names(x$dispersion), " family taken to be ", format(round(x$dispersion, digits)), ")\n",sep="")) int <- attr(x$terms, "intercept") cat("\n Null Deviance:", format(round(x$null.deviance, digits)), "on", n - int, "degrees of freedom") cat("\nResidual Deviance:", format(round(x$deviance, digits)), "on", format(round(rdf, digits)), "degrees of freedom") cat("\nAIC:", format(round(x$aic, digits)),"\n") if(!is.null(x$na.action)) cat(naprint(x$na.action), "\n") cat("\nNumber of Local Scoring Iterations:", format(trunc(x$iter)), "\n") aod=x$parametric.anova cat("\n") if(!is.null(aod)) print(aod) aod=x$anova cat("\n") if(!is.null(aod)) print(aod) } gam/R/labels.gam.R0000644000176000001440000000012013236315525013375 0ustar ripleyuserslabels.Gam<-function(object,...){ attr(object$terms, "term.labels") } gam/R/gplot.factor.R0000644000176000001440000000352011472105544013777 0ustar ripleyusers"gplot.factor" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, xlim = NULL, ylim = NULL, fit = TRUE, ...) { if(length(x) != length(y)) stop("x and y do not have the same length; possibly a consequence of an na.action" ) nn <- as.numeric(table(x)) codex <- as.numeric(x) ucodex <- seq(nn)[nn > 0] o <- match(ucodex, codex, 0) uy <- as.numeric(y[o]) ylim <- range(ylim, uy) xlim <- range(c(0, sum(nn), xlim)) rightx <- cumsum(nn) leftx <- c(0, rightx[ - length(nn)]) ux <- ((leftx + rightx)/2) delta <- (rightx - leftx)/8 jx <- runif(length(codex), (ux - delta)[codex], (ux + delta)[codex]) nnajx <- jx[!is.na(jx)] if(rugplot) xlim <- range(c(xlim, nnajx)) if(se && !is.null(se.y)) { se.upper <- uy + 2 * se.y[o] se.lower <- uy - 2 * se.y[o] ylim <- range(c(ylim, se.upper, se.lower)) } if(!is.null(residuals)) { if(length(residuals) == length(y)) { residuals <- y + residuals ylim <- range(c(ylim, residuals)) } else { residuals <- NULL warning(paste("Residuals do not match x in \"", ylab, "\" preplot object", sep = "")) } } ylim <- ylim.scale(ylim, scale) Levels <- levels(x) if(!all(nn>0)) { keep <- nn > 0 ux <- ux[keep] delta <- delta[keep] leftx <- leftx[keep] rightx <- rightx[keep] Levels <- Levels[keep] } plot(ux, uy, ylim = ylim, xlim = xlim, xlab = "", type = "n", ylab = ylab, xaxt = "n", ...) mtext(xlab, 1, 2) axis(side = 3, at = ux - delta, labels = Levels, srt = 45, tick = FALSE, adj = 0) if(fit) segments(leftx + delta, uy, rightx - delta, uy) if(!is.null(residuals)) points(jx, residuals) if(rugplot) rug(nnajx) if(se) { segments(ux + delta, se.upper, ux - delta, se.upper) segments(ux + delta, se.lower, ux - delta, se.lower) segments(ux, se.lower, ux, se.upper, lty = 2) } invisible(diff(ylim)) } gam/R/gplot.R0000644000176000001440000000005711012713777012527 0ustar ripleyusers"gplot" <- function(x, ...) UseMethod("gplot") gam/R/s.R0000644000176000001440000000137211012714000011621 0ustar ripleyusers"s" <- function(x, df = 4, spar = 1) { scall <- deparse(sys.call()) if(missing(df)){ if(!missing(spar))df<-0 } if(ncol(as.matrix(x)) > 1) stop(paste( "The default smoother is bivariate; you gave a matrix as an argument in ", scall, "\n")) if(!is.null(levels(x))) { if(inherits(x, "ordered")) x <- as.numeric(x) else stop("unordered factors cannot be used as smoothing variables" ) } attr(x, "spar") <- spar attr(x, "df") <- df real.call <- substitute(gam.s(data[[scall]], z, w, spar = spar, df = df )) attr(x, "call") <- real.call attr(x, "class") <- "smooth" a <- is.na(x) if(any(a)) attr(x, "NAs") <- seq(along = x)[a] x } gam/R/polylo.R0000644000176000001440000000407211664612623012722 0ustar ripleyuserspolylo <- function (x, degree = 1, monomial = FALSE) { if (degree >= 4) warning("This is not a smart polynomial routine. You may get numerical problems with a degree of 4 or more") x <- as.matrix(x) dn <- dimnames(x) dd <- dim(x) np <- dd[2] ad <- rep(1, ncol(x)) ### Used to have a x=scale(x) ### That messed up predictions on new data ### So we remove it ### x=scale(x) if (np == 1) monomial <- TRUE if (degree > 1) { if (monomial) { ad <- seq(degree) px <- x cc <- sapply(split(paste(diag(np)), rep(seq(np), rep(np, np))), paste, collapse = "") tx <- x for (i in 2:degree) { px <- px * tx x <- cbind(x, px) cc <- c(cc, sapply(split(paste(diag(np) * i), rep(seq(np), rep(np, np))), paste, collapse = "")) } } else { matarray <- array(x, c(dd, degree)) for (i in 2:degree) matarray[, , i] <- x^i matarray <- aperm(matarray, c(1, 3, 2)) x <- matarray[, , np, drop=TRUE] ad0 <- seq(degree) ad <- ad0 ncol.mat0 <- degree ncol.x <- degree d0 <- paste(ad0) cc <- d0 for (ii in seq(np - 1, 1)) { index0 <- rep(seq(ncol.mat0), ncol.x) index <- rep(seq(ncol.x), rep(ncol.mat0, ncol.x)) newad <- ad0[index0] + ad[index] retain <- newad <= degree mat0 <- matarray[, , ii, drop = TRUE] if (any(retain)) newmat <- mat0[, index0[retain]] * x[, index[retain]] else newmat <- NULL ddn <- paste(d0[index0[retain]], cc[index[retain]], sep = "") zeros <- paste(rep(0, nchar(cc[1])), collapse = "") cc <- paste(0, cc, sep = "") d00 <- paste(d0, zeros, sep = "") x <- cbind(mat0, x, newmat) cc <- c(d00, cc, ddn) ad <- c(ad0, ad, newad[retain]) ncol.x <- length(ad) } } if (!is.null(dn)) dn[[2]] <- cc else dn <- list(NULL, cc) dimnames(x) <- dn } attr(x, "degree") <- ad x } gam/R/gam.smoothers.R0000644000176000001440000000071713075726341014175 0ustar ripleyusers"gam.smooth.list"=list( slist=c("s","lo","random"), wlist=c("s","lo") ) "gam.smoothers" <- function(slist=c("s","lo","random"), wlist=c("s","lo")){ smooth.list=gam.smooth.list if(!missing(slist)){ smooth.list$slist <- slist assignInMyNamespace("gam.smooth.list", smooth.list) } if(!missing(wlist)){ smooth.list$wlist <- wlist assignInMyNamespace("gam.smooth.list", smooth.list) } smooth.list } gam/R/print.gamex.R0000644000176000001440000000012613236315525013632 0ustar ripleyusers"print.Gamex" <- function(x,...) { print(x$coefficients) invisible() } gam/R/gam.exact.R0000644000176000001440000001126013236315525013246 0ustar ripleyusers"gam.exact" <- function(Gam.obj) ### ----------------------------------------------------------------------------------- ### gam.exact is a method for the Gam class. ### ### Computes the asymptotically exact variance-covariance matrix for the linear ### terms in the model (except for the intercept). ### ### Note: Use of lo in the model formula is not allowed. ### ### Author: Aidan McDermott (AMcD) ### Date: Mar 5, 2003 ### ### Mar 28, 2003 ### Fixed single linear term models -- thanks to Tim Ramsay ### April 17, 2006 ### Modified to work in R by Trevor Hastie ### ### See: ### ### [1] Issues in Semiparametric Regression: A Case Study of Time Series ### Models in Air Pollution and Mortality, ### Dominici F., McDermott A., Hastie T.J., ### Technical Report, Department of Biostatistics, Johns Hopkins University, ### Baltimore, MD, USA. ### ### ----------------------------------------------------------------------------------- { if ( is.na(match("Gam",class(Gam.obj))) ) { stop("not a Gam object") } nl.df <- Gam.obj$nl.df terms <- terms(Gam.obj) at.terms <- attributes(terms) coef <- coef(Gam.obj) w <- Gam.obj$weights mu <- Gam.obj$fitted.values eta <- Gam.obj$additive.predictors y <- as.matrix(Gam.obj$y) family <- family(Gam.obj) mu.eta.val <- family$mu.eta(eta) z <- eta + (y - mu)/mu.eta.val ### Don't want lo in Gam formula. ### if ( length((at.terms$specials)$lo) > 0 ) { ### stop("lo found in Gam formula.") ### } X <- model.matrix(Gam.obj) Y <- as.matrix(Gam.obj$y) ### only take terms that survived the original gam call names.coef <- names(coef) has.intercept <- match("(Intercept)",names.coef) if ( !is.na(has.intercept) ) names.coef <- names.coef[-has.intercept] X <- X[,names.coef] tnames <- dimnames(X)[[2]] form <- "y~" special.list <- c() ### Replace the df with the actual df returned by gam. ### Rewrite fromula to match names in X for ( k in 1:length(tnames) ) { if ( substring(tnames[k],1,2) == "s(" ) { s.call <- match.call(s,parse(text=tnames[k])) this.name <- as.name(paste("x",k,sep="")) which <- match(tnames[k],names(nl.df)) if ( is.na(which) ) stop(paste("can't find df for term",tnames[k])) this.df <- nl.df[which]+1 form <- paste(form, "+s(",this.name,",df =",this.df,")") special.list <- c(special.list,k) } else if ( substring(tnames[k],1,3) == "lo(" ) { lname <- length(tnames[k]) if ( substring(tnames[k],lname,lname) == "1" ) tnames[k] <- substring(tnames[k],1,(lname-1)) if ( substring(tnames[k],lname,lname) == ")" ) { lo.call <- match.call(lo,parse(text=tnames[k])) this.name <- as.name(paste("x",k,sep="")) lo.call[[2]] <- this.name lo.call <- deparse(lo.call) form <- paste(form,"+",lo.call) } special.list <- c(special.list,k) } else form <- paste(form,"+x",k,sep="") } mydat <- data.frame(cbind(Y,X)) names(mydat) <- c("y",paste("x",1:ncol(X),sep="")) XX <- X mydat[,"w"] <- w Control <- Gam.obj$call$control if ( is.null(Control) ) { call <- Gam.obj$call call[[1]] <- as.name("gam.control") Control <- eval(call,sys.parent()) } for ( k in 1:length(tnames) ) { if ( substring(tnames[k],1,2) != "s(" & substring(tnames[k],1,3) != "lo(" ) { this.var <- paste("x",k,sep="") upd.form <- update(as.formula(form),paste(this.var,"~. -",this.var)) XX[,k] <- gam(formula=upd.form,data=mydat,family=gaussian,weights=w, control=eval(Control))$fitted } } ### Need to test we get some data if ( length(X) == 0 ) stop("nothing to do") X <- X[,-special.list,drop=FALSE] sx <- XX[,-special.list,drop=FALSE] swx <- w*sx if ( length(X) == 0 ) stop("no linear terms in the model -- nothing to do") A <- t(X) %*% ( w * X ) - t(X) %*% ( w * sx ) B <- t(X*w) - t(swx) H <- solve(A) %*% B beta <- H %*% z varbeta <- (H * (1/w)) %*% t(H) * as.vector(summary(Gam.obj)$dispersion) se <- sqrt(diag(varbeta)) coef <- cbind(summary.glm(Gam.obj)$coef,NA,NA,NA) tab <- cbind(beta,se,beta/se,2*(1-pnorm(beta/se))) coef[dimnames(tab)[[1]],c(5,6,7)] <- tab[,c(2,3,4)] dimnames(coef) <- list(dimnames(coef)[[1]], c(dimnames(coef)[[2]][1:4], "A-exact SE","A-exact Z","A-exact P")) out.object <- list(coefficients=coef,covariance=varbeta) class(out.object) <- c("Gamex") return(out.object) } gam/R/gam.lo.R0000644000176000001440000000321012762431001012537 0ustar ripleyusers"gam.lo" <- function(x, y, w = rep(1, length(y)), span = 0.5, degree = 1, ncols = p, xeval = x) { storage.mode(x) <- storage.mode(y) <- storage.mode(w) <- storage.mode( span) <- "double" storage.mode(degree) <- "integer" if(is.null(np <- dim(x))) { n <- as.integer(length(x)) p <- as.integer(1) } else { np <- as.integer(np) n <- np[1] p <- np[2] } storage.mode(ncols) <- "integer" o <- gam.match(x) nef <- o$nef # nvmax <- max(200,nef) nvmax <- as.integer(200 + 300 * (1 - 1/log(max(c(nef - 200, 3))))) # liv <- as.integer(50 + (2^ncols + 4) * nvmax + 2 * nef) # lv <- as.integer(50 + (3 * ncols + 3) * nvmax + nef + (ifelse(degree == # 2, ((ncols + 2) * (ncols + 1))/2, ncols + 1) + 2) * (nef * span + # 1)) liv <- as.integer(100 + (2^ncols + 4) * nvmax + 2 * nef) lv <- as.integer(100 + (3 * ncols + 3) * nvmax + nef + (ifelse(degree == 2, ((ncols + 2) * (ncols + 1))/2, ncols + 1) + 2) * (nef * span + 1)) fit <- .Fortran("lo0", x, y, w, n, ncols, p, nvmax, span, degree, o$o, nef, df = double(1), s = double(n), var = double(n), beta = double(p + 1), iv = integer(liv), liv, lv, v = double(lv), integer(2*ncols), double(nef * (p + ncols + 8) + 2 * p + n + 9), PACKAGE="gam") if(!missing(xeval)) { storage.mode(xeval) <- "double" m <- as.integer(dim(xeval)[1]) if(length(m) == 0) m <- as.integer(length(xeval)) .Fortran("lowese", fit$iv, liv, lv, fit$v, m, xeval, s = double(m), PACKAGE="gam")$s - cbind(1, xeval) %*% fit$beta } else list(residuals = y - fit$s, var = fit$var, nl.df = fit$df) } gam/R/gam.control.R0000644000176000001440000000157611012713777013634 0ustar ripleyusers"gam.control" <- function(epsilon = 9.9999999999999995e-08, bf.epsilon = 9.9999999999999995e-08, maxit = 30, bf.maxit = 30, trace = FALSE, ...) { if(epsilon <= 0) { warning("the value of epsilon supplied is zero or negative; the default value of 1e-7 was used instead" ) epsilon <- 9.9999999999999995e-08 } if(maxit < 1) { warning("the value of maxit supplied is too small; the default value of 30 was used instead" ) maxit <- 30 } if(bf.epsilon <= 0) { warning("the value of bf.epsilon supplied is zero or negative; the default value of 1e-7 was used instead" ) bf.epsilon <- 9.9999999999999995e-08 } if(bf.maxit < 1) { warning("the value of bf.maxit supplied is too small; the default value of 30 was used instead" ) bf.maxit <- 30 } list(epsilon = epsilon, maxit = maxit, bf.epsilon = bf.epsilon, bf.maxit = bf.maxit, trace = as.logical(trace)[1]) } gam/MD50000644000176000001440000001105113507061371011357 0ustar ripleyusers4590965512be079b118c2163a2d0b9df *ChangeLog a7dc0cc1da2e0c9222ad43f76d3c4670 *DESCRIPTION 8d7cd795b6467570d4449ab7b6058fd2 *INDEX bd1e526f5968efa2a0754c8b914a8b32 *NAMESPACE 944e9c57dfab2a9bb7a1b5a8f623bb51 *R/anova.gam.R 192db032173b07048c4798f7efffcf73 *R/anova.gamlist.R c67ddb150e807c4a0ef77acf132c1021 *R/as.anova.R 996bcecc62a9687cb77863e45830a000 *R/as.data.frame.lo.smooth.R 69d4bccf3afc7a1a9fd2b5d8b2f60fec *R/assign.list.R 928e5bedc7ea9817f33541b4fa904c45 *R/gam.R 6f9d6d8a11d7b20d791233f1ed3445dc *R/gam.control.R 0fd9163adaf0d5aee8b84aaba20eca7d *R/gam.exact.R 77819c025d7e84a1a7dd71cadc95b9e7 *R/gam.fit.R f47a64e337008b4320396a88ba5cdb34 *R/gam.lo.R 946d0c85f06753f768700803d197c247 *R/gam.match.R 526f48fabc38d73bef43169182a7051a *R/gam.nlchisq.R 00fde32a9c268a9f6d3b082721c9bba0 *R/gam.random.R 302811098b9e378092cbc12fd11cef0d *R/gam.s.R a6bc1a9e490a60aaa1d5d8d47b872c00 *R/gam.scope.R 9cf749e544cb4a40728a3e361e5e63cd *R/gam.smoothers.R 1f8d4b4e6776250d0e4080e64a1273e9 *R/gam.sp.R 4fb4fdd03ea7c8562ab8d56f2dea8655 *R/gamlist.R 48b81ce1290eed4ff84af845b760a911 *R/general.wam.R 6bc9b975aa99176b8d021818760af91c *R/gplot.R f8026ded9300952fe6a9810e8bfeecdf *R/gplot.default.R 55d310d740e82e36a69686600b331072 *R/gplot.factor.R 4e843123d1fd91f5d2fea87e487f795d *R/gplot.list.R d9e47c37ce11bb5d36eb65e7af17debc *R/gplot.matrix.R 5fc7caa79f441edc92935788f38444b2 *R/gplot.numeric.R cbbcead34f1eaac0ce36d5a21535b291 *R/labels.gam.R 093d17804fa5ce90f12cdeb4f9fbcf6a *R/lo.R 7ec421436e0baf060ae08ab07bd53dd7 *R/lo.wam.R e4ad55fc0e50f154e067a5e508cd43da *R/na.gam.replace.R 9759edd325ec97005563bb50040f8475 *R/newdata.predict.gam.R 39cfb671132d4928c0a77a79edb1967d *R/onAttach.R 61a9277604d6e2ae437ecd56acd14948 *R/plot.gam.R 51f3318e5882c0314cdd315cd3be5c61 *R/plot.preplot.gam.R b0b4e3ea29649f25919a9b3b9a01886f *R/polylo.R ffd8650ea4322c5d319b5d7dbee17be8 *R/predict.gam.R 7b7b0a7746a9f24758588715c3756dc6 *R/preplot.gam.R 76ec33b3c5ca7e555a958e1baa029499 *R/print.gam.R 4d9858e3b89068610071b8f0e65617b5 *R/print.gamex.R 6ad823ecd940526c459b48ddf85b27be *R/print.stepanova.R 48aa615ae5f5ee6469a5432350e1fe2c *R/print.summary.gam.R 0057a506c52d7b93e0cb650bc6708172 *R/random.R 1478722abc4269fede0d572840c0cfbe *R/s.R c0ea33636dd8d8e8088a173fd5670d7f *R/s.wam.R 0c850a7df21399488cadf999a35bcfb2 *R/step.gam.R 8f34f93005ef6dd0d5f6bfe419daf930 *R/subset.smooth.R a80dd7e2bfa7a2dc3709063cc4481cae *R/summary.gam.R 5cc7658080bc925bb5fc11172d78fb41 *R/ylim.scale.R ba66638e3de17b868b4d98dffe95009d *data/gam.data.RData 83529cbff37939aff8d96d32d6458f12 *data/gam.newdata.RData 4df6bee1aa3bee402b8f1083dda04b04 *data/kyphosis.RData a42dba5f95d8760e06a78389d780b170 *inst/ratfor/backfit.r a009bd4d2232ec7cc19b9d7d10280ffb *inst/ratfor/backlo.r 1ca924fd62063613d16c1cf607abb6b2 *inst/ratfor/linear.r 4e0b184dc647e3abac7fb7f023ed4a69 *inst/ratfor/lo.r 58295734adaaee3561f298e7c0b93eee *inst/ratfor/splsm.r 1b232f5801c8dffea77407265e578322 *man/anova.gam.Rd c3d32c5923453effc1f8b3ec88747e49 *man/gam-internal.Rd bffd976feaf18eea4959033c61d229dd *man/gam.Rd 5167ecd9baaea501d766f87b4e22cf20 *man/gam.control.Rd d3c27998fb1cdce4cb00703557f1138d *man/gam.data.Rd 0e07062c1eb751fb376502ad6dc7b680 *man/gam.exact.Rd 09cedc49777f2ae0402b0eee76d1e478 *man/gam.scope.Rd d0a4a66f6aea7aee65a89e883b722e67 *man/gam.smoothers.Rd dd3553bd8578858873bd1384b000273a *man/kyphosis.Rd 2bac0339dc32adb38b491c7ec1cd8601 *man/lo.Rd 5068084693ec99de54e0531a53d4e637 *man/na.gam.replace.Rd 32be709f5a413ea3ca5eb62d5385aaea *man/plot.gam.Rd d76800b84499e0dd362fb845eab16f75 *man/predict.gam.Rd bd664b11c5dc04bba2c2401a827ec330 *man/random.Rd bd6c6aa28618b388edda2c177d6d9a54 *man/s.Rd 5529c36fcad999e56bed3af042547fc5 *man/step.gam.Rd 2bf8ef7e1425c36f4be16667cdcdd3b3 *src/Makevars 2fa4c7011c2bc0f7449ae151d5cc44ae *src/Makevars.win 45061d1eb26bda41c4c458126dd303da *src/backfit.f 7205467d48f1b2f05d6b830aa34afac1 *src/backlo.f 10f91c907532cc70e76074ca47d14716 *src/bsplvd.f 2cf888d1f6a6ca37a7211c7c6ab86c0e *src/bvalue.f 40c1f6b57d6c3a03a1d972f009c5e5df *src/bvalus.f bf5f2d130e9f4ea39fe81367d8ceb35a *src/gam_init.c e24ae2d36712b498d0bbcf49dee4f755 *src/linear.f 6b4fde12653de078154a99510fed6d64 *src/lo.f ef05027b6965bba920ba3a3d748b4d6c *src/loessc.c 425c0bc459b1dee59d08e5cd6c28d89c *src/loessf.f 6ada085e39fd48968fcd79368c0ccddd *src/modreg.h e1c0a8ef61f04b6239ff2ea6874be92d *src/qsbart.f 876032799d52ef84fb846af58939a318 *src/sbart.c 82da999d24034505301e31c78d1e58cc *src/sgram.f d277bb97eef775673f5fa2da911d81de *src/sinerp.f 82e478f6d0dc2c2a61484d5009427eb6 *src/splsm.f 7d7b6fb9e86d3ea8d8a8ed57af178372 *src/sslvrg.f 4f6275039d4731d4f2920fc3de5f61e7 *src/stxwx.f gam/DESCRIPTION0000644000176000001440000000112213507061371012553 0ustar ripleyusersPackage: gam Type: Package Title: Generalized Additive Models Date: 2018-07-19 Version: 1.16.1 Author: Trevor Hastie Description: Functions for fitting and working with generalized additive models, as described in chapter 7 of "Statistical Models in S" (Chambers and Hastie (eds), 1991), and "Generalized Additive Models" (Hastie and Tibshirani, 1990). Maintainer: Trevor Hastie Depends: stats, splines, foreach Suggests: akima License: GPL-2 NeedsCompilation: yes Packaged: 2019-07-03 07:29:25 UTC; ripley Repository: CRAN Date/Publication: 2019-07-03 08:10:33 UTC gam/ChangeLog0000644000176000001440000000225213236320277012626 0ustar ripleyusers2018-02-06 Trevor Hastie version 1.15 * major change class "gam" to "Gam" to avoid conflict with mgcv (grr!) 2017-06-09 Trevor Hastie version 1.14-5 * fixed bug in na.gam.replace() 2017-04-12 Trevor Hastie version 1.14-2 * changed the mechanism for users to add thir own smoother. New function gam.smoothers() allows one to add to the list * added documentation for random() smoother, and added an argument 2016-09-09 Trevor Hastie version 1.14 * fixed bug in gam when NAs are in data (model.frame does not behave as stated, so I had to make a work around) * gam models with lo(, degree=2) where getting segfaults. Enlarged the work space and this appears to have fixed the problem. 2013-08-02 Trevor Hastie version 1.09 * improved step.gam significantly (it works now for eg, the spam data); added parallel option * man/step.gam updated * R/scope.gam added; an aid for creating a scope object * man/scope.gam added * R/summary.gam split up the anova to two anovas - one for the parametric, and one for nonparametric ### Note that this starts from gam 1.09 gam/man/0000755000176000001440000000000013236316424011625 5ustar ripleyusersgam/man/gam.scope.Rd0000644000176000001440000000426313236315525013776 0ustar ripleyusers\name{gam.scope} \alias{gam.scope} \title{ Generate a scope for step.Gam } \description{Given a data.frame as an argument, generate a scope list for use in step.Gam, each element of which gives the candidates for that term. } \usage{ gam.scope(frame, response=1, smoother = "s", arg = NULL, form = TRUE) } \arguments{ \item{frame}{ a data.frame to be used in \code{step.Gam}. Apart from the response column, all other columns will be used. } \item{response}{ The column in \code{frame} used as the response. Default is 1. } \item{smoother}{ which smoother to use for the nonlinear terms; i.e. "s" or "lo", or any other supplied smoother. Default is "s". } \item{arg}{a character (vector), which is the argument to \code{smoother}. For example, \code{arg="df=6"} would result in the expression \code{s(x,df=6)} for a column named "x". This can be a vector, for example \code{arg=c("df=4","df=6")}, which would result two smooth terms. } \item{form}{ if \code{TRUE}, each term is a formula, else a character vector. } } \details{ This function creates a similar scope formula for each variable in the frame. A column named "x" by default will generate a scope term \code{~1+x+s(x)}. With \code{arg=c("df=4","df=6")} we get \code{~1+x+s(x,df=4)+s(x,df=6)}. With form=FALSE, we would get the character vector \code{c("1","x","s(x,df=4)","s(x,df=6")}. } \value{ a scope list is returned, with either a formula or a character vector for each term, which describes the candidates for that term in the Gam. } \references{ Hastie, T. J. (1991) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). This version of \code{gam.scope} is adapted from the S version. } \seealso{\code{\link{step.Gam}} } \examples{ data(gam.data) gdata=gam.data[,1:3] gam.scope(gdata,2) gam.scope(gdata,2,arg="df=5") gam.scope(gdata,2,arg="df=5",form=FALSE) gam.scope(gdata,2,arg=c("df=4","df=6")) } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/kyphosis.Rd0000644000176000001440000000142611017130216013754 0ustar ripleyusers\name{kyphosis} \alias{kyphosis} \docType{data} \title{A classic example dataset for GAMs} \description{ Data on the results of a spinal operation "laminectomy" on children, to correct for a condition called "kyphosis"; see Hastie and Tibshirani (1990) for details} \usage{ data(kyphosis) } \format{A data frame with 81 observations on the following 4 variables. \describe{ \item{Kyphosis}{a response factor with levels \code{absent} \code{present}.} \item{Age}{of child in months, a numeric vector} \item{Number}{of vertebra involved in the operation,a numeric vector} \item{Start}{level of the operation, a numeric vector} } } \source{ Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \keyword{datasets} gam/man/step.gam.Rd0000644000176000001440000001343213236320565013636 0ustar ripleyusers\name{step.Gam} \alias{step.Gam} \title{Stepwise model builder for GAM} \description{Builds a GAM model in a step-wise fashion. For each "term" there is an ordered list of alternatives, and the function traverses these in a greedy fashion. Note: this is NOT a method for \code{step}, which used to be a generic, so must be invoked with the full name.} \usage{ step.Gam(object, scope, scale, direction, trace, keep, steps, parallel, \ldots) } \arguments{ \item{object}{ An object of class \code{Gam} or any of it's inheritants. } \item{scope}{ defines the range of models examined in the step-wise search. It is a list of formulas, with each formula corresponding to a term in the model. Each of these formulas specifies a "regimen" of candidate forms in which the particular term may enter the model. For example, a term formula might be \code{~1+ Income + log(Income) + s(Income)}. This means that \code{Income} could either appear not at all, linearly, linearly in its logarithm, or as a smooth function estimated nonparametrically. A \code{1} in the formula allows the additional option of leaving the term out of the model entirely. Every term in the model is described by such a term formula, and the final model is built up by selecting a component from each formula. As an alternative more convenient for big models, each list can have instead of a formula a character vector corresponding to the candidates for that term. Thus we could have \code{c("1","x","s(x,df=5")} rather than \code{~1+x+s(x,df=5)}. The supplied model \code{object} is used as the starting model, and hence there is the requirement that one term from each of the term formulas be present in \code{formula(object)}. This also implies that any terms in \code{formula(object)} \emph{not} contained in any of the term formulas will be forced to be present in every model considered. The function \code{gam.scope} is helpful for generating the scope argument for a large model. } \item{scale}{ an optional argument used in the definition of the AIC statistic used to evaluate models for selection. By default, the scaled Chi-squared statistic for the initial model is used, but if forward selection is to be performed, this is not necessarily a sound choice. } \item{direction}{ The mode of step-wise search, can be one of \code{"both"}, \code{"backward"}, or \code{"forward"}, with a default of \code{"both"}. If \code{scope} is missing, the default for \code{direction} is "both". } \item{trace}{ If \code{TRUE} (the default), information is printed during the running of \code{step.Gam()}. This is an encouraging choice in general, since \code{step.Gam()} can take some time to compute either for large models or when called with an an extensive \code{scope=} argument. A simple one line model summary is printed for each model selected. This argument can also be given as the binary \code{0} or \code{1}. A value \code{trace=2} gives a more verbose trace. } \item{keep}{ A filter function whose input is a fitted \code{Gam} object, and anything else passed via \dots, and whose output is arbitrary. Typically \code{keep()} will select a subset of the components of the object and return them. The default is not to keep anything. } \item{steps}{ The maximum number of steps to be considered. The default is 1000 (essentially as many as required). It is typically used to stop the process early. } \item{parallel}{If \code{TRUE}, use parallel \code{foreach} to fit each trial run. Must register parallel before hand, such as \code{doMC} or others. See the example below.} \item{\dots}{Additional arguments to be passed on to \code{keep}} } \value{ The step-wise-selected model is returned, with up to two additional components. There is an \code{"anova"} component corresponding to the steps taken in the search, as well as a \code{"keep"} component if the \code{keep=} argument was supplied in the call. We describe the most general setup, when \code{direction = "both"}. At any stage there is a current model comprising a single term from each of the term formulas supplied in the \code{scope=} argument. A series of models is fitted, each corrresponding to a formula obtained by moving each of the terms one step up or down in its regimen, relative to the formula of the current model. If the current value for any term is at either of the extreme ends of its regimen, only one rather than two steps can be considered. So if there are \code{p} term formulas, at most \code{2*p - 1} models are considered. A record is kept of all the models ever visited (hence the \code{-1} above), to avoid repetition. Once each of these models has been fit, the "best" model in terms of the AIC statistic is selected and defines the step. The entire process is repeated until either the maximum number of steps has been used, or until the AIC criterion can not be decreased by any of the eligible steps. } \seealso{ \code{\link{gam.scope}},\code{\link{step}},\code{\link{glm}}, \code{\link{gam}}, \code{\link{drop1}}, \code{\link{add1}}, \code{\link{anova.Gam}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \examples{ data(gam.data) Gam.object <- gam(y~x+z, data=gam.data) step.object <-step.Gam(Gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4))) \dontrun{ # Parallel require(doMC) registerDoMC(cores=2) step.Gam(Gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4)),parallel=TRUE) } } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/gam.control.Rd0000644000176000001440000000264311364331023014334 0ustar ripleyusers\name{gam.control} \alias{gam.control} \title{Auxilliary for controlling GAM fitting} \description{Auxiliary function as user interface for 'gam' fitting. Typically only used when calling 'gam' or 'gam.fit'.} \usage{ gam.control(epsilon=1e-07, bf.epsilon = 1e-07, maxit=30, bf.maxit = 30, trace=FALSE,\ldots) } \arguments{ \item{epsilon}{ convergence threshold for local scoring iterations } \item{bf.epsilon}{ convergence threshold for backfitting iterations } \item{maxit}{ maximum number of local scoring iterations } \item{bf.maxit}{ maximum number of backfitting iterations } \item{trace}{ should iteration details be printed while \code{gam} is fitting the model. } \item{\ldots}{Placemark for additional arguments} } \value{ a list is returned, consisting of the five parameters, conveniently packaged up to supply the \code{control} argument to \code{gam}. The values for \code{gam.control} can be supplied directly in a call to \code{gam}; these are then filtered through \code{gam.control} inside \code{gam}. } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. } \examples{ \dontrun{gam(formula, family, control = gam.control(bf.maxit=15))} \dontrun{gam(formula, family, bf.maxit = 15) # these are equivalent} } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/gam.smoothers.Rd0000644000176000001440000000317113075273323014705 0ustar ripleyusers\name{gam.smoothers} \alias{gam.smoothers} \alias{gam.smooth.list} \title{Smoothers available for backfitting} \description{Auxiliary function as user interface for 'gam' fitting. Lists what smoothers are implemented, and allows users to include new smoothers.} \usage{ gam.smoothers(slist=c("s","lo","random"), wlist=c("s","lo")) } \arguments{ \item{slist}{ character vector giving names of smoothers available for general backfitting. For every entry, eg "lo", there must exist a formula function "lo()" that prepares the data, and a fitting function with the name "gam.lo" which actually does the fitting. Look at "lo" and "s" as examples. } \item{wlist}{ character vector (subset of slist) giving names of smoothers for which a special backfitting algorithm is available, when only that smoother appears (multiple times) in the formula, along with other non smooth terms. } } \value{ a list is returned, consisting of the two named vectors. If the function is called with no arguments, it gets the version of "gam.smooth.list"' in the search path, by default from the package name space. Once it is called with either of the arguments, it places a local copy in the users namespace.} \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. } \examples{ \dontrun{gam.smoothers()$slist # get the gam.smooth.list, and extract component slist} \dontrun{gam.smoothers(slist=c("s","lo","random","tps") # add a new smoother "tps" to the list} } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/lo.Rd0000644000176000001440000001225412524243750012532 0ustar ripleyusers\name{lo} \alias{lo} \alias{gam.lo} \title{Specify a loess fit in a GAM formula} \description{A symbolic wrapper to indicate a smooth term in a formala argument to gam} \usage{ lo(\dots, span=0.5, degree=1) gam.lo(x, y, w, span, degree, ncols, xeval) } \arguments{ \item{...}{ the unspecified \code{\dots} can be a comma-separated list of numeric vectors, numeric matrix, or expressions that evaluate to either of these. If it is a list of vectors, they must all have the same length.} \item{span}{ the number of observations in a neighborhood. This is the smoothing parameter for a \code{loess} fit. If specified, the full argument name \code{span} must be written.} \item{degree}{the degree of local polynomial to be fit; currently restricted to be \code{1} or \code{2}. If specified, the full argument name \code{degree} must be written.} \item{x}{for \code{gam.lo}, the appropriate basis of polynomials generated from the arguments to \code{lo}. These are also the variables that receive linear coefficients in the GAM fit.} \item{y}{a response variable passed to \code{gam.lo} during backfitting} \item{w}{weights} \item{ncols}{for \code{gam.lo} the number of columns in \code{x} used as the smoothing inputs to local regression. For example, if \code{degree=2}, then \code{x} has two columns defining a degree-2 polynomial basis. Both are needed for the parameteric part of the fit, but \code{ncol=1} telling the local regression routine that the first column is the actually smoothing variable.} \item{xeval}{If this argument is present, then \code{gam.lo} produces a prediction at \code{xeval}.} } \value{ \code{lo} returns a numeric matrix. The simplest case is when there is a single argument to \code{lo} and \code{degree=1}; a one-column matrix is returned, consisting of a normalized version of the vector. If \code{degree=2} in this case, a two-column matrix is returned, consisting of a degree-2 polynomial basis. Similarly, if there are two arguments, or the single argument is a two-column matrix, either a two-column matrix is returned if \code{degree=1}, or a five-column matrix consisting of powers and products up to degree \code{2}. Any dimensional argument is allowed, but typically one or two vectors are used in practice. The matrix is endowed with a number of attributes; the matrix itself is used in the construction of the model matrix, while the attributes are needed for the backfitting algorithms \code{general.wam} (weighted additive model) or \code{lo.wam} (currently not implemented). Local-linear curve or surface fits reproduce linear responses, while local-quadratic fits reproduce quadratic curves or surfaces. These parts of the \code{loess} fit are computed exactly together with the other parametric linear parts When two or more smoothing variables are given, the user should make sure they are in a commensurable scale; \code{lo()} does no normalization. This can make a difference, since \code{lo()} uses a spherical (isotropic) neighborhood when establishing the nearest neighbors. Note that \code{lo} itself does no smoothing; it simply sets things up for \code{gam}; \code{gam.lo} does the actual smoothing. of the model. One important attribute is named \code{call}. For example, \code{lo(x)} has a call component \code{gam.lo(data[["lo(x)"]], z, w, span = 0.5, degree = 1, ncols = 1)}. This is an expression that gets evaluated repeatedly in \code{general.wam} (the backfitting algorithm). \code{gam.lo} returns an object with components \item{residuals}{The residuals from the smooth fit. Note that the smoother removes the parametric part of the fit (using a linear fit with the columns in \code{x}), so these residual represent the nonlinear part of the fit.} \item{nl.df}{the nonlinear degrees of freedom} \item{var}{the pointwise variance for the nonlinear fit} When \code{gam.lo} is evaluated with an \code{xeval} argument, it returns a matrix of predictions. } \details{ A smoother in gam separates out the parametric part of the fit from the non-parametric part. For local regression, the parametric part of the fit is specified by the particular polynomial being fit locally. The workhorse function \code{gam.lo} fits the local polynomial, then strips off this parametric part. All the parametric pieces from all the terms in the additive model are fit simultaneously in one operation for each loop of the backfitting algorithm. } \seealso{ \code{\link{s}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}}, \code{\link{loess}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \examples{ y ~ Age + lo(Start) # fit Start using a loess smooth with a (default) span of 0.5. y ~ lo(Age) + lo(Start, Number) y ~ lo(Age, span=0.3) # the argument name span cannot be abbreviated. } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/na.gam.replace.Rd0000644000176000001440000000361410420023475014664 0ustar ripleyusers\name{na.gam.replace} \alias{na.gam.replace} \title{Missing Data Filter for GAMs} \description{A method for dealing with missing values, friendly to GAM models.} \usage{ na.gam.replace(frame) } \arguments{ \item{frame}{ a model or data frame }} \value{ a model or data frame is returned, with the missing observations (NAs) replaced. The following rules are used. A factor with missing data is replaced by a new factor with one more level, labelled \code{"NA"}, which records the missing data. Ordered factors are treated similarly, except the result is an unordered factor. A missing numeric vector has its missing entires replaced by the mean of the non-missing entries. Similarly, a matrix with missing entries has each missing entry replace by the mean of its column. If \code{frame} is a model frame, the response variable can be identified, as can the weights (if present). Any rows for which the response or weight is missing are removed entirely from the model frame. The word \code{"gam"} in the name is relevant, because \code{gam()} makes special use of this filter. All columns of a model frame that were created by a call to \code{lo()} or \code{s()} have an attribute names \code{"NAs"} if NAs are present in their columns. Despite the replacement by means, these attributes remain on the object, and \code{gam()} takes appropriate action when smoothing against these columns. See section 7.3.2 in Hastie (1992) for more details. } \author{Trevor Hastie} \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. } \examples{ data(airquality) gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace) } \seealso{ \code{\link{na.fail}}, \code{\link{na.omit}}, \code{\link{gam}} } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/gam.exact.Rd0000644000176000001440000000327013236322270013761 0ustar ripleyusers\name{gam.exact} \alias{gam.exact} \title{A method for gam producing asymptotically exact standard errors for linear estimates} \description{This function is a "wrapper" for a Gam object, and produces exact standard errors for each linear term in the gam call (except for the intercept).} \usage{ gam.exact(Gam.obj) } \arguments{ \item{Gam.obj}{a Gam object} } \details{ Only standard errors for the linear terms are produced. There is a print method for the Gamex class. } \value{ A list (of class Gamex) containing a table of coefficients and a variance covariance matrix for the linear terms in the formula of the gam call. } \references{[1] Issues in Semiparametric Regression: A Case Study of Time Series Models in Air Pollution and Mortality, Dominici F., McDermott A., Hastie T.J., \emph{JASA}, December 2004, 99(468), 938-948. See \url{http://web.stanford.edu/~hastie/Papers/dominiciR2.pdf} } \author{Aidan McDermott, Department of Biostatistics, Johns Hopkins University. Modified by Trevor Hastie for R} \examples{ set.seed(31) n <- 200 x <- rnorm(n) y <- rnorm(n) a <- rep(1:10,length=n) b <- rnorm(n) z <- 1.4 + 2.1*a + 1.2*b + 0.2*sin(x/(3*max(x))) + 0.3*cos(y/(5*max(y))) + 0.5 * rnorm(n) dat <- data.frame(x,y,a,b,z,testit=b*2) ### Model 1: Basic Gam.o <- gam(z ~ a + b + s(x,3) + s(y,5), data=dat) coefficients(summary.glm(Gam.o)) gam.exact(Gam.o) ### Model 2: Poisson Gam.o <- gam(round(abs(z)) ~ a + b + s(x,3) + s(y,5), data=dat,family=poisson) coefficients(summary.glm(Gam.o)) gam.exact(Gam.o) } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/anova.gam.Rd0000644000176000001440000000464513236315525013775 0ustar ripleyusers\name{anova.Gam} \alias{anova.Gam} \alias{summary.Gam} \title{Analysis of Deviance for a Generalized Additive Model} \description{Produces an ANODEV table for a set of GAM models, or else a summary for a single GAM model} \usage{ \method{anova}{Gam}(object, \dots, test) \method{summary}{Gam}(object, dispersion=NULL,\dots) } \arguments{ \item{object}{a fitted Gam} \item{\dots}{other fitted Gams for \code{anova}} \item{test}{a character string specifying the test statistic to be used. Can be one of '"F"', '"Chisq"' or '"Cp"', with partial matching allowed, or 'NULL' for no test.} \item{dispersion}{a dispersion parameter to be used in computing standard errors} } \details{ These are methods for the functions \code{anova} or \code{summary} for objects inheriting from class `Gam'. See \code{\link{anova}} for the general behavior of this function and for the interpretation of `test'. When called with a single `Gam' object, a special pair of anova tables for `Gam' models is returned. This gives a breakdown of the degrees of freedom for all the terms in the model, separating the projection part and nonparametric part of each, and returned as a list of two anova objects. For example, a term specified by `s()' is broken down into a single degree of freedom for its linear component, and the remainder for the nonparametric component. In addition, a type of score test is performed for each of the nonparametric terms. The nonparametric component is set to zero, and the linear part is updated, holding the other nonparametric terms fixed. This is done efficiently and simulataneously for all terms. } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S.} New York: Springer. } \examples{ data(gam.data) Gam.object <- gam(y~s(x,6)+z,data=gam.data) anova(Gam.object) Gam.object2 <- update(Gam.object, ~.-z) anova(Gam.object, Gam.object2, test="Chisq") } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/gam-internal.Rd0000644000176000001440000000126013236320454014467 0ustar ripleyusers\name{gam-internal} \title{Service functions and as yet undocumented functions for the gam library} \alias{.First.lib} \alias{[.smooth} \alias{general.wam} \alias{anova.Gamlist} \alias{as.anova} \alias{as.data.frame.lo.smooth} \alias{assign.list} \alias{Gamlist} \alias{gam.match} \alias{gam.nlchisq} \alias{gam.sp} \alias{gplot} \alias{gplot.default} \alias{gplot.factor} \alias{gplot.list} \alias{gplot.matrix} \alias{gplot.numeric} \alias{labels.Gam} \alias{lo.wam} \alias{newdata.predict.Gam} \alias{polylo} \alias{print.Gam} \alias{print.Gamex} \alias{print.summary.Gam} \alias{s.wam} \alias{ylim.scale} \description{Internal gam functions} \author{Trevor Hastie} \keyword{internal} gam/man/gam.data.Rd0000644000176000001440000000142310104461516013562 0ustar ripleyusers\name{gam.data} \alias{gam.data} \alias{gam.newdata} \docType{data} \title{Simulated dataset for gam} \description{ A simple simulated dataset, used to test out the gam functions } \usage{ data(gam.data) data(gam.newdata) } \format{ A data frame with 100 observations on the following 6 variables. \describe{ \item{x}{a numeric vector - predictor} \item{y}{a numeric vector - the response} \item{z}{a numeric vector - noise predictor} \item{f}{a numeric vector - true function} \item{probf}{a numeric vector - probability function} \item{ybin}{a numeric vector - binary response} } } \details{ This dataset is artificial, and is used to test out some of the features of gam. } \examples{ data(gam.data) gam(y ~ s(x) + z, data=gam.data) } \keyword{datasets} gam/man/random.Rd0000644000176000001440000000744713072775250013414 0ustar ripleyusers\name{random} \alias{random} \alias{gam.random} \title{Specify a Random Effects Fit in a GAM Formula} \description{A symbolic wrapper for a factor term, to specify a random effect term in a formula argument to gam} \usage{ random(f, df = NULL, lambda = 0, intercept = TRUE) gam.random(f, y, w, df = sum(non.zero), lambda = 0, intercept=TRUE, xeval) } \arguments{ \item{f}{ factor variable, or expression that evaluates to a factor. } \item{y}{a response variable passed to \code{gam.random} during backfitting} \item{w}{weights} \item{df}{ the target equivalent degrees of freedom, used as a smoothing parameter. The real smoothing parameter (\code{lambda} below) is found such that \code{df=tr(S)}, where \code{S} is the implicit smoother matrix. Values for \code{df} should be greater than \code{0} and less than the number of levels of \code{f}. If both \code{df} and \code{lambda} are supplied, the latter takes precedence. Note that \code{df} is not necessarily an integer.} \item{lambda}{ the non-negative penalty parameter. This is interpreted as a variance ratio in a mixed effects model - namely the ratio of the noise variance to the random-effect variance. } \item{intercept}{ if \code{intercept=TRUE} (the default) then the estimated level effects are centered to average zero, otherwise they are left alone. } \item{xeval}{If this argument is present, then \code{gam.random} produces a prediction at \code{xeval}.} } \details{ This "smoother" takes a factor as input and returns a shrunken-mean fit. If \code{lambda=0}, it simply computes the mean of the response at each level of \code{f}. With \code{lambda>0}, it returns a shrunken mean, where the j'th level is shrunk by \code{nj/(nj+lambda)}, with \code{nj} being the number of observations (or sum of their weights) at level \code{j}. Using such smoother(s) in gam is formally equivalent to fitting a mixed-effect model by generalized least squares. } \value{ \code{random} returns the vector \code{f}, endowed with a number of attributes. The vector itself is used in computing the means in backfitting, while the attributes are needed for the backfitting algorithms \code{general.wam}. Note that \code{random} itself does no smoothing; it simply sets things up for \code{gam}. One important attribute is named \code{call}. For example, \code{random(f, lambda=2)} has a call component \code{gam.random(data[["random(f, lambda = 2)"]], z, w, df = NULL, lambda = 2, intercept = TRUE)}. This is an expression that gets evaluated repeatedly in \code{general.wam} (the backfitting algorithm). \code{gam.random} returns an object with components \item{residuals}{The residuals from the smooth fit. } \item{nl.df}{the degrees of freedom} \item{var}{the pointwise variance for the fit} \item{lambda}{the value of \code{lambda} used in the fit} When \code{gam.random} is evaluated with an \code{xeval} argument, it returns a vector of predictions. } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Cantoni, E. and hastie, T. (2002) Degrees-of-freedom tests for smoothing splines, \emph{Biometrika} 89(2), 251-263 } \seealso{ \code{\link{lo}}, \code{\link{s}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}} } \examples{ # fit a model with a linear term in Age and a random effect in the factor Level y ~ Age + random(Level, lambda=1) } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} \keyword{random effects} \keyword{mixed effects} gam/man/plot.gam.Rd0000644000176000001440000001105313236315525013636 0ustar ripleyusers\name{plot.Gam} \alias{plot.Gam} \alias{preplot.Gam} \alias{plot.preplot.Gam} \title{Plot Components of a GAM Object} \description{A plot method for GAM objects, which can be used on GLM and LM objects as well. It focuses on terms (main-effects), and produces a suitable plot for terms of different types} \usage{ \method{plot}{Gam}(x, residuals, rugplot, se, scale, ask = FALSE,terms,\dots) \method{preplot}{Gam}(object, newdata, terms,\dots) } \arguments{ \item{x}{ a \code{Gam} object, or a \code{preplot.Gam} object. The first thing \code{plot.Gam()} does is check if \code{x} has a component called \code{preplot}; if not, it computes one using \code{preplot.Gam()}. Either way, it is this \code{preplot.Gam} object that is required for plotting a \code{Gam} object. } \item{object}{same as \code{x}} \item{residuals}{ if \code{TRUE}, partial deviance residuals are plotted along with the fitted terms---default is \code{FALSE}. If \code{residuals} is a vector with the same length as each fitted term in \code{x}, then these are taken to be the overall residuals to be used for constructing the partial residuals. } \item{rugplot}{ if \code{TRUE} (the default), a univariate histogram or \code{rugplot} is displayed along the base of each plot, showing the occurrence of each `x'; ties are broken by jittering. } \item{se}{ if \code{TRUE}, upper and lower pointwise twice-standard-error curves are included for each plot. The default is \code{FALSE}. } \item{scale}{ a lower limit for the number of units covered by the limits on the `y' for each plot. The default is \code{scale=0}, in which case each plot uses the range of the functions being plotted to create their \code{ylim}. By setting \code{scale} to be the maximum value of \code{diff(ylim)} for all the plots, then all subsequent plots will produced in the same vertical units. This is essential for comparing the importance of fitted terms in additive models. } \item{ask}{ if \code{TRUE}, \code{plot.Gam()} operates in interactive mode. } \item{newdata}{if supplied to \code{preplot.Gam}, the preplot object is based on them rather than the original.} \item{terms}{subsets of the terms can be selected} \item{\dots}{Additonal plotting arguments, not all of which will work (like xlim)} } \value{ a plot is produced for each of the terms in the object \code{x}. The function currently knows how to plot all main-effect functions of one or two predictors. So in particular, interactions are not plotted. An appropriate `x-y' is produced to display each of the terms, adorned with residuals, standard-error curves, and a rugplot, depending on the choice of options. The form of the plot is different, depending on whether the `x'-value for each plot is numeric, a factor, or a matrix. When \code{ask=TRUE}, rather than produce each plot sequentially, \code{plot.Gam()} displays a menu listing all the terms that can be plotted, as well as switches for all the options. A \code{preplot.Gam} object is a list of precomputed terms. Each such term (also a \code{preplot.Gam} object) is a list with components \code{x}, \code{y} and others---the basic ingredients needed for each term plot. These are in turn handed to the specialized plotting function \code{gplot()}, which has methods for different classes of the leading \code{x} argument. In particular, a different plot is produced if \code{x} is numeric, a category or factor, a matrix, or a list. Experienced users can extend this range by creating more \code{gplot()} methods for other classes. Graphical parameters (see \code{\link{par}}) may also be supplied as arguments to this function. This function is a method for the generic function \code{plot()} for class \code{"Gam"}. It can be invoked by calling \code{plot(x)} for an object \code{x} of the appropriate class, or directly by calling \code{plot.Gam(x)} regardless of the class of the object. } \seealso{ \code{\link{preplot}}, \code{\link{predict.Gam}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \examples{ data(gam.data) Gam.object <- gam(y ~ s(x,6) + z,data=gam.data) plot(Gam.object,se=TRUE) data(gam.newdata) preplot(Gam.object,newdata=gam.newdata) } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/predict.gam.Rd0000644000176000001440000001137213236315525014316 0ustar ripleyusers\name{predict.Gam} \alias{predict.Gam} \title{Predict method for GAM fits} \description{Obtains predictions and optionally estimates standard errors of those predictions from a fitted generalized additive model object.} \usage{ \method{predict}{Gam}(object, newdata, type, dispersion, se.fit = FALSE,na.action, terms,\dots) } \arguments{ \item{object}{ a fitted \code{Gam} object, or one of its inheritants, such as a \code{glm} or \code{lm} object. } \item{newdata}{ a data frame containing the values at which predictions are required. This argument can be missing, in which case predictions are made at the same values used to compute the object. Only those predictors, referred to in the right side of the formula in object need be present by name in \code{newdata}. } \item{type}{ type of predictions, with choices \code{"link"} (the default), \code{"response"}, or \code{"terms"}. The default produces predictions on the scale of the additive predictors, and with \code{newdata} missing, \code{predict} is simply an extractor function for this component of a \code{Gam} object. If \code{"response"} is selected, the predictions are on the scale of the response, and are monotone transformations of the additive predictors, using the inverse link function. If \code{type="terms"} is selected, a matrix of predictions is produced, one column for each term in the model. } \item{se.fit}{ if \code{TRUE}, pointwise standard errors are computed along with the predictions. } \item{dispersion}{the dispersion of the GLM fit to be assumed in computing the standard errors. If omitted, that returned by 'summary' applied to the object is used} \item{terms}{ if \code{type="terms"}, the \code{terms=} argument can be used to specify which terms should be included; the default is \code{labels(object)}. } \item{na.action}{ function determining what should be done with missing values in 'newdata'. The default is to predict 'NA'.} \item{\dots}{Placemark for additional arguments to predict} } \value{ a vector or matrix of predictions, or a list consisting of the predictions and their standard errors if \code{se.fit = TRUE}. If \code{type="terms"}, a matrix of fitted terms is produced, with one column for each term in the model (or subset of these if the \code{terms=} argument is used). There is no column for the intercept, if present in the model, and each of the terms is centered so that their average over the original data is zero. The matrix of fitted terms has a \code{"constant"} attribute which, when added to the sum of these centered terms, gives the additive predictor. See the documentation of \code{predict} for more details on the components returned. When \code{newdata} are supplied, \code{predict.Gam} simply invokes inheritance and gets \code{predict.glm} to produce the parametric part of the predictions. For each nonparametric term, \code{predict.Gam} reconstructs the partial residuals and weights from the final iteration of the local scoring algorithm. The appropriate smoother is called for each term, with the appropriate \code{xeval} argument (see \code{\link{s}} or \code{\link{lo}}), and the prediction for that term is produced. The standard errors are based on an approximation given in Hastie (1992). Currently \code{predict.Gam} does not produce standard errors for predictions at \code{newdata}. Warning: naive use of the generic \code{predict} can produce incorrect predictions when the \code{newdata} argument is used, if the formula in \code{object} involves transformations such as \code{sqrt(Age - min(Age))}. } \seealso{\code{\link{predict.glm}}, \code{\link{fitted}}, \code{\link{expand.grid}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). This version of \code{predict.Gam} is adapted from the S version to match the corresponding predict methods for \code{glm} and \code{lm} objects in R. The \code{safe.predict.Gam} function in S is no longer required, primarily because a safe prediction method is in place for functions like \code{ns}, \code{bs}, and \code{poly}. } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S.} New York: Springer. } \examples{ data(gam.data) Gam.object <- gam(y ~ s(x,6) + z, data=gam.data) predict(Gam.object) # extract the additive predictors data(gam.newdata) predict(Gam.object, gam.newdata, type="terms") } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/s.Rd0000644000176000001440000000635013072774405012367 0ustar ripleyusers\name{s} \alias{s} \alias{gam.s} \title{Specify a Smoothing Spline Fit in a GAM Formula} \description{A symbolic wrapper to indicate a smooth term in a formala argument to gam} \usage{ s(x, df=4, spar=1) gam.s(x, y, w, df, spar, xeval) } \arguments{ \item{x}{ the univariate predictor, or expression, that evaluates to a numeric vector. } \item{df}{ the target equivalent degrees of freedom, used as a smoothing parameter. The real smoothing parameter (\code{spar} below) is found such that \code{df=tr(S)-1}, where \code{S} is the implicit smoother matrix. Values for \code{df} should be greater than \code{1}, with \code{df=1} implying a linear fit. If both \code{df} and \code{spar} are supplied, the former takes precedence. Note that \code{df} is not necessarily an integer.} \item{spar}{ can be used as smoothing parameter, with values typically in \code{(0,1]}. See \code{\link{smooth.spline}} for more details.} \item{y}{a response variable passed to \code{gam.s} during backfitting} \item{w}{weights} \item{xeval}{If this argument is present, then \code{gam.s} produces a prediction at \code{xeval}.} } \value{ \code{s} returns the vector \code{x}, endowed with a number of attributes. The vector itself is used in the construction of the model matrix, while the attributes are needed for the backfitting algorithms \code{general.wam} (weighted additive model) or \code{s.wam}. Since smoothing splines reproduces linear fits, the linear part will be efficiently computed with the other parametric linear parts of the model. Note that \code{s} itself does no smoothing; it simply sets things up for \code{gam}. One important attribute is named \code{call}. For example, \code{s(x)} has a call component \code{gam.s(data[["s(x)"]], z, w, spar = 1, df = 4)}. This is an expression that gets evaluated repeatedly in \code{general.wam} (the backfitting algorithm). \code{gam.s} returns an object with components \item{residuals}{The residuals from the smooth fit. Note that the smoother removes the parametric part of the fit (using a linear fit in \code{x}), so these residual represent the nonlinear part of the fit.} \item{nl.df}{the nonlinear degrees of freedom} \item{var}{the pointwise variance for the nonlinear fit} When \code{gam.s} is evaluated with an \code{xeval} argument, it returns a vector of predictions. } \seealso{ \code{\link{lo}}, \code{\link{smooth.spline}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Cantoni, E. and hastie, T. (2002) Degrees-of-freedom tests for smoothing splines, \emph{Biometrika} 89(2), 251-263 } \examples{ # fit Start using a smoothing spline with 4 df. y ~ Age + s(Start, 4) # fit log(Start) using a smoothing spline with 5 df. y ~ Age + s(log(Start), df=5) } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/man/gam.Rd0000644000176000001440000002672613236315525012676 0ustar ripleyusers\name{gam} \title{Fitting Generalized Additive Models} \alias{gam} \alias{gam.fit} \concept{nonparametric} \concept{additive} \concept{regression} \concept{logistic} \concept{log-linear} \concept{loglinear} \description{ \code{gam} is used to fit generalized additive models, specified by giving a symbolic description of the additive predictor and a description of the error distribution. \code{gam} uses the \emph{backfitting algorithm} to combine different smoothing or fitting methods. The methods currently supported are local regression and smoothing splines. } \usage{ gam(formula, family = gaussian, data, weights, subset, na.action, start, etastart, mustart, control = gam.control(\ldots), model=TRUE, method, x=FALSE, y=TRUE, \dots) gam.fit(x, y, smooth.frame, weights = rep(1,nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(), control = gam.control()) } \arguments{ \item{formula}{a formula expression as for other regression models, of the form \code{response ~ predictors}. See the documentation of \code{lm} and \code{formula} for details. Built-in nonparametric smoothing terms are indicated by \code{s} for smoothing splines or \code{lo} for \code{loess} smooth terms. See the documentation for \code{s} and \code{lo} for their arguments. Additional smoothers can be added by creating the appropriate interface functions. Interactions with nonparametric smooth terms are not fully supported, but will not produce errors; they will simply produce the usual parametric interaction.} \item{family}{a description of the error distribution and link function to be used in the model. This can be a character string naming a family function, a family function or the result of a call to a family function. (See \code{\link{family}} for details of family functions.)} \item{data}{an optional data frame containing the variables in the model. If not found in \code{data}, the variables are taken from \code{environment(formula)}, typically the environment from which \code{gam} is called.} \item{weights}{an optional vector of weights to be used in the fitting process.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. The default is set by the \code{na.action} setting of \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. The \dQuote{factory-fresh} default is \code{\link{na.omit}}. A special method \code{\link{na.gam.replace}} allows for mean-imputation of missing values (assumes missing at random), and works gracefully with \code{gam}} \item{start}{starting values for the parameters in the additive predictor.} \item{etastart}{starting values for the additive predictor.} \item{mustart}{starting values for the vector of means.} \item{offset}{this can be used to specify an \emph{a priori} known component to be included in the additive predictor during fitting.} \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{\link{gam.control}} for details. These can also be set as arguments to \code{gam()} itself. } \item{model}{a logical value indicating whether \emph{model frame} should be included as a component of the returned value. Needed if \code{gam} is called and predicted from inside a user function. Default is \code{TRUE}.} \item{method}{the method to be used in fitting the parametric part of the model. The default method \code{"glm.fit"} uses iteratively reweighted least squares (IWLS). The only current alternative is \code{"model.frame"} which returns the model frame and does no fitting.} \item{x, y}{For \code{gam}: logical values indicating whether the response vector and model matrix used in the fitting process should be returned as components of the returned value. For \code{gam.fit}: \code{x} is a model matrix of dimension \code{n * p}, and \code{y} is a vector of observations of length \code{n}. } \item{smooth.frame}{for \code{gam.fit} only. This is essentially a subset of the model frame corresponding to the smooth terms, and has the ingredients needed for smoothing each variable in the backfitting algorithm. The elements of this frame are produced by the formula functions \code{lo} and \code{s}.} \item{\dots}{further arguments passed to or from other methods.} } \details{ The gam model is fit using the local scoring algorithm, which iteratively fits weighted additive models by backfitting. The backfitting algorithm is a Gauss-Seidel method for fitting additive models, by iteratively smoothing partial residuals. The algorithm separates the parametric from the nonparametric part of the fit, and fits the parametric part using weighted linear least squares within the backfitting algorithm. This version of \code{gam} remains faithful to the philosophy of GAM models as outlined in the references below. An object \code{gam.slist} (currently set to \code{c("lo","s","random")}) lists the smoothers supported by \code{gam}. Corresponding to each of these is a smoothing function \code{gam.lo}, \code{gam.s} etc that take particular arguments and produce particular output, custom built to serve as building blocks in the backfitting algorithm. This allows users to add their own smoothing methods. See the documentation for these methods for further information. In addition, the object \code{gam.wlist} (currently set to \code{c("s","lo")}) lists the smoothers for which efficient backfitters are provided. These are invoked if all the smoothing methods are of one kind (either all \code{"lo"} or all \code{"s"}). } \value{ \code{gam} returns an object of class \code{Gam}, which inherits from both \code{glm} and \code{lm}. Gam objects can be examined by \code{print}, \code{summary}, \code{plot}, and \code{anova}. Components can be extracted using extractor functions \code{predict}, \code{fitted}, \code{residuals}, \code{deviance}, \code{formula}, and \code{family}. Can be modified using \code{update}. It has all the components of a \code{glm} object, with a few more. This also means it can be queried, summarized etc by methods for \code{glm} and \code{lm} objects. Other generic functions that have methods for \code{Gam} objects are \code{step} and \code{preplot}. The following components must be included in a legitimate `Gam' object. The residuals, fitted values, coefficients and effects should be extracted by the generic functions of the same name, rather than by the \code{"$"} operator. The \code{family} function returns the entire family object used in the fitting, and \code{deviance} can be used to extract the deviance of the fit. \item{coefficients}{ the coefficients of the parametric part of the \code{additive.predictors}, which multiply the columns of the model matrix. The names of the coefficients are the names of the single-degree-of-freedom effects (the columns of the model matrix). If the model is overdetermined there will be missing values in the coefficients corresponding to inestimable coefficients. } \item{additive.predictors}{ the additive fit, given by the product of the model matrix and the coefficients, plus the columns of the \code{$smooth} component. } \item{fitted.values}{ the fitted mean values, obtained by transforming the component \code{additive.predictors} using the inverse link function. } \item{smooth, nl.df, nl.chisq, var}{ these four characterize the nonparametric aspect of the fit. \code{smooth} is a matrix of smooth terms, with a column corresponding to each smooth term in the model; if no smooth terms are in the \code{Gam} model, all these components will be missing. Each column corresponds to the strictly nonparametric part of the term, while the parametric part is obtained from the model matrix. \code{nl.df} is a vector giving the approximate degrees of freedom for each column of \code{smooth}. For smoothing splines specified by \code{s(x)}, the approximate \code{df} will be the trace of the implicit smoother matrix minus 2. \code{nl.chisq} is a vector containing a type of score test for the removal of each of the columns of \code{smooth}. \code{var} is a matrix like \code{smooth}, containing the approximate pointwise variances for the columns of \code{smooth}. } \item{smooth.frame}{This is essentially a subset of the model frame corresponding to the smooth terms, and has the ingredients needed for making predictions from a \code{Gam} object} \item{residuals}{ the residuals from the final weighted additive fit; also known as residuals, these are typically not interpretable without rescaling by the weights. } \item{deviance}{ up to a constant, minus twice the maximized log-likelihood. Similar to the residual sum of squares. Where sensible, the constant is chosen so that a saturated model has deviance zero. } \item{null.deviance}{The deviance for the null model, comparable with \code{deviance}. The null model will include the offset, and an intercept if there is one in the model} \item{iter}{ the number of local scoring iterations used to compute the estimates. } \item{family}{ a three-element character vector giving the name of the family, the link, and the variance function; mainly for printing purposes. } \item{weights}{the \emph{working} weights, that is the weights in the final iteration of the local scoring fit.} \item{prior.weights}{the case weights initially supplied.} \item{df.residual}{the residual degrees of freedom.} \item{df.null}{the residual degrees of freedom for the null model.} The object will also have the components of a \code{lm} object: \code{coefficients}, \code{residuals}, \code{fitted.values}, \code{call}, \code{terms}, and some others involving the numerical fit. See \code{lm.object}. } \seealso{ \code{\link{glm}}, \code{\link{family}}, \code{\link{lm}}. } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992), and the philosophy in Hastie and Tibshirani (1991). This version of \code{gam} is adapted from the S version to match the \code{glm} and \code{lm} functions in R. Note that this version of \code{gam} is different from the function with the same name in the R library \code{mgcv}, which uses only smoothing splines with a focus on automatic smoothing parameter selection via GCV. To avoid issues with S3 method handling when both packages are loaded, the object class in package "gam" is now "Gam". } \references{ Hastie, T. J. (1991) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth \& Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S.} New York: Springer. } \examples{ data(kyphosis) gam(Kyphosis ~ s(Age,4) + Number, family = binomial, data=kyphosis, trace=TRUE) data(airquality) gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace) gam(Kyphosis ~ poly(Age,2) + s(Start), data=kyphosis, family=binomial, subset=Number>2) data(gam.data) Gam.object <- gam(y ~ s(x,6) + z,data=gam.data) summary(Gam.object) plot(Gam.object,se=TRUE) data(gam.newdata) predict(Gam.object,type="terms",newdata=gam.newdata) } \keyword{models} \keyword{regression} \keyword{nonparametric} \keyword{smooth} gam/INDEX0000644000176000001440000000144513236317145011651 0ustar ripleyusersgam Fit a generalized additive model lo local regression wrapper to be used in a gam formula s smoothing spline wrapper to be used in a gam formula random random effects wrapper plot.Gam an interactive plotting function for Gams predict.Gam make predictions from a Gam object step.Gam stepwise model search with gam anova.Gam compare the fits of a number of Gam models summary.Gam summary method for gam preplot.Gam extracts the components from a Gam in a plot-ready form gam.lo local regression smoother for gam, used by all.wam gam.s smoothing spline smoother for gam,used by all.wam na.gam.replace a missing value method that is helpful with Gams gam.exact a wrapper for semiparametric Gams producing exact standard errors gam.control control parameters for fitting Gam models