gss/0000755000176200001440000000000013477235423011060 5ustar liggesusersgss/inst/0000755000176200001440000000000012345703270012026 5ustar liggesusersgss/inst/CITATION0000644000176200001440000000114212355360640013162 0ustar liggesuserscitHeader("To cite gss in publications use:") citEntry(entry = "Article", title = "Smoothing Spline ANOVA Models: {R} Package {gss}", author = personList(as.person("Chong Gu")), journal = "Journal of Statistical Software", year = "2014", volume = "58", number = "5", pages = "1--25", url = "http://www.jstatsoft.org/v58/i05/", textVersion = paste("Chong Gu (2014).", "Smoothing Spline ANOVA Models: R Package gss.", "Journal of Statistical Software, 58(5), 1-25.", "URL http://www.jstatsoft.org/v58/i05/.") ) gss/src/0000755000176200001440000000000013475776605011661 5ustar liggesusersgss/src/ddeev.f0000644000176200001440000002262413267111001013071 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine ddeev (vmu, nobs, q, ldqr, ldqc, n, nq, u, ldu, uaux, t *, x, theta, nlaht, score, varht, hes, ldh, gra, hwk1, hwk2, gwk1, *gwk2, kwk, ldk, work1, work2, work3, info) character vmu integer nobs, ldqr, ldqc, n, nq, ldu, ldh, ldk, info double precision q(ldqr,ldqc,*), u(ldu,*), uaux(*), t(2,*), x(*), *theta(*), nlaht, score, varht, hes(ldh,*), gra(*), hwk1(nq,*), hwk *2(nq,*), gwk1(*), gwk2(*), kwk(ldk,ldk,*), work1(*), work2(*), wor *k3(*) double precision trc, det, dum, ddot integer i, j, m info = 0 call dset (nq, 0.d0, gra, 1) call dset (nq*nq, 0.d0, hes, 1) if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( nobs .lt. n .or. ldqr .lt. n .or. ldqc .lt. n .or. nq .le. 0 . *or. ldu .lt. n-1 .or. ldh .lt. nq .or. ldk .lt. n )then info = -1 return endif i=2 23004 if(.not.(i.le.nq))goto 23006 if( theta(i) .le. -25.d0 )then goto 23005 endif j=1 23009 if(.not.(j.le.n))goto 23011 call dcopy (n-j+1, q(j,j,i), 1, kwk(j,j,i), 1) call dscal (n-j+1, 10.d0 ** theta(i), kwk(j,j,i), 1) 23010 j=j+1 goto 23009 23011 continue call dqrslm (u, ldu, n-1, n-2, uaux, kwk(2,2,i), n, 0, info, work1 *) call dqrsl (u, ldu, n-1, n-2, uaux, kwk(2,1,i), dum, kwk(2,1,i), d *um, dum, dum, 01000, info) 23005 i=i+1 goto 23004 23006 continue call dcopy (n, t(2,1), 2, kwk(1,1,1), n+1) call dcopy (n-1, t(1,2), 2, kwk(2,1,1), n+1) j=1 23012 if(.not.(j.lt.n-1))goto 23014 call dset (n-j-1, 0.d0, kwk(j+2,j,1), 1) 23013 j=j+1 goto 23012 23014 continue i=2 23015 if(.not.(i.le.nq))goto 23017 if( theta(i) .le. -25.d0 )then goto 23016 endif j=1 23020 if(.not.(j.le.n))goto 23022 call daxpy (n-j+1, -1.d0, kwk(j,j,i), 1, kwk(j,j,1), 1) 23021 j=j+1 goto 23020 23022 continue 23016 i=i+1 goto 23015 23017 continue i=1 23023 if(.not.(i.le.nq))goto 23025 if( theta(i) .le. -25.d0 )then goto 23024 endif j=1 23028 if(.not.(j.lt.n))goto 23030 call dcopy (n-j, kwk(j+1,j,i), 1, kwk(j,j+1,i), n) 23029 j=j+1 goto 23028 23030 continue 23024 i=i+1 goto 23023 23025 continue call dset (n, 10.d0 ** nlaht, work1, 1) call daxpy (n, 1.d0, work1, 1, t(2,1), 2) call dpbfa (t, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif i=1 23033 if(.not.(i.le.nq))goto 23035 if( theta(i) .le. -25.d0 )then goto 23034 endif j=1 23038 if(.not.(j.le.n))goto 23040 call dpbsl (t, 2, n, 1, kwk(1,j,i)) 23039 j=j+1 goto 23038 23040 continue 23034 i=i+1 goto 23033 23035 continue call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) if( vmu .ne. 'm' )then call dcopy (n, work1, 1, work2, 1) call dscal (n, 2.d0, work2, 1) else call dcopy (n, x, 1, work2, 1) endif i=1 23043 if(.not.(i.le.nq))goto 23045 if( theta(i) .le. -25.d0 )then goto 23044 endif call dgemv ('t', n, n, 1.d0, kwk(1,1,i), n, work2, 1, 0.d0, work3, * 1) gwk1(i) = - ddot (n, work1, 1, work3, 1) 23044 i=i+1 goto 23043 23045 continue i=1 23048 if(.not.(i.le.nq))goto 23050 gwk2(i) = 0.d0 if( theta(i) .le. -25.d0 )then goto 23049 endif j=1 23053 if(.not.(j.le.n))goto 23055 if( vmu .ne. 'm' )then call dcopy (n, kwk(1,j,i), 1, work1, 1) call dpbsl (t, 2, n, 1, work1) gwk2(i) = gwk2(i) - work1(j) else gwk2(i) = gwk2(i) - kwk(j,j,i) endif 23054 j=j+1 goto 23053 23055 continue 23049 i=i+1 goto 23048 23050 continue if( vmu .ne. 'm' )then call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) i=1 23060 if(.not.(i.le.nq))goto 23062 if( theta(i) .le. -25.d0 )then goto 23061 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23065 if(.not.(j.le.i))goto 23067 if( theta(j) .le. -25.d0 )then goto 23066 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = 2.d0 * ddot (n, work2, 1, work3, 1) call dgemv ('t', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = hwk1(i,j) + 2.d0 * ddot (n, work2, 1, work3, 1) 23066 j=j+1 goto 23065 23067 continue call dgemv ('t', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23070 if(.not.(j.le.i))goto 23072 if( theta(j) .le. -25.d0 )then goto 23071 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = hwk1(i,j) + 2.d0 * ddot (n, work2, 1, work3, 1) 23071 j=j+1 goto 23070 23072 continue 23061 i=i+1 goto 23060 23062 continue else call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) i=1 23075 if(.not.(i.le.nq))goto 23077 if( theta(i) .le. -25.d0 )then goto 23076 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23080 if(.not.(j.le.i))goto 23082 if( theta(j) .le. -25.d0 )then goto 23081 endif call dgemv ('t', n, n, 1.d0, kwk(1,1,j), n, x, 1, 0.d0, work3, 1) hwk1(i,j) = 2.d0 * ddot (n, work2, 1, work3, 1) 23081 j=j+1 goto 23080 23082 continue 23076 i=i+1 goto 23075 23077 continue endif i=1 23085 if(.not.(i.le.nq))goto 23087 if( theta(i) .le. -25.d0 )then goto 23086 endif hwk1(i,i) = hwk1(i,i) + gwk1(i) 23086 i=i+1 goto 23085 23087 continue i=1 23090 if(.not.(i.le.nq))goto 23092 if( theta(i) .le. -25.d0 )then goto 23091 endif m=1 23095 if(.not.(m.le.i))goto 23097 hwk2(i,m) = 0.d0 if( theta(m) .le. -25.d0 )then goto 23096 endif j=1 23100 if(.not.(j.le.n))goto 23102 if( vmu .ne. 'm' )then call dcopy (n, kwk(1,j,m), 1, work1, 1) call dpbsl (t, 2, n, 1, work1) hwk2(i,m) = hwk2(i,m) + 2.d0 * ddot (n, kwk(j,1,i), n, work1, 1) else hwk2(i,m) = hwk2(i,m) + ddot (n, kwk(j,1,i), n, kwk(1,j,m), 1) endif 23101 j=j+1 goto 23100 23102 continue 23096 m=m+1 goto 23095 23097 continue 23091 i=i+1 goto 23090 23092 continue i=1 23105 if(.not.(i.le.nq))goto 23107 if( theta(i) .le. -25.d0 )then goto 23106 endif hwk2(i,i) = hwk2(i,i) + gwk2(i) 23106 i=i+1 goto 23105 23107 continue if( vmu .eq. 'v' )then trc = dfloat (nobs) * 10.d0 ** (-nlaht) * varht / score i=1 23112 if(.not.(i.le.nq))goto 23114 if( theta(i) .le. -25.d0 )then goto 23113 endif gra(i) = gwk1(i) / trc / trc - 2.d0 * score * gwk2(i) / trc / dflo *at(nobs) 23113 i=i+1 goto 23112 23114 continue call dscal (nq, dfloat (nobs), gra, 1) endif if( vmu .eq. 'u' )then dum = 10.d0 ** nlaht i=1 23119 if(.not.(i.le.nq))goto 23121 if( theta(i) .le. -25.d0 )then goto 23120 endif gra(i) = dum * dum * gwk1(i) - 2.d0 * varht * dum * gwk2(i) 23120 i=i+1 goto 23119 23121 continue call dscal (nq, 1.d0/dfloat (n), gra, 1) endif if( vmu .eq. 'm' )then det = 10.d0 ** (-nlaht) * varht / score i=1 23126 if(.not.(i.le.nq))goto 23128 if( theta(i) .le. -25.d0 )then goto 23127 endif gra(i) = gwk1(i) / det - dfloat (nobs) / dfloat (n) * score * gwk2 *(i) 23127 i=i+1 goto 23126 23128 continue call dscal (nq, 1.d0 / dfloat (nobs), gra, 1) endif if( vmu .eq. 'v' )then i=1 23133 if(.not.(i.le.nq))goto 23135 if( theta(i) .le. -25.d0 )then goto 23134 endif j=1 23138 if(.not.(j.le.i))goto 23140 if( theta(j) .le. -25.d0 )then goto 23139 endif hes(i,j) = hwk1(i,j) / trc / trc - 2.d0 * gwk1(i) * gwk2(j) / trc *** 3 - 2.d0 * gwk1(j) * gwk2(i) / trc ** 3 - 2.d0 * score * hwk2(i *,j) / trc / dfloat (nobs) + 6.d0 * score * gwk2(i) * gwk2(j) / trc * / trc / dfloat (nobs) 23139 j=j+1 goto 23138 23140 continue call dscal (i, dfloat (nobs), hes(i,1), ldh) 23134 i=i+1 goto 23133 23135 continue endif if( vmu .eq. 'u' )then i=1 23145 if(.not.(i.le.nq))goto 23147 if( theta(i) .le. -25.d0 )then goto 23146 endif j=1 23150 if(.not.(j.le.i))goto 23152 if( theta(j) .le. -25.d0 )then goto 23151 endif hes(i,j) = dum * dum * hwk1(i,j) - 2.d0 * varht * dum * hwk2(i,j) 23151 j=j+1 goto 23150 23152 continue call dscal (i, 1.d0/dfloat (n), hes(i,1), ldh) 23146 i=i+1 goto 23145 23147 continue endif if( vmu .eq. 'm' )then i=1 23157 if(.not.(i.le.nq))goto 23159 if( theta(i) .le. -25.d0 )then goto 23158 endif j=1 23162 if(.not.(j.le.i))goto 23164 if( theta(j) .le. -25.d0 )then goto 23163 endif hes(i,j) = hwk1(i,j) / det - gwk1(i) * gwk2(j) / det / dfloat (n) *- gwk1(j) * gwk2(i) / det / dfloat (n) - dfloat (nobs) / dfloat (n *) * score * hwk2(i,j) + dfloat (nobs) / dfloat (n) ** 2 * score * *gwk2(i) * gwk2(j) 23163 j=j+1 goto 23162 23164 continue call dscal (i, 1.d0 / dfloat (nobs), hes(i,1), ldh) 23158 i=i+1 goto 23157 23159 continue endif return end gss/src/hzdnewton.f0000644000176200001440000002033313267111001014015 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine hzdnewton (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, * qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpv *t(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qd *wt(nqd,*), prec, mchpr, wk(*) integer imrs, iwt, ifit, imu, imuwk, iv, ivwk, icdnew, iwtnew, ifi *tnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 2) ifit = iwt + nqd*nx imu = ifit + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis ifitnew = iwtnew + nqd*nx iwk = ifitnew + nt call hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs *, nqd, qdwt, nx, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(ifit) *, wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), wk(iwtne *w), wk(ifitnew), wk(iwk), info) return end subroutine hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt *, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, mrs, wt, fit, mu, muw *k, v, vwk, jpvt, cdnew, wtnew, fitnew, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpv *t(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qd *wt(nqd,*), prec, mchpr, mrs(*), wt(nqd,*), fit(*), mu(*), muwk(*), * v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision tmp, ddot, fitmean, dasum, lkhd, mumax, lkhdnew, *disc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 j=1 23003 if(.not.(j.le.nt))goto 23005 if(cntsum.eq.0)then mrs(i) = mrs(i) + rs(i,j) else mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) endif 23004 j=j+1 goto 23003 23005 continue mrs(i) = mrs(i) / dfloat (nobs) 23001 i=i+1 goto 23000 23002 continue kk=1 23008 if(.not.(kk.le.nx))goto 23010 i=1 23011 if(.not.(i.le.nqd))goto 23013 wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1 *)) 23012 i=i+1 goto 23011 23013 continue 23009 kk=kk+1 goto 23008 23010 continue fitmean = 0.d0 i=1 23014 if(.not.(i.le.nt))goto 23016 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23015 i=i+1 goto 23014 23016 continue fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wt, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean iter = 0 flag = 0 23019 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23022 if(.not.(kk.le.nx))goto 23024 i=1 23025 if(.not.(i.le.nxis))goto 23027 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) j=i 23028 if(.not.(j.le.nxis))goto 23030 vwk(i,j) = 0.d0 k=1 23031 if(.not.(k.le.nqd))goto 23033 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23032 k=k+1 goto 23031 23033 continue 23029 j=j+1 goto 23028 23030 continue 23026 i=i+1 goto 23025 23027 continue call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) 23023 kk=kk+1 goto 23022 23024 continue i=1 23034 if(.not.(i.le.nxi))goto 23036 j=i 23037 if(.not.(j.le.nxi))goto 23039 v(i,j) = v(i,j) + q(i,j) 23038 j=j+1 goto 23037 23039 continue 23035 i=i+1 goto 23034 23036 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23040 if(.not.(i.le.nxis))goto 23042 jpvt(i) = 0 23041 i=i+1 goto 23040 23042 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23043 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23043 endif 23044 continue i=rkv+1 23045 if(.not.(i.le.nxis))goto 23047 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23046 i=i+1 goto 23045 23047 continue 23048 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23051 if(.not.(kk.le.nx))goto 23053 i=1 23054 if(.not.(i.le.nqd))goto 23056 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23056 endif wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) 23055 i=i+1 goto 23054 23056 continue if((flag.eq.1).or.(flag.eq.3))then goto 23053 endif 23052 kk=kk+1 goto 23051 23053 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23063 if(.not.(i.le.nt))goto 23065 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23065 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23064 i=i+1 goto 23063 23065 continue fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wtnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 goto 23050 endif if(flag.eq.3)then goto 23050 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23050 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23050 endif 23049 goto 23048 23050 continue if(flag.eq.1)then flag = 2 goto 23020 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23082 if(.not.(kk.le.nx))goto 23084 i=1 23085 if(.not.(i.le.nqd))goto 23087 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23086 i=i+1 goto 23085 23087 continue 23083 kk=kk+1 goto 23082 23084 continue i=1 23088 if(.not.(i.le.nt))goto 23090 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23089 i=i+1 goto 23088 23090 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+da *bs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nt, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23021 endif if(disc.lt.prec)then goto 23021 endif if(iter.lt.maxiter)then goto 23020 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 flag = 2 else info = 2 goto 23021 endif 23020 goto 23019 23021 continue i=1 23099 if(.not.(i.le.nt))goto 23101 call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(dfloat(cnt(i))), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23100 i=i+1 goto 23099 23101 continue call dprmut (mrs, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, mrs, 11, infowk) trc = ddot (nxis*nt, rs, 1, rs, 1) - dfloat (nobs) * ddot (nxis, m *rs, 1, mrs, 1) trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) mrs(1) = fitmean mrs(2) = trc kk=1 23104 if(.not.(kk.le.nx))goto 23106 i=1 23107 if(.not.(i.le.nqd))goto 23109 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) 23108 i=i+1 goto 23107 23109 continue 23105 kk=kk+1 goto 23104 23106 continue return end gss/src/Makevars0000644000176200001440000000005613267111001013322 0ustar liggesusersPKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) gss/src/smolyak.c0000644000176200001440000016503513267111001013462 0ustar liggesusers/* This is Knut Petras' smolyak.c from SMOLPACK, * modified by Chong Gu to steal the nodes and * weights of the cubature for use in the * R package gss. * * The program implements the delayed Smolyak cubature * as discussed in the references by Knut Petras: * * [1] Asymptotically minimal Smolyak cubature, 2000 * [2] Fast Calculation of Coefficients in the Smolyak Algorithm * * Chong Gu, January 27, 2002, at Purdue. */ # include # include # include /* replace # include "smolyak.h" by one line -- C. Gu */ # define maxdim 40 /* replace # include "smolyak.h" by one line -- C. Gu */ #define uniw 256 /* total # of nodes of quadrature formulae */ #define fn 9 /* # of different basic formula */ #define gesfn 50 /* # of basic formulae (incl. multiplicities) */ static double quafo; /* cubature result */ static double x[maxdim]; /* function argument */ static double xnu[fn][uniw],dnu[fn][uniw]; /* Delta-parameter */ static double fsumme, wsum, wprod, summe; /* working var's */ static int d, q; /* cubature formula parameter */ static int n[fn], ninv[fn], sw[gesfn]; /* working var's */ int count, wcount; /* counter of f-calls and coefficient calls */ static int indeces[maxdim], argind[maxdim]; /* formula and nodal indeces */ static int indsum[maxdim][maxdim]; /* parameter for 'divide et conquer' */ static int anzw[uniw], lookind[fn][uniw], invlook[fn][uniw], maxind; /* tree parameter */ static int wind[maxdim]; /* Parameter for slow coefficient calculation */ static double (*f)(int, double x[]); /* integrand (global) */ static void formula(int,int); /* sub-formula "between two dimensions" */ static double eval(int); /* sub-formula calculator */ static double fsum(int); /* sum(f(+-x_nu)) (use of symmetry) */ /* get pt and wt from formula1, eval1, fsum1 -- C. Gu */ static double wtt; static void formula1(int, int, double *pt, double *wt); static void eval1(int, double *pt, double *wt); static void fsum1(int, double *pt, double *wt); /* get pt and wt from formula1, eval1, fsum1 -- C. Gu */ static void init(); /* initialization */ static double calccoeff(int); /* coefficient calculator */ static double calccoeff2(int,int); /* coefficient calculator (slow) */ static double wl(int, int, int); /* 'divide */ static double we(int, int, int); /* and */ static void sumind(int, int); /* conquer' */ /*************** tree definitions: *************************/ struct tnode { int empty; double *coeff; int *belegt; struct tnode *left; struct tnode *right; }; static struct tnode *root; static double coeff(); /* tree manager */ static struct tnode *talloc(void); /* node generator */ static void frei(struct tnode *p); /* tree eraser */ /* Start of R interface -- C. Gu */ double f_dummy(int dd, double x[]) { count++; return 1; } void size_smolyak(int *dd, int *qq, int *size) /********************** get size ***************************/ { d=*dd; q=*qq; f=f_dummy; init(); formula(1,q-d); frei(root); *size = count; } void quad_smolyak(int *dd, int *qq, double *pt, double *wt) /********************** get pt and wt ***************************/ { d=*dd; q=*qq; f=f_dummy; init(); formula1(1,q-d,pt,wt); frei(root); } /* End of R interface -- C. Gu */ double int_smolyak(int dd, int qq, double(*ff)(int,double xx[]), int size) /********************** main program ***************************/ /*** for formula parameter dd<40, qq-dd<48 ******/ { /* make parameter global: */ d=dd; q=qq; f=ff; /* Initialisation */ init(); /* call of Smolyak algorithm */ formula(1,q-d); /* free space */ frei(root); /* statistics ( if desired ) */ /* if (size) { printf("%i function calls and ", count); printf("%i coefficient calculations \n", wcount);}*/ return quafo; } void formula(int k,int l) /* If k==d: evaluation. */ /* Else: */ /* determine the required formula */ /* l is the index sum that may be distributed */ /* to the remaining dimensions */ { int i; if (k==d+1) { quafo = quafo + eval(0); } else for (i=0; (i<=l) ; i++) /* Use only non-dummy-formulae */ if (sw[i]=1; j--){ /* anzw[j] to the L E F T */ if (p->left==NULL){ /* if node not existing, node generation : */ p->left = (struct tnode *) calloc(maxdim, sizeof(struct tnode)); pt=(p->left+anzw[j]); pt->left=pt->right=NULL; pt->empty = 1; p=pt;} else p=(p->left+anzw[j]); /* one to the R I G H T */ if (p->right==NULL){ /* if node not existing: */ pt=talloc(); /* node generation */ pt->empty=1; pt->left=pt->right=NULL; if (j==1){ /* leaf with coefficient */ pt->coeff=(double *) calloc(maxdim, sizeof(double)); pt->belegt=(int *) calloc(maxdim, sizeof(int)); pt->empty=0; }; p->right=pt; }; p=p->right; } if (!*(p->belegt+anzw[0])){ /* evtl. coeff.-calc. necessary */ wcount++; *(p->coeff +anzw[0]) = calccoeff(q-d); *(p->belegt+anzw[0]) =1; }; return *(p->coeff +anzw[0]); } void frei(struct tnode *p) /* tree eraser */ { if (!(p->empty)) { free (p->coeff); free (p->belegt);}; if (!(p->left ==NULL)) frei(p->left); if (!(p->right ==NULL)) frei(p->right); free(p); } struct tnode *talloc(void) /* Space for new tree-node */ { return (struct tnode *) malloc (sizeof(struct tnode)); } /******** tree-functions finished ******/ void sumind(int r, int s) /* Calculation of sums of formula indices at division of dimension r...s */ { int q; if (s==r) indsum[r][s] = ninv[indeces[r]]; else { q=(r+s)/2; sumind(r,q); sumind(q+1,s); indsum[r][s] = indsum[r][q] + indsum[q+1][s]; }; } double calccoeff (int l) { sumind(1,d); /* calculation of parameters of subdivision */ return wl(1,d,l); /* start of 'divide and conquer' */ } double wl(int r,int s, int l) /* sums in dimension s...r with sum of formula numbers <=l */ { double sum=0; int i,q, p; if (r==s) /* one-dimensional */ { p=lookind[indeces[r]][argind[r]]; for (i=ninv[indeces[r]]; i<=l; i++) { if (sw[i]=ninv[maxform+1]) maxform=maxform+1; /* total number of used 1-dim nodes */ maxind = (nj[maxform]+1)/2; /* table of 1-dim nodal numbers 0..maxind-1 corresponding to a combination formula number/nodal number and inverse formula */ lookind[0][0] = 0; for (i=1; i<=maxform; i++) { formfakt=pow(2, maxform-i); for (j=0; j<(nj[i]+1)/4; j++) lookind[i][j] = formfakt*(2*j+1); /* in a linear ordering of all used nodes, the (2j+1)-th node of the i-th basic formula is lookind[i][j]-th node */ for (j=0; j<(nj[i]+1)/2; j++) invlook[i][formfakt*j] = j; /* the lookind[i][2^(maxform-i)]-th node in a linear ordering of all used nodes is the j-th node of the i-th basic formula. Note that maxrorm is the number of used different basic formulae */ }; /* root of the coefficient TREE */ root=talloc(); root->empty=1; root->left=root->right=NULL; /* one dimensional formulae (Deltas) */ xnu[0][0] = 0.5; dnu[0][0] = 1.0; xnu[1][0] = 5.000000000000000E-001; xnu[1][1] = 8.8729833462074168851793E-001; dnu[1][0] = -5.5555555555555555555556E-001; dnu[1][1] = 2.7777777777777777777778E-001; xnu[2][0] = 5.0000000000000000000000E-001; xnu[2][1] = 7.1712187467340127900104E-001; xnu[2][2] = 8.8729833462074168851793E-001; xnu[2][3] = 9.8024563435401014171175E-001; dnu[2][0] = -2.1898617511520737327189E-001; dnu[2][1] = 2.0069870738798111145253E-001; dnu[2][2] = -1.4353373284361105741349E-001; dnu[2][3] = 5.2328113013233632596912E-002; xnu[3][0] = 5.0000000000000000000000E-001; xnu[3][1] = 6.1169334321448344081410E-001; xnu[3][2] = 7.1712187467340127900104E-001; xnu[3][3] = 8.1055147336861320147034E-001; xnu[3][4] = 8.8729833462074168851793E-001; xnu[3][5] = 9.4422961643612849944521E-001; xnu[3][6] = 9.8024563435401014171175E-001; xnu[3][7] = 9.9691598160637751110426E-001; dnu[3][0] = -1.1270301943013372747934E-001; dnu[3][1] = 1.0957842920079374820185E-001; dnu[3][2] = -1.0038444269948660093556E-001; dnu[3][3] = 8.5755954568195690393677E-002; dnu[3][4] = -6.7036417312274610184300E-002; dnu[3][5] = 4.6463597657562268842947E-002; dnu[3][6] = -2.6526471514693762748452E-002; dnu[3][7] = 8.5008598149701301695137E-003; xnu[4][0] = 5.0000000000000000000000E-001; xnu[4][1] = 5.5624447156659331287292E-001; xnu[4][2] = 6.1169334321448344081410E-001; xnu[4][3] = 6.6556769662898841654632E-001; xnu[4][4] = 7.1712187467340127900104E-001; xnu[4][5] = 7.6565987182218781198605E-001; xnu[4][6] = 8.1055147336861320147034E-001; xnu[4][7] = 8.5124810324576353930490E-001; xnu[4][8] = 8.8729833462074168851793E-001; xnu[4][9] = 9.1836296908443436775138E-001; xnu[4][10] = 9.4422961643612849944521E-001; xnu[4][11] = 9.6482742871487002833506E-001; xnu[4][12] = 9.8024563435401014171175E-001; xnu[4][13] = 9.9076557477687005343368E-001; xnu[4][14] = 9.9691598160637751110426E-001; xnu[4][15] = 9.9954906248383379883111E-001; dnu[4][0] = -5.6377621538718997889636E-002; dnu[4][1] = 5.5978436510476728440072E-002; dnu[4][2] = -5.4789218672831429083502E-002; dnu[4][3] = 5.2834946790117404871908E-002; dnu[4][4] = -5.0157125382596721131319E-002; dnu[4][5] = 4.6813554990632236808329E-002; dnu[4][6] = -4.2877994543200514816583E-002; dnu[4][7] = 3.8439810249501765521353E-002; dnu[4][8] = -3.3603750473896758409784E-002; dnu[4][9] = 2.8489754747061678706099E-002; dnu[4][10] = -2.3232151026683275572245E-002; dnu[4][11] = 1.7978551653564661048389E-002; dnu[4][12] = -1.2897842450451543066137E-002; dnu[4][13] = 8.2230249271939054668942E-003; dnu[4][14] = -4.2835769453095770463562E-003; dnu[4][15] = 1.2723903957809372077014E-003; xnu[5][0] = 5.0000000000000000000000E-001; xnu[5][1] = 5.2817215652329639498598E-001; xnu[5][2] = 5.5624447156659331287292E-001; xnu[5][3] = 5.8411762577610373249116E-001; xnu[5][4] = 6.1169334321448344081410E-001; xnu[5][5] = 6.3887491101091215753268E-001; xnu[5][6] = 6.6556769662898841654632E-001; xnu[5][7] = 6.9167966209936517345824E-001; xnu[5][8] = 7.1712187467340127900104E-001; xnu[5][9] = 7.4180901347292051378108E-001; xnu[5][10] = 7.6565987182218781198605E-001; xnu[5][11] = 7.8859785502602290742185E-001; xnu[5][12] = 8.1055147336861320147034E-001; xnu[5][13] = 8.3145483001239029773051E-001; xnu[5][14] = 8.5124810324576353930490E-001; xnu[5][15] = 8.6987802217634737933861E-001; xnu[5][16] = 8.8729833462074168851793E-001; xnu[5][17] = 9.0347026597510880592815E-001; xnu[5][18] = 9.1836296908443436775138E-001; xnu[5][19] = 9.3195396909684523857321E-001; xnu[5][20] = 9.4422961643612849944521E-001; xnu[5][21] = 9.5518557847850214624890E-001; xnu[5][22] = 9.6482742871487002833506E-001; xnu[5][23] = 9.7317142918670145257425E-001; xnu[5][24] = 9.8024563435401014171175E-001; xnu[5][25] = 9.8609143737429089828903E-001; xnu[5][26] = 9.9076557477687005343368E-001; xnu[5][27] = 9.9434237877371473996926E-001; xnu[5][28] = 9.9691598160637751110426E-001; xnu[5][29] = 9.9860312968611097953823E-001; xnu[5][30] = 9.9954906248383379883111E-001; xnu[5][31] = 9.9993644406017880596898E-001; dnu[5][0] = -2.8188814180191987109744E-002; dnu[5][1] = 2.8138849915627150636298E-002; dnu[5][2] = -2.7989218255238568736295E-002; dnu[5][3] = 2.7740702178279681993919E-002; dnu[5][4] = -2.7394605263980886602235E-002; dnu[5][5] = 2.6952749667633031963438E-002; dnu[5][6] = -2.6417473395059144940870E-002; dnu[5][7] = 2.5791626976024229388405E-002; dnu[5][8] = -2.5078569652948020678807E-002; dnu[5][9] = 2.4282165203336599357974E-002; dnu[5][10] = -2.3406777495318230607005E-002; dnu[5][11] = 2.2457265826816098707127E-002; dnu[5][12] = -2.1438980012491308330637E-002; dnu[5][13] = 2.0357755058472159466947E-002; dnu[5][14] = -1.9219905124773999502032E-002; dnu[5][15] = 1.8032216390391286320054E-002; dnu[5][16] = -1.6801938573891486499334E-002; dnu[5][17] = 1.5536775555843982439942E-002; dnu[5][18] = -1.4244877374144904399846E-002; dnu[5][19] = 1.2934839663607373455379E-002; dnu[5][20] = -1.1615723310923858549074E-002; dnu[5][21] = 1.0297116957956355574594E-002; dnu[5][22] = -8.9892758695005258819409E-003; dnu[5][23] = 7.7033752332797489010654E-003; dnu[5][24] = -6.4518989979126939693347E-003; dnu[5][25] = 5.2491234548106609491364E-003; dnu[5][26] = -4.1115209485759406322653E-003; dnu[5][27] = 3.0577534110586231698391E-003; dnu[5][28] = -2.1084676488811257036154E-003; dnu[5][29] = 1.2895248973428441362139E-003; dnu[5][30] = -6.3981211766590320201509E-004; dnu[5][31] = 1.8161074092276532984679E-004; xnu[6][0] = 5.0000000000000000000000E-001; xnu[6][1] = 5.1409232447487284716970E-001; xnu[6][2] = 5.2817215652329639498598E-001; xnu[6][3] = 5.4222702004185544185509E-001; xnu[6][4] = 5.5624447156659331287292E-001; xnu[6][5] = 5.7021211657628008729691E-001; xnu[6][6] = 5.8411762577610373249116E-001; xnu[6][7] = 5.9794875135555007695773E-001; xnu[6][8] = 6.1169334321448344081410E-001; xnu[6][9] = 6.2533936515174158830648E-001; xnu[6][10] = 6.3887491101091215753268E-001; xnu[6][11] = 6.5228822077835702166766E-001; xnu[6][12] = 6.6556769662898841654632E-001; xnu[6][13] = 6.7870191891576607618811E-001; xnu[6][14] = 6.9167966209936517345824E-001; xnu[6][15] = 7.0448991061494433620452E-001; xnu[6][16] = 7.1712187467340127900104E-001; xnu[6][17] = 7.2956500599491616643675E-001; xnu[6][18] = 7.4180901347292051378108E-001; xnu[6][19] = 7.5384387876685830107739E-001; xnu[6][20] = 7.6565987182218781198605E-001; xnu[6][21] = 7.7724756631596627443319E-001; xnu[6][22] = 7.8859785502602290742185E-001; xnu[6][23] = 7.9970196512112144648713E-001; xnu[6][24] = 8.1055147336861320147034E-001; xnu[6][25] = 8.2113832125487975688706E-001; xnu[6][26] = 8.3145483001239029773051E-001; xnu[6][27] = 8.4149371554553961404354E-001; xnu[6][28] = 8.5124810324576353930490E-001; xnu[6][29] = 8.6071154268504945774249E-001; xnu[6][30] = 8.6987802217634737933861E-001; xnu[6][31] = 8.7874198319025681896313E-001; xnu[6][32] = 8.8729833462074168851793E-001; xnu[6][33] = 8.9554246689992418071732E-001; xnu[6][34] = 9.0347026597510880592815E-001; xnu[6][35] = 9.1107812718249020368626E-001; xnu[6][36] = 9.1836296908443436775138E-001; xnu[6][37] = 9.2532224738417513987891E-001; xnu[6][38] = 9.3195396909684523857321E-001; xnu[6][39] = 9.3825670724235263487081E-001; xnu[6][40] = 9.4422961643612849944521E-001; xnu[6][41] = 9.4987244988847001831932E-001; xnu[6][42] = 9.5518557847850214624890E-001; xnu[6][43] = 9.6017001273500621036491E-001; xnu[6][44] = 9.6482742871487002833506E-001; xnu[6][45] = 9.6916019888979644182741E-001; xnu[6][46] = 9.7317142918670145257425E-001; xnu[6][47] = 9.7686500321288056820737E-001; xnu[6][48] = 9.8024563435401014171175E-001; xnu[6][49] = 9.8331892577920828354614E-001; xnu[6][50] = 9.8609143737429089828903E-001; xnu[6][51] = 9.8857075731985285707820E-001; xnu[6][52] = 9.9076557477687005343368E-001; xnu[6][53] = 9.9268574979926018555688E-001; xnu[6][54] = 9.9434237877371473996926E-001; xnu[6][55] = 9.9574786058905306619925E-001; xnu[6][56] = 9.9691598160637751110426E-001; xnu[6][57] = 9.9786205234920359425472E-001; xnu[6][58] = 9.9860312968611097953823E-001; xnu[6][59] = 9.9915831765920369626532E-001; xnu[6][60] = 9.9954906248383379883111E-001; xnu[6][61] = 9.9979939983595534162598E-001; xnu[6][62] = 9.9993644406017880596898E-001; xnu[6][63] = 9.9999121517744579929001E-001; dnu[6][0] = -1.4094407090096179346916E-002; dnu[6][1] = 1.4088159516508301065327E-002; dnu[6][2] = -1.4069424957813575318149E-002; dnu[6][3] = 1.4038227896908623303424E-002; dnu[6][4] = -1.3994609127619079851888E-002; dnu[6][5] = 1.3938625738306850804262E-002; dnu[6][6] = -1.3870351089139840996960E-002; dnu[6][7] = 1.3789874783240936517434E-002; dnu[6][8] = -1.3697302631990716258054E-002; dnu[6][9] = 1.3592756614812395909604E-002; dnu[6][10] = -1.3476374833816515981719E-002; dnu[6][11] = 1.3348311463725179953077E-002; dnu[6][12] = -1.3208736697529129965519E-002; dnu[6][13] = 1.3057836688353048840249E-002; dnu[6][14] = -1.2895813488012114694202E-002; dnu[6][15] = 1.2722884982732382906287E-002; dnu[6][16] = -1.2539284826474884353420E-002; dnu[6][17] = 1.2345262372243838454530E-002; dnu[6][18] = -1.2141082601668299678987E-002; dnu[6][19] = 1.1927026053019270040223E-002; dnu[6][20] = -1.1703388747657003100662E-002; dnu[6][21] = 1.1470482114693874380400E-002; dnu[6][22] = -1.1228632913408049353564E-002; dnu[6][23] = 1.0978183152658912469630E-002; dnu[6][24] = -1.0719490006251933623228E-002; dnu[6][25] = 1.0452925722906011926111E-002; dnu[6][26] = -1.0178877529236079733474E-002; dnu[6][27] = 9.8977475240487497440139E-003; dnu[6][28] = -9.6099525623638830096600E-003; dnu[6][29] = 9.3159241280693950931570E-003; dnu[6][30] = -9.0161081951956431600270E-003; dnu[6][31] = 8.7109650797320868735761E-003; dnu[6][32] = -8.4009692870519326354323E-003; dnu[6][33] = 8.0866093647888599709740E-003; dnu[6][34] = -7.7683877779219912199780E-003; dnu[6][35] = 7.4468208324075910174052E-003; dnu[6][36] = -7.1224386864583871530823E-003; dnu[6][37] = 6.7957855048827733947865E-003; dnu[6][38] = -6.4674198318036867280122E-003; dnu[6][39] = 6.1379152800413850434832E-003; dnu[6][40] = -5.8078616599775673581358E-003; dnu[6][41] = 5.4778666939189508240164E-003; dnu[6][42] = -5.1485584789781778127510E-003; dnu[6][43] = 4.8205888648512683476492E-003; dnu[6][44] = -4.4946378920320673048077E-003; dnu[6][45] = 4.1714193769840788527921E-003; dnu[6][46] = -3.8516876166398779769824E-003; dnu[6][47] = 3.5362449977167777340232E-003; dnu[6][48] = -3.2259500250877643515858E-003; dnu[6][49] = 2.9217249379178197537798E-003; dnu[6][50] = -2.6245617274062313865695E-003; dnu[6][51] = 2.3355251860571608737027E-003; dnu[6][52] = -2.0557519892906183110438E-003; dnu[6][53] = 1.7864463917586498246922E-003; dnu[6][54] = -1.5288767059708576017734E-003; dnu[6][55] = 1.2843824718970101865639E-003; dnu[6][56] = -1.0544075979161109798758E-003; dnu[6][57] = 8.4057143271073495315687E-004; dnu[6][58] = -6.4476285603763544016464E-004; dnu[6][59] = 4.6918492427119075039702E-004; dnu[6][60] = -3.1627461843371723357680E-004; dnu[6][61] = 1.8887332316349233013718E-004; dnu[6][62] = -9.1240958700071150936623E-005; dnu[6][63] = 2.5268047603931258812333E-005; xnu[7][0] = 5.0000000000000000000000E-001; xnu[7][1] = 5.0704694320539123130709E-001; xnu[7][2] = 5.1409232447487284716970E-001; xnu[7][3] = 5.2113458238268180160620E-001; xnu[7][4] = 5.2817215652329639498598E-001; xnu[7][5] = 5.3520348802142758953165E-001; xnu[7][6] = 5.4222702004185544185509E-001; xnu[7][7] = 5.4924119829905960104514E-001; xnu[7][8] = 5.5624447156659331287292E-001; xnu[7][9] = 5.6323529218615098342533E-001; xnu[7][10] = 5.7021211657628008729691E-001; xnu[7][11] = 5.7717340574068905434622E-001; xnu[7][12] = 5.8411762577610373249116E-001; xnu[7][13] = 5.9104324837962609912320E-001; xnu[7][14] = 5.9794875135555007695773E-001; xnu[7][15] = 6.0483261912159059738317E-001; xnu[7][16] = 6.1169334321448344081410E-001; xnu[7][17] = 6.1852942279491486360633E-001; xnu[7][18] = 6.2533936515174158830648E-001; xnu[7][19] = 6.3212168620546338097247E-001; xnu[7][20] = 6.3887491101091215753268E-001; xnu[7][21] = 6.4559757425912334098185E-001; xnu[7][22] = 6.5228822077835702166766E-001; xnu[7][23] = 6.5894540603423834159087E-001; xnu[7][24] = 6.6556769662898841654632E-001; xnu[7][25] = 6.7215367079971901138831E-001; xnu[7][26] = 6.7870191891576607618811E-001; xnu[7][27] = 6.8521104397503911506877E-001; xnu[7][28] = 6.9167966209936517345824E-001; xnu[7][29] = 6.9810640302880796959126E-001; xnu[7][30] = 7.0448991061494433620452E-001; xnu[7][31] = 7.1082884331308165002815E-001; xnu[7][32] = 7.1712187467340127900104E-001; xnu[7][33] = 7.2336769383101423687111E-001; xnu[7][34] = 7.2956500599491616643675E-001; xnu[7][35] = 7.3571253293582943846704E-001; xnu[7][36] = 7.4180901347292051378108E-001; xnu[7][37] = 7.4785320395938073008506E-001; xnu[7][38] = 7.5384387876685830107739E-001; xnu[7][39] = 7.5977983076872851099646E-001; xnu[7][40] = 7.6565987182218781198605E-001; xnu[7][41] = 7.7148283324915574524615E-001; xnu[7][42] = 7.7724756631596627443319E-001; xnu[7][43] = 7.8295294271182721131149E-001; xnu[7][44] = 7.8859785502602290742185E-001; xnu[7][45] = 7.9418121722383127071718E-001; xnu[7][46] = 7.9970196512112144648713E-001; xnu[7][47] = 8.0515905685759320007779E-001; xnu[7][48] = 8.1055147336861320147034E-001; xnu[7][49] = 8.1587821885559711520679E-001; xnu[7][50] = 8.2113832125487975688706E-001; xnu[7][51] = 8.2633083270500874805039E-001; xnu[7][52] = 8.3145483001239029773051E-001; xnu[7][53] = 8.3650941511520923959944E-001; xnu[7][54] = 8.4149371554553961404354E-001; xnu[7][55] = 8.4640688488955735144733E-001; xnu[7][56] = 8.5124810324576353930490E-001; xnu[7][57] = 8.5601657768112601729334E-001; xnu[7][58] = 8.6071154268504945774249E-001; xnu[7][59] = 8.6533226062109063066465E-001; xnu[7][60] = 8.6987802217634737933861E-001; xnu[7][61] = 8.7434814680846830141141E-001; xnu[7][62] = 8.7874198319025681896313E-001; xnu[7][63] = 8.8305890965188004535834E-001; xnu[7][64] = 8.8729833462074168851793E-001; xnu[7][65] = 8.9145969705914150819259E-001; xnu[7][66] = 8.9554246689992418071732E-001; xnu[7][67] = 8.9954614548042070089990E-001; xnu[7][68] = 9.0347026597510880592815E-001; xnu[7][69] = 9.0731439382756870671791E-001; xnu[7][70] = 9.1107812718249020368626E-001; xnu[7][71] = 9.1476109731870070008905E-001; xnu[7][72] = 9.1836296908443436775138E-001; xnu[7][73] = 9.2188344133635430051916E-001; xnu[7][74] = 9.2532224738417513987891E-001; xnu[7][75] = 9.2867915544311607826256E-001; xnu[7][76] = 9.3195396909684523857321E-001; xnu[7][77] = 9.3514652777405695292558E-001; xnu[7][78] = 9.3825670724235263487081E-001; xnu[7][79] = 9.4128442012367095342085E-001; xnu[7][80] = 9.4422961643612849944521E-001; xnu[7][81] = 9.4709228416777951142968E-001; xnu[7][82] = 9.4987244988847001831932E-001; xnu[7][83] = 9.5257017940663079759465E-001; xnu[7][84] = 9.5518557847850214624890E-001; xnu[7][85] = 9.5771879357788252032198E-001; xnu[7][86] = 9.6017001273500621036491E-001; xnu[7][87] = 9.6253946645353782618207E-001; xnu[7][88] = 9.6482742871487002833506E-001; xnu[7][89] = 9.6703421807886289399974E-001; xnu[7][90] = 9.6916019888979644182741E-001; xnu[7][91] = 9.7120578259554152990628E-001; xnu[7][92] = 9.7317142918670145257425E-001; xnu[7][93] = 9.7505764876064743827892E-001; xnu[7][94] = 9.7686500321288056820737E-001; xnu[7][95] = 9.7859410805493048136810E-001; xnu[7][96] = 9.8024563435401014171175E-001; xnu[7][97] = 9.8182031078490606626049E-001; xnu[7][98] = 9.8331892577920828354614E-001; xnu[7][99] = 9.8474232975122961588545E-001; xnu[7][100] = 9.8609143737429089828903E-001; xnu[7][101] = 9.8736722987620133388036E-001; xnu[7][102] = 9.8857075731985285707820E-001; xnu[7][103] = 9.8970314083543134190307E-001; xnu[7][104] = 9.9076557477687005343368E-001; xnu[7][105] = 9.9175932878931636438083E-001; xnu[7][106] = 9.9268574979926018555688E-001; xnu[7][107] = 9.9354626397701703359495E-001; xnu[7][108] = 9.9434237877371473996926E-001; xnu[7][109] = 9.9507568520038507959027E-001; xnu[7][110] = 9.9574786058905306619925E-001; xnu[7][111] = 9.9636067214139430766410E-001; xnu[7][112] = 9.9691598160637751110426E-001; xnu[7][113] = 9.9741575140031050025957E-001; xnu[7][114] = 9.9786205234920359425472E-001; xnu[7][115] = 9.9825707295744513692434E-001; xnu[7][116] = 9.9860312968611097953823E-001; xnu[7][117] = 9.9890267724797863728092E-001; xnu[7][118] = 9.9915831765920369626532E-001; xnu[7][119] = 9.9937280723404755735176E-001; xnu[7][120] = 9.9954906248383379883111E-001; xnu[7][121] = 9.9969016901251179096404E-001; xnu[7][122] = 9.9979939983595534162598E-001; xnu[7][123] = 9.9988024546221602366522E-001; xnu[7][124] = 9.9993644406017880596898E-001; xnu[7][125] = 9.9997199810352718788193E-001; xnu[7][126] = 9.9999121517744579929001E-001; xnu[7][127] = 9.9999879818987423231012E-001; dnu[7][0] = -7.0472035450480896734578E-003; dnu[7][1] = 7.0464225345802041774796E-003; dnu[7][2] = -7.0440797582541505326634E-003; dnu[7][3] = 7.0401759812768306624229E-003; dnu[7][4] = -7.0347124789067876590744E-003; dnu[7][5] = 7.0276910363249821385840E-003; dnu[7][6] = -7.0191139484543116517120E-003; dnu[7][7] = 7.0089840197283044049361E-003; dnu[7][8] = -6.9973045638095399259442E-003; dnu[7][9] = 6.9840794032584692578639E-003; dnu[7][10] = -6.9693128691534254021309E-003; dnu[7][11] = 6.9530098006627306317656E-003; dnu[7][12] = -6.9351755445699204984798E-003; dnu[7][13] = 6.9158159547532143382480E-003; dnu[7][14] = -6.8949373916204682587172E-003; dnu[7][15] = 6.8725467215009483161260E-003; dnu[7][16] = -6.8486513159953581290272E-003; dnu[7][17] = 6.8232590512856457141999E-003; dnu[7][18] = -6.7963783074061979548022E-003; dnu[7][19] = 6.7680179674781068068327E-003; dnu[7][20] = -6.7381874169082579908596E-003; dnu[7][21] = 6.7068965425550492564832E-003; dnu[7][22] = -6.6741557318625899765387E-003; dnu[7][23] = 6.6399758719652653251888E-003; dnu[7][24] = -6.6043683487645649827596E-003; dnu[7][25] = 6.5673450459800764181907E-003; dnu[7][26] = -6.5289183441765244201247E-003; dnu[7][27] = 6.4891011197686996429211E-003; dnu[7][28] = -6.4479067440060573471011E-003; dnu[7][29] = 6.4053490819386809834209E-003; dnu[7][30] = -6.3614424913661914531436E-003; dnu[7][31] = 6.3162018217710393822703E-003; dnu[7][32] = -6.2696424132374421767099E-003; dnu[7][33] = 6.2217800953570176315748E-003; dnu[7][34] = -6.1726311861219192272652E-003; dnu[7][35] = 6.1222124908059929493146E-003; dnu[7][36] = -6.0705413008341498394934E-003; dnu[7][37] = 6.0176353926397813152249E-003; dnu[7][38] = -5.9635130265096350201115E-003; dnu[7][39] = 5.9081929454151178816124E-003; dnu[7][40] = -5.8516943738285015503310E-003; dnu[7][41] = 5.7940370165219762842120E-003; dnu[7][42] = -5.7352410573469371902001E-003; dnu[7][43] = 5.6753271579902983008672E-003; dnu[7][44] = -5.6143164567040246767818E-003; dnu[7][45] = 5.5522305670034632684997E-003; dnu[7][46] = -5.4890915763294562348151E-003; dnu[7][47] = 5.4249220446686570495123E-003; dnu[7][48] = -5.3597450031259668116140E-003; dnu[7][49] = 5.2935839524425989654714E-003; dnu[7][50] = -5.2264628614530059630555E-003; dnu[7][51] = 5.1584061654738108409604E-003; dnu[7][52] = -5.0894387646180398667368E-003; dnu[7][53] = 5.0195860220284203990905E-003; dnu[7][54] = -4.9488737620243748720069E-003; dnu[7][55] = 4.8773282681587057305415E-003; dnu[7][56] = -4.8049762811819415048301E-003; dnu[7][57] = 4.7318449969150326471362E-003; dnu[7][58] = -4.6579620640346975465785E-003; dnu[7][59] = 4.5833555817803942033526E-003; dnu[7][60] = -4.5080540975978215800133E-003; dnu[7][61] = 4.4320866047412471320571E-003; dnu[7][62] = -4.3554825398660434367881E-003; dnu[7][63] = 4.2782717806538448095865E-003; dnu[7][64] = -4.2004846435259663177174E-003; dnu[7][65] = 4.1221518815164340152753E-003; dnu[7][66] = -4.0433046823944299854870E-003; dnu[7][67] = 3.9639746671474245551263E-003; dnu[7][68] = -3.8841938889609956099821E-003; dnu[7][69] = 3.8039948328595282916087E-003; dnu[7][70] = -3.7234104162037955087026E-003; dnu[7][71] = 3.6424739902769035319399E-003; dnu[7][72] = -3.5612193432291935765854E-003; dnu[7][73] = 3.4796807046952114697225E-003; dnu[7][74] = -3.3978927524413866973932E-003; dnu[7][75] = 3.3158906214509439470610E-003; dnu[7][76] = -3.2337099159018433636835E-003; dnu[7][77] = 3.1513867245428793585820E-003; dnu[7][78] = -3.0689576400206925217416E-003; dnu[7][79] = 2.9864597827540829024736E-003; dnu[7][80] = -2.9039308299887836817462E-003; dnu[7][81] = 2.8214090506922220792273E-003; dnu[7][82] = -2.7389333469594754120082E-003; dnu[7][83] = 2.6565433025935282831440E-003; dnu[7][84] = -2.5742792394890888809216E-003; dnu[7][85] = 2.4921822823827693006000E-003; dnu[7][86] = -2.4102944324256341738246E-003; dnu[7][87] = 2.3286586498784273886390E-003; dnu[7][88] = -2.2473189460160339308202E-003; dnu[7][89] = 2.1663204840464914272688E-003; dnu[7][90] = -2.0857096884920394263960E-003; dnu[7][91] = 2.0055343620375116994450E-003; dnu[7][92] = -1.9258438083199354620415E-003; dnu[7][93] = 1.8466889585128254091286E-003; dnu[7][94] = -1.7681224988583888670116E-003; dnu[7][95] = 1.6901989955434601911750E-003; dnu[7][96] = -1.6129750125439342307013E-003; dnu[7][97] = 1.5365092173512891617039E-003; dnu[7][98] = -1.4608624689589098768899E-003; dnu[7][99] = 1.3860978822967254969976E-003; dnu[7][100] = -1.3122808637022147812835E-003; dnu[7][101] = 1.2394791133287839653391E-003; dnu[7][102] = -1.1677625930285804368514E-003; dnu[7][103] = 1.0972034626819194194015E-003; dnu[7][104] = -1.0278759946636732617923E-003; dnu[7][105] = 9.5985648550693620626136E-004; dnu[7][106] = -8.9322319587932491235173E-004; dnu[7][107] = 8.2805636407722630260841E-004; dnu[7][108] = -7.6443835254388278387516E-004; dnu[7][109] = 7.0245399782757232135761E-004; dnu[7][110] = -6.4219123594850509816130E-004; dnu[7][111] = 5.8374205871497970384667E-004; dnu[7][112] = -5.2720381143165805354149E-004; dnu[7][113] = 4.7268075842926269123151E-004; dnu[7][114] = -4.2028571635537372133344E-004; dnu[7][115] = 3.7014140212225166523158E-004; dnu[7][116] = -3.2238102065234630638566E-004; dnu[7][117] = 2.7714765746518735745887E-004; dnu[7][118] = -2.3459246214726554551974E-004; dnu[7][119] = 1.9487264223664114660778E-004; dnu[7][120] = -1.5815182927018453366651E-004; dnu[7][121] = 1.2460620024149864701227E-004; dnu[7][122] = -9.4436690910239873306717E-005; dnu[7][123] = 6.7877455474614359864921E-005; dnu[7][124] = -4.5183414893318604279565E-005; dnu[7][125] = 2.6637646834890306562676E-005; dnu[7][126] = -1.2689112411790928068031E-005; dnu[7][127] = 3.4689682162054133584769E-006; xnu[8][0] = 5.0000000000000000000000E-001; xnu[8][1] = 5.0352356922966837324257E-001; xnu[8][2] = 5.0704694320539123130709E-001; xnu[8][3] = 5.1056992668916554416748E-001; xnu[8][4] = 5.1409232447487284716970E-001; xnu[8][5] = 5.1761394140422051163016E-001; xnu[8][6] = 5.2113458238268180160620E-001; xnu[8][7] = 5.2465405239543431335782E-001; xnu[8][8] = 5.2817215652329639498598E-001; xnu[8][9] = 5.3168869995866114493983E-001; xnu[8][10] = 5.3520348802142758953165E-001; xnu[8][11] = 5.3871632617492864128376E-001; xnu[8][12] = 5.4222702004185544185509E-001; xnu[8][13] = 5.4573537542017769545473E-001; xnu[8][14] = 5.4924119829905960104514E-001; xnu[8][15] = 5.5274429487477099426633E-001; xnu[8][16] = 5.5624447156659331287292E-001; xnu[8][17] = 5.5974153503272000256669E-001; xnu[8][18] = 5.6323529218615098342533E-001; xnu[8][19] = 5.6672555021058080067206E-001; xnu[8][20] = 5.7021211657628008729691E-001; xnu[8][21] = 5.7369479905596997002704E-001; xnu[8][22] = 5.7717340574068905434622E-001; xnu[8][23] = 5.8064774505565262868030E-001; xnu[8][24] = 5.8411762577610373249116E-001; xnu[8][25] = 5.8758285704315573785372E-001; xnu[8][26] = 5.9104324837962609912320E-001; xnu[8][27] = 5.9449860970586093052960E-001; xnu[8][28] = 5.9794875135555007695773E-001; xnu[8][29] = 6.0139348409153234877826E-001; xnu[8][30] = 6.0483261912159059738317E-001; xnu[8][31] = 6.0826596811423631404069E-001; xnu[8][32] = 6.1169334321448344081410E-001; xnu[8][33] = 6.1511455705961108857785E-001; xnu[8][34] = 6.1852942279491486360633E-001; xnu[8][35] = 6.2193775408944651079646E-001; xnu[8][36] = 6.2533936515174158830648E-001; xnu[8][37] = 6.2873407074553489524063E-001; xnu[8][38] = 6.3212168620546338097247E-001; xnu[8][39] = 6.3550202745275627176810E-001; xnu[8][40] = 6.3887491101091215753268E-001; xnu[8][41] = 6.4224015402136278874800E-001; xnu[8][42] = 6.4559757425912334098185E-001; xnu[8][43] = 6.4894699014842891171828E-001; xnu[8][44] = 6.5228822077835702166766E-001; xnu[8][45] = 6.5562108591843590015010E-001; xnu[8][46] = 6.5894540603423834159087E-001; xnu[8][47] = 6.6226100230296092760332E-001; xnu[8][48] = 6.6556769662898841654632E-001; xnu[8][49] = 6.6886531165944310981029E-001; xnu[8][50] = 6.7215367079971901138831E-001; xnu[8][51] = 6.7543259822900060450540E-001; xnu[8][52] = 6.7870191891576607618811E-001; xnu[8][53] = 6.8196145863327482763471E-001; xnu[8][54] = 6.8521104397503911506877E-001; xnu[8][55] = 6.8845050237027967240092E-001; xnu[8][56] = 6.9167966209936517345824E-001; xnu[8][57] = 6.9489835230923539773967E-001; xnu[8][58] = 6.9810640302880796959126E-001; xnu[8][59] = 7.0130364518436854633556E-001; xnu[8][60] = 7.0448991061494433620452E-001; xnu[8][61] = 7.0766503208766083188217E-001; xnu[8][62] = 7.1082884331308165002815E-001; xnu[8][63] = 7.1398117896053137129164E-001; xnu[8][64] = 7.1712187467340127900104E-001; xnu[8][65] = 7.2025076708443789789144E-001; xnu[8][66] = 7.2336769383101423687111E-001; xnu[8][67] = 7.2647249357038364189194E-001; xnu[8][68] = 7.2956500599491616643675E-001; xnu[8][69] = 7.3264507184731736792908E-001; xnu[8][70] = 7.3571253293582943846704E-001; xnu[8][71] = 7.3876723214941457764179E-001; xnu[8][72] = 7.4180901347292051378108E-001; xnu[8][73] = 7.4483772200222807771818E-001; xnu[8][74] = 7.4785320395938073008506E-001; xnu[8][75] = 7.5085530670769593912527E-001; xnu[8][76] = 7.5384387876685830107739E-001; xnu[8][77] = 7.5681876982799428925371E-001; xnu[8][78] = 7.5977983076872851099646E-001; xnu[8][79] = 7.6272691366822134369754E-001; xnu[8][80] = 7.6565987182218781198605E-001; xnu[8][81] = 7.6857855975789755799089E-001; xnu[8][82] = 7.7148283324915574524615E-001; xnu[8][83] = 7.7437254933126472430380E-001; xnu[8][84] = 7.7724756631596627443319E-001; xnu[8][85] = 7.8010774380636422090881E-001; xnu[8][86] = 7.8295294271182721131149E-001; xnu[8][87] = 7.8578302526287141699609E-001; xnu[8][88] = 7.8859785502602290742185E-001; xnu[8][89] = 7.9139729691865942541974E-001; xnu[8][90] = 7.9418121722383127071718E-001; xnu[8][91] = 7.9694948360506097719637E-001; xnu[8][92] = 7.9970196512112144648713E-001; xnu[8][93] = 8.0243853224079217665963E-001; xnu[8][94] = 8.0515905685759320007779E-001; xnu[8][95] = 8.0786341230449631900687E-001; xnu[8][96] = 8.1055147336861320147034E-001; xnu[8][97] = 8.1322311630585987327081E-001; xnu[8][98] = 8.1587821885559711520679E-001; xnu[8][99] = 8.1851666025524624753565E-001; xnu[8][100] = 8.2113832125487975688706E-001; xnu[8][101] = 8.2374308413178619439088E-001; xnu[8][102] = 8.2633083270500874805039E-001; xnu[8][103] = 8.2890145234985686771097E-001; xnu[8][104] = 8.3145483001239029773051E-001; xnu[8][105] = 8.3399085422387485108267E-001; xnu[8][106] = 8.3650941511520923959944E-001; xnu[8][107] = 8.3901040443132225891910E-001; xnu[8][108] = 8.4149371554553961404354E-001; xnu[8][109] = 8.4395924347391966287784E-001; xnu[8][110] = 8.4640688488955735144733E-001; xnu[8][111] = 8.4883653813685561645313E-001; xnu[8][112] = 8.5124810324576353930490E-001; xnu[8][113] = 8.5364148194598055170579E-001; xnu[8][114] = 8.5601657768112601729334E-001; xnu[8][115] = 8.5837329562287354788348E-001; xnu[8][116] = 8.6071154268504945774249E-001; xnu[8][117] = 8.6303122753769481634259E-001; xnu[8][118] = 8.6533226062109063066465E-001; xnu[8][119] = 8.6761455415974577383172E-001; xnu[8][120] = 8.6987802217634737933861E-001; xnu[8][121] = 8.7212258050567354115472E-001; xnu[8][122] = 8.7434814680846830141141E-001; xnu[8][123] = 8.7655464058527907126126E-001; xnu[8][124] = 8.7874198319025681896313E-001; xnu[8][125] = 8.8091009784491957458672E-001; xnu[8][126] = 8.8305890965188004535834E-001; xnu[8][127] = 8.8518834560853841213875E-001; xnu[8][128] = 8.8729833462074168851793E-001; xnu[8][129] = 8.8938880751641137235105E-001; xnu[8][130] = 8.9145969705914150819259E-001; xnu[8][131] = 8.9351093796176971108496E-001; xnu[8][132] = 8.9554246689992418071732E-001; xnu[8][133] = 8.9755422252555026338988E-001; xnu[8][134] = 8.9954614548042070089990E-001; xnu[8][135] = 9.0151817840963434389085E-001; xnu[8][136] = 9.0347026597510880592815E-001; xnu[8][137] = 9.0540235486907329718058E-001; xnu[8][138] = 9.0731439382756870671791E-001; xnu[8][139] = 9.0920633364396290369770E-001; xnu[8][140] = 9.1107812718249020368626E-001; xnu[8][141] = 9.1292972939182500054383E-001; xnu[8][142] = 9.1476109731870070008905E-001; xnu[8][143] = 9.1657219012158631236397E-001; xnu[8][144] = 9.1836296908443436775138E-001; xnu[8][145] = 9.2013339763051522117512E-001; xnu[8][146] = 9.2188344133635430051916E-001; xnu[8][147] = 9.2361306794579044219027E-001; xnu[8][148] = 9.2532224738417513987891E-001; xnu[8][149] = 9.2701095177273431290670E-001; xnu[8][150] = 9.2867915544311607826256E-001; xnu[8][151] = 9.3032683495214998490117E-001; xnu[8][152] = 9.3195396909684523857321E-001; xnu[8][153] = 9.3356053892965760780721E-001; xnu[8][154] = 9.3514652777405695292558E-001; xnu[8][155] = 9.3671192124042965509622E-001; xnu[8][156] = 9.3825670724235263487081E-001; xnu[8][157] = 9.3978087601327813128378E-001; xnu[8][158] = 9.4128442012367095342085E-001; xnu[8][159] = 9.4276733449864250446303E-001; xnu[8][160] = 9.4422961643612849944521E-001; xnu[8][161] = 9.4567126562565993583304E-001; xnu[8][162] = 9.4709228416777951142968E-001; xnu[8][163] = 9.4849267659415829518778E-001; xnu[8][164] = 9.4987244988847001831932E-001; xnu[8][165] = 9.5123161350808283752414E-001; xnu[8][166] = 9.5257017940663079759465E-001; xnu[8][167] = 9.5388816205752945181220E-001; xnu[8][168] = 9.5518557847850214624890E-001; xnu[8][169] = 9.5646244825718529503981E-001; xnu[8][170] = 9.5771879357788252032198E-001; xnu[8][171] = 9.5895463924953875081824E-001; xnu[8][172] = 9.6017001273500621036491E-001; xnu[8][173] = 9.6136494418167462076137E-001; xnu[8][174] = 9.6253946645353782618207E-001; xnu[8][175] = 9.6369361516476834842161E-001; xnu[8][176] = 9.6482742871487002833506E-001; xnu[8][177] = 9.6594094832547681967268E-001; xnu[8][178] = 9.6703421807886289399974E-001; xnu[8][179] = 9.6810728495822540331247E-001; xnu[8][180] = 9.6916019888979644182741E-001; xnu[8][181] = 9.7019301278683486068516E-001; xnu[8][182] = 9.7120578259554152990628E-001; xnu[8][183] = 9.7219856734293332429533E-001; xnu[8][184] = 9.7317142918670145257425E-001; xnu[8][185] = 9.7412443346706867853133E-001; xnu[8][186] = 9.7505764876064743827892E-001; xnu[8][187] = 9.7597114693628679474913E-001; xnu[8][188] = 9.7686500321288056820737E-001; xnu[8][189] = 9.7773929621909184878677E-001; xnu[8][190] = 9.7859410805493048136810E-001; xnu[8][191] = 9.7942952435510011067792E-001; xnu[8][192] = 9.8024563435401014171175E-001; xnu[8][193] = 9.8104253095232573787034E-001; xnu[8][194] = 9.8182031078490606626049E-001; xnu[8][195] = 9.8257907428995783298937E-001; xnu[8][196] = 9.8331892577920828354614E-001; xnu[8][197] = 9.8403997350887997398176E-001; xnu[8][198] = 9.8474232975122961588545E-001; xnu[8][199] = 9.8542611086639622162798E-001; xnu[8][200] = 9.8609143737429089828903E-001; xnu[8][201] = 9.8673843402625346338665E-001; xnu[8][202] = 9.8736722987620133388036E-001; xnu[8][203] = 9.8797795835100587656440E-001; xnu[8][204] = 9.8857075731985285707820E-001; xnu[8][205] = 9.8914576916237926976304E-001; xnu[8][206] = 9.8970314083543134190307E-001; xnu[8][207] = 9.9024302393836066970799E-001; xnu[8][208] = 9.9076557477687005343368E-001; xnu[8][209] = 9.9127095442554030212529E-001; xnu[8][210] = 9.9175932878931636438083E-001; xnu[8][211] = 9.9223086866440726729820E-001; xnu[8][212] = 9.9268574979926018555688E-001; xnu[8][213] = 9.9312415295650377634075E-001; xnu[8][214] = 9.9354626397701703359495E-001; xnu[8][215] = 9.9395227384756214023332E-001; xnu[8][216] = 9.9434237877371473996926E-001; xnu[8][217] = 9.9471678026012041935822E-001; xnu[8][218] = 9.9507568520038507959027E-001; xnu[8][219] = 9.9541930597914712183853E-001; xnu[8][220] = 9.9574786058905306619925E-001; xnu[8][221] = 9.9606157276543155884129E-001; xnu[8][222] = 9.9636067214139430766410E-001; xnu[8][223] = 9.9664539442584248310532E-001; xnu[8][224] = 9.9691598160637751110426E-001; xnu[8][225] = 9.9717268217836170296553E-001; xnu[8][226] = 9.9741575140031050025957E-001; xnu[8][227] = 9.9764545157440515113072E-001; xnu[8][228] = 9.9786205234920359425472E-001; xnu[8][229] = 9.9806583103965751889305E-001; xnu[8][230] = 9.9825707295744513692434E-001; xnu[8][231] = 9.9843607174263008064974E-001; xnu[8][232] = 9.9860312968611097953823E-001; xnu[8][233] = 9.9875855803173619998262E-001; xnu[8][234] = 9.9890267724797863728092E-001; xnu[8][235] = 9.9903581726246516165093E-001; xnu[8][236] = 9.9915831765920369626532E-001; xnu[8][237] = 9.9927052784858395301327E-001; xnu[8][238] = 9.9937280723404755735176E-001; xnu[8][239] = 9.9946552541540528111790E-001; xnu[8][240] = 9.9954906248383379883111E-001; xnu[8][241] = 9.9962380947167123679948E-001; xnu[8][242] = 9.9969016901251179096404E-001; xnu[8][243] = 9.9974855623359359526763E-001; xnu[8][244] = 9.9979939983595534162598E-001; xnu[8][245] = 9.9984314322415886588808E-001; xnu[8][246] = 9.9988024546221602366522E-001; xnu[8][247] = 9.9991118183989386959794E-001; xnu[8][248] = 9.9993644406017880596898E-001; xnu[8][249] = 9.9995654057233914140003E-001; xnu[8][250] = 9.9997199810352718788193E-001; xnu[8][251] = 9.9998336504924313844142E-001; xnu[8][252] = 9.9999121517744579929001E-001; xnu[8][253] = 9.9999614906812879401388E-001; xnu[8][254] = 9.9999879818987423231012E-001; xnu[8][255] = 9.9999983647836719219063E-001; dnu[8][0] = -3.5236017725240448367289E-003; dnu[8][1] = 3.5235041442227400686498E-003; dnu[8][2] = -3.5232112672901020887398E-003; dnu[8][3] = 3.5227231656397573838983E-003; dnu[8][4] = -3.5220398791270752663317E-003; dnu[8][5] = 3.5211614635481560479832E-003; dnu[8][6] = -3.5200879906384153312115E-003; dnu[8][7] = 3.5188195480707652615937E-003; dnu[8][8] = -3.5173562394533938295372E-003; dnu[8][9] = 3.5156981843271435475412E-003; dnu[8][10] = -3.5138455181624910692920E-003; dnu[8][11] = 3.5117983923561295551537E-003; dnu[8][12] = -3.5095569742271558258560E-003; dnu[8][13] = 3.5071214470128645821259E-003; dnu[8][14] = -3.5044920098641522024681E-003; dnu[8][15] = 3.5016688778405328640984E-003; dnu[8][16] = -3.4986522819047699629721E-003; dnu[8][17] = 3.4954424689171260377234E-003; dnu[8][18] = -3.4920397016292346289319E-003; dnu[8][19] = 3.4884442586775977292236E-003; dnu[8][20] = -3.4846564345767127010655E-003; dnu[8][21] = 3.4806765397118327574657E-003; dnu[8][22] = -3.4765049003313653158828E-003; dnu[8][23] = 3.4721418585389127471901E-003; dnu[8][24] = -3.4675877722849602492399E-003; dnu[8][25] = 3.4628430153582157781065E-003; dnu[8][26] = -3.4579079773766071691240E-003; dnu[8][27] = 3.4527830637779417740149E-003; dnu[8][28] = -3.4474686958102341293586E-003; dnu[8][29] = 3.4419653105217073549737E-003; dnu[8][30] = -3.4362733607504741580630E-003; dnu[8][31] = 3.4303933151139034897570E-003; dnu[8][32] = -3.4243256579976790645136E-003; dnu[8][33] = 3.4180708895445561092032E-003; dnu[8][34] = -3.4116295256428228571000E-003; dnu[8][35] = 3.4050020979144734418687E-003; dnu[8][36] = -3.3981891537030989774011E-003; dnu[8][37] = 3.3911912560615037304123E-003; dnu[8][38] = -3.3840089837390534034163E-003; dnu[8][39] = 3.3766429311687626453919E-003; dnu[8][40] = -3.3690937084541289954298E-003; dnu[8][41] = 3.3613619413557205401809E-003; dnu[8][42] = -3.3534482712775246282416E-003; dnu[8][43] = 3.3453533552530650329179E-003; dnu[8][44] = -3.3370778659312949882693E-003; dnu[8][45] = 3.3286224915622735410861E-003; dnu[8][46] = -3.3199879359826326625944E-003; dnu[8][47] = 3.3111749186008425472876E-003; dnu[8][48] = -3.3021841743822824913798E-003; dnu[8][49] = 3.2930164538341246889724E-003; dnu[8][50] = -3.2836725229900382090953E-003; dnu[8][51] = 3.2741531633947203202702E-003; dnu[8][52] = -3.2644591720882622100624E-003; dnu[8][53] = 3.2545913615903560041347E-003; dnu[8][54] = -3.2445505598843498214605E-003; dnu[8][55] = 3.2343376104011574084413E-003; dnu[8][56] = -3.2239533720030286735506E-003; dnu[8][57] = 3.2133987189671871946092E-003; dnu[8][58] = -3.2026745409693404917104E-003; dnu[8][59] = 3.1917817430670685489766E-003; dnu[8][60] = -3.1807212456830957265718E-003; dnu[8][61] = 3.1694939845884508295582E-003; dnu[8][62] = -3.1581009108855196911351E-003; dnu[8][63] = 3.1465429909909941834386E-003; dnu[8][64] = -3.1348212066187210883550E-003; dnu[8][65] = 3.1229365547624537427064E-003; dnu[8][66] = -3.1108900476785088157874E-003; dnu[8][67] = 3.0986827128683299817099E-003; dnu[8][68] = -3.0863155930609596136326E-003; dnu[8][69] = 3.0737897461954189510710E-003; dnu[8][70] = -3.0611062454029964746573E-003; dnu[8][71] = 3.0482661789894434646161E-003; dnu[8][72] = -3.0352706504170749197467E-003; dnu[8][73] = 3.0221207782867731729442E-003; dnu[8][74] = -3.0088176963198906576125E-003; dnu[8][75] = 2.9953625533400473573579E-003; dnu[8][76] = -2.9817565132548175100558E-003; dnu[8][77] = 2.9680007550372991380706E-003; dnu[8][78] = -2.9540964727075589408062E-003; dnu[8][79] = 2.9400448753139440160228E-003; dnu[8][80] = -2.9258471869142507751655E-003; dnu[8][81] = 2.9115046465567402885106E-003; dnu[8][82] = -2.8970185082609881421060E-003; dnu[8][83] = 2.8823900409985557147716E-003; dnu[8][84] = -2.8676205286734685951001E-003; dnu[8][85] = 2.8527112701024866615598E-003; dnu[8][86] = -2.8376635789951491504336E-003; dnu[8][87] = 2.8224787839335768444255E-003; dnu[8][88] = -2.8071582283520123383909E-003; dnu[8][89] = 2.7917032705160781880498E-003; dnu[8][90] = -2.7761152835017316342499E-003; dnu[8][91] = 2.7603956551738935322869E-003; dnu[8][92] = -2.7445457881647281174076E-003; dnu[8][93] = 2.7285670998515493199771E-003; dnu[8][94] = -2.7124610223343285247561E-003; dnu[8][95] = 2.6962290024127779680319E-003; dnu[8][96] = -2.6798725015629834058070E-003; dnu[8][97] = 2.6633929959135592898706E-003; dnu[8][98] = -2.6467919762212994827357E-003; dnu[8][99] = 2.6300709478462965560248E-003; dnu[8][100] = -2.6132314307265029815277E-003; dnu[8][101] = 2.5962749593517080743133E-003; dnu[8][102] = -2.5792030827369054204802E-003; dnu[8][103] = 2.5620173643950267591546E-003; dnu[8][104] = -2.5447193823090199333684E-003; dnu[8][105] = 2.5273107289032506252914E-003; dnu[8][106] = -2.5097930110142101995453E-003; dnu[8][107] = 2.4921678498605151495699E-003; dnu[8][108] = -2.4744368810121874360035E-003; dnu[8][109] = 2.4566017543592094868339E-003; dnu[8][110] = -2.4386641340793528652707E-003; dnu[8][111] = 2.4206256986052856760690E-003; dnu[8][112] = -2.4024881405909707524150E-003; dnu[8][113] = 2.3842531668773746263160E-003; dnu[8][114] = -2.3659224984575163235681E-003; dnu[8][115] = 2.3474978704408952326600E-003; dnu[8][116] = -2.3289810320173487732893E-003; dnu[8][117] = 2.3103737464204034374082E-003; dnu[8][118] = -2.2916777908901971016763E-003; dnu[8][119] = 2.2728949566360664274378E-003; dnu[8][120] = -2.2540270487989107900066E-003; dnu[8][121] = 2.2350758864134636345022E-003; dnu[8][122] = -2.2160433023706235660286E-003; dnu[8][123] = 2.1969311433800209763024E-003; dnu[8][124] = -2.1777412699330217183940E-003; dnu[8][125] = 2.1584755562663973996390E-003; dnu[8][126] = -2.1391358903269224047932E-003; dnu[8][127] = 2.1197241737371909221716E-003; dnu[8][128] = -2.1002423217629831588587E-003; dnu[8][129] = 2.0806922632825487288194E-003; dnu[8][130] = -2.0610759407582170076376E-003; dnu[8][131] = 2.0413953102107891917508E-003; dnu[8][132] = -2.0216523411972149927435E-003; dnu[8][133] = 2.0018490167921084428078E-003; dnu[8][134] = -1.9819873335737122775631E-003; dnu[8][135] = 1.9620693016149788733009E-003; dnu[8][136] = -1.9420969444804978049911E-003; dnu[8][137] = 1.9220722992300657945837E-003; dnu[8][138] = -1.9019974164297641458043E-003; dnu[8][139] = 1.8818743601714816912025E-003; dnu[8][140] = -1.8617052081018977543513E-003; dnu[8][141] = 1.8414920514620195598335E-003; dnu[8][142] = -1.8212369951384517659700E-003; dnu[8][143] = 1.8009421577276621593433E-003; dnu[8][144] = -1.7806096716145967882927E-003; dnu[8][145] = 1.7602416830670896134102E-003; dnu[8][146] = -1.7398403523476057348613E-003; dnu[8][147] = 1.7194078538439529593811E-003; dnu[8][148] = -1.6989463762206933486966E-003; dnu[8][149] = 1.6784581225930838067080E-003; dnu[8][150] = -1.6579453107254719735305E-003; dnu[8][151] = 1.6374101732561698478224E-003; dnu[8][152] = -1.6168549579509216818417E-003; dnu[8][153] = 1.5962819279871736839512E-003; dnu[8][154] = -1.5756933622714396792910E-003; dnu[8][155] = 1.5550915557921377307891E-003; dnu[8][156] = -1.5344788200103462608708E-003; dnu[8][157] = 1.5138574832909927223987E-003; dnu[8][158] = -1.4932298913770414512368E-003; dnu[8][159] = 1.4725984079092879114196E-003; dnu[8][160] = -1.4519654149943918408731E-003; dnu[8][161] = 1.4313333138237893412643E-003; dnu[8][162] = -1.4107045253461110396137E-003; dnu[8][163] = 1.3900814909956971752233E-003; dnu[8][164] = -1.3694666734797377060041E-003; dnu[8][165] = 1.3488625576264729333326E-003; dnu[8][166] = -1.3282716512967641415720E-003; dnu[8][167] = 1.3076964863611805461264E-003; dnu[8][168] = -1.2871396197445444404608E-003; dnu[8][169] = 1.2666036345396266287484E-003; dnu[8][170] = -1.2460911411913846503000E-003; dnu[8][171] = 1.2256047787527824196154E-003; dnu[8][172] = -1.2051472162128170869123E-003; dnu[8][173] = 1.1847211538969024757289E-003; dnu[8][174] = -1.1643293249392136943195E-003; dnu[8][175] = 1.1439744968259798618913E-003; dnu[8][176] = -1.1236594730080169654101E-003; dnu[8][177] = 1.1033870945800166459678E-003; dnu[8][178] = -1.0831602420232457136344E-003; dnu[8][179] = 1.0629818370073626652228E-003; dnu[8][180] = -1.0428548442460197131980E-003; dnu[8][181] = 1.0227822733997914672317E-003; dnu[8][182] = -1.0027671810187558497225E-003; dnu[8][183] = 9.8281267251575273865993E-004; dnu[8][184] = -9.6292190415996773102075E-004; dnu[8][185] = 9.4309808507904237696790E-004; dnu[8][186] = -9.2334447925641270456432E-004; dnu[8][187] = 9.0366440750904465039505E-004; dnu[8][188] = -8.8406124942919443350579E-004; dnu[8][189] = 8.6453844527230803583806E-004; dnu[8][190] = -8.4509949777173009558748E-004; dnu[8][191] = 8.2574797385957285327574E-004; dnu[8][192] = -8.0648750627196711535064E-004; dnu[8][193] = 7.8732179501606083094277E-004; dnu[8][194] = -7.6825460867564458085196E-004; dnu[8][195] = 7.4928978553228318107157E-004; dnu[8][196] = -7.3043123447945493844494E-004; dnu[8][197] = 7.1168293570860259950151E-004; dnu[8][198] = -6.9304894114836274849880E-004; dnu[8][199] = 6.7453337464176556563600E-004; dnu[8][200] = -6.5614043185110739064173E-004; dnu[8][201] = 6.3787437988673473672259E-004; dnu[8][202] = -6.1973955666439198266955E-004; dnu[8][203] = 6.0174037000632982440356E-004; dnu[8][204] = -5.8388129651429021842567E-004; dnu[8][205] = 5.6616688025798832458331E-004; dnu[8][206] = -5.4860173134095970970073E-004; dnu[8][207] = 5.3119052442670035687534E-004; dnu[8][208] = -5.1393799733183663089639E-004; dnu[8][209] = 4.9684894981938042897235E-004; dnu[8][210] = -4.7992824275346810313068E-004; dnu[8][211] = 4.6318079780655564168411E-004; dnu[8][212] = -4.4661159793966245617026E-004; dnu[8][213] = 4.3022568890426392406400E-004; dnu[8][214] = -4.1402818203861315130421E-004; dnu[8][215] = 3.9802425864877543575304E-004; dnu[8][216] = -3.8221917627194139209526E-004; dnu[8][217] = 3.6661827711238395602767E-004; dnu[8][218] = -3.5122699891378616067880E-004; dnu[8][219] = 3.3605088848005409732297E-004; dnu[8][220] = -3.2109561797425254420128E-004; dnu[8][221] = 3.0636700400611260464706E-004; dnu[8][222] = -2.9187102935748985192333E-004; dnu[8][223] = 2.7761386698865378985736E-004; dnu[8][224] = -2.6360190571582919306239E-004; dnu[8][225] = 2.4984177665640024225928E-004; dnu[8][226] = -2.3634037921463134561575E-004; dnu[8][227] = 2.2310490505070162374404E-004; dnu[8][228] = -2.1014285817768061591171E-004; dnu[8][229] = 1.9746206912343685221695E-004; dnu[8][230] = -1.8507070106112583261579E-004; dnu[8][231] = 1.7297724606495193567507E-004; dnu[8][232] = -1.6119051032643119483180E-004; dnu[8][233] = 1.4971958842545586543710E-004; dnu[8][234] = -1.3857382873259367872945E-004; dnu[8][235] = 1.2776279479761843100676E-004; dnu[8][236] = -1.1729623106196260243797E-004; dnu[8][237] = 1.0718404501710846857448E-004; dnu[8][238] = -9.7436321118320573341744E-005; dnu[8][239] = 8.8063382772541597737195E-005; dnu[8][240] = -7.9075915205566116981157E-005; dnu[8][241] = 7.0485151102052395706581E-005; dnu[8][242] = -6.2303100120749462771247E-005; dnu[8][243] = 5.4542772822870761025480E-005; dnu[8][244] = -4.7218316126617180477170E-005; dnu[8][245] = 4.0344961400701764692553E-005; dnu[8][246] = -3.3938727737915739053586E-005; dnu[8][247] = 2.8015975392808212607024E-005; dnu[8][248] = -2.2593183623060767475330E-005; dnu[8][249] = 1.7687568602759479431384E-005; dnu[8][250] = -1.3318826217940261494781E-005; dnu[8][251] = 9.5106840952937908339661E-006; dnu[8][252] = -6.2892960976606935680311E-006; dnu[8][253] = 3.6831203455116083442839E-006; dnu[8][254] = -1.7416856803596676839876E-006; dnu[8][255] = 4.7285796697500352441360E-007; } gss/src/drkl.f0000644000176200001440000001647513267111001012745 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine drkl (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, p *rec, maxiter, jpvt, wk, info) integer nxis, nqd, nt, maxiter, jpvt(*), info double precision cd(*), qdrs(nqd,*), bwt(*), qdwt(nt,*), wt0(*), m *chpr, prec, wk(*) integer imrs, iwt, iwtsum, imu, imuwk, iv, ivwk, icdnew, iwtnew, i *wtnewsum imrs = 1 iwt = imrs + nxis iwtsum = iwt + nt*nqd imu = iwtsum + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nt*nqd call drkl1 (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, prec, *maxiter, wk(imrs), wk(iwt), wk(iwtsum), wk(imu), wk(imuwk), wk(iv) *, wk(ivwk), jpvt, wk(icdnew), wk(iwtnew), wk(iwtnewsum), info) return end subroutine drkl1 (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, *prec, maxiter, mrs, wt, wtsum, mu, muwk, v, vwk, jpvt, cdnew, wtne *w, wtnewsum, info) integer nxis, nqd, nt, maxiter, jpvt(*), info double precision cd(*), qdrs(nqd,*), bwt(*), qdwt(nt,*), wt0(*), m *chpr, mrs(*), wt(nt,*), wtsum(*), mu(*), muwk(*), v(nxis,*), vwk(n *xis,*), cdnew(*), wtnew(nt,*), wtnewsum(*), prec integer i, j, k, m, iter, flag, idamax, infowk double precision tmp, ddot, rkl, rklnew, mumax, disc, disc0 info = 0 call dset (nxis, 0.d0, mrs, 1) m=1 23000 if(.not.(m.le.nt))goto 23002 i=1 23003 if(.not.(i.le.nqd))goto 23005 wt(m,i) = qdwt(m,i) * wt0(i) 23004 i=i+1 goto 23003 23005 continue i=1 23006 if(.not.(i.le.nxis))goto 23008 muwk(i) = ddot (nqd, qdrs(1,i), 1, wt(m,1), nt) 23007 i=i+1 goto 23006 23008 continue call daxpy (nxis, bwt(m), muwk, 1, mrs, 1) wtsum(m) = 0.d0 23001 m=m+1 goto 23000 23002 continue i=1 23009 if(.not.(i.le.nqd))goto 23011 tmp = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) m=1 23012 if(.not.(m.le.nt))goto 23014 wt(m,i) = qdwt(m,i) * tmp wtsum(m) = wtsum(m) + wt(m,i) 23013 m=m+1 goto 23012 23014 continue 23010 i=i+1 goto 23009 23011 continue rkl = 0.d0 m=1 23015 if(.not.(m.le.nt))goto 23017 tmp = 0.d0 i=1 23018 if(.not.(i.le.nqd))goto 23020 disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wt(m,i)) * disc 23019 i=i+1 goto 23018 23020 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23016 m=m+1 goto 23015 23017 continue iter = 0 flag = 0 23021 continue iter = iter + 1 call dset(nxis, 0.d0, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) m=1 23024 if(.not.(m.le.nt))goto 23026 i=1 23027 if(.not.(i.le.nxis))goto 23029 muwk(i) = - ddot (nqd, wt(m,1), nt, qdrs(1,i), 1) / wtsum(m) 23028 i=i+1 goto 23027 23029 continue i=1 23030 if(.not.(i.le.nxis))goto 23032 j=i 23033 if(.not.(j.le.nxis))goto 23035 vwk(i,j) = 0.d0 k=1 23036 if(.not.(k.le.nqd))goto 23038 vwk(i,j) = vwk(i,j) + wt(m,k) * qdrs(k,i) * qdrs(k,j) 23037 k=k+1 goto 23036 23038 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23034 j=j+1 goto 23033 23035 continue 23031 i=i+1 goto 23030 23032 continue call daxpy (nxis, bwt(m), muwk, 1, mu, 1) call daxpy (nxis*nxis, bwt(m), vwk, 1, v, 1) 23025 m=m+1 goto 23024 23026 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23039 if(.not.(i.le.nxis))goto 23041 jpvt(i) = 0 23040 i=i+1 goto 23039 23041 continue call dmcdc (v, nxis, nxis, muwk, jpvt, infowk) 23042 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) call dset (nt, 0.d0, wtnewsum, 1) i=1 23045 if(.not.(i.le.nqd))goto 23047 tmp = ddot (nxis, qdrs(i,1), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23047 endif m=1 23050 if(.not.(m.le.nt))goto 23052 wtnew(m,i) = qdwt(m,i) * dexp (tmp) wtnewsum(m) = wtnewsum(m) + wtnew(m,i) 23051 m=m+1 goto 23050 23052 continue 23046 i=i+1 goto 23045 23047 continue rklnew = 0.d0 m=1 23053 if(.not.(m.le.nt))goto 23055 tmp = 0.d0 i=1 23056 if(.not.(i.le.nqd))goto 23058 disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wtnew(m,i)) * disc 23057 i=i+1 goto 23056 23058 continue rklnew = rklnew + bwt(m) * (tmp + dlog (wtnewsum(m))) 23054 m=m+1 goto 23053 23055 continue if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) m=1 23061 if(.not.(m.le.nt))goto 23063 i=1 23064 if(.not.(i.le.nqd))goto 23066 wtsum(m) = wtsum(m) + wt(m,i) 23065 i=i+1 goto 23064 23066 continue 23062 m=m+1 goto 23061 23063 continue rkl = 0.d0 m=1 23067 if(.not.(m.le.nt))goto 23069 tmp = 0.d0 i=1 23070 if(.not.(i.le.nqd))goto 23072 tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) 23071 i=i+1 goto 23070 23072 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23068 m=m+1 goto 23067 23069 continue iter = 0 goto 23044 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23044 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23044 endif 23043 goto 23042 23044 continue if(flag.eq.1)then flag = 2 goto 23022 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23081 if(.not.(i.le.nqd))goto 23083 m=1 23084 if(.not.(m.le.nt))goto 23086 disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) 23085 m=m+1 goto 23084 23086 continue 23082 i=i+1 goto 23081 23083 continue disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc = dmax1 (disc, dabs(rkl-rklnew)/(1.d0+dabs(rkl))) if(disc.lt.prec)then goto 23023 endif call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt*nqd, wtnew, 1, wt, 1) call dcopy (nt, wtnewsum, 1, wtsum, 1) rkl = rklnew if(iter.lt.maxiter)then goto 23022 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) m=1 23093 if(.not.(m.le.nt))goto 23095 i=1 23096 if(.not.(i.le.nqd))goto 23098 wtsum(m) = wtsum(m) + wt(m,i) 23097 i=i+1 goto 23096 23098 continue 23094 m=m+1 goto 23093 23095 continue rkl = 0.d0 m=1 23099 if(.not.(m.le.nt))goto 23101 tmp = 0.d0 i=1 23102 if(.not.(i.le.nqd))goto 23104 tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) 23103 i=i+1 goto 23102 23104 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23100 m=m+1 goto 23099 23101 continue iter = 0 flag = 2 else info = 2 goto 23023 endif 23022 goto 23021 23023 continue i=1 23105 if(.not.(i.le.nqd))goto 23107 wt0(i) = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) 23106 i=i+1 goto 23105 23107 continue return end gss/src/cdennewton10.f0000644000176200001440000001602613267111001014306 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine cdennewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, *intrs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call cdennewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs *, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew) *, wk(iwtnew), wk(iwk), info) return end subroutine cdennewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, * intrs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, i *nfo) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, wtsum, lkhd, mumax, wtsumnew, l *khdnew, disc, disc0 info = 0 i=1 23000 if(.not.(i.le.nobs))goto 23002 tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23001 i=i+1 goto 23000 23002 continue wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 0 23005 continue iter = iter + 1 i=1 23008 if(.not.(i.le.nxis))goto 23010 mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) 23009 i=i+1 goto 23008 23010 continue i=1 23011 if(.not.(i.le.nxis))goto 23013 j=i 23014 if(.not.(j.le.nxis))goto 23016 v(i,j) = 0.d0 k=1 23017 if(.not.(k.le.nobs))goto 23019 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23018 k=k+1 goto 23017 23019 continue v(i,j) = v(i,j) - mu(i) * mu(j) if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23015 j=j+1 goto 23014 23016 continue 23012 i=i+1 goto 23011 23013 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23022 if(.not.(i.le.nxis))goto 23024 jpvt(i) = 0 23023 i=i+1 goto 23022 23024 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23025 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23025 endif 23026 continue i=rkv+1 23027 if(.not.(i.le.nxis))goto 23029 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23028 i=i+1 goto 23027 23029 continue 23030 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) i=1 23033 if(.not.(i.le.nobs))goto 23035 tmp = ddot (nxis, rs(i,1), nobs, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23035 endif wtnew(i) = dexp (-tmp) if(cntsum.ne.0)then wtnew(i) = wtnew(i) * dfloat (cnt(i)) endif 23034 i=i+1 goto 23033 23035 continue wtsumnew = dasum (nobs, wtnew, 1) lkhdnew = dlog (wtsumnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsumnew, wtnew, 1) if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) if(cntsum.ne.0)then i=1 23044 if(.not.(i.le.nobs))goto 23046 wt(i) = dfloat (cnt(i)) 23045 i=i+1 goto 23044 23046 continue else call dset (nobs, 1.d0, wt, 1) endif wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 goto 23032 endif if(flag.eq.3)then goto 23032 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23032 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23032 endif 23031 goto 23030 23032 continue if(flag.eq.1)then flag = 2 goto 23006 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23057 if(.not.(i.le.nobs))goto 23059 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23058 i=i+1 goto 23057 23059 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23007 endif if(disc.lt.prec)then goto 23007 endif if(iter.lt.maxiter)then goto 23006 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) if(cntsum.ne.0)then i=1 23070 if(.not.(i.le.nobs))goto 23072 wt(i) = dfloat (cnt(i)) 23071 i=i+1 goto 23070 23072 continue else call dset (nobs, 1.d0, wt, 1) endif wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 2 else info = 2 goto 23007 endif 23006 goto 23005 23007 continue i=1 23073 if(.not.(i.le.nxis))goto 23075 j=i 23076 if(.not.(j.le.nxis))goto 23078 v(i,j) = 0.d0 k=1 23079 if(.not.(k.le.nobs))goto 23081 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23080 k=k+1 goto 23079 23081 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23077 j=j+1 goto 23076 23078 continue 23074 i=i+1 goto 23073 23075 continue i=1 23084 if(.not.(i.le.nxis))goto 23086 jpvt(i) = 0 23085 i=i+1 goto 23084 23086 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23087 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23087 endif 23088 continue i=rkv+1 23089 if(.not.(i.le.nxis))goto 23091 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23090 i=i+1 goto 23089 23091 continue i=1 23092 if(.not.(i.le.nobs))goto 23094 call dcopy (nxis, rs(i,1), nobs, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.ne.0)then wtnew(i) = wtnew(i) / dfloat (cnt(i)) endif 23093 i=i+1 goto 23092 23094 continue call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/dtrev.f0000644000176200001440000000364313267111001013126 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dtrev (vmu, t, ldt, n, z, score, varht, info, work) character vmu integer n, info double precision t(ldt,*), z(*), score, varht, work(*) double precision nume, deno, tmp, alph, la, dasum, ddot integer j info = 0 if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif la = t(1,1) alph = dfloat (n) / dasum (n, t(2,1), ldt) call dscal (n, alph, t(2,1), ldt) call dscal (n-1, alph, t(1,2), ldt) call dpbfa (t, ldt, n, 1, info) if( info .ne. 0 )then return endif call dcopy (n, z, 1, work, 1) call dpbsl (t, ldt, n, 1, work) if( vmu .eq. 'v' )then tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp j=n-1 23006 if(.not.(j.gt.0))goto 23008 tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp 23007 j=j-1 goto 23006 23008 continue nume = ddot (n, work, 1, work, 1) / dfloat (n) deno = deno / dfloat (n) varht = alph * la * nume / deno score = nume / deno / deno endif if( vmu .eq. 'm' )then deno = dlog (t(2,n)) j=n-1 23011 if(.not.(j.gt.0))goto 23013 deno = deno + dlog (t(2,j)) 23012 j=j-1 goto 23011 23013 continue nume = ddot (n, z, 1, work, 1) / dfloat (n) varht = alph * la * nume score = nume * dexp (2.d0 * deno / dfloat (n)) endif if( vmu .eq. 'u' )then nume = ddot (n, work, 1, work, 1) / dfloat (n) tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp j=n-1 23016 if(.not.(j.gt.0))goto 23018 tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp 23017 j=j-1 goto 23016 23018 continue deno = deno / dfloat (n) score = alph * alph * la * la * nume - 2.d0 * varht * alph * la * *deno endif return end gss/src/dprmut.f0000644000176200001440000000361213267111001013311 0ustar liggesusers subroutine dprmut (x,npar,jpvt,job) integer npar,jpvt(npar),job double precision x(npar) c c Purpose: permute the elements of the array x according to the index c vector jpvt (either forward or backward permutation). c c On Entry: c x(npar) array to be permuted c npar size of x (and jpvt) c jpvt indices of the permutation c job indicator of forward or backward permutation c if job = 0 forward permutation c x(jpvt(i)) moved to x(i) c if job is nonzero backward permutation c x(i) moved to x(jpvt(i)) c On Exit: c x(npar) array with permuted entries c c Written: Yin Ling U. of Maryland, August,1978 c c $Header: dprmut.f,v 2.1 86/04/08 14:05:53 lindstrom Exp $ c integer i,j,k double precision t c if (npar .le. 1) then return endif do 10 j = 1,npar jpvt(j) = -jpvt(j) 10 continue if (job .eq. 0) then c forward permutation do 30 i = 1,npar if (jpvt(i) .gt. 0) then goto 30 endif j = i jpvt(j) = -jpvt(j) k = jpvt(j) c while 20 if (jpvt(k) .lt. 0) then t = x(j) x(j) = x(k) x(k) = t jpvt(k) = -jpvt(k) j = k k = jpvt(k) goto 20 c endwhile endif 30 continue endif if (job .ne. 0 ) then c backward permutation do 50 i = 1,npar if (jpvt(i) .gt. 0) then goto 50 endif jpvt(i) = -jpvt(i) j = jpvt(i) c while 40 if (j .ne. i) then t = x(i) x(i) = x(j) x(j) = t jpvt(j) = -jpvt(j) j = jpvt(j) goto 40 c endwhile endif 50 continue endif return end gss/src/dset.f0000644000176200001440000000176413267111001012743 0ustar liggesusers subroutine dset(n,da,dx,incx) integer n,incx double precision da,dx(*) c c Purpose : set vector dx to constant da. Unrolled loops are used for c increment equal to one. c c On Entry: c n length of dx c da any constant c incx increment for dx c c On Exit: c dx(n) vector with all n entries set to da c c $Header: dset.f,v 2.1 86/04/08 14:06:25 lindstrom Exp $ c integer i,m,mp1,nincx c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da dx(i + 1) = da dx(i + 2) = da dx(i + 3) = da dx(i + 4) = da 50 continue return end gss/src/dsms.f0000644000176200001440000000504213267111001012743 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dsms (s, lds, nobs, nnull, jpvt, q, ldq, nlaht, sms, ld *sms, wk, info) integer lds, nobs, nnull, jpvt(*), ldq, ldsms, info double precision s(lds,*), q(ldq,*), nlaht, sms(ldsms,*), wk(2,*) double precision dum, ddot integer i, j, n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq .or. ldsms .lt. nnull )then info = -1 return endif n0 = nnull n = nobs - nnull call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23002 if(.not.(j.le.n0))goto 23004 call dcopy (n, q(n0+1,j), 1, q(j,n0+1), ldq) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), dum, q(n0+ *2,j), dum, dum, dum, 01000, info) 23003 j=j+1 goto 23002 23004 continue call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif j=1 23007 if(.not.(j.le.n0))goto 23009 call dpbsl (wk, 2, n, 1, q(n0+1,j)) 23008 j=j+1 goto 23007 23009 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23010 if(.not.(j.le.n0))goto 23012 call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), q(n0+2,j), * dum, dum, dum, dum, 10000, info) 23011 j=j+1 goto 23010 23012 continue i=1 23013 if(.not.(i.le.n0))goto 23015 j=1 23016 if(.not.(j.lt.i))goto 23018 sms(i,j) = sms(j,i) 23017 j=j+1 goto 23016 23018 continue j=i 23019 if(.not.(j.le.n0))goto 23021 sms(i,j) = q(j,i) - ddot (n, q(n0+1,j), 1, q(i,n0+1), ldq) 23020 j=j+1 goto 23019 23021 continue sms(i,i) = sms(i,i) + 10.d0**nlaht 23014 i=i+1 goto 23013 23015 continue j=1 23022 if(.not.(j.le.n0))goto 23024 call dtrsl (s, lds, n0, sms(1,j), 01, info) 23023 j=j+1 goto 23022 23024 continue i=1 23025 if(.not.(i.le.n0))goto 23027 call dcopy (n0, sms(i,1), ldsms, wk, 1) call dtrsl (s, lds, n0, wk, 01, info) call dprmut (wk, n0, jpvt, 1) call dcopy (n0, wk, 1, sms(i,1), ldsms) 23026 i=i+1 goto 23025 23027 continue j=1 23028 if(.not.(j.le.n0))goto 23030 call dprmut (sms(1,j), n0, jpvt, 1) 23029 j=j+1 goto 23028 23030 continue j=1 23031 if(.not.(j.le.n0))goto 23033 call dcopy (n, q(j,n0+1), ldq, q(n0+1,j), 1) 23032 j=j+1 goto 23031 23033 continue return end gss/src/dmudr1.f0000644000176200001440000001613513267111001013176 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dmudr1 (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, * tol, init, prec, maxite, theta, nlaht, score, varht, c, d, qraux, * jpvt, twk, traux, qwk, ywk, thewk, hes, gra, hwk1, hwk2, gwk1, gw *k2, pvtwk, kwk, work1, work2, info) integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite, jpvt(*), p *vtwk(*), info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec, theta( **), nlaht, score, varht, c(*), d(*), qraux(*), traux(*), twk(2,*), * qwk(ldqr,*), ywk(*), thewk(*), hes(nq,*), gra(*), hwk1(nq,*), hwk *2(nq,*), gwk1(*), gwk2(*), kwk(nobs-nnull,nobs-nnull,*), work1(*), * work2(*) character vmu double precision alph, scrold, scrwk, nlawk, limnla(2), tmp, dasum *, ddot integer n, n0, i, j, iwk, maxitwk, idamax, job info = 0 n0 = nnull n = nobs - nnull maxitwk = maxite if( (vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u') .or. (ini *t .ne. 0 .and. init .ne. 1) .or. (maxitwk .le.0) .or. (prec .le. 0 *.d0) )then info = -3 return endif if( lds .lt. nobs .or. nobs .le. n0 .or. n0 .lt. 1 .or. ldqr .lt. *nobs .or. ldqc .lt. nobs .or. nq .le. 0 )then info = -1 return endif call dstup (s, lds, nobs, n0, qraux, jpvt, y, q, ldqr, ldqc, nq, i *nfo, work1) if( info .ne. 0 )then return endif if( init .eq. 1 )then call dcopy (nq, theta, 1, thewk, 1) else i=1 23008 if(.not.(i.le.nq))goto 23010 thewk(i) = dasum (n, q(n0+1,n0+1,i), ldqr+1) if( thewk(i) .gt. 0.d0 )then thewk(i) = 1.d0 / thewk(i) endif 23009 i=i+1 goto 23008 23010 continue j=1 23013 if(.not.(j.le.nobs))goto 23015 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23014 j=j+1 goto 23013 23015 continue i=1 23016 if(.not.(i.le.nq))goto 23018 j=1 23019 if(.not.(j.le.nobs))goto 23021 call daxpy (nobs-j+1, thewk(i), q(j,j,i), 1, qwk(j,j), 1) 23020 j=j+1 goto 23019 23021 continue 23017 i=i+1 goto 23016 23018 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, 0, limnla, nlawk, *scrwk, varht, info, twk, work1) if(info .ne. 0 )then return endif call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlawk, *c, d, info, twk) call dqrsl (s, lds, nobs, n0, qraux, c, tmp, c, tmp, tmp, tmp, 010 *00, info) i=1 23024 if(.not.(i.le.nq))goto 23026 call dsymv('l', n, thewk(i), q(n0+1,n0+1,i), ldqr, c(n0+1), 1, 0.d *0, work1, 1) thewk(i) = ddot (n, c(n0+1), 1, work1, 1) * thewk(i) if( thewk(i) .gt. 0.d0 )then thewk(i) = dlog10 (thewk(i)) else thewk(i) = -25.d0 endif 23025 i=i+1 goto 23024 23026 continue endif scrold = 1.d10 job = 0 23029 continue if( nq .eq. 1 )then theta(1) = 0.d0 goto 23031 endif j=1 23034 if(.not.(j.le.nobs))goto 23036 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23035 j=j+1 goto 23034 23036 continue i=1 23037 if(.not.(i.le.nq))goto 23039 if( thewk(i) .le. -25.d0 )then goto 23038 endif j=1 23042 if(.not.(j.le.nobs))goto 23044 call daxpy (nobs-j+1, 10.d0 ** thewk(i), q(j,j,i), 1, qwk(j,j), 1) 23043 j=j+1 goto 23042 23044 continue 23038 i=i+1 goto 23037 23039 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlawk *, scrwk, varht, info, twk, work1) if(info .ne. 0 )then return endif if( scrold .lt. scrwk )then tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if( alph * tmp .gt. - prec )then info = -5 return endif alph = alph / 2.d0 i=1 23051 if(.not.(i.le.nq))goto 23053 thewk(i) = theta(i) + alph * gwk1(i) 23052 i=i+1 goto 23051 23053 continue goto 23030 endif maxitwk = maxitwk - 1 call dcopy (n-2, qwk(n0+2,n0+1), ldqr+1, traux, 1) call dcopy (n, qwk(n0+1,n0+1), ldqr+1, twk(2,1), 2) call dcopy (n-1, qwk(n0+1,n0+2), ldqr+1, twk(1,2), 2) call ddeev (vmu, nobs, q(n0+1,n0+1,1), ldqr, ldqc, n, nq, qwk(n0+2 *,n0+1), ldqr, traux, twk, ywk(n0+1), thewk, nlawk, scrwk, varht, h *es, nq, gra, hwk1, hwk2, gwk1, gwk2, kwk, n, work1, work2, c, info *) iwk = 0 i=1 23054 if(.not.(i.le.nq))goto 23056 if( thewk(i) .le. -25.d0 )then goto 23055 endif iwk = iwk + 1 call dcopy (nq, hes(1,i), 1, hes(1,iwk), 1) 23055 i=i+1 goto 23054 23056 continue iwk = 0 i=1 23059 if(.not.(i.le.nq))goto 23061 if( thewk(i) .le. -25.d0 )then goto 23060 endif iwk = iwk + 1 call dcopy (nq, hes(i,1), nq, hes(iwk,1), nq) gwk1(iwk) = gra(i) work2(iwk) = gra(i) 23060 i=i+1 goto 23059 23061 continue i=1 23064 if(.not.(i.lt.iwk))goto 23066 call dcopy (iwk-i, hes(i+1,i), 1, hes(i,i+1), nq) 23065 i=i+1 goto 23064 23066 continue call dmcdc (hes, nq, iwk, gwk2, pvtwk, info) call dprmut (gwk1, iwk, pvtwk, 0) call dposl (hes, nq, iwk, gwk1) call dprmut (gwk1, iwk, pvtwk, 1) alph = -1.d0 j = iwk i=nq 23067 if(.not.(i.ge.1))goto 23069 if( thewk(i) .le. -25.0 )then gwk1(i) = 0.d0 else gwk1(i) = gwk1(iwk) iwk = iwk - 1 endif 23068 i=i-1 goto 23067 23069 continue call dscal (nq, 1.d0/dlog(1.d1), gwk1, 1) tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if( tmp .gt. 1.d0 )then call dscal (nq, 1.d0/tmp, gwk1, 1) endif i=1 23074 if(.not.(i.le.nq))goto 23076 if( thewk(i) .le. -25.d0 )then goto 23075 endif thewk(i) = thewk(i) - nlawk 23075 i=i+1 goto 23074 23076 continue call dcopy (nq, thewk, 1, theta, 1) tmp = gra(idamax (nq, gra, 1)) ** 2 if( tmp .lt. prec ** 2 .or. scrold - scrwk .lt. prec * (scrwk + 1 *.d0) .and. tmp .lt. prec * (scrwk + 1.d0) ** 2 )then goto 23031 endif if( maxitwk .lt. 1 )then info = -4 return endif scrold = scrwk i=1 23083 if(.not.(i.le.nq))goto 23085 thewk(i) = thewk(i) + alph * gwk1(i) 23084 i=i+1 goto 23083 23085 continue job = -1 limnla(1) = -1.d0 limnla(2) = 1.d0 23030 goto 23029 23031 continue j=1 23086 if(.not.(j.le.nobs))goto 23088 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23087 j=j+1 goto 23086 23088 continue i=1 23089 if(.not.(i.le.nq))goto 23091 if( theta(i) .le. -25.d0 )then goto 23090 endif j=1 23094 if(.not.(j.le.nobs))goto 23096 call daxpy (nobs-j+1, 10.d0 ** theta(i), q(j,j,i), 1, qwk(j,j), 1) 23095 j=j+1 goto 23094 23096 continue 23090 i=i+1 goto 23089 23091 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlaht *, score, varht, info, twk, work1) if(info .ne. 0 )then return endif call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlaht, *c, d, info, twk) return end gss/src/gaussq.f0000644000176200001440000003166713267111001013314 0ustar liggesusersc To get dgamma, "send dgamma from fnlib". c To get d1mach, mail netlib c send d1mach from core c subroutine gaussq(kind, n, alpha, beta, kpts, endpts, b, t, w) c c this set of routines computes the nodes t(j) and weights c w(j) for gaussian-type quadrature rules with pre-assigned c nodes. these are used when one wishes to approximate c c integral (from a to b) f(x) w(x) dx c c n c by sum w f(t ) c j=1 j j c c (note w(x) and w(j) have no connection with each other.) c here w(x) is one of six possible non-negative weight c functions (listed below), and f(x) is the c function to be integrated. gaussian quadrature is particularly c useful on infinite intervals (with appropriate weight c functions), since then other techniques often fail. c c associated with each weight function w(x) is a set of c orthogonal polynomials. the nodes t(j) are just the zeroes c of the proper n-th degree polynomial. c c input parameters (all real numbers are in double precision) c c kind an integer between 1 and 6 giving the type of c quadrature rule: c c kind = 1: legendre quadrature, w(x) = 1 on (-1, 1) c kind = 2: chebyshev quadrature of the first kind c w(x) = 1/sqrt(1 - x*x) on (-1, +1) c kind = 3: chebyshev quadrature of the second kind c w(x) = sqrt(1 - x*x) on (-1, 1) c kind = 4: hermite quadrature, w(x) = exp(-x*x) on c (-infinity, +infinity) c kind = 5: jacobi quadrature, w(x) = (1-x)**alpha * (1+x)** c beta on (-1, 1), alpha, beta .gt. -1. c note: kind=2 and 3 are a special case of this. c kind = 6: generalized laguerre quadrature, w(x) = exp(-x)* c x**alpha on (0, +infinity), alpha .gt. -1 c c n the number of points used for the quadrature rule c alpha real parameter used only for gauss-jacobi and gauss- c laguerre quadrature (otherwise use 0.d0). c beta real parameter used only for gauss-jacobi quadrature-- c (otherwise use 0.d0) c kpts (integer) normally 0, unless the left or right end- c point (or both) of the interval is required to be a c node (this is called gauss-radau or gauss-lobatto c quadrature). then kpts is the number of fixed c endpoints (1 or 2). c endpts real array of length 2. contains the values of c any fixed endpoints, if kpts = 1 or 2. c b real scratch array of length n c c output parameters (both double precision arrays of length n) c c t will contain the desired nodes. c w will contain the desired weights w(j). c c underflow may sometimes occur, but is harmless. c c references c 1. golub, g. h., and welsch, j. h., "calculation of gaussian c quadrature rules," mathematics of computation 23 (april, c 1969), pp. 221-230. c 2. golub, g. h., "some modified matrix eigenvalue problems," c siam review 15 (april, 1973), pp. 318-334 (section 7). c 3. stroud and secrest, gaussian quadrature formulas, prentice- c hall, englewood cliffs, n.j., 1966. c c original version 20 jan 1975 from stanford c modified 21 dec 1983 by eric grosse c imtql2 => gausq2 c hex constant => d1mach (from core library) c compute pi using datan c removed accuracy claims, description of method c added single precision version c double precision b(n), t(n), w(n), endpts(2), muzero, t1, x gam, solve, dsqrt, alpha, beta c call class (kind, n, alpha, beta, b, t, muzero) c c the matrix of coefficients is assumed to be symmetric. c the array t contains the diagonal elements, the array c b the off-diagonal elements. c make appropriate changes in the lower right 2 by 2 c submatrix. c if (kpts.eq.0) go to 100 if (kpts.eq.2) go to 50 c c if kpts=1, only t(n) must be changed c t(n) = solve(endpts(1), n, t, b)*b(n-1)**2 + endpts(1) go to 100 c c if kpts=2, t(n) and b(n-1) must be recomputed c 50 gam = solve(endpts(1), n, t, b) t1 = ((endpts(1) - endpts(2))/(solve(endpts(2), n, t, b) - gam)) b(n-1) = dsqrt(t1) t(n) = endpts(1) + gam*t1 c c note that the indices of the elements of b run from 1 to n-1 c and thus the value of b(n) is arbitrary. c now compute the eigenvalues of the symmetric tridiagonal c matrix, which has been modified as necessary. c the method used is a ql-type method with origin shifting c 100 w(1) = 1.0d0 do 105 i = 2, n 105 w(i) = 0.0d0 c call gausq2 (n, t, b, w, ierr) do 110 i = 1, n 110 w(i) = muzero * w(i) * w(i) c return end c c c double precision function solve(shift, n, a, b) c c this procedure performs elimination to solve for the c n-th component of the solution delta to the equation c c (jn - shift*identity) * delta = en, c c where en is the vector of all zeroes except for 1 in c the n-th position. c c the matrix jn is symmetric tridiagonal, with diagonal c elements a(i), off-diagonal elements b(i). this equation c must be solved to obtain the appropriate changes in the lower c 2 by 2 submatrix of coefficients for orthogonal polynomials. c c double precision shift, a(n), b(n), alpha c alpha = a(1) - shift nm1 = n - 1 do 10 i = 2, nm1 10 alpha = a(i) - shift - b(i-1)**2/alpha solve = 1.0d0/alpha return end c c c subroutine class(kind, n, alpha, beta, b, a, muzero) c c this procedure supplies the coefficients a(j), b(j) of the c recurrence relation c c b p (x) = (x - a ) p (x) - b p (x) c j j j j-1 j-1 j-2 c c for the various classical (normalized) orthogonal polynomials, c and the zero-th moment c c muzero = integral w(x) dx c c of the given polynomial's weight function w(x). since the c polynomials are orthonormalized, the tridiagonal matrix is c guaranteed to be symmetric. c c the input parameter alpha is used only for laguerre and c jacobi polynomials, and the parameter beta is used only for c jacobi polynomials. the laguerre and jacobi polynomials c require the gamma function. c double precision a(n), b(n), muzero, alpha, beta double precision abi, a2b2, dgamma, pi, dsqrt, ab c pi = 4.0d0 * datan(1.0d0) nm1 = n - 1 go to (10, 20, 30, 40, 50, 60), kind c c kind = 1: legendre polynomials p(x) c on (-1, +1), w(x) = 1. c 10 muzero = 2.0d0 do 11 i = 1, nm1 a(i) = 0.0d0 abi = i 11 b(i) = abi/dsqrt(4*abi*abi - 1.0d0) a(n) = 0.0d0 return c c kind = 2: chebyshev polynomials of the first kind t(x) c on (-1, +1), w(x) = 1 / sqrt(1 - x*x) c 20 muzero = pi do 21 i = 1, nm1 a(i) = 0.0d0 21 b(i) = 0.5d0 b(1) = dsqrt(0.5d0) a(n) = 0.0d0 return c c kind = 3: chebyshev polynomials of the second kind u(x) c on (-1, +1), w(x) = sqrt(1 - x*x) c 30 muzero = pi/2.0d0 do 31 i = 1, nm1 a(i) = 0.0d0 31 b(i) = 0.5d0 a(n) = 0.0d0 return c c kind = 4: hermite polynomials h(x) on (-infinity, c +infinity), w(x) = exp(-x**2) c 40 muzero = dsqrt(pi) do 41 i = 1, nm1 a(i) = 0.0d0 41 b(i) = dsqrt(i/2.0d0) a(n) = 0.0d0 return c c kind = 5: jacobi polynomials p(alpha, beta)(x) on c (-1, +1), w(x) = (1-x)**alpha + (1+x)**beta, alpha and c beta greater than -1 c 50 ab = alpha + beta abi = 2.0d0 + ab muzero = 2.0d0 ** (ab + 1.0d0) * dgamma(alpha + 1.0d0) * dgamma( x beta + 1.0d0) / dgamma(abi) a(1) = (beta - alpha)/abi b(1) = dsqrt(4.0d0*(1.0d0 + alpha)*(1.0d0 + beta)/((abi + 1.0d0)* 1 abi*abi)) a2b2 = beta*beta - alpha*alpha do 51 i = 2, nm1 abi = 2.0d0*i + ab a(i) = a2b2/((abi - 2.0d0)*abi) 51 b(i) = dsqrt (4.0d0*i*(i + alpha)*(i + beta)*(i + ab)/ 1 ((abi*abi - 1)*abi*abi)) abi = 2.0d0*n + ab a(n) = a2b2/((abi - 2.0d0)*abi) return c c kind = 6: laguerre polynomials l(alpha)(x) on c (0, +infinity), w(x) = exp(-x) * x**alpha, alpha greater c than -1. c 60 muzero = dgamma(alpha + 1.0d0) do 61 i = 1, nm1 a(i) = 2.0d0*i - 1.0d0 + alpha 61 b(i) = dsqrt(i*(i + alpha)) a(n) = 2.0d0*n - 1 + alpha return end c c subroutine gausq2(n, d, e, z, ierr) c c this subroutine is a translation of an algol procedure, c num. math. 12, 377-383(1968) by martin and wilkinson, c as modified in num. math. 15, 450(1970) by dubrulle. c handbook for auto. comp., vol.ii-linear algebra, 241-248(1971). c this is a modified version of the 'eispack' routine imtql2. c c this subroutine finds the eigenvalues and first components of the c eigenvectors of a symmetric tridiagonal matrix by the implicit ql c method. c c on input: c c n is the order of the matrix; c c d contains the diagonal elements of the input matrix; c c e contains the subdiagonal elements of the input matrix c in its first n-1 positions. e(n) is arbitrary; c c z contains the first row of the identity matrix. c c on output: c c d contains the eigenvalues in ascending order. if an c error exit is made, the eigenvalues are correct but c unordered for indices 1, 2, ..., ierr-1; c c e has been destroyed; c c z contains the first components of the orthonormal eigenvectors c of the symmetric tridiagonal matrix. if an error exit is c made, z contains the eigenvectors associated with the stored c eigenvalues; c c ierr is set to c zero for normal return, c j if the j-th eigenvalue has not been c determined after 30 iterations. c c ------------------------------------------------------------------ c integer i, j, k, l, m, n, ii, mml, ierr double precision d(n), e(n), z(n), b, c, f, g, p, r, s, machep double precision dsqrt, dabs, dsign, d1mach c machep=d1mach(4) c ierr = 0 if (n .eq. 1) go to 1001 c e(n) = 0.0d0 do 240 l = 1, n j = 0 c :::::::::: look for small sub-diagonal element :::::::::: 105 do 110 m = l, n if (m .eq. n) go to 120 if (dabs(e(m)) .le. machep * (dabs(d(m)) + dabs(d(m+1)))) x go to 120 110 continue c 120 p = d(l) if (m .eq. l) go to 240 if (j .eq. 30) go to 1000 j = j + 1 c :::::::::: form shift :::::::::: g = (d(l+1) - p) / (2.0d0 * e(l)) r = dsqrt(g*g+1.0d0) g = d(m) - p + e(l) / (g + dsign(r, g)) s = 1.0d0 c = 1.0d0 p = 0.0d0 mml = m - l c c :::::::::: for i=m-1 step -1 until l do -- :::::::::: do 200 ii = 1, mml i = m - ii f = s * e(i) b = c * e(i) if (dabs(f) .lt. dabs(g)) go to 150 c = g / f r = dsqrt(c*c+1.0d0) e(i+1) = f * r s = 1.0d0 / r c = c * s go to 160 150 s = f / g r = dsqrt(s*s+1.0d0) e(i+1) = g * r c = 1.0d0 / r s = s * c 160 g = d(i+1) - p r = (d(i) - g) * s + 2.0d0 * c * b p = s * r d(i+1) = g + p g = c * r - b c :::::::::: form first component of vector :::::::::: f = z(i+1) z(i+1) = s * z(i) + c * f 200 z(i) = c * z(i) - s * f c d(l) = d(l) - p e(l) = g e(m) = 0.0d0 go to 105 240 continue c c :::::::::: order eigenvalues and eigenvectors :::::::::: do 300 ii = 2, n i = ii - 1 k = i p = d(i) c do 260 j = ii, n if (d(j) .ge. p) go to 260 k = j p = d(j) 260 continue c if (k .eq. i) go to 300 d(k) = d(i) d(i) = p p = z(i) z(i) = z(k) z(k) = p 300 continue c go to 1001 c :::::::::: set error -- no convergence to an c eigenvalue after 30 iterations :::::::::: 1000 ierr = l 1001 return c :::::::::: last card of gausq2 :::::::::: end c c c double precision function dgamma(x) double precision x dgamma = 1.0d0 return end gss/src/dsytr.f0000644000176200001440000000376013267111001013147 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dsytr (x, ldx, n, tol, info, work) integer ldx, n, info double precision x(ldx,*), tol, work(*) double precision nrmtot, nrmxj, alph, toltot, tolcum, toluni, dn, *ddot integer j info = 0 if( ldx .lt. n .or. n .le. 2 )then info = -1 return endif nrmtot = ddot (n, x, ldx+1, x, ldx+1) j=1 23002 if(.not.(j.lt.n ))goto 23004 nrmtot = nrmtot + 2.d0 * ddot (n-j, x(j+1,j), 1, x(j+1,j), 1) 23003 j=j+1 goto 23002 23004 continue toltot = 1.d0 23005 if( 1.d0 + toltot .gt. 1.d0 )then toltot = toltot / 2.d0 goto 23005 endif 23006 continue toltot = 4.d0 * toltot ** 2 if( toltot .lt. tol )then toltot = tol endif toltot = toltot * nrmtot dn = dfloat (n) toluni = toltot * 6.d0 / dn / ( dn - 1.d0 ) / ( 2.d0 * dn - 1.d0 ) tolcum = 0.d0 j=1 23009 if(.not.(j.lt.n-1 ))goto 23011 nrmtot = nrmtot - x(j,j) * x(j,j) nrmxj = ddot (n-j, x(j+1,j), 1, x(j+1,j), 1) dn = dfloat (n-j) tolcum = tolcum + toluni * dn * dn if( 2.d0 * nrmxj .le. tolcum )then x(j,j+1) = 0.d0 call dscal (n-j, 0.d0, x(j+1,j), 1) tolcum = tolcum - 2.d0 * nrmxj toltot = toltot - 2.d0 * nrmxj goto 23010 endif if( x(j+1,j) .lt. 0.d0 )then x(j,j+1) = dsqrt (nrmxj) else x(j,j+1) = - dsqrt (nrmxj) endif nrmtot = nrmtot - 2.d0 * nrmxj call dscal (n-j, -1.d0/x(j,j+1), x(j+1,j), 1) x(j+1,j) = 1.d0 + x(j+1,j) alph = 1.d0 / x(j+1,j) call dsymv ('l', n-j, alph, x(j+1,j+1), ldx, x(j+1,j), 1, 0.d0, wo *rk(j+1), 1) alph = - ddot (n-j, work(j+1), 1, x(j+1,j), 1) / 2.d0 / x(j+1,j) call daxpy (n-j, alph, x(j+1,j), 1, work(j+1), 1) call dsyr2 ('l', n-j, -1.d0, x(j+1,j), 1, work(j+1), 1, x(j+1,j+1) *, ldx) 23010 j=j+1 goto 23009 23011 continue x(n-1,n) = x(n,n-1) return end gss/src/dnewton.f0000644000176200001440000002436713267111001013466 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine dnewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, * nqd, nt, bwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nt, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,*), bwt(*), * qdwt(nt,*), prec, mchpr, wk(*) integer imrs, iwt, iwtsum, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtsumnew, ifitnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 3) iwtsum = iwt + nqd*nt ifit = iwtsum + nt imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtsumnew = iwtnew + nqd*nt ifitnew = iwtsumnew + nt iwk = ifitnew + nobs call dnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, nqd, * nt, bwt, qdwt, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(iwtsum *), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew *), wk(iwtnew), wk(iwtsumnew), wk(ifitnew), wk(iwk), info) return end subroutine dnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs *, nqd, nt, bwt, qdwt, prec, maxiter, mchpr, mrs, wt, wtsum, fit, m *u, muwk, v, vwk, jpvt, cdnew, wtnew, wtsumnew, fitnew, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nt, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,*), bwt(*), * qdwt(nt,*), prec, mchpr, mrs(*), wt(nt,*), wtsum(*), fit(*), mu(* *), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nt,*), wtsumne *w(*), fitnew(*), wk(*) integer i, j, k, m, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(cntsum.eq.0)then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dfloat (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / dfloat (cntsum) endif 23001 i=i+1 goto 23000 23002 continue m=1 23011 if(.not.(m.le.nt))goto 23013 wtsum(m) = 0.d0 23012 m=m+1 goto 23011 23013 continue i=1 23014 if(.not.(i.le.nqd))goto 23016 tmp = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) m=1 23017 if(.not.(m.le.nt))goto 23019 wt(m,i) = qdwt(m,i) * tmp wtsum(m) = wtsum(m) + wt(m,i) 23018 m=m+1 goto 23017 23019 continue 23015 i=i+1 goto 23014 23016 continue norm = 0.d0 m=1 23020 if(.not.(m.le.nt))goto 23022 norm = norm + bwt(m) * dlog (wtsum(m)) 23021 m=m+1 goto 23020 23022 continue fitmean = 0.d0 i=1 23023 if(.not.(i.le.nobs))goto 23025 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23024 i=i+1 goto 23023 23025 continue if(cntsum.eq.0)then fitmean = fitmean / dfloat (nobs) else fitmean = fitmean / dfloat (cntsum) endif call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean + norm iter = 0 flag = 0 23030 continue iter = iter + 1 call dset(nxis, 0.d0, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) m=1 23033 if(.not.(m.le.nt))goto 23035 i=1 23036 if(.not.(i.le.nxis))goto 23038 muwk(i) = - ddot (nqd, wt(m,1), nt, qdrs(1,i), 1) / wtsum(m) 23037 i=i+1 goto 23036 23038 continue i=1 23039 if(.not.(i.le.nxis))goto 23041 j=i 23042 if(.not.(j.le.nxis))goto 23044 vwk(i,j) = 0.d0 k=1 23045 if(.not.(k.le.nqd))goto 23047 vwk(i,j) = vwk(i,j) + wt(m,k) * qdrs(k,i) * qdrs(k,j) 23046 k=k+1 goto 23045 23047 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23043 j=j+1 goto 23042 23044 continue 23040 i=i+1 goto 23039 23041 continue call daxpy (nxis, bwt(m), muwk, 1, mu, 1) call daxpy (nxis*nxis, bwt(m), vwk, 1, v, 1) 23034 m=m+1 goto 23033 23035 continue i=1 23048 if(.not.(i.le.nxi))goto 23050 j=i 23051 if(.not.(j.le.nxi))goto 23053 v(i,j) = v(i,j) + q(i,j) 23052 j=j+1 goto 23051 23053 continue 23049 i=i+1 goto 23048 23050 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23054 if(.not.(i.le.nxis))goto 23056 jpvt(i) = 0 23055 i=i+1 goto 23054 23056 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23057 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23057 endif 23058 continue i=rkv+1 23059 if(.not.(i.le.nxis))goto 23061 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23060 i=i+1 goto 23059 23061 continue 23062 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) m=1 23065 if(.not.(m.le.nt))goto 23067 wtsumnew(m) = 0.d0 23066 m=m+1 goto 23065 23067 continue i=1 23068 if(.not.(i.le.nqd))goto 23070 tmp = ddot (nxis, qdrs(i,1), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23070 endif tmp = dexp (tmp) m=1 23073 if(.not.(m.le.nt))goto 23075 wtnew(m,i) = qdwt(m,i) * tmp wtsumnew(m) = wtsumnew(m) + wtnew(m,i) 23074 m=m+1 goto 23073 23075 continue 23069 i=i+1 goto 23068 23070 continue norm = 0.d0 m=1 23076 if(.not.(m.le.nt))goto 23078 norm = norm + bwt(m) * dlog (wtsumnew(m)) 23077 m=m+1 goto 23076 23078 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23081 if(.not.(i.le.nobs))goto 23083 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23083 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23082 i=i+1 goto 23081 23083 continue if(cntsum.eq.0)then fitmean = fitmean / dfloat (nobs) else fitmean = fitmean / dfloat (cntsum) endif call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean + norm endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 m=1 23092 if(.not.(m.le.nt))goto 23094 wtsum(m) = 0.d0 i=1 23095 if(.not.(i.le.nqd))goto 23097 wtsum(m) = wtsum(m) + wt(m,i) 23096 i=i+1 goto 23095 23097 continue lkhd = lkhd + bwt(m) * dlog (wtsum(m)) 23093 m=m+1 goto 23092 23094 continue call dset (nobs, 1.d0, fit, 1) iter = 0 goto 23064 endif if(flag.eq.3)then goto 23064 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23064 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23064 endif 23063 goto 23062 23064 continue if(flag.eq.1)then flag = 2 goto 23031 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23108 if(.not.(i.le.nqd))goto 23110 m=1 23111 if(.not.(m.le.nt))goto 23113 disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) 23112 m=m+1 goto 23111 23113 continue 23109 i=i+1 goto 23108 23110 continue i=1 23114 if(.not.(i.le.nobs))goto 23116 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23115 i=i+1 goto 23114 23116 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+da *bs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nt, wtnew, 1, wt, 1) call dcopy (nt, wtsumnew, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23032 endif if(disc.lt.prec)then goto 23032 endif if(iter.lt.maxiter)then goto 23031 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 m=1 23125 if(.not.(m.le.nt))goto 23127 wtsum(m) = 0.d0 i=1 23128 if(.not.(i.le.nqd))goto 23130 wtsum(m) = wtsum(m) + wt(m,i) 23129 i=i+1 goto 23128 23130 continue lkhd = lkhd + bwt(m) * dlog (wtsum(m)) 23126 m=m+1 goto 23125 23127 continue call dset (nobs, 1.d0, fit, 1) iter = 0 flag = 2 else info = 2 goto 23032 endif 23031 goto 23030 23032 continue i=1 23131 if(.not.(i.le.nobs))goto 23133 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(dfloat(cnt(i))), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) if(nxis-rkv.gt.0)then call dset (nxis-rkv, 0.d0, rs(rkv+1,i), 1) endif 23132 i=i+1 goto 23131 23133 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(cntsum.eq.0)then trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 i=1 23140 if(.not.(i.le.nobs))goto 23142 lkhd = lkhd + dlog (fit(i)) 23141 i=i+1 goto 23140 23142 continue lkhd = lkhd / dfloat (nobs) else trc = trc / dfloat(cntsum) / (dfloat(cntsum)-1.d0) lkhd = 0.d0 i=1 23143 if(.not.(i.le.nobs))goto 23145 lkhd = lkhd + dfloat (cnt(i)) * dlog (fit(i)) 23144 i=i+1 goto 23143 23145 continue lkhd = lkhd / dfloat (cntsum) endif m=1 23146 if(.not.(m.le.nt))goto 23148 lkhd = lkhd - bwt(m) * dlog (wtsum(m)) 23147 m=m+1 goto 23146 23148 continue mrs(1) = lkhd mrs(2) = trc return end gss/src/dcrdr.f0000644000176200001440000000456613267111001013105 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dcrdr (s, lds, nobs, nnull, qraux, jpvt, q, ldq, nlaht, * r, ldr, nr, cr, ldcr, dr, lddr, wk, info) integer lds, nobs, nnull, jpvt(*), ldq, ldr, nr, ldcr, lddr, info double precision s(lds,*), qraux(*), q(ldq,*), nlaht, r(ldr,*), cr *(ldcr,*), dr(lddr,*), wk(2,*) double precision dum, ddot integer i, j, n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq .or. ldr .lt. nobs .or. nr .lt. 1 .or. ldcr .lt. nobs .o *r. lddr .lt. nnull )then info = -1 return endif n0 = nnull n = nobs - nnull j=1 23002 if(.not.(j.le.nr))goto 23004 call dcopy (nobs, r(1,j), 1, cr(1,j), 1) 23003 j=j+1 goto 23002 23004 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23005 if(.not.(j.le.nr))goto 23007 call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), dum, cr(1,j), dum *, dum, dum, 01000, info) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), dum, cr(n *0+2,j), dum, dum, dum, 01000, info) 23006 j=j+1 goto 23005 23007 continue call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif j=1 23010 if(.not.(j.le.nr))goto 23012 call dpbsl (wk, 2, n, 1, cr(n0+1,j)) 23011 j=j+1 goto 23010 23012 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23013 if(.not.(j.le.nr))goto 23015 call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), cr(n0+2,j *), dum, dum, dum, dum, 10000, info) 23014 j=j+1 goto 23013 23015 continue j=1 23016 if(.not.(j.le.nr))goto 23018 i=1 23019 if(.not.(i.le.n0))goto 23021 dr(i,j) = cr(i,j) - ddot (n, cr(n0+1,j), 1, q(n0+1,i), 1) 23020 i=i+1 goto 23019 23021 continue call dtrsl (s, lds, n0, dr(1,j), 01, info) call dprmut (dr(1,j), n0, jpvt, 1) 23017 j=j+1 goto 23016 23018 continue j=1 23022 if(.not.(j.le.nr))goto 23024 call dset (n0, 0.d0, cr(1,j), 1) call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), cr(1,j), dum, dum *, dum, dum, 10000, info) 23023 j=j+1 goto 23022 23024 continue return end gss/src/hzdaux.f0000644000176200001440000002125613267111001013305 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine hzdaux1 (cd, nxis, q, nxi, qdrs, nqd, qdwt, nx, mchpr, *wt, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), qdwt(nqd,*), m *chpr, wt(nqd,*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot kk=1 23000 if(.not.(kk.le.nx))goto 23002 i=1 23003 if(.not.(i.le.nqd))goto 23005 wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1 *)) 23004 i=i+1 goto 23003 23005 continue 23001 kk=kk+1 goto 23000 23002 continue call dset (nxis*nxis, 0.d0, v, 1) kk=1 23006 if(.not.(kk.le.nx))goto 23008 i=1 23009 if(.not.(i.le.nxis))goto 23011 j=i 23012 if(.not.(j.le.nxis))goto 23014 vwk(i,j) = 0.d0 k=1 23015 if(.not.(k.le.nqd))goto 23017 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23016 k=k+1 goto 23015 23017 continue 23013 j=j+1 goto 23012 23014 continue 23010 i=i+1 goto 23009 23011 continue call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) 23007 kk=kk+1 goto 23006 23008 continue i=1 23018 if(.not.(i.le.nxi))goto 23020 j=i 23021 if(.not.(j.le.nxi))goto 23023 v(i,j) = v(i,j) + q(i,j) 23022 j=j+1 goto 23021 23023 continue 23019 i=i+1 goto 23018 23020 continue i=1 23024 if(.not.(i.le.nxis))goto 23026 jpvt(i) = 0 23025 i=i+1 goto 23024 23026 continue call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) 23027 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23027 endif 23028 continue i=rkv+1 23029 if(.not.(i.le.nxis))goto 23031 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23030 i=i+1 goto 23029 23031 continue return end subroutine hzdaux2 (v, nxis, jpvt, r, nr, se) double precision v(nxis,*), r(nxis,*), se(*) integer nxis, jpvt(*), nr double precision ddot integer i, infowk i=1 23032 if(.not.(i.le.nr))goto 23034 call dprmut (r(1,i), nxis, jpvt, 0) call dtrsl (v, nxis, nxis, r(1,i), 11, infowk) se(i) = dsqrt (ddot (nxis, r(1,i), 1, r(1,i), 1)) 23033 i=i+1 goto 23032 23034 continue return end subroutine hrkl (cd, nxis, qdrs, nqd, nx, qdwt, wt0, mchpr, wt, mu *, mu0, v, jpvt, wk, cdnew, wtnew, prec, maxiter, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), qdwt(nqd,*), wt0(nqd,*), * mchpr, wt(nqd,*), mu(*), mu0(*), v(nxis,*), wk(*), cdnew(*), wtne *w(nqd,*), prec integer i, j, k, kk, idamax, iter, flag, infowk double precision tmp, ddot, dasum, rkl, mumax, rklnew, disc, disc0 info = 0 call dset (nxis, 0.d0, mu0, 1) kk=1 23035 if(.not.(kk.le.nx))goto 23037 i=1 23038 if(.not.(i.le.nxis))goto 23040 mu0(i) = mu0(i) + ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) 23039 i=i+1 goto 23038 23040 continue 23036 kk=kk+1 goto 23035 23037 continue rkl = 0.d0 kk=1 23041 if(.not.(kk.le.nx))goto 23043 i=1 23044 if(.not.(i.le.nqd))goto 23046 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cd, 1) wt(i,kk) = qdwt(i,kk) * dexp (tmp) rkl = rkl + (wt(i,kk) - wt0(i,kk)*tmp) 23045 i=i+1 goto 23044 23046 continue 23042 kk=kk+1 goto 23041 23043 continue iter = 0 flag = 0 23047 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23050 if(.not.(kk.le.nx))goto 23052 i=1 23053 if(.not.(i.le.nxis))goto 23055 mu(i) = mu(i) - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) j=i 23056 if(.not.(j.le.nxis))goto 23058 k=1 23059 if(.not.(k.le.nqd))goto 23061 v(i,j) = v(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23060 k=k+1 goto 23059 23061 continue 23057 j=j+1 goto 23056 23058 continue 23054 i=i+1 goto 23053 23055 continue 23051 kk=kk+1 goto 23050 23052 continue call daxpy (nxis, 1.d0, mu0, 1, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23062 if(.not.(i.le.nxis))goto 23064 jpvt(i) = 0 23063 i=i+1 goto 23062 23064 continue call dmcdc (v, nxis, nxis, wk, jpvt, infowk) 23065 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) rklnew = 0.d0 kk=1 23068 if(.not.(kk.le.nx))goto 23070 i=1 23071 if(.not.(i.le.nqd))goto 23073 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23073 endif wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) rklnew = rklnew + (wtnew(i,kk) - wt0(i,kk)*tmp) 23072 i=i+1 goto 23071 23073 continue 23069 kk=kk+1 goto 23068 23070 continue if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 goto 23067 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23067 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23067 endif 23066 goto 23065 23067 continue if(flag.eq.1)then flag = 2 goto 23048 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23086 if(.not.(kk.le.nx))goto 23088 i=1 23089 if(.not.(i.le.nqd))goto 23091 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23090 i=i+1 goto 23089 23091 continue 23087 kk=kk+1 goto 23086 23088 continue disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23049 endif if(disc.lt.prec)then goto 23049 endif if(iter.lt.maxiter)then goto 23048 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 flag = 2 else info = 2 goto 23049 endif 23048 goto 23047 23049 continue kk=1 23100 if(.not.(kk.le.nx))goto 23102 i=1 23103 if(.not.(i.le.nqd))goto 23105 wt0(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) 23104 i=i+1 goto 23103 23105 continue 23101 kk=kk+1 goto 23100 23102 continue return end subroutine coxaux (cd, nn, q, nxiz, qdrs, nqd, nt, twt, mchpr, qdw *t, wt, wtsum, muwk, v, vwk, jpvt) integer nn, nxiz, nqd, nt, jpvt(*) double precision cd(*), q(nxiz,*), qdrs(nqd,*), twt(*), mchpr, qdw *t(nqd,*), wt(nqd,*), wtsum(*), muwk(*), v(nn,*), vwk(nn,*) integer i, j, k, m, rkv double precision ddot, tmp call dset(nt, 0.d0, wtsum, 1) i=1 23106 if(.not.(i.le.nqd))goto 23108 tmp = dexp (ddot (nn, qdrs(i,1), nqd, cd, 1)) m=1 23109 if(.not.(m.le.nt))goto 23111 wt(i,m) = qdwt(i,m) * tmp wtsum(m) = wtsum(m) + wt(i,m) 23110 m=m+1 goto 23109 23111 continue 23107 i=i+1 goto 23106 23108 continue call dset(nn*nn, 0.d0, v, 1) m=1 23112 if(.not.(m.le.nt))goto 23114 i=1 23115 if(.not.(i.le.nn))goto 23117 muwk(i) = ddot (nqd, wt(1,m), 1, qdrs(1,i), 1) / wtsum(m) 23116 i=i+1 goto 23115 23117 continue i=1 23118 if(.not.(i.le.nn))goto 23120 j=i 23121 if(.not.(j.le.nn))goto 23123 vwk(i,j) = 0.d0 k=1 23124 if(.not.(k.le.nqd))goto 23126 vwk(i,j) = vwk(i,j) + wt(k,m) * qdrs(k,i) * qdrs(k,j) 23125 k=k+1 goto 23124 23126 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23122 j=j+1 goto 23121 23123 continue 23119 i=i+1 goto 23118 23120 continue call daxpy (nn*nn, twt(m), vwk, 1, v, 1) 23113 m=m+1 goto 23112 23114 continue i=1 23127 if(.not.(i.le.nxiz))goto 23129 j=i 23130 if(.not.(j.le.nxiz))goto 23132 v(i,j) = v(i,j) + q(i,j) 23131 j=j+1 goto 23130 23132 continue 23128 i=i+1 goto 23127 23129 continue i=1 23133 if(.not.(i.le.nn))goto 23135 jpvt(i) = 0 23134 i=i+1 goto 23133 23135 continue call dchdc (v, nn, nn, vwk, jpvt, 1, rkv) 23136 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23136 endif 23137 continue i=rkv+1 23138 if(.not.(i.le.nn))goto 23140 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23139 i=i+1 goto 23138 23140 continue return end gss/src/dcoef.f0000644000176200001440000000262513267111001013061 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dcoef (s, lds, nobs, nnull, qraux, jpvt, z, q, ldq, nla *ht, c, d, info, twk) integer lds, nobs, nnull, jpvt(*), ldq, info double precision s(lds,*), qraux(*), z(*), q(ldq,*), nlaht, c(*), *d(*), twk(2,*) double precision dum, ddot integer n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq )then info = -1 return endif n0 = nnull n = nobs - nnull call dset (n, 10.d0 ** nlaht, twk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, twk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, twk(1,2), 2) call dpbfa (twk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif call dpbsl (twk, 2, n, 1, z(n0+1)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, twk, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, twk, z(n0+2), z(n0+2), du *m, dum, dum, dum, 10000, info) call dset (n0, 0.d0, c, 1) call dcopy (n, z(n0+1), 1, c(n0+1), 1) call dqrsl (s, lds, nobs, nnull, qraux, c, c, dum, dum, dum, dum, *10000, info) j=1 23004 if(.not.(j.le.n0))goto 23006 d(j) = z(j) - ddot (n, z(n0+1), 1, q(n0+1,j), 1) 23005 j=j+1 goto 23004 23006 continue call dtrsl (s, lds, n0, d, 01, info) call dprmut (d, n0, jpvt, 1) return end gss/src/dgold.f0000644000176200001440000000522113267111001013065 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dgold (vmu, q, ldq, n, z, low, upp, nlaht, score, varht *, info, twk, work) character vmu integer ldq, n, info double precision q(ldq,*), z(*), low, upp, nlaht, score, varht, tw *k(2,*), work(*) double precision ratio, mlo, mup, tmpl, tmpu ratio = ( dsqrt (5.d0) - 1.d0 ) / 2.d0 info = 0 if( upp .lt. low )then mlo = low low = upp upp = mlo endif if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( n .lt. 1 .or. n .gt. ldq )then info = -1 return endif mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if( info .ne. 0 )then info = -2 return endif mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if( info .ne. 0 )then info = -2 return endif 23010 continue if( mup - mlo .lt. 1.d-7 )then goto 23012 endif if( tmpl .lt. tmpu )then upp = mup mup = mlo tmpu = tmpl mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if( info .ne. 0 )then info = -2 return endif else low = mlo mlo = mup tmpl = tmpu mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if( info .ne. 0 )then info = -2 return endif endif 23011 goto 23010 23012 continue nlaht = ( mup + mlo ) / 2.d0 call dset (n, 10.d0 ** (nlaht), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**nlaht call dtrev (vmu, twk, 2, n, z, score, varht, info, work) if( info .ne. 0 )then info = -2 return endif return end gss/src/dcore.f0000644000176200001440000000444213267111001013074 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dcore (vmu, q, ldq, nobs, nnull, tol, z, job, limnla, n *laht, score, varht, info, twk, work) character vmu integer ldq, nobs, nnull, job, info double precision q(ldq,*), tol, z(*), limnla(2), nlaht, score(*), *varht, twk(2,*), work(*) double precision dum, low, upp, dasum, mchpr integer n0, n, j info = 0 if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( nnull .lt. 1 .or. nobs .le. nnull .or. nobs .gt. ldq )then info = -1 return endif n0 = nnull n = nobs - nnull call dsytr (q(n0+1,n0+1), ldq, n, tol, info, work) if( info .ne. 0 )then return endif call dcopy (n-2, q(n0+2,n0+1), ldq+1, work, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, work, z(n0+2), dum, z(n0+ *2), dum, dum, dum, 01000, info) if( job .eq. 0 )then mchpr = 1.d0 23008 if( 1.d0 + mchpr .gt. 1.d0 )then mchpr = mchpr / 2.d0 goto 23008 endif 23009 continue mchpr = mchpr * 2.d0 limnla(2) = dmax1 (dasum (n, q(n0+1,n0+1), ldq+1) * 1.d2, mchpr) limnla(1) = limnla(2) * mchpr limnla(2) = dlog10 (limnla(2)) limnla(1) = dlog10 (limnla(1)) endif low = limnla(1) upp = limnla(2) if( job .le. 0 )then call dgold (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), low, upp, nlaht, s *core(1), varht, info, twk, work) if( vmu .eq. 'v' )then score(1) = score(1) * dfloat (nobs) / dfloat (n) endif if( vmu .eq. 'm' )then score(1) = score(1) * dfloat (n) / dfloat (nobs) endif if( vmu .eq. 'u' )then score(1) = score(1) * dfloat (n) / dfloat (nobs) + 2.d0 * varht endif else call deval (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), job, low, upp, nla *ht, score, varht, info, twk, work) dum = dfloat (nobs) / dfloat (n) j=1 23018 if(.not.(j.le.job+1))goto 23020 if( vmu .eq. 'v' )then score(j) = score(j) * dum endif if( vmu .eq. 'm' )then score(j) = score(j) / dum endif if( vmu .eq. 'u' )then score(j) = score(j) / dum + 2.d0 * varht endif 23019 j=j+1 goto 23018 23020 continue endif return end gss/src/dqrslm.f0000644000176200001440000000252213267111001013277 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dqrslm (x, ldx, n, k, qraux, a, lda, job, info, work) integer ldx, n, k, lda, job, info double precision x(ldx,*), qraux(*), a(lda,*), work(*) double precision tmp, alph, ddot integer i, j, step info = 0 if( lda .lt. n .or. n .lt. k .or. k .lt. 1 )then info = -1 return endif if( job .ne. 0 .and. job .ne. 1 )then info = 1 return endif if( job .eq. 0 )then j = 1 step = 1 else j = k step = -1 endif 23006 if( j .ge. 1 .and. j .le. k )then if( qraux(j) .eq. 0.0d0 )then j = j + step goto 23006 endif tmp = x(j,j) x(j,j) = qraux(j) i=1 23010 if(.not.(i.lt.j))goto 23012 alph = - ddot (n-j+1, x(j,j), 1, a(j,i), 1) / x(j,j) call daxpy (n-j+1, alph, x(j,j), 1, a(j,i), 1) 23011 i=i+1 goto 23010 23012 continue alph = 1.d0 / x(j,j) call dsymv ('l', n-j+1, alph, a(j,j), lda, x(j,j), 1, 0.d0, work(j *), 1) alph = - ddot (n-j+1, work(j), 1, x(j,j), 1) / 2.d0 / x(j,j) call daxpy (n-j+1, alph, x(j,j), 1, work(j), 1) call dsyr2 ('l', n-j+1, -1.d0, x(j,j), 1, work(j), 1, a(j,j), lda) x(j,j) = tmp j = j + step goto 23006 endif 23007 continue return end gss/src/dmudr0.f0000644000176200001440000000315013475771046013214 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine dmudr0 (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, * tol, init, prec, maxite, theta, nlaht, score, varht, c, d, iwk, w *k, info) integer vmu integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite, info, iwk( **) double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec, theta( **), nlaht, score, varht, c(*), d(*), wk(*) character*1 vmu1 integer n, n0 integer iqraux, itraux, itwk, iqwk, iywk, ithewk, ihes, igra, ihwk *1, ihwk2, igwk1, igwk2, ikwk, iwork1, iwork2, ijpvt, ipvtwk if( vmu .eq. 1 )then vmu1 = 'v' endif if( vmu .eq. 2 )then vmu1 = 'm' endif if( vmu .eq. 3 )then vmu1 = 'u' endif n = nobs n0 = nnull iqraux = 1 itraux = iqraux + n0 itwk = itraux + (n-n0-2) iqwk = itwk + 2 * (n-n0) iywk = iqwk + n * n ithewk = iywk + n ihes = ithewk + nq igra = ihes + nq * nq ihwk1 = igra + nq ihwk2 = ihwk1 + nq * nq igwk1 = ihwk2 + nq * nq igwk2 = igwk1 + nq ikwk = igwk2 + nq iwork1 = ikwk + (n-n0) * (n-n0) * nq iwork2 = iwork1 + n ijpvt = 1 ipvtwk = ijpvt + n0 call dmudr1 (vmu1, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, tol, * init, prec, maxite, theta, nlaht, score, varht, c, d, wk(iqraux), * iwk(ijpvt), wk(itwk), wk(itraux), wk(iqwk), wk(iywk), wk(ithewk), * wk(ihes), wk(igra), wk(ihwk1), wk(ihwk2), wk(igwk1), wk(igwk2), i *wk(ipvtwk), wk(ikwk), wk(iwork1), wk(iwork2), info) return end gss/src/cdennewton.f0000644000176200001440000003644513267111001014154 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine cdennewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qd *rs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), xx *wt(*), qdwt(*), prec, mchpr, wk(*) integer iwt, iwtsum, imrs, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtnewsum, ifitnew, iwk iwt = 1 iwtsum = iwt + nqd*nx imrs = iwtsum + nx ifit = imrs + nxis imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nqd*nx ifitnew = iwtnewsum + nx iwk = ifitnew + nobs call cdennewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, n *qd, nx, xxwt, qdwt, prec, maxiter, mchpr, wk(iwt), wk(iwtsum), wk( *imrs), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(ic *dnew), wk(iwtnew), wk(iwtnewsum), wk(ifitnew), wk(iwk), info) return end subroutine cdennewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, q *drs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, wt, wtsum, mrs, fi *t, mu, muwk, v, vwk, jpvt, cdnew, wtnew, wtnewsum, fitnew, wk, inf *o) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), xx *wt(*), qdwt(*), prec, mchpr, wt(nqd,*), wtsum(*), mrs(*), fit(*), *mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), wt *newsum(*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(cntsum.eq.0)then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dfloat (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / dfloat (cntsum) endif 23001 i=i+1 goto 23000 23002 continue if(cntsum.eq.0)then trc = 1.d0 / dfloat (nobs) else trc = 1.d0 / dfloat (cntsum) endif norm = 0.d0 kk=1 23013 if(.not.(kk.le.nx))goto 23015 wtsum(kk) = 0.d0 i=1 23016 if(.not.(i.le.nqd))goto 23018 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) 23017 i=i+1 goto 23016 23018 continue norm = norm + xxwt(kk) * dlog (wtsum(kk)) 23014 kk=kk+1 goto 23013 23015 continue fitmean = 0.d0 i=1 23019 if(.not.(i.le.nobs))goto 23021 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23020 i=i+1 goto 23019 23021 continue call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 23024 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23027 if(.not.(kk.le.nx))goto 23029 i=1 23030 if(.not.(i.le.nxis))goto 23032 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23031 i=i+1 goto 23030 23032 continue i=1 23033 if(.not.(i.le.nxis))goto 23035 j=i 23036 if(.not.(j.le.nxis))goto 23038 vwk(i,j) = 0.d0 k=1 23039 if(.not.(k.le.nqd))goto 23041 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23040 k=k+1 goto 23039 23041 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23028 kk=kk+1 goto 23027 23029 continue i=1 23042 if(.not.(i.le.nxi))goto 23044 j=i 23045 if(.not.(j.le.nxi))goto 23047 v(i,j) = v(i,j) + q(i,j) 23046 j=j+1 goto 23045 23047 continue 23043 i=i+1 goto 23042 23044 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23048 if(.not.(i.le.nxis))goto 23050 jpvt(i) = 0 23049 i=i+1 goto 23048 23050 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23051 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23051 endif 23052 continue i=rkv+1 23053 if(.not.(i.le.nxis))goto 23055 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23054 i=i+1 goto 23053 23055 continue 23056 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) norm = 0.d0 kk=1 23059 if(.not.(kk.le.nx))goto 23061 wtnewsum(kk) = 0.d0 i=1 23062 if(.not.(i.le.nqd))goto 23064 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) wtnewsum(kk) = wtnewsum(kk) + wtnew(i,kk) 23063 i=i+1 goto 23062 23064 continue norm = norm + xxwt(kk) * dlog (wtnewsum(kk)) 23060 kk=kk+1 goto 23059 23061 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23067 if(.not.(i.le.nobs))goto 23069 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23069 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23068 i=i+1 goto 23067 23069 continue call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + nor *m endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23076 if(.not.(kk.le.nx))goto 23078 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23077 kk=kk+1 goto 23076 23078 continue call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 goto 23058 endif if(flag.eq.3)then goto 23058 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23058 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23058 endif 23057 goto 23056 23058 continue if(flag.eq.1)then flag = 2 goto 23025 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23089 if(.not.(kk.le.nx))goto 23091 i=1 23092 if(.not.(i.le.nqd))goto 23094 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23093 i=i+1 goto 23092 23094 continue 23090 kk=kk+1 goto 23089 23091 continue i=1 23095 if(.not.(i.le.nobs))goto 23097 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23096 i=i+1 goto 23095 23097 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs( *lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23026 endif if(disc.lt.prec)then goto 23026 endif if(iter.lt.maxiter)then goto 23025 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23106 if(.not.(kk.le.nx))goto 23108 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23107 kk=kk+1 goto 23106 23108 continue call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23026 endif 23025 goto 23024 23026 continue i=1 23109 if(.not.(i.le.nobs))goto 23111 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(dfloat(cnt(i))), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23110 i=i+1 goto 23109 23111 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(cntsum.eq.0)then trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 i=1 23116 if(.not.(i.le.nobs))goto 23118 lkhd = lkhd + dlog (fit(i)) 23117 i=i+1 goto 23116 23118 continue lkhd = lkhd / dfloat (nobs) else trc = trc / dfloat(cntsum) / (dfloat(cntsum)-1.d0) lkhd = 0.d0 i=1 23119 if(.not.(i.le.nobs))goto 23121 lkhd = lkhd + dfloat (cnt(i)) * dlog (fit(i)) 23120 i=i+1 goto 23119 23121 continue lkhd = lkhd / dfloat (cntsum) endif kk=1 23122 if(.not.(kk.le.nx))goto 23124 lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) 23123 kk=kk+1 goto 23122 23124 continue wtsum(1) = lkhd wtsum(2) = trc return end subroutine cdenrkl (cd, nxis, qdrs, nqd, nx, xxwt, qdwt, wt0, mchp *r, wt, wtnew, mu, muwk, v, vwk, jpvt, cdnew, prec, maxiter, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), xxwt(*), qdwt(*), wt0(nq *d,*), mchpr, wt(nqd,*), wtnew(nqd,*), mu(*), muwk(*), v(nxis,*), v *wk(nxis,*), cdnew(*), prec integer i, j, k, kk, iter, flag, idamax, infowk double precision ddot, dasum, rkl, tmp, mumax, rklnew, disc, disc0 kk=1 23125 if(.not.(kk.le.nx))goto 23127 i=1 23128 if(.not.(i.le.nqd))goto 23130 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) 23129 i=i+1 goto 23128 23130 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23126 kk=kk+1 goto 23125 23127 continue rkl = 0.d0 kk=1 23131 if(.not.(kk.le.nx))goto 23133 tmp = 0.d0 i=1 23134 if(.not.(i.le.nqd))goto 23136 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23135 i=i+1 goto 23134 23136 continue rkl = rkl + xxwt(kk) * tmp 23132 kk=kk+1 goto 23131 23133 continue iter = 0 flag = 0 23137 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23140 if(.not.(kk.le.nx))goto 23142 i=1 23143 if(.not.(i.le.nxis))goto 23145 muwk(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) 23144 i=i+1 goto 23143 23145 continue i=1 23146 if(.not.(i.le.nxis))goto 23148 j=i 23149 if(.not.(j.le.nxis))goto 23151 vwk(i,j) = 0.d0 k=1 23152 if(.not.(k.le.nqd))goto 23154 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23153 k=k+1 goto 23152 23154 continue vwk(i,j) = vwk(i,j) - muwk(i) * muwk(j) 23150 j=j+1 goto 23149 23151 continue muwk(i) = ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) - muwk(i) 23147 i=i+1 goto 23146 23148 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23141 kk=kk+1 goto 23140 23142 continue mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23155 if(.not.(i.le.nxis))goto 23157 jpvt(i) = 0 23156 i=i+1 goto 23155 23157 continue call dmcdc (v, nxis, nxis, cdnew, jpvt, infowk) 23158 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23161 if(.not.(kk.le.nx))goto 23163 i=1 23164 if(.not.(i.le.nqd))goto 23166 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) 23165 i=i+1 goto 23164 23166 continue call dscal (nqd, 1.d0/dasum(nqd,wtnew(1,kk),1), wtnew(1,kk), 1) 23162 kk=kk+1 goto 23161 23163 continue if((flag.eq.0).or.(flag.eq.2))then rklnew = 0.d0 kk=1 23169 if(.not.(kk.le.nx))goto 23171 tmp = 0.d0 i=1 23172 if(.not.(i.le.nqd))goto 23174 tmp = tmp + dlog(wt0(i,kk)/wtnew(i,kk)) * wt0(i,kk) 23173 i=i+1 goto 23172 23174 continue rklnew = rklnew + xxwt(kk) * tmp 23170 kk=kk+1 goto 23169 23171 continue endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23177 if(.not.(kk.le.nx))goto 23179 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23178 kk=kk+1 goto 23177 23179 continue rkl = 0.d0 kk=1 23180 if(.not.(kk.le.nx))goto 23182 tmp = 0.d0 i=1 23183 if(.not.(i.le.nqd))goto 23185 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23184 i=i+1 goto 23183 23185 continue rkl = rkl + xxwt(kk) * tmp 23181 kk=kk+1 goto 23180 23182 continue iter = 0 goto 23160 endif if(flag.eq.3)then goto 23160 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23160 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23160 endif 23159 goto 23158 23160 continue if(flag.eq.1)then flag = 2 goto 23138 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23196 if(.not.(kk.le.nx))goto 23198 i=1 23199 if(.not.(i.le.nqd))goto 23201 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23200 i=i+1 goto 23199 23201 continue 23197 kk=kk+1 goto 23196 23198 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(rkl)))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23139 endif if(disc.lt.prec)then goto 23139 endif if(iter.lt.maxiter)then goto 23138 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23210 if(.not.(kk.le.nx))goto 23212 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23211 kk=kk+1 goto 23210 23212 continue rkl = 0.d0 kk=1 23213 if(.not.(kk.le.nx))goto 23215 tmp = 0.d0 i=1 23216 if(.not.(i.le.nqd))goto 23218 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23217 i=i+1 goto 23216 23218 continue rkl = rkl + xxwt(kk) * tmp 23214 kk=kk+1 goto 23213 23215 continue iter = 0 flag = 2 else info = 2 goto 23139 endif 23138 goto 23137 23139 continue rkl = 0.d0 kk=1 23219 if(.not.(kk.le.nx))goto 23221 tmp = 0.d0 i=1 23222 if(.not.(i.le.nqd))goto 23224 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23223 i=i+1 goto 23222 23224 continue rkl = rkl + xxwt(kk) * tmp 23220 kk=kk+1 goto 23219 23221 continue wt(1,1) = rkl return end gss/src/dmcdc.f0000644000176200001440000000450513267111001013052 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dmcdc (a, lda, p, e, jpvt, info) integer lda, p, jpvt(*), info double precision a(lda,*), e(*) double precision beta, delta, theta, tmp, dasum, ddot integer i, j, jmax, jtmp, idamax info = 0 if( lda .lt. p .or. p .lt. 1 )then info = -1 return endif tmp = 1.d0 23002 if( 1.d0 + tmp .gt. 1.d0 )then tmp = tmp / 2.d0 goto 23002 endif 23003 continue jmax = idamax (p, a, lda+1) beta = dmax1 (2.d0 * tmp, dabs (a(jmax,jmax))) tmp = dsqrt (dfloat (p*p-1)) if( tmp .lt. 1.d0 )then tmp = 1.d0 endif j=2 23006 if(.not.(j.le.p))goto 23008 jmax = idamax (j-1, a(1,j), 1) beta = dmax1 (beta, dabs (a(jmax,j)) / tmp) 23007 j=j+1 goto 23006 23008 continue delta = dasum (p, a, lda+1) / dfloat (p) * 1.d-7 delta = dmax1 (delta, 1.d-10) j=1 23009 if(.not.(j.le.p))goto 23011 jpvt(j) = j 23010 j=j+1 goto 23009 23011 continue j=1 23012 if(.not.(j.le.p))goto 23014 jmax = idamax (p-j+1, a(j,j), lda+1) + j - 1 if( jmax .ne. j )then call dswap (j-1, a(1,j), 1, a(1,jmax), 1) call dswap (jmax-j-1, a(j,j+1), lda, a(j+1,jmax), 1) call dswap (p-jmax, a(j,jmax+1), lda, a(jmax,jmax+1), lda) tmp = a(j,j) a(j,j) = a(jmax,jmax) a(jmax,jmax) = tmp jtmp = jpvt(j) jpvt(j) = jpvt(jmax) jpvt(jmax) = jtmp endif i=1 23017 if(.not.(i.lt.j))goto 23019 a(i,j) = a(i,j) / a(i,i) 23018 i=i+1 goto 23017 23019 continue i=j+1 23020 if(.not.(i.le.p))goto 23022 a(j,i) = a(j,i) - ddot (j-1, a(1,j), 1, a(1,i), 1) 23021 i=i+1 goto 23020 23022 continue if( j .eq. p )then theta = 0.d0 else jmax = idamax (p-j, a(j,j+1), lda) + j theta = dabs (a(j,jmax)) endif tmp = dmax1 (delta, dabs (a(j,j)), theta ** 2 / beta) e(j) = tmp - a(j,j) a(j,j) = tmp i=j+1 23025 if(.not.(i.le.p))goto 23027 a(i,i) = a(i,i) - a(j,i) ** 2 / a(j,j) 23026 i=i+1 goto 23025 23027 continue 23013 j=j+1 goto 23012 23014 continue j=1 23028 if(.not.(j.le.p))goto 23030 a(j,j) = dsqrt (a(j,j)) call dscal (p-j, a(j,j), a(j,j+1), lda) 23029 j=j+1 goto 23028 23030 continue return end gss/src/llrmnewton.f0000644000176200001440000004364413267111001014210 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine llrmnewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qd *rs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cnt(*), qdrs(nqd,nxi *s,*), xxwt(*), qdwt(*), prec, mchpr, wk(*) integer iwt, iwtsum, imrs, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtnewsum, ifitnew, iwk iwt = 1 iwtsum = iwt + nqd*nx imrs = iwtsum + nx ifit = imrs + nxis imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nqd*nx ifitnew = iwtnewsum + nx iwk = ifitnew + nobs call llrmnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, n *qd, nx, xxwt, qdwt, prec, maxiter, mchpr, wk(iwt), wk(iwtsum), wk( *imrs), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(ic *dnew), wk(iwtnew), wk(iwtnewsum), wk(ifitnew), wk(iwk), info) return end subroutine llrmnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, q *drs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, wt, wtsum, mrs, fi *t, mu, muwk, v, vwk, jpvt, cdnew, wtnew, wtnewsum, fitnew, wk, inf *o) integer nxis, nxi, nobs, cntsum, nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), cnt(*), qdrs(nqd,nxi *s,*), xxwt(*), qdwt(*), prec, mchpr, wt(nqd,*), wtsum(*), mrs(*), *fit(*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nq *d,*), wtnewsum(*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision cnt1, norm, tmp, ddot, fitmean, lkhd, mumax, lkhd *new, disc, disc0, trc info = 0 if(cntsum.ne.0)then cnt1 = 0.d0 j=1 23002 if(.not.(j.le.nobs))goto 23004 cnt1 = cnt1 + cnt(j) 23003 j=j+1 goto 23002 23004 continue endif i=1 23005 if(.not.(i.le.nxis))goto 23007 mrs(i) = 0.d0 if(cntsum.eq.0)then j=1 23010 if(.not.(j.le.nobs))goto 23012 mrs(i) = mrs(i) + rs(i,j) 23011 j=j+1 goto 23010 23012 continue mrs(i) = mrs(i) / dfloat (nobs) else j=1 23013 if(.not.(j.le.nobs))goto 23015 mrs(i) = mrs(i) + rs(i,j) * cnt(j) 23014 j=j+1 goto 23013 23015 continue mrs(i) = mrs(i) / cnt1 endif 23006 i=i+1 goto 23005 23007 continue if(cntsum.eq.0)then trc = 1.d0 / dfloat (nobs) else trc = 1.d0 / cnt1 endif norm = 0.d0 kk=1 23018 if(.not.(kk.le.nx))goto 23020 wtsum(kk) = 0.d0 i=1 23021 if(.not.(i.le.nqd))goto 23023 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) 23022 i=i+1 goto 23021 23023 continue norm = norm + xxwt(kk) * dlog (wtsum(kk)) 23019 kk=kk+1 goto 23018 23020 continue fitmean = 0.d0 i=1 23024 if(.not.(i.le.nobs))goto 23026 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23025 i=i+1 goto 23024 23026 continue call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 23029 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23032 if(.not.(kk.le.nx))goto 23034 i=1 23035 if(.not.(i.le.nxis))goto 23037 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23036 i=i+1 goto 23035 23037 continue i=1 23038 if(.not.(i.le.nxis))goto 23040 j=i 23041 if(.not.(j.le.nxis))goto 23043 vwk(i,j) = 0.d0 k=1 23044 if(.not.(k.le.nqd))goto 23046 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23045 k=k+1 goto 23044 23046 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) 23042 j=j+1 goto 23041 23043 continue 23039 i=i+1 goto 23038 23040 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23033 kk=kk+1 goto 23032 23034 continue i=1 23047 if(.not.(i.le.nxi))goto 23049 j=i 23050 if(.not.(j.le.nxi))goto 23052 v(i,j) = v(i,j) + q(i,j) 23051 j=j+1 goto 23050 23052 continue 23048 i=i+1 goto 23047 23049 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23053 if(.not.(i.le.nxis))goto 23055 jpvt(i) = 0 23054 i=i+1 goto 23053 23055 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23056 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23056 endif 23057 continue i=rkv+1 23058 if(.not.(i.le.nxis))goto 23060 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23059 i=i+1 goto 23058 23060 continue 23061 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) norm = 0.d0 kk=1 23064 if(.not.(kk.le.nx))goto 23066 wtnewsum(kk) = 0.d0 i=1 23067 if(.not.(i.le.nqd))goto 23069 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) wtnewsum(kk) = wtnewsum(kk) + wtnew(i,kk) 23068 i=i+1 goto 23067 23069 continue norm = norm + xxwt(kk) * dlog (wtnewsum(kk)) 23065 kk=kk+1 goto 23064 23066 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23072 if(.not.(i.le.nobs))goto 23074 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23074 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * cnt(i) endif fitmean = fitmean + tmp 23073 i=i+1 goto 23072 23074 continue call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + nor *m endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23081 if(.not.(kk.le.nx))goto 23083 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23082 kk=kk+1 goto 23081 23083 continue tmp = 0.d0 i=1 23084 if(.not.(i.le.nqd))goto 23086 tmp = tmp + qdwt(i) 23085 i=i+1 goto 23084 23086 continue call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 goto 23063 endif if(flag.eq.3)then goto 23063 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23063 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23063 endif 23062 goto 23061 23063 continue if(flag.eq.1)then flag = 2 goto 23030 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23097 if(.not.(kk.le.nx))goto 23099 i=1 23100 if(.not.(i.le.nqd))goto 23102 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23101 i=i+1 goto 23100 23102 continue 23098 kk=kk+1 goto 23097 23099 continue i=1 23103 if(.not.(i.le.nobs))goto 23105 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23104 i=i+1 goto 23103 23105 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs( *lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23031 endif if(disc.lt.prec)then goto 23031 endif if(iter.lt.maxiter)then goto 23030 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23114 if(.not.(kk.le.nx))goto 23116 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23115 kk=kk+1 goto 23114 23116 continue tmp = 0.d0 i=1 23117 if(.not.(i.le.nqd))goto 23119 tmp = tmp + qdwt(i) 23118 i=i+1 goto 23117 23119 continue call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23031 endif 23030 goto 23029 23031 continue i=1 23120 if(.not.(i.le.nobs))goto 23122 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(cnt(i)), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23121 i=i+1 goto 23120 23122 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(cntsum.eq.0)then trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 i=1 23127 if(.not.(i.le.nobs))goto 23129 lkhd = lkhd + dlog (fit(i)) 23128 i=i+1 goto 23127 23129 continue lkhd = lkhd / dfloat (nobs) else trc = trc / cnt1 / (cnt1-1.d0) lkhd = 0.d0 i=1 23130 if(.not.(i.le.nobs))goto 23132 lkhd = lkhd + cnt(i) * dlog (fit(i)) 23131 i=i+1 goto 23130 23132 continue lkhd = lkhd / cnt1 endif kk=1 23133 if(.not.(kk.le.nx))goto 23135 lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) 23134 kk=kk+1 goto 23133 23135 continue wtsum(1) = lkhd wtsum(2) = trc return end subroutine llrmaux (cd, nxis, q, nxi, qdrs, nqd, nx, xxwt, qdwt, m *chpr, wt, wtsum, mu, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), xxwt(*), qdwt( **), mchpr, wt(nqd,*), wtsum(*), mu(*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot kk=1 23136 if(.not.(kk.le.nx))goto 23138 wtsum(kk) = 0.d0 i=1 23139 if(.not.(i.le.nqd))goto 23141 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) 23140 i=i+1 goto 23139 23141 continue 23137 kk=kk+1 goto 23136 23138 continue call dset (nxis*nxis, 0.d0, v, 1) kk=1 23142 if(.not.(kk.le.nx))goto 23144 i=1 23145 if(.not.(i.le.nxis))goto 23147 mu(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23146 i=i+1 goto 23145 23147 continue i=1 23148 if(.not.(i.le.nxis))goto 23150 j=i 23151 if(.not.(j.le.nxis))goto 23153 vwk(i,j) = 0.d0 k=1 23154 if(.not.(k.le.nqd))goto 23156 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23155 k=k+1 goto 23154 23156 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - mu(i) * mu(j) 23152 j=j+1 goto 23151 23153 continue 23149 i=i+1 goto 23148 23150 continue call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23143 kk=kk+1 goto 23142 23144 continue i=1 23157 if(.not.(i.le.nxi))goto 23159 j=i 23160 if(.not.(j.le.nxi))goto 23162 v(i,j) = v(i,j) + q(i,j) 23161 j=j+1 goto 23160 23162 continue 23158 i=i+1 goto 23157 23159 continue i=1 23163 if(.not.(i.le.nxis))goto 23165 jpvt(i) = 0 23164 i=i+1 goto 23163 23165 continue call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) 23166 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23166 endif 23167 continue i=rkv+1 23168 if(.not.(i.le.nxis))goto 23170 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23169 i=i+1 goto 23168 23170 continue return end subroutine llrmrkl (cd, nxis, qdrs, nqd, nx, xxwt, qdwt, wt0, offs *et, mchpr, wt, wtnew, mu, muwk, v, vwk, jpvt, cdnew, prec, maxiter *, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), xxwt(*), qdwt(*), wt0(nq *d,*), offset(nqd,*), mchpr, wt(nqd,*), wtnew(nqd,*), mu(*), muwk(* *), v(nxis,*), vwk(nxis,*), cdnew(*), prec integer i, j, k, kk, iter, flag, idamax, infowk double precision ddot, dasum, rkl, tmp, mumax, rklnew, disc, disc0 kk=1 23171 if(.not.(kk.le.nx))goto 23173 i=1 23174 if(.not.(i.le.nqd))goto 23176 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1) + offset(i, *kk)) * qdwt(i) 23175 i=i+1 goto 23174 23176 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23172 kk=kk+1 goto 23171 23173 continue rkl = 0.d0 kk=1 23177 if(.not.(kk.le.nx))goto 23179 tmp = 0.d0 i=1 23180 if(.not.(i.le.nqd))goto 23182 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23181 i=i+1 goto 23180 23182 continue rkl = rkl + xxwt(kk) * tmp 23178 kk=kk+1 goto 23177 23179 continue iter = 0 flag = 0 23183 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23186 if(.not.(kk.le.nx))goto 23188 i=1 23189 if(.not.(i.le.nxis))goto 23191 muwk(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) 23190 i=i+1 goto 23189 23191 continue i=1 23192 if(.not.(i.le.nxis))goto 23194 j=i 23195 if(.not.(j.le.nxis))goto 23197 vwk(i,j) = 0.d0 k=1 23198 if(.not.(k.le.nqd))goto 23200 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23199 k=k+1 goto 23198 23200 continue vwk(i,j) = vwk(i,j) - muwk(i) * muwk(j) 23196 j=j+1 goto 23195 23197 continue muwk(i) = ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) - muwk(i) 23193 i=i+1 goto 23192 23194 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23187 kk=kk+1 goto 23186 23188 continue mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23201 if(.not.(i.le.nxis))goto 23203 jpvt(i) = 0 23202 i=i+1 goto 23201 23203 continue call dmcdc (v, nxis, nxis, cdnew, jpvt, infowk) 23204 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23207 if(.not.(kk.le.nx))goto 23209 i=1 23210 if(.not.(i.le.nqd))goto 23212 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) + off *set(i,kk)) * qdwt(i) 23211 i=i+1 goto 23210 23212 continue call dscal (nqd, 1.d0/dasum(nqd,wtnew(1,kk),1), wtnew(1,kk), 1) 23208 kk=kk+1 goto 23207 23209 continue if((flag.eq.0).or.(flag.eq.2))then rklnew = 0.d0 kk=1 23215 if(.not.(kk.le.nx))goto 23217 tmp = 0.d0 i=1 23218 if(.not.(i.le.nqd))goto 23220 tmp = tmp + dlog(wt0(i,kk)/wtnew(i,kk)) * wt0(i,kk) 23219 i=i+1 goto 23218 23220 continue rklnew = rklnew + xxwt(kk) * tmp 23216 kk=kk+1 goto 23215 23217 continue endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23223 if(.not.(kk.le.nx))goto 23225 i=1 23226 if(.not.(i.le.nqd))goto 23228 wt(i,kk) = dexp (offset(i,kk)) * qdwt(i) 23227 i=i+1 goto 23226 23228 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23224 kk=kk+1 goto 23223 23225 continue rkl = 0.d0 kk=1 23229 if(.not.(kk.le.nx))goto 23231 tmp = 0.d0 i=1 23232 if(.not.(i.le.nqd))goto 23234 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23233 i=i+1 goto 23232 23234 continue rkl = rkl + xxwt(kk) * tmp 23230 kk=kk+1 goto 23229 23231 continue iter = 0 goto 23206 endif if(flag.eq.3)then goto 23206 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23206 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23206 endif 23205 goto 23204 23206 continue if(flag.eq.1)then flag = 2 goto 23184 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23245 if(.not.(kk.le.nx))goto 23247 i=1 23248 if(.not.(i.le.nqd))goto 23250 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23249 i=i+1 goto 23248 23250 continue 23246 kk=kk+1 goto 23245 23247 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(rkl)))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23185 endif if(disc.lt.prec)then goto 23185 endif if(iter.lt.maxiter)then goto 23184 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23259 if(.not.(kk.le.nx))goto 23261 i=1 23262 if(.not.(i.le.nqd))goto 23264 wt(i,kk) = dexp (offset(i,kk)) * qdwt(i) 23263 i=i+1 goto 23262 23264 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23260 kk=kk+1 goto 23259 23261 continue rkl = 0.d0 kk=1 23265 if(.not.(kk.le.nx))goto 23267 tmp = 0.d0 i=1 23268 if(.not.(i.le.nqd))goto 23270 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23269 i=i+1 goto 23268 23270 continue rkl = rkl + xxwt(kk) * tmp 23266 kk=kk+1 goto 23265 23267 continue iter = 0 flag = 2 else info = 2 goto 23185 endif 23184 goto 23183 23185 continue rkl = 0.d0 kk=1 23271 if(.not.(kk.le.nx))goto 23273 tmp = 0.d0 i=1 23274 if(.not.(i.le.nqd))goto 23276 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23275 i=i+1 goto 23274 23276 continue rkl = rkl + xxwt(kk) * tmp 23272 kk=kk+1 goto 23271 23273 continue wt(1,1) = rkl return end gss/src/init.c0000644000176200001440000001315413475326427012765 0ustar liggesusers#include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void quad_smolyak(void *, void *, void *, void *); extern void size_smolyak(void *, void *, void *); /* .Fortran calls */ extern void F77_NAME(cdennewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(cdennewton10)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(cdenrkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(coxaux)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dcrdr)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dmudr0)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dnewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dnewton10)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(drkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dsidr0)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(dsms)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(gaussq)(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hrkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdaux1)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdaux101)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdaux2)(void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdnewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(hzdnewton10)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(llrmaux)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(llrmnewton)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(llrmrkl)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(reg)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(regaux)(void *, void *, void *, void *, void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"quad_smolyak", (DL_FUNC) &quad_smolyak, 4}, {"size_smolyak", (DL_FUNC) &size_smolyak, 3}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortranEntries[] = { {"cdennewton", (DL_FUNC) &F77_NAME(cdennewton), 19}, {"cdennewton10", (DL_FUNC) &F77_NAME(cdennewton10), 15}, {"cdenrkl", (DL_FUNC) &F77_NAME(cdenrkl), 20}, {"coxaux", (DL_FUNC) &F77_NAME(coxaux), 16}, {"dcrdr", (DL_FUNC) &F77_NAME(dcrdr), 18}, {"dmudr0", (DL_FUNC) &F77_NAME(dmudr0), 23}, {"dnewton", (DL_FUNC) &F77_NAME(dnewton), 19}, {"dnewton10", (DL_FUNC) &F77_NAME(dnewton10), 15}, {"drkl", (DL_FUNC) &F77_NAME(drkl), 14}, {"dsidr0", (DL_FUNC) &F77_NAME(dsidr0), 20}, {"dsms", (DL_FUNC) &F77_NAME(dsms), 12}, {"gaussq", (DL_FUNC) &F77_NAME(gaussq), 9}, {"hrkl", (DL_FUNC) &F77_NAME(hrkl), 19}, {"hzdaux1", (DL_FUNC) &F77_NAME(hzdaux1), 13}, {"hzdaux101", (DL_FUNC) &F77_NAME(hzdaux101), 10}, {"hzdaux2", (DL_FUNC) &F77_NAME(hzdaux2), 6}, {"hzdnewton", (DL_FUNC) &F77_NAME(hzdnewton), 19}, {"hzdnewton10", (DL_FUNC) &F77_NAME(hzdnewton10), 17}, {"llrmaux", (DL_FUNC) &F77_NAME(llrmaux), 16}, {"llrmnewton", (DL_FUNC) &F77_NAME(llrmnewton), 19}, {"llrmrkl", (DL_FUNC) &F77_NAME(llrmrkl), 21}, {"reg", (DL_FUNC) &F77_NAME(reg), 18}, {"regaux", (DL_FUNC) &F77_NAME(regaux), 9}, {NULL, NULL, 0} }; void R_init_gss(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } gss/src/dnewton10.f0000644000176200001440000001625213267111001013621 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine dnewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, int *rs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, p *rec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew), w *k(iwtnew), wk(iwk), info) return end subroutine dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, in *trs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, info *) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision wtsum, tmp, ddot, lkhd, mumax, wtsumnew, lkhdnew, * disc, disc0 info = 0 wtsum = 0.d0 i=1 23000 if(.not.(i.le.nobs))goto 23002 tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif wtsum = wtsum + wt(i) 23001 i=i+1 goto 23000 23002 continue if(cntsum.eq.0)then lkhd = wtsum / dfloat (nobs) else lkhd = wtsum / dfloat (cntsum) endif lkhd = dlog (lkhd) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 23007 continue iter = iter + 1 i=1 23010 if(.not.(i.le.nxis))goto 23012 mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) / wtsum 23011 i=i+1 goto 23010 23012 continue i=1 23013 if(.not.(i.le.nxis))goto 23015 j=i 23016 if(.not.(j.le.nxis))goto 23018 v(i,j) = 0.d0 k=1 23019 if(.not.(k.le.nobs))goto 23021 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23020 k=k+1 goto 23019 23021 continue v(i,j) = v(i,j) / wtsum - mu(i) * mu(j) if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23017 j=j+1 goto 23016 23018 continue 23014 i=i+1 goto 23013 23015 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23024 if(.not.(i.le.nxis))goto 23026 jpvt(i) = 0 23025 i=i+1 goto 23024 23026 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23027 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23027 endif 23028 continue i=rkv+1 23029 if(.not.(i.le.nxis))goto 23031 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23030 i=i+1 goto 23029 23031 continue 23032 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) wtsumnew = 0.d0 i=1 23035 if(.not.(i.le.nobs))goto 23037 tmp = ddot (nxis, rs(i,1), nobs, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23037 endif wtnew(i) = dexp (-tmp) if(cntsum.ne.0)then wtnew(i) = wtnew(i) * dfloat (cnt(i)) endif wtsumnew = wtsumnew + wtnew(i) 23036 i=i+1 goto 23035 23037 continue if(cntsum.eq.0)then lkhdnew = wtsumnew / dfloat (nobs) else lkhdnew = wtsumnew / dfloat (cntsum) endif lkhdnew = dlog (lkhdnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 i=1 23046 if(.not.(i.le.nobs))goto 23048 if(cntsum.ne.0)then wt(i) = dfloat (cnt(i)) else wt(i) = 1.d0 endif wtsum = wtsum + wt(i) 23047 i=i+1 goto 23046 23048 continue lkhd = 0.d0 iter = 0 goto 23034 endif if(flag.eq.3)then goto 23034 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23034 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23034 endif 23033 goto 23032 23034 continue if(flag.eq.1)then flag = 2 goto 23008 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23061 if(.not.(i.le.nobs))goto 23063 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23062 i=i+1 goto 23061 23063 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) wtsum = wtsumnew lkhd = lkhdnew if(disc0.lt.prec)then goto 23009 endif if(disc.lt.prec)then goto 23009 endif if(iter.lt.maxiter)then goto 23008 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 i=1 23072 if(.not.(i.le.nobs))goto 23074 if(cntsum.ne.0)then wt(i) = dfloat (cnt(i)) else wt(i) = 1.d0 endif wtsum = wtsum + wt(i) 23073 i=i+1 goto 23072 23074 continue lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23009 endif 23008 goto 23007 23009 continue call dscal (nobs, 1.d0/wtsum, wt, 1) i=1 23077 if(.not.(i.le.nxis))goto 23079 j=i 23080 if(.not.(j.le.nxis))goto 23082 v(i,j) = 0.d0 k=1 23083 if(.not.(k.le.nobs))goto 23085 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23084 k=k+1 goto 23083 23085 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23081 j=j+1 goto 23080 23082 continue 23078 i=i+1 goto 23077 23079 continue i=1 23088 if(.not.(i.le.nxis))goto 23090 jpvt(i) = 0 23089 i=i+1 goto 23088 23090 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23091 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23091 endif 23092 continue i=rkv+1 23093 if(.not.(i.le.nxis))goto 23095 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23094 i=i+1 goto 23093 23095 continue i=1 23096 if(.not.(i.le.nobs))goto 23098 call dcopy (nxis, rs(i,1), nobs, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.ne.0)then wtnew(i) = wtnew(i) / dfloat (cnt(i)) endif 23097 i=i+1 goto 23096 23098 continue call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/reg.f0000644000176200001440000001234713475306475012606 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine reg (sr, nobs, nnull, q, nxi, y, method, alpha, varht, *score, dc, mchpr, v, mu, jpvt, wk, rkv, info) double precision sr(nobs,*), q(nxi,*), y(*), alpha, varht, score, *dc(*), mchpr, v(nnull+nxi,*), mu(*), wk(*) integer nobs, nnull, nxi, method, jpvt(*), rkv, info double precision ddot, dasum, rss, trc, dum integer i, j, nn, idamax, infowk, idum info = 0 nn = nnull + nxi i=1 23000 if(.not.(i.le.nn))goto 23002 mu(i) = ddot (nobs, sr(1,i), 1, y, 1) j=i 23003 if(.not.(j.le.nn))goto 23005 v(i,j) = ddot (nobs, sr(1,i), 1, sr(1,j), 1) if(i.gt.nnull)then v(i,j) = v(i,j) + q(i-nnull,j-nnull) endif 23004 j=j+1 goto 23003 23005 continue 23001 i=i+1 goto 23000 23002 continue infowk = 0 i=1 23008 if(.not.(i.le.nn))goto 23010 infowk = infowk + jpvt(i) 23009 i=i+1 goto 23008 23010 continue call dchdc (v, nn, nn, wk, jpvt, 1, rkv) j = idamax (rkv-infowk, v(infowk+1,infowk+1), nn+1) 23011 if(v(rkv,rkv).lt.v(infowk+j,infowk+j)*dsqrt(mchpr))then rkv = rkv - 1 goto 23011 endif 23012 continue i=rkv+1 23013 if(.not.(i.le.nn))goto 23015 v(i,i) = v(j,j) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23014 i=i+1 goto 23013 23015 continue call dcopy (nn, mu, 1, dc, 1) call dprmut (dc, nn, jpvt, 0) call dtrsl (v, nn, nn, dc, 11, infowk) call dset (nn-rkv, 0.d0, dc(rkv+1), 1) call dtrsl (v, nn, nn, dc, 01, infowk) call dprmut (dc, nn, jpvt, 1) if(method.eq.4)then return endif i=1 23018 if(.not.(i.le.nobs))goto 23020 wk(i) = y(i) - ddot (nn, sr(i,1), nobs, dc, 1) 23019 i=i+1 goto 23018 23020 continue if(method.eq.5)then wk(nobs+1) = ddot (nobs, wk, 1, wk, 1) / dfloat (nobs) i=1 23023 if(.not.(i.le.nobs))goto 23025 call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) 23024 i=i+1 goto 23023 23025 continue return endif if(method.eq.3)then rss = ddot (nobs, y, 1, wk, 1) if(nnull.gt.0)then call dqrdc (sr, nobs, nobs, nnull, wk, idum, dum, 0) i=1 23030 if(.not.(i.le.nxi))goto 23032 call dqrsl (sr, nobs, nobs, nnull, wk, sr(1,nnull+i), dum, sr(1,nn *ull+i), dum, dum, dum, 01000, infowk) 23031 i=i+1 goto 23030 23032 continue endif call dcopy (nxi, q, nxi+1, wk, 1) i=1 23033 if(.not.(i.le.nxi))goto 23035 j=i 23036 if(.not.(j.le.nxi))goto 23038 q(i,j) = q(i,j) + ddot (nobs-nnull, sr(nnull+1,nnull+i), 1, sr(nnu *ll+1,nnull+j), 1) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue i=1 23039 if(.not.(i.le.nxi))goto 23041 j=i 23042 if(.not.(j.le.nxi))goto 23044 sr(i,j) = q(i,j) sr(j,i) = q(i,j) q(i,j) = q(j,i) 23043 j=j+1 goto 23042 23044 continue 23040 i=i+1 goto 23039 23041 continue call dcopy (nxi, wk, 1, q, nxi+1) call dsyev ('n', 'u', nxi, sr, nobs, mu, wk, 3*nxi, info) trc = 0.d0 i=1 23045 if(.not.(i.le.rkv-nnull))goto 23047 trc = trc + dlog (mu(nxi-i+1)) 23046 i=i+1 goto 23045 23047 continue call dsyev ('n', 'u', nxi, q, nxi, mu, wk, 3*nxi, info) i=1 23048 if(.not.(i.le.rkv-nnull))goto 23050 trc = trc - dlog (mu(nxi-i+1)) 23049 i=i+1 goto 23048 23050 continue score = rss / dfloat (nobs) * dexp (trc/dfloat(nobs-nnull)) varht = rss / dfloat (nobs-nnull) else rss = ddot (nobs, wk, 1, wk, 1) / dfloat (nobs) i=1 23051 if(.not.(i.le.nobs))goto 23053 call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) 23052 i=i+1 goto 23051 23053 continue trc = dasum (nobs, wk, 1) / dfloat (nobs) if(method.eq.2)then score = rss / (1.d0-alpha*trc)**2 varht = rss / (1.d0-trc) else score = rss + 2.d0 * varht * alpha * trc endif endif wk(1) = rss wk(2) = trc return end subroutine regaux (v, nn, jpvt, rkv, r, nr, sms, nnull, wk) double precision v(nn,*), r(nn,*), sms(nnull,*), wk(nn,*) integer nn, jpvt(*), rkv, nr, nnull double precision ddot integer i, j, infowk i=1 23056 if(.not.(i.le.nr))goto 23058 call dprmut (r(1,i), nn, jpvt, 0) call dtrsl (v, nn, nn, r(1,i), 11, infowk) if(nn-rkv.gt.0)then call dset (nn-rkv, 0.d0, r(rkv+1,i), 1) endif call dtrsl (v, nn, nn, r(1,i), 01, infowk) call dprmut (r(1,i), nn, jpvt, 1) 23057 i=i+1 goto 23056 23058 continue call dset (nn*nnull, 0.d0, wk, 1) call dset (nnull, 1.d0, wk, nn+1) i=1 23061 if(.not.(i.le.nnull))goto 23063 call dtrsl (v, nn, nn, wk(1,i), 11, infowk) 23062 i=i+1 goto 23061 23063 continue i=1 23064 if(.not.(i.le.nnull))goto 23066 j=i 23067 if(.not.(j.le.nnull))goto 23069 sms(i,j) = ddot (nn, wk(1,i), 1, wk(1,j), 1) sms(j,i) = sms(i,j) 23068 j=j+1 goto 23067 23069 continue 23065 i=i+1 goto 23064 23066 continue return end gss/src/dsidr0.f0000644000176200001440000000220313475771437013210 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine dsidr0 (vmu, s, lds, nobs, nnull, y, q, ldq, tol, job, *limnla, nlaht, score, varht, c, d, qraux, jpvt, wk, info) integer vmu integer lds, nobs, nnull, ldq, job, jpvt(*), info double precision s(lds,*), y(*), q(ldq,*), tol, limnla(2), nlaht, *score(*), varht, c(*), d(*), qraux(*), wk(*) character*1 vmu1 if( vmu .eq. 1 )then vmu1 = 'v' endif if( vmu .eq. 2 )then vmu1 = 'm' endif if( vmu .eq. 3 )then vmu1 = 'u' endif info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq )then info = -1 return endif call dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nobs, 1, *info, wk) if( info .ne. 0 )then return endif call dcore (vmu1, q, ldq, nobs, nnull, tol, y, job, limnla, nlaht, * score, varht, info, wk, wk(2*nobs+1)) if( info .ne. 0 )then return endif call dcoef (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nlaht, c, * d, info, wk) return end gss/src/dstup.f0000644000176200001440000000173513267111001013141 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldqr, ld *qc, nq, info, work) integer lds, nobs, nnull, jpvt(*), ldqr, ldqc, nq, info double precision s(lds,*), y(*), qraux(*), q(ldqr,ldqc,*), work(*) double precision dum integer j info = 0 if( nobs .lt. 1 .or. nobs .gt. lds .or. nobs .gt. ldqr .or. nobs . *gt. ldqc )then info = -1 return endif j=1 23002 if(.not.(j.le.nnull))goto 23004 jpvt(j) = 0 23003 j=j+1 goto 23002 23004 continue call dqrdc (s, lds, nobs, nnull, qraux, jpvt, work, 1) call dqrsl (s, lds, nobs, nnull, qraux, y, dum, y, work, dum, dum, * 01100, info) if( info .ne. 0 )then return endif j=1 23007 if(.not.(j.le.nq))goto 23009 call dqrslm (s, lds, nobs, nnull, qraux, q(1,1,j), ldqr, 0, info, *work) 23008 j=j+1 goto 23007 23009 continue return end gss/src/ratfor/0000755000176200001440000000000013475774004013145 5ustar liggesusersgss/src/ratfor/hzdnewton.r0000644000176200001440000001615512355360640015351 0ustar liggesusers #::::::::::::::: # hzdnewton #::::::::::::::: subroutine hzdnewton (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qdwt(nqd,*), prec, mchpr, wk(*) integer imrs, iwt, ifit, imu, imuwk, iv, ivwk, icdnew, iwtnew, ifitnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 2) ifit = iwt + nqd*nx imu = ifit + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis ifitnew = iwtnew + nqd*nx iwk = ifitnew + nt call hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), wk(iwtnew), wk(ifitnew), wk(iwk), info) return end #:::::::::::::::: # hzdnewton1 #:::::::::::::::: subroutine hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, mrs, wt, fit, mu, muwk, v, vwk, jpvt, cdnew, wtnew, fitnew, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qdwt(nqd,*), prec, mchpr, mrs(*), wt(nqd,*), fit(*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision tmp, ddot, fitmean, dasum, lkhd, mumax, lkhdnew, disc, disc0, trc # Calculate constants info = 0 for (i=1;i<=nxis;i=i+1) { mrs(i) = 0.d0 for (j=1;j<=nt;j=j+1) { if (cntsum==0) mrs(i) = mrs(i) + rs(i,j) else mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) } mrs(i) = mrs(i) / dfloat (nobs) } # Initialization for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) } fitmean = 0.d0 for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wt, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) { muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) } } call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) } if ((flag==1)|(flag==3)) break } if ((flag==0)|(flag==2)) { fitmean = 0.d0 for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if (tmp>3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wtnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nt;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nt, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # Work array: # twk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, UW-Madison, 5/4/88 at Yale. double precision dum, ddot integer n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # compute U ( T + n*lambdahat I )^{-1} z call dset (n, 10.d0 ** nlaht, twk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, twk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, twk(1,2), 2) call dpbfa (twk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } call dpbsl (twk, 2, n, 1, z(n0+1)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, twk, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, twk, z(n0+2), z(n0+2), dum,_ dum, dum, dum, 10000, info) # compute c call dset (n0, 0.d0, c, 1) call dcopy (n, z(n0+1), 1, c(n0+1), 1) call dqrsl (s, lds, nobs, nnull, qraux, c, c, dum, dum, dum, dum, 10000,_ info) # compute d for (j=1;j<=n0;j=j+1) { d(j) = z(j) - ddot (n, z(n0+1), 1, q(n0+1,j), 1) } call dtrsl (s, lds, n0, d, 01, info) call dprmut (d, n0, jpvt, 1) return end #............................................................................... gss/src/ratfor/dgold.r0000644000176200001440000000767712355360640014433 0ustar liggesusers #::::::::::: # dgold #::::::::::: subroutine dgold (vmu, q, ldq, n, z, low, upp, nlaht, score, varht,_ info, twk, work) # Purpose: To evaluate GCV/GML function based on tridiagonal form and to # search minimum on an interval by golden section search. character*1 vmu integer ldq, n, info double precision q(ldq,*), z(*), low, upp, nlaht, score, varht, twk(2,*),_ work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q tidiagonal matrix in diagonal and super diagonal. # ldq leading dimension of Q. # n size of the matrix. # z U^{T} F_{2}^{T} y. # low lower limit of log10(n*lambda). # upp upper limit of log10(n*lambda). # varht known variance if vmu=='u'. # On exit: # nlaht the estimated log(n*lambda). # score the GCV/GML/URE score at the estimated lambda. # varht the variance estimate at the estimated lambda. # info 0: normal termination. # -1: dimension error. # -2: tridiagonal form is not non-negative definite. # -3: vmu is none of 'v', 'm', or 'u'. # Work arrays: # twk of size at least (2,n). # work of size at least (n). # Routines called directly: # Fortran -- dsqrt # Blas -- daxpy, dcopy # Rkpack -- dtrev # Other -- dset # Written: Chong Gu, Statistics, Purdue, latest version 12/29/91. double precision ratio, mlo, mup, tmpl, tmpu ratio = ( dsqrt (5.d0) - 1.d0 ) / 2.d0 info = 0 # interchange the boundaries if necessary if ( upp < low ) { mlo = low low = upp upp = mlo } # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( n < 1 | n > ldq ) { info = -1 return } # initialize golden section search for scrht mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if ( info != 0 ) { info = -2 return } mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if ( info != 0 ) { info = -2 return } # golden section search for estimate of lambda repeat { if ( mup - mlo < 1.d-7 ) break if ( tmpl < tmpu ) { upp = mup mup = mlo tmpu = tmpl mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if ( info != 0 ) { info = -2 return } } else { low = mlo mlo = mup tmpl = tmpu mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if ( info != 0 ) { info = -2 return } } } # compute the return value nlaht = ( mup + mlo ) / 2.d0 call dset (n, 10.d0 ** (nlaht), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**nlaht call dtrev (vmu, twk, 2, n, z, score, varht, info, work) if ( info != 0 ) { info = -2 return } return end #............................................................................... gss/src/ratfor/dsytr.r0000644000176200001440000001013212355360640014463 0ustar liggesusers #::::::::::: # dsytr #::::::::::: subroutine dsytr (x, ldx, n, tol, info, work) # Acronym: Double-precision SYmmetric matrix TRidiagonalization. # Purpose: This routine performs the Householder tridiagonalization # algorithm on symmetric matrix `x', with truncation strategy as # described in Gu, Bates, Chen, and Wahba (1988). # References: 1. Golud and Van Loan (1983) Matrix Computation. (pp.276-7) # 2. Gu, Bates, Chen, and Wahba(1988), TR#823, Stat, UW-M. # 3. Dongarra et al.(1979) LINPACK User's Guide. (Chap. 9) # Relation with LINPACK: This routine computes the tridiagonalization # U^{T}XU=T, where X is symmetric, T is tridiagonal, and U is an # orthogonal matrix as the product of Housholder matrices. To compute # U^{T}y or Uy for vector y, we can use routine `dqrsl' of LINPACK. # The calling procedure is: # # 1. Create vector `qraux' by # call dcopy(n-2, x(2,1), ldx+1, qraux, 1) # 2. Call `dqrsl' as # call dqrsl (x(2,1), ldx, n-1, n-2, qraux, y(2), ... ) integer ldx, n, info double precision x(ldx,*), tol, work(*) # On entry: # x symmetric matrix, only LOWER triangle refered. # ldx leading dimension of x. # n size of matrix `x'. # tol truncation tolarence; if zero, set to square machine # precision. # On Exit: # x diagonal: diagonal elements of tridiag. transf. # upper triangle: off-diagonal of tridiag. transf. # lower triangle: overwritten by Householder factors. # info 0 : normal termination. # -1 : dimension error. # Work array: # work of size at least (n). # Routines called directly: # Fortran -- dfloat, dsqrt # Blas -- daxpy, ddot, dscal # Blas2 -- dsymv, dsyr2 # Written: Chong Gu, Statistics, UW-Madison, latest version 8/29/88. double precision nrmtot, nrmxj, alph, toltot, tolcum, toluni, dn, ddot integer j info = 0 # check dimension if ( ldx < n | n <= 2 ) { info = -1 return } # total Frobenius norm nrmtot = ddot (n, x, ldx+1, x, ldx+1) for ( j=1 ; j 1.d0 ) toltot = toltot / 2.d0 toltot = 4.d0 * toltot ** 2 # set truncation criterion if ( toltot < tol ) toltot = tol toltot = toltot * nrmtot dn = dfloat (n) toluni = toltot * 6.d0 / dn / ( dn - 1.d0 ) / ( 2.d0 * dn - 1.d0 ) # initialization tolcum = 0.d0 # main process for ( j=1 ; j= 1 & j <= k ) { if ( qraux(j) == 0.0d0 ) { j = j + step next } tmp = x(j,j) x(j,j) = qraux(j) # update the columns 1 thru j-1 for (i=1;i3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) if (cntsum!=0) wtnew(i) = wtnew(i) * dfloat (cnt(i)) } wtsumnew = dasum (nobs, wtnew, 1) lkhdnew = dlog (wtsumnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsumnew, wtnew, 1) # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) if (cntsum!=0) { for (i=1;i<=nobs;i=i+1) wt(i) = dfloat (cnt(i)) } else call dset (nobs, 1.d0, wt, 1) wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) lkhd = lkhdnew # Check convergence if (disc00: rank(S)+1. # Work array: # work of size at least (nobs). # Routines called directly: # Linpack -- dqrdc, dqrsl # Rkpack -- dqrslm # Written: Chong Gu, Statistics, Purdue, latest version 3/7/91. double precision dum integer j info = 0 # check dimension if ( nobs < 1 | nobs > lds | nobs > ldqr | nobs > ldqc ) { info = -1 return } # QR decomposition of S=FR # The indented line below is added on Mar 7, 1991, # with credit to Dick Franke for (j=1;j<=nnull;j=j+1) jpvt(j) = 0 call dqrdc (s, lds, nobs, nnull, qraux, jpvt, work, 1) # F^{T} y; test rank of R call dqrsl (s, lds, nobs, nnull, qraux, y, dum, y, work, dum, dum, 01100,_ info) if ( info != 0 ) return # F^{T} Q_{*} F for (j=1;j<=nq;j=j+1) { call dqrslm (s, lds, nobs, nnull, qraux, q(1,1,j), ldqr, 0, info,_ work) } return end #............................................................................... gss/src/ratfor/deval.r0000644000176200001440000000524612355360640014423 0ustar liggesusers #::::::::::: # deval #::::::::::: subroutine deval (vmu, q, ldq, n, z, nint, low, upp, nlaht, score, varht,_ info, twk, work) # Purpose: To evaluate GCV/GML function based on tridiagonal form and to # search minimum on an interval by equally spaced (in log10 scale) grid # search. character*1 vmu integer ldq, n, nint, info double precision q(ldq,*), z(*), low, upp, nlaht, score(*), varht,_ twk(2,*), work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q tidiagonal matrix in diagonal and super diagonal. # ldq leading dimension of Q. # n size of the matrix. # z U^{T} F_{2}^{T} y. # nint number of intervals (number of grids minus 1). # low lower limit of log10(n*lambda). # upp upper limit of log10(n*lambda). # varht known variance if vmu=='u'. # On exit: # nlaht the estimated log10(n*lambda). # score the GCV/GML/URE score vector on grid points. # varht the variance estimate at the estimated n*lambda. # info 0: normal termination. # -1: dimension error. # -2: tridiagonal form is not non-negative definite. # -3: vmu or nint is out of scope. # Work arrays: # twk array of length at least (2,n). # work array of length at least (n). # Routines called directly: # Fortran -- dfloat # Blas -- daxpy, dcopy # Rkpack -- dtrev # Other -- dset # Written: Chong Gu, Statistics, Purdue, 12/29/91 latest version. double precision tmp, minscr, mlo, varhtwk integer j info = 0 # interchange boundaries if necessary if ( upp < low ) { mlo = low low = upp upp = mlo } # check job requests if ( (vmu != 'v' & vmu != 'm' & vmu != 'u') | nint < 1 ) { info = -3 return } # check dimension if ( 1 > n | n > ldq ) { info = -1 return } # evaluation for (j=1;j<=nint+1;j=j+1) { tmp = low + dfloat (j-1) * ( upp - low ) / dfloat (nint) call dset (n, 10.d0 ** (tmp), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**tmp call dtrev (vmu, twk, 2, n, z, score(j), varht, info, work) if ( info != 0 ) { info = -2 return } if ( score(j) <= minscr | j == 1 ) { minscr = score(j) nlaht = tmp varhtwk = varht } } varht = varhtwk return end #............................................................................... gss/src/ratfor/dcrdr.r0000644000176200001440000000660412355360640014425 0ustar liggesusers #::::::::::: # dcrdr #::::::::::: subroutine dcrdr (s, lds, nobs, nnull, qraux, jpvt, q, ldq, nlaht,_ r, ldr, nr, cr, ldcr, dr, lddr, wk, info) # Purpose: To compute auxiliary quantities cr and dr for posterior covariance # Usage: Use s, qraux, jpvt, q, and nlaht returned by dsidr. integer lds, nobs, nnull, jpvt(*), ldq, ldr, nr, ldcr, lddr, info double precision s(lds,*), qraux(*), q(ldq,*), nlaht, r(ldr,*), cr(ldcr,*),_ dr(lddr,*), wk(2,*) # On entry: # s,qraux,jpvt # QR-decomposition of S = F R. # nobs number of observations. # nnull dimension of null space. # q U^{T} F_{2}^{T} Q F_{2} U in BOTTOM-RIGHT corner's # LOWER triangle and SUPER DIAGONAL; # F_{2}^{T} Q F_{1} in BOTTOM-LEFT corner; # ldq leading dimension of q. # nlaht estimated log10(n*lambda). # r R(t,s^{T}). # nr length of s. # On exit: # cr (M^{-1}-M^{-1}S(S^{T}M^{-1}S)^{-1}S^{T}M^{-1})R(t,s^{T}) # dr (S^{T}M^{-1}S)^{-1}S^{T}M^{-1}R(t,s^{T}) # info 0: normal termination. # >0: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # others intact. # Work array: # wk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, 2/27/96 at Ann Arbor. double precision dum, ddot integer i, j, n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq | ldr < nobs |_ nr < 1 | ldcr < nobs | lddr < nnull ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # copy r to cr for (j=1;j<=nr;j=j+1) call dcopy (nobs, r(1,j), 1, cr(1,j), 1) # compute diag(I, U^{T}) F^{T} R(t,s^{T}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=nr;j=j+1) { call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), dum, cr(1,j), dum,_ dum, dum, 01000, info) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), dum, cr(n0+2,j), dum, dum, dum, 01000, info) } # compute U ( T + n*lambdahat I )^{-1} diag(I, U^{T}) F^{T} R(t,s^{T}) call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } for (j=1;j<=nr;j=j+1) call dpbsl (wk, 2, n, 1, cr(n0+1,j)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=nr;j=j+1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), cr(n0+2,j),_ dum, dum, dum, dum, 10000, info) # compute dr for (j=1;j<=nr;j=j+1) { for (i=1;i<=n0;i=i+1) dr(i,j) = cr(i,j) - ddot (n, cr(n0+1,j), 1, q(n0+1,i), 1) call dtrsl (s, lds, n0, dr(1,j), 01, info) call dprmut (dr(1,j), n0, jpvt, 1) } # compute cr for (j=1;j<=nr;j=j+1) { call dset (n0, 0.d0, cr(1,j), 1) call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), cr(1,j),_ dum, dum, dum, dum, 10000, info) } return end #.............................................................................. gss/src/ratfor/dmudr1.r0000644000176200001440000002510012355360640014513 0ustar liggesusers#::::::::::: # dmudr1 #::::::::::: subroutine dmudr1 (vmu,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs qraux, jpvt, twk, traux, qwk, ywk, thewk,_ # work arrays hes, gra, hwk1, hwk2, gwk1, gwk2, pvtwk,_ kwk, work1, work2,_ info) # Acronym: Double precision MUltiple smoothing parameter DRiver. # Purpose: This routine implements the iterative algorithm for minimizing # GCV/GML scores with multiple smoothing parameters described in # Gu and Wahba(1988, Minimizing GCV/GML scores with multiple smoothing # parameters via the Newton method). # WARNING: Please be sure that you understand what this routine does before # you call it. Pilot runs with small problems are recommended. This # routine performs VERY INTENSIVE numerical calculations for big nobs. integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite,_ jpvt(*), pvtwk(*), info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec,_ theta(*), nlaht, score, varht, c(*), d(*),_ qraux(*), traux(*), twk(2,*), qwk(ldqr,*), ywk(*),_ thewk(*), hes(nq,*), gra(*), hwk1(nq,*), hwk2(nq,*),_ gwk1(*), gwk2(*), kwk(nobs-nnull,nobs-nnull,*),_ work1(*), work2(*) character*1 vmu # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # s the matrix S, of size (lds,nnull). # nobs the number of observations. # nnull the dimension of the null space. # q the matrices Q_{i}'s, of dimension (ldqr,ldqc,nq). # nq the number of Q_{i}'s. # y the response vector of size (nobs) # tol the tolerance for truncation in the tridiagonalization. # init 0 : No initial values provided for the theta. # 1 : Initial values provided for the theta. # theta initial values of theta if init = 1. # prec precision requested for the minimum score value. # maxite maximum number of iterations allowed. # varht known variance if vmu=='u'. # On exit: # theta the vector of parameter log10(theta) used in the final model, # of dimension (nq). -25 indicates effective minus infinity. # nlaht the estimated log10(n*lambda)|theta in the final model. # score the minimum GCV/GML/URE score found at (theta, nlaht). # varht the variance estimate. # c,d the coefficients estimates. # info 0 : normal termination. # -1 : dimension error. # -2 : F_{2}^{T} Q_{*}^{theta} F_{2} !>= 0. # -3 : tuning parameters are out of scope. # -4 : fails to converge within maxite steps. # -5 : fails to find a reasonable descent direction. # >0 : the matrix S is rank deficient: rank(S)+1. # Work arrays: # qraux of size at least (nnull). # jpvt of size at least (nnull). # twk of size at least (2,nobs-nnull). # traux of size at least (nobs-nnull-2). # qwk of size at least (nobs,nobs). # ywk of size at least (nobs). # thewk of size at least (nq). # hes of size at least (nq,nq). # gra of size at least (nq). # hwk1-2 of sizes at least (nq,nq). # gwk1-2 of sizes at least (nq). # pvtwk of size at least (nq). # kwk of size at least (nobs-nnull,nobs-nnull,nq). # work1-2 of sizes at least (nobs). # Routines called directly: # Blas -- dasum, daxpy, dcopy, ddot, dscal, idamax # Blas2 -- dsymv # Fortran -- dfloat, dlog, dlog10 # Linpack -- dpofa, dposl, sqrsl # Rkpack -- dcoef, dcore, ddeev, dmcdc, dstup # Other -- dprmut, dset # Routines called indirectly: # Blas -- dasum, daxpy, dcopy, ddot, dnrm2, dscal, dswap, idamax # Blas2 -- dgemv, dsymv, dsyr2 # Fortran -- dabs, dexp, dfloat, dlog, dlog10, dsqrt # Linpack -- dpbfa, dpbsl, dqrdc, dqrsl, dtrsl # Rkpack -- deval, dgold, dqrslm, dsytr, dtrev # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 1/6/92. double precision alph, scrold, scrwk, nlawk, limnla(2),_ tmp, dasum, ddot integer n, n0, i, j, iwk, maxitwk, idamax, job info = 0 # set working parameters n0 = nnull n = nobs - nnull maxitwk = maxite # check tuning parameters if ( (vmu != 'v' & vmu != 'm' & vmu != 'u') | (init != 0 & init != 1) |_ (maxitwk <=0) | (prec <= 0.d0) ) { info = -3 return } # check dimension if ( lds < nobs | nobs <= n0 | n0 < 1 | ldqr < nobs | ldqc < nobs |_ nq <= 0 ) { info = -1 return } # initialize call dstup (s, lds, nobs, n0, qraux, jpvt, y, q, ldqr, ldqc, nq, info,_ work1) if ( info != 0 ) return if ( init == 1 ) call dcopy (nq, theta, 1, thewk, 1) else { # use the "plug-in" weights as the starting theta for (i=1;i<=nq;i=i+1) { thewk(i) = dasum (n, q(n0+1,n0+1,i), ldqr+1) if ( thewk(i) > 0.d0 ) thewk(i) = 1.d0 / thewk(i) } # fit an initial model for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, thewk(i), q(j,j,i), 1, qwk(j,j), 1) } call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, 0, limnla, nlawk,_ scrwk, varht, info, twk, work1) if (info != 0 ) return call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlawk,_ c, d, info, twk) # assign weights due to norm \theta^{2}c^{T}(Q_{i})c call dqrsl (s, lds, nobs, n0, qraux, c, tmp, c, tmp, tmp, tmp,_ 01000, info) for (i=1;i<=nq;i=i+1) { call dsymv('l', n, thewk(i), q(n0+1,n0+1,i), ldqr, c(n0+1), 1,_ 0.d0, work1, 1) thewk(i) = ddot (n, c(n0+1), 1, work1, 1) * thewk(i) if ( thewk(i) > 0.d0 ) thewk(i) = dlog10 (thewk(i)) else thewk(i) = -25.d0 } } scrold = 1.d10 # main process job = 0 repeat { # nq == 1 if ( nq == 1 ) { theta(1) = 0.d0 break } # form Qwk = \sum_{i=1}^{nq} \thewk_{i} Q_{i} for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, 10.d0 ** thewk(i), q(j,j,i), 1,_ qwk(j,j), 1) } # main calculation call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlawk,_ scrwk, varht, info, twk, work1) if (info != 0 ) return # half the increment if no gain if ( scrold < scrwk ) { # algorithm halts tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if ( alph * tmp > - prec ) { info = -5 return } alph = alph / 2.d0 for (i=1;i<=nq;i=i+1) thewk(i) = theta(i) + alph * gwk1(i) next } # count for one iteration maxitwk = maxitwk - 1 # compute the gradient and the Hessian call dcopy (n-2, qwk(n0+2,n0+1), ldqr+1, traux, 1) call dcopy (n, qwk(n0+1,n0+1), ldqr+1, twk(2,1), 2) call dcopy (n-1, qwk(n0+1,n0+2), ldqr+1, twk(1,2), 2) call ddeev (vmu, nobs,_ q(n0+1,n0+1,1), ldqr, ldqc, n, nq, qwk(n0+2,n0+1),_ ldqr, traux, twk, ywk(n0+1),_ thewk, nlawk, scrwk, varht,_ # inputs hes, nq, gra,_ # outputs hwk1, hwk2, gwk1, gwk2,_ kwk, n, work1, work2, c,_ info) # get the active subset iwk = 0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next iwk = iwk + 1 call dcopy (nq, hes(1,i), 1, hes(1,iwk), 1) } iwk = 0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next iwk = iwk + 1 call dcopy (nq, hes(i,1), nq, hes(iwk,1), nq) gwk1(iwk) = gra(i) work2(iwk) = gra(i) } # compute the Newton direction for (i=1;i=1;i=i-1) { if ( thewk(i) <= -25.0 ) gwk1(i) = 0.d0 else { gwk1(i) = gwk1(iwk) iwk = iwk - 1 } } call dscal (nq, 1.d0/dlog(1.d1), gwk1, 1) tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if ( tmp > 1.d0 ) call dscal (nq, 1.d0/tmp, gwk1, 1) # set thewk such that nlawk = 0.d0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next thewk(i) = thewk(i) - nlawk } call dcopy (nq, thewk, 1, theta, 1) # check convergence tmp = gra(idamax (nq, gra, 1)) ** 2 if ( tmp < prec ** 2_ # zero gradient | scrold - scrwk < prec * (scrwk + 1.d0)_ # small change & tmp < prec * (scrwk + 1.d0) ** 2 ) { # small gradient break } # fail to converge if ( maxitwk < 1 ) { info = -4 return } # update records scrold = scrwk # increment thewk for (i=1;i<=nq;i=i+1) thewk(i) = thewk(i) + alph * gwk1(i) job = -1 limnla(1) = -1.d0 limnla(2) = 1.d0 } # the end of the main loop # compute the model to be returned for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { if ( theta(i) <= -25.d0 ) next for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, 10.d0 ** theta(i), q(j,j,i), 1,_ qwk(j,j), 1) } call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlaht,_ score, varht, info, twk, work1) if (info != 0 ) return call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlaht,_ c, d, info, twk) return end #.................................................................................... gss/src/ratfor/dnewton10.r0000644000176200001440000001424712355360640015150 0ustar liggesusers #::::::::::::::: # dnewton10 #::::::::::::::: subroutine dnewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew), wk(iwtnew), wk(iwk), info) return end #:::::::::::::::: # dnewton101 #:::::::::::::::: subroutine dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision wtsum, tmp, ddot, lkhd, mumax, wtsumnew, lkhdnew, disc, disc0 # Initialization info = 0 wtsum = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if (cntsum!=0) wt(i) = wt(i) * dfloat (cnt(i)) wtsum = wtsum + wt(i) } if (cntsum==0) lkhd = wtsum / dfloat (nobs) else lkhd = wtsum / dfloat (cntsum) lkhd = dlog (lkhd) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient for (i=1;i<=nxis;i=i+1) mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) / wtsum for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nobs;k=k+1) v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) v(i,j) = v(i,j) / wtsum - mu(i) * mu(j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) if (cntsum!=0) wtnew(i) = wtnew(i) * dfloat (cnt(i)) wtsumnew = wtsumnew + wtnew(i) } if (cntsum==0) lkhdnew = wtsumnew / dfloat (nobs) else lkhdnew = wtsumnew / dfloat (cntsum) lkhdnew = dlog (lkhdnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 for (i=1;i<=nobs;i=i+1) { if (cntsum!=0) wt(i) = dfloat (cnt(i)) else wt(i) = 1.d0 wtsum = wtsum + wt(i) } lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) wtsum = wtsumnew lkhd = lkhdnew # Check convergence if (disc03.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * cnt(i) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (kk=1;kk<=nx;kk=kk+1) call dcopy (nqd, qdwt, 1, wt(1,kk), 1) tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + qdwt(i) call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc0 1.d0 ) tmp = tmp / 2.d0 jmax = idamax (p, a, lda+1) beta = dmax1 (2.d0 * tmp, dabs (a(jmax,jmax))) tmp = dsqrt (dfloat (p*p-1)) if ( tmp < 1.d0 ) tmp = 1.d0 for (j=2;j<=p;j=j+1) { jmax = idamax (j-1, a(1,j), 1) beta = dmax1 (beta, dabs (a(jmax,j)) / tmp) } delta = dasum (p, a, lda+1) / dfloat (p) * 1.d-7 delta = dmax1 (delta, 1.d-10) for (j=1;j<=p;j=j+1) jpvt(j) = j # compute P^{T}AP + E = LDL^{T} for (j=1;j<=p;j=j+1) { # pivoting jmax = idamax (p-j+1, a(j,j), lda+1) + j - 1 if ( jmax != j ) { call dswap (j-1, a(1,j), 1, a(1,jmax), 1) call dswap (jmax-j-1, a(j,j+1), lda, a(j+1,jmax), 1) call dswap (p-jmax, a(j,jmax+1), lda, a(jmax,jmax+1), lda) tmp = a(j,j) a(j,j) = a(jmax,jmax) a(jmax,jmax) = tmp jtmp = jpvt(j) jpvt(j) = jpvt(jmax) jpvt(jmax) = jtmp } # compute j-th column of L^{T} for (i=1;i3.d2) { flag = flag + 1 break } for (m=1;m<=nt;m=m+1) { wtnew(m,i) = qdwt(m,i) * dexp (tmp) wtnewsum(m) = wtnewsum(m) + wtnew(m,i) } } rklnew = 0.d0 for (m=1;m<=nt;m=m+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) { disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wtnew(m,i)) * disc } rklnew = rklnew + bwt(m) * (tmp + dlog (wtnewsum(m))) } if (flag==1) { # Reset iteration with uniform starting value call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) for (m=1;m<=nt;m=m+1) { for (i=1;i<=nqd;i=i+1) wtsum(m) = wtsum(m) + wt(m,i) } rkl = 0.d0 for (m=1;m<=nt;m=m+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) } iter = 0 break } if (rklnew-rkl<1.d1*(1.d0+dabs(rkl))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nqd;i=i+1){ for (m=1;m<=nt;m=m+1) disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) } disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc = dmax1 (disc, dabs(rkl-rklnew)/(1.d0+dabs(rkl))) # Check convergence if (disc3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) * rho(i) if (cntsum!=0) wtnew(i) = wtnew(i) * dfloat (cnt(i)) } call dscal (nt, 1/dfloat(nobs), wtnew, 1) lkhdnew = dasum(nt, wtnew, 1) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (i=1;i<=nt;i=i+1) { wt(i) = rho(i) if (cntsum!=0) wt(i) = wt(i) * dfloat (cnt(i)) } call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nt;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt, wtnew, 1, wt, 1) lkhd = lkhdnew # Check convergence if (disc03.d2) { flag = flag + 1 break } tmp = dexp (tmp) for (m=1;m<=nt;m=m+1) { wtnew(m,i) = qdwt(m,i) * tmp wtsumnew(m) = wtsumnew(m) + wtnew(m,i) } } norm = 0.d0 for (m=1;m<=nt;m=m+1) norm = norm + bwt(m) * dlog (wtsumnew(m)) if ((flag==0)|(flag==2)) { fitmean = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if (tmp>3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } if (cntsum==0) fitmean = fitmean / dfloat (nobs) else fitmean = fitmean / dfloat (cntsum) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 for (m=1;m<=nt;m=m+1) { wtsum(m) = 0.d0 for (i=1;i<=nqd;i=i+1) wtsum(m) = wtsum(m) + wt(m,i) lkhd = lkhd + bwt(m) * dlog (wtsum(m)) } call dset (nobs, 1.d0, fit, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nqd;i=i+1) { for (m=1;m<=nt;m=m+1) disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nt, wtnew, 1, wt, 1) call dcopy (nt, wtsumnew, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00) call dset (nxis-rkv, 0.d0, rs(rkv+1,i), 1) } trc = ddot (nobs*nxis, rs, 1, rs, 1) if (cntsum==0) { trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + dlog (fit(i)) lkhd = lkhd / dfloat (nobs) } else { trc = trc / dfloat(cntsum) / (dfloat(cntsum)-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + dfloat (cnt(i)) * dlog (fit(i)) lkhd = lkhd / dfloat (cntsum) } for (m=1;m<=nt;m=m+1) lkhd = lkhd - bwt(m) * dlog (wtsum(m)) mrs(1) = lkhd mrs(2) = trc return end gss/src/ratfor/dmudr0.r0000644000176200001440000000326013475770723014530 0ustar liggesuserssubroutine dmudr0 (vmu,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs iwk, wk, info) integer vmu integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite,_ info, iwk(*) double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec,_ theta(*), nlaht, score, varht, c(*), d(*),_ wk(*) character*1 vmu1 integer n, n0 integer iqraux, itraux, itwk, iqwk, iywk, ithewk, ihes, igra, ihwk1, ihwk2,_ igwk1, igwk2, ikwk, iwork1, iwork2, ijpvt, ipvtwk if ( vmu == 1 ) vmu1 = 'v' if ( vmu == 2 ) vmu1 = 'm' if ( vmu == 3 ) vmu1 = 'u' n = nobs n0 = nnull iqraux = 1 itraux = iqraux + n0 itwk = itraux + (n-n0-2) iqwk = itwk + 2 * (n-n0) iywk = iqwk + n * n ithewk = iywk + n ihes = ithewk + nq igra = ihes + nq * nq ihwk1 = igra + nq ihwk2 = ihwk1 + nq * nq igwk1 = ihwk2 + nq * nq igwk2 = igwk1 + nq ikwk = igwk2 + nq iwork1 = ikwk + (n-n0) * (n-n0) * nq iwork2 = iwork1 + n ijpvt = 1 ipvtwk = ijpvt + n0 call dmudr1 (vmu1,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs wk(iqraux), iwk(ijpvt), wk(itwk), wk(itraux), wk(iqwk),_ wk(iywk), wk(ithewk), wk(ihes), wk(igra), wk(ihwk1),_ wk(ihwk2), wk(igwk1), wk(igwk2), iwk(ipvtwk), wk(ikwk),_ wk(iwork1), wk(iwork2),_ info) return end gss/src/ratfor/dsidr0.r0000644000176200001440000000227513475771432014525 0ustar liggesuserssubroutine dsidr0 (vmu,_ s, lds, nobs, nnull, y, q, ldq,_ # data tol, job, limnla,_ # job requests nlaht, score, varht, c, d,_ # output qraux, jpvt, wk,_ # work arrays info) # error message integer vmu integer lds, nobs, nnull, ldq, job, jpvt(*), info double precision s(lds,*), y(*), q(ldq,*), tol, limnla(2), nlaht, score(*),_ varht, c(*), d(*), qraux(*), wk(*) character*1 vmu1 if ( vmu == 1 ) vmu1 = 'v' if ( vmu == 2 ) vmu1 = 'm' if ( vmu == 3 ) vmu1 = 'u' info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq ) { info = -1 return } # main process call dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nobs, 1, info,_ wk) if ( info != 0 ) return call dcore (vmu1, q, ldq, nobs, nnull, tol, y, job, limnla, nlaht, score,_ varht, info, wk, wk(2*nobs+1)) if ( info != 0 ) return call dcoef (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nlaht, c, d,_ info, wk) return end gss/src/ratfor/dcore.r0000644000176200001440000001051412355360640014416 0ustar liggesusers #::::::::::: # dcore #::::::::::: subroutine dcore (vmu, q, ldq, nobs, nnull, tol, z, job, limnla, nlaht,_ score, varht, info, twk, work) # Purpose: To evaluate the GCV/GML score function at various trial values # of n*lambda using the tridiagonalization GCV/GML algorithm. Perform # either golden section search or regular grid search for minimizing # n*lambda. character*1 vmu integer ldq, nobs, nnull, job, info double precision q(ldq,*), tol, z(*), limnla(2), nlaht, score(*), varht,_ twk(2,*), work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q F^{T} Q F, only refer the LOWER triangle of the BOTTOM- # RIGHT corner, i.e., F_{2}^{T} Q F_{2}. # ldq leading dimension of Q. # nobs number of observations. # nnull dimension of null space. # tol tolerance of truncation. # z F^{T} y. # job 0: searching interval for nlaht chosen automatically. # -1: searching interval for nlaht provided by limnla. # >0: search regular grid points on [limnla(1),limnla(2)]: # #(grids) = job + 1. # limnla searching interval in log10 scale, see job. # varht known variance if vmu=='u'. # On exit: # q tridiagonal form in diagonal and superdiagonal of the # corner, Householder factors in strict lower triangle of # the corner. # z diag(I, U^{T}) F^{T} y. # limnla see limnla of entry. # nlaht the estimated log10(n*lambda). # score job <= 0 : the GCV/GML/URE score at nlaht. # job > 0 : the GCV/GML/URE score at the regular grid points. # varht variance estimate. # info 0 : normal termination. # -1 : dimension error. # -2 : F_{2}^{T}QF_{2} is not non-negative definite. # -3 : vmu is none of 'v', 'm', or 'u'. # Work arrays: # twk of size at least (2,nobs-nnull). # work of size at least (nobs-nnull). # Routines called directly: # Fortran -- dfloat, dlog10 # Blas -- dasum, dcopy # Linpack -- dqrsl # Rkpack -- deval, dgold, dsytr # Written: Chong Gu, Statistics, Purdue, latest version 3/24/92. double precision dum, low, upp, dasum, mchpr integer n0, n, j info = 0 # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( nnull < 1 | nobs <= nnull | nobs > ldq ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # tridiagonalization U^{T} ( F_{2}^{T} Q F_{2} ) U = T call dsytr (q(n0+1,n0+1), ldq, n, tol, info, work) if ( info != 0 ) return # U^{T} z_{2} call dcopy (n-2, q(n0+2,n0+1), ldq+1, work, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, work, z(n0+2), dum, z(n0+2),_ dum, dum, dum, 01000, info) # set searching range if ( job == 0 ) { mchpr = 1.d0 while ( 1.d0 + mchpr > 1.d0 ) mchpr = mchpr / 2.d0 mchpr = mchpr * 2.d0 limnla(2) = dmax1 (dasum (n, q(n0+1,n0+1), ldq+1) * 1.d2, mchpr) limnla(1) = limnla(2) * mchpr limnla(2) = dlog10 (limnla(2)) limnla(1) = dlog10 (limnla(1)) } low = limnla(1) upp = limnla(2) if ( job <= 0 ) { # compute score and estimate nlaht thru golden-section search call dgold (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), low, upp, nlaht,_ score(1), varht, info, twk, work) if ( vmu == 'v' ) score(1) = score(1) * dfloat (nobs) / dfloat (n) if ( vmu == 'm' ) score(1) = score(1) * dfloat (n) / dfloat (nobs) if ( vmu == 'u' ) score(1) = score(1) * dfloat (n) / dfloat (nobs) + 2.d0 * varht } else { # regular grid evaluation call deval (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), job, low, upp, nlaht,_ score, varht, info, twk, work) dum = dfloat (nobs) / dfloat (n) for (j=1;j<=job+1;j=j+1) { if ( vmu == 'v' ) score(j) = score(j) * dum if ( vmu == 'm' ) score(j) = score(j) / dum if ( vmu == 'u' ) score(j) = score(j) / dum + 2.d0 * varht } } return end #............................................................................... gss/src/ratfor/dsms.r0000644000176200001440000000676312355360640014303 0ustar liggesusers #::::::::::: # dsms #::::::::::: subroutine dsms (s, lds, nobs, nnull, jpvt, q, ldq, nlaht,_ sms, ldsms, wk, info) # Purpose: To compute the auxiliary quantity sms for posterior covariance # Usage: Use s, qraux, jpvt, q, and nlaht returned by dsidr. integer lds, nobs, nnull, jpvt(*), ldq, ldsms, info double precision s(lds,*), q(ldq,*), nlaht, sms(ldsms,*), wk(2,*) # On entry: # s,jpvt QR-decomposition of S = F R. # nobs number of observations. # nnull dimension of null space. # q U^{T} F_{2}^{T} Q F_{2} U in BOTTOM-RIGHT corner's # LOWER triangle and SUPER DIAGONAL; # F_{2}^{T} Q F_{1} in BOTTOM-LEFT corner; # F_{1}^{T} Q F_{1} in UPPER-LEFT corner's LOWER triangle. # ldq leading dimension of q. # nlaht estimated log10(n*lambda). # On exit: # sms (S^{T}M^{-1}S)^{-1}. # info 0: normal termination. # >0: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # inputs intact but UPPER-RIGHT corner of q was used as work array. # Work array: # wk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 4/17/92. double precision dum, ddot integer i, j, n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq | ldsms < nnull ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # compute sms # U^{T} (F_{2}^{T} Q F_{1}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=n0;j=j+1) { call dcopy (n, q(n0+1,j), 1, q(j,n0+1), ldq) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), dum, q(n0+2,j), dum, dum, dum, 01000, info) } # U^{T} (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } for (j=1;j<=n0;j=j+1) call dpbsl (wk, 2, n, 1, q(n0+1,j)) # (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=n0;j=j+1) { call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), q(n0+2,j),_ dum, dum, dum, dum, 10000, info) } # (F_{1}^{T}QF_{1} + n lambda I) - # (F_{1}^{T}QF_{2}^{T}) (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) for (i=1;i<=n0;i=i+1) { for (j=1;j3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (kk=1;kk<=nx;kk=kk+1) call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc0nnull) v(i,j) = v(i,j) + q(i-nnull,j-nnull) } } # Cholesky decomposition infowk = 0 for (i=1;i<=nn;i=i+1) infowk = infowk + jpvt(i) call dchdc (v, nn, nn, wk, jpvt, 1, rkv) j = idamax (rkv-infowk, v(infowk+1,infowk+1), nn+1) while (v(rkv,rkv)0) { call dqrdc (sr, nobs, nobs, nnull, wk, idum, dum, 0) for (i=1;i<=nxi;i=i+1) { call dqrsl (sr, nobs, nobs, nnull, wk, sr(1,nnull+i), dum, sr(1,nnull+i), dum, dum, dum, 01000, infowk) } } call dcopy (nxi, q, nxi+1, wk, 1) for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) q(i,j) = q(i,j) + ddot (nobs-nnull, sr(nnull+1,nnull+i), 1, sr(nnull+1,nnull+j), 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) { sr(i,j) = q(i,j) sr(j,i) = q(i,j) q(i,j) = q(j,i) } } call dcopy (nxi, wk, 1, q, nxi+1) # call rs (nobs, nxi, sr, mu, 0, dum, wk, y, info) call dsyev ('n', 'u', nxi, sr, nobs, mu, wk, 3*nxi, info) trc = 0.d0 for (i=1;i<=rkv-nnull;i=i+1) trc = trc + dlog (mu(nxi-i+1)) # call rs (nxi, nxi, q, mu, 0, dum, wk, y, info) call dsyev ('n', 'u', nxi, q, nxi, mu, wk, 3*nxi, info) for (i=1;i<=rkv-nnull;i=i+1) trc = trc - dlog (mu(nxi-i+1)) # return values score = rss / dfloat (nobs) * dexp (trc/dfloat(nobs-nnull)) varht = rss / dfloat (nobs-nnull) } else { # GCV or Cp rss = ddot (nobs, wk, 1, wk, 1) / dfloat (nobs) # trace for (i=1;i<=nobs;i=i+1) { call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) } trc = dasum (nobs, wk, 1) / dfloat (nobs) # return values if (method==2) { score = rss / (1.d0-alpha*trc)**2 varht = rss / (1.d0-trc) } else score = rss + 2.d0 * varht * alpha * trc } wk(1) = rss wk(2) = trc return end #:::::::::::: # regaux #:::::::::::: subroutine regaux (v, nn, jpvt, rkv, r, nr, sms, nnull, wk) double precision v(nn,*), r(nn,*), sms(nnull,*), wk(nn,*) integer nn, jpvt(*), rkv, nr, nnull double precision ddot integer i, j, infowk # drcr for (i=1;i<=nr;i=i+1) { call dprmut (r(1,i), nn, jpvt, 0) call dtrsl (v, nn, nn, r(1,i), 11, infowk) if (nn-rkv>0) call dset (nn-rkv, 0.d0, r(rkv+1,i), 1) call dtrsl (v, nn, nn, r(1,i), 01, infowk) call dprmut (r(1,i), nn, jpvt, 1) } # sms call dset (nn*nnull, 0.d0, wk, 1) call dset (nnull, 1.d0, wk, nn+1) for (i=1;i<=nnull;i=i+1) call dtrsl (v, nn, nn, wk(1,i), 11, infowk) for (i=1;i<=nnull;i=i+1) { for (j=i;j<=nnull;j=j+1) { sms(i,j) = ddot (nn, wk(1,i), 1, wk(1,j), 1) sms(j,i) = sms(i,j) } } return end gss/src/ratfor/hzdaux.r0000644000176200001440000001551212355360640014630 0ustar liggesusers #::::::::::::: # hzdaux1 #::::::::::::: subroutine hzdaux1 (cd, nxis, q, nxi, qdrs, nqd, qdwt, nx, mchpr, wt, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), qdwt(nqd,*), mchpr, wt(nqd,*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot # Initialization for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) } # H matrix call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) } } call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) rklnew = rklnew + (wtnew(i,kk) - wt0(i,kk)*tmp) } } if (flag==1) { # Reset iteration with uniform starting value call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 break } if (rklnew-rkl<1.d1*(1.d0+dabs(rkl))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew # Check convergence if (disc0= 0. # -3 : tuning parameters are out of scope. # Work arrays: # hwk1,2 of sizes at least (nq,nq). # gwk1,2 of sizes at least (nq). # kwk of size at least (n,n,nq). # work1-3 of sizes at least (n). # Routines called directly: # Fortran -- dfloat # Blas -- daxpy, dcopy, ddot, dscal # Blas2 -- dgemv # Linpack -- dpbfa, dpbsl, dqrsl # Rkpack -- dqrslm # Other -- dset # Written: Chong Gu, Statistics, Purdue, latest version 12/29/91. double precision trc, det, dum, ddot integer i, j, m info = 0 call dset (nq, 0.d0, gra, 1) call dset (nq*nq, 0.d0, hes, 1) # check tuning parameters if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( nobs < n | ldqr < n | ldqc < n | nq <= 0 | ldu < n-1 | ldh < nq | ldk < n ) { info = -1 return } # compute K_{i} = U^{T}(\theta_{i}Q_{i})U for (i=2;i<=nq;i=i+1) { # from i=2 to nq if ( theta(i) <= -25.d0 ) next for (j=1;j<=n;j=j+1) { call dcopy (n-j+1, q(j,j,i), 1, kwk(j,j,i), 1) call dscal (n-j+1, 10.d0 ** theta(i), kwk(j,j,i), 1) } call dqrslm (u, ldu, n-1, n-2, uaux, kwk(2,2,i), n, 0, info, work1) call dqrsl (u, ldu, n-1, n-2, uaux, kwk(2,1,i), dum, kwk(2,1,i),_ dum, dum, dum, 01000, info) } # compute K_{1} through the identity: U^{T}(\sum K_{i})U = T call dcopy (n, t(2,1), 2, kwk(1,1,1), n+1) call dcopy (n-1, t(1,2), 2, kwk(2,1,1), n+1) for (j=1;j -3: as from LINPACK's `dpbfa'. # Work array: # work of size at least (n). # Routines called directly: # Fortran -- dexp, dfloat, dlog # Blas -- dasum, dcopy, ddot, dscal # Linpack -- dpbfa, dpbsl # Written: Chong Gu, Statistics, UW-Madison, latest version 12/29/91. double precision nume, deno, tmp, alph, la, dasum, ddot integer j info = 0 # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } la = t(1,1) # standardize the matrix for numerical stability alph = dfloat (n) / dasum (n, t(2,1), ldt) call dscal (n, alph, t(2,1), ldt) call dscal (n-1, alph, t(1,2), ldt) # decomposition call dpbfa (t, ldt, n, 1, info) if ( info != 0 ) return call dcopy (n, z, 1, work, 1) call dpbsl (t, ldt, n, 1, work) # GCV computation if ( vmu == 'v' ) { tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp for (j=n-1;j>0;j=j-1) { tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp } nume = ddot (n, work, 1, work, 1) / dfloat (n) deno = deno / dfloat (n) varht = alph * la * nume / deno score = nume / deno / deno } # GML computation if ( vmu == 'm' ) { deno = dlog (t(2,n)) for (j=n-1;j>0;j=j-1) deno = deno + dlog (t(2,j)) nume = ddot (n, z, 1, work, 1) / dfloat (n) varht = alph * la * nume score = nume * dexp (2.d0 * deno / dfloat (n)) } # unbiased risk computation if ( vmu == 'u' ) { nume = ddot (n, work, 1, work, 1) / dfloat (n) tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp for (j=n-1;j>0;j=j-1) { tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp } deno = deno / dfloat (n) score = alph * alph * la * la * nume - 2.d0 * varht * alph * la * deno } return end #............................................................................... gss/src/hzdnewton10.f0000644000176200001440000001707113267111001014163 0ustar liggesusersC Output from Public domain Ratfor, version 1.01 subroutine hzdnewton10 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cn *t, intrs, rho, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), maxiter, jpvt(*), inf *o double precision cd(*), q(nxi,*), rs(nt,*), intrs(*), rho(*), prec *, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nt iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nt call hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, in *trs, rho, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk *(icdnew), wk(iwtnew), wk(iwk), info) return end subroutine hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, c *nt, intrs, rho, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtne *w, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), maxiter, jpvt(*), inf *o double precision cd(*), q(nxi,*), rs(nt,*), intrs(*), rho(*), prec *, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, lkhd, mumax, lkhdnew, disc, dis *c0 info = 0 i=1 23000 if(.not.(i.le.nt))goto 23002 tmp = ddot (nxis, rs(i,1), nt, cd, 1) wt(i) = dexp (-tmp) * rho(i) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23001 i=i+1 goto 23000 23002 continue call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum(nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 23005 continue iter = iter + 1 i=1 23008 if(.not.(i.le.nxis))goto 23010 mu(i) = ddot (nt, wt, 1, rs(1,i), 1) j=i 23011 if(.not.(j.le.nxis))goto 23013 v(i,j) = 0.d0 k=1 23014 if(.not.(k.le.nt))goto 23016 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23015 k=k+1 goto 23014 23016 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23012 j=j+1 goto 23011 23013 continue 23009 i=i+1 goto 23008 23010 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23019 if(.not.(i.le.nxis))goto 23021 jpvt(i) = 0 23020 i=i+1 goto 23019 23021 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23022 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23022 endif 23023 continue i=rkv+1 23024 if(.not.(i.le.nxis))goto 23026 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23025 i=i+1 goto 23024 23026 continue 23027 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) i=1 23030 if(.not.(i.le.nt))goto 23032 tmp = ddot (nxis, rs(i,1), nt, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23032 endif wtnew(i) = dexp (-tmp) * rho(i) if(cntsum.ne.0)then wtnew(i) = wtnew(i) * dfloat (cnt(i)) endif 23031 i=i+1 goto 23030 23032 continue call dscal (nt, 1/dfloat(nobs), wtnew, 1) lkhdnew = dasum(nt, wtnew, 1) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) i=1 23039 if(.not.(i.le.nt))goto 23041 wt(i) = rho(i) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23040 i=i+1 goto 23039 23041 continue call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 goto 23029 endif if(flag.eq.3)then goto 23029 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23029 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23029 endif 23028 goto 23027 23029 continue if(flag.eq.1)then flag = 2 goto 23006 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23054 if(.not.(i.le.nt))goto 23056 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23055 i=i+1 goto 23054 23056 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt, wtnew, 1, wt, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23007 endif if(disc.lt.prec)then goto 23007 endif if(iter.lt.maxiter)then goto 23006 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) i=1 23065 if(.not.(i.le.nt))goto 23067 wt(i) = rho(i) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23066 i=i+1 goto 23065 23067 continue call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 flag = 2 else info = 2 goto 23007 endif 23006 goto 23005 23007 continue lkhd = dasum (nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) tmp = 0.d0 disc = 0.d0 i=1 23070 if(.not.(i.le.nt))goto 23072 call dcopy (nxis, rs(i,1), nt, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.ne.0)then wtnew(i) = wtnew(i) / dfloat (cnt(i)) endif tmp = tmp + wt(i) * (dexp (wtnew(i)/(1.d0-wtnew(i))) - 1.d0) if(cntsum.ne.0)then disc = disc + dfloat(cnt(i)) * wtnew(i)/(1.d0-wtnew(i)) else disc = disc + wtnew(i)/(1.d0-wtnew(i)) endif 23071 i=i+1 goto 23070 23072 continue wt(1) = lkhd wt(2) = tmp wt(3) = disc/dfloat(nobs) return end subroutine hzdaux101 (cd, nxis, q, nxi, rs, nt, rho, mchpr, v, jpv *t) integer nxis, nxi, nt, jpvt(*) double precision cd(*), q(nxi,*), rs(nt,*), rho(*), mchpr, v(nxis, **) integer i, j, k, rkv double precision tmp, ddot i=1 23077 if(.not.(i.le.nt))goto 23079 tmp = ddot (nxis, rs(i,1), nt, cd, 1) rho(i) = dexp (-tmp) * rho(i) 23078 i=i+1 goto 23077 23079 continue i=1 23080 if(.not.(i.le.nxis))goto 23082 j=i 23083 if(.not.(j.le.nxis))goto 23085 v(i,j) = 0.d0 k=1 23086 if(.not.(k.le.nt))goto 23088 v(i,j) = v(i,j) + rho(k) * rs(k,i) * rs(k,j) 23087 k=k+1 goto 23086 23088 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23084 j=j+1 goto 23083 23085 continue 23081 i=i+1 goto 23080 23082 continue i=1 23091 if(.not.(i.le.nxis))goto 23093 jpvt(i) = 0 23092 i=i+1 goto 23091 23093 continue call dchdc (v, nxis, nxis, cd, jpvt, 1, rkv) 23094 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23094 endif 23095 continue i=rkv+1 23096 if(.not.(i.le.nxis))goto 23098 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23097 i=i+1 goto 23096 23098 continue return end gss/src/deval.f0000644000176200001440000000246113267111001013072 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine deval (vmu, q, ldq, n, z, nint, low, upp, nlaht, score, * varht, info, twk, work) character vmu integer ldq, n, nint, info double precision q(ldq,*), z(*), low, upp, nlaht, score(*), varht, * twk(2,*), work(*) double precision tmp, minscr, mlo, varhtwk integer j info = 0 if( upp .lt. low )then mlo = low low = upp upp = mlo endif if( (vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u') .or. nint * .lt. 1 )then info = -3 return endif if( 1 .gt. n .or. n .gt. ldq )then info = -1 return endif j=1 23006 if(.not.(j.le.nint+1))goto 23008 tmp = low + dfloat (j-1) * ( upp - low ) / dfloat (nint) call dset (n, 10.d0 ** (tmp), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**tmp call dtrev (vmu, twk, 2, n, z, score(j), varht, info, work) if( info .ne. 0 )then info = -2 return endif if( score(j) .le. minscr .or. j .eq. 1 )then minscr = score(j) nlaht = tmp varhtwk = varht endif 23007 j=j+1 goto 23006 23008 continue varht = varhtwk return end gss/NAMESPACE0000644000176200001440000000356013265665045012305 0ustar liggesusersuseDynLib(gss) # export user functions importFrom(stats, as.formula, dnorm, fitted, model.frame, model.matrix, model.offset, model.response, model.weights, na.omit, nlm, pnorm, predict, qlogis, quantile, residuals, terms, terms.formula, var, runif) export(cdsscden, cpsscden, cqsscden, cdssden, cpssden, cqssden, dsscden, dssden, gauss.quad, gssanova, gssanova0, gssanova1, hzdcurve.sshzd, hzdrate.sshzd, nlm0, para.arma, predict1, project, psscden, pssden, qsscden, qssden, smolyak.quad, smolyak.size, ssanova, ssanova0, ssanova9, sscden, sscden1, sscox, ssden, ssden1, sshzd, sshzd1, ssllrm, survexp.sshzd) # export internal functions used in examples export(mkterm, mkphi.cubic, mkphi.tp, mkran, mkran1, mkrk.cubic, mkrk.tp) # export internal functions for use in gsscopu export(sspdsty, mspdsty, msphzd, msphzd1) export(ngreg.proj) # register S3 methods S3method(fitted, gssanova) S3method(fitted, ssanova) S3method(predict, ssanova) S3method(predict, ssanova0) S3method(predict, sscox) S3method(predict, ssllrm) S3method(predict1, ssanova) S3method(print, gssanova) S3method(print, ssanova) S3method(print, ssanova0) S3method(print, sscden) S3method(print, sscox) S3method(print, ssden) S3method(print, sshzd) S3method(print, ssllrm) S3method(print, summary.gssanova) S3method(print, summary.gssanova0) S3method(print, summary.ssanova) S3method(project, gssanova) S3method(project, ssanova) S3method(project, ssanova9) S3method(project, sscden) S3method(project, sscden1) S3method(project, sscox) S3method(project, ssden) S3method(project, ssden1) S3method(project, sshzd) S3method(project, sshzd1) S3method(project, ssllrm) S3method(summary, gssanova) S3method(summary, gssanova0) S3method(summary, ssanova) S3method(summary, ssanova0) S3method(summary, ssanova9) S3method(residuals, gssanova) S3method(residuals, ssanova) gss/data/0000755000176200001440000000000013267106071011762 5ustar liggesusersgss/data/LakeAcidity.rda0000644000176200001440000000740413267106071014642 0ustar liggesusers‹]X -8·-²D ‘‰6TRöåZ²o­¤MÛdzN"Ò¤M©´hfŠl¥¤ä;îyŽï÷Íýýî}ÏyÏó>Ïÿÿþï{¹vó~RsP“““SSTR’SPä.•¸y9%9UnT·qÞäF»xºzn ’“SÔæ¦”¹·÷ö%¢Cý¯4"²myÉŽˆËbŒº®qÿPKÄ ‹‡oaMô¶¿à®vÑCµ9¾ù‰XNö""á¹™ìEtkú_·ˆAÿôÂb¢×ŸÖ¶…èËÒ9±»ìEô¹$js¶±ð\öx"1À|½¾,Íp¢ÿBö``êëc]},5"Bœâþô¾D,àE\ú—dD‰ãõ1Ïä-Ôa=‘d‚QDó‰Q7¯H¨#ŒÈOÐQŒ: è!ðú¡.ê%ðÈ+ƒ3g nd˜ á¼Ð]\g è‹z‰1^Ü?môq@¡¿"Œ!N‘‡| …<Øï:‚>ˆÏPà…~-âGC¼|!Â|†‚.Âs ß ?ô«öEï||„~ó˜G}"à6F¡Žàä7zŸÏu1D܆‚o‘·!âð›PG¨Ëãö!õ™ÇE}ÆuØ7%¬?˜¯G5ó}¡Þ`üW>ŽzÇç¥ZùzÔ}ÔCçC5áØ8µPgy¬7ƒ¿§>á¼ æmçûF}Æu&|<õq)óþ¦>ò¾£:W;âWàýBuñë©>¾T/âíÂxa]'¯'õã{1ÿ7~b€÷_Èó%¿oøåõ§> îœï@ܼ.Tߪy·£¿5°ÿ ü=õë:ô`½6ÞÔkÔO ûnÙÍÇ÷ _ø}EÕáº^Äßù;ð|0@ŸÊ#ßV^_ê úLñ¾DzÐwÃïWÌ÷ }*‡¼{pÿ©b_upêâ>ŽçòÐOÈ3 ûÐñʈSóŒ@_ÀóCש!aúŒê⥷ºÂêzUk ¡Ï/÷ú0j ¡ã5?û-œOèèâ¿L»s ÕSôèKBÇðý¡£#_îZE¬Ü#¶<ó„÷+c^rçÎ’Ù·¦‚>&½ØW•;u^r:ð¼é'¼~¤ }›x£yÝÈCô›ùñDõç„ÜWלpe*¡ç¡Ðä›Sü%ÄJèó^«0ÔMõqöÜÆéÊë`5¢î@­ïlb5±kå¹?9½òlEµƒ× ûez9÷Y•³Ì—@ÅOV³’ÁÜ6`[Xæøû ós«Y¦@Ve®ÈöË”ÎûSûø$–¹áú°¡‹e*†e<øÄ2ט*ÎÁ,ÃâóÁ)\žÙ²se,úë}]Æ2›”íÐ-c™®Íw¯³LY«Ë¨U–é,œ¾]3žeÞÈö˼åï%Cÿ^þ>Ÿ•Lè_nÍJ&fKÒç°Ql…R¨+Qº×ûþ–y…u0Î(M!`<7ÿ¡òår‰ƒ«Ì'±ݪÖê/#¸1BUá™<+Ñò5ÿ²›«£­å½ŒË';7X&Jv~±L4ò»1&Ùîw –¹ÞÙáÇñD]reû‡eÒ-Æ•*½]¥Ã2EY-pÆ‘eòzÇô™üÂåI‰^Ú8›eîó<˜‡r ‘E,S';GY¦¦—·ñÖÏÇ‚X¦JÖGV¢†z ãñH†ñ}“ˆ6]ŽÚmÄ2ïQï?–r†âòt#¾²}Î2ßpÞõÎ. ^W²öw°oA|&©_~;–‰Å>ùôÃueÙñÆéÑ€>Qî‡gÉ2m æ+·³Ìv¯–w*‡}rq«ÈüÏJùu‚mÙþf~_²Mìßyä7Dæ{îý¹šÇ)ÑBÃWÏ_¢ÁûQ¢ƒýx¼Ña¸^yxcž½<‰êq ø<•÷ãƒû¢ëþÀÇKÔdç"kÿ×ñç+Žøù?´X&¢ßŽê8˜«²ïîÿÄþ}ø2­f×é׌ DÞW¢ÙNÑŽïŒ`ß<'›DÛ‘]h z·¢¦/® úQ QY£Í‰yÄåÎ|3äH5Ä-‹Õrç1-­Q&aãÛ9Él®'•Ö7çJží!*FG[êh«JEÅoÎs*=Gù>ÖÚ£ýÄ2ÜW/Où©bSØ–ðÒJÞ[Ô\©%Ž‘±G(H}¹0et•ä\[öaU£ä¯ÞV«Üõ ò³ÌÊ;ß@îÍtEëï(Ȫ_u}Э¡B[\Üv~ $mÜà|æY.䙿] }êxÆí¤ÒG]²~f£¹ÒæHß‹]~O%rº[N-[]¹êníSâ¦BÖSé~f2x™V(“«gÀË5þÇÆ«õÌ3y ÄiN+_ACŒm¢¯Mw„XÉOItË…í‡ôL'k@‚ó É.¥kòíË¢ß(ÛQÿ²ØÏBu Þýö3Ä÷M×Õ€T4ËšEHÝ›BUg@âÂßÏ–ÒøNï¾q¥S Ùc‰çÇÈjˆwø 5ö‚5äŒX×õJÍrþìý½X¾rþ±Õïuh†ÜòñM*;!­úò»÷ ~φ(Ñù½ÞÜüJ\;öEÇ9¦ç)A¦coXTçjc‚׃֊-<¦mp‹y…zR6ÊÅ7#ïPüC±<ø¼o­>f5òô• ñÝATÏ‚UÌ1HÚ´üî›Ë «u] ]v¤ÉYÙ9 ZRÆo˜ŠÒž¹Äw+ŸDãÒ‘§4çC6T¸îm\ Y…l]rf@\Í1ËË*5@ú&ÉØ¿^ròï®. %÷ G©@ýdi¸©<÷Óx£âhj—俯©™ç!§¯`cÍš °ž¹7Hõs0ʼnÆ)º9û µf›ªC®µyM°¥$_‹œÜ¢<ˆ²×‰{ì2e8ž1wÝÜÙv÷L̦6 i{p§Ý˜ª{!לö@–çîªbK ¼‡;7a%d­šÚ]t>è [²°–òlÖ¹lš ‡tný|sÌg*ñJ£íZZr4"¼Ï­¨¤rW-®zµ2¯\>vütÈ5YÓÖíi‡çÓggý îZ‘?ÜNàˆÞ¬Ññö4å³&ÔÔ1Ðò¨;©cå'ÊÙ1tªÍPÊoõÁÂ’ŸS)¿ë¶”a”«¦u}Ô{ p ¨0—8낇ÅÐãåE›ÁSyÝò¸ аÁG·ë‹žx¸Ú×ä¦Í¦Ò)Q‚¸î(%}Þr,éQ %Õ\£CQ1U½*»Ïo¥v(ˆ‡Wˆ¨]È_z8V¨oùÎzLmä›×°*ÛþSߣ•°fù—&ÇÁïÁ³-W¿¬ÐdñR 4xœÜÆn˜nv>#q,„h¬/SnÒ‚=º*—Tt* ¼Ùãóaccw/u­Y3 Â×nÜ‘Ó`Q#÷.MU?4ü¢ãÑÙïlŸdAŒëæËòçC¤½Ë±¿¤#©õ w‹·D l3] í5«a–kô‚_ÿŠ„y‡aæ™Å`7Æè´­é-˜RÜÑ^P ‹Ý<‹§ª€w’éQú­ì÷i¨Þ² ¶)Ý–½Ðió¼Í­®Â¥\-ƒðb±‚‰Æp8 ]è×­‘ û­ußÀéô­e§hÊ XgÝ+²Yk»’˪+CÜ âdåÊé’bˆ<}Ñ뉦2µÓôuWIùuØdW8«ä”:µ²ÎÑ &ó9¸Ö§¦<Òñ‡½fiWÖÛ$S1•–+\¢ÂŸ{~ÓxÉBH>ôâTèúRHÒ8ñÏ•Ey|ÛÝä†^(¤”觛߈ Û½m[ƒ ½ñGSÏByȘéäþ¡}ä¨ÙYáôr2*uöŸàΕØõÚÆ€x 3O*úè)ˆ©™ÜÝNí1ž$–ž…ì«OHC¨„îûeOvC&½|ãîBȾãUÓüRF߉~c/…$©Å¡e3¨•b‡ìâTˆÊë¿Ñ‰J†7ˈ…%;’ÿ.}*u»L¦¯Œm­wÝ^E@ôœÛM1oó!£v­ÉQ­ ˆˆMÊ =zÀ)ª§ƒÊ]©ì·‰…„Lƒ½YÕÑ%TväÖöÕF¸>tbã\H\,¿.O¿üžüózZ-7r¾yº˜Jøcò}¹¯ã`ì׊·wÜû×O©Š®ž›¹á;Ù¯­ÜŸ©üø!*\ˆ·óf7îZã¾qk>F>P¸ú×je/g &•hÿ_üù4ÿ,Ô*ûI—ŸTðõÀº8{ —^Î[.}¼…¼Ü|6ü+§ªŸÏ6!¯Œg÷Ñ××Ç*õý œš«óVgw?n 2ýö_ÿÿU“gss/data/ozone.rda0000644000176200001440000001234613267106071013612 0ustar liggesusers‹][lUgvÞC¨tµ••Z•¬ê! !„ Â-fÛÇ—ƒ}l.ÎŽ  øz2Ét&{Â4’aãL˜iJ3CR” ÌTŠÔ­VŠúPUÇ·ôI±{“øIýB9Öƒn £ÝŒëí"Ï&™Gó¤Ù±ÿ“ÂOëF“Ì×"vj‘ùW‹Ý–;~RýÕþ[DÿÕ"Ï2nƒøs½\¯“ñ-_­ò|èÕ,ï‘ÿ6Ðâ§M¢æÍ*y¾Qæ§ü›…Ï“Žþ:ï™WŸk~®–8R¿jÒº¤ñ¶Fô[%zm~”7;Òÿ»Dï¡kÄNjï-"ONž?)q’sò:/r¬rê—?õÎzX'rk´:õ§Qô×ûÛÄÞë{u}eƺ£õY×M]OV:ëçzáßìÌ‹ëí÷û59ëûjÇ~ZŸV;}À7¥ Žž¹Œ>ªÞádÌSçðÍ9óå¾Cì›ô•wJµçw  ÈÏ;@¯-=/ãùþè' ŸÞ•çÍÎûÃÂçqÿ1è‡"ß yNùjÞþh-@Âþ ×Ç@@§@+r4§ËuûDîóB·È{Ãr?'vw(õøô ôøg\ÿÜêq§×ÿú²Œû\䈄ߜØ7rìq@(õ+Éý’ØùKá/ï%vm¶òÞ^ ú®õ+çIìó¹å“Ø~½Šÿ9¾ÓÚ/Ñ3{q%±[ÕÚ+±÷㢯Æñ¸Ø¥ÙyoXäb¾}Q£¿Y‚ëO%/nŸ’ꇪç…Ϝ̫rkžH^ÝþG'N?L×ûÎ=§þܹnÿ{2^ßû¹ÿ‰Ø÷ãôùèßü±\ÿ¹½ÿмŸÊµêý‰ÔWG~åûPœ|&òω}®X>‰Üúþœ7U§Î;qõEº¼‰=©Oth«PÕûžØë†WŸÊý{޽oˆüê§9'î4ŸÎ‹þ9¡K¾F"‡ØË£ÅÓ'Ž~7äúŠãW­#[ìz•Èù±³žÜ{U%ÎòŽß>»qÝøK©Ë/ùØCý1çøÅ«ƒMN]ûPègb×Hê蜌×çÕŒ¸ñú±FYWsÎúR’u÷K§oyܬ·I_Y·HÜËë³ó}·×?×eôÛuN_žË¸¯|òûƒFg¢øg.Cþú ¹TŽ&gÿ‘eïFkÊïÉ·<0òC½³O©Ë°C–œ}Xƒ3®Þñ[½wœyùÜ !¿¯wälÌÀé³ðëü"ñòÜ"íçáØ^PïàÄ9çý†ŒøÈ;ölpø788P}F>féŸË¨3u‹Ç³ÇïÁø.\·ãº;°üÊ í´?®w ¿nÞùK"IÎK©G§¼_½ºýh¯~ؽ/¶Ï)/ã†þm½Šâ¿ÞØ^ÓNŒÛ=B»EÏ~ÆQhù%wD–òý¢Ø•~ë ì¼ý2_!²þl?t‰ø>íF;öŠÿû…–1~ó쓸ޣãÕnõ;¯)õí%¿b+ß@hóg¿Ž“¸gž÷Ê<%™röÈûɼ2¯æhçMâJêÏQ_»$¿è¯~‘«7L×Oí´WÆ3NTÎ[–¼ã¸²^KÞÙx(K>öës'ºT?áÇxØ£yÚüî‘|)Kè–8(ËûåÐÑ#”:*ùõÐ8‰—²è7 rìÓçéÿôé8]WÂt$×’gûÅ.}ê±K¿3¿®7eYùã²?H¯7IüJ¼tˆüeõ£Ø…uõ §/`Ü%çòº~´‹þä×-ùK¾œ³œë¤¾÷K¾±þì ÓíÓ,®ïQºUêT§3.”¼Ùòòk‘y¸îy|»Å.â7æ×ÞÐö•ñý°CÖyÖ•‚ôº®ežáŸÔûØêÓ¤¿ÇzY”>§'J¯¿º>jŸ¶Sú§V¹¿[úì‚ö9Ž=H;²ì¥ëS”¾­KüØ)v/ˆü›å¾òépòq·ÈÝ-|Kb×>YovH\j }mbY¯»%?÷ˆ½)ÇŽ ½ïëþ…(=ÚÅN;ä>å ¥¯/éõ¼/LG® bŸn±ÃC}¢ôÙ´cAìФ÷eéöéýC¿¬ ½Qº^{$_õ}í34ÿú‚ty{%žtßX»udôŸ‰ÞqzŸM;p}HúâXú‰PÆÇ¶?#åz¿ÏÙ‡öIÿξd_œ~½/H—¿_ú˜ít?Yù÷Šß5.Ô.{¥o+‹ÿzÅ~az\ôDéq®ûyíëʉÞÂò%v íþe¿ôeû¾iÀÙÈóN§Ï§Ý»¢ô>–TÇ÷†éûzͧ©Ó=N_«}\Ÿô骯>×}bŸ³ïé•ýý§ÎõHwIßRrôîyúœú×#ëØ.©Ûí·¤ïƒ´ªýK%éWvH?Ѧë¸\÷ˆŠb§¢ð/ȼQzŸÐ)ù§}Y‡ÈÑ¥óÕõOû¼¢]7“¾òÚ²Úý—&jô§øÎá2Þ{÷Bþ Há|îã;‰_Ÿ­Ñ§á÷ïÇöþO~h¯IÏà;ï\LNzß Þœ²|^‚œóû=‹qÑå}¡¹FÏA›/§Ï?÷¹½~ÿƒGËCzUô¿õ÷5z©v@^û¨F¿;¿¸ùTž9èñ ô¬B_•¿Ù|¤7›ýüLíÃäpfþÆ÷‡ß¬]_„ý/¿Z£/ãýáÇç.Z½_ß×ç}ñÈœÈ÷=ð}ý~þ(Zœžo}'ý~Tyô{ïÌ<úùk´KíÀ#|þ.ìVûâû¢pý¾cy yóÊJg^èwv=· z€ß´ÄÏOs6˜§—@_ÿï¢Nž…]/A¿· ×åÏí{×_¨Ñ÷p=ïoßÇ|·þ÷Q/® nÂޯþ¿zñï!/@¯7!Ç/ðÓ/ÿr ¾ßüoÈüy÷?í ÿníG½Ïv î .\D|]Ú&ïÁ¾0ßY¼òÌÖÙºø<êçKµƒ®ð‡¬/ˆƒsÈ—yÖ-øñãuð Ü¿pßæÓ%Ìsz_½ ŠïˆIÿ,Å}Ô—kðë;xþÆ‚­“{ùµÂúã|ÞÊÿüòcÔåëˆóë°ß­‚àÿŒ¿ø‘÷gÿ†<ø(Ýo·œ<» ù~ »¿†zqúü5âë¯æmž0¯Îv=ù¾—>S±u„qÂ:EÖ®¿À÷ê¯|aëå¼½ÞDþ\í¶Ïÿùp òÝÄzò>òâäy÷wév˜FÞ^ï^\½»Ž8?ý^ß‹#ˆ¯ûéïQÿó÷m¼sý~ëé øámømþ;ÏÛXßþ ćÃïZ«Gw]EÜ_é°ù7#õŸëÿ÷P_/×ÿa뢮¬›´çkð×%Ô§YÏ‘?[úèyßF~½õ{é3`ïiè÷Æ]B}ß?^¿oóTû­,½~äô7ÿuqï³>½×–Î÷¦õ7ûÊ8W¼Ip/ü^,ƹPÌsfàŸ1&‰‰—â{†¸M(úáûÒý6?cßc£‰ó®¾+8/è¡ÀÍcü^/n”} ÷;Ûìüü¯³¸ó?PNà‚q>°ç¾EÁã¶ÚïˆW'ïÓÄ o±ïÇú]ƒžµÙýB¼Òú'Á37ɹB·ÅñcÈËïªãõÖ¾‰¼}öûƒ¸Ã™‡û#è7‹ˆ‡ßuÄ«eß·[pŲàw{dÿ¶]ôÛ¤ŸçqK»ð÷OÅv¿¹ÍÚ1ù]á Ù×h<¶+2ñõ>¼ÝÚ'ù]c»ì©÷z› ®Z°~Nø5È÷ú]E§ì·;WRõy#“þ„|Y§Pâ¢ô]Ûdþ‚ô_ÍÒpþ꙾)Þ.Ï‹2¿Ú¹Eì³YâHÖgÚ-±{>°x%Ï*x>„þü êÁA©ÏiÊ[=&€Maž<Ÿ©ØûS7±`ýÉyÆ¥ŽÑ~\"·'ðüDÅêÉu”uëã””ùÍz·_âõpÅ>§ý’sæ ãBâ8±K`ëÄq‰ƒqÚñ>Éxà:D¹óÖ?¬Ëcóâ÷ÈêÃõŠ~Y°}ëË¡À®£¡äÞ™·r3ØtÉyoŸì“ú´`íG>Ì;ö'G1îØ‚õ;õ¦>]²_+J@~C¬wË7¹/þg½<"ûð±¼]×*÷û¨ÀÖ7Úy¿¬¿úýwYú;úsPê ã‘ó´I_É|”}))ïsÜÁ râ>yLÞ“ûÏ}ßP”>žã†ä<Ÿñ2,}IAäj}ß ÈA=g,ÿYY—•Ž9öQ=)7Òa¡2OAp•‡vR:(ÏÇÄNžAn÷µ?•‡vÑxR=ÕžSâWõ›R•_ãUõæµÚqб«Êq0H¯WƒB·Šß†$ny5®Uƒâ¹.Èþa­ÈQtÞ÷ôT;äýÁŒ÷•§·WW¼¸’u£Uôpê™ggWåpÆeùkPì^pìPÊðOò{,G>§àøKçSªöÑz<¤Ç]ÉyoÌY˜g}Qzýáu«c¯µçu"O«#Ÿ—CÑ£ã¤èäY_FÝÕñ^Ü{ùeO¿èä®SدQòÈ«ûò\û}^tâq*#¾t½Ðx(ŠüÞº6æøIíZ'òµ U»5H{í ²ü§uJ垊Óí¨ñ1,ù4æÄ1iÉ™G×Cωç@ÿ]tÚÓûÝ^ð°‚s+þ½Zðèf‰óur¾´^pörÞ§çô[å©UðÅPÎ?ô÷Ä­ˆS xÕnç¼FÏwxÖ!8‹þîªSöU]‚/êïXôwrú;ô‡~*çiúsŸœ[éïHËr¾©¿ÔßèwîÉïè¸Ïí¹©î»ùÝý>O¾¿¼÷@`÷Å"‹‡$õ‰û'Ö{âÝÏ=%¸÷}Ä#ž\ý⬡݇?#xû³xþldqÕd]aÙsâ‡ä\¸%q=îW¹?®ðÜ@ðbð|"YñÞЂÅY‰»—ä>vXðMâTÄy¾@<œûpâ‡ç-NqxApLâš¡Ýçs_Oü‚ø:ñâkÄu‰pÿO<œ8ñUâ Ä›ˆ‹·9R±x$ÏŽ¾”xUÞâÖÄåˆc=„‹Jp.Á‰?<˜8Æû‡ŠàJ‚#¿JðÏÐâ6Ä% ^s÷ÇÇ îG\{\Î1ˆko:)¸$qSâ ÄOâý“±ÅÓN ÞO¼Ž¸tr~E<8¶8îi®ÿŠ‹âýÓ‘ÅóNpèf‹NT,pÃ@pļř'‰;ƒßdÅâ“‘Åï'ÁwòhlqÛIâ–÷-Î9EÜ>oñù©ÐâÀS•t~ê¢àÆ·¸+ç+à? þÓàÏïN§ÁgóóûóiÌ;y§ïÚs…iÌ;Øóˆè5½fÀg¦×âÞ3ЋßyÎ@¯âä·/þ^aüg‰cÿ,øÏ‚ÿ,q-ðŸÿYðŸÿYðŸÿYðŸÿÙ»›ÿ*øWÁ¿ þUð¯‚ü«à_ÿ*øUÁ¯ ~Õ»h+íÿÏ©¡“£_¹ò+nËpséìÄéþ½:rl†ndz‚?vr$¹?=<“ÜþzüÈщ£_ßÿzLuzæyüý±‘¡çE¦oO~n åú“ÿ-©™ô[*üáñ¡i Ï›ËF†f†Ö™zðþƒ«¯þQÏ/ÿWíb‚”hgss/data/penny.rda0000644000176200001440000000067213267106071013610 0ustar liggesusers‹uÔ¯KaðÇÝ n¨ ´øO,¸à‚åv[1 Ûá6¶9¶ ƒÁ`p"j1 ƒÁ`˜`0 ƒÁ`çÝö|_¹/øÂö¹÷Çó>ïÝsÜü\~6‘OˆHL,Û–˜\Ú±àoDl‰ŽÖŠÕjKÄš,™ ~ ÎAAÂöçY&kd“\#×É6¹An’[ä6¹Cî’ûäyLž’gä9yI^‘×ä yKÞ‘]ò|$ŸÈgò…|%ßÈwòƒü$¿È輻BÚä9N&Ééˆæ½v{¥°9^¶´{'Ó ÛžãÍ Íèûgìê:Ìëzãé°9.Ökßêk>WõJÃs`_sÌc\誇|è¹²ºo}]硯û›qô5ONÍ"¿®Ã<âs:oò`çëÑ9xˆç¯q˜7ñȯæÚÑ<èã9©^¦ÎBÏêlæ¹þÈ£Ï×äIGë›A]QGÊ‹ûÄýs½ÿîqÑ÷‚?æU¿RlÉÁÇ|8h·Š~]¯­Êr™bâõ•Õâ&¸ðý~ÿ„7_,û lŽÁDÁoú©R=ˆz?áï·UZ~tgss/data/NO2.rda0000644000176200001440000002447513267106071013064 0ustar liggesusers‹…\|ç÷¿d›Ü{“›yWì{Ï{›ìD$bE¶]«öÞ£vQ›"V+¨\µkS%j ¥V¢üž×{Îãó>šÿßçÓ¾ÞõŒs¾ç{¾ç¼· ‰«éçªR©JªììíU%íØ_íK²•PÙ«\ØÑ.4¬&û·û«#ûǃÝ)un·acMà|ºèCo8 ®ã‡¸½¾2´38MMlÚž?m›šµíz–¾34j¯5†Ÿ†uϼ쳯-¸4›Z¯ý±`ç1nÓ|wðØô"E{ì"hŸfD·ß±45Ï ú. 4%~7rÛp¹ºuËʘe Ë¶ûç—-àpë߄ǡ÷Á­ðZã ¿Ñ î¾qQR÷A Nº3iqp©.÷X´ÜR¦Å?Ø]´íðY^ÔÖŠ®ûC€ç ¤¶#é¡dóðÎ]ý@3qø°ÔRýÀ£ñ¶ ­¯:‚ç=‡‰?ÎKK.Û ÜÖO÷_«/€’÷¢Êùþ šgû¦”Û<JØþ~ú¾ÅGЕ^8Ö±Ì P]nn°o>tQ7½©œš ëùó}g€ËöÓwŽŽ‹MµÍg¾<çtŒ1ö;ž¥LªÖy¸œÈÔºz} ®×þI2Os×iꆛÊǤJñ#óøü±#¥‚GÙÊ—'zã¿jÇa6p»uãï¼³À)mÙý3ƒæë¼¶÷ÃVE€6…yE»Ô×ßÿ˜÷¨)8lö1… I»ÞÿN»–óš«u“íd¿`÷̆ù“À£[Åë⛂&6ÜTvÂkðØî·OiµÀõc‡+mËÏåöÒfÜÿfîXІ%ö-]f- î3'îË>Û_(Ó®gp™õíëñëƒÆ{ðš€ö×Áeä_ËY£‚>Umóü«ÇDð|Z¿uF¥.Ü>ÎúÜç-‡æ&=X·uì6°ïÝÊu}‡êÖBÍOÕ7éëƒû‚àÆß?±~­êÂì=Ý©ÝPÃ"p›øþï#ÎyÖ¢9C[M>´ÕS«ò“\/X ?Lm—œ×w§'—xñ4/³-G–­ÿ‚óìO‹Ê Š÷QN'Úw; .‘«¬.UÚ¹IµÇœÁ×¥]5¢N¥ õùø•»VéeÁãHüþ_sBA7úmcwóIP»4aÈËõàõ4rt¤<·ÿR¾I×- s·6µË< Ë—wܤ²‚®KÐ_uæ'€s­SÌ!kAZ8}ѰN<ì×QÍ;ý¼:¿_t§æÐÖy·¼~v{puÞVTi[Eð¸9¨âŠ) —71¢a¼½èçfí:‚}Kû±ªdp¿WÉ1éx8¸ý(ïÛåö‘eëîEƒÇ‰ƒ{vþþ;¸<ºàñã2м¨mÿW»<µ[6]xS⎗êŽ3÷î;ÎãNã/™sŸ×-çòý5ã˃ãæþ%Ê.y vSÿ9U¤ßšÍ[¤Àͽãa{Ú¾]Ú/…í­ïµÝÞÄÄG¶Öç?œ½?~³ÉZ4íÿ– ?‹áò»å -‘xÿmï nðg©ó@ëy]2 hó‡Xþ™©—®“Ò[lŽimJ¼põL·Ÿžö žú[½cŽVmÿ5[ý.öíú=nžå÷ƒóŽ -ííøÎu>4 ãñ«A~×þUË ÎÔjSùÑ~®u8¸jŸ¹=¸ f(pž×0BõméÓ3ïþXœçȪ»–ãÆ¥Pæq­ÿ=•wáOàØzWäÆc¿ðÓò–§T^švU~ ÌfûÊ’ýà¼àæèu…Á1Aƹûq æ,nöÑŸÓt— ý¹´M›wù'ÉîÜÍ'^•”¥BßsEÉ}£À¥W`Íéi ÿ ÍíMw[p>vü)c~‹íÀãç³Ú³õ\“q¨ù8äÄîqà´÷ÖðÐá?ƒÎ\µÍ£ &pÙ«>\/è2¸Ø-Í­5ÙÜê?«ýÇjŽg×ç ‹FÏeþøùùÓ&W€¦Â¨àSÕ YxŽéë§…¿?*Rý–̽Ì" Ñý»F£»à¼o`•×@Ó&-ëUÏ$ðœÒÕ/zÚrpP³£$PÛûÍt ?xÚ¿wðnôœ‡5~ynáeÎËÄodÍž½^%zMàøÐ¸5ð/×lϧš½ló÷Æ%Ö¤WÝ Ú:ʧaRØUWK«ã½¶©8Ž5SŽÍ{óˆÅYÆè&†C%@3úÖZÆàeÇàÔýh—ç”þaù0pøy{/Ç€æ[×Ó‹{8¾YšqU»Ý‰ßÚ=Wï9~–Ç[¯»R¿ø=&^bžÇ¼_£ÎÜHÿ–6ëÑò¸w>ëÔ#ã"xŒÝøc¼×¿Ü¿_d'Qwhº?;þó£~Äñ·Ã߀æ÷ Y'3 9’þÑäú‡×25ä㞈¼Ëf|Ðv·µÚðlÅÎ*|¿ê#‘Ö¾×Áõ®c”È/y1ºdûZ×ÞúlÝÙέ,à=qeeÆ,àµòðî7>øuÎÓÍTùÛOß»(ù\gßiÔÂNz®[ˆ)¯ëGßp¨X{+×ižjÔ_‘×w´ê>õ ¿mO¹7êqCð‰Ž;cÙ¾†óÅ6teÿù/炽צJÕcj‚vrÍ[áÝ4”ß@sþó ж4ø7j˜ ®ƒÆœ~¨?ht+Ž—=| \ë-¬R:t¸V»ÒA<jœÝ^Öš&÷Š~a§·Œ•+ƒ&BæÊ7šn5rX(‚c#–À\xüÙÖ¥/šÎýå<½Ûé¤,§²¨êÏõéõ¢ÚUÿÜó=¸¶*º8ðò~P|'%wÏ㎡g—ƒ×Î)g3“Y ïXÎCö15G^ûb—Ž-{Þ^ùˆëÏßn–Úÿôî2D[‹®¾Õìfü z\~}=ÐvKšÂ"‹ç;âcÆ7A;TJK•A½¼EðºáÃÀËY’A׺Îè¾ÁÖW –Æv*êþ æ}ãõÈ4oÍuËï]¸DÑà9&iE÷võÁ3³K欛1àº}cÕÉOp}ážÕµSÓ-u¹~#zMʼ{¨ÒUÐ5½xÅ _ÐüQÕåã¤ñàb ©ÐñÃ=ph ç-m÷}’âuÅ;ÙSW•·þz¶UÛ9LÿïK Ï~ÉtÜw×óM–}áô#åEMáw^——ýÔÄÈJ_tÆ‘GÅü~.™ŽAxõ4éQŠ/÷!ín2÷øÇ³ñ® ­'Á©7¸¤®“«õõg:jÚÞÿq**4ƵãÎqþu:öXÛuœÿÔÏ¿y°²òfŽgdzÍÜ’\ç‚N/ kð,8–Ÿw°#Ø5ËPõûsçWí%¾yxx„uHO[ö€ãšò­6oÆè eܸn÷5Ÿš×°âqkÁèìAŒa8¾Õ.Ó«.?5Šë>Ÿêͯþº6 §F5dåzWÝvÅéF8~Í„üCÐVsØàüôxbªÑÎÆü<¦vÚ1^_¹®v>üêv=ÐÌŽøqéGß§Ö<»uuhÈó'ÕM¤[P/‚v—Ûí›§‚çŒèº{ßíÍ­–·wß1ÛY§Û×ÞñO™:É ½ó›m¼.ƒãx—ôéWÍwû¿.ççŽJ齜®J†[¹ï]\qœó;ék·òޚݴƒýŽÍ{ %ýôLaVæë£üAã¨k³òfâŸ_ôPHÖîaÍkp­=òY(óºô=ÕeÛ†£?¶ÍÙiY7“·ržÅüc}—6é‰ïß_êWŠMȳ)9C'‚ÇC/–Œ÷ƒçµºwÿ6´àøÖ¶8p©ËÄ)à*©.§ïy^ö¸{,Ùa”ØO”õ¨¶ñ=½z[Spš%ó¾fç|©0ãqŒõ&¯ÓM‡O2!é¦SÒÀÎàeýÑÈ Ï.—€&c›!ÓÀ´½ 6“Xàà9ç»ýK@·oLÛ>#z€aåÓõ‰€îýYP»Á·)“ÁòÁRï³`˪l&p?÷õê–=ï€ÿ1Ùu~‰c«ëŒÑú@À°zRÁf¯«Oœ¬ þ7?V`’Òñí=`V­|Ô¯Ö1ðÞWfj‡‘`šõïÉ#׿€ÅnIÆÆªSÀlÒ¤ÕÎTЭؽkî<ØíZaè?¡`®^"lzÜ,°HQ5Œrž4—`YºWø}+ïÓ”7õ–vÀ30µ–ínÌô{ØiÞ,0±4Ðõ;°,½»¨Aš ø^<¾wÎåõð†ÑG©à6¿Fáª9à?ߥى T0lðq‰µ]Ó<–VÂn¯Íud—#lüá¾i×Îþ–/ïÛé–f ç1E qÑÓ–» zÉ›•—ŸýR›ä0»¶fÔHð¯-¯×G/×#æ-˜ð­~ó¥‚Üj^è÷!|<¿rÞ&W.éÞv˜føÞÑó>ÙrÓºÿ*HY¬m$‡M)L\¯;‹·|7lj«–R»=û¬‹³úèõ'uËxy|ŸŽò¹ù—ÐÙÙn§Á?âÓšÎuÁ+Nr“˜KÙ§iwLÙ?Å5ŒKæî;Æ›Àd ]»ñP ˜hÕŽß[™d°Äµ—,X¾?¢]é†`^YboŸû`éqˆU±`I•ˆLß.gBî^Úþz æ—L&x®ã:&‹º½óæóM–.læ&cîã8´¤©ò³Áo©7þÁ2ÏûΗëÏ€6 Ž´>¬Ëê—º+ýÁñªgÏSÀ2ÉÙ‰eHÐß“u7­Ëö¹/ãiãàó!ðZ„ÿY~®ø ¨S¿`Y?»ÝON`8~‹U‚½ÀköÏ=ß s˜ŸŠ1ø\aâ"ixÕ‹°¿qÌ9ŸþðXÀðÐùÀ¿íŸ/_w™? F Öö`  `ØYjn‘u˜ª¯¹âÚ$ |L¥ÜÔÿ¾Yž¹>¨ ưu³³‚¶€¥ëg¦§RYÕ«ž•4ø5}Öý„;‹ßi3ô³8­)ãÒô³wΩ~m!ðÌ·þQLý~ÏìÀÒÍ7À¼ñù„ÄwÏÁö2/Ÿn Á?~rô«¡ñ`^÷ÊãÛ×À,•M¶‚9.+aa*³gêìšõ¦íýÉ!u6_ ¦-$a¦²-RBËV–™F¬¿%åúÝü<#9¤o}@]b¨¿¦ZÈÜJ`–²E>`8UJX`Ú%u³ÂÀÒ‹e߆z°´¨qoõu¸ç¢ÔÈ“Ÿ[Kf>·z±ç2ô‰sõœÏLƒ+¦vóáò};úÔ£MÆ©Åñ÷1æÁÐËùÉœßêE¬¿–ãÏ2¦hã¸þ ×m«¥[°>!ß5céáßéxqRµÎS™]“d~öEÞõ™~í^þQðßÄÐк%˜3]‚Ï¥ÜßA,í%䂹ݒêÕO¿ÄaïÝeztÉ¿Qéö¶ÎA`~"×}æ-RûÙóÏÏÚžóå –¿ÓPIƒ÷î„ͽ~-cE‰†ÁÜfšD 8ÚÈq˜ó*Ü>™w ·_³ØbÓþ3u6Æ}†+²þóJØ)?ó·kààeM˜ Á\éeÄ¡ùŒÏõÝÝBu,¾+¬¾•Ó€ó¥9óòºœž3!pS…Ã5`øu¸$|À\óŦ¢‡iàS <÷M)æ#߇°Š ¼ÏËÃI^ZÁÔ"ÿÈÑE¡`’ûx°DîGXªŒéÞ£ú#žô‚üFt³oÎí„mxþ0§l×”NÚ ÆØ.K£iÑ…aUê·Óº{QoÏæ)ÿÀ£¨F0^efØœ~W¤e,ÃõÛV»k ·-fÆ}×]ÆìlÞL˜Î*[tnà âËõI ðm'µ]ËÅÊÒøâ {ÁTJó#`ž×ÜÉmÆž÷¼öHíêjོP}¸^)0Uºp“ÅÁåäô¸5 ¯Ãå~†9­0ã¡=˜Ûvýdßi4XºTöµÿÔ,mä>·©l£Yí'Kì®ýãÏU #µN†!DÖ_&ì³ú ”uƒ%àÙÎÍwñúe)a‚¹œÇæërÿÀ÷ƒT@-Ë´qF¯ï?I…8ø>”ù‚ìm(_¡çë%`±¬Ï»ZÝÀç‹vûª`z'ó¶ÿªuå.ü扟‰ ¼l»õ¯©`ø‰Ñø™•àÝ'„¬¾»ÐÌÒÕ¦ÏáÔ|K®ÞsüÌ4ž·žr}bé%ÉÓêàÝá]7–iÁâý™øÀÒJ’U!°?«;ï“×òÏ h]¬K½2%ù¦ú{¦Üë÷ü›yAèÚMàßüéþÎ7~S€¬Ç(N÷^ìÎ*y^ÿ˜.HeC]ðɺ½—cC¦«äzÊ´KjÇù‚¾î‚VÇ^ƒÔ3Ýó‹á§C g€YúìPv"˜Š¢W.˜Ø|\VLi´&|Î@™]M²Á‡e÷¶'<Ÿ™÷JrŠéÉŒUf€á™s¦ïR¥ö}W0§Éu°©›Üö&ë KßW¬bÈ_Æ:õ—E‚~y\Ù®vñP©1ß+`QÉúθ³ ­nñT0“Êï¾`Šmw²V2ÿË}H3öû ]¦”ÛéSÆGVˆ²zA{hþ®õÓÁ4L®¯|ëtñï̓ «±è‡¶` “ëzK©iÆ¢ùÓÀgsêªÆí]Aÿ¯¬w,å$sõ‹«TPº‚©ßŸÓÌbúb0-ÛÛøå¹ïÀ´†U³îLOÄOØsý˜.Êõ‘¥“Ü?1c|²tiøL¥ÕÕûWöã[)lŸuÝ*1-ËKß½gLÂuž©gõŒ)¹Þ0’ñï³&4gõ›`ѳ0}> «'-®£Ÿ~ïvEn a|'ó£öÓÙá×îC@9éæ_+¼5<¼žÕ¼×«˜îKŸ¡’ÁìÆÔSÅ]à··SÅc^0\Êý%ŠC¯7r?ÝP9TûçoŒ“gžÙ5r)¯sÍÞ,¬¯\S羿ý5h4øÌ”Ú—MÀ4WÖ•zwù;†±¤ïÊ—ƒ7Kj½®c멉Mj°úBb§Þ¿ƒ%¼ÏsG'¿eŸ˜Öú)ð}Òû~“dÞ ÌfÄ6ô‹dûz/rú¾óËý`‰™V³ ­¯ÿ(o™Õ1¬PŸú]å|ý² ã±Äs Œ˜oç: ê7y˜ï±(ëÆêÃjÕRq]aš1É¡Ÿé Ô gHæö#»ºÿ¶eZ|>˜£Þ§=;¾Luçnˆ?¿ ¯FJ8°ô‘õ oˆûê`™<’%6¦³,a˜¾}ú- œ.àûîüú!V7â÷0SÑѸ^-Ëðý¾½—Ϙo¹Æó®SÉ„à9ãÀ„}¢Óç†8˜ýg›^ß ·ª½èg°Dyžs½¯ÓKõùüü—|^‡MGÃiéÏ™ÜùöòÑfÆûù=[Eù˜û¯;ËÏYŸ«>ÿ x¿P>Ï}‚ãáýèñû• ç/‹ã•Æëô¼;­ç%;9Ë×m•p¿op^Ü­ªã8x¬å/Íò÷®‹pMxæö£u£ß¬È;ü»5úÅú Ï”x£ë*»EàOå>y–Âçu¸ĵy”ãÓMÿ!~§õä’ÝL¸/‘wÑyxŽë±•ÆçÑ?¹Ä{ˆ×ÜÇÊëÜ_ÈŸÜïÄÏW¸/zŸâŸÛy™ð)ú׆ÏÛJ>ñ}â/|ýbÍSÚÍFyó Å%Ç å??—Žh'ñ ñòTÅy‘ïÉNPçõUâÏV…ð¯Ä‰ ã—çäDûQ^-ƒãVÄsâœãÒ[¿Ä”¯A‹Ï;+í" ß„ëò”ÏñH(ÌO|…þä~¢ýñy̳d?[Y<’}i%é ‰¿’m•ñzÁ¾~¸į•âŒìHù¾ >ç"äQÊ»”?p„'ÿÄC~ˆâ1‹’Ïɯ_åcÒa”/)Î-èwÒ¡je\oÙt¤ãTŠ?„[k¾  i?udü‘nr§Ê"p|?”§})Äg¤[l¤£ßlq}5pJÏqAúÊOYßð¼N÷i¿øœÍUX>ÇqMú õ”QÚ•ë5ÒöPEyãŸò÷{Mª?Ю¨s(^HoñúOŒ_!þl¥„¸/!èÉ B}“£Œ~N|YšpDñ†÷+ ÿHçx+uá‘ï·<Ú×ÇñiRÆ'çQÒ³Ês ]'ýDvæëáõÉ_âOùÈëtÚ/¾Gx'œ‰ëâëóò½³Ò.<¿hJÏQ¤ºÁ ä7^Gb|q]EºÉO©‹(ðõ>ø<Êú‹ò·›³RO“n¢z’ç{Ì¿\—hÿï:€Û×DxÁ}R^rUÆ ÍGú€êHò·«£`7Šs²s ²nâï?âÄQÈ_>JÅmieŸGìïð¾Ù•êOeÿ†Û…ôšZèËi^$ž ¸$»ý§ç/i»‘]i^­²ãû&Ñ8dOµ`ïÅìƒò áŒüå¤ìÛЗáñ¬ðI¼à àÕKÙ'äþ)¡Œî:~TîŸÏ#®ÃQ‰®CUߟݕu·›Nà9geÞu4_‹ç>ßÒ{îJ¿ó¼AüóD™ÉOœÏ½|k?k”ñÎ÷í ä=’§x|òÙUÈËÔ§øŠß)Þ—z¡¯Cû¢¾E™/¹]D¾tü¡òáD|NŒêóQŸÝ"ô¡í…~º§œD¾uŒ2oñ¸ÓˆûQæ-Ž÷'ʺ„Ûúu÷”ý7>¾· ‡>× uн°?eŸ–÷íï zB#è>â¢bî8x¥äË/~òå½À·~Êøãøöâ‡ÆÕ ý\oe>yŠÇC¡€CÀkÄ+ÂxîÊ>çÓ’‚ì…|/ÎOxvSòðÿ‹KÍס¿Vá»ç•ÐOpÇשúùÄzá;“²ÃãËU™xôøÆ^ˆ#â9Òy"?9 ºT£Ô}|߄ҵáû’F𣿰ŽCe>à~U y]ÀÏsÄ÷¯”üÃuç;‡…J]'ŽÃó#é3¡ó•ø–t•Ï×W_ôŠ Ãì¾qðã-èN•À?–ÿ®«øû^?«z(¿'ñ¼ü\Éÿ<¯ù ß+•yYÔûœÿ^O‘p^Ìúr…¾P®P'ŠüÊ¿?3.Ù—ÛMðáŠ_â›#ì‡öÏ¿‹v»­¼ÎçÏ+fß^øQ°?á‚÷ ÞSò ?ÿ ô—5§˜ï Âýá=‘_\‹Gž—ó”׿òG1v£~£h±?Æçünãñ¤€/ÁþÔ_ä8¸-ÄWqñöâ¿÷Ï÷yï¿y€ß/|?¯„óbìKýsþ\ž€ÑEʺœs< ë&û|µŠ'Êøu_G¾²ÿýÕún ×óÜç|/ƈvß/&ˆóÒw›JüÝýÎâäÇ—µ˜8ùôŸ_ì¿“Çi|>ïåï×Äüü•½)ϾRþ~è«y„¸ãûê¦\á{ é#•зó Ï«d/!Ž¿²{Þ籯ö—WŒß‹É“|ô^ž²^u‹Èëü;•½2/Š~ÏyüŠþóQ².ä¿#x_äÃbóÑme_å+¾ò$·£ˆëÛÊ}}eï|áws'•öåëºýß|À×ù\àKwe?æ+}RL¼ï‹|ÌÏ]Âë(_¹Bžåó:Eä~ÿ’ò{¾ø»6®k>*ñöU~êþ>Å7ÙËN™W¾â­bt×?ŽÂ÷áw¶_ñº˜…õ[‹‹çâtÑÉÿÆÿþ®R®C¬#¨^à8¾Ÿqÿ½ðQ èò†Ë?8ƒŽòV! ßëßCÿGÿ(Ópžõòó±8/ý^1+\>ÀqVÇqä_ÆAÈ.™'Ãp]Ñx½#žwÁõ¤àüÉÈ«Yçåóž«äc$>Ÿ%ÿpšï?÷ÑqŸüA^wì7òú¢ð½¸¾h²Î;È¢´[¢A~?÷¹I'ßÏÀë)hOŒ ÅïÄxž~XÞ_'¾ï÷§ñpþ¶ø\^E;õ].ÏÓ×ׯ÷C{¥à{ah‡Œç¸?ôù=ßo‡çÑ8OŸdyÝÑ©¸o¯¿M‰ ò[úù¹–è׬òûaø^*î¯â¥^ïï‡ãüýqœÁrÃâp=½hÿ¸ÞÌ9ò±+â1Ç‹ F<Ë>HEœ ÌÄõâ8ÐÔ¿‹ÁqÃçËç­p=¸Ÿþ Jœô—?ø@;|¿§E‰Çþ8ošO£ü>Bׇàºbÿvˆë@ü¦Fá~pžseû¦áóø|/мÞÏCñwçQ8+ÂçåºSW-ÝåcÇýßâã=çK§õ£_ˆßÓ“äû‘´ÛÎé9šý—…¼‰qÒ÷ÓGNìqžŽ×Öàø|ú‹ìÔÿûŠÜß“Ýúáq^ÆÏ¬ë=¯ôC†ß)cñ½Dw¥NÉ+ÏŸ9Ç£8£œ/ÃãwÚ׃ñ›r ýˆñG|Òßï‰~MÂuµ§yÜ•ñnSúi@¸2®ãi]ˆ›Î¸ŽÁÄsèpÔ­hü%ïÒº¢W)óv$ñ8Þï‡ãÆÏ“ÝËãwDž'ž¥}“½Éþ½pžø<é·¾ø^òz$Æ[ÛZJ øk?PyòQ éÄ{¼øJ·(uå‘Öø|ÿóJþ`<„“ÿH·]PòFÚô$åÁhÿÔ¿™>J;SüÆày®/çkF|ƒú£%ÆS&®7½­ü\SÌo1¤›§Ä[}‰q½Y8>åSòo?ÔŸY¤cp¼dŒÒÙ‘ˆûR8oÌs¸ÜépÊ;‘È“Q˜/S(gãü™Ê¸OÇ}§âx6ů5TJü‘n!½…<Oùã–pÚ ñ‰y$ uHgÂ3ÆÕ!„S²k â»>?˜Öƒó¤£É¨g’0%£}ã(/‘î WÖýP/¥‘N ýÏ©”ü•‚öí‰yƒð‹ó5'ý®äНþè4´ËÒwÄ‹¨k31ÿ‡Qê˲Æ[ôí“ó:æ3Ò{ô~•r=¡O&£þθâù8AσpßÕIç­E½ˆö‰´(ù°;Ù?E¾O|‡ñÓI¥Ìï1xT_!?Ó:£Iǧãzzâ¸}©>C¿Ð~£…<ÂëdPÖG]qÉÔPü¯àÒÓzdÑ|þŸÁãÿ>=£&þÕ>)qÀ@úû Þi™ô÷¡Éé½h é:½à ݨ)Ìâ2 chUšI-ýŸé¥Å~úôÑ]\NRjâ@Z]tí•8(±jŸì}vöQúçÕœ¬öä^gss/data/clim.rda0000644000176200001440000001267513267106071013411 0ustar liggesusers‹uœyŒÞÇYÇßxm7NÇG|Ùõz7ÞõÚÞë}wß}w÷w/ï}{Û»Þ;TŠÛ*)DQU¤Ôª‘‚D REB¢ˆÄ>j¡T‚ ´(jƒ RHÓ6¤Mš¿¿çóô}%Þ?<žùÍ<óÜÇÌØÓ} Íw-Ü•J¥v¤*vîLí¨¸ý×;nÿqGjgjO±³þÐûo¥R‡’9©Ô¾ÛÍÓvì÷‹¿?´ýg‹¿3V½•üìðâï°Ýù·ÅßsvÇ Åß7òÿühñ÷Øö÷’ï•vòÙâïOíò+·ßÝaõ/þ~Ójxi«JàÁΤ’ŸzªøûŒp¸Ûoõ3ÖtÜÇ/ÁîǪ8¿l5ì’u§¯Óa·ãö'ëóï÷åÅpÈ¿çßñïù—Z’ŸÆÃžï»ÂI)ÜAÿ8óö%øþn€®p(¡÷ç·?—ÌÛ» ¼í·“õùç¯í7zåáK8èûoÿ£ÏÏÿk2¾ÏÎ8¿CEÿ+aó5œr:Ã>ÑåòÈ'™·ÿz²ßDœwgBwW8âóÂ} ¿~1T:ŸC%ôT&ûÞ*“}¾ª>}/Tç,ß/BÇëÎGÛ‘´¯[Ê÷±]Î'ÑÇwzùòÄ_Oæßp>lÉá¦øi¾Õ&ôü”U$ó?¤}·_e^]2¾¹ýf¯?³»_¶7¡ó“vËÏîdþn—›Ý—ÀùŽc|?í.ç³@ÞçøÚÀ½w;>¶ý|Ñ×o¿¬ÿŸí%ó.ÏxþûŽ_@/5ŽºþäEÏ1—ôÆîC?þ—þA׋üknÛßLÖ?“Ç>ÂŽw8”àño¡:‘ùp6Y?j“yÍ¡6ó¡Þù°ÃpÞùÎ1~.ÿw¡Ž¶}¸;¹»8áüÌ'Í+ßøž‚ÎÓà…>Û]É~õa—Ë'ÿWI»{¨võ¾‡À»½=œ~-þ¤ÿÔþ;ÅþqküË"ÜqKçŠû?mm‰@?b N—5'ûZšuM‰‚>aáeï$û¿f]É~b=õÅöóv%A8Xø½nÿ–_*âýŸÖ“ìó+ÖøE×£Þ„¿Øyç¿ÅïÕwµÛ™ÕÓo¯óô/á7¿îãE/ð2(âù²5º?l„ž¶Oáž°ô ŽWëYçKӳγ®'öz¸—öëâçÏãg‘«wþIÞ²oÙoô¿‡ð“'Ñ˓ȯ=<üû݆Sø«÷ó¡.Y÷7¡ùŸe~=ãÍÂyàÄÏI_àg¸@+?ÿzŸr -ÎÇÐâzv¢÷çÙ÷2öq {ABšý›÷}›ß!ãüiדq= ¾£—!K›vý m®¿q< i—ȺœCó;GîyüüeØ<‰_ïÅoüq\~Lñ(ÿ_Éüß øó°¾ÝKÜz.™ÿa?|'®…ôO"WÅÏäFÜ ÄûpLñ)Ù§'ENгÇÜτӬ«Ä¯)^j?ù»‹’|k‚ÿì×ß2ð1ó,|V¿Ïç·¿âúОðãDèp{ Y÷¡ºÚ‘{–uš—ƒYäååþ$t`ç5îŸíˆç+v–üý³ƒØ] ycü´Û•UbÇÄ};ÌøÖÕ71_yUþ?’ý´O8¾çÜß„*ò‚Ê„Ÿ?“Wü&·£ð“xŽ#· ô°«:Ïÿ"?3ØM;rQÛ†¾¶!7µÍðOòjc~¹´Ëž°ßvɉùY¾·}Üí:ÃúŽ„ž'B;«Ï Ð/ü³È­õ­Ðׯ~9ðȹ¿]ô»ààw gÒÙ¹à´ñ½¼ÛÏ2¿]zÞâøÉ_H/sЃïð7 ÿ³ÒCùæu'2NoŒ#Mõñ‡öq4Íx qj§ë©ò!«v>(ÿ±âlqº›õ]ÄÓ.ô» }Äò²¨·è ÎP<«ÃžˆKŠ»ÇÀ»<‰v‰xš&~6W‹ËÑZݾ-CÒ_š—å!çÝÏY+ùF~¦Y¿-¼ð5ϺÀ7Oú<Ïèò’vø˜\Åô“ýbÜ«Â/V¹‡ÃøÑô¡Nq™>rø¥˜÷©n¸D+ÿ¬zå}žÇ: yl'è½ðﶃøC~ =1ÖË/m¿Ì÷ÝÊ»_™´ЧíçcÔ§Ä'#ï°û”·ð]uâü#õ]ü”‡³¾ÝOœ¬òÍX‡Ö2~ÜùóvÕy乪â}hÝÚFì«Áã–¡ør¾¾¦±Ï,~&Kž¢8'?˜E>ò²ë6õåoÈäŸäg;å—ˆDŸ²ø'å5ò£Yàu(‚W=ꤟûT©ŸÌÁï~(GüìÄb/ÑOµãw³Š«à-ü5žÃŸåàCô{ÚWpñ§Yà6§âQ‡ü½ü+|ž­àÕÝŠ?mðMþZë•W´¶”Ê/Mœý*?h¯ä›ÃïKnièi¯VäwÚõ6Ƈów:ØOrkQd~‡òð?‡P~\O~Nœˆü’œÒ´­ð=~Íâ3ó•G×w;—„'z ¹fàW«üøáoC«ô}#²é1øeÅ­C_³ÒcÙ•úÊ_À_ö(ù·³žó‡)Ë¤Ïø«õªDâyFúƒÞ´Ð×xú.ÐRF>¨ŽQ=uÜõ"ÿªÇå÷ø‹¾Êî”§D>–å±²éG§òé-ø´0¯¾P_êâp¸MÐw|Ku^z‘Q>£|EøÂ§xuÑïÙ}'ëÔ*?êFï;éç•Ï¡‡ÊŸºÓ Ü.Õa[¥òžDžÐ+ý•þ4‹~öÏ0Ÿ|è}à1 ÿ£¿ùoì¿5ù³øù+è‡ãÀ‰ëÁc:&èOhí„ìíz&ÀSþq:ÆX?†½'ú-ø4^cÐ7&{b}ô—²KÍ+ó¯Òoù“~éø©–==_j?²3Í“ß`Ÿ~éƒôEú$ùAW~K¿ ¬èi€?õ:߈ý­Òs±Bªt]žïyöɳ¾›}:•O(WÞÎ:åÓ…½¥ëcœ‡Ÿñ\DçIÊ—‡ŸÁ³Uyß•o73®sÝ&µÌ«g}=û<žgÁ«Jùïh©=Ëî ò'ÀH•Ê?úð‰v ÿzkËìq´Tž=’øX/¹À'°_< Z‡þKþàö’?ó$¼àjß;%Goñ]ú¢:,ZÙ¯‘qÕê_butluž¡s~sè~ô0ßé¾”–{´ükô¯(î*>È˯>^jGýòŸ’³ä³·ÔŸö.ó£ß–]2¿‹}ºU·ªþ…/YæØGòÒ¹s^õ/|hÓù¶â‹òlÚ‹Œ__YW¯qõ™/»i”œø~‰ö2û_|Æ9—‹çÄñü‰¾ìæŒü~-À—væ·”ís¡¥Ô.«iÏ—ûÝû£¦[±ÕùOÊçç¿]:?ìŽÎ½0~ú3~DçéÀ«Õ<¾W–é£îGÎó]÷MµÌÓ:éëñlêIâà—Èlj㬟@?Ç•g+¿¢¯ø¦869ãp§Ùw~O5x;«:ã³¥qn8ò_Š;1_V|‚ÎAôUyÙ âšòʲ8ª¼Pù©öeý°ò?ì4ÖÊcá[ŒïªCØGùÃØVi^1Ëúé?€|§~W~!¸¬ŸÒwøÒ®sðP¼ Ì— øÙ»êÎ.Ýc€gü ª[ËülŒß²ó½¥q=ú£”ú±˜*ÿ?ù«˜¢G1•Å·˜GË¿)¯ÁŽûTÇXižÚÜ>øÕ·U–ß*^–åIì7>ì3åõU¬»T'„²v«´.QÿÊhY\Ø[êËó„‹àÕȺ‹eþIv®w 5ºƒþsŒW齎îËé߯w:?@~ÜcDØB_ç.-´zŸqRù ðËßoTóžEq‘ûè÷/ê¾]~Kø—Â7ò.«áÜž{}#ŽX#ßÁÏZ9'¿±»uŸ¼Ösþ­û"Ãqȸ¸¬wô›Ø—óØØ Ï6æqnlœoù¥uÒ'¯1òOãüɺ€OläçñÝyˆ‘?ÚeíÏ:ò^#ØEµÐ%~51¯™ï‘.ðȈO¢‹6§{&·ƒØâ ÿñ@Ïã=çìVp»y¯e¾îËÈóŒ¼ÏÚáSNp„ZÖw‰¿ÌÇÆ{2Ý’wõ…å™[àG¼×òü×ó ð¡ ú€«~Zð >7ü¨õº3ü˜‘¿[?}Îlü9ï0âö{÷ŒW•ÉUïœÈÇ,-{’><^ª/âk:Éû"žøs£>4ΙŒó#nçD6 9À‡j½§ƒžºT©K/›õ> :ZÔ—^Hoõ~ ú¤¯iÙ9ó8ß·-çÔ‘^êRë¯nÖ‘GÆ{Ö‚øÃ|â˜Q7Gý‘]Àù!÷ÇÛ<þÿC>:áõG󃿳z,ú}÷;§b~«¼¹Yù8­îû”·7ëþ^ï ðïiÕ ª{•G$`Nm'jØüóü³Û<ï}†{Ògñ·»¹WýëøÅïããýã[~{Îþdü:ïS^Š÷¥§8§-óT™?‚Ÿ—Êê6¿·})ø{̆£ïÿB즾þUχŸÛª’ïßåý泈=vÒjÞð~#™w0ø}ícyø&û~ÙïŸ|+ÿzÒþtÄã0ð=oÿ2ï UÉøo›7¾G“¼ïU÷œ/«_kü¿ü}õÃÔ[¿ã°§õ¸Yç Z§ú§Qñø:—P{™Vû7èú!=jѹýfÝ/1Þ¦ý€“Ö»w(OÐý¥ìBp¹?ßõÅ|BúL«¼%­û5ÚœêYé¹ÎFKëf‰oQ.¬×{ñávy=S^£{7Õ»ÚWù–îÛUï+ß•=ê>*(¶Òó8ݯ©ÎíWþ¯ó^×–Þowëü¥ìü¶ïøOž· Çz"ž³~šù:WÔyìUðŸiî™ætKtƒ}V¨ýaGXî*p®Ã§•Œ÷7™·ö-_·ÿÖɧ7 ?ëÕq£:Ofþ¸è¡®˜¥žWÇúëì»]רÓn²nõÛ´¿îóVÀåÎê7Àû-ï¯S‡÷"‡iø¢{¨iè˜Ér_¡ó_àNÍ”žëªîÑ9ºÎç$ÏÞ²ó$éEz Ò—dÿBLºûÂPŸo†)í˹î§à×´îužÀ¾ñÜþM/½ÿ›F¿¦ºfhç8ïŸÿ͇OsÀ›Ñùx̠׳Ð5 §¹/˜A_g‘Ã,òœAÿæÑ«¾ Þ êÆ•SÞÞÄ.n²ïê3Èy}ô{ x«Ô«¥V =YgüvÀ¾q~®j?ôfºÔÊ®V„ï«ØÑ|¯£EÿWЃ•Núð…{ø¾ßV܇›èÓMæßD^+ðq¹ÏCÇó {¾/¢W‹Ð·_5¾€¼Ç"úך|¡{zçð#³ày9Lë;xÎПG¿Àc=¼kÀ¿¾+œs-w‰ñeð›ûªÃ¹&?Âúä(z¯£§7àßuÚeüÌ ö_‚þë‡JÎó¼ûŠyçeoƼQyyOxÀóóø{*Öœçq-Ö ª“mZ£þ}•êòq­×ºº²:_ùΕå·Âhé;­nS=åq_÷5y££G:G­"R¾\Kž£VçÄz?¢üGyŠîyô-¾×/ò6?Ïxî‰P‘ô‡#Ÿéóþîcþï¸>³Ûüß_õû›1¿]§]¥®Û˜¡uûµ,ó¨;ר«6‡||cί{Ü1ìØnRŸb—¶ävcè¿M¸þØTÒÞ²÷vÓ6Þ[Øû©?éva3äá¼'±OèmùO&öØaÜW÷¤F¼0΃mÖíÆæ s<ܯÙ5¾/Ò¿œeøC<±™'Ké™§? =W;¾×€·7Ô¢·ËÔ³+äã+/Á?øK¼°Y÷7†ß°Yê¿«à5ßæÀg¹,P'/À‡÷›vþ|›f\üº Ýóè𦽠¿ÈclŽúœ|&óເ.#ßeàK¾Ó¢83à1ýó´âç"rºF{þ,1¸aÓÐ9‡^._µ|_ü*ú>K¬_úb©>ˆïä¡6¿›Vtƒä½Äøü›¡?‰¼¢üàÿ¸ìüÆ’þ>›¢®ŸIöÿœy¾tËx¯`“ÈEûLHn²+ô”w*¶Îºõ?' ÏÙÀŽ7=þÚ:yAÌ+‰3¯“/¿Ÿ8ÿ÷ä ~‘¶ÈK—/SËÄéeâíMõ‰;ËÄã>âO|ÏÀ¼üñ~sB￈‹3ÄÕÝçèýëtO£wKù²ºQu‰òUÝ‹äu_Gš¨õ¾@ïõt¢~cÙ½~ùý²àgŸ*¹Ï°qßá/xc¼ÛˆçvÐõŠw(æïIl =LôêŸl}ç]JÔÞåÙÔ§ñ§À¿.=Æma¯[ØïVö _Öñ“kj‘çšç“¶Fþ¸ù‡»‰la›_qøßÄÞ6?IK]²Y Øýyÿx¯³ÏÊ êüÊ2yëMêÁ5êò5òSò“pƒ<| ûVý üר#Ö¨›—TWP§¬y~ÖÉ£oPWŸÂJõõÖ*ö¼:Éú—¨—°×Hãò—/’ç».û¿ *6ŠÿµAêÿ¯ v<ímÉ”]ë­>òÈí¿ìÿÉÿ¡ðÈPqìòÉX½µ©É;4ùÛ·>¤¿?¸ùÁËíyøƒ^Ò•¢½ûîÛã>±âݲÝïÚXýðꥭ‡o/qRïü´8ùaÇAgss/data/esc.rda0000644000176200001440000005462213267106071013235 0ustar liggesusers‹µý\ïÿøŸsŸÝ.B6%3+«× ‰ŒeeWd“ÈÙ”YF‘½g BZHÚ›´µµç©ÓÿÜçtßýÿõóQ½¿ÿ<Ó9uîë¾®×õÚ×<½EÚ2‹d Á`±Ù ‚%~È&Äÿ0l†@L–åvsñ¿Äùbʋ̒üXúM4ûnþ<ó/?cþãgc[þ.óÿñæü&Úð3â/×ËüËgg¶âšÿõYþöÜ¿>ÑÆë&þÇx·ç÷ý¯ÏJüãÚÿ6¦D;î-ÑÊ{Ñš¹F´c¾·vüþu/ˆv¾ï¿ÌsæÿX£Ì6Ìóÿ:o‰ÿ°~‰V\ÇÿZ×­“¶Ž)ÑÊyÑšuB´a޶æ:Û+˜­œÿ󰵟ƒhçße¶a ·VFÿñ:[+cZ+¿‰ÿ8·Û"£ˆVì÷íYû­½/Ä?žû_s•øûrku¢•úAkç1ц}¾-cò­Sýk-­Ð7Û«Ãí¸§m½wD+e>ÑFãÿJ¶í¼§­«­½oDe:ñö¥­¢•ó¬5r·=ú,ñô*â?ê(mÑõ[;§[£sÿÐ ‰6Ú}ÿKþ·GGd¶cîþk¿kÝK´s?hÍ=i|üÿã.àn´Üi¹q»ø‘’äÒg™Ã©#š½žc¾qÕvêåô/Y³ÊÜf‹µø‘¨.‡¶ˆÿ½ÿ_ê Ñõ„håöÙZG[Ôf¢ â‡ÙNÕ¬-â¶µjç¿–bk¶‹¶˜Ÿ­D+ÜS­Ù"Z»mTyþ5nÿWs¹=®™Ö˜õmY ­ùì­¹wmQë™mغÛbÊ´EMi«+±­×ÑU’øÇ6L´Ò„#Ú0ÿˆ6¨LíqOíP-Zû7[³N™møÛ­ÝÿFë]Ž£ý®óÖî·­Ù§˜íTéÚ’híg þ£ZÙ–çÛr/‰6Ê@¢•k€ø?0ÛˆVŒ9ÑYJ´òw·ÖD"þÌ©¶¸òÚ"ikè†håk­ÙÙÝ¢-úm{Ü0Ì6êÙ­]#mÕ§Û:Þ­q2Û ó´Va¶A?'Ú8çZnh­¾Û–ÏÚ—a{t`‚ѶPt[ÝBÌ6ì[mу[+#‰VÚ^­Ñ«ÛºnÛàJ&]Dÿœ ¬†VûZ£k´'¤ÒžûHü‡}³-ºjkôä¶¼¿-{ÑJùÔV×~{}3my³vg[ÒFû\•­ÝŸÛ*ëˆÿð¹Úã.o«®Ò¿³×ÙÚuÝÿbkÖk[lô¶Œy[÷ÿÖÚÙm -´%,ÝyÕZ]´-¡.¢ {V[m*&£õ>¶„=˜m\ï­ñ£¶Å_Ñ}ùÿŸ©-mñ•¶W×i‹Üh«_h£žÒÚ”‰¶úñÚ–g¶S–m°U™ÿaßaþèûíM?mí¼!­÷}¶Å¾jKÌ‚h‡¬k«2ùiqsŒ)Be\…Þ»®åÐÀÜmp£ž"2æv˜áÙ{7M¾ÍÌ{à'`4ûß¡—ô5d-·UiŽ‚³U)74(BƒË°/sÏ5ñV·;!;ØPñìgöwÖ|¨¹ï~O93¨[3×$2w#…{¯N˜H†…|ù}†"|žÖ+ð“å9ìx|½µÅ­õ¨û®øçÎ33øÕ‘ø È/Z?õtO”’®}öÆ´æQ /t_·×P­ÓÓa¨¿#ü ͪÂI¿Ó+)ØÁy#øn_ø{kú'”=³Gñ½.]§yE2­Ôh˜m]×ó#; Êô€ß±^«ëë@tðîžëZ4;Î8µò[¬š3lÙ;·ZTùû'ò+S‚¾ÇÊ‚hÓ¶²Õ«C¡4i†×¼±ìæDÞ«*Z{Ý¡LCuÙŠ›ÙÆëÏvüñ&l •p%”Ý‘ý%òâI¨¼ž>uÁ¥ß͉ÌçO¾?QCÙ5—Ÿ'‡íƒ€š±gÒY#qt„‹†ý<ø¾ÂPoʧçßÞ“ûJwènÝßyEäîØÀhHB¨ÐÚs{Ùé=þ`Ãþ˜n;)"GÑýèÍÎÿ"”ËÍYÁ‡GÖ óEV†«g ¼,Äd–õÒ/„ܺ=ã1¿C¤ö{ÿMaã¡r£6“-G³:Ò3ëJMÍ´ÅÑÓNEÉ¢ÜN7uï‹C và‘GÓOGY}昕Y=@øÅé‰UX%òT¿$ÖpÆCÝð\ÙϯV cõ–•©ùVÈ6Ä5ÿl•‹ÆÏ÷Éô¡|uoIÎo>Ôïž6Üñ ‚,—k<ž:š¦¿nm¶ÓÌŠÈ ]t_õœK`¾=`ÔF® ã ì¹Ÿõ¬U‘»ÝíB¥ÛcšŠCt÷u0F¶÷ƒcþ"»»ÍŽîég)Bz½L¡ë·"=þP¼aì±¾üÉ1,_µ£-'^yG@ÍþŽcƒÖiAÅŠ—µ›Š¾ ±ËÅ37Ô‡"T^Ý(()âý sFžÝƒ‚‘åZ"ÓuݲóOhùuWFÇí½­ƒr:Ú;m"ÁuÓ쑯Çi· Ðs†ñÃuHSäÒ-¿‹òìð{¡¶j?òç„},èð––«J¹ÓsBAݧ‹¡G ‡êSêµ/dïSDÁ¸ ã­^\¡É~Yl꧃œogÎÜq›9ÇïÞ={) Y™ïni-Ÿ²K+ûÙ‚Ä ÷)»f^ É¼qSa`j1Ü NȰx Uß íäìG3å¶üÏUõ¡6õàÏ+í ºàÀÛoSNRDŽj”AæÜ›Í ³û¤Eu>ÛœÈÙ9øYr9òR×—¯¿y‚×Ãq¯¼š‚ܘHóQ‡>"óI–Ò¹­uPó4c‘æ©O4kŸ—Eߊî‡üÞw»èV†¬Ž ý^ŒvAŽÅñ7צõF–FïßšûCÅÆ}ùDìdÅ _(B¢Â‰E ;.C­ÂM[ÖF7d¤+>áì?sæ æUCî›}#²V"cÊî…¬Òä Í™‘&û†Ö£ÈJ&½[˜^f,¯ÑÙS\Á±ƒtÞ²›ø{y7'”pžñý Ê=šò²0y9‡ŠSΦ)¸h²ãN×ÙÈ\¢H4hT]:ìÃÈgp™”F;¬š“ñ—/¨þL¿âx<ˆê¬t½ö e– ¸­¥ã ‰¶-°ï]L®†ÇÒä-Óª062mºO6”ë¥þ€ ‡¯¥õ>"d8Z\ÓqpD>_ôtJ®Eˆ¬½œ¦ýzEä“éÝÑz?Eèh½ï[ò›##Ê|{YŸ˜Jêw°|ºY¤RDB–u½¸d M.×y_¯ßsQfÜÇ”ýöã(B½Ñë~㮦YfþÕê‚®½®¸¾Í7 ÷!ËyÝç—C¥h+].^î©>ίY=ó‡ÈôÓ‡o~Ëæ}Ú Ÿ}¢÷ódŸ<©ú>~-ƒ68‡F4 Ó_/W·ûUäêMÞµÕd2´bðgÓ”ï_ïô¦‚&ßÐÅõãâéPJj[òif\e[骆Úße¹~ê4+Ã{èÆÌ‚"ÿ»&¿ößGÙòÇ—;§t¥ß5cR7] ˆ¬Ï­Ê½z£¢œžÝðh3'…æiˆxÆš¿írwú~9)иöLu£í ‡­C®àEí›-})ÂRýúüeΜrx¿,2”3‡ª¬&(6é}YÚ=WNZH*ž¨_ц@f*ãØØ÷\ŠÈú”añ!x¼¼Þ)îg×ÈœwUCQʼnï :…L‡ñn%+š Ö#3 ¨T€òß·®|7Š6å_Ìr/CþéÑ}{ûê@Ä>sbHücŠ(ó@–+QVcrašš#ró­uÓÞ÷¢•u©Ô0!?ëšJHr ²f¼žöÙa3=U6[~½| êòCæïø’„Ìð>[•:@5)­Œõhú÷Ö5ÏI¾úlyKï$M£bÉþHó§ 7·Aî2veé¾t­„xñj}ëM³ÒûÇf#xÙ‚µá9OæÞ= 5¯ÅÛâÈí g¿ú\Ôß—`]6éoDbx/ŸÁZ (Èóv]ž6DÏ)žóÃ" ݦM;²ŽÆ¬˜ê­Å_/y¯•Aî*?=9õ4åý SVõã¡Ìî%î»DEPŸTS,PDlËý¢¬z̆S„†3¼[¢z£¬í»(…Ònê´óÅzSu×_/›· ¹ 1YÂÓÐej E¹ß@AHêþ%»J¡¡tøÈ»ÖšÙŽÌcÊõ‹A¤Uÿ*´?Î.Iûž…J³ßšñV,7>v]zÛEò×™Š%$*D/÷žfu/gê}ö¥zA̰§&Èý•ɺ§)Ô‡Ðü3¾lÌ÷…ŠU-™­P~%Äרäre'‡ÌR¡×ÑË"üô¶MÈŒÞA*NÈqwì¡9s(B}̸_3z™@óªŒgÚ:”ÿ¼õ=sŸ;”,öo¨ æ¼wçEéj›ä®vA)wʸæD®¾B‚LçÈ®?r®‡š*Tžÿûè[x³MmzøíõP–›¼?„‡ã–ësiæ©ZúGíâAI¯áÙ ‹Æ#/+Šûe[ˆÍ~™ ^ªQö w>c‘j ²—‹œ»ìTƒ¾FÀ¦‡{ †5píœN#[0 dü,S«dÊï>uð=¨_ØÏfþ™2”¹1Zí=ZQ„T•@ç)k ÿ)ž#×ò—jÈÆ›(—ýeÖ²P À–Y9£SPy½®Œ¥úM\;#hL4Ä®+?·r4EdöVÂôø•ý)~>ß’@Æõ j_ã {ýõÍù[ Ê¤Øs~ÏØ¨¸ñIꌵÈ+½l=f?M™ýâËì∂EìÈÞj!ÿë…ë'T3)"óY“C:Èžà|òuo>ØZÚÎïñJŸ"²äÙ¿»„ ¡)[Ìø:ÿêI¨R9°üHñEX3¸þ¬œí/ñ}6pTõ0𠢩k—%kQD9ÎF#Gíp(Æ}¹km Ed]“ÊA–Ûfï#¨’W ’{È÷¾WÞµh+M9áö3›TŸ!ã“Óƒ±Ê P3PeYÄEwäNèºiÝÙld|>scýÈ‹ËܰG—"²iözY»¦fú¶//!Oïô~Âb9¤ª£ì‰ñëºzøõ+2üì’Pã-ðÖù‰\–áÈuoá=~÷®óéÈ\d]6ñNOšò¿jË»ŠÇç@kÉó¡-™Õý†uÕf”{2ìÑøª9 <ðÍi¼æg¨ d-UüEçÆL=‘ I³^¸ï%ÖXë¦RâI6g}'ÔåÝvô¸‰Y¯ú­X’¢]¡£Ãº —·&ø×Î)4y‡_æÞ¯Hr‹Vׄ˜%RDbç¿0 Ò>Þ¼°âZEäú&Þëkž@êí‹HGrFIämsBæÊkŒ£mtµ&xP7¨ Þ›5ÿé\ŠÈTXÅ}Ò±Šo8mÜÿ|)2;zÝÁú.*lôöó¹ÈØo÷N,÷7¸ Ÿö‰{ÝœYûÌiÊÿ)°÷œ¢í«W{0.æ ÆíA–ŠÚÃéžúPãkƒS©×߈œéWGݽ—¦àVï´ªøIÈXåútßmŠð&2à©Ó•Ûâ}÷ûIÇ¡×?ν˱”Ã4™:QË“9š-¨ )Vë3P>M©cÌqä'ïq­U~DS`™6¡K’?EˆP º“qe¶­ç,\Gòï8:dôØÕûŒ‡ûæPDf\ôð Ý¡ŒqÍ€Ïy¿)B Ü~¦ë„ ·;«ö}¥<âߦˆü«y²·Ê=)ÂþçéŒñ>æ ’'ÜH¨³?ûà¡Q'šõ®ÜŠ_B“Ð'ºÉŽ4ÉW}Ä2ñ:»t_-ÉÍ™êxÞï¸EZUú© Ú¾MCÒiBmT¿~·wú o¤™ìG£ ¨©>ã4ª^²YW>Ž¢ˆœc!¬@Íõzä¦íÓ0øÖ’ÂNZn.º ÑªŽ‡ܺՂ_Ýy³ÓêwõfÏ? 绿»ªÀî EˆªujGàò¡úÔìÈÑ(ó«hù9ä÷%ï Ê~™¨¹·v6$\ø3nhO±Ý¾mÁ . Êûù¥,òs„2¡MÇ»Q/!ùÝ3?Ù~4+-ª­7±#Cù’â­e/)BI£_/þÈÞ~æ§.ƒèÏ#£=QPX¿nvÈ+šòN‡ºVES„ áДl³@øs{ᔟå«[Í:uUùçºéûöûóTñŽâ‡üD¯-Σ£ hátÏ™ &¾›Xa?MYV©_£õ¡’qÍÀøÐc8LîÊ“Qág7µ¥_(Bå°ïFÕ­B9åÃÃB¾d#akžùä÷êugäι*‘qÒäA5s(ÔUˆÍÈ„# Ÿ}G9gEDs¢L¦ÊŒøÔÈ{´„ܹyZãT6ˉ} w›»A…è!œˆZ”)•(Rít‡3@dø¯Òi†µ  Ì%wë¶C4¹—TókÏîGþ‚c·3E•Ù‡E~¼¾×þQ Ú-úz£kTn>ÌúÕ|ø±½ÇP…áz›tü¦u¤;Ô¹G^½ü Íòr,¡ˆþ3«Ã¶](BøóŽ{Ò¦?G¶VÜjÛÀe!ÔæKƒ§D¬ÐéŸ6;¼·nñŠ?!ŽþzI>õžnL*5ë¥zq=Ìy_]¾¹+l•˜q—iüføØ8¨qWs6¬{ŒeZ[ÔœçR„šŠÎwWm÷+;_Ï€¸§ƒWÞfB5»ø¢FÉù¿ÚÙuûiƒŒ3ûS£ÂÿìR( ;Ü5ªÃršuÞd:ùbñõø`aÍrµÁ§ŒØBuê?B¹8W{=ß'Ö¿Õï~÷ìò¿ŽËK^,_‹–\2tÜO3#ºÃØ|dŽÝ0Ágb27ûâé3âýørqá¤£× ëíòÑ`÷Ù}'9žMSÅ{Û×­Uo‘ï·T߸,™2ѹ½ýÖƒhجT‹ï«:[ËÓT¼¦Ü?÷Me[½-W] ¡òÛ.–þÏeâuy·ïÉËÈlôÖÔïéàoJº„/DþØcdnwEöïÊ úÛA6ž\&»= ¹w7RM“ÙñÖW× $Žo›:nü+Š0 l×u[ÃäX«Ö}:Þ“&÷HªÉ:ù4ŠÐð¬vªh©²×[õ|ë'änê©t t!›í]qo¤ͪpH™±”f¸mšOa·j(î%PÜ>Þ‰ŠÜ4“7Qfðï}¶µ(·Ra`jÑèÔø9˜=SzŠUaäÊÔ¾žd¡Hbóª¼í”C‘ž&gëÇTe"q”tDÕÑÏ'ùçíéƒDà£ÛêÛȲúñÃÈhÐòd”®X—3ʳç,܆̑Ãü-7 {_¿ëzµäxy\½J>;ëŽzõây'WMñ–¦pʬ‘IÕ)4«£]Ìu^Ù!÷ƒùê{ÙÇ Uâ=êŠáö?GBÂÑãÎÉ—+‘1'ý©v_ñ8¾Õœ<9×ê{žš~ëÀd(n}Æ)v Ôœéòø˜1TˆocäI”[݉´Œi2L]:¿Y¢Ij.)¿øÀˆÞ¿XFb©4Þ²·—uÊØf‚„±qöü•Ȫ“8@häCZ˜ëƒ:N¨Ø†ö½nóbŠ(ïukUfÕT<õ@^,B)BiÆÇê‡e‘«[ÿ½ÒÊ23v{Û± t速W§Ñü£)£ž(VjÄW5ž¢ðÚý^õ‹Ež3÷Ù½wžÙ|È÷Þ‡Ðî{&g퇟§× žÇn [¿2×0ÃD+F2~Í6†º¼Ò†ÚÊÉQÏÏ Óˆ z™Ë¢ßÖ_Þ Â×wÜ Q;Æëú eÅ.OºASh¿ßï¼Eä‡rdö.DæSŸ%sEPz;²$üÝE(5*·:3 åê/&ÏÞÙœôÝD³ì¾úÌãg‘cÏêo¸¹/ʲ­ý²}'Ò”™9ËåHð]T¼e£{iR*/~0aJ(r'–™~?_„Ü~£…>#ؼèÎ0½óàQ+õOÖ¨ö° vª}2Üxæ*2ë\ÇØßÒ¿9b¹ÝiµÅ(`ÛÅÒØ‰EÅ“õ»mB^=KÉÔÇ*¦ P\>²¨ì9ž~Ÿñ¹Yumšìźÿ¡™j]¡$Ü¥vì:u(ßûåX§a4…O%ZîëßÏÎ[j]}ròÆ#§WGŽ/rÈ ´ì-®KÆZÿ#S[l×ýyX}ôYš?œ}IruUîõÔîŠ ÖrÍk'P@FEöôFöŒþ} S(‚Kù°œþ³)"÷À¯ê{¯ ÌÒî¿ýœ)‚CɉMÕZ½PÞ}ŸWKˆrNö%ƒÞGþ‰Ék-=JS±B³î,C¹M;û÷žYCSpL©8Wö ¦g=8Ûÿ6”—)‰ /r{‘Ÿ,(ý¸ãÒQuŠÈf<z:½ÌM™`±¤ÍJù Ÿ[n×à×à⚨¦ 4Õ’Ùä%~GzþRv…¯<2`MYc·h¿÷§ÂY}yçß4'rÎÿÖ/Y ÖœóFªRx˜t`bE”u¶ë°3Ö 9áûµ9‡ñü'Tâ‹10³cöŸó-(_@nKêP7pYò œt*?Ù¿bfõY¨[;&=¿ûÔ! |_æ5íÖ7ôÓ\²qYï’?ÅÑãvÈU¨ Jy¸íÎ d§Hä ÆHô-HÍ´ |%–‡x °·æTx·ü¢÷©¨ØzÈ kG7"¸êæëÂÓQaÇÁSK¯ŒF"ýƒã§uþ(˨\oÊß Nƒ¶À¼ºàÙ÷¼î§À5ÃÙ†(À>ÿrNå[.ʬ–Äs(BzÚB¸Œ¶âO¡6*ÅFâ†U» Jμdrï¥È›¢gÎ]q‰¦Ê¡Lþ¼W‰Ðpе{„ž>|môǰŒvÝò„ëû…Zõm€Ê÷¤;zÊ(n÷ûTw¶Ù„­n?Ñ{änX}dñ%ä'xæ†zÇ ÀÁç^˜Ùdzî›v¯n?2}/+î½Î…ŠiÚw/×.£ˆ2É’ jNÈë×E~bƒ%ÇÌø¬6ôÍFý ;ÉŸØÿ‘fCçy—íNäPDÎÛ: ëŽÜ±QGÜ<çS„ÏÙš[,UAmúÐeiKˆõTƒÔéë(Bý›yQ£ò¯PD‚ç·Yí"²F#%G“Ó£ËÙ)¢C”>Œýe玖ßBb©4ûjhÝE»šñgšEvƒN¬ ÞŃÎ'¾ð¾q§óŸ•"qÑ¡nzæUа4IkIïä`¨"£“Åò.ëÐìÒd¿ð?¼…šI· ­M º4ëJM~^ ÖÜ«9G½oFº[´ä¦^åæã´_³>ÑR+:`\ j¤2¼‹Él-—o_P»îdܘktSëĬuû<ëÔ¯zf!ÈH¹ús]µXž­/™6Oí!M.)UÄúîHU£îE_ǯÝs”I™“å¤Åü‹ ô|*Ü9äe'£â3bS„Ýr´÷<€ÊÜÇ=v˜}§üB œ½»rú,šU—n{µ‹fbÍq¨ýÜWÉH4$ž¾<8>|**it{P7R·Îòß9 íªU½QcÜiyÆÂs"S¸Àgûnñºµ<“—ûGŸ¢nòÒ‹uWxÓvög‰zeHQ¬÷ÞY¶ö­:E¨>ÂÑYßþ8d1ê9YKF޵(é&¶Ï3nØj¦ˆü3©eßtÒTü~æ«Y|O–ËhØþAÞ4aõÈC™á‹¢t_¯s!§­qs¢lO±6Ýq"kîN۴ɿɿÿ{qäàg¿ I_ê·k$2Æ“f˜!ÊjÎÒ‘óúuÇä¿]¹vêÍMÙºóûBUí=ñD-³CúÏF¨Åðë:ßàé]Ô{Üœ´½ÑHdxhjtÞ‰ÄL#£=â¡Â5FÕ2™v)E±;Ô˜öxW¡€Ì5ò×lw €ÿ¢£à6Òä-‘ä‘ÑdmòvÎæ(¶Vë„„5ŸÇ8Ä@™}Wo½¸¤„L]É~ÖœT~DC3~­2ø ÷æ¬ò¼}™¿†íí6Ÿ&»Ñß. ^¤{ÔH¯Î¸ý4õý.öâúö-X(Ië@Ç…aDùæ¨i/‘µNlÞ¼ñBƓϯVtþ€ì`ð+ƒ×‚Hl•eï¦ù@ñÐFîmí³7ôb@xqô±“uȘ®½¸ËMñ¼ý²Ïó¥>x%Ètö¨|¢ Ò-£Cù+%z||«ò:Kóˆ†.v¿þáTÝI;æ2ºr3ÎÏ1ÑòÏï÷àÓ^¨¨uò)ÿ2=Ÿx•—Kjž1@›ã˼³yëòÉŒ½¬©™”x`µ74°ÆOW"¶—N”{õJïI“™bù£.7ã% ò´Ô;2u‘÷æ“uï™Í ¤–0æus¢üÅ{oVŸzÉÉ3¦uv™±f {4Dœ mg|."cÇ›{¯6QVp¿z@ážsôlÕb+Yù­ÔsÜ]äÕ>û½ÐǪ‚îÈušo2>Ÿ"%]ýÔa,EäÖÛy&rü(‘­ùýî?Üù7¢Ìa‡ýÛﬡU%»É€?E”³²×|Î3Š d(‰5#±¼ «½»sãfšµ+¥y+¤òSšân:¼]W¦oò³®í°ß5Ý?µåic²{ û¹ñ쾦 Ò+2¡ eŒi£Þïüƒ îñË{ë†ÂÛ~=­nF#ëÿûÆÅ º É?£ˆ,çÚòGiÇÙ£‹îw‚ïñŠ?ù¼Ñû×* cáòûû¬§«O^ˆ;ÑÕx–¡†¥‚­Ÿ¦W–ƒv¹AŠÈû"‰CùˆÂÎAEæ(°a-¼cÊFî"w]ýSO[ØU2ï»>ìSê õòïRU÷Rl’‹áßæöœ5 ¹?®s3÷PlÇm‰ZR)Ry¯ðãx±zn^GŠTÜRg+¯w<‹üR9È1Ûñ`¶ 2¯¦¿ºx}5|‘¸—'"ã«ú {×.T<9ËÃÈ™‹¬ÉóÄšî|šüRÝ”¥óL?JýP„}§ÊÍ™P£–·°Ï\ò¦§íˆœ´RÉmíê5øæ¹ë´ÇÂYÈ1éÕgˆ­6”ôäJs!©Î ƒúŽO5?vÒ¢Y,{®ÏÌhsŠÈý¹ë~Rˆ/4ô—Úݵ‰·êU×UйVU‡tmNä[›+(¯†¨[}kã¾ÍGb] É"ý\p[,ìÙ¥èÝ߈ìÈžGëÙw)ÍGÖ-M‰»úßh‡ól¬ÑzÎÛUUÅk9_‘(ÌÎ[qä[FW Σ̪ÎÖr§âÀÛ² C h–Jópù#âUnØP„„›ñ{ívõÚ> ­ÜnB¹?Ãõ6¬ûõZ‹÷7oNdX“by²_K튜¨\}ûÎ*(»§§®»•*Œ9@:r›*4•9iŸÄû¸ëÛnj+k¡Ö¸Ãáõ‡ÅúAÞ%Ù-7¾Ó÷+Ô¸@ ÂFìEöÐ} 6–÷BÎzý% -6 ;J3—w±rw>0³Ó½¿²æ£–ú:šiîd¢&²ä³-~‚2°˜Ì¯S!^Ö«p­-.Ê^\±k :%¿pr©=l Ø>;jv:Ȉ&÷FÐt±) þ²†Ê?B.#¿ììSùÈŽ¥–ÁP¥ÈøÇÊDÄyjüt¡ü‰1¶dûŽ)·¡¡Á0Äjó~$×ë¤ß„øSjûLE³r¦ñÒܬt(í@¦U™B49‹–Ceoغh¡M‘æÌ15þ͉œƒmε¦×ÿãYä†9¨R—†žôøƒ\ ­šÃ PUN&¢Y"§³¥BçäSßS(»øx°öþpî°—Ç3ÓEùbÕ ‘k× JåDŸÎ#û¢ Óð¾É{®Ðd Üñ{Ì ¨«;`ënÁ¥)Lõ%‚ êæñ‹‰~`_9pœfá8¯t;ún“¼O~ùñõiUTòëlâa¶ÊC¤)´ͽý„' ô ·ü Yo3`׸ï)"ópïK»ìréñHðŒ‰!f¢Y홵4eï™hŸð•"4pôÏýŒ†G½[ÅöÃiVÌì;Äx[åçªïß_Ú¹ºCÁ÷qIVm Ù`÷2kÇx€Š2l¡‰ÄüŒ¥f3AV£?8jEí„+©Ÿ`é…Ó‰£ˆÜ§ªí6ؽ›xð'ß>uã“U‹ÏAbjÀÝa=#apl›ŽÇ,a9‘žPxí³ ÇTîoäîùª)¶”9¦fçnVš,M‡‡– »(Bi§-r"U=šõrûº½:¿ J_’Žš×[¬GFÍÓÝ[‡®AÙÍÓ޽ó£ùšÃ÷”*ÜGÙà žæ¹#s»Ê‹—¢)Bõ݇ŸL¾£óyÙ[$z4•·µfd¢ýC$ ¶äÏ\³€ÊCn¢íC¹šŒcÈë!ÕïXº“ºbd£âÜSù£7ÝDÙê…šžö%%cò0ABpMΚ߉fÇ#/tд9Ùy4¹ÃG_»µùNë-Ã×zBåf‰œ¥Y>óÃú‘{6'*(/PSž!BÙœç6¥%ýP)ÿs៚2N‹çÉw uSÍbU 6ÒyO×µ÷}6Aþ{éuRd}Ù¹(5 å´’ä닎R¤âÈó9¼ª¹½Å;͆¼17Â'ùÑŒ¿±áý‡‰ÈVa*w+å]WÙÏqGüƒ=櫆¾=n/FöËC™³6;ƒè™4_…’ÀE°*+Õ¿¨…’¼~”6¦ÈÞ´Ž"¸’jNç P³äÇáá›Jôd³Žê-ô´U«œÞ¿¡ÀDC&íDêÜpñîæ%²î—Ìzû ÛHÿÈŒð}Í µ]‚¾Þ™} jÞukÌÕP”ðñ<‰f5¹mî ý‘ñ ”\ÈÙ#Í.½Z_•Ãr€¼ çKj)BCòY'÷+§uýý•²+»’žS䟷¶ŠÖ¼§‡×ozA“{gôÙ¡œï zÿxnÈwŠôu¯Úxw3¿´3–.i4å&ïÑï<‘&×SšoÚH¸P7U,rÁ†ÆÃZËÊ7~ù…µz YöYÎuÃN:ž¯¨Þåͨuqúì\g_¨ÚÈHêê¬I•zrôÏý> Cgä<€zÃkƯD{¿ëûýì•4©z$â˜Òú†þP6M.3/""¿æ]™4äEd¯³ò ÊLŽ7õ ©ú« çþ*à“£¼œZ;(:™¥u§«îf?Ù2ä4+E®ƒü¨«¹¢|<ÛosWdϺs|qÿÑ-ȵ4;éì¤FÌÅVÑÛQ&u¸?“iÖ$›Ÿ°¼@Ïäl“äaÀ“=Y»7Ô=DÎC2ÑÔ nª½ VRyß?»¯<C3Ôú;"Ô(¦NŽÑ€ü¯¦Î솬T©_5ÜRâiÁϽ¬övp»¡¯+Š="O»ÇüïÉ›)BuýªŠË®Cdˆßa•Í.4«VÙuK2îŠÜÇ]ä—Ÿ†ªÃõF}N…†ŽîsåÌ’k;­&jÚ!Ó}€Æ‰×ú©#Ù–"{¡t}E¨yU¼p]‘wgªxb¯BÆ^É~Iäh.‰E™«þ#Uã Š}ïõð°˜,dL±…}Å•¦\—Ç µAÛA¨ôþøë Ç)"«zö³…¾(Rõf(û>¡fPÍ#¨þ£ 6PÖ#ë™@šIŠ™#úz¿-¤YC¨\X8~72¾X2_û\oÔ»BŸôo0i(ýEŸuêdÙÚŠÓ7OQ,j */–NL÷Õ£ü2»Á·f¼£¢Û¤YÈCÔg÷‘ÍE¥àC5zýºCš$=Ú„fcþÇ%ìÒ»»X•Dvâ%›YZ¶P2áò»íüÑPf@ª‘KQÆî€øÊQûM)Axº¾èÈñ·tkÃ,+ñz‰ì’їϼ†Ä÷Ȭñ›YŽEb –æ•r~EszŠ·.=Š(;S@¤Ðäj*ÖXOŸ†Ì£Iëõ&ï¢ó±ÓýJu.÷žŠ¬å¤Ã~l rÎIê 70財åG*®9é|éæ$¬ü¾t{3MæØð¬cÌ1(£§ïuÍk*›Üˆ¿5±?Mþçe Ê´~"Ϩ:xî*Ÿ™dzÔ°Ï(›&µß²ûhxÞA³ÁfÍæ¯écáÎÜž³ôn•À=ÿAžf#4Ù½ÌeC˜~!ðuž$àI‘Ê×GâNÿ˜{)b{QïÄýÅóFºÖ®Ì_ë¬òv/3<ë!‡D®Üœ‚î= ðJn¿ÒP­»pþrmC,º.¢ïc¹$,¶"rÎKrY»Œ}1“G›@þÙßÌ>ûP©cÌ·ëá šÔqÙÑN¦àžógÃaN"Eä?œÜµO*©Hòô(‚°|Ý….F‹¡lR.™užkÞLt€Ê“‘[¾úÚBq©ÔoAÑvnÕvaѽ[5*l’ؾy2";Ñ•"\²f½K¿¹Èû±9Îvë0†tzs@<ÿ}é½×xš‚÷{{sGeù1—7qõ}DcD¥s߯ÌkŠÃÓL¦Bñò_Ü7Z5Ùœ"TIãt>?*P^æ±øúúÉ’•t”¾@ë •'‹ÖŸC¶K>K¬)#K©\aÉè8XeÛûËwsñç?, Ðl\úî䉨4yÉÌðZÍ ¥þžÂë->è<í†O‡ žçY@ƒ~ו1 †¢`«ÄÿÕBæ 8ÉêÛœPw€\¦ȺýäI^L%E¨Š–Æg«Æoåß¿ìNy>1õe^ú¡!”}ôæãvYž=üÅæð ?Èí­uDeFE$îNx%;*›"$.œk=´kØ^Õ³mPí‰j§­ûT×™fZo] oƒH¸\ñ@x` ÖÜ“Ö2.Ĉ-Çä7l˜‹ ™~ûS=ÜWBù^Ÿ‰¥á— .nÏÅ/ó?!a&ÍËo$”¤¬Y=êá~H²8wÇ(ÊJ\öÛqÓÜ("/ã¤5[sÉ¿Õç.÷³1â)S"VhEޤ½È xÖøõ¡®“I\·A©b“>h°:Ôiœ&Hh†ðI‡ðoš%êΖ†¢¼¶®ÙÑU1PýYZ‡Øè§,™¬‰ÛH‘EňRz!Ê"9ª¤ãO›L{X;CÝBð¾WÞ"=ï˜ÅkO1ÄŸ×àôô½/Ð :¡ü"QËžfñ®áË.&ϦólÃN¾1 ²†øÕoS'è^¡ˆ2Ç%ñšÊç–žÜ%¶Üíï8Y {{=¹TÚkÍZž_¹ñÎŽpó‹Õ›ú÷ÛyöØŒ·°aK|'_Ðë¼Bõi4÷#ïõѱéAË1î=® ïåN×Ćk U·«_x_;wê»ý5´<ޝ+œ‰¼û‰:ª]§6'TK&¸E”©‘²³û{dí¶2î;â0üúC<Ø3¸"•/ØÕ¸ EÆR;¢A/œ7Σ?ÊT€]áy+ŠÐ Uw)"cðÔ-Ÿ ÅûžA¯!þ/ Ì¡,Ó*$ˆª‹¡òÒš„û•¸<{QTÞüñl¨ñqBžJÊãöC¹•Äÿø¯8ßÞ^vzw$”ê±®|yÊ«÷DØ{ÙЬ:07.>ǹQ—¶ªm:‹r²:r^Ÿ"³G-#}¿bsþu|÷Á<jnX“³q 26¦ÁL—'Pú=`lŸØIT~8M¦T_§?gæ-¢Ï”­ý²0ÁK±ˆùÉ=MÓÑþÞÓïó)Òñ¦F"áiºIíWE¸o|V74pÝ߈ŠcüÈŽ?¡H"–VPD¾K}gØÓä’å)Ï_!»ã¸EJ« ir§mŒó/Š¡IÇÊ÷®=°>’b£(YâO?ÿaOøð¨ÇÕn{@˜P;v]ßĦ¸·Òþk"’Qà­P±Æ@™Ÿ"ŽäŒx†œOsª_,wGZ“*¿ ßηYø £"ñ_ÒdíúiÊ»HQ¼îO5ž­ŽÌWuÙúß.Q„ø½’ýÊHý4K‡pEUþz ’tîû]ÈžL殣ya¬-ÿ‘J9é)bÁ¢ nns1ù&5ünnØW’:yúúÄÆ“Íp$žït†ÁGÖxïŸ{>¾¥—ÄZUŸä›¨0sY©úõ (»,ÛîC‘žW á[É@MÙm>jP¶ð½c¶æŠÈ\pæÂjW(a¨ß}ê਱ü8äu{þwt¼Y±àÁÓƒ1ÈÖ-Êløº›®[ä£4ož¹l¿°9~¦;ö-¹A„“\ìÌþºœO&_·È·Ì 6sà 8›î5åÝdu‘ø[·kŠ÷¨×਴¾e®ÉÙOf1 öÙ”€¯B‘I¬|î`EúzÙÇf=šõA"ö•äÏRDgÓÒÚ§I¢GÞŸP?^ó&¦ÝðxÌ­)? ÕÇ‚òGÄ-<³ÔðõÖ¿eïŽxŸ3d/×%‰åÖïÝ--dÈ‘aœÎÈ™*É›„ê;e+ pƒÀ|ÒsŠÈè‰ÒO›ÊjVCíË”A×VÛh{îýê.»ý•CŽÌaŽw¦É–‘4‚ª€”²b½¥uŒ’>9MzÏüÑQ™Fȧ ~%.¾#8’ ¯f ô ÝBókcžlííþÉ û‘kâaf'‚’ÙþFÖ|3šÕÌIÞ%Ûw´`MU´LÌ–EÿÜתnÍ.˜œÜÝg~ñê&Kü4ÈŒ»Señ ŠP'ÙµÇC½™´Ž]vVÎè_)=¡AS=ËgA”+YøÄÇ^•zÞ¬è×DBÚ— Lb–˜PD9Ý÷‚´AóZ|#ÿ ôï~*È8ñáµgL òe¤ã­²º·¯Î ÈH5¼ûð“)MÁ&õ˜’åû Üðǰ5½Ôh6þú÷ dxÖnM¾O6²Ô8i_Љ·­ [ì@ágf÷|OÇé>M¹=¡Áá,Õ¿‹&•ÑH¨¼³Êu—ìc¨:ÙoCquš ·¿û)G¯E¹Ù¾§är{ ³ã”ϧ¯Ävý’­g~™Òärj˜u¯+ˆ.ܸptÙmø•~½íGAe¹ ;ßf*ï»§ì–ºžJUóxB³,nÖša)þPcàñÇ ¢32/œžnGçk'~“8Ö¨þ_ôx×?8™móç#”ŸiÛý²"Õ‡îÇ)·ýÉ×é\d|6špÐ˰9!¥cùáá¨î-šîÚ-™úgm‚ÊnÝv' JÁ4ÅÒ4hèv¨Þ¡oév#HÜkÿè—ãˆoÌ (aIê·!öÙÖߥ9~PZZL&‚€hìëçw:u¥Ù õkQ¬}G¦§t¤¹]¾æ}ðSP ÃW}¾:šfÉ[Ûž…"ŠH¸}6ßÁåŠ^GŒà,mAªß“4·&Þ†4ÿe¼)iŠ~‰Í΀jʯ ‘Ýæf_OD÷÷#N^ì÷1*™ËÉrS”›ü§ð$»Š¦¼ßÛ{‡~ä@ §'Y‰5’a·C~Ç#ÆÚÕ{Q‘g6_®ðo„?^úo©S¦ˆLÝ»–÷vNGF±2YaE‘Îïc÷Œ:¶uü’§›õ'™fó|¸F¢Ò×Uëvú‚HþúáÌþî¨LÔ­³vXEjÄ›÷–uz4ë|ȲT dd»\<}uE¨#Û$9l/†Ê·ë>Þm@¥bi|¥‘P­D¶£2Ó»Nèøˆ ?÷ý¼û¢_$E”‰Ÿ[mÿ"OX–vÿÓMäG_áî£Iå¹ð5n'é…RyûnSçY"cþ1Gæ•o_üœ(ÂEß*÷8øÒá€NÐÔȱ?6ö=Ç"½^BëâDWx¡ £asÖ’ú;kÙ£©K¾Üç™Ç3ÎxhÓJa'¿žÂc÷w; 'ïo+~¯Ó¾Jû 5̾áÕav&Üô?\4i<ÍŸ³_ÇÀ²޿áŒ_õaä6ÞG¢ø—`´vòž/`wqÞ¼4²Ü:¨È[q$$Ö>O»T÷t@¶Óôi:Eâõ“2WO¦”fù‘}7NpB9SåÅ—m(BåžyOwèn…²°mÓ×W‹õ#—5)Ru34yƒ\ú:§S¤Çµ±ÿT«Y3_,NænªKäY¾Ý\7y ·w©3šN&¥¼æAÀˆŒIwë)¢âë GcBÚQÎé_{là‹êæ†3V£Â%í ¾›_ÐäèJ q”¿;íñЉó¡2·`p¦…+ÊÔ{X'?˜"ÔÝ™ólD]Ù’x äÉ}Oœ¨ŸÐ‚¢/Œ¼4‡¨•»Ul~†|Ç]'÷»šƒè¨“’ÎR+”Uy4·˜XŠ27]Λ%ï„R'²Ý€~‹:BŠáÞ /4 š¬ëF‡Âç½AÁú+—(a‡d[uŠ|W¯³Ø$nÊ“*|içúÜ bÞ2ûþ”Ìó|Yò-½&éÓ¬à T»‘Iù–ƒ {ªQa¨ã×ïºrÈš¤ ’3^¹‰‰åsôlƒÜ¨ó# dPñzš|Y¶¯ÉŽ#GIë>ähLh‹Ñpƒé³&¢ûüfÅîBnŸ÷äÆ5Oê.}\G³±N™o¥y0%#n8õ°+²"$vá_õžÝ$ùÎMvóØ^dŸ"²¦Á¸HÏßPÔØ÷b]78óáP5ôÏE›­ùðe–$>¬gkëÁl%ˆd/ïZ¨ùû˜4™Ý=ç…±†¢BJèõGw¢Qñ´þ‡­'Ñç›ê'¥u„4éxÝà—Ýû\÷B¹¬¬2…•È2”'äÇ ×W¤©,/jv†"|I?[¢óê¶ÏåY{A¼†®Y6—î«Ò¼?Ú ±õ¾üü1(ª^<åü>r_hÝÚ¼gÔDmrìƒ2ò9æ…Š¡ò‘n÷«“ÇÓý>‰Œ‡ïÅ‚ð+²¸ÕÏú¯u¥©PhWQž9•&¿Ç²!0Êú®«öïÙ„þ/‰*­iÈ›%í?E‘1ö¹S„·/^nˆò*…ŠŽ»cF ‚tK )2å3ÚËf.‡ª²=öá×uÄóÐâž× 9¤þ>æ±¶²£Mv@Nò]GKŠô|8­çzš½" nß$ RÃ]fç™È…ÊéR?xÍH²}—ˆîOùè2<2³}'šE¤Ñý“ª>ÛžŽëT u§Ýgþ¶¤ë%šE ëÏ~B¶cÂÞ>Ûé¾ÅDYåîe¦ßh»güTÎЬ7°q€ë¡q+å 2]·<ÚÔ¿³úy¦šÚÓÝP¢M¶ A’²ÎYÈö2ÐÞV,×sºõ ÜñY¦R;š1ÑwF‰ÌŠP$V‹>£ˆ²/wœÿ¬ å…üþ“ÂúÃg2ý•„ îã3¯Ì P)#éuÀU±~ÇâCðî&r˜ –Šÿ2Ôÿ\Ôߌµ”" ºY9&]ƒÜ„×ýÃô)BÅõE¿g©wD†ý£Eó÷¦âŸP-1G šu'fn:¹aÕ¼„šˆp³îÇ Ñhrøh”]d¢²óTý ]®Îcì‹Q<ÙncMªo£NÒxšÇüPÉN‹¼ÁëŒê¬Å÷ý®x”…ŠÍœÐ/W‘½`ÿdÃý¹PÈ<˜ [i†Ž²\½ÄJ‹" –¿?×%{ÔIÂÚšP|øN_÷…Û Jç8¹Q!k'Ù^gcsBÚ—1–~( á®w^óÄ9¸×pHëCÈÓæDF®¤.£9éúHŠnZñ=…›¡üœŠÛ[¯™({ú “ï>!Æz*™éJ“§žŸ;åF-—5Tþ)þ}~}¯,×TÇå-íŸÓHäÞ'Û9l¯§_ûèߺGßdå›-uPnù¨‘òÛ¹éô%#î~ YßA,†œÅúˆöÅ¡µÅðûÕÌ^|Yï¥}tÎn RîBuÿÉ 9ÔØ²wËq…šYdzÆæ&?4±;y‚{"Dä¼|Ù{þ2º_U§"ûpÕê’5©°“ìŽ4A¨K&ÀŠõkã†mŸ¡ì«õ]äWÀ÷ÇÛ(žDeÊØŸ:´„î£@‘h¬³¯·>‘÷GÙß’’™ÚÓ/Û;²Z¶û{Ñ \ìCŒß˜A³„=#ÜîñNäÊJûŠ5’î^øíýÞwÈ3^q¢ÎÙùkîˆÝ2’&ïë¦æ·'¨Ü?÷úEšùc¨Ìçnôí”\°ïµCirj$‰“b½LoäÐä,% µnÁ÷eâç,žK¦¬ï8:R÷ y ‰Òä7/„4›åÉCU²$/®¿Å\ì2ÈuD sV¼3Þ£õCîÎ0Ð+¤ˆ¼Ebí­Sq 2?Ÿ:æxã'*/–öçi–¯@ç-ÈD©__ÿÆÙwª]{*Ñùý‡¨ø1ˆvMß2hÉtt}w‚‘—þo*oK¿ºA ê~9_+–/u.·ûÆvFÁøuc#E–p Ó‹î›z*#W‰LÏ0¤ýd¬ &éæ©HL±_$—FS‰»$Ùm`.òÊÈvJP®­È2¼û ±q6ŠIñ·,n.–Ø«My¦Ç~Y+}¤á‚Îq^K®BÁÑ… cåòíƒÃ” M}£òãåç¥)2Œ”Œôz%«'¾lÒ =oY?)â!«Ç³P÷mȽ×9{ß¼ ÍIõ—…œKÁª}ï—#!‰"1m€âòɱș»˜õÀdxIÚžê#qù‰ö ã‡4™$þÓæ¤û:]jßßLI¡É˜[µØÊ¸/¼#Û÷V}£Ùh×Ñö]£¸e¿¨d:¤=$ÌvxïLudÊnÓ‹>Šð3ÝáîH£³4K‡ø®™3¡ *£È4#kä:¬ÍÑ¿üÁƒ7—Å ãõn ä(BñPiðkìOIª§ý|©ûœÊÛ姆ÚR„ZõOd† ”<òòtïh ÂkOÒ·íöƒT­«êÉ&IÈÉR7x(B¡êñF‘O÷µ*çÿÐW²òõºùˆ÷ ~š‘ò9êÜdåi—¨¸ÒäÚiçg]úBj?ظÇN›ŒDܘ2Ï™PÞ1GÈðïË $Ç×Ð}–›3AzÿhfÜ’ôÇ@Æí Ý5#*>NÇÉ«C7̘³ó œ+^#óܪ “Ë'î[AóË)©ÿ¢9 ÔHóH¹9‘rÖ/*à8å/h²¯Ï¾!:ŠíŸ¡¾ÁA³Â‘qóÅ»ð¹-äK5ìMëó‡ÌkÜä|Ðø.ÕO ™qf½}¸©ó9¨þ½È(ñ_7±1®W;=ây¢ÛGºï:ëseù‡ÃËQæKŸRWÅá^ÚmüŸ\¨qŒì7su?Š(°äoÀ«9o>qˆGî³9Øï¥.4HÊÔz@ùJÖ“cZ-X´qD§¾G!dzîé«Lä2²zôüŠ&ŽÂÏ ±®tŸÛêc}¢KŽˆ¿dœ›ó¯ùÔ¹4\ɾÏŽßÜ#ï;Õe\zw­mâ9ï£Ù-Î3º7éÁ ½1§Á·föqÅP»¥1OQÊ–~Mƒ±d¢EZŽþßgÏNyzg5EdÙÝ%+‚i‘ã¦v~D“c~ÿjª$Ì ³Ùøf-Íø}'>ý`N¥™3_®ÐpöÊŠüak_ø1å 2%l„QR&ÇvëOŽlÒg‚â¿ 9·”¾þƾUÈ<á7c‰lU'ެUYû®½=OçÉ>—Ö¿7jIwPÖUŠÈŒÛ}}4¬¶ éS¤ë²ëÃö½W Yšu #³`LÒñ›Û¡f˜lɽA4“Éî"£vRD‚ £æ4 {—%yÈÉ«v[¾¥¹S;Ý4ݱ¯e_6ùš “‘Ï“Æg Ñ<^žw²@n¬ÒÓ먛Ýi1/‘bS~€Ùι'Mªÿ(ó›?éø§ÉéÈJþ¡"õKÉÄŠ0(]U[çÈØƒ,_‰]ÑÔ‡7áÒ™„[PQ"IdDûÑw±…‰L_K Ý•×2ï…»Ö:6Õ Åa*§ÜG¥õdš‡Eº¿0{ F‡+d7ãPri÷ÉE‰^´þÍ’•Ès¨VwJ+Úþ‰îC±ÔÕì]Î.a‹¿/{üݰ‚q4¹ýíÎÏêùÖo¯õZÙ$iì6‘¹ çÕ¾nAÖÏjçÚr HžÜ!øØªçÈÚäæªa5úë• ÎŸù+Ë\: :÷|T÷NË킽¡®¿¤;Í‚K3ûYzAéQòø.+x7VÛmÔþÓé>–2æ–z¢1QAÔ=ˆlèsGN­$Ök—ý»È,‰×}Y+y-È\E&z8Q}Ñh6öAÁMÒm`‹r‹"¦‰”UZ°±¿|ºà׉ӟ·n†wa<„²Íϯg. Óó²|ÿ€äñjŒCñüß )Ä„2²ËD™êûub)ØÃÁôoDVÿÏ›ž>¥Éõëä¸ôc92XÛ}Ï2†ÞÿtsF*U'Ð$çÆ‘âC<öN+Ù›ðj ÿ¼ÕS•"rkzˆh)òB8bƒë1rÕŒ\Öï:2‚·©•}¦ÎO H¯‡h©ÿ¡…••ñ«çqàOØ”ÎQG®!Óõñï/U¦tÜ7@l$ÎW5nYçìK6êú±j&?û>êû]³å:Œ‚ÊgÒó(V\sáäÙ•-Ø m·Ç.oøTTS §>1~»‡¦·`qïÃ.÷MœQP$9·¦(1ÎF®¡´-ÅÆ> ï®mù, ×$ý ©~ýT]fó¾¡(ÛGûõòˆvÛ¬ì7„K‘ê›Ð”÷yÚ0ê[Þ\8$iÏ¡A9dõ×gª.*ôEUþS“)"Q"QÔ¡æì¤™™ƒhþšœënvûÍŸd›#O'Hõp¿N> j$îcKš‘¶Kßù¿¡ˆ<µ°Ó—'@©Á‚~öb;Þ­öš‹|íya¬!ž4ûõÑ}û({Ä,ßc= ˆœãdè7*Ÿj–3"½;/nÑ/¹±ß²L¥}ƒÍp©äˆí G7¯#ŽùPûhŠáb͵T&šÂ÷'™=é !½“ƒÕL,‘«!­WãH!%2LŒÝnaGõSEnÈ’ÐØáMzC¹5Ùø¼ù#_öž¿ô:M†ÕWŸi f!¡då²åûŸ¤ú7\ÞÆè±tÔ‘úKëÌ2¿Û8í†#jŒŽÕ^ÈŽ’œÓ€¬ƒ2{ŒiÚGØd{…‰M}UoX˜¾Z ý¤}¥‰Œ^†zÃ_즥_jŠôû“]ɯ+4Æ­Üþ«çPŠÈz!µOä:oð0ÌiNxMFËv¨¡’¬ä6d>óuÖ„"\ömì×ÛÊt~²B%ú2•Ÿ¥¤q~ÁåaуW#·ÂP‹«Ë§ÉîwýÛÿ®PÿUÚ_€™ÕCl¨ìÑ3Å…o¨¼ãŠWÄ_Éo<7‰"U’¸ré`¥ˆ^tŒ†LwÈöz} <”÷¸hðvŠb9Oüò»e '6X„ŸFÎø¸iÝœY¨üx´ÑÔ,mš¼5&ùR)‚çðãÇg,×E¹\Iž3ÍÆø2•¥ux„O9¬“Õ~£ÜwéyD©~X¬yWŸë‡2ÅI~&Eú4óöÖÎ^•°šf˜áûèQAIÈ¿ÄØ$op¹ŠRùÕH*D›¤ò]L¦#ï¤úD¶Ð¯>Ž”ÖsųmÈÎ-úEÈ~ûݽ!2¡.éÅù_ T–ø™á²°(‚ס˜"²ÈîG½#QAª§Ð¤òõc¤çèÒé×sδ`ԯƼKy±™“˜>]‹¶œew¤Y?“<6gý?Ù MÌAFßÞcÄ#„Ǿ¼óAPº.²’¹{ «]ç͆‹Òý:ÇÙ'-è˜âˆÌJÒ°‘"ˆ¬d mä&‹íÌkGYK)‚ôü+z ˜üRÃ+"?¢È’_­“4±Eø()ƒè‰$ý¬[K$I_lø]¾<Ø„++2{ÌZOŸkÈ|CºƒMáã§°‚I—(¢J·ýs2|nCÅWÇ¡nßöAäy]gÛHùÍ&ßÈ}Dkû,c(û6«º.Î*ž¼»·¬ûšÙc–\±7XÕ]B;¢F\’¸¦¶`¾æÜbÂLÇwøt`ZAY÷×53 ÷»®“÷:2“T†=ÛøúIüÛèûìtðm<©Q~ëõ=~£§YíLKA†£_†Ã~úÄF‚?™²÷K“äFšé²Pü8Ô©ãú®¹(ñu®Ùnñõ_%à4ù¯T³„49o¶'leÐd,Xtð–©Q ý…êr>#¯òð;¨I‘Æû‰òod¸Ø‹×í]ÙWd^ "7\n€²ýj—×Pgj°]É%òû¤gMÜx9!|<?3]ÔG“f}gm²q=ø1&ø”¾ƒ¬¬×ÞÜóyÏ÷—žKÿ?q·´¿,ņ-}ë%‰=‘óL’_‡'é9¼l¹÷.væMãêþøû ÈI ÃLšUnv .žy(C¨å›ŸûŠœµsÜ6p´©sÚè~Ó!7 °á+QD{óÎNDæEI_sTžÕàpvüU¨{¨;eÉsd¬–òÉ­3Måti}F#áÉ¢´æ8ÊŒüro‡ÒÇÒ| f7IQÈ?*=‰bˆä9ØvÝ/íÈY±t£ò-Hïù™Áñª 3o¯;@3ó`—,ÝWPk}17ÍÃ"ÕÇŠîÊ’PDvgûʶ}(B-Ù†ãx —ãn”œ\i>4Mkëôs>3)BLcÿØZUɼ„XÇ?¢jåáÌE¾­ä|Æ&=CZç‹<ÏÂ]“€b‹szJô:Úû•,«üvDJÒó¦Db"o!ÛdïØÕ½É2³¹4ÍÀk°íBêÜ!¸ž}ðpMO ä+tV«ªþ†²c#w љޔ÷OvgµK¦û$Û3ƒŠÄ~1£nRçŽ!ÛpÌY¾~oŠ \.÷4ys#NÏzFû!Pñ9éÞê¯Õ‡hy޶FNOIÞ7Õ'åbµžSFJ_í®t~C#¡Vf–ÊÁuT²&æ_^ð•&Ûeé @Ö﵂ZSTr?±Óì~1DwKæ÷ÁG>ßÎP„×±ƒ;¥À%åÌæÞH …]ï¢íQyhÑ­Œ¼*”%J·Ï=TŸÉ0EGŠtÜ]¡~C~š¥ ÍÆsèë¤âLé9nÈ5ÿMv| or÷qßýȤÙXŸ)ÞçkÉÌ+Šp}©¬ëù1=‘Hêàor'ùÝ͉F…®Ò~k™s¥ñïÆó¼iR}º¨¾Ò"O½^y;@Õƒg«# ìûƒ²ð­ª‘mò¤Ç\·Þ+™‘¿ó¸!7³©ÞaÏ+ïÁÆ. ›-¼;ÈÈ‹˜tåâšr={ë¶xN“ÛUÒW¼9¡¢`€ëg߀æD¾g8i¹Òö2ÅÚ?k.8֜ȓŸ:“ù$Šî§ÀÍ9çt2)µ©<æz .«zÅ1,y2?@|Idí6ó|ÿ_$þÏý¿^û·ÿÿ¯¿AüåýÍŸoËkÛò÷Zûÿÿ×óÿkÜþ_ÿ'þ2¾Ìÿqmí7¢ cÓžû÷¯ÏÀüÇó­¿öÜëÖÜ3âs¼­ß­¹í¹WD+æíÿë5Ä?æó/ïÿ¯óŽùñþ×=$Úxþ×8í˜3í½ïD+ÇhØ1Û!¯Úz]Dåukï³k‹ø?XïD;ž'þÇúoïš#þÃØµöõDÞ÷¯5ÚÚkn‹¬c¶r.­Øÿë\ø×>ÔZYF´AÆÿ/¹J´s^­Dç ÑÎ}ÙŽ¹O´á›ÙJYþ_öWf+÷CæÐIÛ{[ûZ£§ÿaÿj‹,#Ú!«ˆV®³ÖèÈ­¢ ûR[å+ÑJ9ÁlƒŽÕ=»-ó–ÙÆ{ü/O´coÏžÜZYN´q=·Çn|lÍïj m«¬û-~L4ˆ+Ižg3äóÚÔƒ‘ÒW°¨W0À]³ÊÜf y&ƒHú ú'œÍ«6Yno|9¿ñIb÷ú‘6ýhdã#ö†kF5½}ó–µÔ¶˜ÛP?`oß²‹z«À|ãŽí6–ÖzÍþ¸Àz‹íPêÈ“Ä^üOCƒ°þ/×!c±ÊfÕÐ5Öâ·H¯…!úÿ‚Óä_ùÂgss/data/ColoCan.rda0000644000176200001440000001637713267106071014006 0ustar liggesusers‹í[gT˶î!#JP’1 »eF@A°‰¦f`‘ " "ŠDAP ŠŠ¨Gí6 fÌ9 * £˜#¯ðô žsß]÷½?÷ÇY²Ö¦»jWíÚûÛ_UO¯ÕÛ•å9¹Ÿg? ä0iLJÝÊH¡ LSDWy¦€'`²ù&­ŽšJH 9„d0’b$z½ÃhÑD"‹DÉ$L$*HöÚ¥¯Ãh}ï| $ZHœ‘¨"1DÒëŽm«×¶}?ÉZgB÷Y!ÑA2ˆîW£íöÚK¯5ñÏulÚŸÞñ€Ú(MAºNºNjuñ8£þ5i?… "ëÔ«F÷@׃~:ÂA4ÁÁ“Ë1Ñ€yûŸ¹C×Í\ÛvGèbž(èÔ©‚®wu§›ôÚ¼’9v=ð²HúLÕ†püQmê7^ºèìzÃÚ×[ùG_Y]Ù »lý&¨b® Gît~¹´4ýþIèTýt¯kd=t}\nqáÑ&WšŠiÚc˜¶Ñº~® íцíÝüË6 r«<ÕtD¡‡ÓR^B×=ç¹Ê'|@d¥n¥¯­¢ºÍzÆï‡®•¥©Ë'žGñ%¦]?j"ó$lÂv#èòÙ÷MíÊ×’·*áé§Aé8ÌP DLCÆ‚aÞÐá½G'ù™6ˆ²ªt·ŒéÑp^ƒLùn¤ÿZ–®såy=Wç*â‰Öã+cM² K7½Â^~+ˆ6ÕäG£<¼`íCß ^,Û8¿ô¼ˆò¾µ»ía«\m½²4cÄ7¨’]î ÒºÑd¤2ˆFÔï¿úª/oP{ ¢‰ŒxBYD…ßÎì ’Îˆúñ‹ËA´Ô.mðz º–Öó7ÝnQ¬zÉýÎßüþÍï2¿%ç¸;·‹\y¡Þꌿtì%ä4;ä¸ÐØþƒÜ¼ nת|WÞûë¶[\vêY—ý‹ãa |}Í‘‡ôEkÝêçÔ|…dOp†áCþX[ A¶ šƒÀ«sÜaÏÚD¾˜|Ïa=Ä$4l”? péÄSc^‚ÿšÛGs>ZCí¤Š&•±à¡g»å›ÙI¨¤¶ºÉù,‚l½Ó S_wÚ{×eîƒy÷ž³ƒ—Ì“;+FêÝŒ©¹¹… Ü-zݰ/„Q¾ÊbÌ®}áòZ. 2…«˜GäŸÑÊ•9=y1ðZD­WVƒÔû{'œÍóƒ•YÖñøÉv¨9ñ®ê®‹,¬ù´y¡ÜgXš{2F%x>‡v1—Nÿ]©†×“_BF““ÁSH(ñ¿4óèGH¿Ù• ó=ÛkAªÝtX0ìÜ^‡ŒÛvx¯åY=ˆ¨|7û`Ä<±NkkŒÿ*6[öÀ†ÏGž]«õ€ŒÚ‰¯Ïžn—‚ÌÛºÉÍD Ö²Þr VÌŸ’×IÏëTé݃âþMüúc¾àß¹üã…€«lü:£– ßåžêGÝöéí_ Àyà?¨¶VèœY-òƒeÛ,”_~â ò1ÂÙÝq^æ¥Ø~{Ä›îhyðý `LØ…燜­Û<ÜËKÝß·S,RFï†bËÎ*Î²è ·‡yPõr†©lÙbÛ¦9¨áA%8Za„Þ/‡”Ô-‡ÀË@Tn4?7I*‡mîÉ3>Þué2ÇIð}:4‡EÜÚ;•M×~óû7¿ÿÉü–œãE£îÆà aOCà»- <²Ü2ÿ‰9lÉJ{§§šë]/ñ/h­…ì ™]s!këÍ"f:ä+~Y¾rI!ìªÚ m”$W=kÒ6‡ô9³2ß4{ÂîéüãÏKc Kû†é™þlÈkžuÌÖFÒ;6ž²#2N'óȳ!뻢NJtÓö^˜1 ŽÝ=¿`èQ8vDß)Ö Vßiï¦>±`ãh…,ãW£!Íñ“OÜy;HލÞôÁ J°³Ž…Ú2ȯëWD‰°Õµ=lùèrXkÄèåíŠJ¼‚ Ã&6ɹ~ñ£…"dL=°§BÎ’09QT7$Îjiœ¸í?.^¾}ž"‚Ì\¸å("u¤z0®Jw¯ŒÛûàED«³ïçv q¶9Ÿ½(â¶UÑÆYЍ®’oÛ‰ð*éžZèFüaéãO¬¥ˆ´ëãŽmGq\šär÷)EìGLJ ‰üÖ6ºn?E”-wµ´@~Õ¹6–죈ͥü’×(âÎѬá}°°rI6EÌxSh&Bý%ûÃd"ïRÄÁ*gSæЏÈrüÞ5Ù²_K—ºffAùXeСr">_¢Y€æí‰8´(­{ðÛ3Ûó(¸÷t…iéáR¡6¶ á¹HzH½Y0Eäú*?¿B‚²¦ÆR„pëŒԦj¯ÿŠìï /ÐQ½æ+¨Ÿ;¤‡pI|¿°m=EÌ$¾Îúˆâ˜tµ¥UÅ甌gGüS]Q)ãˆòç¹²Œp¡ˆyñ_Œ¿n™ »SÙßPìënA7O¸ìÞHWÿõDx¦žé®Bùăò¬Uå(b®¶Æ«ññ‡gG|Ë7Ä/|C÷¬q¿ùý›ßÿd~c˜4:Ça•”PnØþ 2NRv­VìùìU?†ÌR]§ø#[R9o’Û5ÌHáXnóÐóH·6õ„Ür2Zà·Lï3бõÎ6A8DÚßžË%Ó¯®äíM%…ëkö- u&ÃãLÈâ"ur͉YƇÝ!³UËpÔØ°2ú…bž; ™Ì®(ë4]HqU“ùZ¯N¦_ÜÒ*÷ø»¼_Õ ÿ²ÔžÏXz‚Œ(K,u4‡L†?Ú£ŸË’‹Þ„XË’qgT²¶|ŸI®×øƒ•4m6¹¦X¦ñNsYPiõ)ÀCLÈ]!š] $“ÙÂ[…Ío SÛü T¾ ¤é¨Žä½U‚¤%G‹›ŸµKøÝ´¦.‡¨­Lr´Ã}ˆð"Êäé9rõçÆì[•ȸáW¢ei½tœ7Ó„ÌN]•bòí)¬_yîe¤ÓD2åø‰‡ ²àúõGüÈM× «Fy¶•Ã2÷Î÷%r_¦‘9â¶ŸªÿNfO®Z2X#"†Ü]mvê-™UïóïR'3 ,OjÕ<«¸†³.‚O©1@¡øôDXcæP0wà 2ùÃ¥þ~Õ÷`eðå1É¡¿ùý›ßÿh~gOyUpåi pÎå+º$SŠsX ËxÈ{ï}œiuwVbBˆ°ª²«ßö™Ly¯ŸµÌÐ Öíj½¬ÙƒCv‚‹gð™7d‹õ˜%…Žd\ÉøÔw+HJ Up±Ð"‹ÈÖq;ó´È\Çy3ó¹djSëŽ\råÀ \«/G`ó%÷*fÀŠº“¼æ¾' Ýóòs´µ ÔB'`o2éG5ÏŠ¸ŸETïØ6–ùlrß6ÁŸŒ©¯ÚÄf÷@~Æ(¬&:ˆ,rͬ½?LÒ§ ³=}™L/ëÞ÷CM "kOZ]5v©{œÇžBn¶ËPÀ^NŽ¿ùVÛ{±pœ‰¹÷¤S` ¶ãEHŠäpkê~÷–Ì´ÉOmZÇ€ü)MQ-‚%°ÚÙ§@Éþ*™}é-³k"A®ÜÏ5XC•Œ|vtýÑdꎒ#P¤'t{À(-^ºŒf Å,™±åÂãP’û!ºø°2™uíXœß7g½âœTœ˜ß°©úÒ¥SÆãÈ\£Sûl|CöÖcljÈTÓ㌽|aÒÆ½ïíɨ(µÓ3ÞA^[Uêù‚<Ø|Û?džy ™±)=hÓ¹ d¾½yÖ÷+™xI'üC“:9üΆ³îw²Ø¯§Åâá䯣n‡óX&P|gut&sYÂÝÑ“Í3|ùÚY;¸ä¶¢ý§… ÖiQÔãÅËÉ4gû~KÂ.’iÊ~Ãvy@iÀ2§wŸÎ“¹9aO§ú®%…qiáËû“%;#û½×K¢‹÷¤¥y{ t›zEÖ²dÚñm²¬çQd¶î@Sy”™1;â/<¶ˆºod€'JŸž3N‚‡«†*”ÞØ!é_ŸN½±vwß¿ô‹¯b­‡ ü·úwmoÖ‘:}»?<¹Õ½oÕèÏþÿy½šã |ûì¶Ü¿¹gúh{IûQH÷÷"5„Ëé¯-Gêäá~î„îÀ¶)ðdõ³e;’M uÇüo¾™­ÿÖ~[z’ \ФýbfÅ™µ%©ÿoœÿ~}Bþ‘—©aÿÿž×¶³kß«áF}vŠŸÆíŽžôžÿˆ2ÿv::ó_íÞÊU™šÞg7çHûäÂÿl7ÎŒ!ÕÏþs¼¿ùý›ßÿ<~ÿRÿÁ Ÿ Òt]”,]_%Oט)þR_ÕŸ~ÚˆkÐ~­×R§k¬4èš.MºÎK‹®AÓ¦kðtéZ·át_o]›]‡eD×öÖÀD2Š®UC×õ£k{ëÑ&Ð5~“LFbŠÄ¬·†®Ië­]›JׯõÖ¿YÒ5a3XÿY ø³¾l&ºFE×øÙ"™ƒÄ‰=’ÙtM[oý˜’¹tí¢ ’yH\‘¸ýYï†HÜ‘x ñDâ…ĉ]ï÷ïÿ*ÞÿëïI G¯VJ¬] ®ú˜éÏ4x<Ÿn(Ù°…‘Až ”-6eÃáG Ämxl¿Ð_<ÝF às$ ¡ š/)±e …Oü‹Ù[iBcòØÂ‰‚ÇŽ‘ÌáqYM)dGÿ²˜<‹½”Ë‘˜Q`qØB_P²"‹ãÇŽŒö5õÙ<ß¾Ñ2%ÁÍAÄïSË8òâ_ÛŠŽ‚?nTDˆ@™^7þæš":ŒÇ‹ÝûùˆþõôôØÿ›§F?v${|€ð§©ŸïÂ?þœí JAgss/data/nox.rda0000644000176200001440000000212713267106071013260 0ustar liggesusers‹VL”u¿à…ò¦„ÄA/½±G°ð*fσpZ–ÚØ5ÅfM9+4û5gY3§Ù¥ös%k]sÌ5‡JÍÈ¥ÍìtuÂq¼Þ¼ï½ÑëûãyY»íÌÛÞ÷ùÞû>??ŸÏ÷»wM…·ØîµÛl¶$[²¢Ø’’ÙRIb·;lŠm³É¾Vv¿‡/Ù•Æ./®(Ø·©¹cæ¤Õ(YûÑ\WÖæ~Ýꩺx®eíßöí ¯ãcuc~çÅ \üìŠ}éÖÏa쓺veøðþ‡/'+ážò÷ßLÍêãáÝŽÎ5 ÙĆK`gtß&ˆg9ýÒ÷߀ʪ-ìþÓ3w–ËĹï­âg½K<<#>UóÁ»Oþ^ŠPÌš‡YgÚÜ+{¾B÷$ͬ>Õ?!û…€£sux÷½Ð.Ò?‚ËÏ ?Ì^ Êúq0*óÀ¯Üûµ°¨ˆø¨‹ÕÖËãâLš»¼IêÁ¹ü4D¸,<Ÿ¢Ç-?óÃE1Q®b¤ãþR ¹f@Ð ]H<@/äBï…¨€m.¨’oй)k·qä4Ä(Þ4W@ìÿý7H×#|;å^‡!¹¯@“û"’‡É¾É_´Ñµ 4ó=í?}¥@ÂXâôýbÜÄC u ¡ƒÊ«æ€~EtÚW= ¸ñ8û)̺gÂé=B}ª„KPž“u†¥n!,y„ áZ+ˆ€(áhâë‚‚ñ1ñàtµþ*‡¯ü ÇÄ*ñ~“x6ýL¾ âG£~û çAâ÷&éLð6@Lž‡‘ç4OŒæWI/#TßpsÀÃíƒ~ÂëÍ ~ÍskàÚ_“çq¾ämJë´°SŹÈ“uLá粨ãH°Å 61>ÑßiáçºÍúV}$ZçÖ*¯ë6眮µêwº¼OG+¬úpXèË„OŽ”Æú-[Ø"]|tüï;D.•M/>o®7ø¶lMˆŸÑì{Ùeæ˜Å¿mÞU¼‰…6l®o1 ™í õÛê]Ï5³xöo‚_ÿDJýb& gss/data/buffalo.rda0000644000176200001440000000044313267106071014071 0ustar liggesusers‹ r‰0âŠàb```b`faa`b2Y˜€# 'fO*MKKÌÉ2ù€ØÞ!~&ÌrÒÁmi ààÙsÎ:„턊ó@øQ àz"½Â·d€ÐÁÆ ààuÂw~1Ïÿ D¿{$D_%Ô\¨|ŒÖ¨óSƒðƒ¡æAÝç5ÇjNàgˆ}P÷Fþ„ˆ{BÕÁü3?¸¢>ø2„Kƒˆ‡&@ìñ…ú#ê˜ÿ ö9Cís†GT] 4õ19:ª?jO Ô‘PwGBí ƒº;ð4œ¡ñ1"î µ7ÁPýqÐøŠp€ÐÑ PðÊZ¸.gss/data/eyetrack.rda0000644000176200001440000001323113267106071014261 0ustar liggesusers‹íÉ“GÆkº{ËX 0‹ÙÍn6£u$ÝŠp3D˜ ãa,[ ^X 0˜Å+Á‘#GŽ8øÈG8ràà@È´ÔÙ…=¨§+3ßË|™ùsÄçjI]]U™ßûÞ—Y¹|îžûNÞzß­]×MºélÖM¦ó³Éüݬ;2?Þ²÷øÞþ•Ý»nzûüÏ›s¼®ë¶/¼ôôÝõÿ^úù3îxËâø³'ǧþíŽ__úOwüòâø“¿¹ã½‹ãÿìŽýâøäÝñøâø£ß»ã‹ãëŽÇÇ<åŽÝâøÄc‹ã÷ÿ±8~﯋ãw_Z¿ó‡ÅñÛ¿[¿åžãqwÿ¹û~ÔÝï#î>¿éîoßÝ×Uw?WÜ}|Ã]ÿ²»îCîzºë<à~ÿ«îw÷ÜïíºßÙqçÉ÷E÷ý/¸ï}ÖýûgÜßÊýùD÷ªÿz÷çÞý{ï¾ß»ó{÷{½ûýÞ]¯w×ïÝýôîþzw¿½»ÿÞ=OwÏÛ»çï]yô®|zW^½+¿Þ•gïÊ·wåÝ»òï]}ô®~zW_½«¿ÞÕgïê·wõÝ»úïzÇÞñ¥wüéŸzǯÞñ­wüë{ÇÏÞñµwüíŸ{ÇïÞñ½wüï]<ô.>z/ýÓîy~q—;ºçúå9wtÏ÷«O»£{Î_ßçŽîyŸ9íŽî¹ŸùÓâø¬{þgïqGWÏþeq|ΕÇsŸwGW.Ïý}q|Þ•Ïó÷»£+§çÿµ8¾àÊë…}wtåöÂÇ]ù½ø¤;ºrüÍmîxoÖ8Çx\*Z×ͱ¼1¢SÙÊ94.ë_„/Âá‹‚óZiñŸáóa|Εw Ë ¥äÛ¡*å-þ ÿ†#ß…æ;õz«…¥×ó*þ¦Ö¥Fô‚¼L^&/“—“¿o å»á×MùeVÏR딿9p¿RùC]wµù¨cøü þÿì_´y Oá©OkÕ]©ú°ÂÃ对óy0Oñcø1òy.T?àk_áO–¸%ß‘ïÈwä»à|Ûäolž“z~åøÎ+ÍðÛ˜Žâsð9ä |N°Ï!.ËÚã¨4¾¶¢ß±¼Ö5õøm̧Ԓ?ñŸøOü'þ“~6ø[µù¨Å߸“Ž‹UãaÆæ)|>Å'„¾W)•/cŸÏZüÁsYž¯¨ò"y‘¼ˆ^çExQ/Bõa$Ÿ’ë]éñż ò7ùÖêÿ&nøëÇ_­y=Öòr(KÓáFÚø(|> 죌Æ<äq)¼Ë¥§KþT÷fóõŠúõŽgWÞѼð̯Áz›¿Gê~?ˆÄ·csóúÏëË"ó„ɦ׫øž{ß |¾_@^õðI†O¥Öh=¯‹ŸJy@¾%ߢäÛàvXmñ#ÍßJù°NW£u¡´¸·ÒOû<+ê/[ÞÆŸàOð'ø“PBÜ•wµÆ›T9.u©’ø­5/|8OVòϺ|°¬ïƒúêë»ðsäü~.ÔÏÕÊwx£û^ȺnäÖ»e~"?“ŸÉÏèlh~†ßðÛ¿©çÃëÙ7nØŸ_©}ñL<·ÏZý"ÂõYJ^æk* ‹Üyfù|K~®‰#|!y„<‚/̶ž•õçKgfô‚x­³§”×ÖÅ{)ù ?„¡¯¥ÍÇú?~û¶x§­Ÿ«î׺þ®à‘õ<¼¶¬Åëªú ŒW|> F>4³ï1õW¯¥ÅñÁ~@ô ì~êÐùpø|>Ý)mýúZy _uùš[§Sû‚RtzM\æö±ñˆÏÂgá³È[Áy«Tþà ]^¬ÈÍèŽp½kçÏÔåTKžÃ?áŸðOäÉàv0¼+›w¡åk­œBëßj\­÷Uº±Ìcäwò;:K~g\é~‚ëtL­ÝeL'¬èbr½’Žã\qÚˆãgð3øüL°NÆ–wàýG+â¨6þ²®yŒy?8ïׯgøÅt+n‘·ÉÛämt:8oÃWøZ_ÉKAyI<áoúŠV}Ÿ¸Ž;~âËñåøòDðxi¾IñË:o#}6ªÏ•ë~¿€_À/ðþ >ÊçP?)]«Ê;–W¹x°®¥ù®ÍËÐóÑ×›ë+þ F>ß±ß8ñUB|7âyþ™Ôwëþc´¾ÕÞ?¹¦Ü´ùÿÆ£ÏøoéusKчæã Þ‡ñ^[÷—º§]ÖÖË¥<€Âá‡È ÁºØ:_´òmbý!Þ‰÷QñnäùŠ÷ø.|¾ ¶2®ßj/ÏuñM¼­‰7!^¦Ÿäqò8yœ<Üη7¹yÜ‹×=âÞÏoŽåoèú±ø| ¾_êK*‹;±xK½î¥5=ûûRïÑ)ñ<²¬WôÙ¤>ãÏðgø3üY1ïà[|k]ï«/ ¯´tÉ¿Áßoð7Áº‰Ô¡ã¶²õ0’é_n½Î¥Ï¹ôÐZ^H¥ó¡yhM~ÀâñƒøÁà<ŸJ'ˆ'¿xŠåóž®wi}­w¥¸ Í;Õéh㺈¿É¬Ç¥¾7’z~ÖÍ%¾h?Ð~(¥ý@øÅü}Íç…\üLÅ_ßßYêx.ÝÎ'øüþÿìˆâƒø¨v]_­ü©§¥Äƒ=°Þ.N”_¬ê;>ŸŽÁ‡0î¨J¤yžŠwcר¥^ÑÓ´q/üü+×ç6–·ñ¹ä7|.>78ÿguÆYí¼ägp})ë\0ÏsñVz\dªxÍ ¾~ŸFþÀ§áӬϻªT'Äã5–ç©x£¥µè•ÖýeÎø ü~¿‘}~Z*^Â[ü±Ê—Äõ.–'é0ùÚ/_wÝôh×m_˜بOh^Có¾KEÎr°Ä»’ž-uyÕ®= ŠÜѺVS¶mh5± àOÙ®±ÒæÓ,+t¢ î -öûdZÕe|Pýz‰G¤A¼h)®Z.;¸RG™£—öyVËó[|_OžoOoñ]yùÐz³ôž@êyi ¢[‡q˜ŽÄ ÀÿÔ£5iB»”~ˆÂs¨µg@É‘äȺ¼/u¦wO©çqÑvèà} m­VÊÆJXjs~å–.FK_?!–_ðŸ±Mx‹WN?¥æ¸b=;D_y°–¶ eØF´Ïø$Ù±£”}Ûc³[Ïýäò2Úp›;-ó¼¦üRë{6Ë:TsŸ~ëíÅ\cᩇ´å¥õûøžüåA\Õï[É‹´—@í¹™>ƒ|儞խOôѵ=‡)æzµ·Y[·Îq°ÖùA.ÉÇóÚÇKÒ£œÈúõ‰ŸFÓÐ [mÖ¹I^K·G˜Õµ—Ø£Š|ò­åJŒ€†ú2r­'×úú£h¨¥¦µñ|­Æ/Ú“f¯™ZæÙäÚ£Ýòü}üšWJNÇŸ•±GIªu@kZo‰=†igJ”?:ríyØã¨”õÞko_’_Ñê¾NNáßÒ”!1ÊzÈ­Ïu‚Ûh&õ¤öZ` Ð ¸Þæû +{Oà (<~jÖÖRÇjk‘³´:†_j)?R&Ä|ë}0pî´ú>°ŽqK|n9Éä¶V8XãüûZÆ9£]èLÉXãúî´/ÚZã «»¼jÞï¸Ä6$šYλB|ýw%¯½2Ás™­—Vã36{ f‹ßœuGæÇ­K{ì]º:ÿtìÆÕ»q|ùáÄïoî^Ú¹ºüúð#wv÷/_™ºÖuÓ£]·}z0uÞHÙaãXÖmÖc€e|m¤‹ø®¯ÌѤv}²Å÷õhZ Èùµ/óC¢[9u­JÇ bàða´KËßÔ¥™­è=œA[JXò¤•-hC¶-9æèäæ[N*ÉSð¿Z{½³ËA²4¶¥qRäb b¿=²MåÆš/hï1©ÿ s–í:ÆÇõ½  Ä:¹¿l=¡Ï3öxl™çÄlÙü§\qQÏ6UŒ‹x.xDù4¤< añzÖ¢$î™cKÝRw¬; Je=&Ñ@>,‡Ã­ÅW cvÑ84­ ¢ž‰kòZïÞR¿!í b½ÆØ§ý Úêõr­ôSÑgŒÎ×ì3EL·[Ï5¬éʸí|}¾9ÊÍBóZl»Ð†#Æk_ÊÔ¨ƒvÇ÷’ï¨;¼$ü$NàF+:EÀc€NXëÚXÛ™¸¥×úš®hè~†µÇ´®E½ W¥èM©ÏhÙ+¢ hç}M÷(±¾Ÿµù*Œ/”;ù©Æµ‡jàmé{°®”n4› x€˜@%¸@‘x=dÆ› @¼P5>øT‚» 6 q¼¸ Ž@&¼@5x€dø T„€'> å`6éºÉËîÈñnvcÿ­É‰ç“çSç3çíå§“Ã'‡3Ngœ<=|Î=9œ{j8÷Ôpî©áÜSç†3Ngœ¾wz¸ÆéáŒÓÃg†3Î ×83œ{f8÷Ìpî™áÜíáÜíáÜíáÜíáܳÃ÷Îß;;|ïìÿ¾7\ãìpsÃç†3Î gœÎ87œq~¸ÚùáÜóÃç‡3Î/Ϙž8~zQáÓe…o¸Úº¸³»ùÊüÓµ9ŽvÝö…ëk«†™-—úš‚‰Ãt$6á³|ÙT“C°‘“‘ˆy¾18¬üc‡@ú>«4¦JˆáO(SjÉaЪ«™‚6L B’3Ëçœ)r} r.q)yOcxd-?äÎcRت!9sðýY Ocó»´W“ð¤Ëû‘ÖØ(5Æ-Å`¨Æúæ»±¹'ÔŸlxž£™o6#=äaçv>egÁ›øøŠzÍåQSù^Ëú›/}Ëå —Rµ‹}ïÓ‚g]û±q˜«Ý$Ùæ Õ÷åÈF#¨¥c¹ŒCãY3îÇê£åéíšm¿±:Ú?hÉHÅ›v_£V<ø^'ö=Ѻ¶ZL»ÆJ¿õØßñmcùú¯±ÏºQp ‰öê÷kVÞ׎•ÃâQ£]é›ÏbãW»œWÝ‹¤§ö­“Ø|>¦\­Äˆ…>š›•?m%»}C©ËË×c[lWÌ„õCÓwM…¼“u/ãó¾nª¬g-¿/Öz¿àó®ÇnÆŸ”ï„jÏ¿µÇâ¦B{~Ò¬ KÑG#å/,¼O-%¾72ûè‰ Ç¥bǧ/c 'CcCËû‡öëJi°ôX1ŸžÂó·îA$9+Áq.£;þ@Ê£§2Sœ×¤Ýg-ÕgãQ+;oè3¿#¶¿B£®ÇÔÝ4±¦ÕA÷Ï©û<$}ºD_Xî¾»TýœZóbs­ö\‰6¤¶Þ´<¯ÆWW´ßíKõ­jyÔÜcbß…çß3®%[‰Û3±¹54?‡öÏùzBŸ~?«sŒ¥s~L® yG;Ì­Òk$Äΰî%¥×¸Y߀ô|Éq[ëÖ0ã RÏ¿ -£ib¿š{Ž»¤N†Ì¿ÞÈ™“.ïxT -š&èëXw¯5Ï™‘x[ÓÚ©òMè;ãZß÷m…èÊÁë0NNÿSö‡§ìÖöŽRë}i¬•jü\ŠõOr½ÿÍ=G@#‡æÈ=’}p¡k#탘*ù‡œu:%×ø8æ²È¶åJyïã“‹5ú¦Ç®kµý¡1ÿxf¤j¯§È1%åÂÖç¤òµ±¾ì0- Ñ*ËóÅ4ãOc­WÍ5|½¡¦ÖçШkU2÷!MŸ”–.çXO<Å<&ß¹9ç'çô0)âÖz9hz­všEŸ}³ºÛ¾‰Ýs`Öé­M5—1VgJ:%¥‰©ö²É‘—rû±ªš¾&Fû58«1—\ß* -eiAì{Ÿþß5È%ò½¥µw$´»5¸­ª'Ƭó0&vBµ ¤}ºþ„Ô˜^KëÍóRÚSÓÎ^ñÔ³L¤ò]‰ûÏ„¬§¡ÝGdÑ'jîû8›]þ1|Ú±`qO>úÛK!1ŽJª#ÉõTã8^y=M]ʹ¦ äºe÷§5§”1Êcy•jo­õ†$óñÌXj"ܦJ5Ï<µ±¸¦³¿jß°YD_YεÑS°<7Iko"É}¹¥×v¥-c£9wKÌ·ÔZ£:Å>cò³T›#Õz;ÖµtÚÙ_o,Çú¾¿ê{¬úßö…¯¥|Íùc=HKã±Çjæ|ŸU͹O¼ϧ}ëÞ­Ûÿ3t]¸˜Üžº<µû²bçKÅ–ÿº>gß2’ð;>kŠÄÖýª÷ñ“¾Mj]“1×k¹]ÉÞå©°4Îaì:H›Ú!óˆcë%¤ïRò}žÄþäškhuó™+ÞJ¿ f¿WJÏé³¶šÄÞØ¥µs&Ýøu.×é†EïÓ,Ý&)­cì<”T}>1|Û\ƒ§LùŽTã9æ·HiÀ¬Óß/³FH¿¯Ñö‹cæKø¶-|¸,1ž.$/¦Ðj‰q…¥/ŽÕ`­õ ÆÖ“O݆ÎåH½ßè:=ŠÍ¥©çWƼGH­Ç>÷SR?jê÷¦%¯2Æ Õš¥±ým³NmÚÒÆM¦ÐLë㔦™=¦JÝï(ÓÆrk³K3GpÚ¥ß/ø°½è¥ßáθ/¹GOÿ£¤>XÚǰÿš-îmÖ¹“ï<´wuþáØ]üålÿ‡ö–_ؽ|éò÷‡­Ë_ùÚÞî¾ûÓäûݧéîÃû‹ž¾ì~ky[ïßÙß¹ûâ•ùe\úÈ•ËÞ½¼üÑë¿÷Dwý¿í óÿ]»ŽÿÆ?`gss/data/Sachs.rda0000644000176200001440000056632613267106071013535 0ustar liggesusers‹ì½g”Uåòõ»»{w$AT‚# ŠE÷R@QTÀ( ÁfA% "*¨ ˆ‡` "IAQŒœƒšœázΞ¿¹®O¿Ž{ï÷#gŒ÷õtï½ÖóT˜U5«êº:M«4-H$™‰¬d2‘™õ×ÿ™ÌüëÿËH$ùý7ûúÛîhýH"‘uÔ_(þ×ÿ+™Hœxfj礕SoiÜ:µ{ùcÛÜÒ(µÿ¶6«Ï{æ–Ô™•ß|sôã©ÝU)QpÊ©í·okR¯ÝàÔÞ^_¸{\FjïŒýÛ®¹µ[”8iEËãæ®Ií8û²Ÿ¦ŽÛ›Úö`¢\£ïoKØüò®;{^—:¸ìÀ¬®7ç§ö”óPÍGz¦v=üï+·YÞ¡sjOŸÓÞæöԮɟœ}A­n©}%?l×~ÈšÔžæÅX}M±Ô®ƒc—/¿ü–ÔžŸw>œYüþÔÞÃnJí¿ÃÿÝÑèƒ}¯ë•ÚÓ鸅­~LèÒ¶WåÎR»GÞ36ë͇R{¾ZsħlJíí¼êØÖ R{S÷<ÞBÔÁ笪S£ZjÉO(~q•ÔþÍ_¿¥Ó´Ô¾OêMiõåo©ýQÕßI 2ÞÊÖ`b±ÔÞÎ-çäõ|jß/?þÔ®í|Þ/J\ý^ígëVNíì}lÞª£û¥öE#ûþÒ³S:êØ,–Ú?é› -^èš:РñˆsНILDµêÔè’ÚwíØkÏüwËø9ôsþ{ýœî%Ê,5~úÒ^WûýöWº{â}ÿ:8*ê{Ô›S»þò’…—NIìrS•‹›~%î}g™#«¤6ÝÖêÔ1%®Mížôö³eO\ŸÚyÂĵÙ{?‹2Æ%Jœ¾ê“Ôþ³^2é÷OS‡Þ5ìœ!IŸû¾–åÛV+µsYí©%ÍRûþùôäå+}îœï©çŠ•ïªß÷’¾©ý£ºÌjòû~¿Çöí—|]íìR{—lþ>•3,µÿÁ&Ç¿Zaujï'Ÿ·½á½¬Ô¾‡®¿~vV¯ÔîRÝg}yÆ ©C}òüñí©ý·×yLË(ãÉT— G_›ÚÖ'uJǯòSF·àÃߌß{òEn\ÞÛ¿¿«ÓMÓÎzU”5¯ÄòkçLOíyCÓ£Ÿ¬a9Ü;ø™E/îù>µ¯Ó¾¡V˜Ú—(ßü‚nÝëæ>·NÿpVê`éoçÕKNBxß(qçO÷U-,ž:Pmð+¹·¶µüî>têÏOü6#µ§a¥.éX3µ§°ñóÞu4çeL¯ðʤeÙ©}›³¶9³]êà̳_­¼{qj犯M{® ¾ÏJ§v¹»Ùç©C_ sÍ• ßÇ ½ú|¿}½¿ïWëGìž0¿vêP—Y·=úb(qqÕÞË»@.¬Ç»2r¾Ø²îDëçÀ¹îm1bò¹§W°>ïm0xîбuR{Ë÷ê9ôç3S›oºæç»§ýÙ«Ír^OíŸñå˜üS’©]•ÎYÚåºBËé®sï}m_(qÄvu6ËvæP4xTÅ×:D™­»Þ{ÔæZ–ÝK”qûȧڽzòk=ãù4?pÔ[•ϰþ ™Ÿ¿iUa>·ý[ª_;ì„~©C3´^xkž;Jœûkï‰ÝÆyG‰:|ôì/“Sû†~ôù¤òƒŠ¼ÇŸJ½~¶O{,õÓ¤íMRÛžœùЗ‹:G‰¼ßßÙÝû7äš÷2.X±­_ç‡Rû‡ÔìÖöä»m?°»»æ?rKUËú…½:Ø ü-e/¯›Ú¶qð¨ÂT[ä:µY¯wWåþeþþ¯c†ßã÷Dlgô¹ûûŒI¶8þ€åJÏ%^=éèVSü÷ÜçÎGÎê²aÒ.ÿ=öi{õCë·ñPê@©ëó_žÜÜvž{Ø›qÅÐ?ú?æïÛ¶ò©Å÷/nýØúæÙ}ÿÊ–Ô¶ùm/)y¬åû„ì¬>ù£ó·úü%‡>ç=KkNþóëÌÔÁÁû.?㵩C‰#§.8bSjëçö}aԉȗï;ÆûYŸVtX8ì¨Zö;oÝÙdTíb>äòÀà)GeUlÿŠå9ýüQfaÓk޽cZjσm¦Æ¦-Uh§–ñŸ¥§ØÎk_ïu¯=sÞJß'úŠÝGNù~ù;ëÇÎÿ,;ÿ­oûûþw¶¿kÍŽ”íéŽÛOxô/y±=•¿Óû§v•Ø9¢óGyÈu”ñò¹skŸñs”˜|ý’Žì”ÚsÙñgW+< ÿe|ÚûÞ*ÑhË8ûq°÷åÞ¸%uhäöAw¯>ÉïÉ}ãWìgôþ‡Zæ—¿äŠý}û–ìëúþóÝb;„^¤ñç•Ú±yÕ‚™‹ª¥ÖØí™Þ<µµïÎAµŸ½Á¸ƒûßvWù9MŸnžü1öˆsÜó_ÿåÛeôt׊¦c'œº'Uøý€¹Í–•‰ñÆäÜŸ^/<Ýr²eøYe*7Y•ÚWñ“;w-ßâs*|níMÅu¶=g¾~u‚ç›ø}¹žÜÁùg6·^ëŒ/ŒOðÛêÕpÈëSR/Œo|èºøùd'ñ·‡*¾ýÁô~“S[–5Y<~ÐüÔ¡Íl|oÒؽ(£lbÛêä,Î)ÊŠœÜì‡Æ~>ëa¯ws:ø¶ÏùÞ]±ê“].)—ÚSqË[—{Ðx»µwËý6Üx4~=µûÒä¦'Þ_d9BߥQ¢°ò¦E¿lˆõ€÷ѽá9·]Ñ_\·øVÛÿ»ì ÷±õikÏ<¸ÒxOŸ%Ž»µÛ–ößøKîÿ œŸ÷$<žÕçØ^ìntÁé/8`ºu{çÄ#­ß0îØ}öGoÜãÅöÈ#ö}A϶3QßÌÒ¶³ÂÆç¾ôSø¿±û¶Ú{ÞÜ͸éÀòS^ûðÌ×|ß{ªÕ¼ç„›³mÑCô}”ýoñí–ßϳžc_ð –á$ðŸ^/lõ~…§šN5žá9ÁÙÜ'~ˆïãÏ[öÕ_8î´ÚQâÑç{,ü¡k”qÎë?\Þ´”ñÿŠ¡µ›vØÛœä¸¿±í›ñOÛ¸×?¿½ó ó<%Êltàƒ¾Gd=âùÀ|~’çäs6ÖÚùÂõ¿}–Ú9û@ûMûkÚ¾J>±o{«•Øôé¹oaGÀÂíQöæŽS®Ÿv©Ï/°_–Sã=wáð^-NkeÌÛ1ðÝI_§öMz<¿Z·]©íyyò±ˆ£¢Ììy3ç43Î6îS€ü ÿØqì÷ žÃ>ø½Rgžpþ—Åm'yŸƒÕJ¯)Q¹{jk‡Kß)>oL/H.À;?Ƹ|«ç2N—´ÜOÉÞq~[>}úi—í±¿çßñ›[Œš¼–±<µ­êg%Æ·Záx?¶uVÝ#î?v¯ã¼ÍO§îøÊñ–gë38AöÝvN8jG×7ŸÈí½Òç̹áçÛé3q§ñ¬ì…ãdÉ£ý¹ð#ñ§…v†óÜ~ÿç·¿¼—å’sâ=¶¯W¾ìÁù9°‡k—³à†ÕÎC w܇ï]ñ5ú.ä÷ð‡;7>ôïÜw;ÇãÇy^â5ÛùoðvŒçÇ¿qO>ÅÃèç¶äÒwêTïÿaŒ„ãð?|ó0iá8‡x†¼„ó)²kÄMè!öoSâ”gGŸ<Õr`{"û‡?à¹9Û!}?ò¨·ÿ%®Ùúñ [ŠO™é8bGÉóÿüzÕs©mÅ^ÎîÙÒ߇ž„~Ñç)ƒ½P¼›ÚùôÙ—íû‘ý¯ã#½8{'{Š¿²ý÷ïKîÀ?;fÝüã›÷úy¶¼Qþ”âÕ^ö{ÚnH?ˆÿÏ@À!ŽoeÇ p5þ‘|HÆ¿VméýÔ–ò…äÁáÎo ¿`¿7½íÔ&[~ò{bgv^Z·òÄeÍb{*;‡}Á~€OÀº÷(£õ[Ï)Ö±H¼?&ä¿>üÊÐ’—ݵáeÛ§õ{>:ù¸¤qÖ¢d¹Íß mä籜+ Þ×{G‰rWµ:©Öpôûn\‹ÝÁ_±[ÛFþùïú»Û!_ŽƒÞzþ¤ùU·Û®lß¿eЂªÓœg!ÂóqnĻ޺rõ«;ãpáì(v\`?$¿²½Á†_Ž®¹3ŽwÓÏiùà¹Á-;Kü±£ÌéUc|GZÏC\oJ<£ï³<éܹãsÙmòEΛèýÉ‹ ÿ[f©ýå‘Ímáðt”¸aÚ¨ÓoÿÈv{H2ÄÍàô*Œ;w÷éóò¿«ßê|¬q>ùHåÁ½[ê\ÿâÊOïqÜÇ99Î‘ß õ¿‰¾9ß/?àþvmœ¼æ‚yŽ{sî¿þB±oø3\òûÄMö»ÊËîxeXù‰—á8 »O]ÂñXúþ¢ÄϽì^fzœçâIå½Skù@îÇ‹ÛÇLøwAÂßËsà°ïè8ÌùÅYøCì9ï½}òɇ†¾´%K;1ªPÂ8™ós¾ö–ÙõkUÎŽã2É1~Ýùá ò^ÜöwëÙkÈÛÏí¸MyMνpü¦sôýÊÚ®qØcÝ7z‰]"®ßþö¾O?£iè\'T~ûÈùù|¤$QÖ…ý£Ç[tརÌÔK÷kÐÒ~\‚_×ù;þßqiÁîþÇ,vÞKrà: ~ÎòÈ}¦ï¼ Þˆ2®zêÚ7§~Ëëˆã§ÞÇñ r+ÿáüŠý5õ1þ+¿Ž•}p^š¼ÿ^ò\$þ’ü`?Á™ÎÃ’ŸNw<§û"?§sв†Þuëð¶#}>àî“¿çç;7·+Ws—qï¡`CÛ«2òâ:æ¬r/ݲîIë#8Þú*¹“óûröƒò—Š[,ÇòQbÔâûkw¼8ÆOzoðñ„>Çu˜?ZÔúWÉ ¿:®Ãþá7]wÞ ^ 󣙉EçNyøy˽ògä}ÞØì&òŒÿós Ç wÂiQæ9O|øNÍQfù¦¿ôü¡GŒT×^õû9ž‡°eâ¦17t·ÝÚrj›É­gtõ÷ɯߝÏçþȃØN+N%ïnãˆC74¯ôS¹&'Zžø9×¥ÒxÜu!Ο<>~ݸSþ™çA/É?Lû7äËççs+ß~cå5ßÅuɃñŸÎ÷Äßrä%ÀeøIóCô¾Ø…í2è¨~%c|¤x„Ÿ·_#®P~Àù Åïü>öÔyݯìS”ùd…Ûú(™š·oY‡~ûÆ™¿ž í-öÞy2=Gh¯Œ—duQæ²-÷¯7•ßÞݸè¨7S;–X廞ƇæË+޳]Õ{Q¯È<ÿœ7.>¹.uÛ}äÐyð¡ÞOúf»å¼kpOàoî} Îò9pþÂw–wÕÍø^â;ä;j^ç3§±~n5®!?bþ~Yv|ÇÁÝNé´ÈçÇsQ?r<í¯ÿœ‘Þ¸IÞQïã<r%}ØUuÍDzî‰q–ìx5sØo~8£n”èÐàÔ‹J¸~mˆýãÁµ’ƒ(cbëKÚ¦b¡ï—rOÎïËþÿâÿ°»ægQgQž&Ô×›ô9ä•À)Šï}ž¾OÙožO÷ãUêÉÔÏ€¿Á™™ßßPªùÛùÖkpõyì„õ’z¹ÞÓ89I?ãsêÜ3þÛqÂ%gçÜ·0>_äAz°}VrÎiKž‡€+C|evjÿËÆccùÒýú9ˆç]·:¿MÝNu&çCe?m÷à+'ÁsÔË„‹°Ï’_ãDì‚ðDüþªcÚPÑs‚£ìÏe·ˆÓmt?Æ/àáyé™ãpåÅ?,oþkÛÜËVÆu6É rì¸Lq½ëRŠó¬×Òg×)ˆ”‡—¿5HöËù\â0>{OÞJy!Ûã0N|k<¦ú/ñ2ùOôCöÛzm^'öXvÏvYrJÜ‹½7‘Çs@yGì­ò¨1?Nö|¸å&í¿à3FGt˜¿ü…—ã<ªôÓþÞ™þëó—ÃNâ/‡Š×„Ÿ¢Î⺢ì8ª¸ó$ž2u(õÊä¶ŽÓä¿£¬’Í·u=p³?×ySɯäÜþÛø©?ó¾ÂÙÆãä³yŸ ¿j=ÆŽ‚ï„»g“çæ{ˆ+ˆ»ù3ç({à¼1vÏüø"Â1ÎWaçÈëœe‡ì÷¸gó(”?A’Oäüµ­Áéï5m14¶ iž¨ýeÈo î? ¼Êß›ç+ܾ€WÈ9aÿÀ‰à“à¿ÆKàžÇuZÅS®£ä~eGåOŒ³±Üõ!ì9v?Ä=Æy²«äï¨ÓR/s¼àêåðó8?ìyCìùûËÀN`÷±ÂaQfã[¾µN‘'/A]š8—øÀñ®ì~ûE°à=ã3ü£ä˜û Æ}~|Ò›;·¾¹9þ\òÒ[âêMÒwÇ®×(þÎܵµMë¶eìÿôï!/Õ߯{Àržæß(¿a¼@žóSÞ8 ûlþ­pqâæŠGõïEF\W'?ª¼6ñ²ùA]Ô<É™ñáÅ[4ùù¥"üË1u"åoœ7‡þ_ù<ê"Æ9È=x ?ÏKùhô ûµiéQ·Ý7ª“å{H¿uóØô¼Æ—àüRÚ_¹>éz‹Îßyób#TüóÔŽOëU¾î§Ep»î3Ê|è–RÅ;i=CÌ£*\AÀùâÉ´§n‡_¶Ý7HïÑKçå÷Ì›Uý ûoÂq q°êòܯóMz^áfâë¿Ç#ä½°z>á¯8§¼&ù%ìuXÏv]ˆ8R÷ä¼{:o%¾m?å›êõbœ­'Ž´<Èž8o%9w}~‹ð"}È»x äUÂ~ãMêBâ£9o.¹+Lüï¾WóÆÈ³Ã×!þÆ/K]ׄçE|¤'¿ê|—êßø1ÙkÛ±Œ×~ï¾è³-öwÔ Àògà!ÿ;q98Çç Rß«üŸñ«ëÞàá Ý“ñuoçùôùà8÷¿çá‡8᮸=~ŽëUò?ðO‡É®GÂ'H×?âóãß%–KäWq[ÆÚgÆVÈ-æøƒïßñðc=þ=üÏø¾äG°o®[ÁQœDBv,Êø¹í¶•ûzúsÁ}Ôù©ºŽ¯þìóLðg$AÝ×õ÷ˆ¿ ¯ ÿµyrËþÑþ)æ±…}nè¸ÒýIð˜õÞð£¬g¹…¿·ž~Ö¿š:ðrS ’SÊ-¹®iœ¯‘½"¦n ¾áà ž|áæÜFoú½Ð{òg›[¬¿èçêÇoÏתë꣭·Ä‡®‚×egÀ%ŽéO¡þô“øÉ7v~ò–2W•\yàòÔ–¶t{îΗ]?æ\Ký\Bÿs|è:²ô`m…YUóî™çxžxØ|DÙ­íýÙôž }ÔùÈ»ž$eÿ¯F¸„>×mdg×…ƒ8?çw©£)¯ã<‡Î×ú#¿jžâ9äWýFñùî÷×Ý6¦cÇÏn±=æ<ø^òEÒ+óß#ï%|D½Áñ„ÎÓ¼Zá^â÷}(ÿcþï™–×½Ð{𸿾ò6¼·óÒSοCüƒ?ÉPéîÛnéóºÓråøyvŸ¨ä y¡Ÿy§¶¾Òýy“.Xet)X\îÙ„ŸË¼Ý'õ"ó«áû a8'¾—sF‡ÄËÆ_7:¯%ûæw¶¿üÎóöTŒ¤È­õ¼¿CrÖu‚_ÀÂ9ËV4-wôU_º•~òà0ìÈ©2•^]ÿ«ã}äÀq;u)xPôÊoão'øåK÷.íñìqìOàë»N·ŸG߆ü™ì’y÷ü»Šs½Y¸ ³Þ캽:1æÈž«¯Àþ†<7çü’û¤ÿ®O?IŠÈ¡?þ*ùá)prˆ_·ñ¼æýÓg(ùÚÙà£>3³·^"ðƒåŸí§‰‡x^ó áù)nØzå÷+Ëïªó›ÿ¡oÒ|¤¿ã­¸N {ÚóËäWÀmëoËxkäg»]¯æ}À‹<xˆsV?…åØö"à‹qØGóòèãÕûšÇ›¶CÎk›÷­ú:¸”çtý#àÙNè÷øo'ÓoF?7ù%ôÏùEå Ä6ÿùq¾QxÄ} º'÷íqq‹ûƒxžt>Äy>Ïýôå§ý_œÑŸÝO–Æé1Þ%¾–¼»ž¥s5ßC~†s¶£_SøÞöž }§ôSS7„O§:ý®ÓÂ_WÞ€zùû{øAþÌü:á’­‹ÝôØÇÄ}úò«øÉuËF\pjjNjÓ¥WÜøråŽÆµôOâï\‡£¾H:È›GDÝ[qñx—ϳ½¡ï¾q×ßóøç{ÝŸ zúò»ù^ð.q>OHñu*䂺8Åv›9ú9ÎÅuTÍKp¿?q¢ê ‰q+ÿ˜(ôyQß§ßù|9/ø-z~ñ©cÞpxƒ~^瓉#¨ÃõFìDaÝo¾:÷ãŸãyè_:>u~ ÞüEã4ø0ª—Ã;¯Á¼:牿º<ÐÇåà~ù;ã%ñŽ—ÉSÿ¡.¤ŸÇ¯×ǹOPrE^>sòäüøœóÒÆY§ílUpâ¾ØO©^b¾y˜Gè¾Fâ-âúÉàë)Næyáky"ç%ðO®ÛIß±ÏkþW'È4ïƒsܰ|øôç¼Û~/¬k¿"oàðù9óæô{ëWÜ9¨á…Çý¦ŠkÀ±è‹ðÌ÷—Ÿ6ÿ†>ø¾ðºe/‘3úÉëÏ1Ž£NI}Mñ±y‚ÂkôM‚<_‡¸Vy>âÏ»‘ü»n(<ˆ>ÉnÇýüôÉ*g~³òÝîÔ<º?Þ}«ô9o øèäWû×9èÓÐûp/¼oáŸ]¹¥Âθ/Rr ïÏýÄÌã‘t_¼Ná8ÍýˆëÖÒwú¤ÝwÅœ áð—㚀7ÄÏ[ÎÞv »«¼IÌo¡ž)ywSWÅÞ×ÜTqQ¿ÎÕËÇýŠçT—3ÎÀ¾Ê>Åñ‚ü§yOà"ð-õtæÅ¨/€8Æ<"ìspä‡ÁëÄ^xNöKþÙ}xʧYéßÒs¯;ñæeÛ׊yŠ³Ì³R|=ö<Éñy6ó”/%_Ä}ZÞu®ø½ÍK[xM‡×ãzäUfïK«V"î¿Ò9ào£t^«‡ìY3p‚"vKy ë¯ßCxÐsyNjõQ÷ëÚÞ›ŸŸ\óïÌÃ~!ô©ˆo¿ãù@zûwñ ñsØ3çÑÈó`Tæ=‰GÉ9_¦:†ó2ÊZ”Ä.À“ç‚OÀÁØWûy=熉‹Þøíè-©?[Þóyãšµ}ØOòùž‹H¼Ë¹‘ŸÖ}ò½ø5ÎîuþPv•>8çkể»˜c§>%äÁù?Ù[Þ3ì·'ÿ ¾3Ï•~eâEø¼î<ùOÝq)ý’àüȪæÇ/¾óî/Œ/°OðµœWRü§ê?æ%“_ÊpÓ÷w»Æ¼âœd÷…5ÿ\å}Uì¾ÇŒ²®}ðøFw\e—ªûÍÌ»û™—MÞœ>œ¬éç=×ýº-ä'¢d×rž=òú £Üµïn3¢O”<ûÍý³g\žŒ’›-ݱüiæE9_]P·ßäþsRõñ›¢d½zõ¾~–ç,ý€Q²E£©/”ܤyXÌÁв{ÜøÅ— ¶»ÉãGYØmö$ßköwÛë_Vߣ>™¬ñåÞÙ=n rìx09¬ôÜ — òßgmrѪ¡¢üÖ#'ÞØ#ÊÊÙñd¯¾e,'Üw2÷ëÖKŽþ€:bT¬ÿš« ³o6‹>bñ‚àíÅõxÚ’Wú ²[>:¯Ã­7F¹Ó“«WÏšD>-ÊÚ¹tÛñó’Qv…Ñ_Ô_\Çç›{Åâ¯ùù‰øçÒýoQÖq-æ6¹ÿ‰(y÷’ m†.·|hg|~ê—ãyUÿ‹òKWRå±Qæ!åä6~)§ü±æ g>|}Æ´¨ØÿìÞà):nÉê3`óWg´gNZ”Ó4jýᆃ1_F}ü9 M{ÄgQθž½._Ý|ŒõŸÏ‹®?zÌ…ÝWŸö³Ê—¨em©ÒlñQ£Ìñ}=pÎŽ(ëµmÊë©Î!gd§ž³Žéë>YñHÌåÞ³¬´sÈæªô‰’µpšÇË•ž#ÿôcŸý袚Qþ°J£×ï[eö¶ðÔÚçÃ/³ÊùnN•!«GÉk6fÄéø=¿Gf‹—ͼâQú³ü<ÊÓD9Ö½5k-zì{@~¬¿ã.è\aa{ëv€ßK6½ðé™ã]÷áçüß²¯sæà¨xZ?¢¬÷Þ¾¸\³²¶#ªSùóTçò¿[ïÓý ¶£ürYPú‚î9ò<ß·õû<Ô¬°ðí³ü>Ø©Üy{¯ýìá—£¼Š ÿóÛÕS°£Øgòî>wî ùÏß5k˳ù'Sö}éüc¹Â.ê¹³oÏ|¬þçe¬·óßiùÙ’û¬×ÈKNïiÓïÜûX¬:—¼.gîûòÍ(~.ÉŸæDɆ¹•ªï¬g»‰Ê)|åÇûÕÇGÉéGß³êüOl‡’»+×½¨úóñùµxhùY•Ï‹r[ :ýƒÂï¢Ü¨Êkå«Ü"Ê©xìo³+Ì´ g’×òNO\tÝm·GÙWt=¥Øymügüüלþ3®Ì1Öý?¶znÞ?«â[ý–žeŸ6㾆ÍÞò}yN«ž{`y—?Àž$O£ïåÙ/añ빉Šåß:!r}ÉþQv3»ÕÁ'Þ1Õv+¯i¢r«Ñl±#yß­ú®ö碬¦#šNŠ¢ìµw­©9ö~ßoîW­GM¸ü­({W×cúÕ´ßO¾Yb@™Ýe¢¼–ÙM~xæ¯÷¾¢Wòá‚úŽÓÉ7Tøqrs×F9K»­¹z÷ÑqžRvÔò˜æ½[.Ô÷iÞ©âûCÏ™#¾Òùå´ý´J^û¸ó@ÿsvMß÷iáñs©î—¿tÚ’î÷XÁ[ØÍìjóZ¼Þ·t”û`§uSª&Ý¿Q°yçKÏÝ×8GuKâ?óÔЋ‚óß½õÛÝQö?mÜK†ÏÑø)}Îî—â~Õ'巬׷ç®q?òO‚úÜ-ŸÜ—ôœe÷iúéS…»í×òÛýù`»V]¢Ü¦¯ÊŸ9)ÆYòßyC6ÿú`þ_ò?¥á—ݾÛËU€7¥§Î+úïñŸºOú”' Îç]³ÿÔûSgÅofOî8ó’‡Kù~Ñp rG!~Ov?Å¿'Gæäm}¯»í'þÆxMv-gFËžO÷9Ïö ›œ\üëÝ箎ížpuκcfÎ\P3Ê꾯Ijn2~ÙüHžxk95*¿ø}ïmæerþþ}é­qK'F‰õÍ*-ɯ•h˜»¾ùŒ×m—ÁGÈMæÐg;Ô~S”ý@»UCºÝ`ûŸÝ¥Tµã§l`„í>?ÏýøßuÞÌ]ð|Wå“»¶»ø×MökØMßö…÷àßå—ñŸÊFɨ}rüˆ„ó‡ùš7K^Uþ9¶²wøcî¡ wN©üÍK£üûkôjz¹ïÁ~Yv0çý›”íþöÓuü/÷˜Ý¿c¿ ¥¿ö½ƒ“ðc>=ïOyYó°7z¾ìQ%Ú>»gp”»kÇã¿¶¨ŽžÆy]üa:~q_¨q¡Îù×£¥çŽçàñ‚›Šø9ÅUØñ¬YÿÚúýÞ Qn»ég­ºq}Œãåw¤?žËÜX÷H.ÐW칿G¸=·Ìsäôûš%õ¯#§¼?rÌ{äŽýfþÍN2?“ß³´ZÒ,ùJ׸Ž%܉ÿÉ)ýYóß®*çûÎm]öÊ~ûˆòŸ+Ó¾Ú57Çq§ž7ûÐc_--tn\L¼‡Þè\UÁxUxÃóä³g6¾yi©Ž‹¹âìò .%^!.ÂñÜÊw8ÏM%·Z»SwÔ­m;‡Eÿræ—ksãK³ÈßÄç Üá÷=ó=áO…×°]Î6abÅ(¹ì‘¼7^Ùå¸üì¸4Ñè³2ƒ¶;Ï“7ìÈÏÿì2Ç÷ÔÇɛȯïÀ9Δÿ&žÏñùØ'Û+á;üqBöÒšÉþSö¯£ïy5²Ž¼àOìG‰Ï¬¿zîÍ~»‰?T¼ŽæÔk–YíŃQ^«Ýgn[VÍy ÇÂ#äUòS#‹õaÎûGC^ÆywégvÓcϼ>Órâoì•üo|ÎÜ¿ðçg\˜~÷S¡oŽcõûyk÷÷^ôC›(·ô«Ñ¹UzeÆ}'‡2[üâMÞ~¸Ôr'<¯\ñ¿yHģĜ7¸–ÿª~á¼"x@ßoûD<‚@.7Ðû -×{ø7ålr»äßÖ&oWlG¥à1ÇÙÒpvÓyå|îýÇy瘯¢ü SG\sg¼×‚ºÓºÁ«;ÐÅuBø|ô—-;pLËñ<{ÏïPý:šûrU¡¯úŸû”¨èûÌÃSÞÝuKæÎsƒÜÿÏÞ)Õ!½ˆù”ì렮Ȝ@Íw„‡ëþ8Õ{ÝÏ­¹Džk¦Ÿƒ—ÂóÒΫuŸs­˜ÃÎ>ê=ÔÅ?ö{‹ßC?¶yLâíP×ßXáñ_ðï™ñæ™Áÿ B<êlôkS_ yPÔ‰Ìdn¡øAÞ—ÄÞõ‰Ð×ã:SP÷âÏ>ú!ƒùwÔçàQ¿öÜ5ð2ó5à²7ˆ}HÔ##r߯{WT÷s_ó‘™Ã¯ÏgŸóÁàS"Wæ)Ò¯*>ŸGÿ‡y)êû çÜ:®ú„÷¤ë§q?äßùêæÕzކê­|/ûÜ—.<7¾xðÉ<_^÷Gõ·Ë?ÜÙèÊY®çó½ð/x/ó+ÅóC¾À1z®¸Ï‚¹V⇺¾ýéâw!ÏÞï%ž ýsðV=' “ø£îCÒ¼rôÇ|SúØ›OWç^»ÏAu`ø˜Öwx|ÒKóV˜'9ƒo¾?|@×}Õÿ/™ŸcÿubêeàqÏa§ß Þ*|øRðËÐ_½¿y¯Ì¥…ùàaëö˜=pâ#šGÍ_øð¨¸Õ‰Í㥿_÷ŠÝ³Ÿ ;€ýç{àGx?‡Îöñ¡å1ßDòæù$â]Rÿ÷ú •7Bÿ¼?O¼:×§éÆï!Oô_ËNo¾ä²Ã·÷ûÜB_x×Â9qßžcå²^÷ý~÷˸¿Q~J<’x^Ï˼Ù§"óƒôý_<îìÚ›ïƒÝÀ®ºÜ¢yè‰û[˜W¦~õ?—ž¼éû#Û›€Wž-Þ ';Iÿ7¸¹‡›§ó/ÂýVöCâágÍ“eîºìÁ¦§kµ¼´ê ñ½êܶ|³glÃSŸˆy†â‘Sç…G†÷ÜêóÌ£B®˜ï™>¯˜—æUYîÂ>pøa¶¿ð2à;Óï?!»j{Dÿ|JÉÿðsËýØ!k‰qUaãúŸÞñôˆ/ɜŠæ#Ù®Ã㣇~Qý¾äÙs0|¯ºw÷=˾n¹mÂüî{ÛÅýs:žï{¶]Án‚_dßèÛ ç®»1í|þÖêzjNôNg¿÷¬ê^ÁØwŸ»ôqc§Gßúðë³ý¾Ö{p!ö^­üçî¹kðËé÷ÕûñóáOïãþþ¾W%ö«Ì#¦}sì#U>‰<2ø¸žÊ\dxgðÕ4_˜÷:æ£Ó×rB£Îþ#ñ“Ÿûï8Ùõ+ãMö"2/ƒ¾úgÈ0ß™¾=x ì­Ó=ÿk³ç}TÌ¥fýRÞc#¿Ïœ'÷- ×{¾„âÒiùÝF\ÝÿxÇ1œ+ø›ø‚ù™øqætÃÃfŸ«ßŸydô{ªNá¾fðý ì–ôœ Å+îó‘ßóJù!ï…b{;åG<‡‰>Ù?÷Û"÷’3æ®xs]ÕŸdËüá9÷Ç)ùsh“Úµ[_„çíý¹ô׃7È£0W‰ù­ð_‰ÿôüìwâÞÉSÀoõžLò ò?Ìqñtì…ônÕä[;Ýݰa¼7Kòàù,zNü–ã?âaö?©Úû*‘KÉÿ¦¯Ž¼¸ÃKŸÆsx‘?Å‘Þß$<…_õÞò-ÊßÁïõ^öƒs©àÓz¾¥ð<ɉócšç>Rì¸yT‘çKžÐSpœçö)¿'=t"ñ1rê}3à:ú8ÀuÌaP†D—'Ÿ{ðùêÞ£8˜ûðžjÙ3ü²qóµÿÞgÇkâ#ðsž—ÿw<Ï»cî¤òâž!;äüªä‰|ywë¡æÏ{l0ÿ×s[uþðéegìw<ÏTù\îÛû´ˆS¤ÇAŸ$ómR›ž5fB#ÏvÜÈ^c}›a~Û{옗Kü&»åýìš“á<›ôØø!˜oçyÌ™c¿4?/=ÇþI¾â~'μÉÞ6å[™ƒ\¬Ì—=;éJï•¥n _ž ¼x7AÞØ¼êÿæÉˆo›ý~³÷)7ÊõLêõÔùò›,+>m@ʼ¼¿­Ì|´‡ùiÔ¹Í[ %ü×ßÄk€åú$<ñ—<Ç91éüëc~oÍËõ\ öð—?–úçâ½;:êòð‰à‰˜_¡s¢þ›3äÛ[>ì<<¾?ê°ðO”IÎû JA­\ŸË[:~ÂSÖ·‘'á¼óÄKUÝ—¾?ê·æ›ÀO3ïS÷C?yxªS×6ŸQsJØdÿÉüXÕY¹'â>Î3ó¸ÎÛ÷<7>æo‹?™7ÿ˜ñW,Ì2?¾–øxÖwõ“Äý-º?x®'‹—ÿ }&ԛ͇ø´Ô=á_뼸ÜÞݷ¼$æªIÞã|s+Ä#³œˆ`>"çD|!úQ˜¿,>†ý ù%÷¿ŒJö®pòîË æZš/¯Xû¼3ï|Òsràá™7_WZâýbÚƒ•Ï>ö¿j.yA»ÂÁ=Þže§FÝ›\V—:q¼OGŸ ŸÁü?¾O†O÷ÀüÝåJ\çÈ;ÊïÁ‚×h~¤êãð™¯i|—žgþ•í üvý{Nç'O™¾ðlÇÔÓõ=ä™ãøRöþì®Ïž…çÙ»_„:=z#ý°\ÁGÄþÒ¿nÞµøâzß<\ìãñàý`Ïà‡¸ÿC}'ØQñÁ~nøáÞ¤¹(æ§åÕó˜kOýÆûŒÄÿñ{ªAß.s̓¿Í}’øÀ<çäûb¿ŸôÁò“æuÁûÂÎ:‚—*ÜåµVú² ‡ÇýfÕ₩Mdž‡÷#Ê/ñ¹ð݃ð´Ôïä¼7üCú°ÌÏà~äè— æÜ¸Ð|>úÞÔO/ûïÏÕü,ÞÏüSáóœô\æ7Kްïà óÉGôù®ñ‹­ïâ»oØï‹oœxGäÙ¬_âù÷±cökêscÎx `z¥ž]_œfžÂ4ŸÓrG?¼AüvÁ²3Ÿl|úã-æ"zOüç¿÷øžà¿Ò_‘[ãÞ‡O:¡ŒyÅæ‡Ê.çôþÌô¥#çÄOÁGã<ÀKÌ3!ß››wÇ}ïd¶ˆyéþ ûOöY‚ã¼ßWx({sÇ)×O»4Ê]Ö`á©ït‰ùWÒcì#x›>ÉûÊõÞÇÈûÀÏrü ¾QÙ'ï Aß<ÿ%¨a¸_æ†x>’ð¢ûhÄ÷Ãk¿XŒÀÓØwü¥ìzæþš4_—ùŒ±}»ƒÿ¥ïÁüIxòæá"Oôljns¿øIóD¹â(õ¿á¿Ô/æ9Ô[ÀÍà¸üþ{^Î?¯‹çUÑŸa\M?ƒúF˜o Ïr“þÜxž ý¹Â·ì—‚wÜÁÛ5ÿ—~HÙŸö”~eñZÝϯ“¾½ýÆî£nÇŽSgsÜ©~aãsé+v3Œ#‰ë|â'ÂóUߪûMxn~ùs«xÜìM ¯ õ~6ð<}ôóÐG"¹¿ÈŸ¨/¶ïô3¦ãhçoÈ÷jÞ]Ü-¾3ïò½Í¦Qñ"ñ fõ™·ŸæÓǸM~“¾%ú¹‰ëÄŒåIvœGÝÎöO¼ÿ‚&k^/»i‚ñq«yêâ[y_Žä–¾» O>Šy½Èñ~ÓýÎàõ´?±ÜÐGNœê~Ét¿¬ý+yóð™$ž/x›þQò<æ[ËNz~¨â@Í×v¿ñ=¸¡ er×÷9Ï7À?&nò^ÞGrçü‰îÞ1þ >¶ìsßã~Ù#xåò3ñ~0áË9ýí/®¾íÉ!ÞGÃ^ZpfÖ=¾l×éDçWœWºbbÛ?¹Ðq¼ã”ô<ˆxO¸ôÓýɲ7ä×/¨>É|bæÐD_¦ßSþ|ŒòÀ¶#äcè$f¸üupæjÐgâ<}óêW%/@¾ÁûQå_ó-ªÑã—³ñ>Ê£ —ÄOîëbÎñ—ú¬Ÿàì³KæßR{¾í;y6â#ð“q¯æÈ¡÷ðÑ­‡àGõ Áä<<Ÿ_v´àŠ5çLúñó9á³ËxNñ~ÿI;xÍ{°71‡Þ¼ÕÏýüÒ+ú-‘ ò¹ú•<¾yŽíùBp"çæü”ìxî°êsÊÎè ÿÁ÷J¦ïuJ8‡ºûל'Ó9Åý÷éxÃs8±ë²à0ðû/èßwǃßÈÊ^änžÊÌÔÙqß qþ_~3çì1[^v–ùèz$»â8œO¼½"ä|“úpˆ¨#±OØøNþ‚x˜Ÿ»¦Å“Uœïs¿žúS˜/î|‚úO3ç›™K"æçT|⺷â6ìçi}Q\„‚“™g€½3^ ú͉×=ßEö—ó¡?FùªxÏ…ö‡¡oô¹ÿÜ¢çÇëçߣù?œ?vøð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UþÿÜ«‚_&OOý…yfàQÏÐ\ƒÂóúþRç©ëbÿ8/òUìQñœö’OòüŠ_,È3~ÿ½9ã­©ë˽í<8œ8ÿ_aÎy-ÏW“}'ÙpÙ5‰ŸÆÞg\B‹ü›ý×m­NSâZǯØ-úOwËO¸®'¼»åúc¿zóùÅ>Wð ù5p4}™î•=¤oÍ¥·¿ùëoã¹pÂ!üïé÷Q]ˆ>Dò"øÅiq®9äyù}ï‰aÞ‘úêð³È÷C¼‚ÒçG½ üÉs1ŠŸ£þÀyƒ×ÑKž}¡?ùÃŽ?çÁÏ&C¼ƒ}öþꜷìååß;êäNsObx>Þ‡û—þÅÏÏ|õIƒ¯‰ç9ÿ-FM^ËXN=ÃøÊsÔÈó OJˆOœ/’à|°{œûŸJ½~ŽÛm×dO}ßú/Ïœ ϶ƒÂ‘¡ óýîÛÕ9r~üœãyEÌIBŸÀéz?ôÒr©¹(뇗è<¨Ï'èyÝNMñ5÷Ïûq^žß¨xœçcž“çTR7V¿5¿G<‚çs‘çSO»/^zNÜé9Ò_òvèöûfü ù†ó ¨×uó8žOû]Û×·ôûÄw;>­WùºŸJø=Ã9=®[J?¹'ä}Ñû9?G…óÅz€ð"zˆ}bÞ¸ÛõùÏÙ’]õÜ;Ùìrmÿ*b¿&yàܱä—ù=ì*÷åyuÌ¿cΠΉŸ÷üùsËî‡s󹇡·È-çã<#}Ý’;ì~^ñ—õC÷Œ¾®¿¤]΢Ë?µ y Ô}¨³áïÐçQ;‹q™ÎÙûâô¼Ì%ψ]äüÑ{êÖš—âûwùÑû“¿"Í{c'Ð;øÎÇé\\`Ík}àyÁÎ/É~s.®c×’¾zžŒê-|ï ÇuÝz Nå\©Ÿ9¯£8ô§V=þµ¤ãð€â¡xΑì ñ)x?üyå+Ð×pŽòϼËŸþÞvPvoK§÷¿ö¯ý1®Ñ½{N‹ðšåNrØþPv—û‡ø¹¹/å³ñ»Ø ì ßãøIrMü^ ío{ŒÞË8_ÀÏq:Gž ÿÊóƒßìÇÀ…ðㄯ¸ç­™+¤ób® råùtÈ•ôg^n¯V§L[ï8À¸T8ƒ9xÄ…ë)5¶_2Æßð”Ÿæ½™o±~ëþ±Ãàì»ùzÿMKºí¾QÜÏDÞƒót}\ù½ÐRG$NâÞ‰·Àíü¸ƒçÁ~qþžÛ&¿´öö—»ÎxâM×»<¯Uù+Ÿ÷ì1µ¿<²¹ßŸ8—ºGáëW÷(x¾‰å”sÅÞ⟸æ{¿Éž§…þ=aΦí¶ì—ædYN4ÏþkÝÁK«ö*}ªíñvic˧O?í²=¶k‹’å67´‘å½À¿Qç³þ :¾Ð},«Pâíöײ^`O7 ý±á—œL¿bjãÒŠ_¼Üäñ8Ÿ#¿âqÎ…¸˜çGà3!¿Økìëõ’ ó‘à0/Ou.ÇIJïØ[î(¼i¾ ÷‰=Eÿ™_Ež•Ï!Þ³Ÿ/9Aþ˜×jû¨?;£{ÇàOÁäÿÉç ÏØ1þ‹Ÿ Ÿ¢x-®‡Š¿Ìœ•P^¨Ã—ó9®/+^F>°ç!ßûö'å ÁyàJÛá}ówT¯w|À\uÙIô yv£ùÃÈ“ë…àåóxþÂ݃¯~´Üîxñ›ò³à9ì™óJäûˆ—õ}Ø×qõûÈ/u_îÛþ^~Åqºö˜QÇ"½@Ϩ§âÐ+þžs&ÎqšóQ.òïÚŸ+»Q·àž‰ƒÌC•—\ñÈ Ÿ‹¿ÀoòüæÙJŸ‘›ÅÓ;mÚ´ž±½Á_h…öÙ¯`?è{Ñ»UµÊuéÀöqœ.yåßÁ»ª7Øßۯɮp/È?r…ŸÁ¿¢×øð<=Ÿ•ºuðÀ>8~‘ÞeNø•xœÅÏ˾š‡âóQ]ð~xž’ì%¸Ÿïÿsjýªoü·ÏÜÇŸyoÏ%MËc¼?›ºž»îÄ~ð_ö68o#h¾"qA:`nQÌ Þà¾eï%§öž/®ú öÆñ ÎÑçHžøò­>oåwy~>ÿ¡ÿ–?Ÿâ|·ó·ð†„ø\æt1OÐø„ü™ÞýÀ¯â©Ú?¡ðQ˜Ÿ§ç¿x.²p‡ç²I¾°“Žc5çŒ÷à½WVlô~Ÿsã{“ÀŽÚNÉ>3Ï9uÞÜ©x…8ßùª Nvœ&»„Ÿá^ч‰O›¶ÿ¤M\7f>(÷(?>Å® ÿøSâuê'Ø-ü/Æržä\§~4îÓçƒÛÁAÔ-ø>ð“yu•*tïSGy(þI?‡§^ë@Ÿo=‚£sàܱƒ®ŸËa?]÷d«üúB} äá`ÿÐKð¦ü’ßÓuTñÛxNðó>?…ûGNÝß#¾üXâõp~-q"ÿõ¹é½\×JŸ»ç†a_xî•ÿóOû¬æ©‹/Í{9”_¶Ü).ðSêFØ%ôÌz¨ï7ï ½¡n+|ÎYâýÀÜ#ùFúí?2'î“Ò~\ó¹%‡ä¸WóÌØ§ÀÜRõçaþ÷ÌçÇzž°âì¬yÁìÑ#žLÛß/v\è=ÊOP¿ O‘ŸwžDzêþ]Î_ïÅ{:ô_ãװרMúH™éú¤êgÔ3Û0ßç¹râ£é¾mg=ÿ[z#>‚õ„~hü ü ô&Ì/™«¸‚¼¹û3àã©Þ<ÂoåÏæŸ wÊºÏ ?e»­Ÿ_¸&}°]‹w±rR»ÎóžÝ÷ꩇƒgÑìyÓ0žÄO}z÷Â/ì\@ÿYìפWàòž«/Ͻfï¹£lã"ûµÿû¸e³çï,Ã'ö>„`îº÷*.Â~x¥Îýp>…p+çÇsú¼éƒd‘üÌï?MÈútß8LJîcž¸æ®Ÿä½°sØYêBèµû¯4ÇÒ{B…kV¯X]fþ5-oØ#âhòsæË‡¨ß‹GÌ{®í°áȹ¿Ú_ò¹æ=RW’>.‹nÞ‘èp‰q$Žô<úåôïÞËŠÜÁï’CŸÈqÿî;”L½¶AÙ]ã.óŲô{YoÀ¹øæ–Ñ·J>€¾3Ý?÷âóÃâÓrå¼xÿm|+\…:笠;Ü7à:4ý¤âÃQ/‡`o°|¾çóë=ÀWøqôÂr.9´¾+Ïä>Ýü[ÛÇ¿ï-ÂK2ßGçƒ_óCÕ¿éïF>¼û.üN^1ο0ÅýaÌk¯Ç{$WàKÝoìoÀÇôñ°ï‚=&:?òJœ?ñø¿'NÆßº® øGæ ѯÄmÎûéüù/yzîÉ{[ÙwËýëœÉ›ÁÆ?¹~ìmÁobŸ¼‡Aöœå8Mòl9w°÷Xï‡_â><.ö›:€žï!Ÿéü“ÎÙñ¾Î÷éÿÒ¯<1Æ_è ý®øaöœ°·LçNŸq~xnÍ ¶ÿ¹áÞ1®+¸o—ýÑô§K.Í/bn‰ê•œ7u¬Ù½7Þ0ôÝšæíZžÒòâþ:ð+òjù”Ý3ß›<¹ôÐûŸ°“Ì¢>¥säy± È]ÈÃÔ÷¹Ÿ‰y2àò7ðS±gðÌ ú Ì·ÿþ}ÏwŒ£ƒ½Ü®+±‡[çAžß¯{÷Þúr¥ïàuó·É7`—À»ÒûQú.ôgôÀ<4ÎQïûY“b£:ÕlÏHëKlŸˆÿ¤ÇÞsÅž.æ×_È?’÷¤À9ƒÛ=׆ù²ƒœ3Æ¿ã7ƒ}±Ë/ÃÛP_—=á÷ɯoá¼á§šçI_ ¸C¸Þ²ùÃä#‘ÅðØwãü±ž3äcÜï ?qŸ ôíx~bÇýu•%‰Ï4¾¢žÇs²€÷_ÑüñÙ5FgÄyé÷'Áã úK8WǺ?óáðW’¾ç¡.ອìŒý~úþã¼±p§ç˜É!çè8ŸÀ|;ÕçÈ+Çê‰#]NEC>†yµäÕñçÄ‹’_?¯êFÄŽÈ¿y"ó½ù¹ Ÿ@Þ…ø|GÝÁù&ɯëPz÷©n„}sþRòï>Wù-ïgBn™§Ïñ<6ì9qƒò|®«¢¿iyv¼=ñ¤÷°J©÷Qw`o rE^Ëüpɯûì„‹C½´_²\Ó/¡º‘?¾5ûßÔ׈¿¢Ëýú{àÛ¨NŽyîŒ>ùÆ¿Y„“ñ·Ü£ç PGï Ä+®[?ÓŸ©‡¹."ÿâº(÷¥ú%?g½£oùÆ!Ïð_èÏ•ä\]Ï`N“ò;öéû‰y,ÌS&xÍú+»à½dú/öÒüVáDú÷Ì¥¤÷ô^:Ý£ó@Ê[R¯Gßmoà±èϾݧ÷ÁŠÏô•˜WH¼åþ<ø¥ÊŸ„qïåü{ǘK)Üã8úïsç_÷ê{Ìÿ×ó“Ÿp=œú¥îÏ|Røhð¸wâ(ánì çéy ò#ðöÈï/Ì[ìŒùRºoøŠþ³p»ãiá@þë¾?æã‘‡\Ú.+ÏeÞp…y!ªs‚çàAxÞŽÎÁ¼vágì9ñ*ó ð¯ôùp~¼OÈ»EÿC»_ÇÞz }Eø=ê)Ò+ãy½7y9ü|ïM>u*ö =ÅÎÈßá/±æGȾÃ;6OT¼Ç]ú^ü5òäz q.ý“zð±í¼Jêõð}àïËô¦û:Ôº:Ö_=ÿú)eêO/5Âò`>õßë ø/ÏÃõæV —!—æ/JϰŸÄ“Ô¯À³æé*#¾G¿ƒ…7gÈ™W«<ßo^­ø'á¼ˡދ8)œkÅ}…}È·ûËè…¡óu…x+a#ùLò½Ü“ó€ø}^8¯9¿’wáù]‡鼜—<™' ß_ø…ûA>¬Ò3p ߃ÜÛN³]ø“ýžÇ)}1RþŒï·¿–W:Fþ”z±žÃ}…è ü^á ó,¤‡æ'*/.¥/ÀöX8‡{y½Ä!îËÒ¹z4óǰ’'ì‰åLþÈù)Ù?äÓ{D…#Éß›G_ þ5ý2AœfÞ4<2âçB«®Ï<-퓱½rÏ\òk»Éœ4ñ!±ëî?ïOEs€¿¤þ§{Ÿ`¯à˜?${HÉzK½^÷âÏ—G±Ô 8û[ác÷ý€ëéßî6^S~’¾ü-öÔuQá"ú ÍÕþ›÷ ?›¾yõ•3}w·~ÞóSõøsæË3'Íõiø9ô7è2'†¾pΕ>8âZáuüycÌËU^›<ç·äà7_-Ú15î÷ÐWêyÀßè's¨±3îO–¾¸Wþ¸?„Ÿq|þ"NÁ®c¯±ü8vÉ|UòòkÖ«à\9?ôßý7í›UøºÄóqÍÃ…®ç"ãº)sd÷ÑSä×õaâq¿óÌ“'ï~•¿4ŸÞ®ìùap)ö~hp5øù»·wg½QçóØÞñ¸ÚuTõWÏ8?¦û"ÿ…=ÄÿržÔ!Í˦BöÊüä_÷gž.ó+ùc~¿ .gã'èC´ð þÈñ-<@â$åƒgïÒg#9²¢~/œd¼ÎBûŒ_ç=á•PGGïÌÏ æˆº_XrO}ºÈ|òàú}ëCZž<×(ì› ó=Λ §àBò~ú~Ï›ÅN0ÏCø”|8÷3Qœgü"9B>Â|:S|2¾?ã¾G=—æùÅóBäø~äƒü3üiî9]ŽÓñCaž”¸Prê: ydå½<79¡ïNöŽûôü‘¿Ï7®uþ…¼)ö?3Ï)ÀÍÖKä—üs?è×À"ß’;î ¹]ÕiöÆjUŠû%¤¿Î/IÏBž‚y±ºgÏù òᶇzóŒ©OŸ“¿äû8?æW†óø÷pN•yóz_Ï`‡âæ4p_Ø!Ï‘= ûIÀø3ì!ò€?¡¾éç•ý0Ÿž¸‚¸”øƒx?ð³<'~*ö>#õVæ¯y^ãáAöŽ:?L~‰ü‹â(Çð É7Ò¯H~FrŠóý0×AsxyÞåË üù›ãx“xQûöàç ßÄ-ö·øgæ[éÏž» ¼â~<Õù9ü>þÀþ]òÂsé{©sQŸ÷œGx¬HߪæŸÑàxS?çyzìÒ|ôQöÉõnó~à5P§g.1q>y}úpé&Ï*|Š|y…ꎂ¹žoL_ªâÇCàp>þAø‹yÌŽàÓéçÍccŽ»ö¦xïô¾ª÷l0OGÉcƒÛØ×m~>üRøø:çmáƒÑ‡-^°írÁ~,åËìw„À_΋)Ÿì¹ÔÂîw€§&;Í|Ú̦×{Ç4ÛAÏ¿W¾ÕMïż.žßñ¸ôË|Zì ólÈk¥ý¯Ÿ‡Ÿ‡ÇLÔñ3ø—9,Ê'!ž¿EŸóò˜Ï*9q¹âbωPý×sµ¥·æ]ª/ßùJòXÔ ôþijöcäK˜ g#só¨kJÑ[êdØE÷ƒÀb/„æy›¯)}§Ù|háwã/Ý‹ãLúdõsÞÁÞ#ùï'ѼbãU½—÷É_1ßÑ|ö Àc êîØ!óçÉ'*žo›Ï@ý½î$Î&Oìï‘bw-¿ô›¦íyâÌ!÷;¯I?Œü 8›xÂóeð³îwg®¥æÌ1—–<ûXÉëHž°SØ;ç©Gæ¦íºŸÏs:5Úy_æ12ÿ¾î4Îô9àÌ·#GÁþâçÇÀ’Góƨï2gÿîf&}ñé?[7u¯á<ì?ò€¼š·A¾ˆyÖž߬÷ÂþšïÏŸ9Eªûs„þlé±çÀ‘GcóõÅ÷>ònøsò:ÂwAŸs<Y~,ÌoùüàÅãßà¥ê^ŒÓ±+àúúõsîKå¿Äûð[èÛAžÑoêâä«ÙCƾ1ö4 ß¹/\ö]çcœŽÜªþÍžÑ8,?ö=#àÇmðF…‘cêëÜ öŽþ0ÇK̉“<âçx?ó®Óö!ÊHïËù§ú÷pŸ ù ú"±ƒœ«ëÂðÐ?æÓóÃܧŒ|ÂϦÇ\4âAñí5?<Êx¿ïõUªÍŒã;æk}äKà‡"'àó™èW"ï̧¤Þßv¿“â¬UCj}|iÛ.q|­¿Ç®úïé‚Löˆ9²{œ¯÷o2^—ô,ÜóÄy{~Ÿæ(é÷âø~[05œ· ~%èþ+ì–úMÌÏf~‚ê•ÆeØyê´à7}>þ ¼oÜ_ŽyëÊ3z®s_™+'ÜO¼„<;®#î€oA]Núéy¹ºìœyjÂõôƒ¹¡¼­çm‘?¥Ž¤8‚}öŽg5OŠ~}½'{ØØ/W¤ïÃùlɹåUy(ïP=¼û¯?y¨p’ç¼ë=Â~7ã]öü©®k^ û€Øo¤{ðœBìû…‹Â¹Âæq+_â9ŒÊÿP§%#å}èò{žK£¾Ïµ…wD~޹BÔO$¯žK®¼µç+Èù|É—±GŠ~^â ½—ù“Ï{ÇsßÀ!ä …óTöžè¹9oö?˜¯M>KöÁýÌ'ÏÆçƒËõ{Öæa1ï<ès çV“ÿ¬ÐðÓλçǼoúµá;À—>Ãx¯‡ð’ë…Aÿ=Ïe;(Þ9ù­9SŠ[°ª‚åÝùöWçÓ½x~ŠúU‰ͯP¿ v~§÷ÆèÜáWc¼Ss)±{䱈ŸÝÊ1ùsæBº'Þ4yÓ"uÙ-óØéGö&»^_Nçè9jð™£Ïœ¡`®¾ç}êûlàí§q¸õ‚üù¸è«äÂùæ>PgQœëú•>Ÿ¹až ¦ó…/ý…÷çùÝÔ ¥<7~"´»žSM½ˆºxÏ¡^—–Ó(ã‚Ûúu~(îCb.3üÕôç:Î×Âož—ž›· ®q>™¸CñÓÊæÃF¾½UqŸ‚ä ýtÿ"seÒòk»ÿÒsà¨3À#dÞŸâƒ0ÿã~_á[ê=àSø÷扰WOÏσùÐæ'2OSÿuýXq%utçÓÁ¿ÌÙÅ~ë\è+·¿Ô½yN)ñ3s”S×äù̓Ö÷yßyÉ¿ã"æºÊ~¸î O‚yÑ¡øð¹ïWïËœiç÷ƒÿºoHüü5öœº,ü ÏV=;Ë|Wæ{2•< ö„ó“ü:nGÎÑSç‰ÁõèäÉýåøiêvÄõ̵ O1Øî}œ'|¨ Ñ< âö‘‘÷¢H]¼ 8–|óÌ‚¾}òxðÁØJ¾ü‚3Ïþ<1å¥Ã:3ùž‹:Ï‹¼y4ù_ê2þwøVÄ—ô‹iŸqf‹—ͼ"އ]_Ô{šÿ‰üßèK‚×ÍÞfæ%'}uäÅ^ú4®¯3¯?Å}Ó÷Á½ÓÇ &ÄMÞsì &þwÌ…vŸ;}Y:wì¾ã4öÃë%?&¹Ï“orßþÝýãä 8æMk^°÷oò~:'G@ñ²íóä™ô[x/™ÞÜè< uOò?Øs汯¢þÀÜæI1ß›þnÙMìÚªUx½ãºwãþú­dg=÷^<7Ƀû½5‡Âuö¡)Nðüö¹}pð­ìƒ}=ÆÿÄðítNijØIÍ«òœNÏûÏ¿x¾>õÙEÇgø1ìu!âöÍ“¿—u?P/Ào›÷ÄÜêiAÝÌ<å Ì7 ü•ûràÁo©Þöñpæ­‚—ä/×$.þòÜ91ŸSÏC¿„å¼É^á ðû£½wIý#ÖžKrMŸ¸ÌsÀÁÞï öݱ7ÄoàHé?vÃï_Wvƒs·¿d¿"üÉ¡ç÷×ӽ›çAž ^dÐ'ìý ð¥èW\ç¾}æ„qÌ«f>µìñzè¸V|ïsS~í=êÔ£ƒþä$ì4N“>P?q_~Š=pôQë÷½W#Ø/ã¹´ôqS¿¦®«9ä̇ïÖsÐØ–Ïxø ?!?Ê>Lž‹~JÏ¿7ÉŽÒOˆ^rÏÖ+ÕÃ×s$°oßÙ|2åO½O›zø…ø â#ïY¥þ¯…} ì£ çNè^7Ã+¢>"æÎ¬.Ÿ×·Ê¬Ññ|.ò:ÌAÒ¹sžð¯Ï+Ÿë9ðô|ƇÂcÄ]ÆOÈ û6¨ÿ°·“þ=¯ûká—°÷޼#ùBðô ½vŸs¨•—ò¼«`_,¼¼°~ÏiÜŒ²5º×+÷O‹OåþBñæ¦Ýûþsw—(ŒùÔÁž°'ìïÀNÀ»'_à9IÂ_ÔiÁßöŸôõ /ð³å/©kQ@>ÝL}GþÎû«¨'}æ ±LïÍyânö»_Þ§ìx0¸HjØ×âþ8É})Î2§›ø”ý„ÔY¥/à$>‡ç'NcŽÁªƒS†õô)޳sEéÏ¥=rJýH<Á<[Û©2•^]ÿ«õ­ϸOùÏ)"?ô1¡?æ?ÐïKÿ:ûX•¯áÜx/ÎÓòKÝ^ùŰ?Áq?õGúÔ¨w‘÷£ï,àYÇx΀>Çó·éŸÕý`/‰³©7™·¡ûwèïüœ˜ÿ!{j>>ù.âYxäâQ…ó]<÷'Ø¿‹|š_ÀùH?\—Àÿ³O•½fȯì?oHŸù0î7ÈC„ó1½'‚¾Cú'àï3?TŸçù(A}hæ‡Þÿ©îgñ>rö£¨Nð7Ë”ÏtÞŸz±ç꽉Wø<ÇuÁÞvöP‚ï{„gÜç^ ò î§&ÏÄ æ³ÀÛQ|Kü ~-¢ä8?æ™ÉÃg÷~/éUhÐÏq¥-ˆ+]_ÊoÁCÀ¯›ßÌâ`_6óx‘sâ<ïVýޏÎ{¼á#Á{¥Ÿ›}ôË‚{$—áœbô܈½‡Oh?Iý¼Ï—=4ð¾à_ûüÌÇý©žÿ/~+r¡Ïs?‰ë$àJæOHÿ‰@á.òìoÁOo yšÔËuî¶A.÷Ï>ÑpßšoÚ’šPd®ñ¯p õcç¯ÀËÊGº¯VrC\êº9¸ž¼IæÌ¿‘\RWÁ.™ï.yð~=ú,„‹Â{ä¹ü|ð1¥/®—¡è§xΞ;¿”¾[æ")>õ\øûì £¾,ýòþZÅÔ1Àž‹'¿æý•Ê?pÿs0Ÿ 9w]™ü:ý«äٷÜÙ› ï$Êš\eÅÀ†§D™OV¸­ÿ€’QÎŒ–=Ÿîs^”uÚÜz­3¾ˆ²®è•|¸ ~”W±á~»zJ”Ý~|Ýg>%×ì»0#çü¨`ÞÎ]—9Ê×ï#·Ù¥ê~3óî~QnTåµòUnŠ’Š+ò>+3h{”¹lËý«ÆM²¯èzJ±óÚXô~QN½f™Õ^<eŸ6㾆ÍÞŠ’5^ËyöÈOüðh3º¥TñÎGF=vÝôâ9å¢Ì•î¾í–Žñ=ŸþFßË;ŠrÜôýÇÝ®‰Jœ]Ð3óªÚ–Ék”ÝãÆ/¾l°-J.{$ïWvEye>½ä½ŸWFY%›oëzàfö|D¹»v<þk‹êQ^¬#/xã“(sJÃ/»}·5>¯ãZÌmrÿÖ¯ì™o^ZªA”=nøðõÓ¢d‹FS_(¹=Ê.Ó}×MÇMðûñç¼aG~þøg—Å÷±»rÝ‹ª?e}¶Cýç7Y²[|â½ßûÍÞ?¦Ü¨(«â[ý–žåïËz°ÒÎ!›«²·‡þqËsÁ°Œ×®Xú^T°kk›ÖmËDÉ&£>=s¼ï/ç« êö›¼3ÊÏ«÷íä¶k¢œ¦Që7´HÞ½¤B›¡Ë£¬u/^qÖ£µÜ'”ÝòÑyn½1Êì=l᩵ÏòZf7ùá™'¢dŸö³Ê—¨ayM–>vbT¡D”ŒÚ'ÇøËŒëÙëòÕÝ}ÿè9ÿÍ9{ÌÖ—Å÷EÙ‡ûjiáÖ(§Få¿ï½-Ê^{ךšcïJVØüíGK›DÙ}š~úTáî(gi·5Wï>Úç“uO§/Ûu:Ñ÷.{eoî8åúi—Zÿróî¸ïÌ–εXë3n-_ócëõív«†t»!ÊÚä¢UCD9#;õœuL_Û)ìQ~ê`bdñ¡QNû×O»¡äUþ½äÙoîŸ=ã²(§Õ’fÉWºúsËbÌ™9ó“f¶è‹æwEÉ‘9y[ßëeW›×âõ¾¥c {Tÿq|­Ë^Ùoÿ¾wô>wóüSf¦ÎŽ?Oú–ßÏËùçuñ9$ü­Ù˜§G9eÛ iqÿï±=×¹bïòFôù®ñ‹ãŸÓýâ÷ü¾òW¶ËKÇOxcÊú(¯Ï9c¦ž54¶«c¿™ó†“,_È+Îo÷çƒíZuñ碇<—x€~.ìåRç“Ìýºõ’£?ˆÏ«AÇ·Þñˆí•æš±ç+Êýªõ¨ —¿ŸŸü"výÉo²¬ø´)ßkžô9oíþÞ‹~øË^ûàñî¸:>—ÄÛ3«?!Ê)|åÇûÕ÷¹ñžê_óyTøqrs×'äŽJö®pò¶ŸÈ_îôäêÕ³&Ù¾ùž‡U½~ßjû©LÙ‡ŒÖo=7¦XǨXïïÿòö#QÞw«¾«ýy§(ó´­ NÜe×yûžçÆ[Ÿ‘Oô‡T?l”œ÷A•‚Z'°7Ïvû’—»»LÇù_Æç‘Æ3Æ#ü—ÏÍkµûÌm˪ù^2¦WxeÒ²ì¨~Iö/³Sû_6»’9kþü¼ôþÿ{ñÔÖ‚;þüÖvû€ÿ³¿“ž—]îØNÊßä¤úÔ¿ý›lâtÛ7pVÁôJ=»¾8:®å”÷ä{íOgõŸ‡N~¼æzeκcfÎ\PÓòW0.óígÖ‰òf|Ôûºq‘å3g×ô}ŸÖå^Pû‚·Ú_âì¥ø)ñÇ¢dçWïþòu±ýÓ=p^àBðHfã[¾µNì·tþ|øÏÁoƒïr«µ;uGÝÚ±ý•ý/ªß&Êkš¨Üjt'Ÿ/ö?j¿+{™ó`ÝÙ[³Öúñ'Ù©Q÷&—Õe~j”7dó¯ækýâ=x>¾/¯Ô’#ÎÈßhžì?hôKU³¬ø'ì úÌïi>³õ»˜Û´âUù3'Á/õA¸£äÌÄœæ§Ï7>༳^ÛÖø§ŒÑ¶÷¹kßÝfDã^ÎÇvkW×cúÕ4î3îWø\õqãdô ¹Nn´tÇò§£¬ñåÞÙ=nL”Ý¥Tµã§lˆžçMï´þ¨'Ê9mäÕ#R·ÓG¤íŽûß$/ðú¢¬y%–_;gz”}ÁO÷ß’å}Uì¾ÇŒŠµÏ{0óÎ'£áÄÐîå”þ¬ùoW•ó=ä¶›~Öª×Ç{˜ÒûŒÛszO›~çÞÇ쿌_„Û8Gì!þËþHz†ž`§r¾›SeÈÁêQ~º>å¶tú…ßÁ‹5®ÃÞ1g„sF^Ð[ì¼ý½ü»p6¼jŸúÇ}d–oúKÏzÄç ®)]uJ•ÇFù¾±wÈ·øÄuð/|è«ñx—n·îÞ^Êñú†ŸÁX/¤WøEÇUø=á*ë+vEþš¸<ª~->z Ïûšu¨YaáÛgùssâ>Ÿ¿ô¼‡?å¹ÄÇrŸ»à”?=mœ+¹3NÃŽsÅ–|ñc™‡ ‡Ä³|^Á¡E'ÞðúÎðsä JôÞ¿xôuGÀcŒ²ú ØüÕí±[Ì…ðû"ÿøKâ%ùµ(7Q±ü['DQ~½œ†-×6Šß;{ÞŒÆ9ÍŒ9pcÁȹ?et}7Ê<Ô¡Ô+“ÛZïÁŽƒÇ€ÐÅ_ñ{\Ø?z¼EÇià˃ì8Èv{þ1ã¯X˜eÉóØþrúý|É/8¿œ×nXéË.N½ Ž‹d•ç¡_Î÷%¾…õ¹ÒÞö8Vž„¸Æç¤û n!Ÿ¿Nxw㢣Þ4ÞÌë?~Ì;Ç|eüF<«çãú Þà¬g²'œv/1§±~nŠæ6ì^ýË7þÜŽ+èsÌ·NþÌïC^ˆ¿§_{ n$.µÿ–ŸWhoNüœúoþ¡E5zür¶ñ³öíZO²ûwì·¡ôׯ¹ÃªÏ);ã/œØ`]Ãï í4ù4åC°GØ+>û‰?F.œ”å~rçí½ö³‡_ö9`ox.ž;\pÅšs&ýx„í òˆ%&¿Â÷ªoÒx܇¿Âÿ¢—ò¿qü .ÕybGuôÏÆçA>Av¡ lÁm§-èiÜ«¾ë;ß—ÑøƒöÝ[®3q^JŸ‹¾óïäƒcô Pe¼óÞ}ü¼õ3ow½êí×ãƒt}<ö?ò;Ä ÜçÆ¹‹_ë¼ ~ÎöPq2úP¼Â®~Ÿ­¾Ç~#¯Ço+3ía;†¿7~%ï¡ç$î#ï=ßroÜgÁÙ%óo©=?Þ£Ä^æWÓ¦:ƒóæÁü@ÏaÖïQ¯ çôzn¿êm®O²Oƒýwâ¸~*þ½ûö¨ÃÇ£ïFõLê¿æW¨NÏÔu5æw(ÏOýÂ}|ªïºþN]Œúõ 怪NOÈ<9úÂøyÕ!̯¢OM}gæÂs€7@ß+ss™Áþú¡‚ï5CuçpŽ”÷s‰Oàú¼læ‹À“Ô=„|Hïã枆óÌ?džƒêÅÈudäŠ{ƒ÷E}ˆú¿û áŠ?ã½ôKžà»­ç1_>}BìyƒÿOLu=ï37N>Bóð]‚—ÍÜDöÚsê-ÏÌb¡êšÌ‘¢.íº•økžKÆ~®4O5Þ'Ç\Õ׸×ßégï¥ç¥À{>©³?~ xužSè™÷¢«ŸÐýt’ßpŸÎ÷m´ù1Õ1® ²ïe^¡ÞKuÙ¸¯]úæ=ðË™ÇÏÅCA/àå¡7ð°¨+{Ž ülö}jnòC_¢÷ŠOâ½Zú{>ÏûÍÙË¢÷Ä>{¯¸æœzßüøGôϰÏP|xŠî“W_ó,áG±‡ýñÞË„üЯKÿõÝ÷á²ç]?Õ{Öè ø±è‹÷lˆOB}½†'ì½ êŸå<œoÃyp^æ ÂÿT}aÞúpÌ[d_‹â>·H¿.ç!|ê>~úµØ¿˜æz¾SˆçÍ[bÿ}£âsyn}0Çùðþñ阫ã>fðqsÎ5çû`¾sYe‡ŒKÅtß3þ_ü+ð›÷xi®µâìx®óe%WìEÁoÁ‡ö|3xÍÌ•R<)9ùƒÄôqÓ?•~ Ís1Þ ú~ÜK¿ŽÎÙr¿—~$ü5ó:ø=æSâþ>7¯È>pú*¼?K8Ð~U¿ç9F’WîŸù•ž#-¼äçeŸ0rEüEßq°ÇÓsì¾¹ç27™·Kß}âÚŸê÷<× ^óÓBþ;÷F_#~PüOõ![Ÿ‰¿½·Þ<{0ù¯â|îÇýðB%G|¾ûÁ?:_ïa„—ªssŽô9´ÿîPá9à²+†ÖnÚao›Ø ?Y_5·†ùeìwò2ñ¿áU{ÞŽì>óÜÈŸ`¯m¿Èo79ïÁJúBØÛô‘ÛýRÌ?0ÿ»þìùkįA¾ûàéÓyOáù¯çEˆgË÷0—Ò{¢è? æi¸oI¸Á}àïÀ¾zŸ–æÐ_ä~^ü;ûɉ ðsÈe°”ï[_éþ¼I,ý8sUè+a>%8PÏ{ïú Ây޼òaÞ*sJÙWÅ\ æÖ ¹ÿ[Ï·á²k?½ÏvÇs‚¹¸ž›§8¹G¿ÜŸÊ{‚é— Ï¼qÅ1Ìä\±«ìIrsC»AþŒ¹5Á>ßû‚{ ÷ÕàG=GNö3Äaðôٟƹxž/s4ô<á\]÷Gë<ÜŸÊ^ùUð²çæÀó–>rþœyGú›o‘}ùíòw6ºrVÌ«—_ó|æŽs“¼G[ç€|1GÓóqÑSðÌß÷ßøùéû¶ÿbo­ò–Û`žû¸eŸÌï—? ûNçØ©þ*çgð“ÊW…s‚üÜÌgeî@— ÷Çxé½äqƒüªû}ˆ»‚~:ãâJä_òìþkÙæ­ø^ȇ°70˜Gçüóè7Þ çÕ2oÆv]zÉÜûaöñr®ô‘17>°ïà%÷}ÑÏE¿}p>à0äÕsŸ°»:Wã8sÉÜçF¾GÏs`få7ßý8÷h~xÆñÆÄbQîŒ>¯þqZÿ˜Gõwê2™çŸóÆÅ'×5/‚º_±Î‹Ëím0Ñõ%ófTg¢>/„zmÁÐr½‡SÎ< øcð…©+›W¥ÏÏïsÄ€ŠG¶Œë]zŸêPÔÛÝ ~ñ¤ç«æú§øUâa0×'ʸê©kßœúëðð‚àUÁ{‚—Æ{R—‡Wo>Wn{>é„2Qþº¼ú¥šFyÕ₩MÄj׋áSÀW¤nêþ Õ+á‘ú¼ÅÏá9ÄûÆnù\¨ËSŸä¼y/êòð“áç™/¾Žûš.{æõ™ÎshîG|¾Âñ™ç<ñá;5g¸n¿–úyf£ô=ú£øýàÂKS}Xsá{8ÞTün~6õ[êÉðzÌ >,òDÕõNý<¼Òâ“·¸ô¸sÜg¢z2vÆ}Ü}ÍÊÛ™÷ˆÞqðÍ'‚×+þ>÷¦ó÷¼gÕï‰ÍŸ ÎÌg0O=*>vÿöÁ¥W¹ŽL>'ýæ±§ÿl¼Ï>ñ\¯P_¿ù»ðÖÄÏñþÞÞSxðQ°CðÂÅrž ýͯ0uÄ5wÖŠr‡6hZºþ%>?øùŒû½Ý–£àzŸ ç¢þ{óxÝO?¼xSi=2ÿ×1ÃïÎñûÂ32Ÿ1}oäÓÌÏÖç¯D­K÷üîÝ+ý¼¼¿x‚à˸¯Pü<ñƒ˜Oa5Np=ö?†<Ú7YózÙMì'°Çôus7Ó~Ò{ZÌßOã1ò"–#áRòÛÌå°¿¿¬]W¥Õ¶²ößðq‰ï2~n»m從–ûwp|Fé#ýô­ §’0Ï–¾2ú-Á³î3 ú›±÷Ú?i\â~_õÐÿ_§ðïØqì’òNQÆk¿w_ôÙã&÷· ¿b7-Ïâçu9sß—oFqŸ¡ü<_ú6è'Çó󨣂óß½õÛÝæ¿Ó—®¹”qMZ>c|A.ý+º_ì2ýyŽSôóàFâB÷3¦åÕùJòÈð ¿ë¹Ýo_]ö½sÿŽð€Îƒ:‚yÛðJ‘÷ùчœ¶›ä¯ŒÃ°?àvé=ùg÷·0W>êuŽwàõ»ßFq˜ûˆd7$G¶;ð¬á½Â‹×û“ß)2'\Lÿ ñ“ý¬äDóŠk97÷ÃõþÌô¥##Ƀ€ñø/âúÜé$>&¾£_Kñ³ùUÅ„ƒÑ/üX±[?{©ùñìiq¾ƒûUq·û Ó¼òx>AÚžÄý†äAÒ}k©ÂõÇ”Û/i9£Ë}$Ò“Ä-³ëתœmb;¬~X÷¿¥qy±(süE_œ³ƒ{`´óàrâ^îA8Ôøüà9ú^úÈK°ßBù{ë-ñ‡ûQ¸7Å[Æ:oçCæ¿Óò³%÷پ䷬׷箉ÿ¬¼ýšü;þ|ûÏußö§ê°•½+vvñZ›Úlvÿ„ûåÉ‹(o¾pCŸï>kÉ­ûrd§èðü‘?S¾‰¸ýª>ƒåÒ~_ï!; O#ÆÍš‡ÁÏ)áøÀ~8ŸH­ªUæ¨K¶ùúô™*ÿàyŠ3È£ÈîyïZÚÿšWá>pñßmÇ„Gˆ³Ýç¡|©ûTéC£Wø‘øþ÷])ŽðœùIñÿ™‹ûMùCß}«Š›Ä£5§ùYŽ+ jyàà±sŒKè±ÿ‘ž’g¥Oy£oœçÁÞ9ߢ¸Fö‹9Nìa1¾Á¿$ȇÈ.ƒ³°ë̹pBÿ[Úη)îqÞÈ}Jzž"ñ¨ò^žg£{¥?E¸Ùxœá>NæÂ·:N_dú=Í38ÔeÖm¾XÇòD|ïy/ôûÐ_"y&ŸŸ]ô˜ ·ÆyZá5ú‰sñ7îÓSžÜMŸ'<å‡ã>Uõ1»Ï&}~Žóì¿Ó?ï¸ ;‚Þà‡ÔŸsx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*ÿ¿îUÁ®»¿G÷³qʾ·“£Eæ Ðwk?N~—|„âiâ °Ž€ŸDOìÙó¢8‚üßCžzýŠ;5¼ðb× <¯;.¿ ž/Òo+»Â÷[ñ+ê7¶ö¸· W›[¬¿èçêØ¾ /ªkÆöQxŒ<¦ó]è‡ü=yg÷i+òÙ¹-o”?¥xµ—mŒ+™=aΙô•½2ü=ùmð7÷‹¼®ïØóÑÉÇ%ãymò÷ôI3O }2Γ=¢»„=Ÿ€wø<âÎÁöP8dÿ¡ï#Þ ýâŸ~Úy÷üøœé³îPý’>"ýéüuNôˆ|ø~Í]ÑžéÍýžàxòÎkçã<šÞÓqäž¹–s³ø½Ö+¾;Ž ç&¸Y~ø{ŒýoSòüɽzz.ÞW¼)ÛEâ6pç@¾Œ~Aê£LÜ{ZƱ¿çÞ°›È#ßûçÐ&µk·þÞ}îÈ7ñz˹cŸñ/Ä¡¶¼çóÆ5kƒ³ÍÿEþ\7 ¿XyÀuƒ'Vw K<_F?“ŸŒy¿¿³»÷o¶Kv*õú¹ËšÆç)9ñ8õ“"gü»ç¾Ð-{E¼À9bðËè78Ǹ\zH¼O}›{"_ N#Þ%/†&Ž\ÃO³üþÑs$%‡A}:΋(¾E/¨‹yž£>wc…Çÿ}Á¿gÆóK¨ã2 ¼ ¸Ëó;%×ô™{® ùr}v†¸rÃà‹ÇýB{ç{Ü/­úuÈ0Kž’¼-v?z ç¨Ïç×6¿ È\4ųøMÎÏybùsòtè#çŠ?gç‘2GA8Ðõ `ž#Ÿ¿aâ¢7~;:¶Ãü¹%OÀÏÙÊ‘'%Îsþ€|¼äûY^©ÒI÷Þ95–KÙeìuT×/õ¹óÞõŸ2|ÇKÌAï‘Ö9pžÄ¶àjü*ù,ëéʆ¸ù¿ü™X|lãCË]'Yóô-¾Òõž"óL`OÖyâþ#¯\èy4®«?dŽ8ìàŸOO^¾Òs6Oì*õp y)Šˆ—±Wð³°·àAÏE’?[ýô¯·ny,²¿ŽpÝŒ8'œÿå|±ž¹`Ž OÜŸ9æ¦x®«ð·Ï—y—ŠÃyäøum…YUóî™—Z{éM÷u¨uµíuSâìç 2'Nç¿°þŽ•_¾lù ž‡¦û ÎC½Ð~>°Gœ;÷á9!ªC„~Ïr%ýr …p ¸~Uóãßy÷©MClxÇ%'Çu]Õ-Èk¿ó\ä¤WŽ¿±OлɫcW‰Û¸7õËYïeGÜË=‘/ö¾HÉò(ŽCô¾üœç-Ê~ç K{Þ¾dÝ#ãêyÊ“€ëwüEX_³Ý”8ÎfÞ«>Èyoé¡ëÒ+êm!O ùsþç檆s›¸oä…}´êo°Þ‡s›—­hZî諾t¾ |I^Ásd%/žÿEömÍÿòa™–â&äßóZUo%îv<.9å¿àbÏ1×ólL|Ú´ý'mŠœ/s§¨ ¯èvËów™S§x?Ë{ mç…Gš×n>Z ÏÈúŠf޼ý°âeûGâ*ö0ËŸ‚Ûœ'cî,z ¿ÁûcŸø|ÇOÂcØgë=ó³‚|0ñ(u½ù|8ç–¡/ûçɧ‚#صæ'ÿø<ÿtŽ é² W¹®þ³ÞÛ¿/9·ü}5âÛUCKmð¿ëÏÿ$ÇEäœsÿÃÁO¿¸ct‘ç™û}ÅëŸ}OêÝÿ}ß‚ÔðsËýØ!kIê‡'êVŸzàÿp^]J]ÒðêÂóN}ûüé½ZŽÝæŸW>¸È=ó{KëÜ{á#oU÷¿ÏÛ·¬C¿}ãR3·~ûèµ×oI}óþè?N¨Ü¸È{q>ðƒ%_þ÷YŸ¼ðûòr¤fæ,\¬oÿÿÏöÜþûÄÊwÖœrJ²ÈÏÿž}ôˆ]OßœzûŒ>Ë]½%õô×+üxâ?ʧþ=õsç›>h¶áËÔÜ«†>¹£lcÿßÔìÞoúnÍ"÷]æÇ²¢áÔ=«ù¯?_¿ï?/ïxEÁÙ5„÷â<%ùþ¹œÓñòß«·¿Èù~֤بN5[‡v·ÈÏ-˜öðwÏny'õKûú>pÈŸ?-¿Ûˆ«ûï?×ø÷áíýxúη¾)Øïïýõøfö/~ïÿ³¾úß±çðäøþÅÓ;mÚ´ž®Ï-ÞÓêèÙ]b9ÿþ¨ZwVÔ"ôKè?Gñ“Nòí?/shÀ’±±½À.Ûo¤Ï»ˆ<`Otžþ¼_Nùqf‹>ŒïùöÇt{ÏrÊ9-–"W Ÿ.5úÐWX>‰[¥Ÿþ<žçîÙÏɼïy¹½Z2m}êǹÝ^\³òî"çþÇŠS«ÿZ2µhìÀ1-K¼^¤~¿äÓÚQ‰—S“²;.|}ÉÐÔªÌÞ—þV­Dj¥žY…o·¿nTjV¯Ÿo­´¤]jݲœššÃ½8ÏÎçȯ¤ú}úî®øÅ~oÁÅMOîsÝÈÔª!µ>¾´m—Ô·ëÆ>2¢i÷"öž ~tÙÔÛêת\ä½—î]ÚãÙã&`7|_²þyò2ënÓ±ãg·¤f¥>«Ñpso¿Ï‚}½óºé3ãJÎ)Ä[Üvcú-?dî?ïÜÕåÏÔìË_9cÎàêö_ ?ÿfNù~:/.Üû#ñ³xü‘äÑïÜ_ó¤~ÈÏ3ÿ=á÷ßðü‰7À·ø½ÐßЧ'?f¹EŸþ ‡aÏW¾±aU²lì§åýù3îßÑãé}Û^+BœÞ7ÏõOþsfÇ_.ßó{þ{òü;zŒþâï±û<ׂä”rK®kšš7ùÕûj?ør‘Zré;uª÷ÿÐ}XððK+Ž¿Åãk9úÛs/µ¾¾FEÿ=òŠÿá>‘æSðùöó?MÈúôÿnÿtŠü÷ø_p×oßÏ=aîû=üï˺æ/ÚÖ`DjnÁ³«Ê§†øóeþ7üQþ½£Nî47µüà5·}ø£ÿþúÆ=.ÏXväšqUýyÈ9öQò_D?°_6xã±ÌV×þ£¿Ä>¡GämÑGÞÿ×mß¶k=ö–ÔwoïÎz£ÎçEp¨ôyˆýW‰Ä×õß/÷@Áãï5*_a±»àìÿŽüzE‰ŠwOÜa{<ðùÔÛÑëÐò÷ÆG’»$f¿tÕßÏʧ:©mýÅ~Þ_–=ù‡-ç¡^‘Çã¹É§`ïø3v;~çοcé‡çxNÕ#ý‹ÿïAr⟇þúü²öwì^`¿K>OxÁ÷D>ü¤çšÈŽë|B¹H-ÿúƶ ƽžZqéÊ:íÏûÅv@úæ÷ãóÞ<áÏJŒVä|9ìö‚|8“Ïþó¿“ßç{À ü™x9 ~¡^"üZ}ǽ‹†_k<‡$ÿ„ý"î'„ö'xnzâãYö±>òßП ߨãðœÀÁÆgi=q‘âì&ñ'¸ol2û‰–'>fœÅó#'ä+ø~»%;?î{Îy󲩕Ë>>zÝ÷ûù¹©×6(»kÜ¥qÜ'¿"¿\ÄÞñ9øAøä{CÿþoS×пûsÉ'qî¼yÝ0î¿ÏÚÿHË›ŸüÉÿ>ãø%ÞUo ò[$N¢¾Š~J.м§ö‹Å¸Pq 8áÓ»î|açÛEp(úÿ£àw,§ògÄøCü?ò®:Î?úEð1ö{ ǺÎÏ8IvR¼æ"qœÏWÏ…Ý"ÏÀùðažMþôãoÎ-Ì[aßɯ¯®•?þøm]R«–ž;v˃å½7ÖÓ’‰Ä‰gšOÞÜýðÔ'V¼÷þ;¹Y®£`wù9ì þºüâ`×­å÷½7M¼%êÙüõyóóÒŸë÷uÝVÏ_Éyyê¢ôgP÷¦.¦ç$~£„½J•ó£FÝü/ž›ŸÏ{•Ä+ ÎK}‹>"÷yQÿ“§^e>M:ïïÏ7¯JuaâVÏß ÏÊï¡ß'ޤ>AŠ8Åõ'ú‹‚zçá}•ì+ƒG—~~?7õ4ó}à InáSRפ~J} þq5õð†ïY¼#ói‘_øâ_ð>ð+õžžƒå~rxÀÌWPÿx€>fâê]Äa½Çü®`ß”ç/ˆ¿ãý¼ú<ÞçÏ©õ«6¾ñßq}–}Ûô7Jn©¹Ž—®óù>ü<âcÃSÂ.˜Ÿ%¾…åL÷M~ ôÊý0ôŸ¼÷¡2?I¼Jÿ½ä—º+q ¸Ðs¯Ä{X5ùÖNw7lû%ádêwÜ3rG_ ñúé>ê˜âiy?8s3ôœæã‹b½“œa¿<9:×Õ—¾Ò©Äå1ß‹yI²Çð¤½7‘~;é¸^õ~Ÿ'|\õy$ubõçhO„yè~oG8—ˆþä7œ·Ï {ϾIïÉ“½å~èSâyÌ· _Kþ93ïU<2÷E±¯Qüð'öØ}½:'ìç ¯þ`Ov_ ¼üüº°O—|8uvÕµc?†½f¦úUm'Å7€è9îìW×Ï{î‡äƼDø²ÒsÏ=`î€Îƒçw¿5x@ò¯„¹žû)¹ÁïÃ3CnáAÇ&OÁûò9àóîè—£‘½«â«êùb?‰Ò{ãOx~÷™ÐW­ç6ŸžµþKÞó)™û è9Mâ¡ϰ÷V}Lœ+8Þ‡yHøWùGäƒçà¾Ý?%?î·žHèóõ~Jö‚ûàU€§èO’?‡‡!?Ÿ3¼Õ£<Avù7æõê>éðžGñöÀCæ{É?ÂS6ÿü­Þƒ÷<ú^8/=z‰_6_÷ Å®ÉÉoh/U<÷Rï+½‹2>í}o•h´qšûÆá5¡ÿøké)÷Ó|\ðór¤áÞ`ú‰±‹žÓì÷4’¹â¯Áà øŒØwäÙs%Æáôï3WSòÎSõ¼úO˜#œe®ôÓ}IJGÄÈAøð™˜óòÊ<÷‡y)òwþ{Í]›ÏŸU¿‡žš—/€|·"Ÿàpþ=¡Ìšãy.ºôÀü(úSéÇ”_ÆÞ{n pšçÇÊ.ÀãùÈÇx~³ü sz8o÷›‰wÄÜ xéæ¡Ó_*»k¾µøÀžw¨sàÍÃfNþ~9=·ûU„ÐûÅYgn¬ÿX#ëöÎs¡ÁQÂ!à7æÎ‚{°S¼?ñ‡ùf²‹Ê#Ú.ÀŸ†éþ áAÏEO+~¸ç5;eÿðÓá{÷•±gZçŽå÷¼7Wö;„^çu<¡ó y˜ðÐÈ×aOð¯ôi‡ó©àŸñ‹æm‹÷ î@¾éÃ÷s¿Ø/ê ŽÁ½ò›ø3Û9ì‡ô™øÑö]÷kÞ=úOŸâ8Û=ÅK^«îÅý|ô}ë\FÀ£ö|YâLä5˜ûèýÏʸ/Þ²ürÝwØþé/0—“¾Oò-ðC™ßÏœPæÍé{ùÏ1–r¿“p†?<ªø^°÷ŠãgÀ¥à Å Ž3dé£$¯Ž>‡ó{è›$?ƒ½÷ê¿î[ßCé7äy=WSïoÖ~—9p’;ÏCÔýÁÇO ×ÄÍæEë<ø9xòØÏÝS|Í=pÿ²[q^sÜ¿%ùrÞKïAýlû¢¸!Äûø=ôÏú#5s-ȃ¸/½äçèÁŸ2‡B~Áó°õ÷Þÿ Ïƒ×dÿ£ŸÃnÚ¯+oÇü<ôÒûÌËêüõ ãúÍŸ]ct†q’ç)3ç„8.˜Kã9r’cäù÷ wøÎÉó&è»Ïô€#íe‰Çñ_Îqß!ïEŸs㙇`§Þþ}¿åÍ}i|.óÙS¯¸Ãýâò#ªÏÀWçhËo¸¿Tñ°çfÑ?OÜÀž Ùúm<_RsÈóð~œ[ØOEÑçAü¥¼ÿŽÿ çÛa79oÙW÷;8þ•Ýõç“–]Ï9žT}Ã}ÍÒCùI߇òUq¾_qŒçóK~lW™oA|Ìœ/p9r,üå½ ÂAÎ2WBy.Ï­–ÝðÞù5×Aô=Ô#ÔsÐÊýx_IÚ¯Rß /Eçé¹}²÷ÎcrÁ<ð Ÿ.ä<À³îëæýõüÄ%Þ £ü!zO|Î> ô}£OÄsþ˜©÷cÞö‹<—öÚÆó„ÑOù%ðç+ëïùòöäÕu¾Ì[q¾.ÈW‚éÇô¼æM1ÏLñ)?ÇózžR°ùóóJ¾è[åçé3ä=éÿvŒz {w°[ȣ䊸—ç%ns¿¾ô¾f÷בOÑœZË/sh°¯ÁüKô‚¹ôOy®[Ð×C<ìþ-ÉËÁQQߣÞìh?ây¢²“ȱçEë^ÑSæÃYþ¤‡ïM<Òïèø9wŠ'xô’>tö@ –kæRÊßñ=î êZž«ÍÞò»ÌñV9ó&Â<÷O|àó ú‹=?š>SÉEhÏÃ9Ý܃ý·üûpÉ#Êž0Ïʸ™ù_ô’ÿÁŸÊÞºŽÅ ö‘°ï‡< ~Bç@úΜ®Ðo;cöN¿NpUïéy i}ˆý.sUÙ3£üy>×±ˆ'É÷KÏè?7Î Žª{'¾s¼ ŽV<ë½i;%VtX8ì¨Z΋y±ì”÷D(o‡ aœÊþ5ú©·I±®ÿs똷éyAÌ+—À>yŸûr°#’ìŽã}æßûŸÜ.¿ÎeôÜuæÞ ÷¹ÎÌœ}çÙ gäcÀ9’cÎÁqªæ_G0/ÔyZâù×M…¼WIytô`m‡ G¶ÈýÕq òèùÑÚ#ê=|ìÐûÒÇþ†s®ñ瞯CSçà}IÌ‘.w|̾$æ× +Çýù|™ §û£NlœÀ¼fæhKÎØ{É~^ûÙ/ã{ôyÔð#̉ÿ…?ï9<ú¯çÓ“çb¾z‰2ŸŠ9ˆççÄø\v=@NסÞÔù<Ç(˜ƒˆÝ çs…sµ½OŒ¹#ÌC`.· æéxž%{Â8æÈŸ a¼Œ=@È‹{/"ñ¼ôÞs½‰ïÙg';Öá™×ÇÏÛëÍ› ꃮw‡|Ý7öM8Ã~×ö–9ªÊk™ïìßô\?áoæOø÷Uo…ßXÄï‚ïð™àwÎÙóQ¨;2¿Z÷Lï†sr>‡¼Y°oƒ¾}üJ8ïûl©çAŽÈ³{nˆäÀúC¼Žfž>õ8é•q ŸÏÜÚ`>½ãhŻދ¨?Ã#öUâðnñùìbïq>¼ùQÎ9ÀO“bþ›çøëœ¬¯Ò+ã¨`_õ½e û9ÈwËç°ïÆó¼È³ÇœA=—½ ºòsžc+=ççÈ¿¢§è§ãXÅÁì»äÞ-O’{üƒí1< æã€/ØÃ! Ž4¯"èËðœü(ñ{~ÉGË1/…|1yUïcṉ»Éë“ï’|›§ÆÂù 曑_ųwBù×¥¤/È‹ë»È½â3â7ÏçPÁvH~ÁyøpØAæ„’Ï þ%»Ï¼ æ™O¿þþй*ÊÃ_³ÿQûB<7_úIŸŒçèQçW< ÎåÜyö>)ÏäyàÌÿ–ÞÃïG8Þ¿Ê_ñê`ž¦yIØ}¯ï/È»y~ü`ý×óz©·a¯™ÿ"ûì:—ô†ºs›½wMzC}Ùs+^­ù…àç`!q!qïže^˜çê€ÛØã%yùÞÌž&ð£xAÖ7xhÁ^ öZá'ØDþßïÁž@ø·Ò'ï!c¾­äŸx–º™ãGäšýézOp ÷ž²ßRyÉp¾`X·6U÷ã¼ |(ÙwÛÉ»å2ˆ§÷}RoJ«/‹çÖÊoyo²äÛyMé/¸É{†d§ìÿØû Dz~È.Æõü:x’ü¶îÝùLp³~ÎûäØ3B>9-gQâÕó—Žn5Åö¾*zásc&sÃáGÉrïð=˜<u[áçÉà)±W^;þKq‡çq ïozO¹ÎŸº«÷í0oŽx’ùÔeÁ?ÌíæÕ¯²gÍÀ ÌçuÝH÷.DOdÿŠð€çþÁóaN1ûrõ\àp*|û_p›þì9Åäõ‰˜/M=™}Ÿø›´ßŒwþt_ÕÂâñ Õi±“ð!Œ‚ó#iûF^y¥ªûÀ‹-’”¼r¾Ööݰ/‰ùÁþxð‡ù ÊÆû„è[ð>RÙ!ôÒóáÍȯƒ'¼·™y¾Äw’Sâ'ó"äÇ,oÙûH©ÿJÞœOà¾ÒøÌy#óå?àcÊžÄs_¨£¤í‚ßõö“ë°“ð½/ž=ÞÂÑÄEŽ{Àiÿ°‡Â÷É~gxžÁÜTú-Â|ãêUúúRÇP^Ðs‹eWwñüÒgúµ™0¯ëÔÖŸ•?ÒóŠÄãŒÏSòE|Ïþ?}ÿÌ»OÀo'iÞy0ù{ø(è7sÁ»ô!:ÿ _\çÈA\ïÎr}V~>&}¤ôÍò>ê_ýìo8§—ç§Ÿ¾üxø{ø5òè+öŸ[jÙŒ§Ü/\˜ÏFÿýFäÏd—ÀÃÆŸøGá[ð|'êGÈ9ý¼î£žìÁÆž2ïŽó%¿Êüxâöñ=ðÕè3÷¾æÃ‹éù»²ûžŠ?b+{ðdg[øóä;èS}¼Hß1çˆÝ…wLý‰:6øÈý†ºoúÀÍ‹`®¡âoú`ÁÅèŸ÷4Ë~ÓG þC_Wú>à0_Ày<ø¤ôa°ßDs™®àÞÑû%ö4Ñ&žûÐ ï‘_óþ Õ˜ÇBÜ?~$žÀžâÇñ[ž×,»C>?MŸ4ñ)zÇ\ ã'É+¸ˆy$ÔÉù~æa¸O„|‰ê²È#÷‚\ó¾á\|ü7ó?áY#ä xô=¦{Kþ±ÈÞã4nŒûõ|šcàçƒoO_<òO>¶÷l_cgì'O™O'ü@þ¹¡ }ñ>*ácü&ïã{Ôsrž»ÜTå⦟ڎ“¯åûèÇ'ÿ@ÊyÉqþÇy#ó.Ès9^ ëÞú<äx…{¥~ÎóšÏOüŽÝ–¿t?ê:î×Jã¹8OIžD¿Ï÷¸ž_8{¸È_rD¾Õ}¹ì‘‡ysì$zá¾.ê[²›ôkyÏšôšyZÈqvÑøŽ~âݯíŒêlâ1Á«ÆKz.×÷ x™=;Æ£:7ÏïWÉs Ø·®¼0uTçsG`ßÜOE_y î™:8ñrh¾œp3úþǺDù pã婘;^aO"s1{¾Ïsàe߈ ‹ð7ßr¿î£.ó>>ò‘컦ÿŸyîªwK8O俈þcgÀ¥ä y~âdúÓœ_”Þ­ÔÀ¦Åã}Þá¼|ÛSù'ì˜û^%7ѯ^Â#Ü?}ÕŽ{¨#õä|¨ù×ðø™£!yäÞÉO§3Çy“ÌóœÕë'Óý0?¿å}sð“U¿E>ÉÃßu^ææ‡‘[æÙ€ûø~êñøî{Ê=aÍû{½&Žï5W yp_/ü Ù òä¼_^øÒó!„W¼ÇV÷æ<ƒþ‹¿Aßù\šKïùÑ={®‘âSâ"ð3v¼Íý‘Ç!Nu¿y.áKΛø›øÂxRrâ=mÔ‚}èü¾û=‚> îOü$ûÙp~çˆß"ÿŸ"_åý³Ü»ìLØ×E¾‹ówLñ8–8Ér+CŸÐ¯3÷ÿò«[<· ñŽó ìgŸ«ð¨û:t>ÔM°?è s¨¼?J~<|€{À­Þ³){hÞ*ûp%OÄ Ü/~Í=ÂûÜÛ¹åœü¯ž/â—±_º8”ÅΛgÅbá-êä}}.ì{`O¹ü=zëýÌ_ž{Ωæð¡'Ô‰¼G„ü§žùÇñ½ËÞjÛè¸}[ŒWÁaÌâ^8êíö§ôaéó¹?üï]Ç‘¯ ÎÃ_9.‘=”Þ™»Åœ>æ—š÷F½”=r:oæ»y7þù#²'Þ#üŠ_ÃÞâÏù}âLìƒí‡Îùâ÷‰7ÑGÞ\Âùó÷䥰ƒàøòï±]áû…Cùªäß±ßÜ#yÎË}@º7ö‡1·ÏøLïã9WòCô{‘ßGNàû€ø³ù¢ú^òZØ}ï…ôÅ¢·îÓežŽx§Žã„×Â:öyàÀAøGì*ñv¸Ÿw<+{€ßÇŸ3Õ}âŠ+8ÎÓ}íAþûƒýfÞ”÷ëçqžÌ‹oØ¿r¾ÂWžK¢¸¸€yƼ/ÿp çÌɾ`ÀýøG÷Ïëï}ŽA¿~ˆú‹çÔ{;‰ßlÿà;2¸—=‰ü>ýòøOìó‰ˆÃõïØsïÃa¯ªøÌÑôž'áòžŸäAÑâz丞ûbn#爾ÙÓÉ>hé/zÏÏ£ÿÔ±'æã Ïx^¢p ùïÝ“¼Q?Ÿ¯Áó¡ŽA> »>ÃOpÔoø^êièû‘°ȹæìÆu%ù?ò.Ô•Í6žÆ?¤åß_Ôóãôûœv¹÷—Ù^Q_“Ü0/Ùy,éó0À¥ÌÏ wäÍ%?Q²Æk9ÏùI”1.QâôUŸD™…M¯9öŽiQ²ýÅÕ·=9„~„(«â[ý–žå×ËiØrm£(+gÇ“½ú–IÚüÇÆ÷&Ýe5Ñ´pRå•ZrÄù£Œ-7¹¡{”8â¿ AfEY%›oëzàæ({h“‹V %n˜6êôÛ?в^ÛÖø§ŒÑðТœ•_ü¾÷¶(ãç¶ÛVîë Ÿ,Ê.U÷›™w÷‹rFvê9똾QòÁßšqz”µsé¶ãç%£dçWïþòuQÎû6)Ûý‘(¹yÐÒËŸ¦o,J–m|͘3GY}lþêŒöQ²ûƒÆ%ß,1 Ìî2ñs—o¿±òšïØ—å^±øÅk~~"ÊîRªÚñS6DÉ»—Th3ty”,}ìĨB‰(wXõ9egt²wuÝ8¦_Mü7ÏI_Q”W±ò‰Â(süE_œ³#Ê,5~úÒ^WG9ýg\™5bl”1oÇÀw'}e<™êráèk£¼aG~þøg—E™ç<ñá;5gD‰oÛOù¦z½(k^‰å×Ιî?g”Ml[œå5MTn5ºS”±ö™±r‹E‰ÿù¥¶QV‹‡–ŸUù¼(sÝÇwÍìÓ1î÷Içcü÷É‘9y[ßëîçÒûD§ílUpâ>nÖƒ•vÙ\5Jö4ú¥ªY¾×ÌOŽø¹ U2ÊŠœÜì‡ÆQrÜ+,l%Ö7«´$¿Z”uorYÝ(7ïŽûÞÉlá{ËžÙøæ¥¥DY[ª4[|TÇ(g×ô}ŸÖe/÷Îîqc¢ÌF>è{ôG©C#·º{õIQ^ƒu ¼7Ür’YovÝ‹^ž2ÓxŸßó¹ç?W¦}µkþ’¿qǯϘå¤úÔ¿ý›ì(£á€‹V}ÿ—<ä~ÝzÉÑDù:OõeG9…¯üxc¿úÌŒï_rƒ\&}¾ÇºF™»¶¶iݶŒ÷µe·_wç™ÏGYÝ÷5IÍMF9_]P·ßäQÖÿôû?Èy™(;ñöÌÇêOˆ2—m¹Õ¸©QÆUO]ûæÔ¢ÌÖ]ï=js-ŸsnƒŽo½ã‘(¿ÿž—óÏëB¾ÐÏÁ÷åÍø¨÷uã"ô\e=>n`·Ù“¢Ìa¿uúጺÖ'ËŸÎ9Y¯^½¯Ÿe–oúKÏzDù:—DÞïïìîý›åDrÇÏŸ8iEËãæ®ñ½HÎáùaGâÿJ.ò®˜ØöÃO.Œ’ÃJÏ­pÉ ËOÎi#¯‘ºÝ÷ñ_ÞàÄbQf§ö¿lìü×}M.þõîsWG¹­Ë^ÙoÿQÆÎMÛWk{…¾æä6~)§ü±ðp|?~NÙÓÌìy3ç4ó÷Û>ó¾ÇÝÚmË‚¨d“]¥?Ù´ÂÏþd>Yá¶þJÂÊò‡Ìýó†¹à(ûŠ®§;¯í`æ÷7”jþv>y_î¨dï 'eÝÓéËvN$¯%&_¿ä†#;EÉeä½ñÊ®(¿ÝŸ¶kÕÅ÷ˆ=Ë:®ÅÜ&÷?ayç½2?Óª:⌂ m¯ÊȳÝÍYwÌÌ™ jb'蟎íÕ¡f……oŸe;È9"¿|v }ÏhÛ«ÝE«{E™‡:”zerÛXzÜøÅ— ¶Y¯‘·¬ÉUV lxJ¬CïºuxÛ‘öÓ’ë;ü9ôƒ÷ÆîkžM”1±u%mSÖ Ëeš—b»Ÿµtþ€ãO±ÝÉkµûÌm˪ÙNd·:øÄ{#¦úçxÞ?gi·5Wï>Ú<æC ïvΤýˆÎþ¥ý{îØoæß¼á¤({sÇ)×O»Ô÷–=¹ãÌK.e;žœ~ô=«ÎÿÄv2Ñ¡Á©•èàûÃnrnÆ:7ëz¢ù 9ó˵¹ñ¥YQnÓŠWåÏœÄ{ÁËŒ ¤w’Ç(3±èÜ)?Ol”(¬¼iÑ/âï•>e<ûÓвuFo¨ãZ^å7»’»¶»ø×Mñ÷Èc¯³×Þµ¦æØû}oØÛ¼jƒ÷_Ó&ŠrkÜûðI'”±_MžþFßË;ŠrÚ¿~Ú %¯2ÞAø9ä’çÊ>ôØWK ·úóÐ{ðUÁ¼».yø=ʸ`Ŷ~²ŸÄÞ‚¤·ÆG–gÙ'î#¿Áþ½š^e¼ß÷ú*ÕfÚþâ'sÆõìuùêî¶»yKÇOxcÊzû©ìüÜ5-ž¬Bþ.Ê8çõ.oZ*u°÷åÞ¸…{‹’}ÚÏ*_¢†?/ûv«†t»Áç ¾Åfö8þ±å[ëø½r+ô+y|óœ(Ù0·Rõõl—ñÒ{ë%Ÿ½ä\³Ö½xÅYÖò¹f7]0öÌë3£d‹FS_(¹=ʾà§ûoÉ0nã¿<'çn%û“ ŽÓ}gŸ6㾆ÍÞŠ’MF/|zæxëúŒñœè_þã~o·å(ã~Ÿûþá_ˆ+¸ô |ȹç¶tú…ßù|äçí· †e¼vÅÒ÷l¯?ðÞŠ|þ-^>4óŠG£ìjóZ¼Þ·´ß'?¯Þ·“Û®‰2Žè0ù /G¹‰Šåß:!Š2{[xjíó£œÎOž2}áÙ±Ü÷ïØoC鯷ð¼Âþ¯å&}~©›_ÞugÏëì'Ð_ü>x?3õÒýÅ´´!ïòÿQA…'×8wm”Ócø3Ó—Ž´=±¿‘Ý—ß4®Å¯æNO®^=kR”[æ¹Grú}Ç{+n™˜½ó@Üÿ繑›ÄÕïÕ~¶nåØé÷°gÄiö«i ŸßrÉ}å–~5:·êBÛ•œƒ¦Œ=â3?v#whƒ¦¥ë_b½àžÀ¥öëzâ5Ç%Â…ø/ôÒ3à+F™CŸíPÿùM¶3ŠŸÈKÏ¡Ÿ–“ï¶×¿¬ÜC~Îü SG\sg­XŸÓöÌýýÄ3Â-þ3~Ñú%\c}—?³üËïgçÙvMy±(ã’Š³sî[X$ ßb<¦ø9ß“OËûªØ}8Ès’'´Ü‚Ó°—œsrÞU j`n,¿>ÿñsüÙ÷‹ßViôú}«éOp<€¿à¼ q·âÎCC*6§ÁYÆçøkü#y$¿·ìƒí·ðò…|+ïoyÂ>IÞmW ÊÜvÚ‚žqþ’|”ô”ŸhôY™AÛc=‘?Cnð˶Dzw¡½Ä9®šÑ²çÓ}γ^á$?ñýä7‰›Û•«¹+Ê[»¿÷¢ÚXî8oüi^týÑc.ŒùáÔ¹àÿo'žo*u êªÅ{GÅ×§A]Xu‹xetóŽD‡K\Ÿ‚—Ãþø ð›á_À÷Qm¼ïJü"xWÔgØsœy£ìó\Pñq¨»°Ï0œ÷ì9ÕªÛ° þÏA]œç§NľVÏÍ×{º?_<¬™gMzrԹ짋÷l¦ëÏñ^fÝ<.øô¯°:"uNî¹ÃÌé…×Ìï­9°+Ú3=žké¾Õ¼÷8]OŠ÷!ˆ‡LÝŒ½gÔóU/*²¯–çöüvÝûü<T¼2óéT—£¾C_ õ/ä¾sEØÃÆRêBÔŸwî¹â¹T‹÷YIžÄSðßS×£ïBu¶Ü'Ž^pOð9àýQ/¦ŽÅ^dê¸ðf¨#Úç> x ðPùwî þ<Î…‡G†~!oì…¥ïùÌ«W¬.3ÿƒšÞ¿NŸçôÇĽ§Õi\Õu]×Å7BÏì{8øÕµc9K˳ùܧ÷3þ}ol‘{¡Î ÏI¿îŒ÷²kÏ#z"^¼¿›}V’îÞ#¼#êóìõœUñ#¸ö3zÎŒì!{Ω‡³Ÿ–ýì]tŸ}®ÁdìvfQ²Üæï†6¢¯/æ‰÷®=\±]’œÁk4ßU¼ ú9¨G‡û[ÑgøŒìed¿¢ö£{ß6uZî™z0ïÁßÃC·ßÓ¼qæm«ŒýáçØËs£‡Ò׸Oýì‡ÄÂçÃ/ñÔíÝ"½Ö÷ÅöE綤çi¯5øm‡õ^ujö¿Â[ÄŽ‰ÏâÏã^lWÅç‚·ò­ö"÷ ùâðÑ{ÞËsì¥Ï<'¼iä;SèŸùÕâ9h/lÜ'"þ¼(ì:ûayopv‚{Gßà7¡ð°3Æ/êïDžÀ=Ø%ø¼/Ÿÿ‚ÿrÿøGø?<7v =†g€[dWÙ;ˆðþxɯ÷Í‚ô>à€ÇË…üúÇ9ógæIПà½é‹`·è?—Cÿ)x  ŽCn$~>ó5u_øË€Ÿç>Tøjȧø—ñûÊÒßža¿,q=|gõ ø÷Ù/¼äà7_-Úëü6öóùìOGNÅÛ+²g½£›{‡Ïù0ß[ïÏk_ >9ò^ÇO`oàõsŽøeöó~}ÜÞ¹«ËŸ¾WοÊþfp¸™¹EØ p4~ ùa±ûsåÀ)È3·û߃=¯øqô;€ÿ7Ï`9_¾G8*æ‰ b?ñÈ#ò îç s^Ø3p ò_^ôÌw2ê¿û[Ù x·àNøaØ}î÷€O‡œƒ³á¡z>Îþ}]øcì*ñqrÆ{;>CoÓü²8NjþkÛÜË<·ßò‡½…¿Ñ/¾Ánð_ü¨çÈNðy¼7硽äEäŒ{…Ǧ?±ÞK$~%ýQü>}©|?~>}àóK¥Ïàü yî|¾ÇÞpôEy¿–xxÄqàð+¿Bݯ¢8…=áà!xã~¾4N‰÷¼Š÷¨¸ºH¿v=ÃOpžÂ‘1ÞÐüðpI}çÜÙ#Žž‚3èg"^ÃOáéG÷žnÝþÑsH¤Çàjâpæ¸o1èó%.à­§œìv‹ø¹A½÷Or¾ü4wó%©q;ýùøqâWîWŸ[$þ ÷ºFþ<Ày`°øöŠ.x¤Ë‚^åºúy9öÅ“ÀþΞå÷ôÜ~Nâ\p)8¼cû ;†ž!gäg°›ðg‰wÑ›Ðn{°sÜ+÷ÿí~Ý;rI¼"ÿÛEÙAï%W>Šx<7’¼b<÷A8ŽçÁÞ;~ï¯ç,¢§Þ#< >ï’¯#ÿÅ âÅ{Z=»Ë6Ûp3ûaB¾¹ì³ï=E¾‘÷¥È>¡ð„yOâòhØ/î=rˆÜàŸÀÓðõñoáœü,ñ9zÃû{ŽŠòk¶÷²«ø=ž¹‡ò¾ÎwÊ¢oœø^çãgýþ´ün#®î¼q#výðœÉ!ùòcÿxꇮ×Þj{€ÞpîT¼€üLéRê’†WTd® }VƽÂéØAçu/È-¿¾âyæÔX8²ÔËûâýÅÊ;p^œ+rH x =ÂNqä ˜»~ãß¿lðÆc™­®%ÛU|vòbØwìg¿Oßý¡Â¿Äý²§ŠëŠä½È'¢äÁÃÈ%óœÈ9þ™½¿÷Á®5?±Þ"žc¤ûBˆÝ-|ÃsxŽô¿Ãù¡?œ£â1÷퀟<ïFÏ©ü@\·HëK\QüÎçâÇxž—ûÇ¿ÓGIœŒ½ñžnåí¼ŸSý†žûÁ|.æW¯a^/ûӘǨ|§ç)0çžyŽÂ•èöÖ{#™ŸîE–~{:sÈd¹ïÿÃn1EvÃýoʧys;¥‡ü¼ókÌÛì þÏóþÔïMÜá=òÌgP>ÿå¾fâAöÙ2·\Ëüúƒ¾ϧfs›õ}Ø)ä”þIæe!?ôõË8÷‘«¯\†àó™ê¾\ý>úî}<ꯦϘïÇïxÞ7û™…×¼—RrÂ<.òÀØS÷]²G€=´àUÕçUwö=rïêÏŠ½ÞÍ}èàÛžÿèy’Oúš½W\¸ûð^Uö92G6˜cLß²çWõ?ìùrï1cÞ$sœƒù+žËÊ\áü=ý™ä…¨»ñýè3çç}ÚÃ$þ]<‡•9é?ûüðCÜ+öLs5lç°—ôáy.*û&™¿Ì|Í­áþ=Wyf.L8\v“}5žÄÜ9öûÒï%?¼÷ÈR?MÚÞÄöŒþiÏme®{¢Ù¿¡¾sú°‡{Çm߅ϼRÏñ|övÒÏÈü$öÊ~¢¿È¸Ïûޘåÿ’¯ö|ï`o¤÷Öè}ñ ÌÃãü°[Øçp¿®ç Ÿù~•¯ ÷iàϰ7Ìeñ\bÙÏ—e?‰úì=O€½ÀÌq`nŽÎ¿HôìÑ×Í8é_{‰KŠàNì¸Îsk%/Þ*ÿ NaßsRÂ|þ€¹‰á|Mï ”¼SÏ _áºó.õ÷Ì·`ÞܼɯÞWûÁG< ¿n¿$»çùe²÷žGÏþü†ìï_d^–æg‚Ÿ˜+ÌžZò‘à êä ñ'œ+øÈ÷À^Y½?õ&Ï1>'>6>Ýqü£yªØ x1ÆU:WôÚ{eç¨ë!_Æi²«Žã˜ó&»°Kõk‡Ð/ž¨û ÷Uz?»ì£çóÊ‘Do<ÇFÏÇüZô×û“Ù; ÿÏÜæÞw9¿£ï'Oîó$ŸÄç1Wšß“Þ󼞧¦|’ý«Þ“|3qó_íßt_ø#òTä­¼Ÿ[óïˆ+¹'ôÔs±käÙ#®=K®¨®7>d¯$õ$å5=G3ØÏ»¾ßy>”Þ—ÏAï¨;ndÿªìú@Ë™‡Ž}ðܯ´ŸŒçêJ~á½y¿¼òìÇáÞÈÛy®§øØKï§€W.{A<ÀÏQ‡Âž1çÕû~Àð<„‡ØÃî¼*ñ¢î‰ŸóÜ{æÑÊNQ?ö<+éñõô{î}s²/žG'¹’ÝŒózÌÙÒ÷S—#b¦çý2'—=pÒsÞ>ÿnž€ü.v™s÷qùaâ-ðzÂy£§<þ=óžcæUç*¿C½Éû³˜N>‹óÆ.ú|åo©k“—µ]gcåwÁ5ø-Ï—}ÄÏ{¾?ÏOü¬ïÅ~ÃÓáóyø!Ôãà3³gˆú7û+Àyžï¦çq}F¸ØûŒe/½@q÷#螉[U?Šë5Ô¿ôžðâÃ:4öÍ{*àKéüf_þÊsWùI’ âSÏóeοÎ¿Ž¡Þ€ÿ=Ø|Ó5<ßÝvÅóÛé_îßû¨õ¼–_ö)ésùÂä¹8OÎ~+v×ñ–ðv‚ú?uìpî,–<½÷ 2¿WñœçeJß° ÊożbæK+¿Àžx8Æ}Ì‘•ÿ¤¿ü rbýÒýò{ð%ØÏa^1÷){g}Ô½„ýIàBÏÕþO /Ä·Îo+¯ç½Ê?x•üß/{V„ŸÊûy^"v[¿~Tßç¯z¿,u!éq¸ >¡÷Õ)¿J|½ Dþøwäžò†ü°¯Õû~t®îO—óû¼·ùËÎÅαÇÕ}i»âýéøß°Ï‰û†×á¼y7é+y`žÓ~E~Íq®ìöÇ'½¹së››­kÌËêüõŒxÿˆü|pq®ç±Rÿ•þáyêÆçðGå—Áó<—çê¥óÉñ¼_Þ[ßG]”8zžç6JßñGà{x\á>ð©ëÔì»pþJò‰]$Ã{ržÈ?¼ðŒóyìá _O\¦srQòÎù&éyÇ×’?ì=Ï ¯€?"Ÿˆœ©»°'|L=HvÆsk™«(yCßøyö‚ç÷•ü°]û!kb=¡n/{€¿χÏKÜî}â·ÀÛ#ŸAÞÚûuNäWÌ3Ý›Ý{ã CßëœÈ‰÷6‘O•¼òÜØÕý}Æ$[À<(¨Ëyγô¹E/áƒ;Ôó /ð\?&ïÊ#é'v ½ñœcáê<·û‚Ä£ÄÎ’wÇïðsø‰p>7yvãwöÎ'PþÈ|Yùwü"ßë=JÊû!oä‘cð/¸ =Á¿Àç_º~'ý'ö¾-ö—¥¿?®Ã çÁwFnáEWb<:óm•´žëÞ,oé8,Æ!ðiÙkOFùê“àhî›çá^ø|òä»=Ÿ}¨Ê‹ÛÎâd_Âý ìs @ ?O¾^þZý–'ÏCNð=è<ÁÓÄðÏ<¯_ïÁ\pï%`ÿ!ö^ïC?½ó‘ø{øÍäq¤‡à+ìçì½UÄéàæ“××=™³|p±¾ý]Gg¹Þ î¤PïI¼êùߊçèô\`êáÂežg¯¼/}à ìƒùeäõ_âuì‹?‹ãÙä›>âÏQй„{ÖœÆ~?$Í/êm/Âü#Åkè=ùx•æµÉáÇ(Oçyñ²|ñ­Ÿs‘|"÷Þ¬úyIïÐ{ó}Þk¯ü,¼ì$yRòÖäG‰³È×8^ êòðêñ¿Øep*yæ&èùŠìãâûÁ9ØþK‹sò¾á`×õ|î÷Æß¡7ì5 øÔñÐsâ|¾<ƒ~š×-¾°qœô9Åÿ"ßûØ“És€“Ãý®àîƒ<vÿKÜ~· ðÜO#¼Íç!Ôûˆ‹½_VþÕï'ÜýÙS­æ='ܜ癑x޽J²ïäÅøwê“è5ùOîÉýIÊOs¿œzˆ_0ü;|:Õ ÀËšód>5rŽ]BO°Ï¼W¸×Â{ÔT¯ïÀ£ñïC¾„º|0÷J_l—¤çî÷MË óOc^4a/¸ç+àUIÁáaßò®ÉŸœ}A­nq¼©÷0žºÎÁüá.¾<ÉýÀ«ù=ø3óÚÒõÔ"ûyB;„9ߌ½ëú~p¨ù$’¿°=fN~ÇûîˆCÈ—(‰}ö:ùùÁ%Ü8ÎüNÅïôóùØô? Åõ<êèà)ÙEô™z–ùßðäð[ä‚÷§F¿åK~¹%Îcn€ëJ쉗w¸¯Mv<£¸Óü.ùAï“€‡'Žœ!§ðŸÑ[ä|‡ý'ãü®ò]øË}ÿ|zòò•Γ7¸'}g Ÿ‡¿!/cÜÜ*×ýÄò¡Ïs^[¸{¤OŠs&΀Lž;Ž]"~Elï¥ÏðMÐ_~ŸŸc~úe;$}%d>ùeúäßœÇÂ>KNá¡„{X‘sïwa¨ž~Õëã~gÅÔ ¼§D¸/ìO‡wg»¡ç'ÿÇ{8Ÿ'ü~§"oÔ3áÿ’÷æ¾Ð'xèüä ž~ž¹~à˜C‰#§.8b“í'~„|6?‡çó½×Xß`𔣲*¶6¾¢oGsŸ=Oý š›ó´t—˜Õõæü¸Bø–z2v—çÕ¼öÔ™•ß|sôã¾Oâ`í§u~çzŽÞ9Âþ~ø€ÆkªÛ»EúŽäïí/„ƒÂ}Èæ›éï½G4è«àÜì?Õ_ ßÐ<ñtÀ‡ä1ȇ’?·\ Âë5EÏM½7äÛ!‡ðààÁ¿Ãò>Øê=ìÛq„òªì©7¯]yø=Ú›`='ïJ ÿë}`ìù•Ý'f> üRý»ûI Ùæþ5é3çn~§xàVÍáõýîoÐüõ[:Móó™ìÄîpîðð·œ'Ï«üó}®ä[ÀI’S÷Ýà‡Ècp^ìç>Ý'ƒ¼ÐG€]R½Ùr/y·¼°wMòÂ{¹Jñ2õƒ¥®ÏyrsŸ£y'Òæ+óýa~{9´]“Ÿrß‹>×÷Ï^:ÙápÏï¸=]’øæ³É^òœäEÝw!yc/&<@ðσ=C?¼ÇT~ßò%yC©ûzŸ·âžpO6äÑ…}ÿœ'?ôWà/Ð?ì ù)Þ ÿ®<¥í2òÞyï&¼ÝDT«N.Ì#w^;‚Ü»O*}QbÔâûkw¼Ø~†ç×÷øß]g^Æ»ïIòŒžx_ýqzn>Ÿúþ¹‡oʹšW$\Çýxî"|ðS:η] ǹ‰>Ip¼ä8Âõ-åCµç%õíº±ŒhÚÝúM>ÈùÅ–½q¡û™tNôsb?¤^ßøÐuñ¼O}?ú×à\Á·>?Éy`xVÈ©ïWuoûiöèJN´Êçf¬î8…÷ÿŽ}Õ^çŸö];öÚ3ÿÝ2î—b¯¶îÛý}²»ô©ñüägíωŸá+ËNñ¼æ*®"ŸäyÍç”0îÒy"ßÄàøxÚ×ô¾<s¯NÇÙEâòþÄgà/î94^”œÚ`¯u~Þ« ~Õ=™_/{m>”ôûÜyŸ½ò8$îñ~x}¼kÇÛú^äv_ïu¯=sÞJŸ+þ=á÷o…£Ü¨{Cn¨‹!7!ÏÖüHüà{p1üœ=#ohzô“5â¹Qø§ôù±§Ærì~9ɹy¼ø%é;uUÇõªë9^ÓÏ{ï¯Þ/´käU™›à>8Å1ü?Þ!í8  ?Aò…|¸¯]qšûFtÞ|Žy¼ôëK©¯K~x¢nõ©qÿ»ô€{åþùæJ’‡CþÜ/ÌS3ÿ•z}ÿú9÷!(^±]d¾ˆÞŸzòdÜDM°¯9œCáó×¹¢‡ô“Óå| ¼PÙô\b>y ì?~Púí8Üï„s oQ÷hÿAÝO~Þ*xžsbO²ùJô/àÏÁ·zì'òí~G½v€þ¬Êì}éoÕJs¾Ô}7‘v>ZvÄ3ç™8ÑurÉö½ß[øÐy.âúA©ÃÑo¡s3Töˆ:w˜ŸÂ.À7'o~±ýS¼F\Ìç?ó\î€+½£ß޼Šã~ù×+uÄè³ùÊã™GÌ{ò|Åüœçlè<À¡è9öŠºsQ±ÄA¼vÜ}ÉÂN+¼c~§>º9qö‡ú¸Ïþ_þçïí{èúëggõŠãÙp¸ÏMzK½ƒ<3vŒº†ó‘Ô§Ù7/ÿh^·ž‡{F.ÜwEI~Û¼x9úw×Eé£UÝ„ºq òo þçï…KàÒ¿ï8Œz¨ô¾¬ó—’_òØCóòt~ô¡ÚoƒÏ‘gá/êv>OÅᜧçcèy?× ©à‡eg±Ø)òÄÜqyAljÌI`®ñ¦ðÕ}ã‡Üß,~ñ¿ç1öÿêqvÒyÉvÖs$øuü¼çë¨÷ȯ¸\÷nœ¥z>ñvÍuá-çE$'ÄðÌyo×õý<¯õ?À5ðz@|L¹øðü>}¤È ¸¼%?‡ÿ@/ñß~OòèÂûá÷¢È-¼ëñÞ“¹;øÉ½[îµáÆ£ã93àødÌÓy1Ï–{uÝ›¹²¯àhÇ{²sœþ›|†çfêý‰[À™|žçx1ç‹Ïòóàä¨>’Ýs=ý!ÿ óÁ.;ï@ß3ùé-~Õñò…þêÏäe‘+â6îÛùSxIÁüDÇ)ò7®—‘§Ñ=ƒG°‡Î×Ã/‡è÷<·âüúÔ)Ã9Ä)žKÀ<ê1ú<÷9€—„wˆ#]äýägÌ_Jïóù[ÔËUWFNà ˜÷"ùp>Ÿ¹:?òÃÎ3ß»Î@QÿN<ï9gÊß#Æú³ñ#|”h𨊯uˆç‚á7eïŸpþÂ+aËsP¯ðÜ<çþQ]f5ù}_*Þ?;úðÍ/#Ÿð€<·€>qúìÈÏÑ× ÏDvÒñ¾äÄóF~¹ÿ]ö9¬çwÉñùÎëÊî“OqýAþÎq!|Ƀç“1ç•ø¾¸âg÷ˤߗ}«þ>טÓËü#ýñyDzÇöûò ÔÃì˜G§|•ë Ø_ìˆü3ñ0òd\#ü@Ÿ§ëôð7éïê£ðÑü!yÎÕ¼pòðêÉÏ(?ÄÜsòKØUä›zƒí¥ô˜<‡ófà?ò'žN=Szg>@8g#˜×í9ÂíÄóè?ù_öºzž¢ø È—ç>K­o¿Äs^™Ó§ós¾‘xýÔïyó‡ÁËùÎOþ–¼ ü&çƒúûþ\§%NR¾ ;åº?yé»óÀè=ò Π%;/†¹Ü“ygè;vTr Žv~QïiÞ¨Î1ìÛ$nòy‚¿©Û2/S~Úñ<#Ý—ç#ê}ÜOÁßã·¥ŸôÇr~œOa0„÷‚OŠŸÅ‹¿îü:~ŸùdÂõžû.¹àÇÀÉÜ|â“ð=ÛMéç¦b¯¨ÿ€‹™ŽÞ"Šùö®‘·‘ÝöütøTÌY$˼:É…ýœÞ?l,93ÞRœNžÜú-ÿñí™»Æ>qA…¸_šx ý]àçÁËð<¯–ÏÕ½sÈ£ù`§®Kë½Ç™Ì,ÙCò7® Êž¢wÞ㡺¶ûžxþ Ç‘ÌUößõ;Ý÷ê¼–ò3!¿8ÜwîS"¯oØs»%WàC÷ÉIn<Ç‚¹ ̵„÷¯ èsóòA€<sœ…GÝo©÷ Dýñ=RÉDâÄ3cÿÎ>æ¼HN¬i\`|ézS:ŸevjÿËÆcWÆóŸåoè/á>ÍOa”ðè¡zŽú|~í(qàÝ‹Žz3Ê8çõ.oZ*upsŸ[§8 üe”Ml[œ×áÒòe–?}i¯«_Ðún÷OúfB‹ºÆuîtþ"Êì=l᩵Ï/ROE…Ç¢D‡§^T¢ƒëô©©>%ëÕ«7ðõ³¢Ä[g|»å÷óç÷OÁ×JÇeæ#W<ÿÁJ§v¹»Ùçq\¡>”¬ñåÞÙ=nŒõ»‚Üãg¥QF—‚ÅåžMxÿòÃy`¨;šÑ õÂ[+Äý ÊC…¼=ï1'”>ç(«û¾&©¹É8þPþAvÈyqò4ÒÛ(qõ{µŸ­[Ùõù©(£|û•×|g¿ï;s×Ö6­Û–qž€¸×{G‰oÛOù¦z=÷CdmrѪ¡bÜž–£(ãÙŸ†–­3Êr–,Ûøš1gv^Ø| ú‹”O‘üZ.©KQÿVm”¸ôeެb>1y]úl?Ä“Ã/¨ÎaùsI]}NäsŒè/–¿$î’7ÿÛû]˜?—]pžƒúZ0G•ù³øgêgðCÀ[ØòÌû‡ÔìÖöä»c>WÚ_D·|ªÝ«÷XŽTGˆ2žLu¹pôµEêŒÔ•ÇàÞ¢¬-Uš->ª£ó‚ÒgËy7åmoˆ÷ôß(q'~t¸4J wk·- œß@<·Zõ6Å ô'DÙ‰·g>V‚í¶÷‘P>#ʸê©kßœúûäþ .ã÷Ì7@n2‹ÎòðóÖ/ð1ö™z‰ú#ŒÏÁäe‡°Ïî»ÂÞ“7sð¿úÉ­_Šs£Œé^™´,›Ÿ‹súë÷á_zøò¹skŸñs”±ö™±r‹E‰GŸï±ð‡®î«ÇþªøöÓûMŽùŠŠÓT?õ÷ÉorÆÏAÿ@”Vzn…KÙß`W¨ßbN¾¨ÑË{›_.â/ðý<Ï#˜AÝ }a…ù ô]É /ÎÊnÉßD‰;º¯jañx®>û5Ò<Û(kÝ‹Wœõh-çÅ8?îýÐæ?6¾7éŽ"óôÁOÈø“{ _•<ýšŠƒ¢¬×¶5þ)c4õÄ(ñ¿ø©mêÀòS^ûðÌ×,?¡üiß_€»£ÌòMéùCç£$Ï®_z>Súžl_ø=üü ú€}KN?úžUç9ÊØ9£iû cc½Hß—ý£ü~”¸aÚ¨Óoÿ(žL~EöýÀïrOºÛGô>€ãbå_Uˆ²®è•|¸ ¾q¸Ïûç§àŸop•x QöÚ»ÖÔ{?{ΣÄúf•–äW‹²†Þuëð¶#ýžŠç,ƒQÖq-æ6¹ÿ/9ü¹í¶•ûzÆû:äOÑ ûEáWô;{häöAw¯>‰|X” 8¹Ù}ßäÍÂü†íçWCÆ\se"ÆÔßt¾Ø•ìQ%Ú>»gp<ÿ(]׊²ûwì·¡ô×Q’¼‘ò6â=‚wŒwDŸö¾·J4:îcÞu>¾ù*ÅAôI¹®•ö¿àaûYì„pU”ÑøƒöÝ[®sÿ¸‚¼qºó…ÂÃøãqÍG÷Ü*á*ã–†.Zõ}û({sÇ)×O»4J6½ðé™ãmo„#¢¬CÍ ß>‹Ï’_½ûË?ÖÅyúê¤?Ø]ÞÛx1o‹’»¶»ø×MQ¢ò]õû^Ò7Êx¿ïõUªÍôýel™¸iÌ Ýã¼óœ%ç’§(ñsï#»—™efÏ›Ñ8§Y”¹lËý«ÆM%Ÿeû­ÓgÔ÷G‰‹«ö^Þý€y-Î_2<ªúá;©¡ñ.Ùwáô}(ÒÏæügZÀÎ7Ïÿ^‰²¯èzJ±óÚ ÿQÖ…ý£Ç[t0î7ˆŸç[”‡WŸv”ùd…Ûú( ®ŽÏ“ý?Ú[˜Ûºì•ýö?þŠ2[w½÷¨ÍµÜoÊyGyŒòjæË*„Ÿ#Îp}™þ Ý[vµy-^ï[Ú~“9ÂöÿŠO%ñç¤ó4ÄŸŽK8GáEì›>9î‚ζ7.VŸŸû4ÀIØuðeØf^­~ŽßS¼e¨t÷m·tŒùñò7ØÎ ž€xeØÁøùÓzáûÃï¸n®x {’±â–‰Ù;¸_¼­üP”Ñú­çÆëöÿQ‘ý²¿u}Jò!ûàx’~IóF™ô+OäÏ%î!®Á.€È{b¯À}Ô…‰o]—Þᇨ£¹%<ˆÞÉÿF™ç<ñá;5g¯GYØmö$ò:ăQƼßôµõ û ÏGü—à>ËþÝñ sé57†ç$¿ Î÷ü•t¼é½äQ°ãš'ç+àƒÊo†ó ˆ3Ì#ãüq^ì;Íšõ¯­ßïÀïñç(ó¡[Jï|düùŠ lï&_¿ä†#;Á³ó{!—øó‰Øk&Þ‰û8ij!_$¼jœßQqºýç]R0ÊÎÏ]ÓâÉ*ø)û‹ì>M?}ªp·.Yú؉Q…ös¶iüA?ïeükÕ–ÞO=a»(>g”œ\üëÝç®v‘ú üAòžc¡|u÷·QŸT<Æ÷pþø{ïíMÇc>wÕ3ÀwQv©ºß̼»_œ×/Äû”¯%¯I< Ž®tÞÁû®Ucž£üjœ7>çýÍ7Jã¬8~NÇ×ÄÖá(çìü­Ù˜§©?£·Yßê·ä¯÷Ä’TÞÞq‹÷+o ÔùáBâ ó 4o8y_¨þl{NݼˆŸÄN2ÇHv×s"ÐêžÔ Ðò?ÄßÄ#ȇãEŹÄïæ‘¥í·óu|žp¥ÿžŸ·ÿ>ά7»îE¯Nt¼šxõü¥£[M1Þá9¨Ç»¿^ø…÷ç©—3¯Œ85QîªV'Õn„¿ÿ`‘[Õ÷œ·ÁžÚž(îóž]ÙøÄÂÁäƒã9‰ä‰©›Ã‹'¯¤<1þˆxÏyHÅ#:§(yú}/ïtÈv ¿-ÿ„ÿ‹2ø ïÑÙ£Wþòþi\lÿ’ÝãÆ/¾l°Í¸Ÿû¡>æ|:®3^ .†œgŸ6㾆ÍÞ2%þE‰Û°Žãy/æ20§Dò-¿e5Ñ´pRòƯ©ne»Œ™·&\@Bx6ž"œBþ¿‘ÙâåC3¯x4æ5±¾¦ðRfã[¾µŽõÖsýeÏÅqLGÛÿ`ïwÇ}ìì+Lף伪Ô:ûFÜû9òÊô—ÿ=~Ž2?9âç‚VIpB”YØôšcï˜f¿„KÞ±¿q^S~\ñ¼ëgâEm{µ»hu/ðq´yìàVåôžœC”9þ¢¯ÎÙrSuÝ(ã¿~tb±(k^‰å×Ιóè?f>˜ü­÷¯kß=u5×çÒÏï¸Uòé{ åÃ}ÿŠ÷Ḕù>Ôñdÿ/`'Œ+•O1Þä½øçG9ÕãÿÄŠ ‡UËqy&ÏÁ£RvŸ¼?þO~¼e-?àøxšóxä ‘ü¬âçOÀOØÕà9¢dû‹«o{rH!ë´¹õZg|a=Ã>“”Ÿ7Îñ<ª4¯%ÊNº7¹¬nœÇH׃ì_]wJÇQŽkØÿž"~1oYøYuŸ³òKæu¢ßÌ¡¦¾ƒ\Gd7¸¬íåûWÛŽñ_ç3ÒõvÇëè±ö~8þ –¥<(8Þó„ƒ=g$/‹²¿Û^ÿ²rÙÏ›—%?«8ÖùwóèsŸIþÜ~²H>;ÍWŠ’kö]˜‘s¾Ïü…^Q‡‘?±ÜK/b?¤:µäÄŸ?'ÞÌîRªÚñS6Øßê~c•>Oçw²¨Ï+þ$N ŽîûW~ {o¿®öÜ+ÅÅàûYÙ ò ä]ÀIä“ôýÎë0Ús_èS‘Þ‚3ÅCŠ2×}|×Ì>c{yö›ûgϸÌ8Oõþ(ó´­ NÜç:Hv…Ñ_Ô_\Ç~Wx8®³ƒ+'y«ðy}Ç…é8Îïoyç¡ú¿í“þ]¸Ã÷ ÿ)¿%Gæäm}ÏsO?pþVq/q>vOzB~ÚùeÇËð1Tg#n§~kÿ¢xAuÈ(óP‡R¯Lne—é¾ë¦ã&Äñ‰pˆí{BÓqžñ¹çD©/ˆz)sÔÉŸb©g¡GÊë8Î>2>sž}•öOò,Òü4ù3×gþ>'ÊœÒðËnßmµüò{Þ£ªº¸êà®Ëxþ‰>: çi®|Ï™¢¿–ç`^¾ôOyeÇžß§>'Þ=gþŸð·ópÊç9_%žk ¿»î$¼l^•ü&õkùë(ã’Š³sî[h>øÔûÙ•çÔŸ£Ìïo(Õüíüe=XiçÍU±wð;Ìò>.ùì.xH|ûâHÏKÐï'*/e~˜âT÷S§ççUׯŸ3ÇHùãöâ ¿¶—äÇé!ŸB=£ÅCËϪ|q~”Óâö[«}{i”l˜[©úÎz±\*¯ä:±ê¼Ô÷ðëð.‰¬_Ò;üqŒû¾Ϩ>ÏïaŸ¶äœÂ÷WHÞ½¤B›¡Ë}Ÿðj˜ûí<‹ðyxÄ{ÄÇÌoø¬I±Qj¶¶}°ÿW;J]8¹»rÝ‹ª?ïü zÄócÏðYÿ»ÿÄóäT×å8—Ìã:oßóÜx×'©gxΓêGðAÁ%äÉo‘w¡þ¦¹ÄΉ?c>üZòàY]ºÝº{{)xŠŽëU?âßí݇­ß§ÞÖ§éGÀN§á§ËO8>"¾ê–擪ng{^rœ,F?Ë{Šêº ùGü4uAøø1òqðYðKöÓ%›oëzàæx^þßûÏ‘¿ŸyhÌHžŸ“Ïóž(æúªîk>W7ÛÞy¿µÎ]u׸^GUuç±åœÏd^TÀ Oe½÷öÅåš•%Îõ¹Ã/¥ ~p¼ˆ¿ƒ×нHã3çO3Í+ºnã~oæ$0‡H}æÓ‰÷™}豯–nõ p8v¼ 'χ¼)w^Ús|U‡£žåùã̧Oó¡'rJÖü·«ÊÅ<ñºƒyEŽ—î]ÚãÙ¿äzs$¼ó½Ó|ó‘÷“À×WÜç¼[:¿bùS~Èñkæùç¼qñÉumOÃ<<þ{Æs"΃©žã~pÅ…Ä{øy÷s1¯Qq¶ë’'åwügp88ÿ£žŒÿÏÃñ9q„xZæY‘·ö\yñ®9÷‘Áç¦Ï^’ü®pœy!®›§ñ¶ó® N?ï¹î×mqü€?!®GÂãÞÈwa§¨G·øÜv¾H¾]ïE|îúyfòÈâÍû}à¯Ë/{.¦ø©äÓÄwŽù)²ûÄËšŸa?ÿŒ:”ùžÌsž2//ퟗǛ¿&¿…|&7ZºcùÓ±\¥å5öGÊË’ïGÞÈ7S—Æÿ©þâ¸Î{3TÿHöi?«|‰ÖWóI…oÈ·ÀK$ÏÁœTê2z¯˜O+=¥® œ|“ò´Öì!ùUòÇà#ù­x¯Eº¯.Êê3`óWg´ó²ÊÇ*^.Rpžžü)8Hx ~NáÏL_:Ò~Ò<åo$gEö2›Æ¼áSòØuò;è¸ù'"λ3ÿ$wù|/xä=wCù Ï3R]PyÎ8®•œ¸_ýp·£z^üƒúÑàׯsé_RÜ!9q—â(ñâ\÷b\­x<—ïQø—üñŒãÉ1òÖƒOßÞ„ù¦Š/¥¯®38//Þ y ò&情ùõ9Ðo!=ñ=:ÅÜåן ·(Žu}.¨3Ø~’sß*óE‰ßƒ>HêûÙ´[5¤Û ®‡¸/Eç¯ú¤ëä7Ðsãõñ“ßQ|ïåN–=Šýý/â y‚¸ÞÊÜå¥É·7sÁÏä3K©ÿJÞø<â(ìý”î—V!yõ½ gá|wæÊÉ>cÜGžœ8€øOúçŸè? _šÎ»ù9ÁÙæQ´h4õ…’Û»ù=óà§ËoJ^ˆ¢œïæTr°ºíuiæO¨.Kž«Èð*÷¥}©~náž(µOŽ‘ˆr£*¯•¯r“ãUxŸîeþ­òž§$¿¥¾ÇÑÒwçe©S)N!ÏMžÑ¦>ï=Øšg¡Ï‰rÆõìuùêîq^_øI}õÎg8?©ïW= y³ÿ¦ŽN|Kž*3—„ßãzüXx{Ôˆ£4Òù4xPàwp-qÏIùzü ÏEú¤9Ž‹¸Ç°.Žüçöt~!ÊžÿNËÏ–Ügû ž’?ŒãZñŒÙoe? ¾JË sœ‡ ¾Êùꂺý&ïŒûèÿþû^ç)T—Œ2ÿ×1ÃïÎ ýùVà<óçe?˜_ÿ yçþàM‘—0ïJzÔÅcûªç'O„<7ð«Ô ¨Ë;­xÈóS÷%NT ¦¾çº*÷?Þ~Az“S¶Í÷ÿî8C¼Ë(ÙÐè—ªfqþŽ/‘Ï4ØyháMæ"?¿3®g¦ó‘Ö+åÌ„× ´ÏEzGñ)xNõŒ?ªN'ìû\Ì{SŸ.þÍOü­ü.÷’yÔ÷/uk±Â¼6ü€êÿ±¤û^œáßáû»oH|Wü-õñD}Ìí Ï^q¡ÏYòÏyëÔwÇyª—’§b®;ù2ñމã·ú^õ^9í_?톒W9O>7äœ6òê©Û£¬K·?/éz4úLžû¡ŽCÜâ9ªÿ_„ÝyØ·sµ>þgHÚM¦ µ5Øj—ÆûÓ@íTh¢(v©Ð ¢6B“Fš¥I£¤P„ ÉXæ™ÇcHȘm(â×þ~Î×y®ûèøùç9<Ï}>×õÖ:×¹Ö:—ú–®{ò„òêü²ïÁ¿‡±.üýpþïÀêÍà ùàðŒ±ßÃ{Lë~*ýIt»ŠûÕ¹:×±Ûµïy|??:äE“‡kâ·j¯;ß&õ\øæô Þ»®·xÄ=ð\â0}¯§¸O?Äÿò‰ŸÊË$¿W{%_·ø…—|æ¥øÀ`/ó¾‹n?ñΟ½à€É­ß{Þί{Þ©ñkõ“—PÏ%nNéßËgÒo^fëŠÂC5Ï£^¹|PúYõ¯7>ÍÇ7?ÎÇ&/î‹÷ûà­«¾º~eþoù¾›Ú#¿;²è¦ÏŸòª/mÔ<“|`û£ÒÏ‹ŸÃ»xžòCò…òŽæ¤¨ƒË½K^©uqž'üuñ^ðPûÀ¢5ø³é>}¹Ïò¯©kýEìVû®ä!Õiµ%ü?ûºèüÕ·{ÕgÏÀ—¼yø¡ò²/{×›¾é%«ùåÌ3ÖY} ý‰àou5ò:òÑS…'ú}ñ§^ Ooˆ~õ´y¯ä[' ©;T¯¤ÿG>ÍyhýEêÄìKê[†~ÜôóÁáÕ G‰ þ¬Àã]ØÙ>_ø=ÏÝþ7ù£ìWóÎY?÷ášËßüMžþ¬Æ íCLBû’n>4}S‰÷†÷R/fݧþ¨y¡Ô¡”·iýnüqâÏâñHøŒÖoâM:7#u%Ö1¸¥x‚}Æ×Ê׈ÏàNø¤çj—[w´`ñqÛ,{àÚ·Üx{¤ûÙ:—øæûã7ÇuSÁM“%{ÿÇáÇ>q¿™?>ò”Ó·zçEA='>Pýû¤O‘Ý­ßã¿ÙàvùWϽhñ«?»èa®=¤£$¿ª¾‡Þ¼«¿”=Ãçµ®&<Š:~ñiãœ#÷>óåñš_UÁNf_ê7ŠKR'âsÅ'ð4û^q¬—2ÜëœGç§s`ÃÇÛâ'åkkÏ“wÍÅk_mê†÷Sÿ,.šÖŸô½ìcëp逤¬8ÎqOÕ‘‹ÃóœÉûMŠ;c'ð£xi¸7oÛõ×;îúÐá¼æþ°ëÉs–·õ§u êð½¹7áÉZæsàÆÖ«:×¹í÷Õ»XÝôñÂq‰û‘¾”ÜëÚ#z ³ËéÏyÏÊÍ·éj¾>ö0}Œ“Å;žøÄ+_uMó:™ß<ä!‚cÔ ÖNدÜcÏ=Î/ò{œ–~¬ò…x;þK^оoº©çȽügpƒþ¦Ö)%~ƒ«çbŸb÷Zo]¶ÎÅM}ºïYø´S¯¿k˹åØeþ6ý[­ÿlRâ5y¿ÇPÏ›u®ÞÂ4žò0yßöé¥ß¥õáÏåE.þÈ »ÎÝèk[R;ì>„À¿,ZëÁ眹æéƒ_KÜÇ“÷HÜÔõ¨®Nâ3õÜò£úfú¼éÑ÷Æ»á9ߛ`?ô¥ÔžyÀ×Ì=¾~¯<}òõ3òút:Ó7Æ/³Õ‰ßc_Šâ»ŸÓ8µõ‹Î¹|®¼ž|nõ§éá?¶N?|JæÙ üâ½ë‚›ßmü~pïâÝ–¾a»%·O–ÎÙôÐU¾ñ¿tš_[4³÷FoüÝÂÉ’·Þñ¸[–?i²xý·¿çáY¥|¬ûÑ÷ÛÿÀÍVýØ}ÿ¥ìŸ|iž{é“;ýœ­ß5Y²ÊÏžóƒ?üÓ>èƒ<ñ¢u{ÿ—~åoŸ[ú”Ýü{ù¥%¿]ñïßçîϧI÷oÉÖ 7;ù#hÜÆî®ð«þãèSþ­õ0êî¿ÅþZýÞ+÷h…5OùÍúOþsã}|Õ¼Mp²<…¿_tð®Ÿ8ãA_,ï°dó9ë¼õ°]'+þöAk\ñŸïêóº§Ö­ŸŸ:0ë»xÉ›Þñ½y[•ϰïKîxÑz;]ó³É¢õ×ùÌI{Ý2Y¼ÏkNúɇ_:Yô® Îüëü?O–üðþ?ÿ¡ÏòIâèœÃV]á ¾ðÝy ¸0y¤òãüÓŠO;ûôÓºÅdñò/zÔ÷vƒ×,¼ô™ ¾rÌ]“6»ê««ÞðËúë%ç?è/¼h~ë7øg¼¯ÿoŸ­ú•ÄWÑÙiÞaÉi?ÞëåGNä›jOÓ?=Y¼ùZ/^zúÑåí_çÀþ¬ðç«ÿÖ[V¬8ó§ÿ9ö¥Ç x;÷%öp²Â6÷ûÄ ßÿ¯Ö!ÀGéw›å?ðKã×Zï”ó·âš×¼ùÕ¾£üÒâ#~wþk¯{xy@xß>À-ÖE\W~"?Çn.zÑóžô™»'+ä÷<×âÛo}ÿY[­×ûGàä·ð/KõoD×Ê=ÁƒÒ½Z’8ßéçØ§EW?èôÓ/|fÏYëÏ/~ÒŽºuƒç×ßú½Þó¼·ul]@òªýýôYŽêøŠ;ð3îì\ÔîÍYëaßyÈd²tæî9ßg¿ò"΃ºv÷§÷fùK¾öùÛËxN÷¾ç7ö*üEŸ{åÎÙkÍ·\6Yò•_þ½ý¶÷ÇïÓÉYñC—¬þ÷*ŽUϱd·ÇÝùëoOZ?×8eòŠþô¿N–îø—wíøÖݪC NÂ÷ÃÉ+„÷KßVù/çÿ빚GËý]aÇ›¾ùñïþóüOz_öiñžO{äV§î>Yxú«_{éÊøeúþÃ~9Óz¬ïH]óóñ—òü»s¼è+§ý×üƒŽ¨]X1~¤}$¹gî¥ýgçùáÚƒð—KSa}øUç;u`=ÏKN¸ò„çÿ|×ÉÒ½ÿmŸµî¿õdÉâ;VÙåü_ß÷Ûmùå†ß©=è½ OG-]ò¢ßÿfû«z¬ÏÂ~±Ámk¾¿õüŒûîþ,Ýlù}Žßg¦÷TœqŸÍn[e­'¿¤ŸË®ˆØü€sR-õ­{M\Ñ<ŒýÍóö>‡X‡æaƒgWX|öÊKo¼t²ô·«=n½½Žé{øü%;þð~Ï{úí# ïÔnÇî-yÌœg¼ü oì=,þˆ_¸ÏŽÿxñ·¬Òþ>ï¹èÒ_õ’;8¬»8P}Œœ;çÕ½]áÆÛ>ûÉã¾8àšäOäcá ÷j…ß®ñ®¥G/œ¬œ½è´­?±ûÞO©ýÜ?ü;´tÍcz雟]ü¨OºûœÿWísØ ûU»ûU­Øóâ¡Ô}.Ýs•žôÒ×öž7w»¯‹WÙs‡E_:®þ…?³‡Kþ|×^Ÿ¼]ñZóI‰áiù9vÛ{ÛŸÅûm¼ùý6zNýØŠ›qØÛ×±ô[§ö‡ëέ(®Ì}´Náqkïü|q|ö±|oê&ùMv@¼sW\Þw…ón»ý=÷}Hí;ümøøËù£3"~â§Ü{ç¡ç3û¹÷ðW÷5øI> ÞgGÚoœÍÖ¯ŽòÄüI×Ë=€Ãò¹Î%?PýVö/Ïéó¼?Ãn7çüZ×ÞŸ)þn¼Ô:)ùzn©Ã°þιó¸øÏû¶ÝA{·nÑ9›Çàeƒ_áB8lÉÇϹbÞ{?>Y¼Õ7ó£›N˜,~ô^O¼Ï#Ñú"8€ŸaW­sâ•Æ·ž=åVÊyk’ϧ?Àީ׳~£¾Òâ~|ñ»v½ú˜',(n·žâ Æ‹Á7öÛ½Zq•kŸ÷Ñ£ÿ«û¹ÂÇoÍgþcõú§þ\ìœ{E¯AÒâóþþ²Cßó¹â†ž8,üdãÛ¬{'º÷ìký|øë&žmý\žßy`gàûÅ{ozΛ_|éàgÅ)‰Üúö(çÌ{4NÌ~Œq­uƒkÙKëN¶zux¯à ûê|Z}Ü‹¾õû-üÐűpcãð¬£ç]zðYW|ç™o(Ž…Gk¯NÀ×ßýˆ÷ùƒ¼‡z°âþÎÎ:ÛÇäÕÿž¸Ÿýƒ àKû Âp ÿ÷/ພ±ïürê÷××Ï­ ¯–:mõ@ê"–¼óü;V_é“¥[oôß¿òUý+þÎïÁKxšâýøuõ>޵ïíHÝãâÏäé3ëx-¼»dÿà:Hò¾g…×þÄŸ9~ˆG²žö¥ñk>Gâ½Ü“â6õá5á%ߺñ¬w-}ðÀßðwîó ïZúý×ýþŽá{ãj¿ñQê<ñì^%~ª÷FÇ’~§óÙüzî7ÞŸ½gÖ_Ú¯øc<­û^ÜŒ—›öƒo–G‰qnÜ?¿äIß¼ë¥ÛMÿ îuëþüî'äOá xk…ÉÂ}ßüö9ƒ?É}/¬°õ‚ÛOZôÑ™.}ÀÞqÈ®3¿Ûÿ°k²Î«gÎ9é܇œ»ÿÇgþð¡×üh‹ë~ÝyFégkŸ =ïËvyá ë>ó™söüì6¯X­ÖñðäÕOÙyþ2u÷ýÓܵóßsû×W¹öG3±ïá[¯ôÝ~îU—ÿ`ÿï-žßy›t#^¸ËE_]¶_.s‘[wê¹7>gæÈÛf.ßïù›ïü÷íšwÓ·ºõþ¾¼ë5»|⽿YmÁÌ xÐí»¿væ¸ËWZë-GÝÚßûê5',;wÝåüü;ÛoºÚ7ÏœyØËO{ø¿ÿ}æÊß¼n×·l²IçÆ\¼`õOØoÓ™eŸxô—7>çÖ™å“×Þ:gççÌ\±ü'¼ú¤»äóú—dõ/Ò1Ö­Þôì]6¼`½Õîš9ú’®xá®Ë:‡Ô:ÿé¨K?¿ëJÎ|òÿäxÚvæ¢ÝW>ìž¼pæ²ÉC>rÊ‹º®W¼þ‡‡<æß:gô_õVþ2ç’¿úžËf¾ûؽ/Ûô%7·^8ûן¿pÁ1«/{ùæOvæ]{ݽÇ3:sÑÏwöþt`×õšo}`Ûûÿ×EÍ£û½Ë½ê#NÞw­Î)¾îy/sêïè矹×õ¯ÜïûÏœ9ý‰Gð'¯0sÅ×®»rÁª?î9æ•eÿsµågž[õLõ!ùyßçÿ3`Ö:µÎ›ŸyÌ#´Þÿ¸]ŸôôÍn>çÈÓV]ÿc/ºOç¨úûè‹Ð)›õ¹Î…?é™\ù­gÿä¹ÛïÖϱÏt`ôÿçs»?~ÞyYvä;Wxÿ6¹lùM§üáÚ×¶îüêå=íQ3g÷9èiž}ÌŠO^áÊ5g.›»üþWù„™ëŸ}Û§_qΡ³öùÄ-Ožû‘ÞïsÞ³~ýû NýåüŸÝyd×ëô]þ¸á]¯ýA?ç껟û„OÝïQ3G,Xø­ú¾™o?ä/kïpðgíKÎoÏü®Ôíõïwÿ?šá”‡Îqíÿœ¼ÇË^7óÛƒ~å~+_Çôçþòì=µhò½þÿ¹™ {Ù×vÚåðÿ`æ’ù»~£÷mÚyvöñ7‡õ«=vX¹¿Ç¾™—wþÉwÿìWo:¬sb“œ9sÃÏ?öìo®×÷ÌÜõö›.{î÷^°ÞWœ¹ü®'¯¼ü´ÿé{³'žÇ}ÙÇ>ÏŸº}áÆ¼kæªßþç/W¹êU³þýÒ¼ýé;|g½Ú«ñ¾·Ú׿÷ß»ýeæK?ûþÉk¾ð]—Ü»þÜh?ú÷gý¿: ;ûìäò5WúîN/?dæœ ¼mÓÿ:cæœë\¾åfÏ\¶öÚû›íù¼|m/ÿU÷tNXÎ}?ÿ„ïÞ1ÿk/øùÌÕ»m±Ù‹>ô¦™ïÿǶ+¬ú“ »^?{ËE·}ú¶ gÎøé§/¸lõú{?yø·oûë·oì~äóûï£uÿ}ÿäw¼—{ _†¾;qãî3Ûîûù5ú~<çgÏŸ¬ô¹ù=W=÷'ÝxÜïûð´ q÷Áÿèù:ã®¶~íOíŸÎ¹ùôãs~Ýë×>uõÍZûäü\õÛ';ñõýÞ_~þ²÷ü|—íg®Ú}Ë¿|~·u^´×Ï9^óö8v›Cvÿá|}âË®þÚÁýšö3Ô¯ú½ Ÿµù#ö~ùÁÕy4—wüùüÂòË7_ý/þõÌ¥‡ß³Ï²#þÞÏ¿~¿7š÷Z\—ÏåÏঋ6ºõŠ_ÝÔûÜ>ØcVùÃgW=ñøâÞïѽƒ¯Ó‡X;oÝÇï?ºß³Î‘}uÞ|ÿŸ¾õ·«öýå…ÃÏMíUÿß¹Ïùn=nìî´moýøîw¾gæô¿þþ½/{ÅÍìñðïk,ûË¿èæâfñÂOXmáï>yIûìùoþH»æ¼°±KC<ðí¿þÊ·Þº×aW?¿“ß›õï×ά²ö®9«Ïþ—ö ÃÍ—üí­oñ§ÞúÈã¯ðo–}ù˱=áÕ¯úÏꤎâŸa}óùðì)»Í9ó³/>Ž™½¾Ó{4üþ v<8®sïòž³>Oœd»â|ñóñ—ýžâ¿Øëøë¿ö¾yo}¿6Ä‹Ñi¯ï1þì™G¿ãÒÚ}÷è° Ö_öÌG_ÛÏ÷ó£ø©q§ÎIÎÁáküdÏwþà¯üfíLâ˜é/ì‡þúçmðŽ'~ä#ëÖϱ'׬½í’£Ÿv);ØÏ9öe¯zû‘Ï¥/߸ݾ³“â’?¿ñs{œöo×^ø{xçO»Ÿõº›ß7™µž‰ç†û6õ'Ã=I¼rò6XïØ ÏÅŽó»žËùŽöï³p°ç»æ9;.ºxßÍÂ+p›ø¾s>=Gôy¯ÌõëçýüÿáѳêGÛàÕg¾÷±{>—gƸbtž†s•ýk|ÞÃyŸËž_þ7ëøbfÙÝ¿ûíÅ·;sÖ'—ïô¦;.ìý‹ÝpXt¤‚7ú÷çݹ|ç/ýÓ_þþq·ñ§­ù/q5¾cìïÆ|ÑÙë_tðÊŸ»³}àÖ _8÷î‘xÊœåî3>¿ñ+âº>½Lö:ö¼ÿ¾c8ïÑG`ŸþŽîχg©¿í=Šßħįõ÷èùû:ŠãË[%Nj|äßá=uÐôoÝ+~òÄ9?9㇛l×ßËÏø7qoÏcp7ÿ…¨¿Ï½ýW¸§þzüsÞëú9?Û|§Ÿn7 ':¿ì-»â¼Ã‰üFîwŸß9ºòÒ'qó»6ð±Cx‚øáêX\{Ôßý‚W?¡û>qv<5½/³Îÿã>œ1sèú›Ü¸WûF|¼1ë¾é³á%ý†ýÿo>ø„›ŽÛåï³ü•χÆÏ'f§ÝÃÄ53Ç¿}ÿ=ß²ÒM3Çì¶òs6yÉËËÁ‡ø“â†ãßsÂGoþ^yÍàØYÏ1Ž/O^kßÜyÚ==géã†ÿÊž»ÂG¯|ØÌ·zþýyýšïÿϧýçéðUíJÖ½~alg/_~É]Úî³øJ|œKwÆ‹1á{GønÖ¹€§ð¼ü—xöª9Ïúõ;ŸÝïgÛö9<ºþýÞSï‰Ûçú«ð;öݺÛþOé{z¯ˆÆü׈ßíÿ‹/r￞¸Í}c§NÝýoëÜ0ççå¡Å±æäáøIëož~Ê=ûŸºÁ¡³ì™øÍ÷ZÏã—~ø —|eêl™_¨_®ý:}í7O~Ø\_:Òú­ÌÄ3Íšs–ylòóþÆWö¹á’_ sé,éãî»:zú˜tô›U"s­év™¯Á?ëÛ¥?L—RiûMÒ_—>¶ÎëÖ×ù#ɇÀ«ú`èµÿW¿ñ´Ÿªº‚úßôÒCÓhžïX‘^±þyù,ýðúõÕÙÏê´çûÍY¨.ltõûV÷.z¼‰+ú7¯òâû^ñ ‡y|éû¦û/ëC…è³±ÿߘyÔîMêl†9\ѱ4É|æôãV'¤saó\æÏwNiÞ“NèÍgþü_ßÿõ=?úÙ%ë=ÑöŽæñúoÑ+4‡ƒnOõUô­f.EubÒo_½äè´u>Až—NdçQ'~ÖŸ¥l4×¢óLÔTG º•îUçùLûû÷ôüôíÒâǯÒÑÎk_3Ýéì÷0—(õÁúé´˜“B'Tß<;B׎µøÓù£'™|zuJ{¾ï}úÿÕë0G<úTôYõ[ç…Þ¯~æÞ³ô“º?ôXº±žÛr?éàÞ´Áï~ûäŸü¡vJ¼ÞyÕyø,u<ÅEæÀAüÜc¾Bícì~t¦‡yù}:/î¯ûm}ébÓI ¿^’u¦Û*®pïÙ•êÚg'Ý¢ê×ãÁ7ß¹ÑEG>úùƒnEì?Òâļ/½öýo›¬ýãçìòÌöm³óé‹îüdsTœgºøtùù/öKŸ¾˜õæÄ1æÝt¾jtF;g-õùæ.°ž‡nþ…Ô¿Õ^±ƒE÷”Žƒ9žæD空tÑ3ßÁ¾›óå¼w¾Oú¨éfw˜9áÑqà:~’ÿÖ'NŸþ§lýXÏνt®‹ƒÓ^œݻηf2W>ñâszñ}ÎÁÈ{°ßt_ÔcÑeâè¯ÀÝìLâÆA38‡pÞÝÓôCÍšÃKï Žb¯èí™OPýíÌ‘ì}È=¡÷Zýz™#C×G]ݰô]W¯D^ñVæ8ßš¸ ÎÁÀ»sîLû"ŸÑÍó×îwãT:AæˆÿŠ+ÜOóŠñº=—Á‘æ*tþYú1Ùßâ¡èȇ¿ú§ýå3Ìëɹ¬^YðVç.÷yƒ§ì+\‡7qÍ·®n½ˆü» ·Ñ=ï~åûÙ•ÎÃHœIW˜¿òtCÜ»Î_Í97'KüCºóÔ§¸­< ÝhõÑ{×öwÏ~Sç"ðßî~ žéþðŸüSçáÅîâ èßgîZõ@ÒGUûá>[WçH|ÌŸ[¯ú/óF2g¥ø8õütßÄ«'žÏïàÄËÕU >¢—®wttf<Ÿy£Õž%»X]ûÌï2Ÿ„î:9ºMúª=¿94Ö™Ÿ§GØy-æÀäóàJ¼•¸Ñ{³·ô_÷§s‡Ð w•|Ä0O8v/ú[Ý×ú™è›ë•ý-¿Ïž»êµn:iŸs·X¾Ê`ßòÜôZè(ãÑê?ƒÏá\xºóªÌË|.q9ûÈnÒi«îjô õ+¨[Æ7ú9ßÓ¸>óààMº‡ÕÙ >ÈçîŸõÄ7òCâàÄ{êè[óšÌ¯ÊÜ›ÎÇ6Å:¤±Wð ;dþ„u ŸZœÝ9¯Ñ{óóÕëà$ì|¿è×йKŸCŸO?†¸·ºŒÑ'M_IùütyŽè=ó3ôQá,ø\}qçrÓ¥S=as¦œO8C>­|dÎ}qGìü¯ßD¿þŽÇ¿9ïÕé4—&þÆ~Ÿ~›¿‡èC¦Oª|±ûÅoÖŸàkF÷Øy¬_Ì>F¯½ñó,à÷ÅUâ–ö;e“7=çÕE1–içÙ:gî'Þ|ú[Ù±úx(üœø‰]¬ŸÍüÝââØ]úôp=¤Î1ƒÏ‚ãÊÃdž®{ž?{/;7=:¼âwO*Ô>i<<½¿ø‡á~ç/ZÏì3‘ûÖ>Çοžò¨½ßæP–ÿ Îqþå¥ðGÅçâðàMz满O.sÄ£ËÚóœ3èE¯²ö"ûêžÐ÷”OeOéõÝôˆ§ß¸xÓo—'ç/Ä÷éßnÜßyWÁAâ ëWTW/óì£Ï—âùƒ7{îÄáâýŽxyd÷Îç¸WtŽÅêHÙ³â³ä!äñòtx/øßü’æ_Ãðÿ×ïúÞïxܺøƒúËÎÑŠ>huÊ“×Â]ò¦ø(ºªp¤øMHóºÙúxtvÏ\Ùô© yìÌ'a—Íßvþóýŧ¾æùÉŠKìwçx†w¬Žö”ß*.j>^>{ºÅCåÇËÓ5žû)ïá}átö g½FúÍ£Âã<?]þÞ¼šØ-s÷à‰Ñœ·Æ]ÑÙò¶Ñî\ý“æFÈ_ž÷Þ%_3GQÞÙ:˜³Ô:‚äù ù¸›þ>Ú¼ñ]$¸©ó†§}áµËðCó‰Ëè¨ÂQð^ç9²;ñCæH‹Ã7g^…9`™×Ós[|}Y~¦þ.ý”æ±vžQtÈñ¬ìƒøß=ÁÓªh]Ì·Èï7_Þ¥ó¬s~Øÿê¨ã©¢— ט/'½18|ÐûM~_}­¸ï!?ƒ—ºI=¦ù«™?æ|u޶yÀÁ5½ç‰Sð ì1½d¸¦õ ê/‚oʧ$ßÙùºñåU‚ÿÅx õFég¨¾,¾Óyiž,ñŸ9…êT›ß ϪŽ"üÍ€?/š“¨ïM>Çzˆ;õ™‡_Õ?ó÷ß^sп< úuæ Åo óz£G[}æÌ—6Ç‹¿cgGóËš¿do;7|'ÿo4ï•9<ðBùðä½ùqëÚù¸‰kFuG‡í#{Õ|@p0þO= >Ý÷ðÃâñíuß|Ö‘ë~z§aHê“ zÒx‘èþ²óî«÷‡Ýuü@ý"íäQªï¹2ðcu›Ã³V§9ñEç]%_OçÛ¿³«ì”uKióvìþBž—]¬ÿ ¾ê\5þ;õx-Ÿ“sÒû$“{Ñuß'4î χ…[ÌKô\tyÄ+p;~¡y¹à6qmý¼y+y.ùõrìVðFÏþßßtn±øtªÏ<ðÜñŸéƒê¦2/W¼õù¦ö°~ÄséÃè¢sãbŸøï¡¥uû%îç_ùýæKÕ÷Æßág;ç'÷_=|ÉÞÂQòÇâLõƒxJºbÑ,¿†’OÀ—‰s}9¿ü ¾Óü)yöÎ/JÞ}ÇÑmw¿ñ#±¯'Zœœz*ñ…¸Ÿ!? Gã݃øæñÚæ@duëš}°~x‘ÎñN¼o½áû]?kÞNê’‚¿kÇs¥ÝSûM· ÏèO´Î1õ‡Å‰™?óµ7És¨Ä‹á›ôa¨#T¯Î™;$¾Tg—ú¶Ys ¢X¾µóÛ¦|]ãú­»½5ïÆßÛo~K>]N> ®n\)ß»IçëŞɧ›ƒî}œSöÜýkÞ+ü‘¸¤x/û*næ‡ä3Ø9xþP¿ê9Ìîç'´®(ûcÞ4?¬N–“/áßÜküAyÿÌÇÃ×9ÿpüàœ¶"þ¤y˜ð·žó—8®y'|3üŽ—®]3—uÔå·“7M]Ó Ÿù+ꢇÙ8¾nOì#?ç>âAÕã´Ž9ç9u­O Q\ày›¿È}Òæýâ·[‡ÒºÅð\Þ?þ·ö§ç$öÖ¼?Ÿƒ×Mاų…—¡‡W1}5êñù}÷>jÞ&ý8Õ—›ê6O§mBâwºÐæBós=?ÁÉ>ϹOŸbó ­óOý°¼‚¼¦8ž û\þ|ê·éKÖÊ«4¿Ÿç¡#î~¥¿´sÅ?ðLyÏà38 ÎåwÙŸð­§M|Øüüë}ÕLjKã7êwš·J=>3ýƒ¿ ÎÂ_ÉOà7åå[W=.¿ÿÑúAõøù¸Æ= ßªƒ®Xç¿§Þ,zÆ}ÿÆEæ­Å˜³Â.ÃøIÏOÿY^Ç}k<;Oß o§ÞS\Ç®X?õVæ¼Ô.¥ï³¼½9¼áyÒ‡Ü9ð5Mu†ÎÀþàEÍËìþ±¿©¿õ§,÷E<…¿S'‡aÏé™è‡ïö¹2Žç碻¯Þº÷$yäÎ=lzâwq_ôÕù—â?<…<¼õ†3鎳Ox‹òLúß§vµv^<1²Ã=µ‡ùysPõñµ>lTWÞsÜgN7»©É=Ð/'_¤nÍz5ß©FzúAÄÅtŽàœÎMŸÎóì<éÆ 9_â!öªuÊò©Pï">×›ê;‘ÿJ<]uïƒou^[_žù˜ø˜Ô»Ô_…gæìdî\ý¬zvõÝ9×Î…>2õ:â^ñ\|Õ>¢ò0±“íóŸ.o¿+ïû[ÿ>Õe¯í¼ßØ#ÿ‡«TÇxïú¬ÖãÁâÀâ¡Ô«vx~¤k@¯½ûßþÅØQ¼3|­ê/knò³Ý1àåÆ[á-ËÏß;ŸÛ{ÍÎG¤q«¼˜¸ÒÜWÿî¹ÔSªw£K‰ã[ž>ÁðËÄN¦^(8©ñïò³Ö»ý5áåµí\Ñ9·Á¿ì˜u‹h¿µú¯òåYunåýÃä> ýOÁ_ê{äCè1é ^j¿\òµñ;ìÿR¿¿\>/uòÎê­{¿ô·Ww޶¼gîQqSâýÖý¹ÄÎcýaâ q/^:÷µqMó|é×윽ÌÅrNÕ³Ò­ÁïÉ÷³ ž.[á€ê Lñò0_%û7ÖÁ/—‡I}笧^Aüg¿œcõêÆÅ[æSW"|ûÓ>êÔý´ß'xÓ~Ýà&þÎkpêbšGhþ„] Žƒ3ôÑËo«WçoÅâjý<­Ÿ¿w¯~“öÁ1Ä«ò ÓüÃÐÏžÃ:8çãü#»ßº²ô!âáÚ»ßs¢Ï¼ñœ ñ?Û¸"~Mœà}Ì?R硾@|hßñ x”Ä=7ü~ôÁŠÃõ´î/ýÊú¢ ßým^ ö¿}k©ghŸ¾ùuóÛ2ÿcè“Hÿ +8KIûeƒ_ÝöÚ{ÁOå/“çÓa>Ž>þS¡ó|¦ù¬¡î/ù[üjõ£òóâÌà¾ÎËíݼž‹ày<º­ÖÏ»8ÔEÅ>ÊóÁÝðWu¦Âè#–WëÇÈ'ÇÕ/Ë»škd.’ú ù«à¿Ö¹5߿˾ू3Êê·ë\ÉÌM¯½R§`vêáð¶Á¿Íç‹Ý[õ»âYx̾Tg&뿪gê\³Ø«öw'/gŒjžRó-áÉŸŠ3âG›/H?dç¤çýðUtØKöš–gõùò¹â‘òÿìYê0ðtÔÙÊ«Ø÷ê›Ϻ÷å¿Ó_2àöàÆÖYEï¦þ-||½8Fý?\Z>‚ÿ­>Aúºåçä Ô·š÷fÞT⩞OöB<å|X><;eàü)Ýþ±ñxú}Ìk½0ýšü{óóö^Ì9 #™sSÿ 'ˆãá7ö…_snËÏè7*/˜ó…ç­kö›ßj¾mZw-Q~_˜¹Tòzâç0}c­Wiž,u¾ðºzéwæk«ÛÌ}¤÷/Îì|ØiÞ\|ݱ®+|×õN¿–z%qOë”Òãœô~Më2:Ÿ-óÁÚ×Ëná‘Ä[ì~×1þ]Ñ9bÓ–¹yê ªó—üdô…Ë¿É÷4®H<"׺ØÔëÑ×'P>ÞÔï!Î62ïŸ9…C?Eú°àÖÆá/Ú¿CÇ"ø z.Á™üló±æWw^<Ý!u=áõÄOêNá²Ì™mþ\dõÒ—JO|“ÖE°¯ôíÒ_V’}g'oØ:&}SÅíÓzÐÎKmXÎWûpƒsÅá¾WÞ±}4Á‘õ;òQ¹·±ãí»žU¯£.G¿sú)äõðœìlìUó·êîS·9ÄQ¹OíË='¸ÿí?“¿ý§ïuÃoïÿ¬?û³Æ›ægêÀdŽ]ñ¨ó¥ïÉz³ûÕ[Ìùi^mê¯jOÔàåá`x¨: yo?¼2ÔÑ%_ZÞBÝWò­O›âØÎí46ù†A/3}ÕË=fËcÐW {˜ý§õþ'þq¿Ê÷æ¶ž=¼„:eûÛºT}_Ó´ß2xCÞE^ÅóÃÛ/SïS]³Ô7Ÿ…w¥û€§÷»ˆoª{’þÎ~_òhüÿZú~á“Ø£öw¥ÿïŒ'‡³¢G?Ôg¥¾?ýíƒÖ§_µŽlz.»ÿø ú+òuúaåäÚï{ï>üöe©[ƒKð+úXåÁä{ZO’8¾~8yozeµ'™ŸÛ¾¡ô9õžgWß4q}qTêëå§à„œ¿ò‰p »æ}ð± æ>Ï©‡wȶî0÷%s[7%¥¿Ò}ŒÃëàå1øEv_\Ž¿o}gìuæi”§6¿‚hÿô¿»¿'«þaι<¤{,¿ê<ëÎø‡ö»Ñ1Êúµ\ýNò'ô¤«ß™|;Þª}Xá äŸä šÏ Þf'jo風ÛËükü–uoÿjê£×$Ä+ø=¼¡>«ê8ÈëºÉïð¿ÍÓÄþˆ³?OGÿ!: =OÁðª:¶q¾»ýUá‰øcu0»³7<÷…¯úÜ:» z ÑCS7W]ÞÄUê)àzý2x¾öµ¥îA=¢÷aÿôY©—Š}hü Ÿéƒn\x~UoŽ'j=¦>¿è¶©C+?L‡/›¸ŽÎ{%ïãç§ç|ÑÃcïª÷1ýœA×ÿûd~4{&:Ò3h»“¼Aý€þõ6ì˜øNŒhß7¿Îµ~C¾%þ:úC]ŸÖ%¦»ºKÁåsb·õ£—gP§\˜¹TC¼’s..î} Ïo½ñp^y}º꘢¿ Ÿ¨}Šø‡Ügýöß¿Êü«öoÃ=Õ=N~Š}å—ª|%®qoªã<†'I_òð©T¿ÔùÛy^õò7¼á­:|¥—µž¶u¡‰×ððló*ɃUçFýIê Å÷Õ1LªuÀ1Õ;Ï9ª^bôt䇚Ϧ[WȯµÏ4zžê9‹séŒEŸIÜÖú ºû©§¬~(û|!^f·ñúÓäÏé’°s­ƒÎz7?­>"x?ümu>jFúTkÃßeàp?³Žø–ê?ѵPOœL¢úö;ü>¡õgpvü¸ø¶:9éÔwÕø:ïíÜà©Õñ[úv¬¿bámq Ê9ÁÊÙk¾`«Mýô}ÿ·úóø ç_= \¨.DÞN¯x@Hõ<Óo¾º~Aùüyušô¿§®ž}T%ÿ§oAcã¹{ër”¯‡á%Ô1ÈÃñ‡Õ]ͽožKüGç-ñ·¾‰æa܇àkõÐì{û€‚[Åë³ê¦´ÍüŒœxÙ9†ٻΙ×g³Éâµ×»íEµ§©¿k™ý¬ý Ÿ†7iý2ÙäQé8š¿„×—Wü€g¥“<†¸—Ž‘ç3ÿŽ.tõ’—,_šýçÅéÍŸúwz*t‘Sw#_Ó:øˆ^¶|Wç±ÞwΜ‡>®ü¸¹CtDÍ-„«^Ï×þé: :áWÔE”GIÞ¯†À[WÇ?ö]^Ü|o8Þ’×ë÷›[}jvXÞòº9»}pÏwÝÓ|’x…½7—I>¡}áÉàŽÖ³ߊ«w¤È÷§ÿªºñß­çoežÓX‡Þ¾ªË5Î<2ýÇê#á$s;Ä?êŽ[wAO"ë .¶õÖ¹Ïæ©kÒWZ¼“¸P¼ßÏ~ õ#á{ø%ûÈÿâAÍ‘²tª›>_¿¢Ï1Ï@Ý˸nRcõ®‚Üù/:œø€ÖoäáZÇ­¾^Ù½yý¡^$÷Q•Å/Ò3²Ïž ^Ð:ZÿÞÓÜ«òbú2f.I×Éœy÷Mý¶ßS‡b¾ºsl¿ø3º\üœsëóåMZ‡û`.™û_øÜÑ< Ö¹÷Ö§~.ö¸¼^ì–¹{êØÕûÞöAç¼á­ÜxRœZ}åômVG?÷ŸYþ6~_Ös‘}Ç«wÅgÖ$®ÅK°×Ï•øŠž@ûõò'»}ùs¯xÁNOùã÷U×-?’õ0ß~žþGg7ݳÎ_ˆnþ?|±<µ}èó†.Ÿ Ç«C˺zžÆÝù~ùjs3åï7Ÿ+¯ÂU¯9z,öQ½¡çjMx©Æq±ÎWëåÁ²žÎ»ój¾ru‘¢·ÍŽÑki=IΉ}h=°¾T}%‰#Ä™Y»Å¿ÛG¸Þ9ÒgÆîys$Ûÿ`Î@Îkup£h.©ë¡ ‘õêú© >`?ñUâ":ÅxùòD£¹zÕKà¿s>åÕµ¨#Õoè‡o>"v£u°9âÞê•f¼»ãœñóü­Ïç§ÇsÕÚO—ç¯^|ò´ž[üé¹èÝÐW‘ëóÅÿ¶_6v×nO¿iTo6ôéë¢ÿ>÷¾Î™üݸ]禥oµö-yx§óÝ’äïÍqîªû–y¯Ñk[ë¡‚·Gõ&Ã~ɇ§þŒ½×Oƒg‚WÝËòúÝÕרWH|ÁÏö¼Éå÷èh;çãþS¸ß¹oÄQì±ó~¯ö±q>ýsÜFõšíÏÉófzßw\ïÙ>ÅØÏkÿÅçí¿ ^n¾6q_ç§ÄŸ‰ïz¾È¿ÐÅ2ÇÕçUG˼ ýå¬gñJÎküaïEã¾ðÖ]/O•{æ|Û'ø˜½ný%{†ŸÒ,^Ã?éÏÈ:XWqйàp»ïüøÿêåÞÙ'÷Ùß7Ïæ<ÂA‰Üçο:e÷ØüqëÁn›Ïí^×åûì£øû¨uÞüÌcþ‰›àùÊâ»èºŸ*O›¸Åwˆ#:§5ó@¬£ü'{Ì_Ywû'Þ«þÞG?Cß…8Ô:_°ã¯?æ>Kk·í÷•Ï^åÏÝw§î£çðîœ)NÔß:áQ=yû*‚ûñ5t©àãÎáM§ùæâ¦òJ#žîÏGݾpãÞ5ÄOæ{¤Žoƒ_i}Jâþ—å'Ü'xÔúãK=\/ÞùË¥¸á¤ûïTž¿M'ÇϹÇxbvöú­wÌ£Ÿ÷·YºÅmÁžÛºVg&þ»ú‡tÎÕóå|·®0ÏWü–{d=¼¿ï»êòìÿ½ÅógþtÔ¥Ÿßu¥ {¿áE÷AüJ·Dü ¯•Gˆ?åßé]º7ÎWýCüVu?ÕiÅ‹Õûˆ=…{ðpÝ7ºîêCÌÙ 7ðó—ä©[oµüå ‹£è°Ï^¹ë™×?é}k—°þ½_ñã|¾F¿oõEÍK|Óúoù«Ø©ò`‰[:g†þoÎ/}Qvˆÿ‚ÇôIt_ÍCæ×Íi-îä¿{¾ô %~awùõÆgy¿ö³¨» ®wn›ëŽºøkç<ðæáškûšçì¸èâ Öý³Ïx­öW‹'³OÕñ•I<Ç_ÖZWóŠñÐøjxµqLì þ¿:ɯÀUâIöZÿiý=èÄEp‚¸êô'ýÁCž¼BçÔd¾aó'ìoçé™Ç3âƒñBÎ…sÝÚŸ9hï¥_îùbgZ—hžtÞK¼yÍ?®þÊ#¶=b°K‰+¼·xF<Ï_íCH½æ™~þ±gs½þÜŸ¶ä‹?ã°î;\E>Íu©~¤º8÷R~-º/]/q¡ý.ž÷?ŒtwÝcq^nŸÏùÝþ‡]ûu^]üZ={Ÿk.cî=B~µúÁ9ßpoõÔFýáîõ™‡½ü´‡ÿûß›¿„3øaø ¼Vî­Ï9ý¯¿ïË^qóÀóˆG¦÷­¸·ïen‡9sÁ“­ˆ_ºlíµþö7;³ü;ÛoºÚ7óïÂÛDg¹|úwÚèÝ7½óžaax¤è47¯§n½ýùOpèh^Qó:ã|ÍOß»ß 3g_0Ì'Š”§P¯xÞo¾ðŽç¿k‡Ö¡p[ù~ý³‰ØíÆá7í·{#¿ì{á)öB<Ð9Êò9Ïžƒ_unÙ!ø®ù¿?½wÝ_vÙ½g7:(÷Þ÷ynÏQ=²Ä»æø~<±û`.­<²÷wÎz¢“zù]O^yùiÿÓça'ð¹î ¾U^°|rðzê{®wä|øþ)_œ:%uÉì¬}¾ðY›?bï—Üx"q~×÷ÏËV<üÂWþi¸OßüÉ–o\íÒÁîE†¿­®{î•÷½êÛý•o?¼ß¯ß¹gv~WÞßú«ƒTgõç5ÏxÂ’·7óç7~nÓ>ðíâ°Kþsµågž[íˆþ|ylq Þþµžì¢ûV8šóÐû‘|?¼“uxäð*Εuê=Î~üü?¶]aÕŸœÕ{ƒ»|m/ÿU÷ϳCã9êà3|¢|¸…n…ó¥Ï_ê’øC|sýCâñ“ùOô$øÇ+’LJ7?7šÂÿºð ¼=TuR=¤àŠï>vïË6}É ƒ~Ƨþ𺵗íØüÿ]?üÈtÎRøQçÖþó7òTí# ž*ÿœx4ÏB·Ÿ«>UðB|f.„¸›î—çLçÀwç|àÎ:ýÎûüú·[ö÷«{ &¿Øyy^ø•?s_Ìîtþ/Ï\ùú5.yó[~5ð?éÿ”÷:gÁ:—o¹ÙÆÃ|þß¼¦ðâ"ûuÉüÇ]¿Ñû†:ÿ=÷“ùÔÖGÜÒ¹4ìGç‰ÆÏ•î\!N(þÀ[æýà„k·zö¿ß÷—gõsÅãì‡ç·Õý ߺwòŸâö®çßð‹o2ÂeúÔÛÁ»ð„ûzÆÌ¡ëorã^3§ž{ãsf޼­xÓ{6?’ø‡‡÷Oøîó¿ö‚¡Î ïj.‘s|üÒô’¯¬¡O ûéùÝóq?=|fŸŠ«“G¸zùAO{ÔÌÙ}åIúžî·ýeG½Ï²ç~ïë}åÀâm8©udtÉã7κå÷;nsÄ–µÛÎ^Ýû°_G/Ü墯.Û¯~îbЧի'>ä'Ø yÊò8÷žÛÑ÷e/ô½ªÃºðν–¾û5C?Aë·‚ÇÊÏ'/ççÔA8W­¯Q—•øσ÷2ðìÁÕî/¿.^æŸìOñXp<üW}Á‘¿×ÿµï—ÞUž>åá™>|~¯º–æ_åyà*qºøB½ üÅÿãÅá7÷íÚ‡ýàØõÜÆ#ÃKáMÕñÐOòìAuGÏZû‡ãMü‰o…GÙö¤8Ÿ=/Å?ׯNã ÙMy¸ž®þ^ðÿ¢þÔ÷:Ÿêü>ˆpÎÝãÆE¹÷çlxàm›þ×Åø&ûŽ?ö=ì ^8~pÐe–N÷Å;97­?ç$.8ÿ=·}•kTÓùÆ×Âiò`p{Ï\Ìß]pØ0·…Ÿ4çÄ<%/¹|§7Ýqáàÿùñð*êãœv‘žþ?ò+í—ÿ•Wõ%À}îõ/?Ù{~¾ËöõCâ³ö³Úo~9çŠ/¿'?{»ü ¯yêù?úú§Ï¹”W²þµ/ñ3pcëÍg /¢Þ"<¯8Y~ÖçÁãî[tÛk?ðT­—Í9TgR|óÁßâ|ýQ—ξ‰#ݸ¿m|̧¶ŸÈ\’·~5sDñ>âx. Óç÷œp…ø\~^¼T1ÒgwŸ¯Ú}Ë¿|~· Ÿû¯¾`ÙÝ¿ûíÅ·;ä§ø³ÜëÖsÞ»Ÿ ëYÝLuÇê:ôÛeýàÚÆÙáIÚ•ÏË™ž8Óþ8§ø@÷ .Âkáéñ'pƒ}e¿œ³Ö£fñóöïÃ?~ÿÿñŠvC¸º~ó•’…·£'_œÉÞù>ü·ºyLxG¾N]ª¼ðLu*á ñ¢ó„ßoYýjâzÍSÅïõœf¾1^Þ¾Ó—êøøÿòEùýÖËdN¼>~üzñ~î‡<\ý°:ñðKÕÉüªê"ç=Ù'x·ºLúcs¾Ù_öHÜDßn]"ý4Ñû¬Þ@ë¼ðÜ£yðæ›É‹kZ'}!zÒâÉàˆê{u.CÎ3upĬ¼v¾G}lçé¥.¹z…©×ʼί–·kÝœÜ9vÙOñ¥zyëöAЇÖO—¼syš¼¾¼ó.²ÿü{꿪ÓÓyâ±+™kܼÜi~5þµx%ö ¿@¿Œ$f~ÀIŸýðV—¼ì~õ¶ÕÒ¡Ì:«×Yö‰Gyãsnê2Ò7O÷ÎÉAï;é¹ëÎêcoŸptÆÄ)Öþ‡gèŽè·‡Gñ1Õ›HŸ`u#c7;W/ºî ]ÎÎËNœ„ßm½“s^‹n½¡ú“ì·uU—îùü\¾w˜kþ´û–{QèÐoÆ?°Sü6]k~©|QêžñFì?ݹ¥ú£ò|KV^öo]z}ãùXü(}õêùÅ.°[s¾Õ™»×~Û>ËÿV‡8÷Ž_µÿ­GÖGŸ÷„;œç Þpà†ö¿Gvn”>ÐøqïÕùÝú¹Gó§á~Ïë®ïgÄO‹WàK8¯ýÌpSþž,/*¾ÁïÄ~ðäÕOÙyþ²îgûYÔƒg_ÙQyDxQ_*>ˆNÒùÃyîÎáNžO¼ÐzÝð,Å¡ñö —V×Y¿cü ~ ó¥Ã3¹ÿxnëW´ŸžžAì½ûé^胯]Ýô\ø£q©ý‹Â[ê,ðR­º·yëªá}ûi:§/¸Ký\Ù{GoÁ«©=øë˜øM™ó*/GoÓ½t^õ§™ÏG7tÉùúÅ /š_é¼Uç4ç©s†c—:ÏBŸ[ü&ÿÅ>áOÇsê§OeĹîSãdó냿Õ)8gâÆÛñ‹õ£±Gűkî7×zSõÝásùÕöõ·Wg’Œ½æoñ]ìž—_W¿Ì_±{òàKseÝ3u¸ãúmñIãüÑ|köOœl_:×*õ+úôZ™{,Ž‚7‹gÙûøëâ‘ü9žÓÚ¸ñ~Ÿ7뎟oÚgùÓêöÑ—Ë}ôžÉ/Tϼú~æG.G„×.¾ïx/v¥sKéÛÄ?ËÕ?Ñ‘£«­__Ÿ ]ìkÎEãT÷Ûyó½êÅô/ÛwxÖ=I\Vœ‘óU}³Î)ÏŸåßœ‡àVûXÜ™ÏÇ?»ßã¼ <èyøpÜ×QݨĕœúËù?»óÈÆ¥òpì߇OÚ¿îçÔ{ãó;ÿtº¿å1œÇò‹ây÷(ç±sÈÌýT_~Óû6|Ôzƒð7Î?R\»ï^•g0×CÝ œšsÄ.à‰<Þ¹ybshèÖd½ñø—áÜ›«;à=sðµGåïèã•ò>öS§³G~¿zÞÁ5ââÆgê!ÃÛŒôGõüÆï´/3øßþ8ßí§Ðçj^~"õ¼~¯ú;úsN:‚îAö¯úôàZŸO§)õZü¬ý1Ó÷òpøœà¬ú!ü@æûП4ÏWÜi=ð?H·+ï[^š~ ÝÃø©Ú=ù{y¥‘­]PG GçÜUw€.Bê¥ì¿¸ Ï,–'qOZ_—Ï«CÉndzŸæhÀk¾O¹ýî1Þ"÷±ºò‰ äÅ;/ÅÜóØiú®žÇóëÄØY~Óºø>ùq/;\ü*®Ç›%.Ì9í\ó9·Ý¸ãêϼ}ÐÊy‘Wê¼ìì³ûÔõv®Ìk¡7ò7p{u=éïç|ËŸvÞ?,ŸîœÂó± tKéݺ§ÅÑ™K+b]çñ\‘ò»ðcüè8ßá~ôó²~î‡8Yý@ëèõ#ÆŽ¨[ƒ‡ðKú»à:yóÔ§¨¿¯žš< =šà°ñ}æÿŠKc¿ë¯ržÙø®U'ÍŸÃ òœêóà~x]]}”SsÛw~·Â]ÕIiNì€úyÉË_ÿþ3×?lnã-uaôÑäiååÔ;ª+OÅÇ©·•Çõ>ê[ÔG·n3ësìË6^õö#ŸÛç“w-®þÔÆ?œ·Ç±Ûú°û—gj}£º÷Ô87Öݾù9uyâS8EŸúB}@ÞÏç9GøsuEp†x§ºïÁ=Õ¡g¾;ùYyÿQ?ÝЗ”¾(:7íVo¦¯(uO­‹ Õz»é{Ÿ›ºÕÝÿ=塵Ûã:ÅÖƒ§nÀs¦ß¤ön/áË–O^{뜟S»Ñù.ÁcêúþÉ7Š«3ßx¨ƒ ŸÈߥ¡yu]ísÐ?®^&}&§îþ·un˜óó¡>V¿Zò'ìuÕ_Óþ…Q»Þ:‡ô9gíç ζtËé[xOë!ÞÃcTg`Š;‡z’Ü÷SÎýðg®ºâ-ý{õéò£úäÅ5­»Ñß»¡£}ù©óñ~ê™Ô«ºOÕ Œ]T?íÞ´oF]Pü={Äþù>÷Î\OùDçÁýósòuç-þÔ[yü5ÕaaWÔy°'ãzQõsî³:NþÊ9kWôÐä#Ù-u¬íçT»µO5ç0ý(Õõn}Qê ÔÛ[oþ—΄ý‘‚ÇÄÕQ ^ÐW„WøýÕGìpÐæëy€ ÙOëî~þäáß¾í¯ß¾±<‰úB¼(ü,ž¡K’¿ç?ø#ç.úeçåòå—Üõ¡íþغ öŽ_WÇ.©¿Ç»ªwÄkµŸ‚®lâjç…ñÿíGLÜ)Ž<{ý‹^ùswº÷½ôÄñ¼ê(á=öCÜÔ¹>Y/uIü¿ëž‹Sõ‡\´Ñ­Wüê¦Ï ¼vðýÓ¯Ç_µ,÷Öç¨OdO[÷¦3yT¸´}Eé7²o‡;ËÇ'.V×™ùÉõÇü…{Û}I=”ûcŸíû_±—òCì˜~R|Bîm÷¯ñ~ð xŽà麶ï9ç„¿a§Ô7ãoÙMç^\û?Ô[f=ÆóPàåÖ3Ç_¨{ÇWáƒØ¹ãv}ÒÓ7»íc3—|è5?Úâº_ïOtž¼æ>W÷¹’oêáÍÝ¥ï>šcÛyãüaÖ>éyÏ:qíÿœ¼Çˆxƒ]Ï«g‡Å{ö¥ëN[wðKíMìˆ~1önÿ±ÿânvoì‡à©cv[ù9›¼äÇ=/Á­ƒsá ö|ŒïN_tÙ7WüâWªmnþ©})ñËp þU¾¡}u©óæí—Ï©.†~Íé>VÏY}°¼v닉ƒª{–ué<ùÌy/.ÌûúvPž—Àc«óo¿AÎ{ãæà©ê¸Ä/{ç½T—4îs¯.!=³Ü?çNP[{Ÿÿççª™ó —¶ß1öþ××+ï/ú÷âGzþñ×Õá§ûi.„÷Êû³×í;MÏð~üÇÙ»lxÁz«Ý5ôaæþéçÿÇz–ôÊð;òXÕ¡Ë:YGqRüC?G| O­Õi‹Ý/‘¼?û|¿ï|³Gxç>õþÑÅï³q½xûb’'ÐOe¿¬»úi¸Ñóµþ1v«úűÃx•>oò³Î7þ@äçô[™?g®¨¼*;`ÞšzÏ¥Ì÷ÄŸv> »oÝõ‡»_ø8¬ñTòNöA¿1߾Ÿ·ö‡©·¯;§=üs­O­v18†·ÉcZ7öžÃxŸâ~ºéærä¹?üwí;VóNb'ðŠí?Ëç;¯øåÜï!ÎÏ÷f=gõ_öµv9üÃ?¨¿ÌzÍê¿æ÷ßӯ‹š‘<ŽsS½ýNÁÉpæ¸Ï®¼<ÂÞU×=ù­êHžñø>q~ñœ“Î}ȹû¼¼ŽïÕ7å¼X7øoñÇGžrúVï<°¸…¿ÁÊ[ÜW8«}!¹Õ¯×‘ϯݙò]Ã)ÄÞxn¸o"žj^$<…~9ü¿ûR=Šì³x—Ÿ±Þ}>|`êjÔQÉÀýêïà y):Î{×GJp5|ç9Ä›õ¹Ÿ~nj\œ}‡¯»ïùy:í»¡C˜x¢ø 8gîy·îûý£k2{Å_‰+ŸöQ›¯{€ßoÈÿˆØ«ÎщíýÈ>°Ãâxx®Ç·ÒívÎ[ŸûËÏú½ò‡‰#Ú—> kj/×tîxî£ó G;7x°æuâ¿‹»Øszú1óœågÕyÒwLþÌïãùÛ_’|¿¥¯¢:Hñ'ú¡ÄáÕo‰Ý¶O³tØr¾«K‰ßP‡&ï@_=ÏïÉßã7ª¿’ué\-u‹©GJž¿û¢?\ÿ©þH?ß¾»ðf'm·Ïv§ÌìÒ:‹öÓæç:_Už_¿êÇ×?âû:×K?½†éûô¹ÝGñ?#ïç¹Ø3ç½À»ˆïùåêAçü4o?kùUx ¸vàY³OÕÑO¾šŸq¿ð'pBçëŒôWáåöŸ{Ïü;|â^é,½äoá̱¾Pùp<÷™~_ßκ”ò\yîΫÏsV·¾XìÆXGŒýÀÇ:ÏǬò‡Ï®zâñ³üqõ̯Èùr>ØC?OÞ·Ïâpöž•w†ègàÓŠÃôª·ÈýÍ¼ðæ¥øÖ_¤ÞËsáð‹ò!+§îÕü—ØÃÖÓäçí£óÐ9CÖ_¾ÙÜöÔ¯¦ÿ´ø¾u=·~ZçŸ]ÄÇô^fÝj_ÅYwçNüÝçÎ>Ú·ÎA§Wz.çC¾òâ#ö=|땾ÛÏ“óïø |%{Õ:¸Ü/ç®dïÅÁËýø-={á9égß|W½Õø)üYuós.ø÷Èsç÷þááZ_•uóÎ ÿi.ùÛ[xæn·Ô–Ç5W!ï §ËßãÔ7t^ÉhÎNõÉS_1æS;ïpjï=ËØæi¿V=ï[ݶœgü=±ö3ïVo4uUì}„1éüÛWqwçÄN•ÿͺ;÷íï›Ì}ɺ²cx{çßáóœÏ gˆ'Ø :pìpõÍ›K=•óê÷ĉüUõGñÅÙ‡Î7¾çרŸØƒÁÿg-ßcéÅ·l|PñâXß,sOš¯Ëù¿ò#ž{¬KˆgгÛç<¿{à\Ðͬ~*}ïÜgõp¿|ûg¿ºïøºÜ÷ê_‡W`§ø öQžè<<ºúâƒwÜ£qÜãœyoñOýeεóÑ|kÎõóö OkýùqëÞyltô=äÂcãywì¤:ÖÎY5·u4÷Â~§N´çNŸ?ÿL'µý^áµ:·ÞÔ'fþ }2º{¹OxíÎõÉßW§ß<°ø'ë&Þco/þÈ »ÎÝèkCîHŸ£ùçøöÕÄÿÒqb'ø;úÇö«õü}Áì“ón?؇گœ£þ{âäq}œã}Ë·FŸ¤¼FÖ¿s “?h½Ü“ÏǧºêœOö³zÒ9ü|u‚éƒgýÅ[Î }GßÇ?û9xÒ9†Ãıì³{]|ü$oйˆñwÇ—z÷ð’ƒ_ùÑÑœ›a~kþv>ª‡¬¿Ô<êøÍÆ9Á-ðMõ7èÄWð#˜sÂîãõÇyjqˆÏs^å“ä¹Ù¹±Jó6‰'ígÏIîŸ÷.Žˆ_éœq–úzõô?ó~tÖ»ÞÁCÕqŠ?i?üÈ©—pü{u.‚k§à)åeÔ¯%ΧòSxJþµù6qÆ·Êóó»µÏâ§¼_ã×ä-ý¼ïµžì\T]ö?÷è‚…<èöÝ_Ûº*þÊyµüqâ¬î{q>ôÄeøHçÅù¨ýU—ž®ùØ‘~8˜n ^Îy´‡n¶â!»>s›þ<ÝOö¸õ_p$ÂØ·ÓO¹gÿS78´v´sTã?è´úþ®Kž›¿¦3]½ëØüDç‚ÂljKý½~2yvן嫃àGö»ºœæöš×‘ïë<ÑÜ¿ ³ú²—o>Ôů׮ÒoÇçÇ?9/Åoù~üFu˜ƒgZ“÷h^ŸßŒ_ïÜåœûãß¾ÿžoYé¦AçÎ1Qx0÷X]ý£â289qNÿ>ëî^­ðI?7çoV'êZÔªƒi_íH÷bœ¯U÷‚çÀwÿ̯VGšu…'ØmþÃyí\‹Ÿ]Ü çsõƒÁ9ðŸ¸VÓùÃÁµú‰åŸÆq,¾´¼Bìº6ñNóùÎOwîSÞÙ>ýc¹×xíÖ1„ÇêÜ™ø“ÎûÎç:'­oˆ_iSÞËç‰ ì¿{P™Q_ÜÇê'ê~e_ª+ÿîÞ©7’?·Þö‘ÿ¤/Á.v^\î]ó.ò'æÅΩÃÁ§éóïÀ ð÷õïÕùŽ} ÞkÿjšgÐÿf®lâ|Nû’Ù3õXp»9¶‹WÙs‡E_:®yÓö¥æwÎìÔn·]¨NHúªäÙÜïÝyá9ä½Ý;|”õªÞGxQõD©¿«®Þ?ùç¡nÔþ7ñIÏeα{Ùîwùnü¿9¿Á5ú{áQÏÛ9Çám¬\æ½Ù9ïãÞ˳èo¬þWtÒà²æá‚ô¿8Õ? ŽuϽ¿kÉ8ïi_ð»ìxë¶sjgù[ö3ö‘ÿí¼Iú ©×Æ[±wô’Øu_âïS¿¥>+8È÷Âô|š3ÿ!÷ž_³nÖY§®lþm—Þ²Æy Š_ª÷ÿÕþùÜï Ï ½ù{ÍŠïÖÍÀMÁ'ô6ª£$p¿Ùçˆýb?äqÂÔΤº÷Ú¹àG­[çygUO(ü™~¼3{U]…ÑüNñ'œ5¶âzçÈ:Óëæ_Õ“øyv¸ú°êUéÁ‡_to«Û«^Ï_¦>rˆóéQ‡w¯>ÕÔÿ|˜y«±;ՙϽî~åü³ üŽõ–ÄÕ3¤û ÕÓQ„Ÿc/W™Ï> :t(c7ËóÒ%á,ö¶ýýtžÃã?àµbŸÄð¡õïüËį¿¯ï»õÉt¿ÍIŒÎ‰õæ­SõrÍÁ‰ã÷ù¹êŽêIÅQ½·æ‹æ¼ëˆá}ñÞ¯yWukø­ì ûZýþðìHçï©'Lj?¢w4÷Ï9bÍÅ+¶®À9‘”_¬î‡ø$?׺ñQýNë?sÛwâÜÒÇ N?ž5‡ÊþñÃ9/Cÿ>6ïç~ã5ð{ÕùcÿÕèóå=èEw=ñšÉ³ðGóŽêˆ“§jÞ6ù+8PŸ »Õ9ö±?oÉ.ÄþáÓñ4ío5o5ç¤óKã÷õ3·Oý?¾zò†›¯\>E_¤õì|óôÙuRâFñ’uwð¡Õ%¥{ýw~ÃO ýyÓ¿¯_‚Ëã³ã¾Aç°uté¡«ÛL¾èï~Àƒ?sÊŠîYõFÚg˜Ï×WUýýùsEZ§„oȽc¯jw³Î]'<½úõ†ñ‡æîñ‹Õ—ß±¿âñIçÖŸàäñàö¡ù@ydu!øúÁ#=*¸Õy”ÏkSŸÎnÈ·ðoðže¬'‡ÇhÝ(^8öؽh_wðÀo‰ «{–?ÅêuÏ©+ÌzW·T>ß–ýs?Ì9Y°Õ¦Ç~ú¾ÿ;èPÒããg«“‘:œöæ~—§ _ê½é´¯ ÷^üÓ9Má7Ôç˳©£;÷æ£n8ü•C½_óéÓ8»ú­±o+áÞèçT__VìmqQðfû›ÂOÀ½â38©ó¦õï°³¹ßΕ:õÖcÓ©Oü¼è¦ÏŸòª/mÔ¾xn3'È÷ÐÁûâ{Ûï¿+þÇšóUýAõ„ê€r.ÎÛàOüÈGÖí}æ¯ôº·ÖKžÁçÂ#ò¼úýàZü`ãøœcûƾ”ÇÎ9l_½|Wø«ÎkÍy‡gùKþÔúV×,öNv^«çýxñLëçÌH¼ÇfØáΗÓ7«Ž(vWœg:ø!öËz‰ëôe$ÏTþØ\W¼¦çUį÷æN7Ÿíù“_ÇÀawöë×>rAy2ç°õ%ô†ôA„ïP×n}Ùçêòe=ågù;ï)ž¶núms®gõÓÃMÕ­U_­n(8Éûð£íëÈ=öýÎ¥x[ÜÌÕï¯Gg¦ÿN/¤qKâQýGüKç¦F¿Êï7¿1]—Î[ƒšW'ûÒ¾øiq…8€ß§?S}®Ä7Þ_Ÿ;7ª>:þ»ºlÁ7ò]ÎMíGú–þqÙ#¿|àã¾\/>l¾8qœóSÿ†§ ·»}Ÿ|^ùDóM=Wúv›·?SçP½6:¿‰›·ø¯êÈ9/ÖW>[_óX:v¹:Öõ7ÁëÛnîLö›ßV“çœÌý¿óxÔŠsùÙök&¾æÏª[1ªkÇë´/ û°#ø—οwýjõTùï±dy‡øau¡x*ö¿ºâô³/ú á.<û '¶®‰žKîcqjìƒzx‹_×w.QøÍÖ3$Ïþˆ«ÚçIç/¸Ü¹ç¿ª•üƒs뼺—ìDóêô1å‰åí¬¯úŠÄ¡ Ìc^±ïpzóÛ9ïêöáX|šu“_ Ï*?ë|ùûÎK7/R^0õ â¡Ö+çû[ëV;•þycøšþ»×¸2ïû:ÔÃ¥oQžq\ÖþÄ3ò½âïö§¥NÂ|ú/XýÆöÛtÐÌya7õ¡Âeò«tzè¶þ>ufÕ'5g#ÿ/ÅÏ9â þ[ÞÐzv>Gì¾?Þ:SõÿòíÁeò.âý­c~Úç»×ê :?#÷˜¿pOÆùtq+üÓ¹걃‡;ïdß#_÷á›/òC±ƒx˜êŽ&ÞçØ·âVýØÁ­O0_}4ϽqVÖéÀ'¬¶ðwÿ×>K|Òüsô?:?lù?ÎØãµKž%y…êåÇÞøyþf<Ÿ#÷¯ú4å Gû"Ÿ+ÏÑ9 Ñ_²>úiÅqÖ§úòñÇÖ¹qlÎ+~I\ѹ`9¿Ãd.AònÖ ïäyÄ_tè&ãÇð²ÇnN<ÿjDxWçÊóÁÅí«Nœç”·¿ƒ?Ú‡ä}:×6y7óQ[Ÿ©Ow”Ï¶Ž­ß‹Ý×9—£s|¢NÀúÙv _ÖyÜÁö‘Þ’s†§…?ÇýеÓᣜ§öqgª›KÇ\OÁÇ4‰½¤«g2÷¶Ó6ßiÍ#š§`_õß±—ê:žó('à‰Ô×ÂËê.ñžì~źˆÛœÃòb‰‹½_ë$¦öz2gçõŒ•vxÃàu†í—~Àï«SçÿÄÅú…;,v¥sËrÎðÕoî¨>CÎ ¿QÞBÎ'¼S> Ρ>²ú¡êõWÐÏÄ Òwg×è%;ßöÞ„§øgv¶uøá¡áFüŒuªNоàðãù2â_v‚“…¯ný”ϵ.xªêçþª+Y¸ÿû?hõC:þ¤§Ø~ÉÜunÕ‰ ?)?R<;ã^ÁøRy{ñÝsŸu³îp ž·uêâ:oÊÜXõgæPÆ>º7í{£¿;,ÏÍîÂ?üç¯7þÚûæ½õe³òÅü|ë΂ÿênüÜíoþÄËËÙŸÖÛ™¦îkú÷SÖú·ØMç—ÝÄW«/V7b_ù·ê¹'©¯é|ÉØSuìœ+ïCÛùp/‚ë' ŸtÞV_ýâÿ÷‹²öÓýTGâ>Š»ñì¼YIºQxŒ¬×…ÏÚü{¿üàÖetnEìfõ‹§s§·Öœ·ð2íûHœèüòâqç°ý ùÿæQ‚3àYûÃþ¨+jÿZø’ÎC‰­¾YêZø©Ö d®=¤ÖÝÄ_µÞ&ëܹ׹§çg.qî'^¨ýЉ àö¸ókßñŸ­›Öw§’^~ž«ñ·¾¼Ü+~¢ùëì;¼R¾IÝE쇺~øÏßóÏÎ+œ¦.¦}Ò±ƒp½4û@i¬ÿÞüB~î‰u-oiGîå¯xîοÌ>Š£Ç:ÑW~Ìù0Ç¥Ï'ß¾6¼puM³/ì FÇ ž€à¿æãŸÚ?|Ëû™«½pë÷ž·óë^5è ¨›N]™¸ ïÏnÁ1>Ïs«3Ñ\œþÝo=£ySþ}ÐiM܃o`[O™xLŸ†÷Å׉ÊÆ_ËÁùüå8ïÓ~å¼Wóû¹/Þ¿2®Ïnÿ£9©#’/é?ÆoW/<8±ùºfÅ'¯påšWðýíï1W'ëÞ¾Tõ›æoÊ?™—hN]ù¡¥õ}±³_’'†¿ùýÆÅÙGý+öŸýMŸmëDð,ìªsæžáØóÖY%V]ÄØŸ‡;qË“ç~d£‡óûºž“þÀ˜G¶/ž/Àoð“íÃo†4ïÊ÷±ƒâqq^óOòjÓ8n°³ð_ì|“s5Ì5;¸ ®¦kìœ:çôWÚï×ÆÞ‹[ä5ØÇäg‡:¯à)úñ}¼—ûGï¶ú~Á}ø?ç¥}¹ñwò„­Ÿs?¶:ùAy†Ë½ê#NÞw­A—3~Ú¸,vùÂv»ðS«ïQ»Ž§†ÿÜCº–î[ýyø(þþßêj’ÅãÀ ø.xdÜW鹜Wü¿õÃ[ç—^Cu‚éÕ‡—÷ÓªÏ4}¡oì\ñßâ÷Býwç`äßáAÏÑ8”>É4ÔuRçêþ±c­çÅê|Oç…O÷_râ9>þøO4Þj'þd<§E}Kû…ƒ‹ø¼Nýxü@ù?~L½BòÖÆ+9·ì¡}Wĵãçj½Zž Ž«zòDåûs¾»®t §8x–þ^Þ‡:¯ð6ûçÏâ÷øv -¿çÞV·Mÿžú…ðé¯iýã9Z§Oß?ÏAÏ¡}çÙ¯3îÚaë×~ðÔò+òþê´Ú7¾Š¾ õ kPМ¯ä5ýàà(x´q¹'ϧì|ú6±çü)þ±žâ*º¬ðœuë¡wÞÝÕü<^Æ|ëß¾’ì?¯>©: tY‚ŸàKvJ¸{Ì_À]ìç’7ÃQ­CéŸà÷:_#ñ¦}oü+ïü¬N­Î’ºÈð‡â|ù/vZÿÛXÏÿË£²Oê ñµÎ}’Ök$¿õûàä±?ÇÇç,Xçò-7Û¸v«óÐs/ÔOÉó‹[ºOùx¯å\êÈË5ߘ߷îâ¿Ö©_•ÌçóçÛ¿Q½ ôÀíµÿÙOøïñÕkNXvîºË{ªœŸs¾Æ}\î<;ÂþW·=÷î²×Ÿµýâç]Ѽ¼8ÅûÁ«Î'Óû àïרÏdW½·?ý;¾J½–9–x’ΗL¼ÀŸò_æÊŠ£ZO^Nj}˜þTsŒâoî¾qï×xàC}îXg<÷­}hÁƒð´{äóñ0òdêWíKóNúÂGz<»†ç§éWß1þÎa/¬›ûÆÎ±_Ë/ß|õ¾ø×ÕµíÕØãÖóˆ·’G;ò´U×ÿØ‹îSüìœ¶Ž”î³9§ñccV¼ˆ:sçÊ>{ŸÖG‰Ëí;8ÖËRw2žÀÏÈ3Ãéü^F<Ôø!<ç6Œx¬ÑܾA×Ïž}Âc=$vާ²ïÖ~­{Ç´Þ÷|kíGŸ½ññƒžGž»ztæ*â½éDëÿȹeW=7œEV‰—•—•Ïó~p2~;ó}ʯñ£êߨö%Ž«®õ Žc_«—{£>u~à6v¥ù~ N½?~é‡zÉWÖ¨`g;PÿwòrÖEœÁ¾Êÿã¯ù¥êOæ¸×ü©:$ñ?Ö:æœóÖKz.çRþ0ùë+‰çÂK°ëÕ£—;Ñóߺà³ê Ð “çI?{çÕ³oê7rnÛ¯¼ŒººÖÇæ¾Ã{êùW矅;à°YóëÿŠÌ“hŸ2Þ^¤Sü!R¯ÊoÅ.«·ðpUù²ø7¼»XÝnõû#½"÷šŸ`‡˜/1š+E¬ç,õròÃê’Û?ž<>ŸY\¡O%8>ê\Åô#To–ýÏ}ÐO_ê3رêöæêãÀ[Œç¿OŽæŸû^~P?;ã<¨ó‚OÝŸÎýÿzùtñnç5æÜ럷ðýêäë:¿%öżóëúØaq°<þɾºêhZ_{ãÞZëçâ½ÔÍw¾KöÞaߨÛò5Á í ¯û£/ßg.‹xS=Nç%Ð=Ï=°oö ï¢ÿi½ð¢ø çYžÆ¾©/·¯ø!~ÒùWÇÒùe#üÆ?´3~Þlž5ç´ºâ¿Ä½õÏæ™7•ó_}‰¬7;ËÊ“Š³¼oy®Ô¯TNÿkx¥öë7yï-> ŠÔÝU¿cŠ¿:Ï{\×Ü>xuÞtýâ·S¿3«þUüÁ.Â×â¤ækÕÿæüèòóÕMUu¦çm2çš-Ö^¶ôICÞ4Ÿg?sOfé7ãŠSƒ[Ò«ï{2÷i—ßò¥½{Ð1ŠŸ·´Ÿi¤‹•ú³ÉœËw¾è‡x¶uœÌ=rÎJ¹ò§“¹Øþ–+îüDã'ö‹¿Š™,>qÁŸþtÆÑCÝHâ¯à½!—xz¤gØÇ+¶NFý¨zæ)þož/ë7™?Ùç[œüêú·ÖKÓ34?+ëÃÏ‹ßÚ'£ï%¼Pç`MíádÞ»·\ù>ºë ­sû¶ÍÝ—§¯Ÿ>ö)û0™·é?~ôÅþxæ¼;—ïü¥;ê ‚«ÇùëàžÉ¼½~xÑ£žÿÔÉÜžºßª/8dЋTß?Ò…ÇåçÄ î » îB¾e\÷Û9˜Y_ç=~w2çK¶}þ.Ïê¾9/Ö\¾VÞ‹nNö«zÞñwÍo'ÞìüFú%yõ)üOurÿ=/|ÊðGã<}ç´ï;7ps^\”úO?ç}£Mæ~îÉç>ÿ±(îv¾ª‡©î3¸´üfâŬˠ{;ã^ÉïU-|•u“ØqõQú2zN‚'‚#~9~H|{Ý<•ç­~TâßòþøØà?v©ÜäåOáúêz†¿#Ńü‹x¯ì\²îo뤜³øUõðTõ òûc}ç–?ÃVg3ÏÃ~ŽëÍkwcGÛ?Ÿ<~ ®M\V?.ÞjÞ ùëyϺ‡~a‹E_æXwÃ#Γûïܱ3ð2ÿ×:":,ú.ð¦¹íû Nlݤû?ýs2w›ïìyøŠ» |oð_ëBÌ{¤›^Ò¾—äykWñS¡}ÕÕ;K¿wõbê_ãçû§þ2u‚±ìþ/Òú;ÿqÅ×®»rÁª?n]Qus^ð˜£O:õÙøcö-üÁdÎwûû›/xJã»öãÇþêÏÒ>ç¦un¸ø×Õ^©ã¨QâCñ_u¨SÇ+¿_û>Í_V¥zü±x¼Æßúlâ_áf÷±õ‰òõy_ëJO„Nÿ„7µ^x#÷ɹ…?œç²ó2r_|¯:çšÄG{Þ<Çd¬Ö¾ìØçm¬›Ûõ QW=åÖ±oƒ2=Ÿo=/Š/à\öS~3ûÔýS·Ã~Ùõ;Ιü1zÏiosÑëÖæ–¨'’¿‰½à¯Ù›ÆC£þ‡Ö¹èkÎï——¦Ao1û郋ûèCfýñ!ŃæeÄÞŽêت[¨o õ·xâßœ øÓ~9Ïâ!Ÿ‡g’Gá7«'œsÿjÝ—úù_ù¡‘Žey¢ÜO¸Ý¿Ã—Õ3g‡žkîWêŽ&s¾ðÔK{ëп —à‹ù3öÙº”‡L}yïWì»^»| oUïÎeî?Þºº=‰kÅkrOªó¯Î.ù»YzðúqÍÎ:À©ôTœOywûžµ"÷•½ô€g¿y½ol5س)^­ŽÕ¸oιÕ?5æyÄkâ|~HÝ”üž]¢|‰¼Œ÷pÿÝOç”>‡}vnøéæCFsÈ›?¨3 ÞtïÄtZlÞFò6ýv‚>dúªW·2Ÿ_º}ɳÐg–„—:7õ Õÿ0Ÿ;qJûµ“o—Wë<‡éùþç’ßwΜ‡>®v«õ]ù½îÇh~—õèèœÝÄ_•sÞõŽ?dÏÙ¯Îk1Ç"ñ ïíüRyyujáKùïÎÛÔG 1v¤¼_î!y1ñwuîÆs)Ô åÞÁå»ÌsM}„x´}þñíÌ}„ƒ;oSüñ[ìuóÓæ$â¡ÍEÖD/?õgµæ’êC4/*_esPÝ{õÌôàé§.Ú9…CÛwÜY=íØ<ߨ®v°SYÇæ7Ôeäž°¯ÕgHß>ðÔ•UOR¾(üký8œ.oÀ.Ç4ß—saßñé?"nÎ=å/üœú¿öE¸Ït}Gó?áëQ>¤ç»õèáÁ:CÜ“<¢<ªóغSóär¯ÜGuAâHö[¿CõUô?/z±‡gÎfÎ{xÕC_}ÃÍ3¿ò ±'ü[u‰òïåÛé®›úŒærœûö盫žsÝúÄÄËø,뵞"çÏÂÀãp¸}“ov.ìWu ³.£àÊØ|¦û—ËO8âÍÖ‘%¾w¾:?P>?7š«Ì_ŽûÔáÆÃyßÎ7H |Nw¶s¬rå×[Ç=Å õ7xŽÎ ÒϘ}ë ñÇÞG܇4ýüFê£'sþñýë/~À·‡üuâ"ö.‡/áMõ„×S÷Úºòàÿæÿó÷ê˜Ú¯œxX](¼Ü>‡àP<—8´x$÷QÝœ,Þ¯Niî÷Ç+´~)ç¦ùËàüxu²®tçÙ5ëåïÝ‹eŸxô—7>çÖæUÙ þGÞs\—Ùó>•ÝTÿ[ëØíÎU•·Æ+›kžQÿ û‡Ÿ„Ûà/÷¬õÓ‰ù{8“„s}¾<žÊ¿ËSúܱ¢÷pßcGšßës·U‡ ÿï¹þ¸ÓFï¾é÷´j¬«0Ö×ågÙ{vn6úü§xö–û}®¼œsªÎªþlŠSZÿ*_ϵ¯(û0ž‹Z¿‘sÇ~âߪ—5òΣx§úmù{z‹—úçS+~ÊþáµñõÕ¯•GÕg ISuk£‹4?H·3û#PçàiôÙ¸7ðEçAçVg9~¯ó´rÎ;ï6öÔ=ª(kçÁùuÏó¼êø)öãÜ>zåÃf¾U}ž?óéh÷àgä;§G öt–®úS:~ãùs±­w?ë¼zØæhï‰Kê?¯¨¿²ÏÅ÷æ1äûÙ-y‹Ø÷ð­Wæs{uIpGû1ôùÑ3Ó›8\]~û’‚·;7;õ p]ãzv4ù¨ÎÛH]Þ®}Ùp»z$<þLpâ$ñQë¯s.Åýø´q{û_ð‰[ÊCÄÿWÿ-ö‡ý7;õ+Á­Ï >¶ïÕyKœ7â÷Ý7vÀ:¸/Å y?|2îÞÓ½©®dðNÏMâPößßùùœØÿÉü{¶¸é¦ï>qнT¯H÷Gݼ‘÷çœ7¼>¼Ž©ý׬sûŸÕéãaø‹é:Læ~pf·§ö²a?‚³ñ ìiçh™«œ­þ·¼,}ëä‹WªJ|ØzòQ]sû¾Ó¿T}±øë(n;ç¤srîþt>Gónœß'þ‡#;gÒûÑg‰Ýbw[‡«žÇüF< ^lTÿès½Gû³‚sØ÷¥õìuü¿øŒ¬NØ4>¬øÂ+öùÛ·6˜¥oXˆØ÷e¬§{✟œñÃM†úbçm¬›,Õ>õQ´}#±GìGó0â¬ØovP¾I~¸÷8öïâ÷ªç—ûC?²:å¹ïüduÒ×éÓôóüœ?ùûÃŽáqü;žÆ>wÎnü™óP]óœ›ê-ŽêÆsǬ§º|\Û8&þÀ{6?˜<½ú¾æk“ën5ïžç¤³VûüÈߪ—„«Ú' gÐÇ3;u«Õ Àïë‹ ÄOW?"8½¯U_%Ï)Ïø\~¥:·¹gâsx¼ý‹ì5ýIõ°æb«7Í{¸'åƒôiä<ˆ‹ÏÛãØm}Øý[ÿå\un…~ÙØÕÎõÕ%‰ä©×êæš_|׸}T·縇á~Ë£T_8ùQ8¿u…yyvϽ'ª›oTøχw€ƒœkùü7>£üü€8Íy–wh]„º¢à6ûÄ~éW²úHÆù‘êÅÐåQ‡™—w±ŸÎ™¼Š¼üx©÷õý]?:æç¾4/©¯2ûÑ9çæ׌û.;$û`¿Ý3v¦¼›ù0âKu)±Ctôéµ?=ç»z‘ôÞõ§Ði3*q&þ‘^9Ô½î\°ð<åñÜ—àí1ž _8™·ßGwÞè“7ôù«+! ®b÷Ù¿ò‰ðo~¿<9½…øm|¹óåßçÐsvtðË1«üᳫžx|ï¿>CºqÎIÖ»<}šêd…÷q¨€{à[qLëø¼¯~<õªéSê;ÿ‚»¼xö«u·yÏ…/†šG …[Ø÷ yãÔ¡ŠÇùÏêônòß?üo-æ8Ä_9WÕéˆ?jÝQpbç˜S%OeÞFøügÏú9õhéÏRŸH—ÂsÐ…kž;8cl_[u2êø ÷•4¿L\ÇÃC——ʽé\W~ܼ–¬>`GÂâPû©¬óor¯Å!Åëáåªû®ž>ù¿±®ì¸\~¼}3ê+ò^xûê=ч‹¤Ó‰ïâ·›Ÿ‡Õ÷^E|ƾ%ΙÌyó©ïxÂM÷i¢ç¶OêÈígç—äóøu¼³sný;ZÞZ¾\Þ)ïW½¢œc}”'Üå¹äAÔÇ9_ì6?#žå'ÝW<$Ü,ßæûí¼©Î–oýŽ>|õ Y?õ8í«ŒßÇɇ»¯êªªK?HÜT àç.WŸ`¿Ê[åóÇq§ó#ŸÀ_ÐQj\¨>E¿Cö¡üEøyÝÖMë‹dWÌ7Ϻ¶n!çA¼éœÓ¹ð½»}g7Ååübë›ÔÆ®ãQª£¼Žon¿QöÇû³á·mú_g ç6þJ{σùÀ¹ÿÖ·:±éwÊ=í¼ ç³z½ÑïÍ=̽|Ë£ÞöæcŠOõ1gý›_j½/¿š8%÷lð‡±CÕçÍù‘ì¼ÒøKŸãçZß–ûÏ‹‹ÝËâþØýæÇ‚+Ú¯©ÎR]|{Q=$81öï o§_µõçõ×ÎeîŸu­Þ<Ü\ÔymÑk\—¸{\GÛzÑÜ;~±zYÑ˰Ïå¡cwʿ˛oå|æ|U‡N}D~Îù…_ðòÜøÙΡÌþ÷|ÁñÉÇ´^1ï×¹pÁü»QÄø±Î¡ŽŸí9ì—)®kÿ~ë$ò9Å=ôTÂoˆcšÓG–ýÁƒ©Ógø“êËŽ÷—½h½Gâñö͆ŸhÜôÞ ÷,~Ïã¾¶NC]ìLõ¯sŽ:w+üÿP^"û%¯éüˆoô-óÛÕû Þwà€ö½ÂCâæÄ3øw?o³ÏÎ{ç!dõÕ¹_â ý íŸÉ:ÃÕÓ2‡*ó뛇¥ï2Òsª}§×™{ãyÚ'ÜÂ{Oø4ïÓú€®WìEõZî­ÇÛõ¨’9ìÝ€Üÿê²±gæ|8p‡¼tõ޲opbë#UŸ*xšÝµîÅmñÍd]}^õUÍÙÊú6¤Þ*vÀ:tNátÚ7Ù>úœÏ#®ýŸ“÷xÙ`O·G×Çÿ[ïêA/Ñ«ƒ/á%:rìº8¨õæþŽô’Ú'C3û¯ÉS¶OG\šûE§œÿûÅO/ßäØ¿ý©÷s×]ó­l{ÿÿºh2µ­ÎÝlÛA¯‰ƒ{W‡éÏý‡ðIpPu8âñ­~~|î›H\b}á4v¡uÂy/û+.iºz³œÛô;T—£óEâOÄ}êËô%4~Ä{ä¼–OË}ï|ÕøEøTý@q¡s; o°â’úCóšr_ÇüXü`í„çì7üTÝûàמ;|U~¯õæì]}Zp`ë!sßÇ1Á_ú~~l܆giý³¹Ùw÷ôÿö“„¿:×:ü¤ç:gÏÏnóŠõ×*Þ°ÕEL~O¼V]ˆØ‰ñüj}Zí‹JMqZî§|jy»‘®yãõ¬Ky|}d¹ït>Ú‡^ út©¢kT¾'q‘sÖü²º¬¬këçò½ìYû§³.òóÍ¿Ny³ÁÑ‘Èy©þ¬þ¤ØC}MåËr/á'uÅcÍ…oªã¬5óìª{›NüP¿•ºøêƒÂ©«H~«¸kÌGç×Oeð ì†>”ÎÙÉ~èK«®àÔNæüæË^yÿ]‹Ãwþ­ú‡ì¯sÏ9„?õ±6­ž9û¦. ¿ÇßùyW¦ç…'ªGƒÞpÎÛ‡…÷L¤ŽÞ\æÇƒ¿ª7a®Vü/¾ƒßf?ÇupEëþôAÓã aÿñ³,OÞ·:Ìø¸øIvS]_ùìSùzzÊñ­wI¨}iÁUg̺þ&7î5ðuøczetÝƒ×Ø y©öÅßt^¤þŸƒ'Í{áïÔ¯ÃÓΕû;žs‰/ kܼnÖ%ÿ?™ûâÿyÙ·ýQù™öeGº?Η?ùq81ñZùGq»ü»}«ŸJœL¯²uòpY_ü®÷j5~_ç\Êß8s¿¦®£¸;ωWpþ[£þßûÄÎ軳^øÙöå˜Óü{WÔ:YñR¾Ï_à3å]?O6¾Ò'”8­ç ø²º«tR’§ãÞÓà1o=ÙÓêyÇÿ´;õÔé_ò¦ì\ÖÉ~TÏ+v¡ürpŒ÷ð÷åù¿yq3;†ëÌWGÜœ4óÎÕíÅ¿‹ã[o¤n%örŒÇÄÕï~Å7é3°®Õ+ÍyoÝŽü|ø3ë…·¯>Nx¹ê³+±¯ÖW<ß¹ÂñWÍÇ›ïš÷§È×±ƒêïÙÑæ1å·“osnÔ‰Wá“Öç‹;âO}¹â(<,\ݼnþ½óFâ'ù‘Æ97ì:\çósÍßÒ ‡÷éœìœ#úÍþ_ÞªvB½ÅÄÕµ þ§ Ç.Ð…õûåÇàýŠáÊoå9Ø%}ˆôPZŸ{ìþ˯Ê7êgjÝ=úijÍÿÒ‰•‹}mœH¯+ï+¾„3Ê›@‡#üIídìuÏÛh¾÷8Ž`óçx¨Øá1¿-Žà×á‡öéé›S§ %N´Nþ_ý˜:|uZð\¡ºú‘y>|=þ³}]‰?õEÀáüDu&roÆz™ú;ëŸàë«ß;ÒO¨Þ¶>´Øö‹ßÅt¿±ßâ2uI­ËËsŠ+#ûÂîóûx>öÇ:wnzó·²~ÝW:»ù\ý‚x÷öÃÇnóíÖÿ€dÇ[’xf4‡½Ïk[O4ê©Åì{ÚùUúõw7o«ß—~L씸sœ§q?ìWçh'ŸÖy$áÙa÷–¿£oÞ(ÿÝ|Eî?~Õ:T‡2<š8¬óÔõ÷çþà±ñ ÕÑ;ª@_šç÷zÎÖ1â=ó|ö­ëÂîÐaL¼Þ<ùrò€ô7Õ£š£—sÞ:ú¢Y÷ö]%þ.¾’¯q¾ðŒúir/áI÷Ïy©ÎzìFëÕóûü§ó /” .³oôðոʼngØuAðTûÂSøwñ»ä¾Õ/Lß{2ç%?xþG7Xg8oÉ_òcxþÖ‹WÀ¹ì¢{_Ý\¼u>¿óµéUò\æ¢wî6ž"þ§ù<º;Á{å ÍUÍ>V¿GÝ[ð_ãkzÜìvöÍœ#~‰_iþEýEγøµ:èñãìuusð§yõtü¡s$/ÄîÔïŽæŒˆ×ÚgkŽ`ìEû”ß²gîœÞs™z¸Þ«¾jâ³òEÁMü\Ó?cŸÛÿ©¿Ç§u/ô´sÞð›îyòÄK½¼n}ÙyûæþÂËã>r¸Éz›£\;¯¾1ñcû%’7—'Œyziö‡]§÷Qý]s•Õýæ9Ãû´Îšƒ_Ýwû…o’‡w_œGþÀ¾¶[?uê Ä-â$þªu߷ݸãêϼ}²à7÷9îŽ'ÿiæçÿ±í «þ䬾Ÿþ>÷­v>Ÿ‡7§cXÒà¢Î§ßÏŠ×ôï%¯0ž¯„©ŽN¾W~¡:ù‰[/þÈ »ÎÝèkå«?ü4ÜÑ>¿‘î@qxì;üa½{>ü}ðRùûØ;<“÷“§·Ô¾Š_ó½åIñ籯­GN^Bþ]]:|d¬Wûðݯœ¯ÖªÿN>¯"þ+Ÿu‚眯±… ÌË3/±}&úÊà |/>$ñ ¦õú·c7;× x¿q±8oófîYóIɯ°xûê±FŸ¬õá¹÷ì$~‹U§Ð9ìÁ'ì‹¿³?ú ÜÓú‰ØßꜚS¿[½|Et¢í·øÕýÕOVý³à ¸Qÿ&;R}¢œ¿{n¼öúý¦ž|<)/ËN³³âuû¤>£s%²®Õ÷ Þ ·nÞ£úöÝü‰y/:sƒg|á¨AO8vUœÃ~˜ß /Ѹ˜Nö‰½•ïU‡ GëSÆoçüOæ¼`‡ô¿éº´?-¼.¼ü:™÷êO¾æÊü°yµúåÔÇ´Ï(¸É}Ož¡x³u”æ$§”×6G)û¿5ÿ9Åu“9¿|ëÕνªñWú-›—ß'y ü¢ç”ÏeOÕ%ªç²ìŸõì|Ñ|vñÿÕÝÖŸ˜û–zÊæ[šwÝµÏøq]Mç…]SW´î8ñ¹sbr.š¿So™øy2ç÷;ó»õ^Ô÷ NìùqÞÔ•™Ûåü¹Gâ‚q=jëAÓ÷ì½Ø3çK½ªøÄ¼4v¬õïò±ÝßœßîêkÜ/þ׺·wª3Mç¦çÍçâqØ«®Oöß{Ä^ô×~äûìSxÔÉÜÿ³ÇG­Ø~ ë€ïÂ;²?ί8(ø¹yÕÞ‡èfÃ?ÕšÆ3­ä/Û¡>úP}Þø'ùbºÐÙ§¾oçÌMy„~¼,Î`wsz¾â÷;¿ÌýÄ_úuEtGæ¬óß}ñ9_ìså¼µ.ª}œ‰OäÑ;ßvŠš_i=Hðoú‚¼Oõã¯&ó¶úÜ=§¿ð½µÛÍ·±ÇÎ}ü[ìOŸÛï±_Õ¡Ë~zÞÔ‰Læœý•¿tà_7‹3œCñ;U]ÖÌ}Èúw¾Šþ„ÞËÄÑgl¼»íŠoÝx1~§v5ö¢ïÝõ ?¥^”]Áǽ÷9wî‹çÏs”WùQç—}ó}Ë •8Ðúåç:‡±¸-û’ç*¾,Ÿ;­—šÌûÅ3ŽÛ÷ì[k¿ñA­CJŒ{9ž3§ym8†þ Ü®Õnå¹ËŸÉ{Àí§|ÎZg.zÇEÅÃâ'xŽÝ…ÇðIƒ?ŽýV¿ Þ©_NpÎGsw‡õ4?‚ŸÞƒþ;ïՎŰ;»ªÎ©soûÇôÞ:w>?|ÐdÞjúß¿íù‹â¦q¿‰õn—óh¿ì¿óîßqiíPü>¶÷uÕ9·üiÁ=—Îyë­Ô…‡ñœìœøºq½õLœ"/7¶Op?=a÷¾ö=y†âþÜÃäQº¾ÎcãáœëÖ1Å~±3æÀð·Ö_ÄŸ9_êzé4«+™õòÁÍÕ‘„K­Gu/ò\ìIp|yZëÿðGõñxëмÕ{½íúŸØuùmçÞ¹³î×¼$.‚;ÔÇãä â:õ‰3jGäóëG§ëßßOÜ;Äûé—„ÿ»ÿt.Ü«øU<µsÄÏ™ ·ÂÛÅω·Ù›âí|;Š¿ôsx„ò±ÿî›>‚ü¼øs2ïƒk¾á+ûܷ线—ÏÕ—Ó¹}¹—Ö#þsàçâ×ÙÙÓŸxôyò ½‡ø4÷‚]€Cæþû•7ïõ?è}ÑOí¾«³‚—ó¾ƒÈ}ÔOÀoY—¬ßdî—/øØÅ‡ÞÜŸO<Ós+®tnÕ±Œ×Uˆ¿ã?Ôï‡÷sï& ¶ÚôØOß÷{/«×@-¼UõnFºòYì =KsÕáÁÎg4ÇEýš9\ôå‰èŸÉw„î¨øq8³õ®¹OêÀùGþ«¼¯ºõ[ê:cÏå ;O‘.qîië9ô•$>Òß+Å×ó“úÄ}ìÞ8¿ç^©óöüøWïßùGæ Åo]°ã¯?æ>KÝYzÞ+üVuPR¤ŽE¾Æ÷˃v®\Þß`:W3çÆóÉSVw y2÷ÏáÔ{µÞ,ëÜ80|ŽøMŸÉHÏ¥¸´:3ñÓ}.}†Îƒ¹Dø<úøÆ{à9ù[ç¤:)tÌÃûzÏê‘dÅê]ðbÖ·xúöÄ/÷Íâw;@¿Ý‘øgý©µ[¹GÕÙS'AÏTþlÔ/§ÀÜ ufâ‡öaæÜ‹—ñnt5Å}êT¯d?åïÝOv¶ø9ç¼:ÑêeÔš×M÷/}ùp \\íÔ)µ^Û|òد®Ýk}ÉÉ[²ÿpzóÔ#ý×êîç}[w–unVüNûuV'L›¾Uó¿óþÏcWÔ…Œûjÿò¹ôpZ÷çk¿+}¢Ä%ÕÅÉ÷6>ÒC7§ù<éÜ«æKÍ•ŸâôÎÕ®®Þ18ÑŸtKš×Íû6oaî-^-¼»¬Œ¿*.È:³ÿúÑ[¡ORÝ]¾ä‘­·ºFëT8ÒmŸÈh{Ò:íô™xÏÖÓÑ×Åyí‡Å稧§£­~Ù牿bW;ï%ëm}ÄGæVW×4ç/bŠÓÃ7࡚gÍýkÜ`_ÇstGüØ œs ßéWZ>yí­sv~Nïü ŸÉ±³êèLÆ´žÈ÷Â1t0+õø¥žð3ú ªgÍ>èûßì<ˆÔŒç;áÏÚç%ÞϹé|ýª¹­§²/ñ¯æ„´ïÐÜ©àç»qlüPõõËšk3Ê+U׎[x°âÿà ~ÎûÓ­b/ù¡êúÒÁמ÷¯?Ääüñ'cž­ýìú®â/àòÆóñ—øëÁïŒñ•úsz/Íçæ<°»Ö¡:aütâvv7¸¤õ1Þ£ñýs*ñˆæ¨åžøyv>j`ÖQŸ>ž§öÔÜ,|oð—>e|œÜó›{l¿<¿>NxÔz;ŸÕ韮oëÌô»wÓó`¿Ìg ›«NÓüMó èà tgÃÃ4/._>•¿Êùi ;ÿÑ¥éüWx\_-}â®Å3±»æ?ÖÑou/3·vî6ßÙóðwðKö}¶ö±:‘9'ü¾|\â^àYz®“÷Ùßß>¥ø=çܹ€‹Û¯8»ìuïs~¾zµ9ç8å‡üÇ~Ïß|ç¿o׸ý‚…<èöÝ_[{¬ÿû€'¯~ÊÎó—Íœ¼Ö¾¹ó´{fŽ¢ÿÏ.‹—œ¯ãVûú÷þ{·¿ôç¾ûؽ/Ûô%7—ÇHßZÿýñÜñWýwuge~lt¡úï™[Ùÿ×ßêýñÊç,Xçò-7Ûxà‰â×èãf>è°¾ÁÉí«žÆ»ýwó¶>ù×í mgÎøÔ^·ö²åmá“þüOþíÛþúíg~ö–‹nûômöÞwçò¿tç‘ðsÞs]xü{NøèÍß«h?tâ}Yæm‹ϸk‡­_ûÁS—ó göòÓþïÃ÷éë:u÷¿­sÜŸïEgzÎè¿ê+Ëk²'|÷Žù_{ÁÏgþÝ óÍá‹“?°ÁzÇþcÝÚÚëG¿)xµßgÿÜór:_0þ‚.Èè¼Îz~ó»è˜Ï"T§yzúûðÁÑ w¹è«ËökßñoßÏ·¬tSß's ú{ì'½¼|óÁ8é³ÞêòêíÁyÙÇyîÙ:™Û4Ü×|óä|ô€g¿y½olÕs˜þÞáާϯgÌ/²nWþæu»¾e“M†>Úğ΃ïãgÓçÿ/÷‡=ùþÿ[× áðY?×ùÇá]­[æ†ôç~sØQ¿Úc‡•ŸÙßßôû+÷[ùºñºs'Gs™Õè' Óß÷ýÖI¿ß·ò—µw8ø‡ý¹¬ß°Îé»Äÿ™·%Þ°Çì¶òs6yÉgÎÞeà Ö[í®ö·ýñ‘§œ¾Õ;¬½eo>÷îuïó—¨ÝXþ†×<õü}}˜¸Í|ÚÓÿúû÷¾ì7ç5÷›¥Ï'wùJk½å¨[Ù—a_â—ì;ýš¾WâXsÁÙEëÇ¥opìwæüÿü×¹1ü~÷=újì‡8²ó3§8ã_~.=tú7—ä©[oµüC¼>Iüç>¶ÁúËžùèk{îôoÃø£?î´Ñ»ozç=ý>öÎd¯ôµ§ÿ²?á‚cV_öòÍçx>}óêŸÓ¶½õã»ßùžê‰¿ÝlÅCv}æ6ý÷“¶Ûg»Sf†~ˆ¹|§7Ýqaó&yÿYvÊy>ê¿ëKÇãÂSöçYß/ÚèÖ+~uÓ0—Ÿ•¿§§9à«é½ïÿÿô½ûÝ0söü˜i¯}ýôÚr¯ã/œ¿Ïî‹›ÜG~òÜà^¼5žoJÏ^¶®âóªñUñËøãYçE<˜s?ø³)ï3œ«é¸þ?¼™:µo/Xø­ú¾ÞkþÝúTx§ÏÆ“ÁOÎú’äçgý|ÎQÿÿ¢ÝW>ìž¼pþã/ÿôçáhçÈ<yçšÝ/ )ÞÊ=Ÿõ|xoýý𪸟Žÿ2ÏŸiÿÄ•k˜üLx—ég­;{Ÿy‰Cœ¼ ×ä<Íòƒá†ý¿÷þ§²/æ”e½fÅ{‰WÇqÄðùáùyþOÜç>À#\0ËnácðºößIú@ø„+ÖÚtÿ½/<o6k}/8õ—óöÏ󊇒×Á³Ùo8/øy–=ïÜ<*î.N î—78÷Åû}ðÖU_=Ä/Óøq°cñ«ø×Î=ß NìÔso|ÎÌ‘·ÕžgÝû9Ö%ør8ÓçÎûÔΪW ~>/ûÆ^ø„Õþî“—ôßõã]Ë“$žÉ¾õçùKu>øçaLj·2wxÖ¾:gÕ (ÏwÖéwÞç׿ÝR<=ë<ð_½æ„eç®»¼~}Oü8 Ø'ùË‘ŸÇ;Íz^¼#;#vÿé@ÂçcÜÆ©Ÿ;åÜæª+ÞR¾È>8x/|-Þml?à |rôЇyÉËñsxƒ¬Ó¬÷ïþmǧ<´úêâqùt|->8ø{àAbŸœ÷ܹcïñâ 1a“'Ÿ7É{e½úïúÇàì˽ê#NÞw­Ö¡Åžöç÷ qýt¾ÃoçsÆ<{+_b÷Ì«•‡ƒo ûH¯,q\¤Ž@éé›Ýö±ò ì(?\þ1÷R\l^oë×§ñêÏ ç.÷ / ?Ê{Óqg÷ôaûyh8?áùù÷Oí¼ÚûvÎIç>äÜý?^‰À¿†O˜e'_χLJSðÑ÷šuŸ‚K»ž‘óýtÇólä'Å·þd'ØYñ†¸;yÖYÏÃÂÿñoµgÖÕýgX/çeG™oæù‚Ÿû½Ç¾lãUo?ò¹ÝŸÜŸþ»}oèF¹ßâø±ßôüÁ{ÿ2Nƒ[áõCõ_™Ãìïå³àdñ­ø¢ùÛäuñ×מ8^>Ї Ÿßù×tl̈]tÏÝ÷RÞI]ü:œ)îµnxAqUëhÔ%y¯êƒÆžÁ-ê‚ñúü^;xgŒ—=©üœïsîÅIxšq<ØùEtåÂc¨¿Vð·ò¶òˆì—9 ò«ì7ÝÊÎåŽÿt.ÚŸšÏQw­ŸÕú:‚£<©õW‡7ñãºýÎk£‡KŸ4÷Ãþ7ï~OÙ|yΙ:ëÎot.à¨oÙyxæâàeãßÕ?t¾yð¹xËÏæööàÇñFcÜ$®ë<÷ð¥òò–æ3Ùõ\αuªþYúoðh­·T—å\‡©aO[úçW¨þ`qfuìsŽ­Ÿ<‘÷†Øxóóx8¾ê|.ó?bä3Õõ~]}Uê#Z·÷ï¾g¾Ü‚o¯´Ï*w¬ÒºõÓâyu îú¶ÎÝJóS~_Þ½u„ò¶£ù¸Î—{OèŸÓǢιó,ƒ‹Ô74ÞÏçéCÁ_t®xò¶üýHþn–¿pªÏ§NœŽ§þ–ðÕc oÕ¹Ip¹ Ù_ö=W¿SžD~.öïî|«CéܨÜSþ¦x!uü˜úIvB½ ~ Z}ÍÔÿtÞ’9%ôÎãßù |ƒçé¼¥Ü+ögß:Ç8ûãùÜ›ñœjö€èœ¾œþN\ÿÐ…÷íg½TÄþÀµíÛÑwûÂ~¹?ìo焇‡„oªïÞ@~ºsßãÿøïöUæu´ ëï¹Úßšs*^ªNKtpŠKF:úðŒõvŽ_뇧o¿ç¨ÿì¹­kûwƒ'¼§u‘WuÇó&Ô'yïΩι‡OœO~~äo[g>=7íu/ùsûˆb‡Ë«Ó7×5çÐ}„{à2ñ4ûݺvsiGó3ì“ü5žºu£æï¸çêYáñiû’r~s8®S‡ÓùŠ9ßìqëÎØ™Ä5ì…x½ý/ñÛícÎr¿ö¿†Ÿw¿ÙeçÀ÷ÃmÎ'<_È:w~^< Ï;§î‹sÌ>É#U79v£}Sîq¾¯sÔIZïœçÀyU'Áï8§å%o¨?P/ƒ¿ï¿zRç^ä—­£}ƒK[7ع9‡¾§ë'Ÿ’÷ CW:Gønñ6n<Åú†n>®ý³úßsN샿ÇW_±ü'¼ú¤»êÇÕÕÈó°#ž³ñ"ý*ºýYWy´â—øvÁsðÏ;6Åë³xAöP-|Óù©¹ž—=aßÝëÔy˜òÖì^ì2>gÌ'èÇèÜéœx°s”‚÷ø øèÜå|ŸçounwtEÇü¾¡s'³/ìÅù'ßý³_½é°á9ô&Ç«ªÏè\ª¬þnòÿx{÷·ø'þ®ìœYõÞæãêç —¸§âéê1ÈSäsù%ñuë6óxŠÎOÇãЭ‰]î=Ëù£gÚþØØ×ê±è+ôï‰Äcü©÷VeýÚÇ¥O?þªv)÷CÝSí%{ïû²øq±8Ãû¶¿<çR^¢ýбCð)Ü_\?ÄÞŠ ñ’Î3?‚ß,ŸžçqísõÒTÜ;š'çïÝqkñRÖ7Ó×9Ó[à×ðNâûæýåýì;ü[d:ü“8NsÏÇú$åëªSaÚw“s&Ã÷É£ñSp œVÝ”ÄepOë›bÇœýâXøŽýf‡Ë3𿛺ڡ?$ŸÃ®àø ñVç‹f.Ûå…+¬ûÌ ‹—ñÖîœQ~/÷ˆßtꂇñG'–÷hŸsžþ`øx©ºúˆáâàøÆÉ+ñ³ãþ1¼¹}T1Ž;ˆÎmôÄOí»Í¹•qì{u<ô{…'±â ÷‚ï…'ô½ž£üdp.Ü«Óëo‹¯é/Z:‡Î‘ó»5™»ý§v|ÆŸ>5èÊG‡Hßnç»NëŽè—Ò‡®¬ïISõ£Õ¿…§¡÷6™óÞO~ü¢“÷(ž°NÑ]®Ž%ük=ªs;Åÿ“P}ÃèÝÁ‰#'so>ê†Ã_ù±ádŸðQxÆØ¥ÉÜÛNÛ|§5¨î5œÊW?xß º¡ñSì­:j8‚þÓ¸ŸÏsW? _Ÿx®ûLñCõðéçúyë3÷Ä5?ôò…Õû+îO< O˜bûá|z'£ùWú~ù‰ö OõDËŸ¤?p87Ñ7俬ouT£[O²:¿ù~ùýê²Gá[‹?Ã÷Ñ ¡—ÖþÝè‚uÎIì‡{:žoÓ~úدê?à™«KF×!ñ/~_¾Vž‚‘wWuïÔß6ÿ@?+ç¥:Šì¦{ëýðt2=·¸¡ºNáÇøy/ü0ž,}}¿ÖCæ¼Ð÷HßNySuOü"¿™|Nçè§Ž_®n²çp>áø‚]‡Ç«÷|Ëî¶n8øˆ}¿¬/{oè<לy‹úýü|碛K|×âq;Ç*ÏÇ–ÿ#ΠkÌñ­ç¥wžõw~àVç½ÿêoã¯;O2ª‹´ß ýÛÎC4÷8~¹:Ê9òâJ|bç3æþ¨—Í¿¬n+¿^ßèKZ?ö•¥"?KÞkˆ—ñÿÁÙÖ/Zœó5«O;÷ˆrÏØþƒžûÏ6Þ7Ç7ñ \ÆnU—N—ºH¼˜ÏÍùχwÏéT4O–¿ïÜÒü=½VsD«¤Ÿ+ûG×RÜ —v~iô êoé¬'_ÇŽŒu'Äü…÷c‡«ÿ½ÎÎå‹=²^üˆsˆ‡b';·2q;nì¿øºyPïŸ÷ë¼hu=ñÿò³êVÛ¿KÏ™§‡¼¼ç³Ý—èwW$ë*®wžÕVÿ‹_Éÿç}ê_Ø­àªYõÕó’?È}°Ï¯ò<òÈô‚è\šc5çYOØë²ý£öU_*ù»ê•З¡“}8Þ6‡Æç…×m_ç‰&>sïº.ñ?xïÝùáÓ<¼uª<{„w_ˆkš“ïgwsnàzº‚æEZ×Ö×ʯ%¾­nXö™>Šuc·:ÿîcÖAþÅùïç'^ÁóŠƒðäÞÃ=‡³w~žÞ@ç×D_KN¢qbΗýdÏå ͳ ï ï¯udÙWø8}̵p!¿ÜüŒºcõ<áøö޹˹™Ìýè©û­ú‚C~s“Ó—ŽWWxþúñÜ¿êÆæ¾T¿&Ï;Öô9½¿ÑçP·ƒ×°nòrìLy0z„÷Ö}ª.xõðé G^Ÿ°û‡ÿ©žºùò‰¯ñ«`~HtôØS¼ }ÐêÝÄàÑ:'4x>è|›è\˜Ÿ0w…ë¶ñÜ%]¿Ø¹aÎÀtî΀OƒƒÄ;óß¶ë¯wÜuXWç¤ç4~š_¬^[âÍÎÙ2§$ë)_=Du'úsRo£>®sb³ÿË^D<.O!¯hë/ÍÎs»Otsù³Ø½ÎQëüÏý7gÄßw1½Ñø3:0Õa Nä'Ä1ü¬~Bü4ž¿Uý¹Ø5¼;¦ÏW½„¹Fóßµömߺñ ƒÞxpdìfý~¢s2sÏËŸåùÙY8r¬ C/“¿¦;‡O“÷Ï׫îVþ^~QÜÃ^Š#ÄìŠüšzóô7U§z¤#%î‡ÇÆ:ܹg“¹»­pÉêS=Kõvø†Î¡Ë9ì¼òÜy]vÎsU6ü¦s'Î÷<ÕŸ 7G£óœâ;7)÷ºós¿ç>l§ë×¹ê„ažÜúÀƒÕÏÂsÐáÍ÷ˆC[/©ê ¥žÐ}‡ûšß63vB^¡sVè\Mï×dÞÂóN{õ¢-—Vw<<]ç…dþIëùr¾äAømóð3á—úy×ÌÕ2—#~ÝýeËÃæ|±x½®_ì”ó#ŸF¦ó†ƒ'ðÔÕsнQï¨î@ý’8ž}g®ÞvÎ Ø:×ð7±Wê¿ðñÕ§’ŸO¾[=$ûèç:׎}™Ú£î}äè$Ö.Ƀà?;ŸH¾?ù+}êèàvÏßw>Yx[8U¼WÝ7örj÷;·¥úŒá7ÍÑ»ÏñWÖ½sÂòïÁõËp*^H<V_9ñŸ{ÍNôþПŽÀÿˆCØÇÖ'˜§e®3œø1üÇdÞ~Ýy£OÞ0Ì3ÿ"¸)ø°|©ú:ùæê¸±êª?žõ´OæFˡgÃçø=8µq3½¼Ñ÷«êûÇnU_?ù¿ê*æ<›§(Ã{¾ÖµÓ=œî×0&÷;ß3™sùÎýðÏn~ªý1á/èFâEä½ÚG|ÏŽ6¯—ø_Þ9Ú±küuÃÿU7^|ïÐ[ÏüɹœÙí釽lÈtáøuõBÖÇ>ˆãéÁñ—æãÐÝaW;/4|sW½h8%ö]þŸÝâ¿è°z} ·rïÄyü 8ZüfŽRç\˜ÏÇ.ñ³òÏüSóÓ¼WíœÉWg)~<Ç«:¯Á…Õç¥Lß2|^ /…§±Ýwºî…ú~<ïí^à_ø¡âöÔœ¬ðÞc¬‡/o.?šÛØùNâñÎ3m¼mnPü-ýAþ‡_²_­+NþE=°<yµ©=¨ß²¾ü|ó‰ÿœƒàåêÅ'—ò>øóÖ]æsÕV#¸F¸u×ç .²ýù<ø¼úͱŸêHÚg3ÍÕ>©Ç/ìWç#?Ë+ˆ¿ñÇâù{}zÖ¹¼‘þ¥)oÔ¹ò­£”ÇŠ}µü§¸þ*žÍ:Žû¼äOÚw•<‚~ÿžOýáÿ;Ï;çQ^[<.óþí7”KÜâ^Ék´o2ïçàE«snþÕX÷1ü=ûÀWøÞ~©ú.êäõ3xõµ­ŠÝð¼í7}U[þ@½òtÝËWªgäçå[ظ˜}*®È÷«¯ÑW$þ¢»‚WPï ·.;ç^tÿá6çÛ{8òzìRç!/Àgí»È>ûSÝùxE¼ì¼é/O­î7x%þaÀÍ©Cˆ-͈«ñ ârñ™¾RÏÓ:óĽâ]q|í<û9}¡Î·¸Bü ·Î5ÏÑy@x<¨{!^QÖ¾¾Ä‡Îžºs××°ò;ð? §ÂSxv»º]±?~ÏzŠ×Û×~ O³ôÒã—}쀛kÙåúõøÝÖ»få«SžsØüð”—ƒ_›§7<š3À²WÍÑE67À|˜øêÂäsùeq£:<š9àöŸaoä9ð>xuuÔp{&Ïæ\·<ïË/X×òæ?æ=Ù vpÌÏ['Ï.Á9òÓxûѾŒø¸»õæ‰KÔ?Á÷xyÓq‡ûƒ_ªÝK½ûÞþ£Ø‘ÖïÆ?6žVœ-ïJ¿¶~$çþ°Óð;Û:ò¼wìní~×A}zòFÃ\¾Ÿ§ÂßÖW=œTüûÍ.À»û®Î\?€çˆýÇË·;|kç㪗ÈsÁcð»óàùÕ•°žã˜?öÌ£ßqiqº<¥Ï‘÷bOŵö±º ±Gcþ¡uÅtºƒ³7¼‚ýl?tÎ{o}|®sçsñ²ÖŸÝ£{á|zNëf‹ÆýN£~ªægÌGÎ}rßá¥òèú¤éœçÞÂk­'W'®N3ï Ã]êïÔñÐ_é\²ìGë SŸwȵ^A?FÖŸCǤzÁ§ì¡ù(t½«CŸï¯þ|ÞG|Z^ßü,õuò ÁOp™ç)¾^òü­?_t憟ìÙßôj{néÂÇîê3ÂÊã):ß,}ͣϋk:G?O?_ç­ÄŸÒ‡*OšýtNÕÃ7ï´ ýFc;¢ž¹zÑ+òÜâIy÷o+¯å^°§å™âgõo¸/âYë+_Œ¯ƒÂ/ºßåâ×õ¡À‹òî ;Ú9ãÁ¥âØò/ú=ƒ×ü{çæ¨·®ì|Îð¬ê‰Ü ñÖxÞ{"Ï/Ú¿öyÇÏÕÞ›,ÏŸùËâ6yjïÙ~…ØqиŸ¬ýôâoáQüû%¯Ü|QÎ/;àþ¸‡=Yv þÆÿ²KcüËNðÞÓú±ƒü¸ºYvˆn~_í^Àmæ[‹ï½guâß«Sø¸|pþÝùVÇQž^ßGø ÏG²Gξ(÷Îy¶nøòö»Å¾•¤Kû®/»}1ú°²µ_ôur.Gó9;ÿÔzÕœŸ{ÖúîNüÒo†s˜:Ïë\6ÿ˜z8¾†#Å¥>Ç9h|•ûà|ú}õã~3y*xSüX>"ñ ^Ø{X¼ ¿Uýà8^ë4¸WpYyqcê7Ä©þ¤—k]ø-yv£ó'“«ÛdùÎ5 ÿ)žªQ~¾s¨â×èóÃìcy ¸ÚÇð$ìqóÄtFósØvHÊïßsé!í·ëÖÅ í NÞ]½¡óX¾Zþ!öĺÂužË::­ƒ‹ým]î¨~MÓ:éüŸOŸ?ÅkxÖΉÊóÕþàéÃûãå›ð$åó‹,x˲5·Ûï²aUüŠï-£Ïo¤kà¹á:¼Që&Øñ¬7üÓý5ßÈ:'þ÷ïÉËOæm³ÇÛpã³kO??ÏN´O8çF¼8ÒG+ÿÚùßÁ êßÇçËûòüTõ´rîàPç­u4£ó_ø{v´óœÂ;4Ÿ¿ —¶~0|Ÿ÷÷ðlëIb÷›¿7/6|¡8Ý:ò»î·¼`ëÍ3L\)O*¾g÷ðm­¯ 3˜ï­^Jîeû±ä«ÝC<¼®zãÔMŒë6ì‹8OÝ:óÛƒ?ý½úHupw÷î<¼¼Gí>•¼ü1Ö1²îíãÊûاÎñJ^Ÿ)Úü—s|䜕såO»nxŽö%ÒC×§^Ü÷åÜ´>WÝ:>Ô\âÜGç@]Øœ/<õÒÃÞzÌ ÷˜<4üà>‰;ųpoãñlòÚì_ðÈdΧ¾¿øÝwúö­Ï“÷ùÇoŸúÕ›Ó|,¾˜=h5¼kó¤t ‚CܸßÇϳWÍ?Oã§ö]â à <+~²ý$áà|ª{•{Û~ ñ¥saØû…Ïp.:ÿ7Ï]{Ðþ=õ)áKÄ-ÖÇyïœH<»Ï .­Rø´Ø¥ÉüGŸû¢mæþªŸïòÃî;>Q½tçâªOˆ]aרÖoÓ›šâëÉüŸ²çÇ^~sß×ù‘ÿR7#ßß~У¶YÙöCÞœöþò)­C™žÿɼÛÿºÝ6Û¯Rh½åuå•ùÝÖÐYKü'žç‡ØYõ½ñ‡ÅxËøkëj?[·~Íñœùò'‰kú\ôj‚àÄæmœŸøÃêËÆ®´¿)8=èÜÄéç }‚©bؿƋö3üLûWò=½?Éÿ”Í=jÿ±{›{ ¿ùÿ⡬+¿ O°ú5æ8ç9=Wyüxp–}/;™·×/zÔóŸ:èä}ÆvÛþuxxøMÇuþñŸÕI€§c'à×Þÿøçêbé7T¯¯:ç ë0™söWVüÒð/ÏØ¡ÖG&^Åk;¯î}çOqIï{ñåHϧv,öjþÇîÜlæÜC]‡¾ þfºíó°>òŠÞË>¶þÕxç0u™Õ7g[>#q}ã¡ø-üjëÍ!æ?Í#Ï9q¯Ùñ“竽Qz±9×~®þ3~ u>¹çÞ§qaò xÀî#.÷½<€ó$.Èïwžrü{F¯¡õ­ùëT}añYü ü¢¾QÝ#v—¿ÂGÕçuî;\H¯E¼“óÝ|vÎSû)Ý©ïý…è`ÀMøv”ëÁo­ÿÎy‰Û¯|ÔoÆXwß_½•ô‘Ù8’ކø¬|fâÔÚ-÷.ö¬ýñáWÕÏà…á¦ñ¹`ï‹cÔg½Z·ûÌ_x÷/ áµÊc'>p¾ËïfŸéxŽêmä|ˆCÝßöÆ~©¯Ÿ»¿Í#éãá´æ‰Å×ö9ñј¯h~o¯ÞXÞ4qšû*~ÓG §4ÞL<»hóÉ6^w÷ Ó:õ“9Øëþ[åÄ!ßæ¹¿ŠÛÜOv‰=¯žÝàà­ÞÃ<;X¾!v-ý^“ù‹nýà§¾¸Ê †/ÈzT·!¼CŸ3þB?s|Ñú8}åè»f«I2v /V;G7în÷ÁWìÿÂÿÁ?~}*ߥokt>׋‡×8÷ø%q˜{‡Ç²¾±¿Ö­s«ÍwéˆxÖ)êk›¾÷ä>Û!v7üÐdÁý|ÔdÍ•Š÷úÞú¸²N­Ç†á8:ýò…Á+­;H_ÞŸ~°¼wò\Íg™{Àžªñ}ê:·ïŸúýH­‹ Ÿ‡ïzæ<ñ~¿zZâü_ýåÈ^»×í_Îz›wW“¿·[_6§ÒC鯕'Êû´i¤ãÂÞº­‡ 3\î\×Á{úñé*…o®îýÓì;=ñö¹ñ7â;÷Èóg½Ûï¯.î‚_ååá¹òwÁOðƒ~ÙêJáåámu½ù¼úCóÞè …®¿Î:–‚wé Æ_”oÍy†×«Ûln‰úžÔÙY_çWÙgüqýNøÞÆmê^ãÏÊϲ[YûÓûýÆ«æù&s7ÙçWž´Së6ØëÂN»êüÄùìoû²Ÿú_{Ö#6(¯b_ø}úG£o)8Ôs·ÏÞÖÞÃ=æoЇ“?rËw¦ÿ¼ç„ÿNÊnÒó(—óŒoR羽ž$n(¯áüãåFùÈæÑù¡ê(¶Îq¤ƒE/h\GÁÿј{Þ­û~ÿèãzÿÛßšøÐyï=ω«§u®C|½ú‘N€¾ö§Mí\óàü@uñëü~zú¾ý=yøÃ¹¯¶Ž#x­¼SÎ¥:ýbíû ^t~ü~ñ(>ŠÎ ^SHî~²8!|)ÞÈÜp÷ÔïÚ~¥Ø¼7~±}%#»Æ´ÿ ¼3»Ñø?8Y<]=õµòñêQâo}?»â9ïMý±û4ÔíÑÈýbç«£™÷t¯Ù}y÷¹¯þÑNÛúêÚÏï\·ï ¿ ×çžv§÷°:ÉÍ«À9—â)¼§ukžÏ½’ÉóÂÍú}ÅÕ%ÉçñWík þ._)﫞,ñgó±;ð—:E¸Ÿžáœ7~Ô3VÚy8GñtÂÛqo=ɼ þýA¼eQýŠüXqWî©|nû¸ãGøñLû'cï­_Ïe~®ñ‡¸@Üžusª· N–ÉþÑWàÏ[ßšûÚ¸ƒ~ý–‘¾póòÃùs¬Óú鹨•WlÜ­Ž*| ;Æz~¸Ÿý¬¾´ø1}æ#¶ö×>°úîÊ/LíÔ Ãóß<‹óiþÅÔÿOæîÿÅW<þI§·¯»íŠoÝ÷ n¨}n­>‹ó[=¯àA~Ïsò_êËøçöÐÁ?e¿ÇʳeßéèçÄXOç¾ñ•ºöàÇê|âmò¼xÛÖsˆßô†Çjþظ1yÑɼ]wúãõ¾bÐGÊçÓ·lÅô<‡‰óõî…]®.Oôžœ7vD¾Î¾³[­½w]Ñ`Ÿé;Ê''>Ë{:wÕ%‹~?Ü>áQxó§ù¼…o½û?8èØa_ÿmçó/ûôÐ×Á^é›·ŽêÊø¥1Ïäï݃q=­ûʿ裊](ŸU½zñ®: ÄïêZÅ¿>?};“ù“}±Åɯn¾´ë}¢âYúÎ9Î1¼å¼Uï4q?sÏ䛇¬õå‡zru€SÜV<&îT_aᇱ¾šóßú穜Ì[ù'^ú©— z#ðIÎCuÈrÎ:ÿ’Yü×z‰¼ÿ¸žhWÀAs®ÙbíeKŸTû¢ï]E甈;äѳΫzÓÎTw¼Íöýrßñáêï¬#ÿ¯É_ˆGø¡ÚÓé9¨_×;Ôž%^Ý*þ³^âáÎK˜Ú£¡¾†ŽyêHà¥æ™ñŒøÄÜ«êèèÏùò¾ÖA\Y¾MÝ…x“^©ü|â·æõ­Ug^>"vع,”¸zÞ×|ÃWöòÕí2‡&ç8õÝÇêýÆÞW©{WÏ~½ze±O寂ë³>Ã| vNKþ¯ýÙozÈò­Ûñ®ô&zŸÄ©üŠ¿×/âó[Ÿýñýåäs’·€—Õ76ŸšóÒz³ôCľ´~»ùdy6zùêÕ»™¿™?;‡Öµ¯jŠŸª éüú‘'s¹dÛçïò¬á¾éÿ¼à+ß8ì³O˜ßõðüÕQÌ9eÙßÖ‡É_DÏYþ¼uò.ùyƽÛüŸ8ùãƒn{îõësŠòüÎeŸ3vß8æKàqpõyñçS»T| ߨúœà:×xBþÐ9k¿lìIïyê <æk_Üp×{ê·w‰«rÿÚÏ™ó_&|—÷ nœÌ¿ôü}ÖøæÀD'½~uü9üGq¼9â}gxά£<ÿîÜ•g ζ¯õïôœÃ—è+/Ÿ¡¯>v^i=Eø¸./ßi.’ø2ñ]ùGù<|œùáÛáÏÚÇÔ=·N!v Þ¶ÏÖ­ó¯Gs ŠÛ¦6Nõ=í¯Ëùm>CHÖŸÞüjúÄ›êLø•òúêìÓ¯°`­=v|ÖY7 ¼YüFûÍF<¼|9^ÖyžÏ7ÝôÝ'ÖNTo5þ¿rO:Ï+÷°¼ܧ¾Omø•ð·Ø:¤œ—œÓÚQþ¡zùüÆ_êÆñJìLêó½C|ˆ7vîÕå9;&8Áóu¾‘üqêœð{xíy?ý·?¬ðÖ/Ÿº÷°s¹ò¹µôÓ§ç¦~¡¼rx(<©xªñ®~³ÜƒÖGÝ»Ž½Ïa=ùq|ûIå3õq‹sÌ·‰=‘7âoé«èg™5Ÿï—ÂÝð…y6© ©>vîeûÕ×ç{zÿé`Ço¶/\þnÔ‡ïœTG]½;6šÿÚO>Ký\ÇŒÎtqP¾¯ùzòôú¿“/hž|zÞÚ‹mIì€:Lq­ÏkÝŒzœÔ=·ŸoºÿKÚg¼^>Oþ2ûEߦ|§x#ö¾«þˆºÜ¬ƒûÇów­O îâ×ÅÍksïúÔò€­×Õtrâèòèã¾ru‘ø'çD?†úûÌskœ4õ#+ÙüXâÊê&%ή}Î=lýAìyñ<îÔu‰‡æ¯õ/-ûgÜÃôóåÍ9ȹhAò¬ëþ²÷‡Ÿ¿àל·Æô[Õï©—Ìyì¼€à‘Ö ç\´ß)öYÈÏðãõ‹©{Rná€þ\ž«y8ùuuO÷޳‡¼dò?ãùXåùðøºøv9ëÔxØyr®ÍµÑÈOèhŠú2uöêµc/Õñµ?Q>%y«ÎiÊþVF½=yç=ö_ýѸþƒœ—Yø7ëÛùúZáQõc<½Cºœüax¸â÷ð­ßK¼Qû8æ#Â3·¯ÅÏ™smþvΓó. ‹­ÿ™ßo)uøX:e­‡™Ï>}Þ1›üúÃ'üuÐá0ÇÌüô‘MóÐÎ]ê:w;ç•ïÄm­³×?'{I¿¯uNòktfs®j7bo{à¨ü^qº“ÜOç¨sÙÕqˆWè!ÄO”ß`·ô…ŽòŸö˺•W žè9K~ˆ}ïV·mŠ Ë?՞Ķ?8÷¦ºoâ_öL¿>¼^dšß˜ÌýÙ^oüä°!¾T /(ùåÔ_¶^@œ ŸÕ~´Ñ<‘Öľòçì÷òïl¿éjwÞ\{ÔýI=Tù†Ìá0lŒûFqpûòà—Î%†çb÷œçy'½rå×wéPŸ˜ûP>nN½Ë¬úSö¦sîÌãϧv²~?ã¹jOÒ·”sʎ׿;‡ìZë‹äs3w¬—*.qÎkÌ[Rߥ?Zýmòøê ç}|÷]ö×Lþù¿¯zæÛ¿³“οYÿ(® ~1gÊû»ÏìEû$ÕUÒ¿Ðÿ®/Ó<Úé¹i½pýõ nT ¿Tß~Þœ‹Ÿ|Ì{>Ùú|*Û>Öø¿Î¿4ç7ýžêuù}ùyŸ+¾d§øÏêź—ÕI˜ÚÑâŽæÛrÏ«C1šS ÏVoo¤7-Nj½w¾¯u ±­·K¼Ò¹,t/µŽÏ=½?­ßéy͹4o˜zõ‹ãú眛îßXW³óÓÍãÁ÷ú”ÙCëÓ:“Ø…Öᇇl\‘ú!x—¿U/:žÓ”ø·ùfþeñVßxÌn:þàdá~›=ãÊýö™,øÍ}Ž»ãÉš,X|Ü6Ëø#úQ“ùS{1Y°÷Ngüº;þweúhòàìðdÁy?zü Ï~Èdá=ïûí¥7ýu²péâ«¶úàã' îXgƒg¬÷Is'Kgîžsð}ö£«2Y0ÙiÁ/š3™Û¥·¬qÞ|~Ÿwþ ?µà=+l4Y°Õ¦Ç~ú¾ÿ;™¿ùA›ßtôdøû¼Oßï‡÷;wÍç|c²àc­ÿ_ün²pãçm¿á]ÿü÷­ß{Þί{]°É¢«túé>s²ð;^ù­¿Ò=Ä :NÓó7Yz¿'óø÷¢/~²ð+»|éºû7™õg^øÄ÷>[œ€‡f_ñ¹“E—~øª—ÜñÀÉ¿êW¿ÞøuŠ“¹Øþ–+îüÄdÁ‘OûКí$Ÿožl÷/ó¡áÇÉ¢ýÜlÕí O4Yôñ>râ¥O¿úv¯úìýÜÄ“p,NùÉÂU>vûkVû¥¾çÉ¢U·ûÖVÛ^ÀþvÝ|¯ý¢;–¸}2ÿ¾¯¿e¼V}ÀdÑúë|椽néyZ°|‡%_ûüíüÒdÞ£o{ë ½³q½Ÿwî¢ÃÙý\ø›]NÎ{VžÌÿÁwŸµú«NÞ¸Ë1¯8þ¹“ù{ïsãoûÏu›æw&óÿžþº:žï…s¾{úû6úeÏÙÂ5ûÕF—üÓî¿ÅþZýÉ’•—ýÛc—^/§~u²xý·¿çáY…ßm~qÑ[—m±àó{L|è oùõµW÷¼-Y|Ç*»œÿë¾÷¼ÿøÀß{æiø+ñüdÁÁ‹–üõ£×çX´îáÝ÷yOìçÍ[~ó¶Wyìð>Ó<߬çï¾äü‡L¼ëœ-?è1“y›þãG_|à' <à€kæ¯þn²hñ«?»èažÌ[íCÿû·=Ñ}_°Ó³Ö»åƒßê9g_ÜÏE§mý‰Ý÷~ÊdÑ·~¿å:`øû°Õ»/{â:OéûusÞ|þ¢m1ïIŸ¹{2ÿýGîûá3>×çMëô&‹÷Þôœ7¿øÒÚ­ÞÓi=ͰNy^çgÞVŸ»çô¾wøü½Ž?ñÍßdÞ/žqܾgߪ¾Õ<îÞÓä/' Oøßž·ú»{.çÿbõïÝqäáòÍ“ÅïòÝÞºÃdá“ÎÛê«_¼_ßáN¿Øà¶Çýóþl~á{Å‚K' Yiûþ훓Åk~é¾k¼~QïåÒ%/úýo¶ÿ§¿XõÕ/=üqßì~.~á%Ÿyé>ÐÏ÷þ ÷ÞügÿsÓµÎÏüóVºìegŸˆ‡ë=çÜï»`ý//úèý:¬ÿÈÞÚ§ð¹“WÝùô¹‹žÚõ[|È‚½Ö|Ä&‹vúê£_yß×îÖϽèE/Ú÷«O¬®KðôdñŽ'>ñÊW]S¿Ó:ÔàŒÚƒÅ·ßúþ³¶Zo²h«7¾îI¿îpŽnßãúÿT}⮿Z¿èþ-Øì°‹v?ý}oûÑs>­ƒŸ,šÙ{£7þnaíŠ{cýžþê×^ºòÆÃ÷Ç/äçñMõ‡ì´ºˆðƒÅ ó÷ûï×°ýÁ½wðǼwo¹ò}>tÿÉ’'}ó®—n7©½ËúTÿÔùI™:»לּÁïNË—Ä­½çü¡÷fR/XûïÜðßìéü›¿Å%ð”})ŽqßöYû-oØrë_ÜÉ?;?žÛ=HŸyq×âUöÜaÑ—Žës»GΩ}a׋ï¿.úíÓ6øÒon«ßcoçy/:sƒg|ᨮoêDj¯ìÿa?Ù™ÄÅå)¬ûí»Î<íyþ˜Æï}nö‘Ÿƒ+ìcŸ ÎÉó×/eêWr¾cÅ{õŸ‹ï÷…É“ŸpÑdþ—oyõ©s›,Þmé¶[r{ÏGpI×Ï=J=߀ƒ}Ú;6Ùâ;Åu‹}ðKšycù‹Øó@' ÏÿÞÖ‡.{Gícqé·WÚg•;VÎMαüVò½î-¼ZÜœýõ¼ì7›<Òdé6+|Ô«>΋#j×}ÿ:'©G®âW?Ç^UG¹ë:ÅiíMDý\ê.Yk“¯Ÿó’cª£›º/žŸÝ ¯ÖóÇžußùë¬o×aš'„K†ûšÏ…[z_ᯩ?l½ÜTüÿNï'>µö,üvÏ…ó»‚wè:/ºß¡¯?çÅ«W_ °/â=v‘Xô•ÓþkþAGÔ.ò—øþäWÕùöœ¹g=±+þt¿cª Ðõ‹_-~Èùwñ›‹N8ûñߺ{½!î Ž÷>üAÏyì×â%ozÇ÷æmU»Þ¸vª¸*øŒÿh¼9åŠÝvÈó;Á­·n>N´öS}cæx!þ†ÿwÏsþÒ~¸/ìtⲞ¿úð©wðCìlü­:äúÿœïÎ÷>xŽ¥k{ÐKßüìÆSâ%Óü`ítÖM¾µöbþoù¾›<²çîN~¯U\.Þ…#ÙGóá°âÙ¬û’ÇÌyÆËßðÆÆ ð;&î'ׯüp½³W=më‡,®m¼{ǵåÄ©Áááµ'‹Þõg<è‹Gú½S¿Çl¿xñœ83x¬vÎ ?ÅÏZçö)å|{ov¾üÒö)Ò ÅwÈS»·âêE7}þ”W}i£Æ ð-<†Ypã7.½õ²Ý'‹>ôÁGžxѺÏ”Ÿg'j§r¾ÜçÅ'.øÓŸÎ8ºë _ù³ø)ö¯v‹¿Âc²Kx‹ÝV~ÒÇ\WÖ牨_È}pß—œöã½^~ädÀÍüå”ÿxÚiAyÑÅOÚñQ·nðü!Þþë9˜î‹ºÆâÏâ¸0ÿݶړö¥E}còùÅìÈW©Þ½÷e××%;þð~Ï{úÅéãóï±;ÉSô|ç~ÉKöœç~–ÿç§ÅIùýÖµ¯-ü«|(Þžò‰[ž<÷#=|ÐWÐï’ú_ù(¸0ùþö[V_Nýu>Wj¬ƒÙüròFxaõ³ï™¼V뼓§oqêÞÔû5¯¥ïX¶úÜØ‡êÈÓÛPï:õ`ì3}–ä‘ÊÓ³£ÕY×Rw•|²zRyìæ]c‚×½®ü¼: ó6«oE·-ùqyIù0ùÑYyÇ©®Aã1õ÷é“m–|ˆº y¿æ›FùQ:òF©{i«Àyòž]Ïø¯ñ\uRòýê§é±Ð¥i½ó¨nºóM²/ì…~ÆöÕä¼Ð}0gT€<^õ@è.ÄŸÒ9í¼š¬Û¨_¦qŒ¼®ü}Yõxî§>ÍÚשýoÝDuSR“>ÕæÕí¨_³½É—ûýêüd[Ï£1ùÝÖ!Ù÷èStÞ[âný$­×ˆ½ëp÷ü&Øü¯¾I} úE²_êÚ›ÇVßš~yÔ~¿~ÑÔ©´^™î’ümžÓç[¯Î‰žžãÖq$:ÔÕŽæW:/îµõ–×—‡×½ã_¢—×>{ý #ýÑêêµ>5ý¿sè÷ôQªC°‰?ÔÙTGzÔÇÚº^õ[©WTÇ®þÓüËä£7±§©Û¨n^û¨ƒëÅ5êô]µ¿$uG©+ªŸë>Žú#ª37=oÃz¥³ýêéö^Îgï…:ˆØÎL=aë FúKœáÞ¨sT£n°õ ‰CðåêxÚGšçS/Ïÿ«OlݪïMý­ºÆÎPçûZüsä^»~ãçö8íßn½‹þ|v›.Fë˲¿£9­­ ­®Qê¸ZO•ºÚî½Ô«W_H`ê+ª¯›}íç©O ˜çS·×>HúNúdÌK›úÖ­¶>9÷©}ê õ±OÕuÕoJ§àÞú”õ»­çJ¿Yý@ìGuÃÒo«Î²õQ©—àèU/&u_AÏ%uôÕ…PÿÑþ"zŽêÄéd«£Iý²z ¸­u¯ñ—êåïÄñÁÿÅ'ű©Ÿ©ÞVÖ«ý8êÛÍ ¡÷;gÝÕ©ÃOúßéˆÚ¿F?Üü!z%™¯Ñ{jþ@—þCú–[—J'"ç²vÞ¼†ØÙöëo ÎnÝyðEûªS/^]Á¼çh~Ú  ¥î1qˆ¾ØêÀ¦.ªunü6Ý}ssõ‰±Kî¥úÅø½ê®g´¾JŸ5ýîôûÀcyy’!®Hó,™xÓ=íç¦?«zÆt‘S'¯ª·ÈÜôî3?Ò>Ùü{ígêïà4þ õÐôÍ;0ÿ)úQêÕë³­³§ÃJ·G]ÿ¿’úæÎg„—ÝÏê£/V§h4ïÈ:±Scû OÁù ÇÃѳã7‹ÛGý…ìçûðgú—ƒ¯ÔyªÏW²®ÎmõÛàtë4®‹UçmŽ}¬Gõçà}îÁóî_õ•Fó™«Wf^gp÷õs~¶ùN?Ý®q`ã¸ôU;¿Kj^ ÝcuÓtyÕåÇn©¯,~7GHÖ‡_è~°ôݲ/ê ;K?Pü/}¹Î©Î¿ãÚ÷ågµWìt¿ýuÄ÷®÷=Ëü?:©U7ª¿XÝ|Ö¡ÿð7­ÇϦ>ѺOéÍq‚gÛ—£N¡'$ÞÉùµícɹ½zùAO{ÔÌÙC\\ÞuÍqó{ú!ý|õõEÐGN_Ù¬¾äàÝëæìöÁ=ßuϬ¾Áê†é?`§R_Þ:f8&ýÛµwæ´Š³óüêX½_y€ø{}ð";Õºá‘o¿GâIù þÙÜDqŸûÐy×ÑKd_Úߪ.º~æX;çúCØñÆ ôŽb:7•^ }s¼Ì­ Ç”óS;9êK®^ntzc¯Z—Ê~uþæ´.w¨ÇÎùijÕ_Ñ™óÑþ§{÷áÌšÚ¹ƒñ£íKÍýõþcýãÎ% Þnß•>YzÜæÓGv¾Í›N_îX^ª~jüRûTèšÓÍ7·"ö®÷ü3N'ž=‚ñ±ãí¿ð¹ø¦Þ-^ÓG,^Ö¯áyü<ž®þ1ýrÔùÓÃ5'S¼•ó<ÖêþEö±ö/¼Tã9}Lôµ‚ Ù‡êØúS;/"8%}ïåõõ©ó«ûÄ]ìø´o¨¼=ÏQ?yq™8lZï=èÉòOÑì~Žâ†ú?ú9¹÷É?ï¹ý}uŸÇsºƒ7ºÿåMR—ïyØ/quç~Ñ=O¡¼Nëàáíä•Ô¡èëÏ«k?gìAã{sJsnèix_º/Fß/~ŸÎv‚§;W\còì©+ôþèÜäû;¯Æ}yâiç¨óp‚ò=­_Ñÿú\~ :ut³pcãÞ{ë{•‡QW•ºÍÁïä=û\ÁôfàÉò×ü]ôC:דîyŽÁÁcþ¬zktâ«ó2ÒÉÀ[dýª\˜¬“ý¨ŽlüŸ}ï}Ê:±óðœ—}îz—gʹ‰òý­ëïÅþzŸæ¯èwæþ˜+Ýy"ñ›Ñuö/}}[€§ÌÏówì”õ¤Õ9ñ_yŽæeb‡|ªüqÖÕùa¯;—lŠ ü^ù ü]Ÿs¤×Øþàô“ó§ø€êgÇïµo28KüÓ9¢ð¼ùÎSݘöõÑS‘W¬þ,¾ÔºÅ>_ÑÉŽ½bª[þº<$ÝÒØ_ÿÞ÷žÁ#Í:â~ñ¸~DóŽ3¿.“çè=£S^ŒÞ½º·Îµ£g˯ç\ç`·Ü<7úq‰/r®û\Õë r~?E*u_½Ç=¿ü?½yÝ©ÿW÷Ôu«vâ#þúª‡¾ú†›g~9Kǽº ø|÷;÷•¿,»ÇÞuîý¶©ýêZÃÛÑ¡kßr>_=‡x³}Ò9¿øíÄ ­Ó–OäWªG–z“‘Eqqóo±Õ‰I<âž´.!þŽ¿Â_;ŸÎ½çd䕪_Dg ëÇ~6ž— Ÿú×µKÑ!ÄKÖȇE7e¤2è˜&¨?”GŽîNïŸú‘ðª­óK}>O}ó²±WÕaˆÝqÿ÷ç4®Ï{Ø?q§÷5‡nñyò»îEq@Æ9í¾fŸñ™G«Y¿âÞ|ž>çÚÁ{Ï稽•ÿe'š‡Lžºsô¦¼t×Q="û‰gнV·^|]Ýãø‡ÄWC£?:Ïž©ýrìZõêüžþrs¶éÈ/†n¿^tÛáËÚÃÔeÆ×>èrÙKö>†CŸLñ@ëèZˆK:0y¿â_}ææ±†Gß?~­8Í.ÃSûÒú”Úu=ÉÔ¿Š½û½Î_£›|"}žÖE8GÙ/~C^_½FêxëÏàšÖÿÄÏâ-ʇò£ááZÿ‘ºí>oâa}RÝ|9ÝÃÑœyq—º­ÖY%^­2}Js¸Âwt—8:öÚùR᪫”¾Uq';øAž®:YG~¿l. ~Yù£Û:O”ÞKxèêŽò>Étù'ú­ŸRÿ6Å'C<¨'úÚ­T=àLqUõÂî­+;èVÄîV?0ûR} óåð9wx¦òxÕßÞ9'êüä±å%sán¼=|ݺ:óÍã3¿Ê–ØGö*¸¨<ŠºœÎ© ?Þ:qDê_Â϶ÓúãÆó¹«gLO5ö¿ewš?ÆçôÞªdOÔ_ʯão²yŸúçJGu¨ðIðœõhÜ2ÅEã|KíYãœÄÓé l¡¾¿Ôú6|gð‰ým]ÞH>©Îa>¯uu£ùm㺩ÖwÁ¡á_Ü_ñ‚÷¯¾löUáTï-õ6p`ê8‡9BÉ×X‡±^ë@áÜ8§y×øWëÔüUì“ûX¿ 'iÞv¤¿Í¿øÞúëìCýHòr_œ—>•Ú¹ò4ê›ñ1ê§’¯„KªgMW\Þµ¾±ìEë!èUǵ0~«uq97w›ç)/“8@=WÏ­{Øy4é·Ô‡¯¿±}‰Ÿ;§Xœ™s#/îüÂQ#>x˜wD‡ßœL¼º¸ÛœÌÜcþ`¬{ëüµ~?J=¹}WÔxž6ßB½AîQç $?¯ÐÕâßä[Í_™SÌžEwŹŇý@ç»ÇŽ©‹TGÁÎößÿó]¿Z|Å¡Õm„'ð!ž«ŸkNEêAªçO§1þŽÎVóçê"œ÷Øïk?´Ú{~r÷žÕ!¥ÿvÍ.ŸxïoVâ›ÖÛÐ;Ï>ÂÕkÇ«¯˜ïj½Ìë³.—“|Ò»Ÿúðí7ºd˜‹'HÏ8~üê7¾Ë.‡n9ÔÅ>þ7ó›]9õ2ÁïúLjÇÔAŒê=:g\^>ö _mNRë_²¿ö®l7º’­5Ç)Ï_ç8VO×\žðç×>ìxÄ®ç¶î²ýxÄÄs Ïå§Ô…µŽ(|€:ïþwÞtÎYëÛ󳿙m.KÞ纵?sÐÞK¿\;Ð>+õ£x=v?öQ<ÄŠëÕOuÞeÞ×yèŒÜGõæÛ˜'Ò9ôcó9òïx¡ÆË±#­;ÍŸò =¿ê¹¦õ=ç­÷4¿9¿?ÎOµ¯(8Þ}u¬Íu žl½OÖI]Qu;sÜÿKÿ~éÇ?ºÚ/‡8#vÍœrxÜ~¶>*ºíÑoª?õ^ìýÙèHÔ>ó?Î {àÿå]}ûh^ùXOÛ}¦wì½;·“«9|‰—œÛž×¼ÿ¯™36ÌûH‚ºUþ¢õê¦Ôså~ÑWŠËÔÓo‡×ïsÚc[Ï6Ò½­ß¥‡žïm]ˆùEY·Î+áOì£9ÙÇë·Þý1~ÞßúîkÏÍh¥¹lòBö£ùY¿—{Ù9 ð/Þ qZõͳM|Âÿ°‡xn|^ûqä³~εsÞþsõ£$>ª=;vŽYò‡ì™û…ïò§õ¢SÛy0±£íƒ4·>û罪s­.4vYÜëœw~Wò¥ì<œãŸÛxÆú^wÙ'îù®·´¾¢s¿ï]ç3äÁ­«çË~7•KœÜ¼^ø}vÍz¶¾#÷Uý3œÈO™_×y|î9ýääŸððûÍŽ·”¾kìiñƒùž©k½y•ß÷Šl8øÝQ½]ýPö¡ýEáð/òÄîAóêúäÅÔçšc—ç†SĉÎÏ»Ïl»ïç×è½VoÚ~|Gâ˜ÚÑœ—âþ$÷…=³žlÞlìu„oÆ÷Žh?ôè¹Zÿ伊«kŸèþçU—šþlò_µúÓï(_Å>´>-ñ˜÷åWÜóÚu|bÎKã§ØuûÜ÷Î<_qðÅ V¿ñ„ý6¥ßÍ¿‰';ïkT¯ÿÖeÜ3Ïå>¸Gc|âÿý<\e®Yeí/\sÖÐoÁŒâ›Öc¨{†GÝǼ\_^!玽›ËÂîv~PÎyqcâÕq=©s /çèÂYÅUðxÞG],Ð9HÙÏΟ36ñ]çæåñ­ó¤Ož÷0ÿ•½k¯þqõ†øçœ—ΧgÄ®Õç>tÎ4Ýü|Oçtª;ã>Âs­ƒRšu(ž4“¿§UŸ’ß»ú¡¯]Õž=Ìé̾ûÞöm˜ÃœV]þà±â¿Äoò¯­CùãúÝq¿v:ÿâÏ•{§ÁzÚ¯êªçûœÇÎ¥1_À|ЬKçÈçüágÙþ¼uãù{ö<¨¸ß U}è_P\”¸Ì:°Ëâ[8®ý6Y÷ò„Ù'÷µuè±³ÔÇîâì>¡úöæ çyÄk=—±¿cÿËòwƒ(z¦õgƒaÞUðsí{;×9½â~~z4§Š_u/Ë'dÿÔô~ÏÃÇG/Ü墯.ÛoÐ××—sZÝxx)ëê}Žûþ{¾e¥›zOí‹<¿çe_݇úý9ŸæºÍ:æ¢ÇŽˆ+ñ¤Þ¯ºüñxqçÓ¾»W7~ó›gþËM~&ø±~x4W«¼ó®n%uÕã¹öîcç^˜k›ý¼a¿S6yÓsÑ÷ã§:ŸCœ—?áç¿\úˆNºÿNÃÜäðEædŽóÁxŸÆïìÓhŽ­çjÿÿkÎ}pñkmºÿÞž;ÌTç˜{“À÷¸7µóxÑàBuFü|\^,øÐsÁ›pÿs¿sì5«·øaÜ/ÞyóÞO¼–û;Ö óp­ƒÍ9èÜXú pž’¾ÞÊ|,óàQóQs:ø}ðWò åYÕ›§_¾ë\—œxÓ{²Û{³>Ç’sâ÷Ý÷ú›à ¼|ç]š7¿Ú¸0ŸëóÔw\÷Íg¹î§wúe‚{néà¿Û·©L\§ÿ=x¯~0ûÙ|‹¾ðÄ¡ú¤‹{ÍAd—c·ÜË?}ëoWíûË ‡zhóÂñ_©£÷þÖ™~”ûv忯ùÕ]®þþ0ï~s¨Ô%©·Ç gª+Àã%øëòpFΙúËêÊLíjëë½×xN÷X¿¥}ÛY8>à·Ç8¹óïè}ЋŸŸ°k­0'5ö¬q9~_ܑ߇sZ§©^¥x#ë_]™ô™´ïŒ=Ëÿ·þgZ2è›ÄOVÿkZïÙß¿üõï?sýÃæç4ë*?ésª3]0vµs÷ò¾ì月ãÅíãymí;Š+/Ÿ~ïèEó×éJêgõ´Ž‚JìwãÎðrâ¶ÆKpLêJ‚jGúœáëñ‹òWt©Û§soÔy°í'Ëú‰՗€Ûñüés¬N‰þ4}öôFœ'}^Áø-ï ÇÏéÀ_§n½:žtºéþ™_kþÜ´>¼u¸—ä©[oµüC³¾6ýÇù>uÅC²îÎc÷uTg 'é?Rw[½ÄE¾_ÿ€|‘sP~T*~ÝÜPº<êiƒ ª‡¨þ:úÎ[ýSð³óP½…œ#qMqjìGë6õWJ½z‘¬¯•>uz9‡ø²ë¹ó» ›S=H¸ } ù“ޱ߫nGú›'ɺëShßnú­ñÕù„Ÿœ—ôùGÏ{àÕâ‡'gÎ=ÉêõˆGä©r—¿á5O=ÿG_êa³ü;Oâýýhžã Dß ƒ"OüGù5õ½ñ'­/ãR'Z¿•sT}|µø-ë".­¿¢WR\œÞ~µ|Oëù‡Ó1Œ}®ªÞ:½àÅæEé'ÎiÝ¿{“{,Ï-Žk>P\~NÞ»x ~J¾^ÕÿŽëœé¥—+¦ß;vÄ|ðê9ÛŸØg¼ûØ:Íéù/N¡ÇÑù¡SÜØx°xG= ÿ^=ÈÄÍŸå¹é8¨Ãjþ8~v¬g*O2Æ£ôNü{óùÁ‡ÕMõuòáo}ÐøòðêÊðG铟ª'o¿dêi;¿.ö.ó;‡y‰ÑOPo —7w®œ7ÖÁ¬ÿõ‰SÚ‡ª>&u@å—èÞÑaP§&}?µÃê3Â{ûÓ=_î?<ƒ§ã¾ß»ÿ¼¸Ô‡ÀyîðÃCŸ£:zzAö/ßW=h~Pÿ ½Wú¯©WÇ?·ÎÉçÃSp«xžrìGuÕ§O=ºøCž1qMðë s®.Ú|Xy/ö •¾<(¿U£Ø/Ïɯ·î2þ»úÁ1Ö ^ƒÛO `º_C[·zÕö{å\Ëo7_H·3q÷e¯?kûÅÏ»bˆo“ÿ©niæ1e.Û £»S÷àXu®íçÿ ¿ÙóݹðÁÍ«ÓAËýeŸ»Ó{S]ŠöÂÉôñ7ôÿFúHt~ù³öy«‡¡×?TüÄAüvuNÃ÷µŸ(zˆáÕ|-¯ ßëCI<ß¾ú É;Ò?Ì|†‡„/4Å$}rÕOò^p1Ÿ9éìhûÁ£C-0¯•ä?âïkßo~Á+>sÅÏÞVû™s\{Sý³Ôç»ÿÎu#âÿðp⸟³~Í«w–_Žýc:ï›. ?¼Ó¾åð3Í#©Kâ§òýíÇŒ]ëý•WËyÒïOƒ“Ú¿•ýÀ‡/óo­#é<ùF|…çÊù‘ÏmŸKì8?¬ÿ²zúô§q}ûbj'sù9<??W¹Ìo+ŒÎ{æ^u?«â^ò/Í'ž ï¢o~dŸáØ7u¯ã:µöë†Ïvõ«ÒŸh¢o.º xÕÌIø óßé?'>d/ª7{5â/Gñ‡â¶ârý¥ô[ã_«ÿ7ÒŸf_zNã¿Ûw)N¡ËuªnEæÕ>çÞñƒåÔU…Ÿfë/’· {Vþ„..ÜHw-ç±ýÿ±óÕI‰}PGÊζ>z úŽ[çFß,¼4³ç;¼Jýyp(ü¡{X]vy©Ôƒ:ð[þ¾}Çâ‡öSæÓ{0Ǹú$tÆœ§Ñ|”›þíÿè uæJˆƒÓÊëéûšž—Æ½å»Ô«§Ïþ¼Ào4Ž ß]^4zBúÝÍÂ3e~çP§‘󪾯}Êþ·þ‘n zy¿Øûä[‡ø!÷Çùç:GGì¬uPÏÔy9/=Gá GãCé7¶¿V\œ8•=è<šéŸ¼R¾íÞë>ðšôÅø[:éy.ö m¯ºuõn©çh}@øS<Š÷÷ ù~8ÿ—Èc-»ûw¿½øÖc‡úÉ|ßõ»¾÷;·îPßÿ ¿´~%uOì—úƒö %N¨ÞxµÖ±ÆÞÀÏ­S¥¯aNòUpEããð°?¾¹uÍámøuhý¾ÔtîTò)©KŸÌ»gç•?ÿ›í[GÓúqyúÜïæŸõɨïSŸçüyÏæ¿çè_i?…z }Ä™¨?X|‹—á‡ñ@ÅcÉ«÷¼¨OŸ¸i§-Ö§}ßé¿uŽÚ˜û¤ÞNÒæ^ú{õIí{Ë9jÿHêûé˜DO´º(ÎeõcŸÕ{T×.Ï}íåzÂ_^0ôI†o”ÇÎüSu“y?^âºê.Óõ­Æ>Ã_±Çƒnì½çh5~\zéñË>vÀÍåÓ«÷›ý®Ï÷¹âöLÜÐüät}:/:y¯Á_eßÙ õUÕ'‡Ã².â¿æ=ù-v=ë7¦upå<ûf]åw»ò¾ž+?϶ïxºsä9Æyþ¹uÁêÌøWøÄÕÌês?ÚO¥ŸËÜ‘Ôc”/ îÅ“yxÍùäÜ'qTëïÔßú6ª“û×XGý"îKõô“àƒô %žâœÛk¿ù“-߸ڥֻëŒ/ÅsÊ °k­Íïl˜Î ]¬ØSzxÎyõ{òùî»ø®ý¯9÷­ #”|@ç?äü©c’òÜW{ÑÉo[rqý”s\»Gª?O½<{4–¸·z‡pGž»õ‘ìu>ß>¸ìXq@pƒ÷h°zìðÒ­ÇN=ª>cç¦u3£ûW|Yž”^¹>»Ø}þü7ûåüàä«Û`ýeÏ|ôµÅ¹ÅÁŸÎcñKö£û@G ß§©nFâÄæ“ÇçmñÿåõÕôd|/¾§ùˆ{óÀÝ—Þ»ø³öÈ'Å^׳}úw³¯êÙþÌŸâÎÖ/ÇOuÎ…>¤ØkÞ0÷;zGÏiçáš?ž¢ñKìoŸGþÏ^@ýsë9óÍ“À-ñçå×Ì“Á—…·ö¾­G Ÿ ÷ñç/ÄŸ¹'üGû¡’göâ:Ÿ{Í?®þÊ#¶=¢ùü‘|üºWîç5ÏÙqÑÅþlè“K}`õèTóÿòä9OìöxŽEý|ê_ì‹sîóÙ£ÖIæ^±÷p“ûÞx/ö¶?§&q>Â=/ÞÔû%~°Ÿ’ï‰CÕ/¶^7~ÏWŸÏ§[Ôý„?ÜïݺðÜÛö‹Ê»ªã`G’lß\òÂö׺é‹K¼Ýùd±ŸÿoïcÙ¶ýãk-k^ •Š(CsI¤çYR®T4¡š5FŒ•’®P‰êJÒ¤BH JeÈ,ó,³Ì ßûº>Û{;ŸŽõó꾟ç~ýúÇKÖú|Îó8öaÛ§mwK~ ÿFÿÚæz72°£íÜú {O¹¤iµ„_ƒ<{¹˜+a>?ÀÜŒìù5ü’÷P«þì|µêØ}÷]Rç¥o‡|#¸Oq õï±–u_™â'Îù1¿šú"ð3!o=ç€}ô~7Åóaÿ~h·Œ;ÐøZ„·À'Ž_þž ¹#¾ÁWÙ_¨yñ\“ž¼k>)ùïÿAïÀ+“΋2'Cß>û±dçÝï"G÷É<)Øä.œc y¦ÐSÎ7äeæ\ŒcSñ›ŸÃyÙ'ì ú‹¿ÇŽ£ò£8{ZëžÝúœç´)÷~E÷S‡‰s–6^xò»]ý=ù­3wý˜ýŒ÷û¹ô=êgˆ³ßú¾ÅÐ.Æy•¾våíÿõ÷æq›¡ÄYiïL¤Ñø8ks§É×~wQœY®é•cN˜œCéßN¿³_œ;©àÞG€g>ÎÔ¸ùaêÅ™S޼{åyŸòÜØã8sÈas*Õ{3Î:øÈ¤%[¶ÅYwxìýa_ÇyÑ´á…ƒ˜?‰sËŽ¬÷þ/+üܹÊÿó¼úÿ®sf6ªåìËËÇ9k>ÝvXŸ8kͫ댽/ÎÜ]µÁ5Ÿ3;zB\©$õIê™qÞÚÜFù¥›ÇÙ•ž=³Òôä÷tÞ~^½ov¹¶oµºo~œÝÚ?J gUýE£E—ø=ü}/¬¹ýñ·\/Ì©}σÇ[6έ]âˆZo|gëÙëÒU=â¬AÍ.X9h€å gîÞ«F=Ø7Ϋ>zúìÖíácŠ –žpá#øÜr†ÔœUnZ÷8'>ãÕŠgÜgµ~xî“7_çWš:±öÙkâìg?|zÊ’áþÿâ³ÊöØuÃ1ãý<%v.Ù^an&sBqÖ®îÇô«gösô‹ÕJÄ9;½s䎇âÜœÝe;Íû2Î^òÔê+véóÊÙ<ï¤éQ úŒ,üÏW›ýðqN‡)g®¼~]œõitë·Yq^³¥…ß ˆ˜óñûå¾µù·öyG»L=9¶ÜûðÃuéßù¾2㎙ŸK‹sro»÷ÝŒVqö®)ûF^òaœ9<;wÛû=|¿èOÖ³×ñeãíìˆK¼ÿÎ…åo*G~"Ñ÷.Ÿ4eaò¾Y—u?©àœ¶qV×ÒÕ+LÞ`ýÌú঎*?"Î_zúãMO]gE#îÉ\Ú 9ÿ–.³aƯ¿vfrOy9«[=~Fò½“j5è7qgœYãí¢™Ó.Žs‡ñÙ££.Žóúïé›wNWÁe+ìy«Ÿ3û®Å7e¾ÔÝ÷< è v.oÒ1§×ì=9Î-½øðÓò6Æ%¦œó\k¶Æ¹×6iüþ‡ÅÎ;kzÓ—”nl{Ççc7rž«uR«Ÿ»‘ß÷ïçŒÈì]é„üœYKêdöŸ\d;¹dÿ0댷Ô´àÜT/ õ™w.®ÔvÐ2Ûã¬Æ·»´h•õ0÷‡•?Ôÿ¬³õÍç¯çÎËmøýÄv«£5‹ Æ,¸n•õ}ËMùAß/ö3§ÏÕ³o¿|I"÷Òcî)§R¿RZf[î°«ê«MüÎ+”;Û©6ùÃ'\ÿ¬õ…çásm¿Süt–OöÔ ê‹sÒ*W|ll?d;´ô¡Ü7^ÚÅ|J"º—Ì&9UjîlgvyùÎ/ׯå}ÜgO>kb§éõ,í{Íl?û¦1ÃNsãksþ6ÛYÍÉÅ%¶žqÓ¢2û)ÿ‘Ýû»)·ï}$Î;¬Úä3a½·ýEndïä?ã¼]3¶>“wBò¼ÍF/ì6ýsûõsK.»jÖËM‰'nûqïxÿ;ò&¹à^ÝbyD_%/š÷´äVnò¯ÙWLŽóf7i½æêÄ¿öi>ò‰-»ãœæ•/Ï›þUœ=¯|Ûë_œçŽ8þ³]Ÿ/²qÏØ_ëyó´“êÏOì/ï‡üé¼™‹D±WØYô‹üa§ó•ïýá·åm·|ïzþ¼´ïpWWŸ¿——âŸ÷}cß×ì-/M½¾_#ß7sªô!áo‘?ã‘yï¶µø^û±Ü»vŸ¾}iuË-øÇ~Mzå÷žxÆò×›œ”Èò¢ù+¯î•çöçÊ!—²£îÛÌ]òùø7&¯Kä;ÕGh{nü(yãñWøáìÆoN{ø(ûwæ“5™<§Þ3{xçž3Žz%±ç’{Î+oøo+×¹Å8ÕxMx#·yZÕ»Fw¶_G/ìŸ$O©9ëÄ“uNè3úúÍ͇5ßòUì==泑üäTïpòŽõã¬S¦ÝÛä¦Á¾/þÎóèÿ»¯‚óÁÏ"/>ý`}éÓqFÅ’µñäÿ|Ê9^þÝÝãÆØ_pÞà$ÕïâÜê‹®lÇÙ9M_Ì®x´å{žÛ:«ÙOO?çör|vµ…qn×Ó÷}ùvì÷—äöÿ|Ì»GM2¾D_À'ÖC='8ýK—VòÔ•ŸÚð{àœÜyG}~ÙÂþ\ðþÿ†žŸéþÀ©Ïu½}tÜ çE®ø3÷Ô´ ®¹åVÛAä}Är_ù9³Jçm^TZw{ÓKï5^ͺ¿ÃÊ·žº.ùœóûǶzÒúSö¹‡²û}c;â{â)Û{ùïìc¶½~ñ™ n’¹jÕŒ¯»"ýÂïbÿ‘ÿü&§Wìöæ/ . ¿à‡x/ôŒŸ§nc}“}·>K‘ë£ðH^Úգʾù§qúÅû_p.Ø~?û”áW ‹n%®¶_¶}þ×ÃÕøE½'8 \‰7ðçØ)ý\4³÷Æë½WÇü ܇åLzˆ¾«Ï*‰ Rs-ŽWÁ‡ÌÅ`7ÑÛÙgûuâÝS~‡-Ÿ}g<| ¾–!^ÌReôº}«’8VñŸq£ü`ÎØoçݸáøÄï—qßøÇ{µØàèYî÷{'b·ÀÜü܇í™âuúÜüÞ²“9§ô>³ð„üÊùë>/é¾/Á·òW9Óú¼¼þ”þÖ[Γ?O°º_üö ç²Eÿ¼ò—Ǽ/;ƒ¾ð½’ãpoUœÑpfƒ ^žÄ½²Øü"ç~Æ~©?-Á]•»w¸ð·M¶[êsò=ƒ×ˆËÐCôy±]Ež8gì’ð.ñ-8Žßãçle·8?ì;~¿äóÕóâŸÐžƒ< ÷”{ÿ¼ÝåK^ë¼òn—]b>Ýr.ÊnuëÍÕ¿¿(ñ+òãö×òcŽ‹ôÿ‡âßÁ™Ø}ò#²+Ž¿RùïyÄž©4y¯>gùúÌAÆ~.ð¦ì<çí|~fõ¾óӳϋK”j¹½ûþ?H";ƒþ/´>ñï’+ë ~Tr‡ŸÿŒe_rµoÃy =Ïißyíäj™¶?šk0nÅÞaßPŠs; 9ìâó?4Þ°üê½O¢×ŠÇm×¹oÅ#9»v<ú[«šÎøçôþ~é­ñ9ù;òÈ‹ìhîeÚ ýôü$¯&»d}’]€W°·¶;È'oÌ}§îÃýóØQë—ü&öŒ¼¯ã+ÉŸóà’Çd0´Y¹%øYöž#â

v?î<'Ÿ£ûËkÝèŽïÏ^m9BŒ[e‘ûsòÎÒαd­ƒƒÇÿ§õ”{åOæ‚—ƒkµ/ÜyÙ7ûÃ>G}ß~â¨$^PÜæ¸K÷æ|›üx¤ÄêÿŠóî7¿ÃÖ2¶Ž_ˆÛRŸË|’7Hé‹÷î÷+_Ç}±OÓñ¶ô »}ƒ™ÛJ¬±þâÑôÜùòxÄ’oçCô}Úoà|çc»¯çÔ|…åØùMpö;Ú›š<·ÎÜé¼8ò¡¹ã*Éï‰Ü`çB<†?uÞ]ñ ë+øSù?Ÿüªâ ó2¨ÿ ˜'~À/‘¯¶ŸÑ¹:ÿ$ùÀÏ’'Ç?ãçÀäcù½ügwÝðϳÊÛ_σ§åŸOä^vÎsj΀÷äOyògà>⥰ÞÅ{(Ÿá¹/êàNÇè¯ê3à6ì0çäzF´ê‰¯¯œlüDÕŸGAvÈÏ/{þ°ß}®lÇêWÞèxÈøGòësVœ•;íãÞ׌‹í§‰‹Ðì£ó䣩§qÎÒKì8þÕr Îçñ}ÆøC½'ñþ‰¼.çž3à†?yêJçç]T>Áñœð/¸×ŸOžGöÞ5p)v”{#n¦£ù~çý-_Áûa¿ßóü:gîÓ8¶kÞ-msw%8 ù–S7#.D°3ømã âWôºõ ÙOò"®ÿ¥ìžydŒw©#Qÿ#~“œ#7Ô;¬ßäñ¨wé}\÷ÀßrȽâ±búŒŸÁŸJîɃbϱÇä%Ä÷à¼?úŠœæLj3bü¥ƒý=üõïÜõº‘ê²?æ½²|*’œÒÿê|b޿ÿÔ6γ^¿ýž4??úÁy€‹¨ç—Ë¿å”= óÉÔ\WþÒ½›×€<~þšµgܵ½\b—êÄqzç}äyì»ó¶è+qaàG?J\g$oŠýD_8?üŸäÕò/ÿk9£!»êû–½s<Ä¥Ü+y®‚Þ;>øõ‡˜7qŒýÀ¿aŒãÈûHó¶Ôª_kðÂä<Á7Ô?ûMý;ucËŸ>ÞG×ÇeÇÐ;pŠßWõû ü™~O¼‰žêÜì_el/ÉËS/Fï¹î¹ÒÏw’²ü’çQün+ì°ÿòîÛËZ >XÖá½oîŒóN=ú™/¨ã>â*ð1ú˜?$ýÕË–¼o¿‡^`· jÍš>ýÓ›lo}?²Ûä°Ë¶;²KΟêÜòk”ÊkQžß‡¸®`ÍžÖçÿ!ñò/e×_üÌWÿp^ }¢î~DÞÁ«|>Ÿ‹ý ßÌý‚· žÝ6êÅ–üœšËHâù]שɿH‰›ìÏU'pKú|ôý¹»Öì¸ndrþܓμ#ö»ËûS_·“wòóàN>'ïàﵟýµ†ý•ýžä³à‡5 ¶?¸ÄvÜP°;câ«WŽKê&¼ò/|N]–ç¡®é¾"=/8y¡®R˜›ÿý—c޵å}øýüöyïÝüýîDîtøIÞÃõGâ§ÐŸIÀ›àF÷SèÞÝçÀ÷¥êôºN .Ægá'„ËóT·áù|²“ù]Ï2~BåŸËÎûþ¦—ù×'<—ìP4èƒ'Æ'ýFà_õ£r_ü™q€ž‹ï/ìzX•ñ¥™OÊu8ú(¨»Q÷ ÿpï¥ç½X§Þ9ÆUø÷§ÐoF¿~^ýaŽÇ„óÁØgì,ráü;}2ŠÃœw~C?ó‡Ïù9½û{~çi„·¹ì0xÚyêsŠ?ˆsü{ô)Àó¹>O¾¿.’¿ç}¯’}å>;{EÆÃÏ&ç¦s‘—C¯ˆÿÜWP£°î¦¶›ýœô ÇÆô‘_•ßuÞPùt>y"òuò“î7Òó¿áŸdŒSSŸg(×-„— ZWlÜ·Ò§Iœ+»Á¹8?§ŸÏ¿lõY_M=ÜøÙ¸œüùKêÄÔuÉOG€7ð£~~ùóbyDé-rãüAJ® ¦í8yÍ€“ºŽpŠëŠÂmè#ö›ü¸ô6éCÕóa¿ˆ» Éc'¦TéÙýŸß%ýœôQ!ïàWâ}ò‡²ÆÒ×a¨3SÏ$I½‹ø¸|/ýSô›I_ rË[8ó†$Ž$¿EÝû„}Õù„øÊþ¿©|W¾ðyqê‡ä[ wÊÏ/Op=ßÔ©è£q~N~ˆ< ø}Ík\T»WóKûNbŸRz ÿ`"‡øò2äUdGÀé¶?ªs :ªÚí'ýGúÿØKäçv¸Ž|œì÷ïó–¼S?=2ï výpq¯Þ ;åø!…7ÌïO&îÎ]–:Ö¸×xJ~Þ¸€8PòÏÏÓ·˜'^1÷[ Ùžrÿ!žC¯©ûñ?v¥`KN“5_²$^,¬]jÁ·½êÒGe¾C÷%bרó)_SróžŽGÞ÷¥ñ(ñ–ãdÉ;uãN✠‚}ÏŸT¡}ÞWYIùOêL²àÃ<Å[îc®u½›¼*¸Oúçº$ý4²3ø£Âe½ìì¶¾'÷-Q—WüÏýòs–#òÅÔ‡è× ~@þ•<ý´Ü³Î» Íi7W¬ó‰íUþô£ôý«õÊ¿ÎN´ý'Ž–ž`/‰Så‡ ¨«€ékV}ÚøL¾€ü<õ#ú<è á¹TËPåÎ[Ztr>û…¾‡õE×a¨³I~OÅ}Éè•ãÉ ý®î#ÏHœ©øW¸ dû%}âyù>ü3÷–§>Iü>8Û~<ÎÓ9s_œ³ñ}2ª×€k¨w¸þ«<y®0uŸ°üŸëF²îúfC¹sÜI›ïßWÛ^ãéO’?³|‘·åþ„³‰sø»ÏQŸGŸ°ë¨Ô¥§î¢Dïï¸Z÷¥º¸y œG Ÿ€º“îÁv˜ü(uµT½Çs7ÆÒcðëØÒ#p˜óØút‚¾Fâä?V²wÑ¢Ñ×^|>†>Jú{§Ñáú»ð‚|®{§n„½õœˆpxAÿÕWlɺÑ~‹:1ùp { Œs«õÂÝGœc\‹¾’Ÿ°ýÁ>«Îé:u ì|Ou~œ~o}/ùâR÷¸¿ù¾omw2*6ÿµçOÏ/dÈž•<ì˜=§.ûÓù9påW¸9%Ïc»J?¦Î ¼âü!ý9ä×ÁÙ äňSÄ3—ôK`ש3é¹בï¤Þ/»Â}!|y@úG\ïçï²#a|ŽÀÞ÷JþÓ%ïä§ñ œ}¾ÅúÝÔçl{Çü›ôxÖýˆôqÐ×nQÿšëÔzNòkĝſ¸ˆÐoæ°ˆ[8÷ ÀzMŸ9 úžÕ_ýw¸ŒyñijnÞzêz£ì‡ó:Gò9èç%^<Ë›ólô½)ޱŸ"ÔÁ8Ïç}ÆõÂݼûýèÇ%ÎTüž×çð•hísrßùkõ¸>+{`¼_—œ ·Î#añ«œ»âz÷GÑwF¾JòC”þ~˽òcèUØ/ιn¬}^…ѶüÛþøÞçà¼uò:mëùÃ{ÿ0^bûë8—ù(ðð¦ëÄz~âW÷+w1?DþSÏþä7[ýZ¹Mã‹Íb§Ü)ytßYØOM}R¸ßñp«ñúH¦ûtß‘ü?uL÷µÓ·I_y"ä…þSð¢òxôýOÈ.cÏÀMöKÌ}áG™S`n~}žñ%ú@»"¿ä~Eæ?™ë”¿p¿â-ê2ÂιîNž†x/È÷äoÞùâóß¼’ägõ^Æ‘Äïºãž`nÂý*A ¸Ìy"æGèÇ ¯IÝ“ü&þ¼Žâ*ðŠç†dwÁ—ôÚ¾a÷铯aÿ™ %o,œE¾’ù*î{È:øöxnë5s°ŠoéÛvžY÷޽sÿ!smÔ;d_È¿·ßñœþ„ïÅʹ@çLvýwcßè;äsgÎy-dÞV÷KÜîþ5ê)à:æ+™#CÏ…°Û¶ ’oð8Þó•ô_‡óžÄ¥Øiú»©C˾;%<à¾ÕC‚ˉ¯ºO„yiꓞ×Õχ}¢ü¼çIÕïè~'æNt~á–âóÓsNà†pn×þ’ùâyò>Ò·Bá꿞ÿ‘=¶?Ðßñ»àm×÷˜'§¾&ÜêþòÔ_ñÃð"à×Õ¿^b®;çùRêãàHâü–ôÈý¾ôé¢?Ô¹UïošûDg ç{n]ñH‰Êƒû-Þrf2‡N| ¼bØÿ޼zN‚<£äÇuGÝ/þÈó&äaáyÐ}¸ˆ>eâòYÄ™Ì+0WÌÜ1öÜ)9%~Ðï{NÈq }ƲwÈvÄ}ð6¤Î^/Ÿíý_Z?Ä—à9ÙyêyÈ ŸËï{ÞX}žûžA]¿fN¾P殘×`7È#‘ßcž›þ`æ‹d§ÌsÀ¼6}Fí7Nê0ú}רgPO‘|¸¯Z~ßs¸ä…ðë²S¶“êƒrýúž;æz—p•óÎòÆÑž¿¥~L>š¹gìñ†äÉ~üι1WK½šþ/ò2ôC¯'Ÿ*9ËŽ÷½éOÏ?(®0?y_ì·ð-ùãFéùCóVèܯÌZÐwE^–>çÛ‰ÿá5PœîøîKq½í¦äÄxOÏÚ÷oãö>póîÛ/3Žu|'»é9ê‚Ø;æWÁi‡óXÌÃÈŸ˜¯E÷|$yùmÏ Énƒ_ñ×ÎkÒ¿Cÿò:ØEç¹ÀØoÙßsÀÇã<°âi×÷Ȼ÷!»þâ}ÑoþôÜ;v€zw€û‰\×Uœé~4ðŸ‡ýa~ÞúDðÛØâúÆw!ÿüõgðn8Ÿk»Nþ9 ª÷c^Ï÷-ý¦ïÅs ð‘×w3'ŽÜè÷=ßͼñ¥ü ýœ}ëÈ­ý&|ôéË^ûçs}¯q“ò¶äSýýÒwú_ÈoÓoÅÏ3—ˆ½Až\WaŸÑ/ásó?è¹-¯äyàÑày™ÓG ñ}æi’‡Ø1oŸaT{²Ùûàz7u²`þÚ¸çP¼dþ)£ëGôÅ0WE|N½¹/ôI8Åù"=ë;Ä9²«üé< ùOÕ­ð?ž_ óžèUðÜøKë u.å)ÈÚ>’?Ö{ØoÓgJ?åÁ éÃÿÊõO癨“Ÿ–ÜW¡×¶ƒÌ'‚/„‹<çø$õ\ÞÏúwç«ÐW}Žëº|öŸx^*æÀÈ+#çðí(Þvÿ&}êÅo‚ ± ž?÷ús.êóÜ0õ~ËyÙ+êlæÅ"¾ä癃‘° x°øÿÎ×éžüïÄÉ’?ü•ë–ÌÑ“· L¿`*>1†ûp‰tÎÆÍÜ¿âXú±Ü§A?v™>#ÝöE{m¯ï©ÎÁç£øÎüIÝÑùo昢ŽÔŸÀÌmò9žggÎ^%ðõIþÎü™üõBp!þÜv ¾&ægù<æUt_¶ü¤ö¯'óÊÔYè‹£_‰9AêþÌ×éûíßõy®—H®°‹ÆcÌñ}FîK€?IöÎq€ð·çªÞ÷€×Éÿ’W>ÓýY²ãàì"7Îg(Ïç¾fæàBÞÉOÑ×*¼ž ç Üÿ~>,挧¸®Ež3àÃÎe´é~O™Íu“|²puŽÎ}á}ÃþË»ìùªèÛ’?0Ÿœöï]:¬ÖÉÑ,óq.éyëâµo 7o;¼Øð›nnµî‚_~º$ú}ìëcZ—|ÇûYà_skßîÓ{;Úúíž±MN~,ZU1÷•3fŒ6:üÇ‹Î=féÌy;½ç†ý1ªüsXŸ¼W£-ÿá¿nÎ>—hìú'~ê~ÕÍæ÷†‡•çåsàéeŸÄænÑ}¯¿TÁ|ëêæ}^a{×hCË*?—ovœùVá±eoûø>öMüQ©ÉÈ.»ç™unƒ{Ï|úéÑñ+eÞîd`øÞáÓg?ù¯'MÞêþ¡ÑÏÝöTÝ”öYƒ,^`ø¹7 šÚä¶z'D&üþÆì#·F«ÞÚ³úõñ ¼'~\öMë÷½Ÿ€Ÿçsøö‘ÀS _ÿ‚ ›ŸÐçšáÑò¥‹Šº´ýÕû<ÖœPsÜþ®æe‡ïžføi7 ¼p\:zoÖ䲿¼XnÊwæÙ__ñý2'tž˜åkíÅ¿]ó6k zöÎi}–]}ÅVó/à òÿV£Ï&G«»µøã¥îw'z#=çϵ·ŒéÔiT ï¯`òÇ^äe]§žO<&Ó|ØÈq¸Gýä\Ùoáý’ xˆ%‡–sø°áÉ_4eö)ß}×Ó¼æð‹/ìVzôÁÇ.‹V¼±aef¹“}ú¹@¿Í?®½áæ—×=¡'+–~räÚ‹¬ßð2¯ïr̃Ÿx»Ä~AódcO»?ÿÑ÷¯¶Þ„¼Ìðl£w´¾û³¦uê{ßÁ”?¥?ÝèxËv˜ç‚o¾pø¡ÙÇ5{1ÖTšQ-÷î¹ÞsÇ÷c'á÷÷>ÙGä~ê_uè2÷™}ÑÚãn¬]®c]ë³>×÷·dï’gŸ9f¼÷T ËâcŸž:?Ûú?ñÞ!íÇ¡¿Úû$7쀿ÿÛF¯?¶jÓhæ¥/6k`Mï“à~‘CÎ}¼7Ÿ7¿ÞÈúqɾ¾ç•Kλµ}ÅhÓ¤#.|òÅ‘¶›ìmDÞ~,S÷öšo¶Š6t¾®vÛŽu¼'‰ï·ß”þ›W\vÊûܸ}?zŸúš7ûØ´èóheݲe.z½£÷ë°}²Ôùò9ì+ÝXéÑsk;=Z2æà€Åc÷F˪T9þžÛ“߃W¿ŸúêÿìCÈHì¹ö Ù^kŸ 片`ÿ‘[pÀÊÎ37V¤ þÂòãçÑ> Î{Éžû{þ~üÿ±û’ý2’üû6ÖÝùµ³GE‹/z÷’šý‡ú|Ù£c¯ïG¯½WN<éà-ä‰óbkQ\mè»Ñ Ÿvý—.7|tÓ†/mGÃ=ìy±_N§qžìýàýÐ;öŸag~¯µàóÃ÷[>æä?³²bô–í$~Rßç{aÏ&ûÀuKãw¤=YÏò¹nùío69ÿB¾Þϟÿó9Þƒ¥}ú<óìcï±Ç?ÏÙ\/·Ó÷Æï³§‘ý@Üv™=(ìÕÀ™_{†à»ŸWk謃úÚÏóyðä£ÿ«Ó.üòþœYÑÊ·ê~rQ»®Æ_ø]p•ñ¨ìû)ÀØyî =ϰ7œ…F¯ø÷Ûh;5꿲÷1`GÀqàuì=瀾‚ðû߯ûаæ=,·à6¾Ç{…µ÷{ÆÞƒ•oî|g“&ÑÊ“‡”év’å9ÆO±×y¯¬ºížß?¼"Çï ~À^`·Ù#17§×]'}·ÎçùÇת5½þÜhÝ䲦”f|ŒŸÄ¯áOÀ?è½÷!t½©YÃ.·ÿ‚“ñ¯ì›™YÔû@÷:ŸúóÙƒÀ~Ëo:W?¿ÙÎà·ä<ˆ«äÿçN|ùÞúíŠfuºt~ÍcŠ’ý+Ú# ÞÁü‘¶è覗™w¹F–ªßüɽm“} òOË+Ü·üÑÕ-oœ{"„ýœØ)ïEb“ž›=,|.8¹@—·|tfíÑéÖOìöýAðóè%8yÍ“Žh•ó["g'Vz­ÓÚ÷ü~ø)púÉž«5ve5>²È~ <µ,}é«ÇUKö¦IïðwìaÂbÿ凼Ó~‚û‡È^ wÓ·}ÿðU×nEï|Þs~¬üI£w[/ðOØ â)îkcÚÈæ?mk?¹ð³ogUì74Ù¤="ì«å>—_´â’ŽçüÊy&÷-œŒž€Ÿ—.o^þÈË¿Löó¥Åu/©ÝÕ{yÀ‘ÄÜ?q÷ì|„Î;®Z´ç®#gvÝî=.ìycï%qx?ƒÜL=uçàoó‹¢e®|}ûЩÑêý»â=SZús½_\{2½/Nñ5öŽ}+à8öá¿Ù'Ä~ÊÕÇ5Ý´5ï÷eo ÷E\·lé–©¿¬¿Ñû-‘óù?/1rß8ããáÒ•-+,ºýÎ/ü¹|øƒ¼qܲ7:vóÔûŽ'Ø×¶còòù?>ð”í08}_œ'ûÂÙ'Ë9*_þµÜpïü>y™£¯™vü‰{ý}«&,y©sÉK£ß=øÃ3[ßõ~(ï–ü-ûæúv ƽfœŠ=Û•žýÅÖµÇ%û¦Øó£}:œ'þû?€Ççýt`ä·ö¹²çgÞƒ»þUvýG–Sî›|8¼B|ƒ} îÇc§WT¾úƒ> æóÃøUâ9öZbÀ È~ˆ÷8°¹ÏÍS†ÎðÞð0x”ç?ÓvnîP¾Î.ãHöeaW±ïàCï’¿ ÷?ñøî»‡sßì¹ô^Gì†ö˜ƒÏ‰Ÿ‰C½Wv=ç\Á!Ä9޳õóúïo.–¿R<ËçâçÐCp'úI>Ƹ@v¿ŒÜ/þ·_’]%î7’oÎwœŒüq¯œï1ªYÁˆÎuÚ¿áøwò²Ü‹ó&Øá[žëµu?,žSc©óÈùPÎ[y“¤^£z€ùÈc«Îê|?Fú àûeï„î>ó?‚º:sô Qï¥Ìý=š‹ô¼9ý†ðÿÃË­óq_õVõÑñy®Kñ}ê7/ó¸ð¦¨æþõ0·åyê}Ô™T—F¾ÍûF<}4ðfÀH_üöôEª.ÉûÂOã:™îÏü’GöÑc>Zx0Ô߉ÜÐËszÞþpõÐçk^.xÀ˜;‚oŽzž>×ü*:Ï\òÆÚWÌ_v9úèþ(úœÕ_Ißå>ÕëÝo¯ý*ºwøeèó3ÿf玿n,ø—ào¡ÏDöj~"ú¹ƒ½1æ—Ü¡ÿ!ÿù²ÄGD?›ëêê{ð”æ¶…/mï™;2}4ìÑDærèÏfNDÏi?ï2vUvs(ÆCŽŸeþþ}xXéáÞJx.øyþÎ|{4ïÎöœ#s’a¿r0Ÿíþ)æ|Ø›¿z&{ þ%žt?}‘ì-¡O”9,ì.r¬Ï³Ü ÿ"ïØEøŠñ‹ƒÇðKšÃ² ø'ðÛ–Wù]ó Hî±çîŸcN€>Y=?}Mž? ¾¡оMú áa¾’þfõ;zžOxË}pðø2×AüF,8™=‰ÌUa×>më“xI‰4×åyTð4¸Ä|uÁœûîá bÎ~Kæaá1W?0{ÅKë<õì—Ñsš_A~ 6}ÚÜ}ÁðÜЇNÿ´ô—ø…9{Ïå{C¼o•=[šcu¦Î=‰æqa‡x0Œ§$îd?-{îàicïñ°ž‹ÏóžúàékfÞ¾ÙAó ³¿†¾GöÂ0wÀ¹ã/á‡Ç•9CíßS½<Ù'ìåñ¾AöUó=ìAd¾GvÓsïÌõ€“è_—uÿ£ü»çÉ[€ëù>=r/=!¯WŒÏ9œ;w.}Ì̽¢÷ìß‘ßósçÒGâzä ûäyâ&ñZroĉž·~kÚè_6ÌIâVâ8ú4™—eîx™=&ôõû£3zYxrýó’½Ü«ä“ûE‰Û¼Ms3¾æÔ… ±³¾gáž¿`ÿOó¦Ì×InC~Iú˽O4e¼_¶Ø>Xâ\ú¾á%®ƒOþÉó~¯®ñ‰â{ï g·8Lçãüû‹˜ûпw˜W » ?|àÓ`O“yÆØ›&»c~8òWô§³Aþü—ð¼ÃóÀ^ö·‘ׯ2o/ûá½̱IÏÍSÃÜûª„KÌ;̃˜?–9eø‚°û̧èýÙÛîù ü1ó ØòyÈ9yUí§Ü_úÚ¼¾[&ÏK<¥¸Þ7ï=€*ÈW‘Ï3 ó ÒøZ3÷É<[p¯Øç“Èãh~Ìñ¸ì)yÏUI,ßÂ]Æ;Á~Jï†?“¾zì¥ð ø×qóZÌeK_ÀKàÿ>ø€ó–½cÏšó<Èc°¯Æ~>Spq"¼zÄà*ò¤Ä™ì“T;iþ9xIeá@î½ì]•ßÛxB‚ßá!g>…9<äžÉ;ü3®7wÀgÁ2|+Á›çчßâ>=$?ÆûyþI~Ñÿ_zcû>ƒï>ò!äËu?iUïhôJ½W¼ß*½bÇUWÿ§]X­÷²û>¥íÝú`¯ ×í)9æ:õ¤¯:.\{ØG]<*:8é­1Wþ#Í{ìwuNâ#‰4®Ø¢Ü¥ ¨CYK–ÝrìÆ×/Ó~é}D²Sœ'—|&ÏÃüZÀ;i;œšo¡Ï#N;û·Þ>¾Å~ ~*öM’v<ß¶x 8潟5åO¢ƒKF4Ô¹µå ýg ×i‡ÿk×SC’ý¶%ÓÒW\½q8|ðî§V³·KëYy“ž'¯¸ïÒÓÖ¯ñÞ@ö»!‡Ä³ð‚y>GvP¸$Ú·9kaÛÓ;˜_ ;^2§¨ó'up<”vÅûõŸiP;AŸDì}3â D¾¸WáϨhkÍ«†Û/ñ'®ÜÚû‰ÇüóŽ£Ù›5èãϾªøfTÔ¸åk-:g{(þ;ú(;ª÷®sŸè§ùÑRó†ÑÁÖyë]v½ywÒþÓwÙ.É›c¿àmIÍEEoÕyªÝ wzßóEÄ?Ô3áô¿Qܧþ!ϧ׫<3ûÞ…ÜOt ë g\Ø|dÂO¢8 ¾Köªîï¹Uò‘äçÓ/⪷¿þˆ~dnO8ÀvDýBû>m8ù®/g;JŠ=Êz^ä–9š8½]¯¬êåøKzá¾(ìrä<†Î•¹6ú á# ÷Ù’¯at°ÉCÎz+Óû!±Ô‰©§7pÁÊ;Fã#*¿údrßú<×ÁØ“Ç^á êgò·ÑÁ·ªœ2«ñ™É\ªòОoLù?æJÌçEÜ©ßCŽ<b=?£ä"Ú—ò7¶'ðIxž‘y1ñÏ1ÇŠ}'ŸäùsÕ)¹'xgÐð´ä*:~ìy_:ŽI¿uø^¾;*ê3&³U…ýÑÞû_[¸{\zR7¦NJÜ-|à¼V*žŽöÉ›:õ'“}ëŠã%wöC¼'vBöý5o“p‰å“º‹îß~+ ãKò¡ì§Üõà¹ÿØúÀ½ÆEiÇ/o}̜ծsšÏ“}›Ê? 'ÛïÀ»m>eæ-U—З~Ök?]Ú¼´ã¡´^ïå6/EÀ+Fžå)™ÃˆÓ'´©½¸]í´nØîñ&ù‚TÜMÃ|î/P|.û`}Ã?à§ü|ª«cwñ7Æ-f6ª[5ËöøÓïžIù‘hï§Ÿµ»îýÌe8/Œ8ÿJþŸ<‰ôFó ­ú‡ÐêŽ?TçtŸð)8ü%ù¶ß N n¢®æ{’ÛÓù˜g·Ü5Õ¸ˆý—{·ü»ä'‘KÝŸê„ô×:/ƒ·]”²ç‚~÷UéóÀÝÆß)¹tÌuixËõØú.´§¼§ÿ»ßwBñŒóÔ%–íÛà“-Æù…m*høÓÆá… ³VlÿWú$ã4ñ8ï™ÂQQ—ʯ~÷\¾÷gìês÷á…ï-w>ùcϲüˆñç佬)y°6ï_ªßþBûõ0σß­q>߃Ýog;¾ÃÎ —Ò_Ÿ7ö1mÝMUçUOx1”ŸÂÏð'8…óƒ7Vñ(ýàqºêäª/1Ï™øEöÐ'‘Ò[ëqÉ&9ëZN{-Ú{D響ú³Yœž¿¡ÝåéIÝÖ{â„çÌ#˜ÒÇ?ØáýËNzuèé¯:n%E¾9RžÛ~÷f?yDã/É%~PöÎøÄø@zDŸx‰<7qº÷-¨né}É)ÜE_ºóRøoó«çsÏàhó·Ë_hÏ å;á{ÑÞyâò"œ³žÛþL|iœwRßDRrèø½Ìúdw’¸Sqñšý9y Ý7ß+üÀwòþÔà•Ýóþô¥Íê_Ðoè6÷3Ÿ 7X>à=7ÐÿF&_…]W‚#w%ùcù-Ƀ?—}ð’+ò"àëó7â‘pÞ`yW¼v úa«KVM>~nçy‡?JþÈ£û¼õsêca.$ù=pO*¿Äü…ë|¥~øó©ÅÝF9Áù`7±Wæë&nKÕulïñ¿ÞŸ¡üq÷æ>À)øCü ûjB>ÇÈgªî–¼7¼ßªÇawÐcúz¨WÓßÏžò»Ñþ‰9?¿¶åT¿¿ùÅÅóõmÙ=ÅcÑÎO[|ºìÉ.–Û’­ËlÜúÂŽ¼WYuË)ò)ûG~»ã¸4u–#×cà]’!Ÿ%û‚]IäRñ²ý'|c©|#ý×ü\R¢þ¨:YAÇÜö·?îü88yËýeW=-Á}ÄIÊs…{½ÀÈûHáß…÷^÷J>Uó˜ÞS ®À9ï'=v”¸‹~Éû¶•ÇÞ`Î'áÏSœ ~¶>Ê®ýÕŽ#U‡â|_™÷Mñ ¸ÚyDý\éþÛÛåí} ì[C.?Á~.ÞG}WÎW‘ô^ý‹Þã––;ÿÝݽg'u ìOÐ?‡üÝÒvÕ9O·ˆŠ–özoeίÆmÆ)ŠÏÉwYþSøÍ¸Vù"Ëëש¼s*ô‡Øƒ_xÏ¢6ê;¦µãnä »Z0wóŸ½ónNxSƒýÞîç’¾"ý9qŸ+}Jðs³–¾øÜ…·½ß€ºRªå¸Á¼ÅêWv¼—Ò‹‚&§D³xÎûÒ¼žcõ‘¡æ‡oо!æcèO o¾køI„ûx>ìSÈ_ŒÜ‚«Ì£K?¼Tª2GCýŸº¢ûJéûŽq]þGê·ÊOñóôq…¼Áä ¼_\xÍŸËœõoú3¨›«ß?î¦_Ãû‰é ¢>ŠS_…÷üч!äþ úw‚ý«æƒS|âz;ý ôYÃoKŸ}Dô;ÂcIý]ì×Ïy¿8¼ êÛà=ÈW8ŸÇ\ú<‡Å>Uö˲W…>göÜÑ_«¿“Ÿp¿†ú¿¤oQQ©OŽ-¼ð êËÞ«aÞ䀿yô^r缺ê–ú>„Â>áÂÖe¾¼eá\æK=—âþÎT>>Ÿd<•ôíÐO~b¨÷ÓwH~Cú}™× ßŸ|±ôÇ}dðRÓ¯¹øæésuߌîßûè¤O…÷=Þ÷šO“=VÌ G:gòt®³©†¼/ø‹sñÞ%ê¹ô/ÀÇì“5o ûíÔÿèýì‰e¯1û¤Å‹Žõ|›ì§÷cÑÃ|‰Î˜QxŸý/ùÎÉý!!ÿ5u<òvä é‡#þfþEþ9œës¿:~€¾{úʰ²·æßÔ÷—ÃgLŸýáì•Â9pý;ØUð‰û·˜S¿yì¥÷J`w¤·Þ/I?>v–º¾ÇùUá²p…Ÿ?˜Ëóþ ú¤î«åüØ¿«¹ó#Óo.ÐçÛ¯I¾Â¾ÿ>ycá.óeÒßìá!žóþÇÀo™¯œ§—>;ö ¡Ì3±· ¼+ÜfÞaÍñ¹ßLõ#êÃôcXo‚½¶»š²=Öùƒû=ÏÉÞÉ…ñ.û_ô‰þ-þN>ûŸõÿÝç&ëyõSyÞ‰¾_ô™ý¸ð4ƒÿ„7Œ¿°¿ôí1¥|£ý!ýDè}rô›Á§«÷r¿s?ô5qŽô‹±÷Œ¾,ý<óYô¿ˆ¯Äz‹ß÷^Ø`Ž¥XŸ8{œd÷©[˜'ž½UìÕ‚Ÿ–=ä쿦Ÿÿ Îw3'Åå,g²kÞß .‘ýô Õè‡õžcö2È_s?ÔßÉox.U?ﺷâïÖ¹ñ3y)úÉ4ïÍýñwûøžå7È/[n™S_®ùÿ… È·™Ç—½_èòšôۙǛ9á?÷>•ýò\ˆx·w™3d…ôËù,Å®ÿñÞì‹”Ÿ1N÷²ßœJŸ%óê/ð~<æÄÙà ޠ.ØCi{ö/ê>Ý×Ïþ é‡ã$ú›™ß ß\u ?ò\ÐÈœ±ð2þÏü×ÌÁcØ/£{÷Þ'ö„£Ÿì`~‰sƆ{Ku~îƒ_û”¼¿˜þMæ6˜NÙIxt“þ:ökÑ¿/;À99~ÖÞ"ñ›&sÌÿüu.ÌýEøQúzö-ƒ7Ð#ð›âú:œwÑ}QŸp<'=õ¹Ë>°/Ì{NÁÝðü+^ñ^QöD±ç˜óåù‘cæQeoé3#Ïå¼çÄ~8ð’p2çj\¾¥Ÿ‡=*ªÓÛr/Ì™âOÈWH^l7…‡¨ÿ™_¾ ö²²ç~ ÉñŽ÷sÏ2gäixì—ûä·<Ï¥<•q­êæ«`þûG\È|‰ì çè»"ΔÿgŸï³½'Þ$®bN»J¿8þÄy&öÞq¸‡<ì½qì_dï"þU¸¼¥óÝ÷‘ìe#ŸÃ~$üó$²¯à8¿G0GìçeŽùÅ{ð¤8ïÜ$<š÷ç\ß 7ì!ÿqÞȳæ9©k:";é}êì¥Õç¸ïy ôÅs,AŸœç‚Á§²CöwÌ7#oà0õ]ï˜qãÔ·+ï5þtÜ©{ð92ƒ]Ç~ó{ÜÿŽfÎ/˜{Ã΃SÉW ‡Ô“=7ÀáuÞ›:ºq¿üZØÇê¸7Øg`þ"áTúEíW#G®ÿ‘—Å.±o|x^vš¾hï[ÃÎH=çÂ<­Þ—½ è;ý’:÷!ýɾaòøÅEô0ç½.ì)!¿ ûK7àHäž¹pÞ›z‡ã ä5¨:ßþ $ÏŽ=?8 äs¥O9³Â§Iß;|7Òkã£àûÍÓ‚ý¦O˜}™Ô!à[a^Œý)ôÏ€O±ûäáïN'_J#ç»Ð8Mñžqycp¾p,ñçÃØCO~ùcN‰ü$þžýQè…ò£Ž—àcϸôËsFÁž$çõeÏ ;쿼ûödIᩇï(Ó¨t¢Ç²Oä ZWlÜ·Ò§®';ÿÇ9ê¼ É'€O©ï°GXsBÞ£ûáóKUÚüýÇKš%{{ɧÊ{ÎV}©ä5=·E¼Ïœ4üiìmÄ.èþ¼7[v¢tëüs›ç Höö¿â·ÙÓI½WuBïwTœã<(u-ùÍÃIÞCEý‘½ÂÄÔäG°Cìãá½ç]ùô{d1½7ŸoÞ äFçWÈœr ~&óô„ùWå÷‰ÿÀåÞkŒaŸŽ¾—~ ìŸú$’z û„…;¬ÿÄÝð+×;ßMþIy]ãæ«Ù“(}u½ƒº/q·ü¬qú,»Iü~ðÞ4ìþþ├{ÞÀ{¯ƒyIïC£N(Ãý8?E}‚ç&_ v/ž“ú ¸—9_ò'ì¤~D¾\O•â)û¹Ôï»þï8‚xTþ­°Æ1¯ŸÞ³WÂ+%»R¬/¹3n>4îaß'úJ~6œO·‚³ô>öëà.äºüBz~ãáÀ8Î&Ï£þqdzàJæÔy›åÀs¢ÄiÔ-‚|§ë«ÔsØ;žAÈK`užî ®@Þ‰¿$ÞGNÉÛ3×ÖÁ…’{Û Î—z=yIö$ëû˜§„gÀód²wøCÿžâsã“ð{$¯Ì%ºôgpߞϧ~Èþ/=¯ý!¼ˆäátæµ’½µþÀ£¿“ÿ†Âu}úAØ{F~†}•ÌÅÓ· Î ø_Â|¨yhئ¸‹ç*¬]jÁ·½ê&{ÛTu^O¿O}T<îë2>@À9²“ȧ¿Þ¼€'Åñ&ýÂ9ØUú-œW£Ãϳo]q¸ãì:qŸ~ß{ê¯î;à\ȳ×[Ïg¿Dž”<*<$è%õð>8Eçëz~I8ÀuhöÞ3ç÷׺³÷I›’þAÙÏ“S‘¿qÞ1àŸ5ÿ«ò©ŽÏØÃ,y°é}±çôóyø1ë«ì9}¤®Ãa?Í Ï|/Èp#y÷ÈŽ8nWý{n»A~9È—sÿÞg‰]ò`üé>ä» º´ñ:ñ¨>Çü z>ãgákúrù|æ~¼÷þPú¨÷×P÷B®uÏ<~ÅuFâ)òàØ€ŸÑö@zé| âó ’". åLrÖÈ{¯<ûÑ9/åÿÜOì¡ÇþZá3ÏFräþÉ7ù_çqÁaðdþµÏÀö9È?øûq×½všq*ùpù}æm°óà ì{ÖÙ_+»ËóØßüÜæÙ¤î ¿ ùJô?xÊØ/N~žì¿æOlŸÁ‘àp ôœ9Qpùúµí·¹_ð|ÆäWˆ8Ù;×K¨+Ò¿"¹ðžtñz+r _ ýNä]èÿ òÿè“åJù=ê$~¾ ÏÀy7òWìWUžÐsƒ¿ußäÒõfð0<žôͧæ¬?Ü#ü#æÏT>Áõþ€§2ä5vIÙYË)ýÔE7ð6y áyòHîóá|Ù¯«þHÛ;ð€ü¸óàœ7ïIð¥÷ß©{wÜ*=,l¶³lå³ÿ>øÙáS§?Iö˜zåƒ=Õ¯Þg ïõßá€7ùjú®ècÆ~wÀ ä½°[Ä}ìéÖsšo |jJž<ßì>=úp¨³Ó_F]¿†¾s~à ͺ?Cñ>y$Ç+Ø]þ.¿ê~Ù+ãxðè§'H¾@x {Åyoó~²CØ‚AGU»}àâ$/ÄÞúˆGü˜ä„'®0?ªúnlרïɾyÏü¨zúáüÜÄä;‚øÃ8“º¦êºö£Ô³à¦îLŸ8öUçO(Ïoÿ ÿücÈ!~‹½ð '‘Ïç9à'2>ñ¢Î‰¾Vâó©‚w‰[À«ä[¥ÖìxPG¶“—ƒ'>à7>Ó}Ñ—ú7ÛAâqð‡pŽùÃ79¥zqyøWœof¿€òQŽÀÅŠc©óãñg¹ì¹ëÊôaõcì?ýkàGçƒu>a=Úç½"_D^¿C>,÷á3ç…ÿæ\ƒþ{ç!™/Ðý¸ž@ˆ>[õÐ?Àrkžcú»¤÷æÉ ¿Ø¾ì¦û´„c JÏ{±N½s’>— ”üŒëb»Ì)9ÏE^¿£:z‰œ:/ ùà\Í7*yJú¯ˆtæ±¢žM”ùÙü¶ñ½îË}¿5ž'ßNǯ}\æç£n˾ ì"÷†Ÿ‡§WÏIþÿG=?ã<­>ø†øÓx˜ç–žX¯„ÓÜEþ‰|=}öð‘Á׬üQanþ÷_Ž96™û†“ú°ð}zæ=ßb^Tû1“y2ñ7âݧLŸû à‡gÞ†=2ô«©/É~LçͽÛSw ú•lÉç3ï;øþRêÞðÂ+ #<Éð•sμ/Ïôkx¯ ÷_5|áz?ó_Ò×ËçÒ¿G¿+}kà^xÁUïv=—ó#¯¨¸ì¾sxlä‹éó ò?'[ïÍ÷ƒ/é³ð^.p7s™ØAîMýüØ?ÞÃý |ü£Ü~9;ò…ä¯àEe^>[ú¨£‘GUÜãý]_°÷éó¨GpNÎÓê~‚Ï…s‘~›¢y!ÏáÚ®3wB•÷ ø×}è<%ÈÞÛõå³ÌßE? u¨ /Û¿\`ÁÌýI®ˆ¼ÿ à 3~yòaô“²„þ|½·ûYyôƒº,ýÅðÖùqûwôˆ<0õôs–_à^\×f¿ˆxi¼W ^pÞŸ:;óÒoûô{ ;¼ƒ“áS°gnKøÅ}1ÌíJŸ\×缸oùÛ°¾è96úU%–kÕ«?¿ŽÒsÙ¯s?ä'•‡ç9܇Á9Ãc%|¿v\üž>/Ïñ@ïn ÷¹ß¼}å²OÆßÁÿ'¾óž2öÖiîÊyòTè¼àØ1xÉàûdžŸ¼7øX÷l=äø\úªÔ§bžs¾ü©ì¡Ÿÿä)¬gì™ø{°›îÇ êÄäoù;õïë.ö> ìò‰?£þCŸ:sô/s~Øé½ù©ðÇâýdþØÏG]ˆ¼°òê¶CØUâŒ7À3f;Çó0Ï€·÷‘_òÑÞóÄÜ÷^@.È£²Ï;Á÷ówì üˆàúµƒú¸ý—ü¸yâ$4ñ>óÎP¦¯TùóÆag˜“ ú4¼ï-Ø‚>ß³Aú븛>høòô|~ȼ>ªƒqà‚ð{|ŸÌ?s¦ž_“¼R2ÎA/è7¢oùÂð'÷†¾§söSÔ+ˆ“‰«Á챕_¤>‡þßzŠ=ˆò›øÛgâSâBxZÐ;ðûL¤ß|ù¦0¾ôœŠð¶ûô%îO"Žþb÷±ÏÌï×2gI\@ü‡þR·ážˆ›èׇ«È>î‹>@ÕgÉ[y^…üY€û}¿ìËÿȹ÷%¤sµ&Ã轋í÷Á/“O†Ç(à©ÄïðþôŸ"w𓲆ߧn]RÞ^ü®å‰|ªp°íxÈc~Oѯ å=ɳ?Içé<Ÿì÷ÙI¯Ý·Ì;`üùäoØk,œÄŸ¾Ùyñ4&ùòäÁékÕ}ÐʹßWòj;)ÿã¾(éù ×먂“%ŸÆÌËꞈ㨛o=#þá÷u^A_nRÏàûð³ÄKì+ž²]Áo2ïK|"=µÒ\‚ã"ì.v‘}[Á|$:¯Á{ÈN#Gð{¢ØYã?½ñz'9@¯mÇÑâræÀUàE¾»G?ýöðè}÷“¯P]Âxž9ìxþìüËäÏÈ»p~Ì)*ï‰? ëÂÖ'ê2ÄëØ_p>òM¿¬¾×rÂü8–¹Ý}}~?î;À~’¿îA5¶q6¿/ý¦.É9Áãâ8Aòb~ì–Î }¡ßÉûÀÿÚ•––V*-í¸Ó£íÿ±=¢¥Ë›—?òò/£-ëŽ*=¶_f´­FúšŸòÞ‰VÝvÏï^‘ã¿oKñ†Eë–ßþf“ó/„¯3ÚövG~|ikôçŸõ¾©^ãXæo¢? †ü¸ð3ÿ»x<¢}þè6qÙŠhÏ¿y™¿Üm|ú_þÞ%Úyì„5Y{GEÛîÿnÍéV°4ÚváÖÍ~y(ö›úÏmÇïùô›c޶4ý©ÿ©NvŒlXõšŸKF[7.ÞtN‡MÑ®j«?PâîèÏwö]êi͙׎v.­¿1Z|S´§eáá«®,€_3Ú1øùãçUû3ÚöÉu[ 'Oæg9lW·£=Mª|\¯Søt£UoíYýúøѶïZîÜ|òÌhõE·þ¸ù›ï£mvI{¨ÍÑʉ7w¾³Iöúù\v\”¿»ÿQ‹¢­/l}ê¹ÛûFv9vÞÑ'G›*ÿÞ¯KÍŠ>wÎsû·Ÿ?^°qo´£ÒÕc®èa^9ö$Dë+¾_æ„Îs¢õ?iqë1K¢¥Îû㛕ÏEkÞì?`Ó¢Ï}®â·vö>:wå‘ýüž‹|;é÷_ûygD£j7ÙÜ;šßa~ËÉ…yÑÖ²——Z±ÿÒhç¿–ž7øûþÑÝÃö;*ÎjÞ­ïéÏOŽ5¥g“èçn{ªnJû,Z·mÿîË^@ßûç­Û›5ì00ÚòŸ=)Í97ßóÂn¥G|ì²hî¾¥OöÛ7ÎÿŸóÜвÊÏå›mè|]í¶ëDó_bä¾qÑæVë.øå§K¢…Ÿ};«b¿¡ìŠM™}ÊwßõŒþLÙsŸÏ²o®o·`ÜkÑ–ÎßœsõÛÑÖkžôöó‹¢íÇßõqk_÷{rΦ»«ûª#£mO^ônáÜ1ÑöƧ¾ß¼Õ ß+òôûØ×Ç´.ùN´òÄJ¯uZûžïsNþ3++FoE›Mmr[½|¯ì7Ùòù»¯>Þ´€ýÑê›w6Q?#ÑÉÛšýsKtùfZ´ó¢U',½)Ú”vÒ3£Oø:ú£sé×Î^ÚŸ½Î4ö’h{Ÿè¤N“òØ·m½eü¼{;`O,ÈÏ¿³äúeO­;tèΫÿ1‰hçί ÚöWTÜU)±;iG?7?-ZW¯Cöï—ŽŒ¶ìxÅÃåwG˪T9þžÛ¿ö9Ï{p׿ʮÿ(ZÜó”WÏÞásû#mÑÑM.³¯žtîø²«¯6-)s˽#:ÛnntËÉͶþì{zêÎÁßæEÖ<¸nûáD»/ÊÜôØ¿G?U~ýé}ÓF«–¯*;ï£:Ñ’Kî9ÿ¡Á5-o›'¶îMŽfÕ^8¼tß}ÑŸE[ß\Pí;ë÷òç}·×ñÒ^¶{Ë¿,wÂO¯W޾é\ýüf;{ø}··O+õ·ø9¶OËkW¯ÔÑÑŽÿüõ¸½ðØFK¿~v{£ºU­Wö}÷ùGNy"Z;pBÍqû»Fë&—m4¥ô°hÍ“Žh•ó›í(ÏçÏ•œ¯^þþïæ”°ÿÁ®h?v´½Ú¨’ŸßµÜò„žm¹ëƒJO4ÿ{h9ÀžaOøÞÝj\:ö•-ÏÜÿôìe ^éí¬9ñãaó¶ÙNíxð‘gÏýðhí-c:uÕùI¾Gòµ}Å‹îû°0Úrø¨l­ôQ´¬åoír.^áŸÛzrÛ‰m¦u÷9léxS¥oJ`‡¶ü8`ÎMKËÚ?®<0yH™n'E^øé›eú•²³^µ›½š¾Ì~û€¼¡÷øß•=·Ö¹Óí5·ìÏóßuŽØÓÍõ.nm^2{á•O¾fùæïSÒ>™1¤I[Ÿ/r¶1md󎟶þ¨Ôdd—Ýó¢m·ýÊ #޳Ÿçy‘ÿ¹_¾·~û‡lGð“è=rÀ½qž–7Ùu]Ы|w8†ßÇ-oùèÌڣӣŽ{IÍþC£í¯/ZóîÃcÖÜÚ·û´ÇÞNì»ðÜŠ¥Ÿ¹öÇ¢heݲe.z½£ñΚÅc\·*Ú}ðä_›=-šWk謃ú²7-Ú¹ñssÞëäsÃnkƒíœÏ+ÅÇlyÁßi/ºß¹á>y>þäýwÜzÂëGþšëÿ¿´RÉw:^3Âz·ãÀîJ'uþ=úýé:§7zÃz¹¹[tßë/UˆÞ;ë¾ürŸ,ðymÝ×há¸SêÛnX®%÷èÇu»Ÿœ¿Ííþu›Qˆv×øøû®¿Ð÷Ç÷­©4£ZîÝs­÷ÈÃÆÖÝN=åâ=ÑŽ—†Tœpéá¶¿ÆÂ;¼'úoy‘¼òïø¯Éey±Ü”ï°ß‰ß\>®b¹'Fs~¬üI£wG»ªœµ¤ë5[l_kew±C[æ·™ræ‰Í³vmœ¸ºÖ°\ÿø‡ûBn¹Oä‚óÃîàŸV§]øåý9³l—WUÌ}匣—ÅÇ>=u~v´í•oÖæ:âßþqѹÇ,9og´öâ_ž¸þÔ{’{Tü2iØ÷+•Þàý>ëî|áÚÙ£lŒk%÷èÝÆÉûÞÉfÿ´½àµ¸FÏÖÖCô{âsÔ÷roÜç–s^ùõ’'®õÏó~È/ŸËóÙßËþ‚“xž-‡Œ8õÏ»¼ïQ{bŒûÄWb=!Þãóø^ìñÌ®’;‡uù8×q~ü NÆŸ€£‰G´?Éx+ŒvW®öx×zå“ó:jÞï¯dmß8pÄ–¨ýþ9ÓüµqzÅ=‰çÐ8ÿŠ^YÞ»ývóÖGbßçoÿ‘ß}ÑW‹6­¸¬óbß?þŸ}›3{o¼nÐ{uìÐwü(qæš »²Yäs¶>5øvÒÙŸü¼sáÎv.°@ÿ—ô¼uñÚ7†û±È?·ëÊK;ž3¦FâŸôùànÎqÓ-w<¦äUÞÛa\¤x{×òæcÇŸ¼Ç÷¼î–ôÁÃGíŽþh}÷gMëÔw\¼íê|Ãwç ºÜøûˆ]B±»|/x|ÞOF~qÛèä>d±ø ä…ïÕ¾€hT³‚ë´±ý#/\ñ¾Æ…Ä›Ò;ä¹üúªÆåv»È~cë·{Æ69ù1ã^î}X2æà€Åc÷:ž[Wå¾Ü¯j-±žñþÈ çäxWö‚çwÜ©÷ä9ùÿØÎgϤՇ×:iS4¿ÞÈúqɾ¾µ_/üéîÜßý\|¯ý‰îùÀo,øîÁžÙún4í¾ÏvÛ÷`ôÃ;»K¼qÉgÑÚãn¬]®c]ãüúÖsÛ‘³b”q=yðvz틪õ:ìdËq+ö¿hü"{büÚùáÁC¿©aÿ5¥ÅOéO7:Þr»úÍvÿºîž1ѬN—ίyL‘Ï—8 ºî­Çî;â ï€Wüÿ¥¿Øcâ/ο‰îî~´ÿøgÏbž³¹^4ng‚ß”ßÇÇÈ΀¯‰#±[k»ÞÔ¬a—Ûw¯Ë¾pNåol'äŸÐä|½ò­ºŸ\Ô®«í vØñ—ðç;oìöžÊ[_X¾½ñÞú {O¹¤i5?8ù#å|–þœ÷cÛm§FüÞÄãø)p"xŒ÷C>9Wüùw÷|ðÜ%·8Á7ñ})*ü™àaùKüv‰<'xÿ¶ªnÞç¶wµ<ç/{£c§1O½ŸàSÙCð y$äóäùä yá}$ÿI<,»²vé°Z'G³ü¹Øß=}NýmJÛ[ÿ/ðyöéÓ÷Üš7;Ï‹<"çøEò¨à0ò#à¼É]K×krÅÇ~ïolX™YîcÛÏsnÜøvÏÅjTßr¦åüMüÎÁî×ÿ±ä„M?Ñ1Z¹äì±[ÛWô{a×xoì>rJ|‹]Æ¿áñ/ä Ðì ÷ŽÝ#G»o©¿ç½OÙϷоLß3yF>Ÿø­˜~.m¶èó7çù~ɧóþöë²7è q­öÈEë—Ÿ\­Â«™ÑÔ9OýsõŠ;­ÆÇÂÿàcì'õ ô…xku·¼Ôýî$nŽæ÷ÁØðöü€Ëø=òÕÄá|/öšüÒú.Ç<øÉ眗$?»jÂ’—:—¼ÔyYô|˜ó”²§È…p‡íçƒšÕ¯ßæÇ$¾‘$Ϻzÿ®xÏ”–¶Û>½÷¾RC;t|ku’o•þ./:»ôÒiOØÞà·Ñ;ä{N|Büe\ø'þÝùEÝ#q{ž8?ògä#¨§‘Gâý‘+ôéxJùkì8ùDò>àü/ö ÿÃ9h_­ë$äÕð àÓ?¾nT­éõçÚþ‘g2~Ö=oHëúøsíFÏÿ{ç°ûüïÔ#lj¯•G^ȧ€»¹_ž÷$>ãó9ÿÝ[:Þ±zGäsâß±‡ä+6LøýÙGnMêz.ä|„>®oU÷ÄRã³]³>)ŽÆÿ¢ßœ?v‰zç¾Â¢wØ9í'KòÙÊà ߎO¥¿üç¨ýmö<öŸGÐCãgù!ü1ç.çó“]o8ãÂæ#'p.ÈùLâ!×å_>8ç¥i—OüÓuQäÕç ÎV¼Ï=¹þƒ>齈«Á‹›ºÕm}Qµc‹ý;yrüžʟ޾kYRG義ç ø!ü?xù䜨û;nW>û°7ý²Aëû?⸆ûðóà1ߣü’ø¤œ_%žÆžñ>Ü3÷Š]!þ¡> .ÅŽP·Fo°î7PÜιòýK·»ú˜}[]ŸÄ>¬ÊVyyÝoÆè)8Íñ¹Þ½ /…¼ ÿÄc*|òÜýïoóyaÇ?<»üÔ'K,f/µíú^¬>–½^sÑ ÷>Y÷ ?'õ}êqŽ'…K9oÞƒü5rLœ³gøuÍ|¼¶å—zynâwðöûCO-§zoêâ®g©>çŸçýdOÃ< Ï WRïBNÉcñ¼È­öxÙNqN›&qá“/Žôý!Gè5r‡ü€oðGäeÈw¢Ï<‡ë·ò¯âívœJÜB¾*ôŸ<¸Aû,gÈ1¿O¾Åyiý©}¸Ñì̪Ë[4kl½CÎð'è+þ\E¾‹ÿ¯9 ç›ÑãwÙü߇_P_‡óÌø­0?k;«¿#¿äyÁ®êóÁ‰œ³öxE{–Ô™øÇ7ÑîA¥.¾cC_Û/Þ'ÌC¡Gœ ñÓ†‹¯Lûyì½–[ûCé7ÿN|f?€ßWÞ¹ñ¹ã¤7–}8å¹öwF3Šj}ãã?û{°ÄÕ®+ÿƒ]£Þì8‚º¨þŽ_äÞˆûùp98»ŠÅOÌÍéu×Iß­s}| žqžBõYâ>üržÔ‰ø=÷…IÞ}¾ŠG‘úX°?ÔÇ‘ðùògè7öÌ}²ïÔ;Ýg¦ø¿Ï÷°ÿ¼Œ_vŸ‰ìŸï¾±”ž:¾Ç.Z®äo,:'ìžñ¢ðÿÎýs^äó'RrÇþqçmø<ÕCý\à1äVõí¤?Kñyrâ•×Öý°xN¥Æ™ÄE{§m¿ò槬§älïßPïÚ^ñžØ;éŸq£ôÇõâ hi÷¼ß·7f?‹½Gþy>ëì”ó™È‘òÿø+ãê´ÊC ?àÎ ?⺠ìý‡–sÙü~˜ü?y ú#]ŸJÙß“ý³êüç#žuß öP¸™ó ŽÅ>7§Æq‰þN~ÁyP}?uü9öÎõ}þ{ױ˖]ÚŸK‹ú¦ë†ú|ì¾âGâxä—}ÚËc¿ê|‰ì»íºäbÎó§öj=v»åÐsÂ|8HçãsÜÛ¥õ¬¼IÏûsÁ™îgŽ÷½ê¼À9Î'霱Ü/ßÿÙòã¿ù\ñÿøwÞº¬öÔ».&?âçæ>Oò˜øSçOÈJ®ŠFtÑl~Q"ÏÈ¥üSßjþñЇ~ì6òí> }>ö=Zٲ¢ÛïüÂýàäƒðßÎoë<‰+¨8O#üM„Ïç÷\¿S_øš:.߃<ÐWA‡ÿ ¿Š¼`¯ÁoÄ÷øqðëáô7 Ÿ!÷øU÷›ëýw þǪ—w<-½å†óæ}ô¯hAæäò‹¯ižà%áúf¸äÍý5Ôë%§Ø%ê.Èø“÷°?WÏi?¡ç¤ÏÅvLú‹ÝÀÎwñÿÉïàÑôÏvEòˆýæ÷Éc`Lj—Áø­ÿ¸Ï@vÜÁßy~âvž; ®q¾ <Ã9«¿‹ó·ŸáOäü$9-jÜòµ¿Kò²Ûàâ5òö®_ÈŽ’W£ìx‘:¸>¿Ë}èýEù7^ßê{EŸÑOðåþç,zÜÛ>ðûHÕï`\BŸ«üŽñ˜Î\gœC^Vy¯0_€<`/©Wç>À%|žÿ.»@þ€ú7x—{p¾Hçê< yõO{„¸B8‚Ï×y[_‡—ùñŧZ-w¿ ñ'ö>/ê~^ÉvGñŒ?—:.za»LœÄÃÜó7ËKV¾sÂÏ‘wáÜù<ìϸiåj÷hXèú:z½@Ï\žá^ˆG¿ý`ôúc«6µ}/óûØ âcòJè“ú“¼Dêç?]±WÏA¿œî÷¤ß»L}“<7Ÿ+»‘ôaHžéƒd®Àþ|0}ïíãH>‡:Êþ'÷¦:&ÿNÝCÇùuõ»ÿÒå†nÚð¥?¿Ë}8ß ¹u({‚ÝWã÷Ð{ê¼àräÜþÞpÿÜxß}"²£äñ©C€gx>úýèS O?êÏ¥Î#û‚¢ß€>Yב™£P‰zs-|.q®ó\Òp'~ÃýÓÂôÅ:NS^¹æïòG‰\0·'ùq_¨òPÔÃÜ_ ø¹Äo#'Ô=¯¤xÑùAú+…Ãéß ý,øØs+­È'y#çK/!WË–n™úËúCyOôSs¢Üyg×£ñàyÙ]ê‡ô“€/íçôüÔaø=ú~°CÜ«ôˆ÷(öœÄÊ$ùFéþù¡¾â¾æw•¿¶“¼»¿JzþMçÂ÷óóž`îCþO?Ÿôaéþ¹Gü£ëö²ïèû~ô¹øM×郡ÏByéPß]?g¾Lx×óò›þSωqŸä‰3ÈS„qH˜gáû=ïÆ\}(Ê›¸~¥¾Š©]Óf¾xùdŸ?ñg½òç¾7é öËyòH:Gð ÏCß¿ó¨Ø ú{™óBž¤Çî£ æ—ðžS>:+òn}¥¿‡üºðòN|ï÷Õïã°‡Üþžºóè qñçã¹&òu²÷«kºik4ÞrÏýò|Ö?ôGöÖý¬Êo:Þ®Ãî`w‰»œwÖýÿ"ô³c¸OâFò#Ü‹ë‹zOäÛsÙŠÇ7ãä`þÿbþų{«—Ü4òì‡í[™›‚¯@ö|Š|XŸ%·ÔMÁíØ_Oš:½ÕýC­wÜ·ç†d÷Ñ'ú*ýò·ä[èÓ¡>ã<ÀÕô˹n£ï"Ìe¹ Ÿ"Wœ÷FÞÏó¥’gì u\üçÄsgƒÿœ'“gžšþËEòSØK¾‡þTžÓyHÙkÇeÁü&y >»Oýœž§Q yGæÔÈ›S_Ã/ gî³Ä.I.°ü;ùhìún¿ª{ö¹¨¿ý™yéK§ÍX3é›Òó{î›>t}òBü|~—÷Ô°+úWðïý ‰OÉeR_”BÏü68½Âëé·Ç.9ÎÔ{¢?–kôYx ½džÖß/ücý£_ƒù@Ý+ú¯¸6á7‘<{>^y$>ägé×à>9'Ïù#zNÏ ÊÎÒÏs˜·Fr矗½a.sÔý's@üÝ?sÒž·Ðó!ÿè%rHÝÒ<ò_®éÍ ¹#?c~ɹúÖü|œŸç²™—b¾Vßü£w{oþ1ÊâŸ÷p¾Ô³9Gã=ÙâòžÆeò øYüŠç_$?ø7ê*ıÖGÉ/ú‹<€©ÿÓÏaù”¾‘×Ý;iݰÝã?ô¹ût¯ÓÏüêñgç'¸„ùù)¾O}eÅæ]B¿BŸy Ï¡Ëû<Ç`ßͳ¤ûw?Þ\d; ßr';|(3yÍ‹3¿ºwI4½Ó¯—ݘÌáŸÁk¶gÒ7ðç¿&ò7ñüØQî'äá"Ž9Ô<ò‹}"?ÀÏ™· æø™¯†÷Ay>}1Ï ö€>JædtÖ'É­ë~ð”Çëïà p[è§ÌW£><ã-é ý3–Cý<}‘ØsôÄs²ŸØ¥Ñ j/®sÊzãJôŒï+êRùÕïžË÷÷O…~œsñ³ýÏ£ûw»úÞŠÞªóT»îLžSz\û=e|Þú<ç¿‚¹#ó¥‰?É÷£þ(âÛgìvRrb¾ Éý¸ ?‚ücuÞüéyá¶=íÛˆÆlIx‚<¦çâÑÝ}¡ØQ~ŸxsåçÂ{GŸxNæIB\ÌßÑCž<&žäÄOë{œ'_‚¤—Ø9—z|G¹¦‰óаSz^ÛWòÒÆú>Û=És7Ø_ó5pÎÄKê'ø½Ö‚Ï ߟôÝÑ¿#{fÉ<>sêÌ1)^§9ÿ/ýǾy~Yö»C¼K]Åsôz^ôÊ}:Ü—ü.q«q¯îÃý±ú|ãSÉþ•<ó'àä=”]³Þ3¯,\?x¸}¿àÏ÷JC=s\-{Bÿ‚q~^ïÇùÙç‚ݶ]‡ ï€CܯþK¯%.џ؃pNÔü[äåtoŽ;uŽòÇ ž— ¿8®Üaà9à^dgý9c×?ñS÷«nvþ4îç`×·<üÏKØ¿á}êüž<Ù-ø£÷]zÚú5ð^{€ûQ_dœ^.mûªÌæSOo2à‚•?vŒö}õh^õ§v™ŸWû£+¶(wiƒ8£á̼ ÿz´/­bËZOÍãà!%n†=:0"~¥ÌÛ8÷8í’‡>~æ×‰ösòkì¿öWøRÎÍíl_9?ÉyœVþ߃yÆóO<êÃ;³£ýÑ Ÿ7=x <¼ÑþÞCnˆŠnƒ×\À¾väÔ|ôi‡ÿk×SCfÏà§ŠúŒÉlUa?|¹Ö_îA}Næï†7Ü{RüìžãÿL¾7Õ'ï,~„ó3Zõ=8ý²‡½O>bïâ^šÜ1䬷2±gðÛ>àçn^¿ñý¯nƒ9:8üÏ7ï\u¼Ÿ¯èÀŸúŽimžü´Ôþ ü%üâÑÞVÃ&ž}j¥Ä¯'¤ü_œ³æƒÑm‡õ‰3Îzlè»u¦ù÷½g!àÙM›xíâëŽèœÔ›RýÈqÆÚOî˜Þ§qnœvüòÖÇÌY§k¦äÈ÷§xÂ÷,Ü ?/zŽãù⌬¹Óšfß”àãT<¿q¨xfØ[b;²oñ¾î<ÿõÆ8íáçŸ]øSwϪ_½doItpɈFƒ:·FÞâ´_zÑ£ìæølOö—¾6¯ïÄ–ì)°Þéÿ»?)¸oöÇÚNga´o§½|Þ’ÑwM†7Ù8ƒ¼âþŸÛ0ó+úªÍËŸvaµÞËzì7ß¹xœÝ÷¬ó1¶æ’ý›Ú£±øÇ£-7]¹þùÖoñõÛçˆÏæÕ÷þ×tíµ‡ÏZòk=ó~ÝÔ~™hŸøœ%OØÝ8C¼âÚ¿d¹ÒžÛëôg~Tî’qÆÕû?zåÈãôWç÷ø}ÔÖ8íöŸï­¶¥Ð~»Ë~qɱõÅ<Î;7w(_g—û¥ÐKp¥p§ßG|ÚÎ#GðU‹'§W츱êê’ûKí¯Ä/Ç´(]ØåöS`Gé7ô÷¦7ý¨cÖk“}åÈ¥æO¹´Á§}¿uþ9ø{ïÅNû¾ãäok6tÞì`åw>šÒo¢ýHú„6µ·‹’=§ì‰þO_G;ïƒ×\{OÀ ÉÞ¬ÔýúóNzkÌ•ÿH‹¤Åu/©Ý5N¿uø^¾;N¯Wyfö½ =‡ºÿ2Gÿsj}»±ôÐú$< ï¹õD~8N[wS•ÅyÕãŒÔ>Óè`Ú_/8|“åy_ç}ƒž\y~9AÿgÉÿ8o&\§U½£Ñ+õ^A/½Yø‘½§¶ËèŸøÈm2:wüuãÑ+¼¿UÏí~eæ“x^ä÷‘ß÷Þx {$ÿb9Ø?½êÛo~Ô{[¬¯ÒkîG|ì•rž=ÊøñºÒ-ßÉK~î¼³Þ¸ð„žKÂRw80ñ‚«¯_ÖÛ{ð¤§Ø3üjTTåÎ ½rnœÞ®W‡ Võ²þÓß`>rͧâO°¯šËHö?§öÏ»O÷_‡—.N?qåÖÞO.­ä©+?NkÜfáÍ•<)^pË3ýà4ú3„ÿ˜;cuJÛ»¿_ZôÔs¥û'æüüÚ–S­àPäøFq{#}Þ7èãϾªø¦÷ºà_…_<Ÿgž"áäÙvVö¼‚þ#çÈzj½~">$ÎÁÿÊŸÛ·i|•šóaO[‚s•—’ßsžLyaÏIü{Øí¹ÇØß‚ƒÔ/jœþN_ÞbBÖÎýqÚò')S×rKB_Q…õ¾š?ÒrϼôÌö¸ðàaí.ŸøZ†å=¥Ï}ø3úX÷liúüÃw§ðʵgTŸnýH›Õ¿ ßÐmqúÈÞ÷œö{Ðo\€KØ“¡½…¶#Úca=ïˆN?ö¼/ Ñkë#òŽÞà/Ðú>”Ÿð>&âÙ7ïK»oôíe8ƒ~sÛcöCao$ù#åG°ÓÁ|5{v¢¢­5¯rl?ö[¯ÄéÿÆ œ¯Oé~‹7Ï(/ÄþçYèK×}g뾜·Tœ‘ܧæ…Ð3É]œ6®rÕ©i[|¯Ê—Ú¯ ÷Ä9;½s䎇,/ì÷H_óôØJ9‰“—wË9NÆoƒkÙc Nâ|ÀÝðŠbg°¿æáÐü!ñ ÷ž~Ök?]Ú¼4v7N{}ÜÍOm]àx›}dØoü?|*Ìÿ‘¦ÿ[þ ?á{–ÿÅï:¿²sß]·÷¼Æ~1£éó7¬¼dH‚«%¯Ä¡è?s>è•öƒ?k¿‹í z¥ºJœþxÔõüÑW9ÏA<Â>H}®ãQðƒòþü¢¥½Þ[™ókÂ× ;Èya‡ñä—•_°½AOrFdö®tÂGÎ×Éž$øP8F~›½… ^O§ò)èû±¢ý-÷—\õ4ÛIäCñ¿Ov¼ëûÇÞÊO?ƒƒøüÄ whÿíˆîß¿gÜ®{Ö\÷ÙH¿/=$ß“µæŽÕuÆÞç}~äÅÁY²'qFéϧ,éu…ñøËyíoÂ.PŸ Î?h_«÷àÉa÷°Ïøù·8}ç´æ+%߃ß`¿ŸöŠÚÞiŸ¬íö¼Âý77ßy*¯ÊÞ¬äå_‘ì öž÷•|‚/œ/!/ <{MmGœŸÒ$ã=ùoú¶ÀÇÂgÎCðsÒ'âZöw%x:…Œßñà4Þ‡Ï_7Èno’¯µ}TÞÇù Õ_Ç¥îÑûXe·—a/±OÊÙ?“¿ΈÓÛ ~nLA'ŸÏEž\ò–ä1%_z/öœ%þ÷‡?]\þW _àw´‡»˜~;^(®eO£ü£í<ñùÞ=#_Hß<ÄÔ¡U—$¯LöÅü˜ª³ºS}aœûÉU§ïÀüIÂíÌÒg@ýÍuuÕ)˜åù™+£îçzüéÁ< ýcæ3€'Jõ°ŸÇ<Œô!Ѭ¹&óyê~èG…ǘ¾¯oß}óœ¿úñ¿_;ö¡aÍ{˜Ç•züÔ“™§aú ë`Ê›¿Žùùwx)\÷ƒ·—8Jùk÷H˜÷gŽÜutÉ·ù<õÜðH»LõHž= oÚò¬ÏEO]ešÞ= ûœ¨[Ò_Iþe癫?RÅsTž£Qß }ÄáÌýzÎEu4?ôÞï£s¢ûkÇFl¹ÿ çϨ ÓgáúwPǃ¯–<÷ ÎGÏ]ï¤N Ÿ„ú™‘ê€æ[Q]œz2ý<Ôïl”`þÜr®9HÞ‡~öpÏôA£ðÃx‰ú°ÄOâ£NúV‘céyQ5G<º€ùJå Àô5ÀC_öÜÏœusμïÓíßnrêqI¼êúØEæŠèSb_ ü½Ô¸Gä‚ßûßø;ý¨ôP‡÷Þ1ÍUº_ˆ½N’3Ï_©í>½'s&Ø-äÿN‡9Gú€™Çp_{RuAß'vÄukìä’sç¾™³eîÖ¼ŠôêÞB>Uü„åžýê÷^²wɳÏ3Þzˆ]¦ÿ×~¾Fúä”_ÀÏÀ¿åý ô»ýÀÌÍS÷÷œ¢ôˆ¹.ôæ(ÜÇï{JÞ’~cô>^ù¯bsô¿-ûv¼Gþ‘8>2ü#öÖ{»$'ÄÜó$à|óæâWé{Ö¹ƒ°ôïâ·¹gÏ‹Ê_ ¿ž{£ÿEöØ<Òðe1ï \ƒÝñ¼­ž¾Î_<¶‹æ¹fNO}°¼¿ïA~ }õ¾Oö…0Â1Î{áW±WÞC¿(8ŽsTŠû½t®øwòJ콂OÃ|9ð7¨ßŒs¥Ï…sò>*áã…v¬øbK_ÏÓ˜ïR{üd,§Ô Œ˜ëþð~óÜøaîƒ{ÄχþË{éo‘@yóë¨ë Ïè¡çbê È¿g>~Ù ö,x¯žü{8×á9ø9dWÑž»ë9 ê²»è ö¼‰ûóäù9p¸€Ïå^˜»^´ç®#gvÝnùƒgÜÂç`Âyäˆù6οFß=¸;‰Åïÿ‚pr°'Å< ü‚ø/ïÝPü¿ôçÑ¿¯óÅ>bg°ÛžsÜ—0¿¬þ)ò>ØcÎÍs.ôQiNÕýÇô]²UyUìkˆ™ÀŽ"_žÓÐûÐÏNçaOׂ>uü¶ùIØc£÷%Þ„GùoÛø>¼§Fvš~nž“û³]Õ½ÒWL|D¼ÿOP'KöÉ®‡ûŠà‘p?½þ$îoxŸ‡êfÌU¸ïÞ1ÍGÆ¢î£×sÂ_ ®ð\!û€ô~Ä-à|â,îÛ|¶šdo{žÜ/;æ½Ì}êû‰_ЃœÏÅÿ“@?‘_öã™O@~™÷!N§MœÌ÷z~4àS'?ç=ôËž„¼e¶W쑟¤Îß/sPô³1—‹ýÅ?ñœÈr̹zž^ øôáOR>Èñ«Î¼ÆþúvÝÏ,Ž5 v’¸Œ9Hpþ<Ì+-¸°ù }®n½sœ)ûç¹ö&j¹#¾†·ÜÏý¿àxò]îW'O€Î"¾áóÑ;üšðLÒMAþ•y|ïí¦?™9#úv‰è»Õ9ñ>ØOë¥î߸ž,Å“æ‘LÝ“ŸÏ{Ñ4à¸]q‹y˜§_‹û‡Ù =Ãn{o¼ðþ€Sá“•œçɘo<ªs ÏâøŠ}1Ì)Ê/y/!rOß;þHùâRü‚÷Ê0÷­ï1µÎ?Ÿ™çXRýÌ>_ì1vÿá8NŸë¹IézÚ9î_õÊb}þijÞë-¾Æ_°÷œ^°¯wÞ7Œr<å=•ÒwË-s#’êÚø-pyHžƒ>'.8YϾö\}ÀGD^=÷>É¥í¯ú¬±ƒÎ_ë<ÑGâ"ç9ƒ¹Ë)ùÉsáÄ'ì¿B®Ø÷~7½ôÀñd0g¾ý<ßÞ‡?×¼â¥ñ¼“ð£÷HßÈ›'áU·ÿÃþ·b‹9&}>ñ0ïåy/ú>Bî°«È÷ žÇOÀw…ýÃ~Âkäx…xB¿ççÀ¿‰'ýæ}Ñkâ_xIù;É>Tö<€—ÁƒÄAàípîFþÞoWÂ' ÿSÊïãÍÑù%ø”}¦Š“àAó"|J)¹Hò<ÂuœkÀÓ_ŒÿŒ8Hó ßòè›ófÁ÷±W Ëüq9úG|NßŧÚÍšo^Jp5yŽoŽù×»wtýÃ{Ÿø<ðñ íýé©ú~òž­¸¤ã9¿&ûà‚}>ÊÃùçáoAïùCx±½ÿnâÍïlÒ$™û‡L|)àOéy1œ@¿"x{û±LÝÛk¾Ùʸ'Ô[ÅeÅxtðËÜoÈ·Ký‰¥î½Я¢xÙߣ9sÿý‘?=Ö æ×ûÓ|Ÿä!Ùo¾TÙ5þÿÿv;ŸM6žäý¹7ò¡Þ+#y¢nC^ÿ¾sýHþ`Ƨ/Ì_Vþ!/ùü;ö{AüA^|»q¯ò]ÄðÇãÿ‡¼{èyOü/ù"î¹÷ÓŠE~‰«8æòùøB©ßñ^œv{º§â¿‡ìFqÞ¾@ÎÁ«Þƒ,¾æô™¯þ¦sõó›íìáç¢N+^š´Cüçºøþ{ù=ô}Z…ÅÜÑp«qqnÈ_…ÝáùÈÀ_ê½~Òü{=5O™ècÊ~ãEƒŸŽ]#>åùÉǰgýbß,s‹¼Ç”´Of iÒ6ÿÒ²?ë”ÌÍé=Þƒ€û‰\qžä¿Ì‹)û¤çKìXP_qY~ŠºøÿÄ9cç4wíÏùäø·wn{{s±ÿ/ž¼äût^Øcî—ü*üǼî/üÄûOɠߺW÷Œáý'T½½Îä“~Kpû«àïZ혬oÿÍ;¦x{^¡nòœ²ßÃyýÿÙ?Î9vÎÉþMò€<vû¢ý!Æ£ÔÅÈׂ;ÉǰÇzæìç^lsmíÊÔ£ý|ès›ÂþwÙUÿ]çî¿/š2û”ï¾ëi}Ÿ–çÿ,¯pßòGW4O¸ì\R¿’½ä¹ÉŸ'ç®+SÌáG¨sJ½']qKâÜ{æÓO'¸ =‡_~¥™£¯™vü‰{-c3³k}Ü#Þ£M¾ þ=gø=>géCòïòGì3#~eïs ‡ÅÞûK}Y¸ÇÿÎ~_úVàóÁ/HýóäWñgä‡ðOÄ]ÂýÅž‡÷AÎá7ÅNâ×øSršð”(„}$>Ðy$z­÷Á¿|ÙøG2îºÊ|ÈÞ«!ÜÉ=`GÐ_äŽÏc¿ñ†ü¸¿)ûá<úÞÂn°/“¼‘ðzèÏ‹éõºE%Nߨè‘âçlänNìŽøÅC}>ôßÁ›¼?ï£ü\òòÏâóÿ—¾'sâêÇoáwRý¥Ø{pOØ3ñ¯û9úiˆsˆ¸W凒yó”žûù½bÿ?Ô=W_¨¨<ÿ?¼Øª'$ö(…Ÿýwô›ºþ¸€ú%üÍø¹p¯~ >|Þ_ŸS ÈÿûÿË®&yÉTݲϯòVÅä ôãà4éMò¹Še?‹Ý·ìg‚g·È_¿õ¢ò3þwðµâ/ÿòoØ3ô?^:Ô}aú|ï§J—ýj„¾ó½øéОáÇà¥Ã¾Ã†Åny¿AÐG‚&Ž·†q·ò&‰½R<¿4¾qGÚ“õà].ÖŸBÞ‡÷í…ú^釰—à'Å‘þwüeè9Åˉ_KÙ=÷ãqþÔÉO/8·à9?Tÿc±ÿOÞ»B(ô7œ?ufòøup¸¼‚¼Ð_ £þʾþNüM]€{ƒw°ÛÄ«Ès‹ažDqM/þŸüE€Óÿ’²;þûÄѾèþPébù λ¡Ÿ;$~Á.€{Õ7X G³Ëª G_euZøÚâAÞ7MüG\NÆ? ¿ûó;žØ9áá–_ù﹡]óßÁ‘ø_ž{F¯_n®²¸C4³÷Æë½WÇñ3üóÄóÄS¡çÁŠCäÏÅn‘ÏüüÓåM¾Þ³ªþày黿|É?_q¾a<®¸¥X^‚ø~ò7ðĈ¯¸¸ÿV¼);¼ o&ø0Wˆ;U‚Iyübõ:éã2ÙÝù\¨'Pá¼çÛI܃݃{ÀÃÄØêÄœ«ð\âoÿËïáo„Ëýï’pM±|#õ2ì6z$9)Öçá¸UqOóµ‘?‘¾¡Ïî÷Ôû_»ÏN|ZÜv’Ï£ÞH–ø>4漉›¼‡Kù,÷±hÞˆz2ÏCÝ»ifø¡Ô'C¿Æ– Iý×ýøÂ“æ1U_û•૤~Nߊì7ù\úMðkôŸR×q>VñAÈÇGÝ”~JÞ›¼4òâ½ ð“—`€pzÀž­-6ù p¤÷+{°¼GCùcâUð2ýôÕ¢WàF¾õ óDKØÿ†ý"®çÞÈ#p>î/†ŸÞ@é‘÷Çè9Ì?­¾~âmì+Ï͹˜wOúEÊzª|û¡<ÏÇœýözoÛcÕ1xôÀ{,õ=æ‹…×^?õÕx>IýZ>/;¼ÓðÚ«Ozuú?©3€s<ç–:$Î`>CïEüÅsNßöýÃW]»Õ÷C^ÍýEìWß îæý?Ô¡ÕoGß}^Äuô£ _äïm¯Ä·âz&óeú=êºôS8.¿ˆ]ç<ÑGó–²D??õ[?û™åÿ¨¯˜ÿVýMôoѯDÝ›~ü.uWüzî9ú<ÔÆ<#þÜû%éwcGüæ­U_<¸ûbž\É1yJ÷{ýuU?±Ç ;Ï~˜`/¶ûøäé+õ>víÿÿzþ‹~|æécÒ=a7ÝWÇ>ÙøªÈçÑ_ç93úô$ŸìÑ¿‚¯Â½ðèý5äó<È\ <­ô¥ê=!gŽà³G>Øÿ€_aNKÏG>Ñý«Â1ÔÏC»o}Öïð?ô5’'"?fÿ§ç!žxþ„ûd¿{¥À#ê—3ÿu°?ܼ¹úÿè ñ=ù·p®ûKÞÅ<¾¼·ô€<ƒùùáÙ¥_WöÀsíðëOò9Þ»©|Žã=·ù…eW˜ƒ ÏÇû¾Ù‡(»á½Wð[sÿzâÊpï³÷Ó2Á|žì˜ëáê/ý–÷]ÁOLß={ÃØ/£Ÿc~Ü{ªt/ž7aÞExÿ®¡®F|r¨½ Ž“Ø¤ÿ>ã=é'÷œ€äÏûá¿ÖßéqŸ“½gá?Ã=jàEò®ŠÙïþå{m„—Ì÷ ø¾pøâü^²ÈsÞª<ýUàmîûÌ9‚_sܧ÷ÃNÐOO>‘<:ûAlGÙ¥þ?Ç]ÒWábyéoãßÂs">¥Ÿ‹>DâbþŽ÷ܸâ=ð*ý:ÄGè!öÕùùËólÄì7c¿¦Îþ{ç]Èß°ÇRzʽ³_Ñû*ÙD¿{Üá»”ŸÏÁOÈ{:Ž’¾¢'žKg¯œì~žóÂ/›×Ÿ=ÒwìŸò‚æã}È×P¯!î°ÿù+OK‚ ˜÷P?çJ>Òù– N>—~mïßÃÒ‡®øÍûQØ»¥8Üè÷•} ®çC¼o ¾Ü“"/î«ñ¾-ÕÓ¸'ú‰ã¨Wðû’›¤~ þÊbrÆ>vŸãyùê£ø]ïW¾1¼çë¸É1þyçûÈ™?…}§Škˆ‹½oAçÀ9÷á?,·’Çp.Ë{Âõ{àÏݡײïàLïscÎA}àá^^ÞË~ûÄï+î'.]_ñý2'tžc»íùxáLêŠøíp/!uLp qù|ô–?Í¿£8<›ùB$÷ÞÔa8îßsêì!Õ¹"gŽÿ*—Æ%ÄÛÞ׃½’þÓ_à=¢’ÇàödKžù^ϹÉÞq¯Ä‘ÄkÌÁ!wä}¨™Çùì%öQv޼ý»ä‘oâ6ú½“}¹ì9՟įÆqì™ÇŸÉ>Z®ÉP?`_*~Dö?Êç‚7áÝ1oûÏØCƒÿ’}ã÷¼ÇQ÷Ÿä9±'ô{ñ\ø{ê¹Øgâ6Ï!×û+®OôŽýÊÿÒ¿C=ÈyÖÀo0G)ýÁ¾ø|ˆo˜? o$|…\ žçfžò0Èv”~—ÀŽ$}Ê 9!½¢/Ü7ç}0Ì¡©çHÎë¯ñ¶ë3̱PC/éCÖ~„‰yA忈°§²ïÉ<æˆÂ=€Èy ñ=Ãèz?¶ŸR~‰| ç†|ª>öÓº~Ã÷ '$ýX­Øï1e‹yíwžAñö;D}ƒó§ÎD½Š~QüyjÞƒ~eøD½‡y0x äO°;ž‘<2ψŸGš—Š¹vé¿Çü9ò‰_Á>¸ïPxšü$q-~‘¿ëù“y1Íg{N 8Äõ4Ýñ€ç{… °§Ö?ù¯Ók¼\u÷¢bñ2¸ƒ>bø28WöÂПË=:Ž”À1Gd¹€ïCþ‹ú½ë+̵éžÍ¥ç£~Ög¹¯Ð. ïäññÛ<—ë4Ô™à‰ßŠýÎð%±÷J¿G~ËydÝ«íùMágâKï-’|âOȧ?‘ï[¦>Í^dð†ü q zE^ÔuDö¤kNŒü,ñ)ù'òwÜzâùeæ•ß¡oÎË(ŸË¾ÇòÄq>_üSÀß@>¿l<«ºK˜ÇB±ÛÞ»GÞRÏÏÿÇñÜô3Pçw=¾F·q§ð‘ã.ê”úÿÈ1qP˜wÅ_r¯æ“Ôó„õü3r¿.çŒÀO ¼÷iê{ÀgÌ“ðsð¥R/1O‡òLä¿Íë¤|.xÅyTÝ#çe¾(ø=‡’‡1ÿÛ_çc­øËŸê%îA¿„wñ·Ø-ôÑ<,â«#ïLß ¼6æo#!9Àî™ç“8Rÿî½óÊÿã·87üö—ø¼ƒÿcî•{dþ0œ·Ã[ËyÒ¯APú‡À¡Þ÷Ÿˆð+¸!äáñ3}\ú»ëŠ’Cìö€¼.ö‹ûô~Q~Oßï?uÏæ™’ž¸/Zü;<¿ý·ì 8 | Ï=ïí½ò£öãúü>þ¼Gÿ‰õ^éòþ@ðãȼߎóÁ—ºòçØÇÏðRß ¿C¾Wõ0x:ÜÇ äþïKÑû›ŸYv–¾ž“| ýÖީ߇¾;ìyô¼Ã9Ñ·‹}%®ß(¯]l9râ|´ôÐuHÕùà wÝMy,ú0Â| þÍóíð™÷37¯ýQÞ Ã~pêRŠ‘'æ}?²;æ Gßtoä½\·ž4©ì(zÆÎ:þAßCûJ~Gþ ùÁ¯[ŸåG,'z>ò<¼7xËq‹ìŸ^q¿*ûË…[½O”ýÖðæ©îÉ|.ä”ÀÞó=Ü#üôMR/æ¹±OôÑá÷ÉK _Þ£äÇ9G~\ɾރ¼iù‡¸DóaÍ·|'ñ¸êÁ楑ý£Ÿ“¾kìù^pú†½³>è¶ýÛÈ'ý‡–/Ù ÷ëéÜÑ[â~÷eé|±÷Ä‘ìk¢O–ÏÅ/²‡Çv@ò€Ýæ¸ü,ý?Ôàý7¯¥ä‡z8û†´GÕó3!$}œÜ|-ȉã}Ùyò~àúQÈ?àŸÌ«Åbõ3aWy/òÌñ>ü÷ùªos£ûO^‰ù0ð~•z?òŒ¼x¯‘x‚É[9?&ûýÏ€ésBn]/¿ç9©øžxÇý»Š[¹Ÿ-ßø׳È+ö½Çÿa'ÝïÄ>OÉ!ï…PwRüãý–ÎK(ïÁs üs?Ì-rœ3ü’Îkë^¨{‡uþ¿ûSɳéçðÓäÁ}ôQ!Ǽ/øØýÒäI…‡ˆã‘î‹þCü‹ã Å‘¼§yÛ„àiAÁ•Üz@Ý ý¡né¾êãàGéòâ?ÀGœ—qcÐOæyêó’òÔ'Í?­½ßüœãlø—åoí{žyIäÉz&9æçlçuŸð›¿{wЧãþuåóÀÈ ïMþŽó„ß—>xp™ëiª¯`W©_Áû‡Þáψëðs¼'þ™>ÇÇÒêQÜg›÷mè~ñ#œ+q'ý™È;õMÇ©ÔAƒºï‡=àþo×s…¼ùØ}äý·|}_Èñ-üžî`…ü2ü@îO×¹axNýgޫեÒÂŽ~?óé‚[¥_¶àXáv>ÿæ>7ÙQó—³È> ü•ðþ ùeÎ œ‡}|Ì×ñ\¶;ÂuÄÙÌo;.£o>Nxƒ%ïäqÝW@ÝCy·5ve5>²ÈrGœ¯ó(Æ/æ¹1ðŽâä^Häy„¯Í~Gçîø@ö‚½Pþ\âtxmÕ_Cž”ßóžsÙ3û âê!òOSOÝ9øÛü"óõpoè=yå‘Óþ‡ÿ…<‡ü¹€ÿço^}Bþ{8ç*<—ö¿ôßßño…sª‡üwΙ9"ý™Ô5S÷u¨s,6Ϭy‡ÿµ÷„?C|Aáµë¤ª[òs7òß…+5§ý?~î`>µŸþ™¸œyQæTÕuÈÏù[B>Ž€7+äýHæ ÿ:Gí:$<7Á¹ÂTìsÃ9nåÅÿ×ä€ùjæÈ™ £Î] ä÷ŸGÀ¿yÈŸúÊuîë×~”ÿöû¼ ÿÏçEßb ÿÿþÏý`ý ùJÿ׿—¹rîž ñûùp¯ üO!¿˜æ»ý{âIüÛç ßþ_¿—÷”¥xT’ÏøK°›A_IXŸòßá±¥ßE{§Í+¦}žKÿ+/Ôß¾‡òÿã÷þøoÿ¼âÔÿñ÷€ÇàÁ0ü+)üý÷zš¿Ï9ÑSñÕ¼_Åý}pßšCøÖ“€èo^< ÿíŸø#þöçÿƇÃCòÎP_ x;ŠË½òõªkûwøÇÈÿ¨?íïý‘ú éf.6À‡’Gó;‘¯ùß’õ­ü¯ùÍÍ…|)Åy’”§\†ü!{Žø%ÎÑü"ŠwÅÇòß~îÿK¼æ|Ÿæfÿöç•çù·ÞõRVÞõ¿Â~ÊCÄ äýBËbüäôïý—Éy¥âêbŸ/^«ÿ­¸ï¿Ÿ$yqêia?®ø¹ù9ÿÍçýÛç%ð‹ÿן§þüÿñï‰÷Îsä_þÎ^ªîÿÎüI°— 8Ò}ÈÞÿ?ŸÃÏs6׋Æí,öð±QwTý ɨ_:ìGø÷-ŸâÂ?Vsƒg?üwæôà±¢ÿŸ¾cøEà x¥í·ÕoJ½"àþ;Pæ.}—½á9ÿ›ÄÓ©ºÖß>_È¿ò…ƒ_BÉ|oÀÿö¿æÏ?Š?UyøCò(Ó¡ü{ÈÏü?Í×Ê¿û9øXà5xýþûöó¯|_‡ü9ï]RýSyßCãÅQØå7üïâ/>t¼«y;í (.‡©üéß>7}?ëßçSv#´ëÅ~Nõ¡¿ý<í½ø?þW©´´ãNw>œzõ2ÏÏ 'SG§þBþòÔ|Þþ“Ë”¨Ü&Ù笽ÔØ7¦¿És‚êC žnýI?éÁ>yS§¾ó¤ç½YsJá>jú¾¨ЯùxÞŸŸ£o‘~Ò]o8ãÂæ#“>^úÉÙªÏ3ošþ„/ƒ¾Nž›>ú©óÒ'I-ó ž³ýOý¢ŸÇsKzæ°Ì£:ýÓ~_õ³Ó/DUÈÅ}Ó‡ã¾~ö¥ª…ú&çÏ<ÿÎû)’ìͤ_WøiËýeW=ÍuaÞƒ~•p”¼%ó2œ7õ8ï=d/§úìÂ=Nž§W}”þÏ5ª^B=¹u¯ôù2ïuMÉ)~ïežÝ{X%ÿÒ⺗ÔîšôQ¨žÉyRg¢Ÿ›z©çHÕDŸ¼|î âþ¤_œ»ûˆ$w>/Õ›Í;¥ú>s\È3{v˜ó£_¹&ÞeÎFuÕ8íûŽ“¿­Ù0á£Qß5vˆóæ¾ÑSúOÐsúX¨·Ò†Üпh{‡jÜr¥Ÿw¯~Oä{ç¹VÕùÿ<§í{6Õ_Š>Ë̻Ğvøy˜ã`Ÿ™â¡Po8oìöÃóæò£¾Wõ§ ÌáÈžÅé;n¬ºú‡¤Eóî«á¹è7äóù~>×u]꼚sòóÊ.šç€½hðºÉ{O¶ðçGÝžRúÙ<¯¨û…‡–÷Æn{ þÉ;ó'ÈzÖK¼÷\~’>DîÙúË{H_xÎ/ÜOí&ü[ðCg`¨'c§É³Yå±;ڜԕ5d>£Æ-_kÑù»¤¯QzG=`¥ý`æ‰b?s°Ãçî;s_ÕyU^ô9 æK°ËØ/ôù¶ÿM~PtKÛUç<Ý"áK€G”=ö:äß7ߟžÏs9Ò ì&Ÿó|¡î‰>aìraý•¼ ØSx/ñÛð=Ù¾ÊN"ôÒ‡+ÿ§þä¼e/ôµ\`ÿÀkÜ}b<·ûÝÕgȽb_ñ[Æ!êc¡Žç´Ý’Þ¡ïûGœ³`èqo[>ÍûÃ>IÙYä‚ïAnÐϱ«‘ÿÏÜû—e+øS°oèï…=(ZÚ뽕9¿&û×Ñ?Ý7ó–wúÌà}Ô9âèGÄß!Ü7ýûæÿÃþËo[NtôçñØôÜ|vì¹Ç®é<Œ“Àõ²Ëà#ú‚ÀŸ–[ð;÷ËaöÔ¡÷zNä½åœ¸OÏ ¨?ËýI:ëƒì0ýsî'"®Ñùð>»Î¸åá^ây2p¸ØóJ’?žßv—=óÄ ì·e~ƒy:ݯå)Ø{Gòç>9æMe7Ð#Ç ú<ž; Î<°¹ÏÍS†ÎHx/™CÔ}`/Á%ÜýÀÈzÈ1ßG?’y_e?l·ôœò»qZ‹™êVͲ¿ç¿éÿ‡¼V¡ŸÇ wÄésw¼þÞWßDû(sô?§&qö{Á¿b¯Ñ/ìƒí ~þ@•“»ÞyÓg‰_¾·éœ´Ütåúç{øÂ½ÙØ3æL­ß’Wð¾y»Ô‡l^aæ°$'ØuüñÖ¾ÅûºðüSŽ'xNâvðñ©~~0ü5Ïg<¬?9>Çr+{‚œCyô ÜB_9zF¿.v“Ÿ7.–ß7–^‚÷°ÃÆmêß³‚S…óÀŸÄ»ðeƒ±;à{ãUæ”ÕèóÓóz>[òeyƒOR÷âyáyë1{¶õ\¶?’{ä2䡨¿ì¤W‡žþªýßÿ?àæ½‰ÀÇÎèóÁñø£ÐŸáG™ƒóy1oH¸âaãér„ß5>—Ý!Þ³]ž3¿ ý®rìïÕùlW±Þe×;¯cû%|†Ÿ`ŽÄ{ܱ¯ôJ™á\è?õû«Ÿ¹"ßCœO¼«¾¡8ýñ¨ëù£¯Jð«¾Çq´ä|jù–äùoÉ_ gôÉâßéÓ³^ ·*nˆÓrç¿»»÷ì÷齂x4±¯º_ðqh1û¨s Ecÿ ýçØ-ìö”øÅsx’_ÎÓñä†çvü€ýÓ{€ãÃs¯`'9ô“|§çè—p.è¡ó3ú\ä…~bË=ù\øm”—à>.ÑhPçÖ ÞU<Ã\v=w^0ˆÌï.½0Ÿªî‡| }ä¶szì,÷}08¢ò«O&ûëõÿé/ÂþáŸx.ç[õ¾àÝK÷Ïè~cžïßùåÓŒ·¿a¹äçà¿Þ$ÏÅýyϱâ˜}›³¶=½C²o^ö?äÏ…ß¼$ùç~°×Ä;ür>·]•žp/àîÍñ²Îßûˆ[ὕ}ò^ì:q¾ìÏ ¯4ÏŽ ®q'=Ã?ÀGè3ùãCý<ÏK^{ÖÌëšì õ—û&!;a~,Í8î•Üz^\ÏIÜËû÷¼¿çˆÏæÕ·|rîž«F_uÿλɟðyä-|ž²–;ò$’»ƒMîrÖ[™ ï1sƲ{¶K:7îÅók:'ì"ñ'sÆß:/òßøžÓvÄ{ W0ßk{O|%½ò~øÁå_™ou¾RÏOž'¬k¡WÄý~ }}‰3Žéòçžç>÷¹ÈžÆigÿÖ{ÂÇ·O;o,{+û§Ÿ¸rkï'KôXv×~ˆ=,Ò_ï-Òß]Ÿ"®“½sÜŽ^¦ðø2N öq¾ÓŽøzÁá›|æ-„C<-ð#‡÷K\nÄ/q¿èñžëªÁþ'ð7ö@ò§Ý7úö²Gœa¿a»/üdž‘À^cGíÏ7‘Wr=Z~Íy`ùkû)êçA>Ïû?”Ïà>…\ÏCO'êyàãr½ˆ~„€‡“ùç‚úñ©qùSê…ÂÁÜ õ žÛx]zƒ}àþ¨S†þÍ~’ç!o" }(ÆòcêÓ‰Ó^>oÉè»&'u>xª$OÔ£ÌÏ'üEÿq²óQìc`߈æ~n^¿ñý¯nKxK9éörï!7DE·%<àšsE$ïqÚ“O¾ ä“ökøWôØ|ò›Øgøj¼£ó%ìï¡®{æyÝÇ ?G¾”çã¾°‡Ø#ÉÏØêþ|õüNï/Ê¿ñúÖbûŠFtÑl~‘Ï |‹C¾·OÙ8}dï{ΈG'Ùð®ó…ýwã'âQç”/E|N’§0ßÎ\»ûúÔwfÞ`õàO8/÷qQ‡Â_ñ¼ò¯ÆŸä›äñ—îOÓ9¢ÿä=\×`y}x”×8ä ¼—Žü€þÎs¿Üwéië×$ý™Ê‡:®&ß.»ßá}ŸÆéízu¸`U/Ç«Økäžs5ß7ùúCè—`¯ˆì™y†•?å÷ùÓ{~ü༠}Œ²çØÛkð¤~Þuÿ`/òaÁ+øÒ¨Ï¦üSœQ±ù¯=zÖzL^Î÷¦ûæù܇I'q‡þ$éþúL˜+'Sß„?JøÕ<éÂá}€/8÷1éû‰7Áä)…oü¾Ä[!Þ繜“Ÿ yɼg…~jú¶ˆÓ”¡ÞƒÜþç›w®:ÞùHìƒãòoÁ~:ô:¬óóžÌ:¿JþYzˆ\iž1N»ä¡Ÿùu¢ë–~ì)ýªzOðŽóÃäçÑó”ÞÆçõÆ…'4HäBñŽìˆç9ìßtÿîo¤NO<ø?øßÀÛà&×%©Ó,<…\ºÎ$<ò>uöŽP§VþŸ'.ƒŸÈ~úv‹<‡âYæè[Dn]O¤oD÷‹=ñ^Wø)‰Kñ··ÿ|oµ-…Öêùäá×2N b:ùKøìÙS«ß§/ ¹wý|†þ¤¾Jó¶Ã%=4Ï<÷Ê>]Ù}çAÀWÈzG½~ÙçÛð_ào‹óHìíMÅ-I…¾ï°ßAò㼎΋|‡óM’ çÙ×a¡MíÅí"Çoî+”_Ógã}Ðð ŸÁÆ>¿îåNöq¦Î=Îx¼Ò-ý”Jðšî“}Ôg2ž­ðȲm—›ë!®A.½‡F÷J68Ïu\òÃÊ¿Y?èŸ`^A8Ìy(áêÿî7&oÇœ ~þCxÛáÇdï¤ì”÷{VÍ÷,{np"ù}¯ûvtïì÷&ÿê¾Xá4òùâÁrÞÙ{œõ¼á¼9|jÜñü}žëHÙõ´°ÞÀþÚÔyñÒÍ}Í´ãOÜKýПã½0z>ä‡<¼è)ÏéþCpõ|öÐ(¾ Oí=SÊs£äMüwêÜØùæ·œ\˜—ôŸ(¾N;üßÄ3ŒoÔÿ—ðuÐדòw®Ozo—øþÜÇŸò!O\bS?Wl»W¬>ˆ_EO¨ûêûÙ7î²Ý…¯OxþM>×ü›økòpø?æöôùÞ;€}aÞW|Ïð2yîCøÙxTy êà?óŠç’>ñ9%y~Å;È“÷4éßÝß!¹Z|àÛI¿ïHx[¹ÿUËW•÷Q!áGV~Â{ï•×q|,dùÇ(?öÿ!ßaüLÿ{ÿZúRGSç×}÷Ê<œq‡ì üÙÞ£$<„<ÃóJ? üø-ì!¸üÅüŠûâUwEî¼ß“þù?ø0í·©Jx.âSã*é±ûÄ¥ÏÔýÈ¿"G®{ч§:Ï•ùRÅÉž3†×^çâ(ä¾3ûsò’wÇ=Ø¥€'Ø|Ìàpó†ô è÷Á_Ö?æ›$§ÞOÌ<'<ÿAŒ8ùp>^v yvŸ…pÿÎ÷ç‹}'9þÑŸÞWI\L~AÏIþÛùɧ÷ʯRÿv¿5öš9ù9â ÏíaÏØÇ#ûö3˜O[÷꼪îÅsïzN÷ÝÓL¾›þ;êxôáëçÍû­úzO)ö¿êú“ìªçöu.Ž•?ç|áûÅž8þ•žy?˜úïð·Þ(y"ÿ¢¯®o§ì@œÞô£Ž=Z¯uýØ}¼’ì,üÇî«Ñyà'eÏ“}3ÌIs®î·Uþ޼Š÷qÓ_LŸóóäsˆ+èÛä\ä7´‡;Áå²÷Ä È'ünžÓ“ÞS‡±ÕóÚÞ`¨Kêœø½pÏ„û(™OT¾~!žŸß'<ºï•:«äÛñiЊþãŸÐ#ñÒXßœ_eNYß>a*}¾p¬î;ç¾}?z _U˜¿U'ás¯>s7} –;椂¾Jï§¢ÿ‰ú}Àáüª~Þñ6{…SÐcó{(Oâû Ný œ+úë¾ ½r_rà9<ü*8˜s‚¿DyVôÙþ=:ôï)vßÏ¥<9ñ ý«áÜ'öÊ}̽)ïF~Ðû¦˜¿ÿ«]Iê¤^âýxîÉ|úÓqšîÛûàÑ{ì¢ìþÍs*ȧ~ÏŸË|$uMÉçmy¡¿CõTðÂìù%oCß9x;e~øqd·‘ì+Ïç|šäÀú _¸€<¿òvîg—žÙé{À­ðãz>Oþ…¸4œ&Þ0ŒêTá9òþÈ7ûI<Ľ°ï(à3Aîøwô“¹Eæ=_Àœ|¼7öƒ9}Ýöý'>±¼ÒÏ$ùã½ñÄEæ·Þ˜I¿ïù;æÏ©{¦ê±žÇu_ƒîÝö ˜»5OðxÍç$=¤Ž`~e¾\ßÞ ÏC£—øò¿š“a¯igyÏ ~ùó`þÔsr¡Ø'òÞüžó:Îû…¾‡ùÏ¥JÜ7%¿N\k¼žÂI^âRê)äÉÈŽ»nð1ñ|žC!ŽQ>Äs}øÝ«û”™¯@®%çæw¡ßWúŠ4žÐûzn‰¼0ýœÂ÷ž ïYu}ì Ïá~}úu¾,ϦþžðÉn»?XçHÝ|Š>±OÓy#é1ñ"ïmû£s5–½õ>=Ÿûëá…Ð\þÂ~Þ+Í‹ó¹îϦ…~1Å—Î+*ÎD_øúÛ°Oî[¦Ÿ ø:€þtž€9qæ…égeYõãø*‚>UëYÀçcÕCÝ—,;n;D\‡ÝÓçc_Éã£æ /Ëÿð<ÄgØAú‰ÀÈ%ñx÷wŸ¿pŽùNTÇ3Þ¤/¿&;m¼!ÿDœÎ3o¡?|ýôäIçÛ‚k„/ÍEÿoê^“¸ ýg¾Z‚£¹'úP=Çœ­âaÏŸ2¬|_ØÀ)ö„û'roà~ÏKpúæú4óÄìV?óÛð¼ü}Æ1ú>í}±/°_œ|©ñx~#úk„»Ðã5x)ÈËÂk€ŸR¥ü»ùÿÜE¾^4=¿ñ&ù#ú±á¡x\¿ æ‹Â¾1Ïk çð´É^àOÈ·:ß ®%IÿóAð_c_6y<úÚÙJÞ‹y¼€g^Yä_ŒQönõ¤sÇ—]}}’Ÿ"¿­ú8yfL~&ÎÔì‚•ƒÄ¥: ?¦ý¼8«kéê&oˆKËZ±lß9qVÚ;Ói4žºsœH^8(ÎQ²Ý3{ÆùÃçüœÞý½8£sÇ_7½"Î2»óO§5ˆ3¢ï+hÜ:Î^òÔê+vgv¼°æöÇߊsjßóàñÇ–K¬ýçeg>\7ÎÛR«~­Á ãÜË&´úéùqÖ]{Ø×qnéŇŸ–·1Î‘Ù»Ò Å%*î·xË™q^nÃï'¶[gíê¾qL¿:qþaµ^¸ûˆsâoÚ²å3ãôWç÷ø}ÔÖ8{R­ý&îôï•,»åد_gåå¬nõøô·$Ï×°aÃ×_û¯ßï{öœú§ý®=ì‹£.ÅçÒ×gæ|Ófñ‘Å­úœ~ÙÃqvå£gϬ4=ÎMÍÄY¥|;ýÎ~qaû²é9šÆ™S޼{åyŸÆ…Ê{ÙÙmãSÎy®Ç5[ã’zOÕÕãÜÝ kv\72ή]õŸ?öÞîóˬܽÅ¿mŠ3›äT©¹³aœßlõkå6÷œXVócO¿6#Îy®ÖI­~îçöÿ|Ì»GMŠ *­»½é¥÷Æy}PùˆÖqÞse;V¿òÆ8k܇®Kÿ.Nÿ¥ÝöûzÆyCªŒ^·oUœ=¯|Ûë_œçÇY¯ß~OZ\â”9 Û¤çlžwÒô¨Fœ;äˆÏuq\ò‡?]\þ8¯av“Ök®Žó†ÿ¶bp[â¼ÃªM>ã‘>õ…Æ¥rvU©së¢8c@•;oiÑ)Îl6za·éŸÇÙ_;åºR—Çù­3wý˜ýLœ5±Óôz–޳ž½þ‹/o3ûtœQ±dí8gR›ã/çör|vµ…q‰V,;³ê9qáÃæTª÷f\â²^™æ7ŠÓfõ/è7t[\¿—êoŽK6ÉY×rÚkqî+¨ÿYç¸Ä1­æ4»ï±¸à‡5 ¶?¸$Îï°eà³ïŒóî7¿ÃÖ2qvã7'=|þ2ÎØµ­m›veã¼ê£§ÏnÝ>N¯µ|{¿.ÄÙ?Ì:ã­5-·ú½8û®Å7e¾Ô=.1·ä²«fM‰KÈ>탓éwŽK5)üyKÞ#qÖÁG&-Ù²Í÷œÛ<­ê]£;ǹñµGŽ9[œ¶î¦*‹óªÇém?7¦ S\Ø0kÅöU‰3zYxrýóâŽ{ý©™_Å“Žª°âÜö̉ę5Þ.š9íbüBœ½ö¨éÓÔ‰³îï°ò­§®³å´ï¼vrµÌ¸Tÿ­÷v>æÜ8»áMÕÿy .ñþ;–¿©\œÓ5ï–¶¹»8oòËqæÛ%”Ý]6.˜»ùÏÞy7û=ùÿÜî!ΜûÑùu >XÖá½oîŒ3NÙyWþqûâôå-&díÜg·ºõæêß_FÛòoûãû8óÎÅ•ÚZçœÒûÌÂN°^¡Ÿ%&ž±üõ&'Å™»«6¸ æóq‰%óT89.è˜Û>ãöÇ­?èoÞ¤cN¯Ù{r±çÌ/—Ë) zúÞ rË[8ó†¸`é >’ñ@\ØûÀÍ»o¿,ΗVòÔ•ŸÚ.rŽùswîz°Ô±–;ô*»\Û·ZÝ7ßç›/¹G~³»<~Ò”…5âÂáÛï{ͧþ^õYǹÕ]Ù6Ž37¿¹dDzn¶ ØÍÌrM¯súÀ¸ Íi7W¬óIœµ¤NfÿÉEqN›rÿèWtœ[vd½÷Yç¬ù`tÛa}âì-/M½¾_#ÛgÍKX/³Û7˜¹­Äš8ýƒW®=£úô8?gVé¼ÍK,7è+ﯹã8£ôçS–ôº"±zΟ—w÷¸1–ƒüéG5è9ú×8óΟÿæÛœ!5g•›ÖÝ÷Zкb㾕>¥_'Îqüg»>_–;¬Nï1=㬲=vÝpÌxËSöa£Zξ¼|œ“{Û½ïf´Š §­Í-uÆ‚¸`wÆÄW¯çÏÍ’½Êî?í%†ÅÆ%õ>œö¨¾8§ÏÕ³o¿|I"©çôïqNykså—nçvrØÅç²]ÆNò<Øí¬núà¨ò#’{›Öçåõ§ô·ÅòþÙãzöºtU¸ }•om®>‹óÛç½wó÷»ýÞø§œ²Ï=”Ýï›87…—ãìS†_1,º5Κ÷nëQ‹ï3‡gçn{¿‡ýVz×üEåŸù¯Ÿû`h³r="Ok¹C¯±OøaìF~“Ó+v{óú­âÜgg¯ÈxøÙ¸D×§nÞýgiNé´ô¯±..1莛?l7<νk÷éÛ—VKÝàþæû¾µÿÎìÿæè«•HäJß“qÖcCß­3-ÑËéMo\Rºq\ {¤ßUûÑ­'ÙÍã6C7°çÌÝ{Õ¨ûZó•ïýá·åã¬5w¬®3ö¾83î˜ùù°4ã‘}lžtZǸÄÖ3nZT¦“å;„½âžŒ‡R}²>wî=gJæªU3¾Š³ú4ùÄ–Ýö3Üö '­rÅÁÇÆöw™­®þú…RúïÆ;¥Znï¾ÿƸÄÎ%Û+ÌÍŒKö.Z4úšÃmo².ë~RÁ9m™“öógUýE£E—$øLv"÷þy»Ë—¼ÖŸ¿+1ãÄm?îý/\ØdÀ+ì¶©8 áOž5îQ? ý‰õíüþñ£­žô9Ô(¬»©ífÛÝ}©q&ótšÇ/<ìè q¥’qÆÚOî˜Þ§“í]ÞÁßk?ûk8¯u£;¾?{u\ò­ýy§Ÿ<ظ2¯Ãí;ÜÕÕr•¸'si?_î´{_3.¶^¨žè¹ÑÜ%Ÿcòº8cKó+¾í;ß#ø3/5çç jÜü°FõâœøŒW+žqC\"¥¯qFÙ .xyóc–ä =Ïûí¼7Ïþ\ã"ð£q£î/;§é‹ÙfÎÅúœä4îôΑ;2¾wå\¶èŸWþò˜ïýàþÓÿçœPÀ½x¾=Æïà'¤ä%âÂû/ï¾½,¸Û8³ä®ýÏÕ{÷Iî5ÎÙµãÑßZÕ4~·=”Ü£7?^Wºå;yöÛÆ“QŸF·~›å8;‹ßå=²6wš|íwÙŽÇoÅY?o°óôçÁ·äGŒ;°Ïè?ñ Ïã>Áïøý¼S~æã êĹ]Oß÷åÛ±ÿÈ{Ø.Hð›ØSpqÁòkÿâþ½oYñ|œ.üRróžŽGÞ÷¥ý&~»ð¹Ãn¹èýRqöðÎ=gõ ýäÖü/÷ŒižÍóôœ›å@v\ßÖ{ÒŸo¹ÃÏb¯Áѳqî©i\sË­ŽÀØ¡’ÍËV¿®àxòÙq¦ì8 yï ¯èWfíW³Ÿ9âSûKüœýn ?`WÉÚ^ó}%ÓÒW\½q¸ã â"äýâüðŸèGf——ïürýZÛ‚.‹Êïm8ÎwÔç—-,Aþ'.œøçþ‹Ž9+9—]Sö¼äCŸg©ÚY='MkR,ÞÂÎdÕúycQ‹tãXõ='~O÷"ŸÈ~ˆø–çÅ~‚±ÏªÓÅ%õÿs+7ù×ì+&û{r×õþý§¶qÆ-Jv9Âñ=q*8œ…=÷aGòß/Ö.µàÛ^uãìg?|zÊ’áÖûmKnŸ³Æ|}æ ß q-þŒøïɪ>·Õk¯çTêWªBËì8·uV³Ÿž~Ì8»W¸ëÏŸ^9úøpÐq§ü|ñò¸ÄÝ¿ìÐù8Ë5òФXt_ýN&ñ²ðªçFRóÕqÞ®[ŸÉ;Á~9ä>Á –wÙGä{³ÿW>&W¸&ÿÙ]7üó¬ò‰ßWœÄýGñœŽ3埳N™vo“›ÇÙÓZ÷ìÖçœÄ¯€wåÿ9ß+vVþûA¾…ÏG_ñŽÇðc²‡Ä9ø ü'ÏŸqõþ^9òcÛü6øÂöç×}€;yì;ö ;áøDøÍ÷œšó½‘Âð}µfMŸþéM¾?ò0ò÷IœÙ~öMc†—|®ô)gVø¯8¡ñÅí.-Zå| Ïm½®*è½ãƒ_ßyȸûS˜Ê3Áßgÿ€=¾ðœ\‰«ÚW¸ú¶+o×Ýçªú u/úÜÌSEŸótô%SgW½$ìGö^ø‘á­T]ÅJýycn¬—{ÞyVó¸re~[æÎÕ§@}ˆ÷áóè»ðü%s±ì×E}´>?øæà€WTçA˜¾Þ°ßÐý`:Oúƒ]7U_÷ÈϹ¿~XÙì(ýÌ­º¯QõJꊞó x&˜3%ßɼs®Üúå½tšÓá~Ý?ê_p½>ê¬ÞË"}rŸ<ì퀕="ª#GÞSľõ a/Ñ7êÂæÝý佑sú'<_¦~ž`¼‡M~Œùúb‘GúvéÓñ{Èðö3©óNöPÒO&ÿÃ{𷉾iøoU·6Ÿ<°âÉd>Þ¼}ô5£ð?ÐçÄÞ+øtî ú1Üg¶ì½û dØ—òMпo¾/ö=é\‘?òÓðâgÃ9nïû¼-Úsב3»nOæÞô?Lý©ÔýÝç&ÿK s¹œräùaÅ©ð‘"o›ÒNzfô ¦çÇèb¿•úƒæÌ7-ýwþŠ>7úY4ßὌÂ_ÖoÙiú£[ì“õ„½:Ás¡îû`޽Ì÷0×Iß:~OòÏ•ùòuÔwÓ·NØ4æºÖSxHÂ}xžS€—}ø9Ô¯l~9ù ï3À^_a§˜c¥ïƼ²!þ/ysØ?˜sÓÒ²þúpá{BŽøwó2÷¢~8Ï=“èwÕùz^>&ùæ¶|ÎÁ5ìX`?­æ^1¤úÑkp¸“ùÞeéKX=.éõþô9<âÇÝ¿Dÿo0ï€ü#èë¤OËŸ§ßŸyV<~’ü#÷Èü1æ!Òÿ7¯:¼½ð”Ê`7áññ|…·ó¤o›÷`þ¿Ëž䙾h÷Ó{XÜ¿ô³áÌOý¼Ì‡ðœò'î+¥ þ*é‹÷“ ¯À£ÿšûFé³g_‚ÎÅsŠÿÂyì0¸ŽÇ à4üÏo;¯¿Û¿É^'˜Ós¿s²ïæïQß#çâ= ’oóó±L¸Œþ1ð—ãZúÙ›ØË‘ü‡ûêè_ özêÜ’¾|ö²DþþPLJòïÞw‚}g^ {$9åó'ÄiUïhôJ½W,×î'OÙóã˜W^}‰Ž¿á»f¬žÏüwôÑÓ·Èyï#ûqô'çμ¦ûƒÙÇǽ/*Þ3gÐ/(;AFâÇÙÿ(üéøEòŠc½÷Zrƒu?/ûš±kà7Ù-óüHy^ì(çÂܸ`súà¯×•‡÷¥*鷥Ϙ8[þ-œ3²<2oÌþf悘óbŸsvò?î×Οpž{‡™ý1:çp5çƒ]ò¼ ý¦:7󳳯H~È|ÒÒ?ïk®7î=÷~#xœ_iO’ó5æÁc?h°'~¾pN¿|œØWÍi8ùÙÓž'q>Ýï…žŸuä°]ÝnLú]ƒþ^ÎË{0°¿ì땼x¿ƒò9àòp¦çàI o&ùæ¾ÜoœäÌ{Ò¤Ž«°¯Aß2ü%Ž;åg=!ÿæx¹æçÙ§ðHs^Þ“Ä>=ÍW8_Äî›ó0¾ Ÿ üÒχ…¼/ûy$ÇÈ;çâ½4A߿ϗ߃ÿ”ùþ0žV\ ^Ãn`<')ùØXéÑsk;=уԹúܽ_˜½¤ì)$¿ŽýäܘHOÌË Þ`/¥âÏIÀË ? ï s¡]óƒ½iø;êYàyü=ùBì³ùžà7…'YÏÞ¸."{jy§S7eÎ~•`ž¹nrÙFSJKæÒÈ7ƒ¯õyæïd®6°W|õ?ó¶‹ï5䟱¾÷3OˆÞÃC¡üö•¸~aóSÂÿ«ù@öxN>Ø'ož=ööÀ "¿a;&=÷ÿùþážó\ð§y¿=s£Èsxž{ y®Ðëpÿx žIì”ûèCâxçƒ:‚óîàhå½Ámè?öÝ{Ø[Gž[÷Ãs{{à±Óäëdwx/ÏKí÷àeÏ ¼yŠ÷É‹‡ûP=®÷%_Ï}ãWÌÃ+¹q½;oóÁÂæ#¯Ê¼<¼+ÂܧëÔÛeo½OqkÈãìùzáxó=è÷-×ôà/ìŸ ö$£WàkôÎ|I†yLáçÒy;/¼d>já7ê öÛʳ“'ãnü2¼$Î;é=Á]ü;ω4µêAæ­cÿƒôÝ}6Ø;½õCïfŸôÖqзa~_x}¨ß`ÿô¼Øøl•ž™×^ î#¨Ë¸NŽŸÔ{ È þÁ~Nzî»CNÈoP'3/ üI¸ ÜÃå:»ð!rFÞ†÷4¿ ñ2y'Ù%ó_±wš}làÙwôÂù)òȳΉ÷ ¾èxOö¹p[òé½Âì1S›| ýÈ8μ ðà+éúþ Ž$Ô½×Lò!ýJú?ÁÔËe÷Íg‡ß¦^¯Ÿ'¾ÁÙÓ÷*91ŽÎ;܇kÞwö³ ·×›¹ÆNÂGM?—λCñ'zà:}µì¡‡OŒ=wAþËßä£ð+ØöGÏ·ã„G±ƒÞÿ®Ï3?5{Zè[ß¼¡ì´íyb䄽X’_÷« —áçÀ“²®?:ÞG©N'výžä~…÷ÌïŽRÝyðž5öÑ ÷Ðæùw÷‡êóB>,ïuæOêñÔ'ÀÅ:_óD±×Q÷ã8™|}®Ä ôm°¯Lþ×õ ɯûe¿Ì« ¯_É©÷©øÔýÆ’{×çÉ×ëß±ÿægƒo ;#95W€óÑ×+õy–gð x–8ž|4{¨Q¯¢Oï ºy¼á[W¼Àý¸o‘=Gú^ìç°é¢Ë®ï[µS’/ŽW~%N|Ú÷[矓ðÒ+?òþ‡ýpÎ; Ù/¥{ǰ¯Úùéü÷η+^¡¿øp„yMéb¢ò¬ä̳¯ûeõ^䩼ŸQýŸÞ§ÎüƒÞÓýÏôAÈþP_vñîÏv’¸ÿHŸ#û'áG‡gNzæ}ÖªópήS£—ü<ý’ ﯡBÏi} $ØÛìº4yfúÄ…óí_È7³Ÿ’¹ ò¯­ã(âó`O5u üó¢ÂÈy8Gàý›)?ÇÜ’û¹Œewù<Ιú"zê=ƒÂÁ濱—ÿ+¼G~6äSÆ’ÿ6%ýeʧðœƒõBzŒ?äÿ{ï1ûþÈ»(ßÄù†ý]î_€ç–ø”}ÓÒ#á€dŸ/}LÄðS7`Ï£ð•ûÄt_Â_¹¾ªŸ3 þEñ1úâzycÕÌۉ xö4àŸàä=dœÿ öl‡xËû]ˆ“©wÈÞðwì„q ì}qäÑ×—œR'ûC\w ¯ƒßåy¤wä]CüfÈ¯Š½Å.z¾ CüÌ£˜‡—ùøêà5ÔœþÕ~@χ^»ï‚¼¼Öàyú¬èÇa/}QÁ8Éñ9}&ìýÔó€o<·Eÿ yú é+$NGOy/}ŸûRáľ|œö£ìíg²·Aï‡Ý2Îå÷„Û¨¿…zíþ`ú#õóæë$ÎÆ^JÀµäËÜß!\í~báð%v9į“O oïýà?ö+³\êð-WKîátPïAÞye®.¬/€ã<EÂ|}Ô²³œ«Ï%àiuGrCÞÊøˆ}²kŽ¿˜[ úïÌ÷ /hÐGiÜÈy’æþè’|ÒŒ? ã0Ϲ¨oÕsÔu.ØW÷—)NãÜÍ—Ëfæ÷T/sK»Ï~YúŸ™¥’¼¼úü{ÌOЗ!»Œ>¬¨|õ}Ì)6ëy¤ïšóùÎûS7’>ø|…[Ý/À>ZÉ5y(ä“ç`¾À<áÊ“‡}Ëæ‡&Ã¹ÑÆž"ú§Ðk>'…c?pŸ‘îÇûu™wd.T÷ο· ÇØž‘ŸaNN~Ã|Òô»Ò©ú7~»ïýÞF¿˜Ã0æ°=oªúyRëýðà`ö¶Ð¯¯ï!¯é|ˆô`KÀ ì{gAx„zëgôÓS×⹘[Ö縫{Ÿ»…¾nêú’óª“WFŸ©/0¡sã\\ßÑóyOþWßòƒãÏÜïG½8Õµ¹p–çctÞæçå<§ï/}WàÙ3ð¥ëõô3È_ÿ{ÿ0þ„øTyyÎÅsYÊ[#ߨEðþÒ{ŸôóÞçÍÞùÀŽ8þ¾qÿ+çG_Ÿìã¦IG\øä‹#½—‘ßgÿ„ãEòÑìñ•œaÜGÊn;ón®{vKÙ{wrÛ‰m¦uOò¿ÒGö?Ïz^Þ{Ý#ùóªKÞˆGÒï»ïB¸’¾Dp·ëeòëÈ=õ,ð€ý²ì<ûü÷Ôþ¦„BçfùÒŸÎ#)>dþ‹|Š>~½¤ÞJœ@žErC^›}mÄyøò\ÅiûßÛø{™·“º‹ä(Ü‚œòüð¸ƒÃÜoð£Ûÿ2Çļ…⧉£'|Ñý¡Ò–oÎË|ê’'í“ôœ8ý|Øã(åå¨[aWø\û ï•sq^@ç…=àóÃ=7î¿ ú]Ü?ô¥»¾ ‡ì Ÿo¼Î~%ɯû\ƒ}*èsìäG<#½qþ|?¼¼'õ@ò¡ìeÿ‘ð$rà>ÝT?|cI»p!õ%pŠçÀÇÌíkˆíd/X2æà€Åc÷ºÿ¿‹_:?Í>TÅmîû`¿ }Äß÷ Ê~“OX·mÿîë|·ßS8 Þ~ÎeíÀ 5Çíïšð¹S/ày‚úqJXßì7ò½Ÿ*]ök2£Ï1ó½úÜ /WㅎɾVúÙß©ó?‚s°Cà)שÈ+ /c½ŸPq>~‹x„sáOòWÈrä<ä|Ë÷/Ò¾_êa¾}.¶ÿ…ù2öoý0 öõÎ{à†QÅâü¹_¾·~û‡Šù×]ñCì¡E®å÷9?ûuÅ;ޣ종{Â>"O®#HÇ¿´ìÁÏ:µKêcìe ŽƒŸbó’Ì[k~Íu¨ O‘½è‡ë òø×aÿÚÏÔåÏ/Ó$×ôÉ{˜p#¿ç9=Ÿó‚²÷áeò½Þ ÅóIýµÅæ²èÏ£ŸEv¹ñü'øN8Æ}*ä©'²—VöbÍE7ÜûdÝ+~+âCùî™Ï!ïçþú?àÁ"/%yB^V½µgõëã$óÄòCö—Ôëƒ| ûG™Cd¾M÷ÊþQϱo^ÅÝôݹ*½_Üó”WÏÞ‘äyåoŸÉ[é}œ‡JݯùM8_ì´ûš%çà7ÿÜq7Ö.×±n¯+N>øV•Sf5>Ó8—ïõy×"/,»þéÃ6E³æ'<0Êz¿«üüÆA·œÜlëÏŽ£%Éù@_܇Eß¹âfölšOˆ9$ôXöeNþ3++FoY~ÿóÍ;Wïs×ã—È“.íž÷ûöÆÃ¬î_x{°îÏþGž‘oâXžŸzý®Š;⌬¹ÓšfßÄœC²K8°²e…E·ßù…q.û¸Éãz_–î?Nƒ÷]?ð“·³$ÙŸ¦|³ù?˜3•¿#>ÇîzAøÁóŒôé…ýmøcê¬ôÉžüѹôkg/m^Œ¯¿³ªbî+gÌðOÐÇ ûƒ_%ê'râ¹ú®õyÎ7Ó/{ ÏŽy{„3ÜÏ,y ÷áxŽ/È[Úé‰Ïxð*y!ì&õ3ãhÙ#ö…y7÷í¦ð¤ç‡73·)þyN&¥7ð´úžÝ®ü ýIÊŽÂëÌwЧÀ>P}8ÐòA:ùxäÔï‡|ƒñ»Þ‹¥<™ãxíRzé¸Îö½jòãæEúÀÉg‡{²¼—Œ?É+’oÐ=¸/“~ò±Ì¡Êo:ž›xíâëŽèlý2/!ý&Ä/ä¯ñSøKá2×'TG0î`¿«âAì¾ç©ç¼ôI‚+©?;®~Âÿ;ïFþQz‚Þx¾…s“x»üK8×àz={°¤à^ô9ì#£Ž‚Þ™W>ú±‚¾×Õ™[=w«ði¸?èßÓ9`ÑòDÈ#¸ÎuBøàÁ˜»ãõ÷¾úÆöeS·º­/ªv,|žë×qžžOLá&ë)ñ#þÝ÷&¾añþcŸâ´ûFß^öˆ3œ ¯¼‹ô9°§‹yyå=Í#£x˜ó£ß‹¸ÅùxoeÀså¹}úPᡞϤúU9ø ø|çŘחr•yå_ý›¼/ñþRrà>nÎËûFé—OÙ/Û[x Ì·õ×~{ø‡“½Ô’WDz¯ÄîÿQ½GvySŸãÙ=ð:xÙý׊[xç{èw”¼{ÿ#óÈÔ%‚ý–æƒý+?ŒùRÜ—L¿#vC¿OžÏ{~á»aN‹>‚ çþAñç¤O©ôÒWK³’x‡=Ùä+ƒz0y!çáåÇíO‚½¾æ1‘ó'û:á³þ¢ï Üižø`~Hçù©ÓÒ‡ ó7o)s©½oIüHžFϹ¾âûeNè<'ékÞ€óèw†oOr‹t]…<x…Ï¡®¢ð?ïG^†º±ð^œ–Ú7ãû4_/øFöÿAžÇõ4xU…ë7v~xðÐojãŸ0ÿ›î]zlžó û[¹/çG„SÀïÕ¼Mê{åyxú¦³‚9^ò;ÈÍÁiÛ,¼¹RÒw­º/ò‹âyÂ}ß®u>âBñ°'ü}ôï3_!{Dÿ¼1až"¬»Ð—á½±è5÷E]»A}MŸÃχ{Þ_ÀŸ!¹òþmú·•×1ÎfN‚=Ú:/áP÷;xnNø•û#ñlæ‡e‡¹_Çô‹(nC®‘'÷ŸP¯ úáÜß&œay’ÜPŸ5‰Î‘ºøÚý’²S<'úàþAÅ3ü><-Úëcû¼¢äÔ}Óä¡Ü/Í|‘ž<&;æ=Šæ“¥¿¸R÷ƒ^Ù¿3·BTv žëБrýHr OòKmyfN~qÕõm§š×^vòAzò5Ø=õ/ÇiÇ/o}ÌœÕÆ9·Ò?%y ûÄÌ›•zž„'Œù(æÖá§>M¯ØqcÕÕ?¸¾é9 áDì¸ò„ŽçÑ/ë/}=Ø+ýÞû.=mýÇñæaS¾;ò9x²î•þ§bq<} ô%S_á÷e?<ç(;Á¿#ԗܧ=¼}êCµ_ úAtIŸ½ú¢<‡ˆe$À£èÛº[ÒµÛ8)äÉ2þ×¹K¿ÀɽÓgK>D8 ¼àþmê ø]øÑÉÀ3«8—¼7öÊç÷׺Vœö}ÇÉßÖl˜ôïÑGÉ}p©çˆÓó7´»<=·Xÿ»?Oñ¥ë·ú}ôØóóôç ¯€{]——@߃4N£îþÑý—‘÷ô<äÁ|øi£ýŽò#àYò²æ¹“}ó{‘?D~Øë.ý"þš÷‹¹7âdÞþp ?ßüäœË=¾£\Óäý‘ê\Êï ?ü»qŸâ6dzÂqæ™ÖÏ“÷Þ¥îþœç÷Ù»@¼H^Rïå¹ê>ÌÈO`ÜW†~GR¡O¾:âfú¾á¹ÕÜ ÷ä>\¥¯Nuó€À»§¾Rçs˜“¼‚›Âý+îÏ útÂ95p òè9=úôésž¥ÏáAÍê×oócÂ÷#üŽý6nÒç„u^Ç3Â¥ÆczoòÐÆ;à1ê©ôá’/f΀>/ɉçÛdG7áµ½'#—Œh4¨s뤟$œOD¿Sq#ûLý¼«n»ç÷¯È)Æ÷|2ïŽ]2ïò)¿ìz‹ì}Cî£=3ÿý'ôG0‡*œâºó’ó˜ÓgFü§ç0ïüFà$øUÈwGÂ;ô×|†ý!ñq#ùãá)úJݧÆ+zI¿tÊŽÆé·¢ÃËI_uä|…}%/ Ÿ3~uü O¥pçãù/â,ùe÷q<“üz >TöúûÌó“Êo³+ZÒóÖÅkßNž—z\œ¾æé±•r ØoÆÜœëuSOÝ9øÛü¢¤¯Kû$µÖ?·¬åoír.^=ðoº¬Ï&ó§ÿ}Í„]Y,òßù9âóºÉÎO«°ø;nKTÜoñ–3‹ý^øùà¸ß=øÃ3[ßMp­ò_-Ú´â²Î‹±/–úièÛ\÷Öc÷ñ…áç³°X}Wq•ãÚà|ýóâ'óß‘óéS~ðsƒQŽs–uº,¿FÉü‰òÖYiïL¤ÑøhE·Ÿo×hQ4¥ÅOéO7:ž|¹?÷ûµcÖ¼‡Ï)üwæHæw˜ßrražÿÿŒhTí&›{'z/¿È\*ý.ìïe? öKGß,/YùÎ ;B¹¢¾íïyç´>Ë®¾bk´,>öé©ó³‹ÓŠ¥Ÿ¹öÇ"ïMc/({õÒvnîP¾Î.úǼZ|ÚÅäÄ}š)\§•¿ü®ãë~h;¾ªÛo7o}$Ž&—ýåÅrS¾ó|ñoÓ÷~9ÉýΣ*¾5ÆSÇÿì¬ûòË}ò[±þ2ÍÇúùø|ÝCœñéá¿äß•I޺ع€»„G‹½'}$ÈýZª«ÄyÑ´á…ƒÿ'{1òÎ…;_ع šQôPëÿ9Ñû®i3_¼|²å}š_odý¸dß„çB|™ì§Ë8ødé—&¶óç¬ïr̃Ÿx.Z³¸`Ì‚ëVùÿ“—Ä®|ú®±Õªä÷Y½üýÞÍ)-üìÛYû MúRþØrF¿(ñ'ù@>‡sFÏÔ/Àž¿DŸSö>”CÎÊ“‡”év’ýÁ¬N—ίyLñtœ;äˆÏu±_òä½ÄîsJῇ÷Ûjg~›ÃzþðÞ?¢oŽù×»wtýß»®Sχ'“­«r_îWµ–$ç ¾R=záߣ¿}e癫?RÅý·z¿¸„ö³WyZùVÝO.j×5ZðP×½Êw÷¾nñö'秺ϸiåj÷hXÈ~A>û¿§Ý·ãÙnûLì¶úÃUŸðÿ§ïCñ­ÿÿ·Œ^lÕ¦ìA6®Põö:“OÊô}Éßú÷Èc¨_£˜ß’öÿó¿8îÎ]–:Öýª³Ÿ{±Íµµ+'÷övÉew—-¦ÏÿÛÌ KöÍç ©2zݾUÄ£ìõÄïÓwÎ-ãó ¾y}–íjôs·=U7¥}æïQŸf"âÝÔü]±Ï]öFÇNcžzŸsôï•hõÀ²3«žc;©}èÑÚ®75kØå¶´CüÇþóä–<šý1¸‡ü¿ûrSø>N?üÉyË^è[ìôó‰_f¯æÚ^væÃuçŸócåOÕ¸;xô[¾é´7¹÷þ/ö¹ì ùàœ—¦]>ñOŸcîî†5;® ®rÿçŸ.oòõžUø ï³-1·ä²«fMqÞâ÷±¯i]òãmìÏóýó§öj=v{¢7‡Õzáî#ΉK5<¬ÙK%ÿËÿï‹&¯yqæW÷.‰ÆTøä¹ûßß–ôý©æú¹æ—Õ'åŸ yÏ–.o^þÈË¿4~ÏÔì‚•ƒD˪T9þžÛ¿vÜïztÊ;7ÙYê5‰|OnòåS?l+&÷yý÷ôÍ;§kœ³æƒÑm‡õñ9p>ðÈÐ77ï§#¿¸mt´¡Ê?‡õÉ{ÕyfÎceFï‹fW/éçÕ¬`Dç:m’óœ~Tƒž£õÞjó[«…ùðý¯‡ÂËÊ{/þý‡wv—xã’Ïœ_ýõ¤©Ó[Ý?ÔöE~¤˜½RÞ7íoþ‹³&vš^ïÁÒèG4´Ú1Yß>¿(Áº7å-ã=ö5‹æd:í88ŽøXÏ}}Uãr»Æ]„ŸHì䛸ré×Ïnÿ¯5TÜSLNM™}Êwßõ$Ï>èd.]ù·olX™YîcâÆ8·ôâÃOËÛèü…ì„?—9úWMXòRç’—âÝ7 ûÚKöÛ»ž‚ü-*qúÆF\çWš:±öÙk°qÆüúðÎìCùxö¹Hå]±»žÐ^ÍÄþ+®§/•ü.¸+û”áW ‹nu>û˵Ç=‘ím.†3”?DÞr»ž¾ïË·có„ñü²#¡}-ö¾a]‘¹‡éÛ¾øªkÿ+þ|tÜëOÍüÊyëÕ“Î_võõäûB;­Þ¿+Þ3¥eb¯R~ËŸ9úšiÇŸ¸—þ¸hñ¸ûó}ÿjÿ9iØ÷+•Þ@ž0yN}?ïG¾*ÔkâìõO5¨ùõþ4æ /QGëöoužz\ôںϩ±ÔvPñzi}š~æW8;ŸýÎàóð9By*æÏ‰„ËíWóÛç½wó÷»íï–\rÏù ®ÉϳoÚyTôPòtÆíòçôÒG=wßÒ'ûíg»<)Ž)¦ŸÜŸëþ`ù+õ%ýGê£0_§òF‹/z÷’šý‡úÔÇœO*žNâ>å–¸òõíC§2PÌîj/¸íEFÅæ¿öüéÙ¿³ÃI<žÂ1q‰­gÜ´¨L§¤Ž—Ú§gœ²ó®üãöág\­¼7u¼¥Znï¾ÿÆ8£éó7¬¼dzœà¨Ô\ ÿÎ~Xí½'îŒÓwNkÞ±ÒXó}*žMâ³T$ΉÏxµâ7$xyí'wLïãü yfÿÝu}å÷Âþtáħ¥â¤DχÌîüÓi \Oõ¿þ~ò¿ãè+…9ÕœýûCÉãã”ÏKô^u]Åñî/w¯oU÷ÄRãKâ®T[ÌîSGߨg_¢}•om®æü?õœ_з—ˆœpÓOMñ—þæiçÕ:«Å ¾ì%÷¿“÷Õ\Gqܰ¹Óäk¿»ˆüüȧ?;Ü_ò=©øÄ_9¹üâkš»ßÊsz©üMœU}n«×^9Œy®¸ uÆë¡pà¨5•fT˽{.ñ`Âg’Ê{Oü9x’ç#¯C~4¯Ò×î¼ýÿ<§ÿŠ¡;Ýu8êæQVÝè@ï/Ê¿ñúVÏÝyÿyù¿öS†s¯ôÑÒE<‘àéÎÕÏo¶³G2ç/y|ÕÀ©«êæ}^a{×džYu‰?*5Ùe÷<ÇCôÉɾ$£.¿÷‹ò~/Õ<ç«þ‡uw¾píìQÎ+‡ÂSä9øIè_Hå»ÜègÞP¼ð pnìAØÇîy|õPç‡Ïƒûà~˜Gô>ÍÑgE½1ÜãÊ}Q?‚oÓõ-õOóïœû&¼÷Qu*Å=Îѯçy6úT³>‘?†F}Dô xO§x«±ƒÌ Áñžô«Ðä=s²ÜýXØ3óê}jýçó©ŸkÍ¿,}6´ÞSó-î÷÷¼ûAÕÿB¿sZØp¿ç“U—[þe¹~z½2üïIŸ“ê ÌïЯA^}£¯‹û¥¿¿êsR=‹~ås’}Oʛ³@¿ uhêëäÌ'«:­ù,¥oæHõsð^îÓ§ží~ ö7À"?‰ÝCžé‹¦ŸÓu}Õ_Èó®<±ÒkÖ¾g{ 'õ_òlÄ7ÄkàòAôGÂsƒ\zŽ^Õý,S÷öšo¶ò¿ ¹_޼?÷Ïçb7±ÓôëãÏ8gÎ {ɼòÝ®+‘ߤNNþyðÞqÞW¸˜ýäi°Ó|ŽyŽ™§Ðžß͇5ßòUŒÝt=Ëýpªß3'fÿ)ÿÀRÏÁ®P7¼’è™ú[™£¥O€ùüþ>×óˆÌéJ¿—W¸où£«zŒ|8›ú ýÄÈøy úD¸_ð~Â~VÏÃ<óÐĉæ-QߪêÜĶçË[>:³öètûòYA>Ðçò§3Â÷Ô¥ô•ùê·î÷Á/ÙHné;úµc£¶ÜÐöùÍhÓýž2›ë:NåýñoîÛ ø½/×9‡û˜xã8õ¹1ÇÌŸäó±sø+á~ꪎ¿ÁCÔ³ÁΫŸÂ{1Ø Î|*xñ”×!/~Z¡úí!ø’=F²Oè…÷¦â.ÇýȼvøóÊëṡ$»ËŸÈ/ö†9?p ÷€þÚOkŽÓx4u¿®·b¨>kö^ƒˆžËÿxo€Þœc>Ná òÑ%>/ÿîîqcþOù]>>-ãrøµdÿ%¯ÌoÚ§¹_Iþ¿ç¾}}zö{^Xýf’×8ý™Ÿ•»d„ûé9wì:òBÞ¼÷Š?[å1»è7Àÿ­N»ðËûsf9Oë~öòÉ>-[ºeê/ëo4ŽÃÎP¿ O¾æÖ¾Ý§=öv2?­ßÇÞÑ„^roè%ÏMŸœý2~})\ìsÂr|ý˜¼þœxŒ>E÷§q6ùPì­ùÛ…×ñ?¶Â+¼ò  £ì&vÕ||’Oã ö˜èüÌ/$ü@ÝyæOéë"¾!þC¾yOïÑP|Jžnýò“«Ux5“ç÷ü=öEq˜í«q†p<ö;ŠŸŒ[ÙK(»M |&ýrÿ’çÞt.ö£’OÇ.17‹ßÀO!'Ü+8^AòƹÒ;>Ç{äUô\sªÏÈs Ž÷t>àVê*àuä…þnêœÌq‡¤òZÎSñ9àûÍ郿^Wþëç›à½—Þr>æÿR¾ „ÿ£‚{R>6Î8ï¬7.<¡åÞ4ê›êCµß6?›pvÆûŸb‡…óÝŸJœi~8úÏÕ7J>ÈýÓ’ûiÙeðö”ùÜoÚ8HÙ~Î{ ˜ûÞaîÄ{»ÉßE/ÞWÐ8É?¡ÔiKÞŸ<~Ñ|%²¯Ì—J¯âÙ;ïõJYÏÒßâ:­æð26løúkgÚ'‘_Vv5ãñJ·ôP*™~žÙ{ãuƒÞ«“è¹ì©ç/…ÌÃ&?Oÿû€ÝϾ#ò$à}çc·àC2›Î»i> æý‚½ÈüÕ™-îãg™òxæŸ`ß_ ÷ðå¢?Øaì-ýhž æÊ±Ãä±—Ž+T6ïŒòNÈ¿ûËôûÄÏøOö´x>’¸ž+áið ø=à—p>8ܫ眤ïäÈk€÷á÷.*VW2OŸð5ñ­yÞˆ[à V|ˆ<®h9dÄ©Þeò¬ø¼ùHõ>äµù9ätvfÕå-š5NøŸáPÝÏ| ð®2¿5òÎ>+Õ-Òi·}žžÆ±ÌYawÑgðv…{Ànƒ ɪ/Â~žx?¸òûä‘Ù‹Ë}8wòŸ¡ŠœÇÄ?zϼºÄçì_a/ü0½ÞËyàÀ;ÖWï«‚_7¥÷qÆ€*wÞÒ¢“ó¾ä»<'ËÿW> ¾SïQž5Üwçý|âI¡¯€8ÁûßRò>´ß ÷³Qan ÞCžôž¼¸ $ñ¯ð{Á›J=Cßã9zæÌe¯©_“÷Á®òsËÕoþäÞ¶ž¿¤NòÀz®™¹dö ÉÂ/›¿‘sJá ûÏ*žÒ<ŒûD¹_âð—yË”o0O¿ì©ê®?š¿PvówNyKìq|ÀkßóÀàdÎÕóµÒò²Äõàó9Ã3(ÿoþbx$e×þ¿öî<ز²<x§»O7¼aP#jLŒŠ@copŽ L2‰€‚ A5 8¡A”¨‡(¢ˆ ˆ 2£L2KÓˆ"ƒ (‚îç÷ìëêºuSùãÖ­ÊîªU§Ï>{ïõ­ï{çáyéEöÔÿfµG<ûŸöís°:*}Vá“ö…O N#:¥s>pŠS~qü[ü9zåÐG¿å¦»ž[úÉ~Žæm}䃗nº÷ç'ñþmçdÁe‰Ýy^ý>À{k¾Šÿ£Î»8éYû·s‘¸bÅuOýDùÒœ¸ñy¶ÞXŸ©96üpòü‡SÑþý|?ÿ¤8õpÒ“‡–ï…óÕ¹Y9ñ™¡ÿV<ÐñúŠÓ$nS¼ªAÿ9ùÒ¾ÿA=Xíæ¼¡:'É7Á#‰ümx Çš¡wã_²Ç‹{Íþ6÷Z¿Þší7YßßzÐØ›òºµ÷cOëÛ‘'oý”>ñ?V=Ýù ‘ÏËEÞógÿ0r¼OÃ>*x"µ7Ä™èäÕ»>~ùÁžHÞj‚OçÛÜÞØ á[¸Ýý\øQ\¢ùV¸ÐðVö;»–|ø÷×úÖ‘¯xkóAô½sì|¾ð+ÿ“Ü¥—·úÅò-¼Ìøóµ³Ø)±7‹Ç)|*_Pü½ðUâ̵gÔ[à#ý§G´OÜ/~úX/4Ž\\ôä‘äkô3Š“µŽ&þ¹÷o?Úî˜-7zfùT\U|¼õ€É{wŒz™<ïõï\õ¤ß¶iã>ÅŸƒ7™}ÖÓ§6ôßxNê슛‡3ñiò¬8_ê¼b/Ñ'ÅÁ"W7Oê<_ñó±¼?vAñ%Õ%DOëê|¢ì£8Oýãä1Ôyɳ«×d_vþ:ÿ >žú´èeý©øœ?@¯ÕnŠÔz‹ìŸókÝjäŒs–W̧Íßô}3{.Ù|’ŸŽÜä_EMâ£êÀÌ•Ìóß·ßâ;‘8FãÅäHì+yr¤sêÌ54ßel?Nêw¢Oç6'ÖÜZs„à6ó³Åm­[|)zªzFBüu丼Jë!Bïâú@àš©#P· _Å9±ß†õÆú±Õ›’;èYÞ¡sÄ"×å…¯ã^Ô¾7´žÎcO¾ÿ$ß ®Ê?D/ü'òP=”ú)þ ¹¢^ΰ[~Wž·ôÊç}ñž­þî²IŸgìUõ"Ñ×íÖ÷:ký–utôÏ%îÖ>©Ø)âü›ô[·>gØ_…þí;y­^¦û;JtÙß=ㇿ:«ùààÍé/Ìï3G5õ!â©æ²G›J|ü„G\ðƒ·þQõAê_Šw£žA\#ßßx®ó®@Ï—þ%÷ÙMÖ¹üÓ»oµÆý¿èç½Já#ß¼ÎÊ·ïõyø>Õ·>ç{ïxÙ“wžÔÄ„c"}k^;¼©ë7ÿÕÍߺóÈÆ¡Åÿá+’ûíKÜKý‘:ýîïo·õú!ã϶_> zÉ:.\ëŸÞuÿ%¶P=MãÎâùyéþßÞo_u\û¯ðiëstäôŸÄ>éütÆŸÆGâöÑùª³QOÍÿG×ų5'3õ"âIô¡çWÏ¡’>UÿÐz§ðûÊüJuÑö¡u•á—npÝ©œðúã&uKÑWêZwùé¾ÖþÅ ñsp·jOòS­ƒžh]ièCýjåOæ®]÷ÌW>ñˆŸ0©{†™ýRG ¯Yº=¨ÃäTå†zæøqìçú'Ñp«ׯ¯ðS"WÈQt&Ï#^ŸÈ'}‹ø½Ñ—.¼é“+}ø¨úµCüïkÜþ ß»¾!vûù;C~%×ôµ°3¬‹EO/ßöïÿêš/|¢úŸÿn?èú^?²shþ,|®É7öˆ}G7í{ Ž¡<¦z ÏÅÿr?ö€ïikü[xöSß÷°?m^N]FnMðÿ"?Õß§üG±¯Ýßûñ+ûè´-Ž~˼_Ty)Oâùؽê­ÿéÛçÇ CëP÷¥®¼úœ\P~#wn=ëú ß8ûÃî¹Xzf×¢ÇòÿX~tß૳7¢'r*ò =Ò“è^ž ô{’Ã_dÁÅQ÷Aé¯`§ä¼ç„ÿD^â/~JûÃ"?Égtgî§~}çÞ[ÏÊߌÜÇö½sìõ'éÛ‹¾æÇ²Wè7÷«>Ž|ç' óÏô—}U_¯Éò±ý©w%ÿÅ_Ûw’ztïN½…ót~­›O<„Ü€ÏòÓcŽúØ7œ:éCV·{‹×•ÿ¢ï†|:ì×sî蜆O‹|¤—ȧÓìýÇ—Û÷{nçÀ¯öÁ°»ÅSÅ+³Î nLô³<@öEíytKG8Orî0~AOô4}j]¾ç²÷}ïµ_¶9Ú¸Wé!z©ø:Y'{W=AõZø‡|W/f½îÛþÒгøGq<¢ßŠ­ý|9}-öÜj¥¾­ø«'m²á²×¾­çÎÎcWŠÙ?ý’òlòüìö+¦Îˆ=iä¾wîôŠs]>zÕ¯æì÷¬Ú¯â|øN¼Ÿ¼Âoüiy^Ÿ«ÜÈ~àr‰|uvŠý‚ÁÿG`à_ç=ÄÝh¿]ö‘Õ¾Ìüô9z•Ý sË1»â¥;Ÿ\ øŽ]7zo?°¹áñãìºF‡üîÚËìrß“}(ßÅ¿É÷OðgÄů¥ïð {†¾Áïä\íùЇsñ>}â1½_ìÕ~û4úF¾Ü+ßë«Í>µ_2ëïîœõÀÿqëQOÜõÅå¶/âêŒéerËy¢kú¦8 ê‚"oÄûБz8v >cw¢zÏ}ø¾Ï9à'ûÅž¸ò‚«sÕñ‡6> ^¡v{Þ¯ß2û8ÁÈ÷‹Û5n•ý•÷(Sø n¾†Ôº¨È%ôJN²Gè;ßÞ¬_>.½Gn’<áê?r[^‡=^y{Iüsè·“ßò4ÖËnoùÁ™+­·äÇ«ŸbÝö«t¹!îfßñ;ûU¼Š>ñ}莾CŸ~o_uøËs´^&ëG7ì0~/{G¼›½ë¾öݾ¿?ÕsâWv+?AœI¼QŸ˜ø;Ïs“/øu¨§ÄÿáÊ‘žŸýæ9Ù—èŽÿÔünô•¹pÞñOë#§ø3ì½ÊÝ<Ï#ö5{ßëø¿ýÀüØè¹ñ㬓¬‚‡ýÏ$WÄ…ÉGþ_Ï9z„¼h}ü¯Ø©ž¯t£O8z†½ÒsßÊïøÐþÀýÇ÷â Î ßw^{ütÏ)nO¯£ ÏÇ‘gàWw)?õéÑûpEõíëSÈqvÕ0e_:ç y6ÏcÃx¹MßT/8Ÿè}ü×xüö½LäUâˆÉãNp×Ã_ø ñgôÒKòÐìPv&ÜñöƯ@Ÿì5ro}Ñ3è“=ïœèSvyHu^S~Ÿ!úŠ^c/ÑWì:s+ѧóE_üyQçÜxTö‹ƒ?†¿Óßâuð.ÄÇêoš#˜ŸäÓ°/¿vYžƒ*_Xy¢~v0оâoôUÜ®Ðuí Äíê‡F¢ÛöIDŸ‰KÔˆü³¯âcäý‰Ï®^ô¾Ÿtο5¯LnÂñâ'°+?è§üý%î‚ϯÞd—§½ë]ëLì›±R?Z2îóÓ'6ZeÇÞvÜ—ÏÍÜ÷”MþzÝ÷ª‹-š³ÖŸ|ú1£ÑÜg|üÂç½rÕÑ¢ýý_:ø…£…7|Ë î{dš1sÂÂÙ»Ž{7¼ øÜ£ùÇnÿÚÏï~Âháy?ø‹O=°îhfËE_÷žÍàQŽ}nݬ~ÉA£™£Ž9éO_|çÌ#’LJ÷Õ>£Ô§ëoìœÇàéŽæôî—_<÷$õ£ùk_µÙNs¿Õy<ÉÏï´ä„o¿ìÐö‰$\<çÔÑô¹ÞùÁ‹^ö‘Íá}eæðÇ=ñ pÐFKN™÷™C®îhÞÿðË_vêhñ§.9é{?»Jôhö+Oøú½§ÞÐ:ŒôuŽæotÔè­[ï×ý_œóZtõo^ôµ=,Žqâ­æbéWëº2×a4oÕSÏ¿ñ}/(Nù6©ó4O¡çŸcá¾_û¥ôüÑ,:øÆw¯yÕÏž0Z°ÅsvÞobŠù3öÍ|©ÎšÙð£ yø‰ýþ…'ðžËõaó°àÿ«#-Øfï«÷{íˊ룎iÉ+nùøêw|sÒ<¶‹Gó–ÿbןrVç,-~Åò•ÏùØÒ }玌î±ÉåwÍÿ©<çhÑ‹·ÝmöÞÑÌû^ö'«l8YwöÑóOŽñhÁÿûo_3·û4³úË_xòŸRæh¥ãoÚç_ÎÞAÐhöM×Ü·æ*/é}<î¤om~ÃsG³«}õYÇ}ïæö¿©ëIÜf´øÒG|âÍOÜýÈŸVZg忹c·Ÿ-ßâú?ýìê‹G‹6½áý/üÞÛÔûæßsãݾzÆ|€ÑÌ)üÃã®ß·ëC_3ï¾~ÃcNýîhÞ½wí¶Óî«Á¹®ý¼¿Ñ’3½ÇâÓWkÁ¥/Õ«nŸ»ç·hÃ÷|ÂcVƒƒßziýßú»Ñ]òñð+F ŽxåWßqç}“ù2㺾žgåþã3–œÿø÷ôþsJøpÞ‚«/yùÂWWn¤ÿs´èa­÷ÔëáøfÝ·Úþלf~<«Òõ¢{õÖ+¶^·¸’™Ã<šÿÆNÛç€ÇVŽÎ^ò¯‡¿ø”‘:¹îËìZ[~âÊœ9šÝôÛ»ñÄŠ³ƒþ‚“\úupÈgåׂçáõEÇnñʇmþ¬Ò[êv:/6õ(è…üÓ—Þó?˜ƒPÜîôÙæ>k­Ëîr}éHlêŽÚgg³?ýíá?¼p7õ •7p¶ýüš']ºtÑì·n¹ÅqŸï¹-ž³Õ×V;æ—­«H 9¦ÿ·sYÈEó^æîôéÃN^iÿê%úlÉhÁ?m·óœÑ—½zæƒé×ÒסþÑüJsÆÈéÒùz蜫Åo:åÚ}~ñˆ~y¡¯ž¼ö=3k´Ï3¯¸Ã<‰<Å¿™·µ`µwßû÷k|s4;zÉ#OÞ讞#>Yüä?>ä_ÿzãÊ-üàù#/Kÿó<øµ÷ýrÕêcrþë¢#¶ºr»çß8Ñ3é+L]Wù}ð}í¯Î «üÎÜû‡ß–ìsç'ýÌ7Íi*¥Rÿ;¶OÍEêy/š}Ã.Ÿ·uçÈOóרúªWìú¶ÉzÌ×ËýÉõ•V»í9‡œþw­Û´ÞÊÉï¼dÙK~@ñ2¤ú Ÿ“ã©Óœèµè…žOô»y•ø ïÏ÷Í?ýÃÞýâ_”Ï3§²sûì?\¸ôõì¡WÞ£wõwÎñŒ“ÏzÚ±£…‡Ÿsþv¿yKû%zÞŸ›ûÑMo<®úÑj‡íµð#g—>o³ùöç®wËhÑ;}å›ÏûtŸ3øüÕ¯ìÏE—ñ¡ÛÖ>ªúbþƒ¯¾óÎÏoÎ9Üõ²£èÓΊ]\«q=tõj?Ÿó‰]Y|€ØÝÍd®yWå#v@ç9Ï6þÈD¾Enšë3sËýÍ]øWpSjW¢ó>ÿêãµæWFóÆq«ÊóÚ)Ç²ßæï½£~9jøÇ\Å…ûÚë®|þšÅ©ô>öEø°z+u[µ·Ý×>¥_g´àÁ·œqãwÕŽîzÆsHèÙIÀ'ŽX;€ßáÜÉÅGü¯­õðmj²Ë3‡¤|?{ÞÏûÛ¯0á¯ÌýÕÈ^|ëìæKV}eçý''ç†ù+ì9tS{"ö!½W{1¸é©çî>d.[ùˆß—zãé:üœŠÉófN%ûÒ~“KöÍ~Ä*ЗüSzÑ÷±ÇÜgå¥w-yÃíçÖŽfŸÄ>ŸØ#g¬´Ë[?öÀhÑù3?ùÉe§÷ïµ;ÇsuªñyÎS¾½rÓ9›»B?ØÏÁ®dß÷s‘óúéwzŠE.dÎ%ü‚Ñü¯ùØ£?yf÷­ö^ö ÿ/Xú•g–oR¿‚¼­}=ŽïOìó„b¯Ôÿ¾õQ—^zÝÆÿËý¢*§².rtÑaåý~÷hÁ¡/ûÖi[ÜÝù’‹^¹Öó_zz÷]lîWôÐЯ\¦Wð?¯8üéãg/žÝìÜïìþо?ãm_üìÆ—Lâu‘+ä®xú3g/ýÛ•‹ø{ÑÚ‡?må'>±çùF£…kýñ•—?îÒžWã‡ã¹k9= ï® 9EŽ“ëüªÆ5cÏò/¶Ú¾Oá«êwóGùøzñÓOºôÊmöÍîxߟ߽üéå#q·ÚYY·8#ùˆžÑ¥}£Ø¹â^èÕ~³£Çþðì~L튜ÿâÍn¹ÍO·ê>ûÜ¢­yòî<¯s=+c',\zÄæ¯ÿþâçŒý´ÖqÉ—'}§ê^ää™õȯªÓ”×W'W¼ÜÔ‹ÈçË3éÏ•·kSò#âíò§ò í[ þ…ú õ;O)þ¦ï‡§Ðü«ºëä!Õ¯¶.!ù ø^ÅIMI]£ü˜4þ¯¾Áûá;ÙÇö_˜“ý†+,?£@°¸éw(~AοóªÒ"O;Ļ՟…~ìOq¤ƒW¼ñ¬£óˆÒOÝ:º?¬Ï/Þ—ý…й'©£V·ìwöú–g“_ë>g~Â5{Þû‰Õnû¤~J½Mê{í üy]8òáú+á@Ø7ç€.ôÙê3ƒªîªxï©K0_QŸ©úÓö ɯ©cÈs&ŽÚûªËR/NN87û_¼ s¸àºçN´^²õ‡á+}—C¹Õ|7\ØôûËwëÛtNÍ+šÃ|ãÖë½K@ñ`sþô´~!õ è`ÖC?6æÜôõè[Ñ÷ª.€V/ßE=¸÷uþ@êÛÕg8uE©—o¿0Ü7ynýºÖY|½þ•:ýÍC@yàÎë+•çV§°øX‘{­ëÔšzõ4ðfÕ‘Á‹-.|ð½ŠC•¾>ò}Ã;³ ?V}R眤Τó^Rw¨ïÑþ’ÏôŠ}Ö‹´®5u/úöá¶¾1ëÄε8á/õJꆊgšþ\÷a˜§‚ooü͇²Æ7Û—¯nŒ^TO¡î.Wq·ÈߎÃÅïüõSî˜óõ¥7/ÿÒ#o½à·ÕwèÀýÉ=vAôk¿‡>÷ùa}z0·]=:#Ú¿5ÖÛ“y¬c>]×µøÎüzPÿ/{‹¼$gÕÏ©6߯ó«ÃGèéòßþÀAŸØúŒâxÁAŽœP÷Ñ9šyNõ|ÞÏ>€ÓÒ9kÉS¶ï:õåý=uÅí?‡¢—ò<ìPvmõLö£s´B?—{Òó«ÃU†ÎÔ½¨[bÇ-ßËnì¼g¸yæÅ„½^\ŠÐ1û;õ,Åû¡'ðUqK#Õ;©c.®ZðLá8ïÎÇ4·‡ý;SÝ”z¬Îƒ$SÿYû&ö¥~øâ¤ûþ‹CO’›¾·¸­êIC¯‘Ëòaå3z×û‹³ 2t¯!w»p2¢¯è³öDîuÞLø/±vPä û¨öfè·}î±[Ôç©—#GØíìô ?¡s3ÍiÝйfá8jcmŽZè¦xMYwçú&nÁ®µ¯µÃ£ÏË7á+ó ‹c{À%è|‘ȯúѵáaÂeë½ÎÝ¥‡:ÿ/òŸQ\³ìûŸ&Ï]ú þKçÍDß¶ž‚_?88¼úrZÿ»N=~ÃêYS÷ÖóA—Î^Zq§SÿÎOe_·_)õì¥Ö«ý¡ÆÍø±µŸƒ£a.QëöÔC«ãŽž1_ƒ=Õ¹RáGø)äOûÆ"àµX»R¿‹þ-~Jç‰ÁM ¾%9êïøÙzÕy/?ëлºQñwø¹p$ùô¿þ‹¯úù³–žrÏd~Rè¨}ïè8vsÖ§(L~«CöþâGž¨{ì§ñzZŸ!ž¡ ýÁB_žƒÿ¨Î³sób9§aß@ëÙ5ÁCâWóÃÅ…àÖ‘oÞßùwé-^gôäo%ò¨sºéUøMìzƒþÁ§­Ó\0WB|Á¾´/?ö…8$¾Ìܻ·k/nÑy¼â;ê†õïGþ‘3ôý%î?ª¸-‘íÓóMñ•;_ öPã ÁïÑ?Œ_Ø ?zöÍÏÝwýï÷üлG#þ7bîñ~É_<}2ÿ”½BŸvŽWô»yÇâjüèœGß§?@?Õp^*ü§öÆþÅ×è“:ñÎÑ„¿ÿÇnÓï7ÝŠø»çæßà|̮뼬Á¼9ý:ü†žwähûO";—9t‰oøŸ­ÛŸ²×Úÿ™óSWÍþi¿iø†]ܹ¶ÑoâžS¼±ør‘³úŽ;‡5zžþl?»:~nç %Î+N2œ[Ü~àô1†Š ¿ŒBñƒÛßoŽ«¹„‰ˆ/_5uäÃþï'àŸ{Õ¾Òø;ðÄé©ÚkäRöΧûéƒ(ÞJì öÆ-Ï~ý??ûÜIÿ§8‘y‰O°›ì ÿºý½‰ß‹7ÇS?Mì_ò/r¸8‡øÓ߇rµs&bo‰·ê7äóÃÑ«xdç~˜K{•ýJÞ‘ðYèSý6âUä$7}ô8¿„>EŸä‡x…:øä‡+ÏÛç¹Çö?ˆßöñlÕNp¿rîÅCÉÜ%uúõcø¾úæÂq}6ž=Eã'û-~ÂþƒGØ~Âô%‘Kô´~ ö±þŽâGÒ[âjé[Ö4Äcßüt¿Ÿ=|ëEWôõ]ÁÇ,ÚØÎœàu˜»;ÞÎ}(>ΉüWðú‹õ1™¨îšÿEo;ôD_5®ž83½û£ë-¾Ÿù}9qBûMž¯sÙã?FÇtˆ ¡oI<„¼ÏÎįðuÄÈ;rH|±8·±wØ}Í?†ïÌC$§ð;¡xßãüë$þ=®ìûÉcÏÓ~è±þS?ZÜjöGç/Ç/ïtø½c·çCNëSí¡'z?›þîɼµø¿ä²ûç$}ŽwûÎ×ÜþÁƒÞØùÑôûÊCÀƒp~ô» ýTÆ.lÜ)çÝÂi Ÿèaö­}a_ |MÿÙOçT|¢ØøÆºÙ5Í«‡žñ»ø~¤çØmü;ÏÃÎ&§ð¹\œƒèvkýÏ1OâõÙ×ê³ô‹:¯;WqÁÚs¡Oq° vûØn-Ý¿øhüBzŠ› ;y]}œÃ¸}Ýþl¸‹ñØýâIì:û$ÿPœ%ó“¿õêár‹O³Ë·+~ç0LJ£P»/ñ ö º±/åÿàÑò÷ê§Ä?“ÚÛíS?Þð—k,¿üš{Ú—!ÿ\œŒð«õuîA쇮/öjûSW£OØ|SòNŽ\äÇÛ¿ê‹|>bö¾'wÅø«ø„]7¬?1W.¿ý“7ðZ®¸ûÜ}vúÆk–^»à‘_¾÷¯ª¾}¯Ï»¯çtÖ/ž#ŸþŸØsù‰^áqÐ_—^ôàñoòµú_â"ú|á¶ñ³Í#€Gw‹0ÄáÔÿK¿Ç3y5z ¿œ~Ã7ozÀ²îùWÿ–ÿ98‡âøÄ/Â?pDè-ùMôŽ_åMÙ½©K«…×cZ!ߊ}E~ö<³Ÿè|¢G¾ô„¾ç®þyqP¢?ÚA“ÓürùfõìžœCéà_~ÓsÝd^aüjübĉðYëÇàSFψۋ‹;ú—<§åÉÅÈ­›ößtÉ:_Woô`?Š‹š8}qÐ|…È+øô5|fþTý7ø4ð!cï|üßÎ[vÕ:Ë;OJ¼¥ó,¯/Fì`x×Á™™3øWº¡Ÿév³yåäDñoá£Eϲ«ð=n½pWÄ™Š3›ó+>FøÝù{>Ÿ‡?&¾ÇnÁÏòÓü#|JŽ£ò¡øuÉoЗä´ý±v}-î/osÃùW®}Î9ï™Äƒÿa÷7u€› Ì÷¡7ô8´è¿›ÿø'ì¼Ýg‚¼…+dý¡«É| qØØ_pÁ§ß;ÿNpä#9÷Ž~’;ëE[¬~ï)Ïnܳç/®SüéÖcf]âÐüdò{›ü‚“Ûxû#þ/ù]9?ÓOÆïô(>±oµÓ“Gn}Í8®×¹ÅÌÜ\~^è¨ý›Ã<»¦¸pñ·«×Õ£eÿêg„.Â=wr«ú(tM.‘‹ü×è‡ÆýÙ-“ÿH];Àëâ.êÌ©pì0ñˆâ”ľåO¸/9‘uë +®½'>6ÀÉ›àêæùé]rý±SÝ/þÓO'r»öwì þ3}ÄžB/±ú=ìfòHÜR|_['»©ú‹|Êó=úËþÿpfÍŸŸwìV»T{-~!ú‚O[<£óvbO»{Ìz‡uÙêy*Ï~Ùî×òñÉ>ÄßéóÁË#/ò¼ä(½oÕ ñÇÙ—¾¯yé±]5±G³®âæóî ‡¦õã‘'pÂð=c}ø¤zM6r¥óÔs_r<õþä³[ÏP}œõÙ7ùòæi27œ2gÓ¾ñçùËûŠ|l|7v`ö¹óûÐù0°®|õ_.|ܦ߯On™«!®DNÁ×çAwì|ù8v«çç°ŸÕoävô7;†V·È¯ïï»ù›ï|Óƒ“¸Dâì[þ˜8|ýô1 â—µëÕˆ?±ßZŸyä>žŸ€ÞØ CÜâîOò0æîþð]ç0wó£ÏmÞ(÷Sÿ)O@ók[??˜Æ/ïl}¿yt‰{³³ÄÉuÈå¯ñóNâ3Ñ‹êî|®ù›ÔûvŽRêÚ·"¾£î?ñc|Ü>—|ŽÜ¢‡š·ÓkçE²ÕëâÏÖ社I=YëCÿõÅíÆvVót—”x»Z7ûǺÅ[·¹gŽ ¿²u.™ïÊßj=SêëèÕâ5†ÞèËìëÙS/Óø<Š8~27Jýš:PqœÎ‘ŽŸÞüdâÞÅk=Ú:äyÈõBüeuCêú¼æ­§Ÿ¢}拺:«yGq~y#õ(òv/:öSÞ7§sûÆ}Ú §Ný çÎ#Ëy^}ÿòý>rÿ)úÄ[?Ê®%½ŸÝc¿ÙUì ùáÄ+Û—Ö¹Ôù|¬¿€|WïÑzËà‹Ì9wß3¿»îf“>ŠèÁλ t^rè€~QÿÞz„ÈEsỈuΑ•+ä…¸‚ú%sNå_;\Rü³â–f]ÎGK~Ÿüfß© jœ8tÀŸÏl]Ó'ªümŸ:Ÿ4}aê|‹?û€wìuŽ©ÓÐÏI~wD= ŸÕÈ÷Âùƒ+Kî°3ÔS±›œ«<¿½Òwê ôg¡C~€sÏ&G;·5ûæ\Ä Ô‡&>ܼ=®ÞÙýJO‰w«[ÒÿÖúùЉŽKWeîÛ—¸ÑI/šàÕÓß±ëÅyÛ÷-.™8Cêß&󕓯ߒók?³y²è0ò•ž'ÿÙÅè=6>É. ßž³øà/¿à¨G—¿÷Èzëo›dWúÄQÄ{äEÉþ9=f=ââc ¯“øÚ°> ÝñÇ›J>‘-ßÐz¤Ð9ò»p:÷&úD^„|€£M>ŠãUß„¯ä ;¯DýUòÔòô{Iœ‘?&›e_Äœ{çP„.È#z¯óÊÌ£‹<ë¼:8ñ#ƒ§]ÜXzÂyˆC‰ƒ´Î.òük¯Xé+l¼Så–ýWG!ÿ%_%ǧ¶OÍWæ|Ô&=Ì4?„ú4rIüP~T<¤q›ì!É ò‹ÿsÆ—Ïýñ±«þ¬rˆ]ê\ùä—Ògè‰ü¡ØAü¡Ú»ì è3u)ß‹ÜBgüv7½­.¶ûc>ë°?"÷g”7-®KòPìþ©uª÷é¼@xy.ôIŠéKrÎÞ'žŽŽ›wŽ@þw^LÖMÎÉ/Ñ×ä†9»âú0:8v‰ßÅÝàã”ÞßÔMGŽ©—ÀçÝÿ±?Ñ>TûHN’÷õ##ÏäÅЛ}¤oÉ%qXõ äý¸ì=kt‹+Õz2çîyøKÖ›õOâàùžÎ߈XºI>½sŒ¢‡ÔGŠ7å@ëöCŸêÏÚGžõ‘#ô°GyìÁž {=wN„ùsÑ«äÅEWüþ[nÞ¡~•¼ˆ}%Gn:zßýO>ø¸>7{ПáÜy3zι뤗+³ÎÎæw›#9»c"—bOšWU¨Èön~¶¾l½¨¼bâfäZè°÷ãg]uÁZ_Ú|7Vot.nò;òð­«ËúùI7‡qÁWVÙý_rée'þãµ7­¹Wý"v•Ï_þ¼þÙ>¹níÐÖ™…ÿøûì¸'âµä³¸Wûa“Wïò~qˆâ[$®–øüÑÆÉŻ᫧ ~iëÌð¥ú{xÎ3ñéWxÛêÄ—ðOûD"§‹Cœ8ûÞâfgîxÚ•µà ot2¯ò«ý„O?§¸Ùp6Øñêô?6s´ÿü%qGzZ ükãAñ|þóÆ¿ÿ°ß¤øâÅ¥ÇÄ¥ÍU ^fë…ôáÙýxô ¿ž¯x…õ¦Ž¢}õ𜻺¯Ó»þ.^%^/~ oœzèâIÀO‡X|¹ØqøT_">3_ÅsãÏQ¼ÄíÕ‘ê[ȣʃ>ò»øQþ°öVê”í£uáOóbôù ;uùÅóŠßÏ$¸•?ä-»¨ñÇð¹®?ÔùË£+yë,ŸGþYǯoÜø;·Ÿ=¯ñ:ûŸzÌâ,²÷Ð\»!>‡ýô½åëÐ<=¼ÑÜןðŽ}>ôÆò?½g¿ÉUß«¯™]eøåÏ|Þþ‹›G®wNuq‘¬«óäCcg¶ï¥86ÉÓ4¯-òBŽýÅ÷òŒäoðT&s1ƸÉÛÇ(üο îyóVΧ8Rc>€OÜýVwC®6ï&F¯Æ¾À+?¤n"ù¯I?fòåðçì3ù[=H^EN‰oªK$7ð¿ü†øNøºýÓô;Z|ÍóówÐ!yãùå[ä]ÅñgèNûÄ^‹–?÷œ¾_ÜI•}‡ÏÏ<'»U~—„ßõÝ»¿ú‚â?Ò×É#‰c›GӺؾ§vÞ8?SœÉȯâhçp¼¿åÊ‘àTÖ%^†^+GrßêçÐCqT³ÿâ>ž¯|;£ôy¿ ®3zk>zgGÆoi]‹ç*®IäZqxG¬>Œ]]{5ýéεôOoG®²<å…sÂ/êZ»qÈØKì„ÒãO:væ§#öˆ÷·Þ$ô׺¶<ŸŸê?êÇäþüåê³®gçCä¹<¯8+ÿ=ŽßC“94‰#Àí÷pþ}Îy2W1z©þ¤s¿Èóˆ+ú¾åÇu^Aø¨úÎøkæ²ÀäÏÔ?wˆ?Ô>ôÐ7}ڹ˩O«œEG±Ó|¿óf/ωƒÎìŸ÷£‡îSüÓÆE²ÇD‘ÓÖMnàwqÁÆ•#w‹/>p¿þ=rTÝVqÊxõôVçJ¤þ£v}]$¯ˆÏ‹<ÞÏÉ<®ø)ŸäyÕAxôW¹•¸¤yGê.œy1¨¿Ÿü.>“}P'Ú<ùEþÅ®*ݧN}«Ój<ö{‡?üÝ«_=í¹éõƲ/èÿ—är~ô§}•OFôiõxäqûmbÿ£GrÖ9×þIŸ:4/¯ÏïÕoÛ~è~÷± É úW\«~nä“u¨g‰7ø<»­ŸèMz€Þ£¿›'ߦ—²òc¥¿ð…z»ž›Êgþ숛¶zÁ/–~ã¶w\xЋ^ÛçºâÒûW>íŒ×¨?îëò¹_ÿ=ÎÅÍÓêcOZë=¼._¯o^>»ýý‰7¾÷wpT_Þµï?7õz©Cè:àr¥Žaòzpl¬O}Ï™®ú¬-_ð¯­{Pwqþk.œû®ÍŸ÷e< x8çì|üa;¬r'ü‰þ=¸<ýý²¥_ÛpËŸÞß|ó:+ß¾×ç—žzâ¶<ë×?YzöŸøìöÞÞz;yfõy©£êçå¿ÅARÿÔ¿_ðˆ¿ÙnÝc¶îßÕ)ÁuROåïöSÝ@Ö»ôĽ½cé®]áùO_°ÿõ_vlqCn|Ïë—Ýzô ­CR?„ÏOxÄ8xë-ýÎIßþÖA{­Úz!t ÿT]»ß³¿½o袿ëWV¿„îØÑéÃê>~û)Ûm|æCzÛ¹Û§ëö:ðº÷­yP÷G¨:Œáþzÿ8?ø'údÜ/þK?ÚG¿eÞŽ/jÝ)¾°¯ö ¾„ŸèÂ~^û¬¯þíh•#—žrÉê¾{³•—~òÏ»óìýã\W87üþÐùñëð’çç—çÂ~Wÿ6ìcG7WçC»üí{õuõHðnŠŸ—u¦_©ïO]XWÇwöOßè÷¼»õê#×ûþ ߶ɺgýÇœáº&ø‡©wDß—ìú«CßyÿžúþWØû+Ž…ÏÕyÂGBW‘Wý¼úpxßÒE—ný¦/öïîï'9ç{áL}÷ø“n{ÌS^ÞÏýócnü^'|nÒ­¿>õΡמN ¹®?,¸m>¿ÞßÕ¡áÓì_ÿz_Ṝ3ù—!ôÝ÷Ãõ}Lö/òT]*º¦Èôž‡tˆ:òyü„ÞØu©—ì÷¨¿²Ž|~>PïÇþÏù•¿ÈÉ!ž ùà§:ÕâÞýêä.:±_öA=VέŸûâS×Xð݇üEúƹF¿·~½DîÓ—“}Ís²Bß]GäVß_½~AÇpÈúÕ÷Ñ‹ç}æ¾ùG?÷ëåõ€ì3uƒgþô—Ÿ¾ËÕOäƒý7ÿhø<ƒu¬pþC;ô^üã¾ïäGé°7wW÷Áúéá*ç—‹</E7öQ}~â¬+¬ÿ:ïÈ¿ì;÷unƒsXá{‡xQø_Àå@ï—ð/Ü5õ÷©WŸ¬+ôåïô»Ã¹^»Ïµ¯;såÅ»3tb_ñ³uÓûðOœ»$rn"ObüŸìÏÉ>£Ÿ­Ï}ý$§ós…ïs?ö0zR_FÏ;Oz†äÉ÷è¥!ÝOäõ@¾9'ôlБõã{õåÖK~°ÿ­_#¹èý_Ýáú{þñžëV؇âã+üÿ§®>¸7ýûP{v,º`'ÇNë~’pÌèÏ眢×KWêÿõUàKv§ºhö:'oÈ;ß; “ÚÁ‘Za_¬Ãù‘›žË÷«Ç¶¸AøX=7ùX=yHÿ súÒ}|´Â:Éq¡è‹ø_߃÷ õ=9Ö¾ÎÇw±{WX‡õzûû™oÛæ±oés““^'‡à¿:?û7’^²ÏùÙýDWöN˜uG5õiâ ä½øœºx|F³¿üV»ã+v¸xÇNÉûbýâøiè_KèÊó©Ï§·ôãÀOFøhøs@½Ÿ<-½P¾ËºáR¡3ýülë…»-~ãùÝŸ=ïûɯô®à? } èH&{ÛûsnÝW÷ÏÏø?|Ü×£ø}ÇÏúú¸êÆÎ%¿üNÎDïõ~ô+>ǧüv¾ýC¯ìàË~»×6¯zûÅ]úóÓºÈqþœ¿£G}:øJ({<ïŸø£©Cq>ä}E>à'ß+΢ïÙþÞôº+v_ôœ›«Þù»´ÛE­œÏÏÊ{öEæ ãuõçõ?F^Mú”Æý.+ءί¿H¿áÐÿÆYéÇø‹“þ¥ôqÛøýø"¸R+ð)¾·žÚÃóW™3ç±þÐ[æN¯é5½¦×ôš^ÓkzM¯é5½¦×ôúo_ó¦×ôš^ÓkzM¯é5½¦×ôš^Ókzý¾æO¯é5½¦×ôš^ÓkzM¯é5½¦×ôš^ÿ—kfzM¯é5½¦×ôš^ÓkzM¯éõߺL¯é5½¦×ôš^ÓkzM¯é5½¦×ÿg×Âé5½¦×ôš^ÓkzM¯é5½¦×ôúp-š^ÓkzM¯é5½¦×ôš^ÓkzM¯éõ_ºf§×ôš^ÓkzM¯é5½¦×ôš^ÓkzM¯ÿâµxzM¯é5½¦×ôš^ÓkzM¯ÿ™×Ìïð“çΙùýï wÝþ­Ûïº×Cÿ{Øïÿ:~uî3üg]ÿYÏÖ÷Ÿ¿ôŸ¿òŸ ügCÿÙhp»oØu۽ܭkØaÛ7ìý¦=úß÷ï¾ínÛ{ûÊyqf=·Ý¡ÿßmû]úÿ]ß°cÿÿÆ=Öýßþoõ ÷Xý§­ï/³{l»ËÞ{­¿¿Îßc—m'ÿ}Cÿ»Þ†ýªww»ù;î¹Ç`¹‹÷|Ó>O³äUºæ8çwÿ~7öwoœÿààÉ—l·íÞÛ>m‡=úÈøéç<ðŸè~EH} gss/data/stan.rda0000644000176200001440000000440613267106071013423 0ustar liggesusers‹ÍX PTG}ò18 "~@@P@Ðq>dî óÁ€º@Р2ü„E`Q”ñƒ ¨¨]ÁhÄ5Œf JˆVW±LÔu êf5ñâ¢ÄÍ"ï¾—}]P×JíT gn÷íÛ·Ï=Ýô{ äB^¢(=JßÀ€ÒÓïÿi ×ÿge@zi¤i5+)Jßüåïþ¯Iÿ· øÔÀŒUˆ›VÓ¸TGã ŸMØI£3¶‡àøºPä·ãcÿÄÄTšh(߉þÈ_ öoÀu®¡ †ùØþ6b,úÏD»ÖŒÆÊ|ä¸óÕì¥qÖ¹F‹y ÕÈ{u"ޝž‰uåò³å*U4 C}ì¹ÊÍw÷9wÝ¥±Ûw¡ŸÚrDkÄJä¥RÀåG/;1¯²\½”¡ŽÊ0Ïe]Èo+Û0Ÿ ä©yHA>%§¼‡FÚ™¸¾2Ô]ê ì#®®·!›J¸ü—bÞJô+Å:”ÎEô¦1uç‡ãJpŨó¢Fä×±û q߬*áîÓ|§Å<òhÌC;Ç…¡…¸×»u½1û7¡n6¡ž62:Æ:Êõ²ùÖ¡.t¸®8l_‚q3±~ëp}ëˆói<Å9 ù[üfFq÷•m-ΓŠqS¢¸zLÂy£ÑoæÏÄÁqÑÈÃbÔÅ"Äôî¹8‘➟Ì9ÎØÿ/HQ¿í¸W7ÜøCù¿é<k¾‡âå×>Ãåw¨ñ¿–ïpçý_×;ܺ¿îº^5Îpý^w]¯›Ç«æ9\½îºÞ4¯ÃÕñøÐ÷ñ â^£ î»Ì½ ˆ@æÿCú)tÜv&Î;ˆ€ýj"sšGäÁÄ•#†í„ÍÜWdÄýU5T;ѯ&úý‰ø@q1€à‰™ßèWë¸÷af¾9j"/51žA5x]TD¾*â9ƒ‰ÇÔINÜÓ™ç+f¾hKuD=ˆ8ÌýOŒgægx Ò Î+[?b>1¡‡@â9OLèÌwˆº¨ udxct&$âª=È ]J}3ñÝ >˜<¤CèÒ›¨w np½1ÏQB‚¥CÔG5Ä~ â“uñ$ÖÃÄ÷ õ¤ã>g2óÉ>¥„Toj"ž’Ð1΃¨wà¼2ó¹ùé×™W1DžjBgjâ¹ZNðêAðÅð,&ò®ö7éë<|SÒwbÍ݈¹ƒÕT+ëU§ƒ÷Ÿ¥×ü}8¦Í.2™vL]– ÏÛ9¿;=Ó`>m`RÉêmÔ܈·¯¿ Ÿwµ,º\bƒO½Nˆ§ƒršDlq‡N ¾5>V÷>û¼æûÝ·ß»^_6y\àØC¿7ȉeøîˆ¶À¾W±J4y–Ý‚)±WlŒ¶€uIGÕ,ÿ  î¸xü¬“ ¼#Ün)ä‚Éù©e/’=@’gµ/ë§«¬Ÿ¿w÷ø13˜ýÍÇ÷o·Áœ}óÁ9´ùXÌ ÖÏ­÷–£YÎBZÁkÏt;Ɇ§^Mc hžÝ…©†5 žðn_ò,+¥JnHògûíl»$šO.ßÞ¤ÝüÔk]ßê+lfŸß|löoµ¿ç êi¾c¦ÔÃè¾kÀ¶¹yýéôÅÐYk\ò5È*»ÆMÌÍÍX$ì«¿ö¬ü?7qÇ3žuÈŸ„,wƒ,ZwLµ ¬Ú([Þç Š ×3Êm3þ8l›Ø­äÁH·Ôlöc˜Uä+í0î¾7.A¢„€Ñ/Fä˜6€ÜkŠÛ¤PwpvÉ¥²‚³ÙùTc®T A ªž/É]Ê'f¼žôçàf£_ ݉¬~•±÷ôôGÏedØÆu/ƒ2lfÙÎòŸAilc¢±dùÊÚÙÚ¬E¥_ÙŒÔ[ rëâwØÚ‚bm~fD»%›¯ÂB] <ûäÍUsÝôìÀ/£È§ª5ä'S,¶Œè³3?- ?“Po†.9 ½wAî›’9]g rsƒãçW²üûWž¨½±üfG;xôrø%ëgƬ^¤õcŽœ;ú3H ÏMýêò?Àµ®oü²YÛAÖèpLÒ°¿,:°½Ÿ÷â‚ÖöJ>ȶ|÷Cþ7OAPTtùèµ=`©ˆ5LhiYÈ|?Å6-Lú^¥v4‹÷Í÷\ÉX Ò¶–峚2@zÖIsºüH[YvÅ›²º–*&‰ïøƒ¡Ðs_8Ë?ô4>nÛh “¯¸'Æt¿ØoÁµ­“ÎÏ~  ÒÁéðãFp}ÐØùü©,îîðÚÿGä[²iÌh£¯–ƒ_Gßã‹ÙóÀ‘ù¿tÛ~§‹Œ=g|oŽê)ù—+TQç3ùeŸÎ¹Ùuy/­ß[u­w2ˆŸ(¾°ùg.ˆòb—­3”=N`_8á¤ûj!8>_ù~ô%#ðinÌèðêŸÆ3¿³8sfZy{ßL°&›éКÞ7=NÜýà4xßkGz³ç®èÅRåÓG0‘±W*J×|½D VøŽë‘,aÏÖç ²:s²üË;ìyç8Á§ØåàpÿCÖ»U~ÇÁ³Ö.-P? }ÀoTjr&Ÿ‰iüò¥=½Ý©&râ˜$M31ÓÈ‹Õh5üøTÍ˸Կ_~ÿ¡Ð Óÿgss/data/bacteriuria.rda0000644000176200001440000000170513267106071014747 0ustar liggesusers‹íœ[S1†—mA(¢(¨¨¨ˆˆˆXi6»O ¢rí·µ”™Îp˜)UoýÉþp·“}: ÝäK¶Ò™‡|Ð%O6ç´ÓþØÚa…‚ã8®“Ëç7†y7ü1ää±0ÿY©6kú¯F½â8¹©èù0á­ËäpÛÈÈw`X‘×:0z†1… OÁõL$pC›mL¸Eà6)ÓÜQän î˜!p_’¦`V‚G <&ð$%sxªÈ¼Ï.a!çX$ðB‘%E^X&ðŠÀН Ïð&«JXÞ†/A@ L`À:·Þ%ð>%$ø˜‚ ›>%ð™ÀE¶ùJàï)ØNæÜÑgd¿ö»¶,vŸÛâ¯C¥8`qàÅ?‚8(ÇÁZ¬‹À-­"*!bˆYÕï Žoëí®·_çWÛþÙîzý¾º=>¥_ØýšÚú{‘'«þsUæC{°Þ^Þßtº»ÿ1ëíÕò]•þm½v¼usÿizœØ~0Øç»ÿ¼’¯ÄïÓ8mr¿Ë^GÍWµœ²ùSï+mydSÝåÏ:ß´ùéú?Õ~%Û~ºÇ‹l>ÔvÔÕžª×©Þ‡îyFµMõSÓãAW¿’mw]õÜižLû¼éöR­wSëSVó£®õÝÔüiª¨–_uß {ÕUYÍCÔõDu¼©ŽSó¬©~,[?ƒšRûƒ¬'«ûQ]¿eǧ®zW-µÜº÷!Y··éöê·y@v½ÒuR­GÙú5Õ¾Ôó‰©r¨Öµ¼ÝZ»õÐ}ßÔvÔÕnºû±©ú2½È*ßnõÕy¾×æAÝëŒîþšUW=ggµ_PÏ÷üWVjñWäão0¨ïŠ(×l4E˜oÖjñçsê‡{µjó‚Oïv+ÍJq¯æÜfký)ÆÆèëîÜ¿­"µÞ6Š>êsò «×O-Qgss/data/gastric.rda0000644000176200001440000000073413267106071014112 0ustar liggesusers‹Õ•=OÂP†/-~@¢!qqppp&ÂA“C…ò¡Ô’ö‹‰‘H0DEV‚£ƒƒ?ÁÁÁÁÁÑ‘Ám9oIJBŒ‹†›”çÞ{ÞsxïGÚðb4èzcÝn&ˆf×-˜?.æf“ciIçZ6Á˜8e­ø¤ùÄÚ¬ÛBk1"Æg‰©'â.t*âù8Q{v²€ù"ò‹Ð1_B½ô¥¶“ûÐïßàëyåñdžh ®QˆèΦAø9;Y]¡¯~ë¨W%^Â×UžxÍÁ7ð“Ø|!¶à¿õH `ÿ–Àep\Ã`ëŽ`Ýà&â[ˆocœ|'Êð™Â8uglbÝøÛA¾‚<qÿ§cŸõ{œ‡xˆó;F~ù|8Ï Îãt„*öõñö¿ßpŽx“±ßÍ(ñ¾ZÌnŽ{ý×´Û°Õûi~Pû¯}þ¶ Î'¬{Ý}¥ß# ßãø|Žæä¢œÓÍž¯¥YWÀîûô#‰œ¤Ûò^‘””àªfö:ýò=I‘m¹Ø“xV‘í‘Î%^Ð1¹Æûjx4µä·ëXwE 7±ug,¡øÕgÇ›”¸äOif Ybo¹xáTHgss/data/wesdr.rda0000644000176200001440000000751713267106071013610 0ustar liggesusers‹ÍœÛnœWǧIÚ&¡mÒ¤Mí\Ûs>zŽžñy’”D®¸êm  BjAJŠ*îü¼@‘¸åò<@x€¾€¯‘@ªpâõÛÒþQ+±g°Tv¾ïÛ‡µ×á¿{?ýèÓþÅO/ …3…³çÎΜ=üç¹3‡ÿóZá\áÂaûúן?úìa¡pöêÓ/‡ÿ½sØ÷ÓÒ7Oÿ~?->yú÷çéÚàÙßt³ðìoÚŒï{‹Gí¹èw7Ú[Ñ9úõ<û›¾ÏkÑnìÍw%æ}?Æõ¢ÿÅh«1o-ž?‰q—c\7Þ¯ÅóN|‡îc½¢íF[‰þ[1¾»¯ñGï÷¾‹ï;1îV´ƒ ëf´ã˜¯ßÏĸÍhÏÅ÷vеã.Dö»m!úŸ~¼OüYŠv9ú×¢ÿk1o+žo­›öóz|¿Ï+Ñ6‘sЉ|+ÑÂÇè ý£ÿârÅ÷j!o¯Å÷Aô_Š÷ ’OWtü èÇwø]ñKZg%úß„ž{GóÁ§åxKzƒœVc<úZŠqÈ¥¬õ?ˆ~h±ƒn¬ûa¼Ç®Æ3r¼Ïïļwþ|XÌù½£ßû‰ñðŸuFAGYûØÃnc~Æ·cü>°n´ÌŸÊ…ܾá'öR‹÷›1nüØ 9.G¿f¬‹|îÆ"ä·íðëh?{ÿ(ä8û^Ì{ º°ô+ø¼ÏÌ·Êúñžý‚çWã9ÖMþ¥¢¶&û›‚1Ž~àvTÇïÝàpïñÑwäFìuóvÐ[ù¿d×Ƚľc=ZøÞÂnXùч ëºp¿8>-FÿKÚ/ø‚ÿe½÷¢o°‡R<_—^áÇá'þ ßÚÑâ?Zñ|M8Ý–œ+ÑŸõÑ3ôü ¸Š¾Æó(Ʊúc¯òØ8ÿJñ¼(?¸ ~+Gëîý+žÑ¿7åKâo÷ ì)Zô§/ÿ âçÿ–âð®$œÃ. Aç¿ãûªø]‚Gà?ö îM¿ þ‰ÏõhñÓèÇÛ1Ïèq.àâûN´wÞÊå{Eþ*üðÞ_ãy$?~<É<šÆûâ‡žäø°”û÷½¿ÁOè÷1oZŸùÏÊn‰?À…óÒ×1ûu7À…xß×:ŒOñ"ñOô/æëTw^_†Gãžúx^¸€¼ÆÄAÄ#Šãßgô½*œAï+ùúÓæ•=¢ÏÌónŒO«Ñ/ù_âʘGÁMâðyAûØñeåØËíƒ|=ü t¢‡èqaWóÂo⸆öÙÃ^…+Èœºvôœâø‚>ðv…¼DqûßG¢HÎ⯘ýÂÏœSgþDñÖ5ñ¡F>IÞ*¿?’_•>MW„¾Ã?pžx.ê-Iÿ®‹ßÈ/âÿ¯@wAõÞŸUžq)G˜ù&9/¨Ž®‚w+àô傸tSñüX•áyÆòZô‰ü…¸¸¬xdYùtíP·PÜ]«~–ô8a;Æ#op¸£ü†<Üéäø•øØÈã¶$÷uå]ði¤¼èή$þžW’â”Õ„wÔk°ãä?ÄgäK\ÿ¨*>"ni_@_Ôÿ¬)n©(?n(Þjé<ùƒ{MÙ vÓT=®‰oeù³†âÇ[«²ßv^wLt‘'÷M¯âŸeï ÕizòOÄ+EÙgÚŸêoÉŸëÜ u×qyƲø“âEáïëš⡦⓲Ϋ^¿j:§‡-ÍS×ùñEU¸‹ü]®HŽméeQñKEñBMøÜ¾µÅ‡’è\T\P—¯Ëîâwíkêªo5Ž9o+³~M¸Q»×…§/K_íg–vUøqô %?_vÝ|?Ç=Æw·¡Ÿ´ÂOì·£ø¨¦óõ²ê7ØYEz†Ö÷µ”wÁ÷‘äâ¸}-JnÇù¡¢ô8ù/é#çëÉÎ(¯†ï5ù¥Šî›Ôu[‘¿XS}¢¤{H%ù•¢êgEùðqYú¶ª:‚óKösKñAK~³)}X‘¿Ãþ «­s®”ŸÈ> §¤û=ÌÛUœWÕ¹mÒwÙoSzÚV~ÜP^ÑR¾^“]UïnËoqŸcUu¨²ðùutä–êÐI^Ò«%ÙASmOyjM÷Ø[u™’òét.y$þ;XSÞ»&œ­JŸ‰¯ëÂïŠë²›ªöWTýª¢ýÔ”ßÖto¥füŸ«Ê»*ÒöÉ=©UÕ7+Â}×w,Öí‹.ãkUùvUúÓ‘;^®•…cé|Tòj èW”}TT·¡Ö6NÃÕ;9ßå¾Ü|z&j©OïrÇ=³Xwv@w—s ÝC£~ÇùÆÇñ<Žù7™—º1y7ïcæßÐùåþ-æŸ0?çÚÁÏuíŸóxÎÕ9ïÚbÞxëžóNîåu'Öç¾t4úÒñð™¼úÎXñ÷(° èf}ìs=|GNâ|rnÅ} äÂ8öKþ*¹lÆ|Û¹½p^Ä9È|DÏ¡‡÷1ù¬ä÷B¹OÁ{ô úÑÛuË?è`4úÆ>U7d®Îs°£d?ª²ì˜<‹ñÈu±ôž{ ÛØt2{Òzða¤ºç¶ÖCOwGú›äͺðq?æžv‹¬‹^ΑÇ&öÈ:Üã…Þø¾>Äømô–u3òg䳘ßObžu݃å\,éŸê4Éžbø¾ F;Àþòû²i=è§?ûn€7Ü×€ïCéótÆ<èņîßP§Bðcë¢êë>Ðã^XÂ3ι7Á>Ù7ö$~Aw_÷™Æ¢c]zœôåAÎwÛ;÷W’@?Á‹A¾.tÂWô-ù•B~¯½K|ç½îóÒnr?91žrœJöO>*+ŸJçbÄ7ðœBo•§7üŽa¬{N „+Ù͆îýÓyÂøL^Ž¿¢¾›ìùAî§Ñ/Öß]Ìë®Ð‘ð)èžè^"ö»¡sö3”Ûð}¤÷ðÁò‘@ÿŽê„äëøô}Ý®ôäï¹7Oü2”Ý`_#Ñ=”ÿÊþRÿB޳}ɾm /{ò“Èóãxæ>ݦâNø\¶tfbfÏ1nïqŽÄÉÈõ_qÚ~޳ɮ…¿Äéí¶ô;ÜžÃ?âuø4XÌýàPq§q•ý¡ïè|(Oà=z¸%½oˆØ'z†ÄfÚ?Èíh$Üʯ%y=ÎýÒmÞ?ù~ý)~à÷Zàôôa7à²ìvOy¿ÿ˜?žáß„C}ÅÌ¿­ºv}ün.Å!û9nl‘w,*ÿ‚àˆ~/s×~D¸Žþì*>ÆÿÓùáßíiìã ÿýÚ@øŸ'º—.‚ëcůcÅmðcè8þ¹žsÿ~ò;Äé4Ç#ps]y üFî>ÎãÆùkøK|Ã=QèÂÏîÈŸãW‰GÐ7øs}…æñ.r:ÈíŽ} uÞ;ÒïœvµÎ®âpì|w"?>Rœ8V>”ò_ú)¿Ü’žÈ Ïèï–óxé)ëàÁsò ò˜Mýp$‚?_ÀŸ?ÈñÄyüXqëºð¾m ÿ°ðžgô¦§ø{Î[ÊOà_ÀSð<9ÈóÈ‘~·Šà;|Lþ\¿»ØP¾ë¸q]õ ppM~e¨¼›ºÆP¿—ÀvõûÌ4/¸#}â;x7”ŸMùí½üw»cÝóHýˆßÐsäL\„ž«ÞMeOýÞ1áüÆ_{}åÁ#å'Ôo+ÿ‰}ßËïIcGÛèÇ~žo%¿(¾ÞV ;BnèQO~{¡ÿ@xµE¼‹Þ@pº>¿Ä?Ç<Ô; ÇüíýåûÛç}^û¢'íÿ¢û˜u½ãúôýié?-_“ß‹®ó¢z1«>Í[žGç¬úùÿ®§ÝßóÆÏKOª§'}ÿªä;oýš•ϳê׬tÌŠ§ÕÇ—µÿ“âèiñø¤8yZ\ÕŸÏê_ÿWñÀ¼õa^z?/ÿyRý<©~ÍŠS³âéËŽ‹æåO«_³ÆÕ³úÏÓò{V9ͪ_¯Zfõóò¯/Ëÿ¾ê¸þeÙÕ¬ø7¯øã´v>k¾1ï¸åUÅ1óŽ#fÅ©yãæ¼ÆÏŠƒ³ê߬yá¬zý²ó¶yÇóæßËŠÓ^¶~ÌgžÏ‡üÿÜóW÷¿üüÑá?.?ý/Ï~ö›‡üó_ü–þìË_òχŸ¥‰.<üõ×&{ûð¿3ûÏV{ZYÍWüù÷±"//~vÿ«ûÇ>}÷ô¿ÿ-6Y\™Tgss/data/datalist0000644000176200001440000000015412355360640013513 0ustar liggesusersColoCan LakeAcidity NO2 Sachs aids bacteriuria buffalo clim esc eyetrack gastric nox ozone penny stan wesdr gss/data/aids.rda0000644000176200001440000000260613267106071013376 0ustar liggesusers‹…™kkG†'¶ ‰¡ÅPÈÇR‚J1¾È¶"YÖ¬î«ËÞ$»þ*§’â–~ÝŸ¦ŸÔ_P*Çón™Ç»ØÍîÌœsÞóÎ9g¤¬s¼{³kŒÙ2Û;;fk{óqgkóß3³c^ÜVßß³ýãæóýË6¯^Û óíÏþêä+Ès'qò“ÝüA¾tã=Ì«9yêäONÚÜŸ§çuì«ñ1浜¸yGx/½ðCöYøe1Oë„K)}íŠqÏÉ(÷ñêAßÈÉKì?>g°_øD˜_‡žØÉÖõs×W˜÷Vûäþx~ž€7öM;yˆñ(÷õ§ÀØiîû}ˆxí!ΗàöëémÂx:ýÉÚá˜û¼µˆcž[ðr?ëë×û.ì¨ÁÙ9Î}žþŒù à¤s"¹Ä¾ŠÓ8OÁ_ñF¼ sŸ'ÂIχàQë4¿ž+N‰“ ‡kñ¼àù;Æ9n#>o}œôWè=Åyi‚_uSžwÚÀéyäçæ|é#1ÎÓ<œ¹çø(»cØÃüSÃy9Ázæaùÿçýyù x*üxˆüÑ.1ô `o½"ö×!ü:À¼>â^ǹŸ1ò!ëHþÖq.{à‹ôÔ÷pÁká¶\ûþ·q~õ| ?d×ÄÉÎevw ·8Ÿ8Wí'ôXäÃ1òŸÎU„ý”Ø¿ üÇ8O)êñõ…ý@ õ©‡çî<ýÓxÇ)â9}éÚß?€Ý¬[Ä1@=ë¿ùâ |Ÿ`ý!p=CC>Z‚/ôwÙÏÃ.ñ÷Õ#øÛG}éÂâçå÷}Æu†:×C^`^ù¦|&Zxþò˜â¬ùCÔµ6òD?“¼üþÌ>#C½²ÈS-ÔÈ”ßßgÈÇç8x~‰~-`~D´.Ïšˆw y*Äù¹ôù^ôOº§º‡|©çdźGãçåãªuÜ÷Ѽ½'ô?åÏórY¼Ÿ!®uœ¿Îuy <度)çAˆ|Â|׆]§¼?@Îñ>xâû·!Ö…²§yCð>À÷’Mä£ùŠüœ"ßðþ4Â~M¼+æ  o‚óÌïçè;Bä;[Á‹¾µ‹¾RóæÀñ÷Æ)î!d|˜£ë’È/àéð˜COÍ”ç©)xÚ^ìÚ'¾¨Ó3ô)¶¿ž)ïçÔwÄè—ÔGE¸ÇĨ)û,ôE ÔågêIÑGpÿ}k=…½ðK÷Öu,Å÷¥Ú'Ã8½¼°Wý[î×q┞¤jÞvœßE^nO ?—ÀGÏ3ØUàËù¼?$´×ø8jÿ+ìûTübSþ>ÿbô î)¿'~ |ÏÌuÂoaËãPÜÏ­¯‡ñÔ¼ìã~1p£¿²#©À%nâ%×¥¦ü>Uñ’<¶åωwªïŸ¼ßö¾û²ú|{·ù°÷íÇ=÷ƒßÇ/ïþúÿó‡[÷y{õû-Ö¿øúÇßÚãûûÔ<{MEï>­î¤Hw߯þ\|øºY¿ý{ÿï?MP€Ègss/R/0000755000176200001440000000000013475773371011270 5ustar liggesusersgss/R/sscox.R0000644000176200001440000004434212355360640012544 0ustar liggesusers## Fit hazard model sscox <- function(formula,type=NULL,data=list(),weights=NULL,subset, na.action=na.omit,partial=NULL,alpha=1.4, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { if (!is.numeric(time)|!is.vector(time)) stop("gss error in sscox: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sscox: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sscox: time and start mismatch in size") if (any(start>time)) stop("gss error in sscox: start after follow-up time") if (min(start)<0) warning("gss warning in sscox: start before time 0") time <- cbind(start,time) list(start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sscox: response should be Surv(...)") yy <- with(data,eval(resp)) ## model frame term.labels <- attr(term.wk,"term.labels") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+"),"-1"))) mf <- eval(mf,parent.frame()) ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sscox: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) random$qd.z <- random$z random$z <- random$z[yy$status,] } ## Generate s and r s <- qd.s <- r <- qd.r <- NULL nq <- 0 for (label in term$labels) { x.basis <- mf[id.basis,term[[label]]$vlist] qd.x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { s.wk <- phi$fun(qd.x,nu=i,env=phi$env) s <- cbind(s,s.wk[yy$status]) qd.s <- cbind(qd.s,s.wk) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(qd.x,x.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk[yy$status,]),c(nT,nbasis,nq)) qd.r <- array(c(qd.r,r.wk),c(nobs,nbasis,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in sscox: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p[yy$status,]) qd.s <- cbind(qd.s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rank=")&outer(yy$start,tt,"<="))/1 bias0 <- list(nt=nT,wt=b.wt,qd.wt=t.wt) ## Fit the model if (nq==1) { r <- r[,,1] qd.r <- qd.r[,,1] z <- sspcox(s,r,r[id.wk,],cntt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias0) } else z <- mspcox(s,r,id.wk,cntt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias0,skip.iter) ## Brief description of model terms desc <- NULL for (label in term$labels) desc <- rbind(desc,as.numeric(c(term[[label]][c("nphi","nrk")]))) if (!is.null(partial)) { desc <- rbind(desc,matrix(c(1,0),length(lab.p),2,byrow=TRUE)) } desc <- rbind(desc,apply(desc,2,sum)) if (is.null(partial)) rownames(desc) <- c(term$labels,"total") else rownames(desc) <- c(term$labels,lab.p,"total") colnames(desc) <- c("Unpenalized","Penalized") ## Return the results obj <- c(list(call=match.call(),mf=mf,cnt=cnt,terms=term,desc=desc, alpha=alpha,id.basis=id.basis,partial=part,lab.p=lab.p, random=random,bias=bias0,skip.iter=skip.iter),z) Nobs <- ifelse(is.null(cnt),nT,sum(cntt)) obj$se.aux$v <- sqrt(Nobs)*obj$se.aux$v class(obj) <- c("sscox") obj } ## Fit single smoothing parameter density sspcox <- function(s,r,q,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias) { nobs <- dim(r)[1] nxi <- dim(r)[2] nqd <- length(qd.wt) if (!is.null(s)) nnull <- dim(s)[2] else nnull <- 0 if (!is.null(random)) nz <- ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(lambda) { if (is.null(random)) q.wk0 <- 10^(lambda+theta)*q else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda[1]+theta)*q q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(lambda[-1],random$sigma$env) } fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk,s))), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*((nqd+1)*bias$nt+nobs)+nn*(2*nn+4)+max(nn,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscox: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscox: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,log.la0-lambda-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization if (!nnull) { vv.r <- 0 for (i in 1:bias$nt) { wt.wk <- qd.wt*bias$qd.wt[,i] mu.r <- apply(wt.wk*qd.r,2,sum)/sum(wt.wk) v.r <- apply(wt.wk*qd.r^2,2,sum)/sum(wt.wk) v.r <- v.r - mu.r^2 vv.r <- vv.r + bias$wt[i]*v.r } theta <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:bias$nt) { wt.wk <- qd.wt*bias$qd.wt[,i] mu.s <- apply(wt.wk*qd.s,2,sum)/sum(wt.wk) v.s <- apply(wt.wk*qd.s^2,2,sum)/sum(wt.wk) v.s <- v.s - mu.s^2 mu.r <- apply(wt.wk*qd.r,2,sum)/sum(wt.wk) v.r <- apply(wt.wk*qd.r^2,2,sum)/sum(wt.wk) v.r <- v.r - mu.r^2 vv.s <- vv.s + bias$wt[i]*v.s vv.r <- vv.r + bias$wt[i]*v.r } theta <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } log.la0 <- log10(sum(vv.r)/sum(diag(q))) + theta if (!is.null(random)) { mu.z <- apply(qd.wt*random$qd.z,2,sum) v.z <- apply(qd.wt*random$qd.z^2,2,sum) ran.scal <- theta - log10(sum(v.z-mu.z^2)/nz/sum(v.r-mu.r^2)*nxi) / 2 r.wk <- cbind(10^theta*r,10^ran.scal*random$z) qd.r.wk <- cbind(10^theta*qd.r,10^ran.scal*random$qd.z) } else { ran.scal <- NULL r.wk <- 10^theta*r qd.r.wk <- 10^theta*qd.r } ## lambda search cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscox: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } ## return if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) { q.wk0 <- 10^(lambda+theta)*q qd.r.wk <- 10^theta*qd.r } else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda+theta)*q q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) qd.r.wk <- cbind(10^theta*qd.r,10^ran.scal*random$qd.z) } se.aux <- .Fortran("coxaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(.Machine$double.eps), as.double(qd.wt*bias$qd.wt), double(nqd*bias$nt), double(bias$nt), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## Fit multiple smoothing parameter density mspcox <- function(s,r,id.basis,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias,skip.iter) { nobs <- dim(r)[1] nxi <- dim(r)[2] nq <- dim(r)[3] nqd <- length(qd.wt) if (!is.null(s)) nnull <- dim(s)[2] else nnull <- 0 if (!is.null(random)) nz <- ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- qd.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[,,i] } } q.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) qd.r.wk0 <- cbind(qd.r.wk0,10^ran.scal*random$qd.z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(cbind(qd.r.wk0,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*((nqd+1)*bias$nt+nobs)+nn*(2*nn+4)+max(nn,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssden: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssden: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } ## theta adjustment z <- sspcox(s,r.wk,r.wk[id.basis,],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,random,bias) theta <- theta + z$theta r.wk <- qd.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } mu <- apply(qd.wt*qd.r.wk,2,sum)/sum(qd.wt) v <- apply(qd.wt*qd.r.wk^2,2,sum)/sum(qd.wt) log.la0 <- log10(sum(v-mu^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspcox(s,r.wk,r.wk[id.basis,],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,random,bias) ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search lambda <- z$lambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta ran.scal <- z$ran.scal cd <- c(z$c,z$b,z$d) counter <- 0 r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscox: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- qd.r.wk <- 0 for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.basis,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) qd.r.wk <- cbind(qd.r.wk,10^ran.scal*random$qd.z) } se.aux <- .Fortran("coxaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(.Machine$double.eps), as.double(qd.wt*bias$qd.wt), double(nqd*bias$nt), double(bias$nt), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } gss/R/project.ssllrm.R0000644000176200001440000002367213266770211014372 0ustar liggesusers## Calculate Kullback-Leibler projection from ssllrm objects project.ssllrm <- function(object,include,...) { mf <- object$mf term <- object$term id.basis <- object$id.basis qd.pt <- object$qd.pt xx.wt <- object$xx.wt qd.wt <- object$qd.wt ## evaluate full model x <- object$mf[!object$x.dup.ind,object$xnames,drop=FALSE] fit0 <- object$fit ## extract terms in subspace include <- union(object$ynames,include) nmesh <- dim(qd.pt)[1] nbasis <- length(id.basis) nx <- length(xx.wt) qd.s <- NULL qd.r <- as.list(NULL) theta <- d <- q <- NULL nu.wk <- nu <- nq.wk <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] y.list <- object$ynames[object$ynames%in%vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu.wk <- nu.wk+1 if (is.null(xx)) { if (!any(label==include)) next nu <- nu+1 d <- c(d,object$d[nu.wk]) s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) wk <- matrix(s.wk,nmesh,nx) qd.s <- array(c(qd.s,wk),c(nmesh,nx,nu)) } else { if (!any(label==include)) next nu <- nu+1 d <- c(d,object$d[nu.wk]) wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- cbind(wk,phi$fun(qd.xy,i,phi$env)) } qd.s <- array(c(qd.s,wk),c(nmesh,nx,nu)) } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk+1 if (is.null(xx)) { if (!any(label==include)) next nq <- nq+1 theta <- c(theta,object$theta[nq.wk]) qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) } else { if (!any(label==include)) next nq <- nq+1 theta <- c(theta,object$theta[nq.wk]) qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) } } } } nnull <- length(d) nxis <- nbasis+nnull ## random effect offset if (!is.null(object$b)) { offset <- apply(object$Random$qd.z,c(1,2),function(x,y)sum(x*y),object$b) } else offset <- matrix(0,nmesh,nx) ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 qd.rs <- array(0,c(nmesh,nbasis,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.rs <- qd.rs + 10^theta[i]*qd.r[[i]] else qd.rs <- qd.rs + as.vector(10^theta[i]*qd.r[[i]]) } qd.rs <- aperm(qd.rs,c(1,3,2)) qd.rs <- array(c(qd.rs,qd.s),c(nmesh,nx,nxis)) qd.rs <- aperm(qd.rs,c(1,3,2)) z <- .Fortran("llrmrkl", cd=as.double(cd), as.integer(nxis), as.double(qd.rs), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(t(fit0)), as.double(offset), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nxis), double(nxis), double(nxis*nxis), double(nxis*nxis), integer(nxis), double(nxis), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssllrm: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssllrm: Newton iteration fails to converge") assign("cd",z$cd,inherits=TRUE) z$wt[1] } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift if (nq) { ## initialization if (!nnull) theta.wk <- 0 else { qd.r.wk <- array(0,c(nmesh,nbasis,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { mu.s <- apply(fit0[i,]*qd.s[,i,,drop=FALSE],2,sum) v.s.wk <- apply(fit0[i,]*qd.s[,i,,drop=FALSE]^2,2,sum)-mu.s^2 mu.r <- apply(fit0[i,]*qd.r.wk[,,i,drop=FALSE],2,sum) v.r.wk <- apply(fit0[i,]*qd.r.wk[,,i,drop=FALSE]^2,2,sum)-mu.r^2 v.s <- v.s + xx.wt[i]*v.s.wk v.r <- v.r + xx.wt[i]*v.r.wk } theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nbasis) / 2 } theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(q[,i])) fix <- rev(order(tmp))[1] ## projection cd <- c(10^(-theta.wk)*object$c,d) mesh1 <- NULL if (nq-1) { if (object$skip.iter) kl <- rkl(theta[-fix]) else { if (nq-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { z <- .Fortran("llrmrkl", cd=as.double(d), as.integer(nnull), as.double(aperm(qd.s,c(1,3,2))), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(t(fit0)), as.double(offset), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nnull), double(nnull), double(nnull*nnull), double(nnull*nnull), integer(nnull), double(nnull), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssllrm: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssllrm: Newton iteration fails to converge") kl <- z$wt[1] } ## cfit cfit <- matrix(1,nx,nmesh) if (!is.null(object$b)) { qd.z <- object$Random$qd.z nz <- object$Random$sigma$env$nz id.wk <- 0 } for (ylab in object$ynames) { lvl <- levels(object$mf[,ylab]) if (is.null(object$cnt)) wk <- table(object$mf[,ylab]) else wk <- table(rep(object$mf[,ylab],object$cnt)) if (is.null(object$cnt)) wk <- table(object$mf[,ylab]) else { wk <- NULL for (lvl in levels(object$mf[,ylab])) wk <- c(wk,sum(object$cnt[object$mf[,ylab]==lvl])) } wk <- wk/sum(wk) nlvl <- length(wk) if (is.null(object$b)) { for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[,id] <- cfit[,id]*wk[j] } } else { id <- NULL for (j in 1:nlvl) { id <- c(id,(1:nmesh)[qd.pt[,ylab]==lvl[j]][1]) } offset <- apply(qd.z[id,,id.wk+(1:nz*(nlvl-1)),drop=FALSE],c(1,2), function(x,y)sum(x*y),object$b[id.wk+(1:nz*(nlvl-1))]) id.wk <- id.wk + nz*(nlvl-1) eta <- log(wk[-nlvl]/wk[nlvl]) repeat { p <- exp(c(eta,0)+offset) p <- t(p)/apply(p,2,sum) u <- (apply(p*xx.wt,2,sum)-wk)[-nlvl] w <- 0 for (i in 1:nx) { w <- w + xx.wt[i]*(diag(p[i,])-outer(p[i,],p[i,]))[-nlvl,-nlvl] } eta.new <- eta-solve(w,u) if (max(abs(eta-eta.new)/(1+abs(eta)))<1e-7) break eta <- eta.new } p <- exp(c(eta,0)+offset) p <- t(p)/apply(p,2,sum) for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[,id] <- cfit[,id]*p[,j] } } } ## return kl0 <- 0 for (i in 1:nx) { wk <- sum(log(fit0[i,]/cfit[i,])*fit0[i,]) kl0 <- kl0 + xx.wt[i]*wk } list(ratio=kl/kl0,kl=kl) } gss/R/family.proj.R0000644000176200001440000002473012440620716013634 0ustar liggesusers##%%%%%%%%%% Binomial Family %%%%%%%%%% y0.binomial <- function(y,eta0,wt) { if (is.matrix(y)) wt <- wt * (y[,1]+y[,2]) odds <- exp(eta0) p <- odds/(1+odds) q <- 1/(1+odds) list(p=p,q=q,eta=eta0,wt=wt) } proj0.binomial <- function(y0,eta,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) odds <- exp(eta) p <- odds/(1+odds) u <- p - y0$p w <- p/(1+odds) ywk <- eta-u/w-offset wt <- w*y0$wt kl <- sum(y0$wt*(y0$p*(y0$eta-eta)+log(y0$q*(1+odds))))/sum(y0$wt) list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.binomial <- function(eta0,eta1,wt) { odds0 <- exp(eta0) odds1 <- exp(eta1) p0 <- odds0/(1+odds0) sum(wt*(p0*(eta0-eta1)+log((1+odds1)/(1+odds0))))/sum(wt) } cfit.binomial <- function(y,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } p <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(qlogis(p),length(y)) else { eta <- qlogis(p)-mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } eta <- eta + offset } eta } ##%%%%%%%%%% Poisson Family %%%%%%%%%% y0.poisson <- function(eta0) { lambda <- exp(eta0) list(lambda=lambda,eta=eta0) } proj0.poisson <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) lambda <- exp(eta) u <- lambda - y0$lambda w <- lambda ywk <- eta-u/w-offset kl <- sum(wt*(y0$lambda*(y0$eta-eta)-y0$lambda+lambda))/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.poisson <- function(eta0,eta1,wt) { lambda0 <- exp(eta0) lambda1 <- exp(eta1) sum(wt*(lambda0*(eta0-eta1)-lambda0+lambda1))/sum(wt) } cfit.poisson <- function(y,wt,offset) { lambda <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(lambda),length(y)) else { eta0 <- log(sum(wt*y)/sum(wt*exp(offset))) eta <- eta0 + offset } eta } ##%%%%%%%%%% Gamma Family %%%%%%%%%% y0.Gamma <- function(eta0) { mu <- exp(eta0) list(mu=mu) } proj0.Gamma <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) mu <- exp(eta) u <- 1-y0$mu/mu ywk <- eta-u-offset kl <- sum(wt*(y0$mu*(-1/y0$mu+1/mu)+log(mu/y0$mu)))/sum(wt) list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.Gamma <- function(eta0,eta1,wt) { mu0 <- exp(eta0) mu1 <- exp(eta1) sum(wt*(mu0*(-1/mu0+1/mu1)+log(mu1/mu0)))/sum(wt) } cfit.Gamma <- function(y,wt,offset) { mu <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(mu),length(y)) else { eta0 <- log(sum(wt*y*exp(-offset))/sum(wt)) eta <- eta0 + offset } eta } ##%%%%%%%%%% Inverse Gaussian Family %%%%%%%%%% y0.inverse.gaussian <- function(eta0) { mu <- exp(eta0) list(mu=mu) } proj0.inverse.gaussian <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) mu <- exp(eta) u <- (1-y0$mu/mu)/mu w <- 1/mu ywk <- eta-u/w-offset kl <- sum(wt*y0$mu/2*(1/mu-1/y0$mu)^2)/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.inverse.gaussian <- function(eta0,eta1,wt) { mu0 <- exp(eta0) mu1 <- exp(eta1) sum(wt*mu0/2*(-1/mu0+1/mu1)^2)/sum(wt) } cfit.inverse.gaussian <- function(y,wt,offset) { mu <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(mu),length(y)) else { eta0 <- log(sum(wt*y*exp(-2*offset))/sum(wt*exp(-offset))) eta <- eta0 + offset } eta } ##%%%%%%%%%% Negative Binomial Family %%%%%%%%%% y0.nbinomial <- function(y,eta0,nu) { if (!is.vector(y)) { nu <- y[,2] y <- y[,1] } mu <- nu*exp(-eta0) list(y=y,nu=nu,mu=mu,eta=eta0) } proj0.nbinomial <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) u <- y0$mu*p-y0$nu*q w <- (y0$mu+y0$nu)*p*q ywk <- eta-u/w-offset kl <- sum(wt*((y0$nu+y0$mu)*log((1+exp(eta))/(1+exp(y0$eta))) +y0$nu*(y0$eta-eta)))/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.nbinomial <- function(eta0,eta1,wt,nu) { mu0 <- nu*exp(-eta0) sum(wt*((nu+mu0)*log((1+exp(eta1))/(1+exp(eta0)))+nu*(eta0-eta1)))/sum(wt) } cfit.nbinomial <- function(y,wt,offset,nu) { if (!is.vector(y)) { nu <- y[,2] y <- y[,1] } p <- sum(wt*nu)/sum(wt*(y+nu)) if (is.null(offset)) eta <- rep(qlogis(p),length(y)) else { eta <- qlogis(p)-mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) q <- 1/(1+odds) u <- y*p-nu*q w <- (y+nu)*p*q eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } eta <- eta + offset } eta } ##%%%%%%%%%% Weibull Family %%%%%%%%%% y0.weibull <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) lam <- exp(-nu*eta0) list(lam=lam,eta=eta0,int=(xx^nu-zz^nu)) } proj0.weibull <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) u <- nu*(y0$lam-exp(-nu*eta)) w <- nu*nu*exp(-nu*eta) ywk <- eta-u/w-offset kl <- sum(wt*y0$int*(y0$lam*nu*(eta-y0$eta)+exp(-nu*eta)-y0$lam))/sum(wt) u <- y0$int*u w <- y0$int*w wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.weibull <- function(eta0,eta1,wt,nu,int) { lam0 <- exp(-nu*eta0) lam1 <- exp(-nu*eta1) sum(wt*int*(lam0*nu*(eta1-eta0)+lam1-lam0))/sum(wt) } cfit.weibull <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) eta <- log(sum(wt*(xx^nu-zz^nu)*exp(-nu*offset))/sum(wt*delta))/nu eta + offset } ##%%%%%%%%%% Lognorm Family %%%%%%%%%% y0.lognorm <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) quad <- gauss.quad(50,c(0,1)) list(eta=eta0,xx=xx,zz=zz,q.pt=quad$pt,q.wt=quad$wt) } proj0.lognorm <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) u <- NULL kl <- 0 for (i in 1:length(eta)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) z0 <- nu*(log(q.pt)-y0$eta[i]) z1 <- nu*(log(q.pt)-eta[i]) lam0 <- ifelse(z0<7,dnorm(z0)/(1-pnorm(z0)),z0+1/z0) lam1 <- ifelse(z1<7,dnorm(z1)/(1-pnorm(z1)),z1+1/z1) u <- c(u,nu*nu*sum(q.wt*(lam0-lam1)*(lam1-z1)/q.pt)) kl <- kl + nu*sum(q.wt*(lam0*log(lam0/lam1)+lam1-lam0)/q.pt) } xx <- nu*(log(y0$xx)-eta) zz <- nu*(log(y0$zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,kl=kl/length(eta),u=wt*u) } kl.lognorm <- function(eta0,eta1,wt,nu,y0) { kl <- 0 for (i in 1:length(eta0)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) z0 <- nu*(log(q.pt)-eta0[i]) z1 <- nu*(log(q.pt)-eta1[i]) lam0 <- ifelse(z0<7,dnorm(z0)/(1-pnorm(z0)),z0+1/z0) lam1 <- ifelse(z1<7,dnorm(z1)/(1-pnorm(z1)),z1+1/z1) kl <- kl + nu*sum(q.wt*(lam0*log(lam0/lam1)+lam1-lam0)/q.pt) } kl/length(eta0) } cfit.lognorm <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset } ##%%%%%%%%%% Loglogis Family %%%%%%%%%% y0.loglogis <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) quad <- gauss.quad(50,c(0,1)) list(eta=eta0,xx=xx,zz=zz,q.pt=quad$pt,q.wt=quad$wt) } proj0.loglogis <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) e0 <- exp(-nu*y0$eta) e1 <- exp(-nu*eta) kl <- sum(log((1+y0$xx^nu*e1)*(1+y0$zz^nu*e0)/(1+y0$zz^nu*e1)/(1+y0$xx^nu*e0)) +nu*(eta-y0$eta)*log((1+y0$xx^nu*e0)/(1+y0$zz^nu*e0))) xx <- 1/(1+y0$xx^nu*e1) zz <- 1/(1+y0$zz^nu*e1) u <- -nu*(zz-xx) w <- nu^2/2*(zz^2-xx^2) for (i in 1:length(eta)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) u[i] <- u[i]+nu^2*sum(q.wt*q.pt^(nu-1)*e0[i] /(1+q.pt^nu*e0[i])/(1+q.pt^nu*e1[i])) kl <- kl + nu*sum(q.wt*q.pt^(nu-1)*e0[i]/(1+q.pt^nu*e0[i]) *log((1+q.pt^nu*e1[i])/(1+q.pt^nu*e0[i]))) } w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,kl=kl/length(eta),u=wt*u) } kl.loglogis <- function(eta0,eta1,wt,nu,y0) { e0 <- exp(-nu*eta0) e1 <- exp(-nu*eta1) kl <- sum(log((1+y0$xx^nu*e1)*(1+y0$zz^nu*e0)/(1+y0$zz^nu*e1)/(1+y0$xx^nu*e0)) +nu*(eta1-eta0)*log((1+y0$xx^nu*e0)/(1+y0$zz^nu*e0))) for (i in 1:length(eta0)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) kl <- kl + nu*sum(q.wt*q.pt^(nu-1)*e0[i]/(1+q.pt^nu*e0[i]) *log((1+q.pt^nu*e1[i])/(1+q.pt^nu*e0[i]))) } kl/length(eta0) } cfit.loglogis <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset } gss/R/smolyak.R0000644000176200001440000000121412355360640013053 0ustar liggesuserssmolyak.quad <- ## Generate delayed Smolyak cubature function(d, k) { size <- .C("size_smolyak", as.integer(d), as.integer(d+k), size=integer(1), PACKAGE="gss")$size z <- .C("quad_smolyak", as.integer(d), as.integer(d+k), pt=double(d*size), wt=as.double(1:size), PACKAGE="gss") list(pt=t(matrix(z$pt,d,size)),wt=z$wt) } smolyak.size <- ## Get the size of delayed Smolyak cubature function(d, k) { .C("size_smolyak", as.integer(d), as.integer(d+k), size=integer(1), PACKAGE="gss")$size } gss/R/project.sscden1.R0000644000176200001440000001716512355360640014415 0ustar liggesusers## Calculate square error projection from sscden objects project.sscden1 <- function(object,include,...) { include <- unique(include) term <- object$terms mf <- object$mf nobs <- dim(mf)[1] xnames <- object$xnames ynames <- object$ynames xx.wt <- object$xx.wt nx <- length(xx.wt) xx <- mf[!object$x.dup.ind,xnames,drop=FALSE] qd.pt <- object$rho$env$qd.pt qd.wt <- object$rho$env$qd.wt rho.d <- t(object$rho$fun(xx,qd.pt,object$rho$env,outer=TRUE)) rho.wt <- rho.d*qd.wt rho.d <- t(t(log(rho.d))-apply(log(rho.d)*rho.wt,2,sum)) nmesh <- length(qd.wt) ns <- length(object$id.s) nr <- length(object$id.r) nbasis <- length(object$id.basis) s.rho <- ss <- 0 r.rho <- matrix(0,nbasis,nr) sr <- array(0,c(ns,nbasis,nr)) rr <- array(0,c(nbasis,nbasis,nr,nr)) rho2 <- sum(xx.wt*apply(rho.d^2*rho.wt,2,sum)) for (k in 1:nx) { id.x <- (1:nobs)[!object$x.dup.ind][k] qd.s <- NULL qd.r <- list(NULL) iq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy.basis <- mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- mf[rep(id.x,nmesh),x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.s <- cbind(qd.s,qd.s.wk) } else { if (length(y.list)>0) { qd.xy[,x.list] <- xx qd.s <- cbind(qd.s,phi$fun(qd.xy,i,phi$env)) } } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,TRUE) iq <- iq+1 qd.r[[iq]] <- qd.r.wk } else { if (length(y.list)>0) { qd.xy[,x.list] <- xx iq <- iq+1 qd.r[[iq]] <- rk$fun(qd.xy,xy.basis,i,rk$env,TRUE) } } } } } if (ns) { qd.s <- sweep(qd.s,2,apply(qd.s*rho.wt[,k],2,sum)) s.rho <- s.rho + xx.wt[k]*apply(qd.s*rho.d[,k]*rho.wt[,k],2,sum) ss <- ss + xx.wt[k]*t(rho.wt[,k]*qd.s)%*%qd.s } for (i in 1:iq) { qd.r[[i]] <- sweep(qd.r[[i]],2,apply(qd.r[[i]]*rho.wt[,k],2,sum)) r.rho[,i] <- r.rho[,i] + xx.wt[k]*apply(qd.r[[i]]*rho.d[,k]*rho.wt[,k],2,sum) if (ns) sr[,,i] <- sr[,,i] + xx.wt[k]*t(rho.wt[,k]*qd.s)%*%qd.r[[i]] for (j in 1:i) { rr.wk <- xx.wt[k]*t(rho.wt[,k]*qd.r[[i]])%*%qd.r[[j]] rr[,,i,j] <- rr[,,i,j] + rr.wk if (i-j) rr[,,j,i] <- rr[,,j,i] + t(rr.wk) } } } ## evaluate full model if (ns) d <- object$d[object$id.s] c <- object$c theta <- object$theta[object$id.r] nq <- length(theta) if (ns) s.eta <- ss%*%d r.eta <- tmp <- NULL r.rho.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) if (ns) { s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d sr.wk <- sr.wk + 10^theta[i]*sr[,,i] } else r.eta.wk <- 0 r.rho.wk <- r.rho.wk + 10^theta[i]*r.rho[,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } rho.eta <- sum(r.rho.wk*c) if (ns) rho.eta <- rho.eta + sum(r.rho.wk*c) eta2 <- sum(c*(rr.wk%*%c)) if (ns) eta2 <- eta2 + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 + rho2 + 2*rho.eta ## extract terms in subspace id.s <- id.r <- NULL for (label in include) { id.s <- c(id.s,object$id.s.list[[label]]) id.r <- c(id.r,object$id.r.list[[label]]) } if (is.null(id.s)&is.null(id.r)) stop("gss error in project.sscden1: include some terms") if (!all(id.s%in%object$id.s)|!all(id.r%in%object$id.r)) stop("gss error in project.sscden1: included terms are not in the model") ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq0 theta.wk[fix] <- theta[fix] if (nq0-1) theta.wk[-fix] <- theta1 ## id.s0 <- (1:length(object$id.s))[object$id.s%in%id.s] id.r0 <- (1:length(object$id.r))[object$id.r%in%id.r] if (length(id.s0)) ss.wk <- ss[id.s0,id.s0,drop=FALSE] if (length(id.r0)) { r.eta.wk <- rr.wk <- 0 sr.wk <- matrix(0,length(id.s),nbasis) for (i in 1:length(id.r0)) { r.eta.wk <- r.eta.wk + 10^theta.wk[i]*r.eta[,id.r0[i]] if (length(id.s0)) sr.wk <- sr.wk + 10^theta.wk[i]*sr[id.s0,,id.r0[i]] for (j in 1:length(id.r0)) { rr.wk <- rr.wk + 10^(theta.wk[i]+theta.wk[j])*rr[,,id.r0[i],id.r0[j]] } } if (length(id.s0)) { v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s0],r.eta.wk) } else { v <- rbind(sr.wk,rr.wk) mu <- r.eta.wk } } else { v <- ss.wk mu <- s.eta[id.s0] } nn <- length(mu) z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization fix <- rev(order(tmp[id.r]))[1] theta <- object$theta[id.r] ## projection nq0 <- length(id.r) if (nq0>1) { if (object$skip.iter) se <- rkl(theta[-fix]) else { if (nq0-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } se <- rkl(zz$est) } } else se <- rkl() list(ratio=se/mse,se=se) } gss/R/gssanova.R0000644000176200001440000005134412355360640013226 0ustar liggesusers## Fit gssanova model gssanova <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, alpha=NULL,nu=NULL, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { if (!(family%in%c("binomial","poisson","Gamma","inverse.gaussian","nbinomial", "weibull","lognorm","loglogis"))) stop("gss error in gssanova: family not implemented") if (is.null(alpha)) { alpha <- 1.4 if (family%in%c("binomial","nbinomial","inverse.gaussian")) alpha <- 1 } ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in gssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in gssanova: use glm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return jk <- cv(zz$est) if (nu[[2]]) { nu.wk <- exp(zz$est[2]) zz$est <- zz$est[-2] } else nu.wk <- NULL if (is.null(random)) q.wk <- 10^theta*q else { q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^theta*q q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-zz$est[1])*random$sigma$fun(zz$est[-1],random$sigma$env) } se.aux <- regaux(sqrt(fit$w)*s,10^theta*sqrt(fit$w)*r,q.wk,zz$est[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(theta=theta,ran.scal=ran.scal,c=c,d=d,b=b,nlambda=zz$est[1], zeta=zz$est[-1],nu=nu.wk),fit[-1],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter Non-Gaussian REGression mspngreg <- function(family,s,r,id.basis,y,wt,offset,alpha,nu,random,skip.iter) { nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 if (!is.null(random)) nz <-ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { if (nu[[2]]) { the.wk <- theta[-(nq+1)] nu.wk <- list(exp(theta[nq+1]),FALSE) } else { the.wk <- theta nu.wk <- nu } ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } qq.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk <- 10^nlambda*qq.wk else { r.wk0 <- cbind(r.wk0,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^nlambda*qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(the.wk[-(1:nq)],random$sigma$env) } alpha.wk <- max(0,the.wk[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) z <- ngreg(dc,family,cbind(s,r.wk0),q.wk,y,wt,offset,nu.wk,alpha.wk) assign("dc",z$dc,inherits=TRUE) assign("fit",z[c(1:3,5:10)],inherits=TRUE) z$score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment z <- sspngreg(family,s,r.wk,r.wk[id.basis,],y,wt,offset,alpha,nu,random) if (nu[[2]]) nu[[1]] <- z$nu theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } log.la0 <- log10(sum(r.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspngreg(family,s,r.wk,r.wk[id.basis,],y,wt,offset,alpha,nu,random) if (nu[[2]]) nu[[1]] <- z$nu nlambda <- z$nlambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta if (!is.null(random)) ran.scal <- z$ran.scal ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search dc <- rep(0,nn) fit <- NULL theta.old <- theta if (nu[[2]]) theta <- c(theta, log(nu[[1]])) if (!is.null(random)) theta <- c(theta,z$zeta) counter <- 0 r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in gssanova: iteration for model selection fails to converge") break } } ## return jk <- cv(zz$est) if (nu[[2]]) { nu.wk <- exp(zz$est[nq+1]) zz$est <- zz$est[-(nq+1)] } else nu.wk <- NULL r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^zz$est[i]*r[,,i] } qq.wk <- r.wk[id.basis,] if (is.null(random)) q.wk <- qq.wk else { r.wk <- cbind(r.wk,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-nlambda)*random$sigma$fun(zz$est[-(1:nq)],random$sigma$env) } se.aux <- regaux(sqrt(fit$w)*s,sqrt(fit$w)*r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(theta=zz$est[1:nq],c=c,d=d,b=b,nlambda=nlambda,zeta=zz$est[-(1:nq)],nu=nu.wk), fit[-1],list(se.aux=se.aux)) } ## Non-Gaussian regression with fixed smoothing parameters ngreg <- function(dc,family,sr,q,y,wt,offset,nu,alpha) { nobs <- nrow(sr) nn <- ncol(sr) nxi <- nrow(q) nnull <- nn - nxi ## initialization cc <- dc[nnull+(1:nxi)] eta <- sr%*%dc if (!is.null(offset)) eta <- eta + offset if ((family=="nbinomial")&is.vector(y)) y <- cbind(y,nu[[1]]) dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) + t(cc)%*%q%*%cc ## Newton iteration dc.new <- eta.new <- NULL dev.line <- function(x) { assign("dc.new",dc+x*dc.diff,inherits=TRUE) cc <- dc.new[nnull+(1:nxi)] eta.wk <- as.vector(sr%*%dc.new) if (!is.null(offset)) eta.wk <- eta.wk + offset assign("eta.new",eta.wk,inherits=TRUE) dev.wk <- switch(family, binomial=dev.resid.binomial(y,eta.new,wt), nbinomial=dev.resid.nbinomial(y,eta.new,wt), poisson=dev.resid.poisson(y,eta.new,wt), Gamma=dev.resid.Gamma(y,eta.new,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta.new,wt), weibull=dev.resid.weibull(y,eta.new,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta.new,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta.new,wt,nu[[1]])) sum(dev.wk) + t(cc)%*%q%*%cc } iter <- 0 flag <- 0 flag2 <- 0 repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) ## weighted least squares fit mumax <- 2*max(abs(t(sr)%*%dat$u+c(rep(0,nnull),q%*%dc[nnull+(1:nxi)]))) w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk srwk <- w*sr if (!is.finite(sum(w,ywk,srwk))) { if (flag) stop("gss error in gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) iter <- 0 flag <- 1 next } z <- .Fortran("reg", as.double(srwk), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(ywk), as.integer(4), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), double(nn*nn), double(nn), as.integer(c(rep(1,nnull),rep(0,nxi))), double(max(nobs,nn)), integer(1), integer(1), PACKAGE="gss")["dc"] dc.diff <- z$dc-dc repeat { dev.new <- dev.line(1) if (!is.finite(dev.new)) { dc.diff <- dc.diff/2 next } if (!flag2) { if (dev.new-dev<1e-7*(1+abs(dev))) break } zz <- nlm0(dev.line,c(0,1),1e-3) dev.new <- dev.line(zz$est) break } disc0 <- max((mumax/(1+eta))^2,abs(eta.new-eta)/(1+eta)) disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) if (!is.finite(disc)) { if (flag) stop("gss error in gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) iter <- 0 flag <- 1 next } dc <- dc.new eta <- eta.new dev <- dev.new if (min(disc0,disc)<1e-7) break if (iter<=30) next if (!flag2) { flag2 <- 1 iter <- 0 next } warning("gss warning in gssanova: Newton iteration fails to converge") break } ## calculate cv dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) ## weighted least squares fit w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk srwk <- w*sr z <- .Fortran("reg", as.double(srwk), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(ywk), as.integer(5), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxi))), hat=double(max(nobs+1,nn)), rkv=integer(1), integer(1), PACKAGE="gss")[c("dc","chol","jpvt","hat","rkv")] cv <- switch(family, binomial=cv.binomial(y,eta,wt,z$hat[1:nobs],alpha), poisson=cv.poisson(y,eta,wt,z$hat[1:nobs],alpha,sr,q), Gamma=cv.Gamma(y,eta,wt,z$hat[1:nobs],z$hat[nobs+1],alpha), inverse.gaussian=cv.inverse.gaussian(y,eta,wt,z$hat[1:nobs],z$hat[nobs+1],alpha), nbinomial=cv.nbinomial(y,eta,wt,z$hat[1:nobs],alpha), weibull=cv.weibull(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha), lognorm=cv.lognorm(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha), loglogis=cv.loglogis(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha)) c(z,cv,list(eta=eta)) } gss/R/family.R0000644000176200001440000001731612440617772012675 0ustar liggesusers##%%%%%%%%%% Binomial Family %%%%%%%%%% ## Make pseudo data for logistic regression mkdata.binomial <- function(y,eta,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) if (dim(y)[2]==1) { if ((max(y)>1)|(min(y)<0)) stop("gss error: binomial responses should be between 0 and 1") } else { if (min(y)<0) stop("gss error: paired binomial response should be nonnegative") wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } odds <- exp(eta) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for logistic regression dev.resid.binomial <- function(y,eta,wt) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } odds <- exp(eta) as.vector(2*wt*(y*log(ifelse(y==0,1,y*(1+odds)/odds)) +(1-y)*log(ifelse(y==1,1,(1-y)*(1+odds))))) } ## Calculate null deviance for logistic regression dev.null.binomial <- function(y,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } p <- sum(wt*y)/sum(wt) odds <- p/(1-p) if (!is.null(offset)) { eta <- log(odds) - mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y*log(ifelse(y==0,1,y*(1+odds)/odds)) +(1-y)*log(ifelse(y==1,1,(1-y)*(1+odds))))) } ##%%%%%%%%%% Poisson Family %%%%%%%%%% ## Make pseudo data for Poisson regression mkdata.poisson <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<0) stop("gss error: Poisson response should be nonnegative") lambda <- exp(eta) u <- lambda - y w <- lambda ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for Poisson regression dev.resid.poisson <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) lambda <- exp(eta) as.vector(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda))) } ## Calculate null deviance for Poisson regression dev.null.poisson <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) lambda <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(lambda) - mean(offset) repeat { lambda <- exp(eta+offset) u <- lambda - y w <- lambda eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda))) } ##%%%%%%%%%% Gamma Family %%%%%%%%%% ## Make pseudo data for Gamma regression mkdata.Gamma <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<=0) stop("gss error: gamma responses should be positive") mu <- exp(eta) u <- 1-y/mu ywk <- eta-u-offset list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for Gamma regression dev.resid.Gamma <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- exp(eta) as.vector(2*wt*(-log(y/mu)+(y-mu)/mu)) } ## Calculate null deviance for Gamma regression dev.null.Gamma <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(mu)-mean(offset) repeat { mu <- exp(eta+offset) u <- 1-y/mu eta.new <- eta-sum(wt*u)/sum(wt) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(-log(y/mu)+(y-mu)/mu)) } ##%%%%%%%%%% Inverse Gaussian Family %%%%%%%%%% ## Make pseudo data for IG regression mkdata.inverse.gaussian <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<=0) stop("gss error: inverse gaussian responses should be positive") mu <- exp(eta) u <- (1-y/mu)/mu w <- 1/mu ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for IG regression dev.resid.inverse.gaussian <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- exp(eta) as.vector(wt*((y-mu)^2/(y*mu^2))) } ## Calculate null deviance for IG regression dev.null.inverse.gaussian <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(mu)-mean(offset) repeat { mu <- exp(eta+offset) u <- (1-y/mu)/mu w <- 1/mu eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(wt*((y-mu)^2/(y*mu^2))) } ##%%%%%%%%%% Negative Binomial Family %%%%%%%%%% ## Make pseudo data for NB regression mkdata.nbinomial <- function(y,eta,wt,offset,nu) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) if (dim(y)[2]==2) { if (min(y[,1])<0) stop("gss error: negative binomial response should be nonnegative") if (min(y[,2])<=0) stop("gss error: negative binomial size should be positive") odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) u <- y[,1]*p-y[,2]*q w <- y[,2]*q ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } else { if (min(y)<0) stop("gss error: negative binomial response should be nonnegative") odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) if (is.null(nu)) log.nu <- log(mean(y*odds)) else log.nu <- log(nu) repeat { nu <- exp(log.nu) ua <- sum(digamma(y+nu)-digamma(nu)+log(p))*nu wa <- sum(trigamma(y+nu)-trigamma(nu))*nu*nu+ua log.nu.new <- log.nu - ua/wa if (abs(log.nu-log.nu.new)/(1+abs(log.nu))<1e-7) break log.nu <- log.nu.new } u <- y*p-nu*q w <- nu*q ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } } ## Calculate deviance residuals for NB regression dev.resid.nbinomial <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) as.vector(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/q)) +y[,2]*log(y[,2]/(y[,1]+y[,2])/p))) } ## Calculate null deviance for NB regression dev.null.nbinomial <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) p <- sum(wt*y[,2])/sum(wt*y) if (!is.null(offset)) { eta <- log(p/(1-p)) - mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) q <- 1/(1+odds) u <- y[,1]*p-y[,2]*q w <- y[,2]*q eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/q)) +y[,2]*log(y[,2]/(y[,1]+y[,2])/p))) } gss/R/mkfun.factor.R0000644000176200001440000000410412355360640013772 0ustar liggesusers## Make RK for nominal shrinkage mkrk.nominal <- function(levels) { k <- length(levels) if (k<2) stop("gss error: factor should have at least two levels") code <- 1:k names(code) <- as.character(levels) ## Create the environment env <- list(code=code,table=diag(k)-1/k) ## Create the rk function fun <- function(x, y, env, outer.prod = FALSE) { if (!(is.factor(x)&is.factor(y))) { stop("gss error in rk: inputs are of wrong types") } x <- as.numeric(env$code[as.character(x)]) y <- as.numeric(env$code[as.character(y)]) if (any(is.na(c(x,y)))) { stop("gss error in rk: unknown factor levels") } if (outer.prod) env$table[x, y] else env$table[cbind(x,y)] } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for ordinal shrinkage mkrk.ordinal <- function(levels) { k <- length(levels) if (k<2) stop("gss error: factor should have at least two levels") code <- 1:k names(code) <- as.character(levels) ## penalty matrix if (k==2) { B <- diag(.25,2) B[1,2] <- B[2,1] <- -.25 } else { B <- diag(2,k) B[1,1] <- B[k,k] <- 1 diag(B[-1,-k]) <- diag(B[-k,-1]) <- -1 ## Moore-Penrose inverse B <- eigen(B) B <- B$vec[,-k] %*% diag(1/B$val[-k]) %*% t(B$vec[,-k]) tol <- sqrt(.Machine$double.eps) B <- ifelse(abs(B)10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { nn <- nrow(qd.s) z <- .Fortran("drkl", cd=as.double(d), as.integer(nn), as.double(qd.s), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt)), mesh=as.double(mesh0), as.double(.Machine$double.eps), as.double(1e-6), as.integer(30), double(nn), double(2*bias$nt*(nqd+1)+nn*(2*nn+4)), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sscox: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sscox: Newton iteration fails to converge") mesh1 <- z$mesh kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) } kl0 <- sum(bias$wt*(apply(qd.wt*log(mesh0)*mesh0,2,sum)+ log(apply(qd.wt,2,sum)))) wt.wk <- t(t(qd.wt)/apply(qd.wt*mesh1,2,sum)) kl1 <- sum(bias$wt*(apply(wt.wk*log(mesh1)*mesh1,2,sum)+ log(apply(wt.wk,2,sum)))) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) obj } gss/R/predict.ssanova0.R0000644000176200001440000001027512355360640014566 0ustar liggesusers## Calculate prediction and Bayesian SE from ssanova0 objects predict.ssanova0 <- function(object,newdata,se.fit=FALSE, include=c(object$terms$labels,object$lab.p),...) { nnew <- dim(newdata)[1] nobs <- length(object$c) nnull <- length(object$d) labels.p <- object$lab.p ## Extract included terms term <- object$terms philist <- rklist <- NULL s <- q <- NULL nq <- 0 for (label in include) { if (label=="1") { philist <- c(philist,term[[label]]$iphi) s <- cbind(s,rep(1,len=nnew)) next } if (label%in%labels.p) next if (label=="offset") next xnew <- newdata[,term[[label]]$vlist] x <- object$mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { iphi <- term[[label]]$iphi phi <- term[[label]]$phi for (i in 1:nphi) { philist <- c(philist,iphi+(i-1)) s <- cbind(s,phi$fun(xnew,nu=i,env=phi$env)) } } if (nrk) { irk <- term[[label]]$irk rk <- term[[label]]$rk for (i in 1:nrk) { rklist <- c(rklist,irk+(i-1)) nq <- nq+1 q <- array(c(q,rk$fun(xnew,x,nu=i,env=rk$env,out=TRUE)),c(nnew,nobs,nq)) } } } if (!is.null(object$partial)) { vars.p <- as.character(attr(object$partial$mt,"variables"))[-1] facs.p <- attr(object$partial$mt,"factors") vlist <- vars.p[as.logical(apply(facs.p,1,sum))] for (lab in labels.p) { if (lab%in%include) { vlist.wk <- vars.p[as.logical(facs.p[,lab])] vlist <- vlist[!(vlist%in%vlist.wk)] } } if (length(vlist)) { for (lab in vlist) newdata[[lab]] <- 0 } matx.p <- model.matrix(object$partial$mt,newdata)[,-1,drop=FALSE] matx.p <- sweep(matx.p,2,object$partial$center) matx.p <- sweep(matx.p,2,object$partial$scale,"/") nu <- nnull-dim(matx.p)[2] for (label in labels.p) { nu <- nu+1 if (label%in%include) { philist <- c(philist,nu) s <- cbind(s,matx.p[,label]) } } } qq <- matrix(0,nnew,nobs) nq <- 0 for (i in rklist) { nq <- nq + 1 qq <- qq + 10^object$theta[i]*q[,,nq] } if (!is.null(object$w)) w <- object$w else w <- model.weights(object$mf) if (!is.null(w)) qq <- t(sqrt(w)*t(qq)) ## Compute posterior mean nphi <- length(philist) pmean <- as.vector(qq%*%object$c) if (nphi) pmean <- pmean + as.vector(s%*%object$d[philist]) if (any(include=="offset")) { if (is.null(model.offset(object$mf))) stop("gss error: no offset in the fit") offset <- newdata$offset if (is.null(offset)) offset <- newdata$"(offset)" if (is.null(offset)) stop("gss error: missing offset") pmean <- pmean + offset } if (se.fit) { b <- object$varht/10^object$nlambda ## Get cr, dr, and sms crdr <- getcrdr(object,t(qq)) cr <- crdr$cr dr <- crdr$dr[philist,,drop=FALSE] sms <- getsms(object)[philist,philist] ## Compute posterior variance r <- 0 for (label in include) { if (label=="1") next if (label%in%labels.p) next xnew <- newdata[,term[[label]]$vlist] nrk <- term[[label]]$nrk if (nrk) { irk <- term[[label]]$irk rk <- term[[label]]$rk for (i in 1:nrk) { ind <- irk+(i-1) r <- r + 10^object$theta[ind]*rk$fun(xnew,xnew,nu=i,env=rk$env) } } } fn2 <- function(x,n) x[1:n]%*%x[n+(1:n)] pvar <- r - apply(rbind(t(qq),cr),2,fn2,nobs) if (nphi) { fn1 <- function(x,sms) t(x)%*%sms%*%x pvar <- pvar + apply(s,1,fn1,sms) pvar <- pvar - 2*apply(rbind(t(s),dr),2,fn2,nphi) } pse <- as.numeric(sqrt(b*pvar)) list(fit=pmean,se.fit=pse) } else pmean } gss/R/ssden.R0000644000176200001440000003500412355360640012514 0ustar liggesusers## Fit density model ssden <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit, id.basis=NULL,nbasis=NULL,seed=NULL, domain=as.list(NULL),quad=NULL, qdsz.depth=NULL,bias=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$domain <- mf$quad <- mf$qdsz.depth <- mf$bias <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssden: id.basis out of range") nbasis <- length(id.basis) } ## Set domain and/or generate quadrature if (is.null(quad)) { ## Set domain and type fac.list <- NULL for (xlab in names(mf)) { x <- mf[[xlab]] if (is.factor(x)) { fac.list <- c(fac.list,xlab) domain[[xlab]] <- NULL } else { if (!is.vector(x)) stop("gss error in ssden: no default quadrature") if (is.null(domain[[xlab]])) { mn <- min(x) mx <- max(x) domain[[xlab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else domain[[xlab]] <- c(min(domain[[xlab]]),max(domain[[xlab]])) if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",domain[[xlab]]) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],domain[[xlab]]) } } } ## Generate numerical quadrature domain <- data.frame(domain) mn <- domain[1,] mx <- domain[2,] dm <- ncol(domain) if (dm==1) { ## Gauss-Legendre or uniform quadrature xlab <- names(domain) if (type[[xlab]][[1]]%in%c("per","cubic.per","linear.per")) { quad <- list(pt=mn+(1:200)/200*(mx-mn), wt=rep((mx-mn)/200,200)) } else quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain) } else { ## Smolyak cubature if (is.null(qdsz.depth)) qdsz.depth <- switch(min(dm,6)-1,18,14,12,11,10) quad <- smolyak.quad(dm,qdsz.depth) for (i in 1:ncol(domain)) { xlab <- colnames(domain)[i] form <- as.formula(paste("~",xlab)) jk <- ssden(form,data=mf,domain=domain[i],alpha=2, id.basis=id.basis,weights=cnt) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain) } ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } quad <- list(pt=quad$pt,wt=quad$wt) } else { for (xlab in names(mf)) { x <- mf[[xlab]] if (is.vector(x)&!is.factor(x)) { if (is.null(range <- domain[[xlab]])) { mn <- min(x) mx <- max(x) range <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 range[1] <- min(c(range[1],quad$pt[[xlab]])) range[2] <- max(c(range[2],quad$pt[[xlab]])) } if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",range) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],range) else { mn0 <- min(type[[xlab]][[2]]) mx0 <- max(type[[xlab]][[2]]) if ((mn0>mn)|(mx0alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } ## initialization mu.r <- apply(qd.wt*t(qd.r),2,sum)/sum(qd.wt) v.r <- apply(qd.wt*t(qd.r^2),2,sum)/sum(qd.wt) if (nnull) { mu.s <- apply(qd.wt*t(qd.s),2,sum)/sum(qd.wt) v.s <- apply(qd.wt*t(qd.s^2),2,sum)/sum(qd.wt) } if (is.null(s)) theta <- 0 else theta <- log10(sum(v.s-mu.s^2)/nnull/sum(v.r-mu.r^2)*nxi) / 2 log.la0 <- log10(sum(v.r-mu.r^2)/sum(diag(q))) + theta ## lambda search cd <- rep(0,nxi+nnull) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } ## return jk1 <- cv(zz$est) int <- sum(qd.wt*exp(t(rbind(10^theta*qd.r,qd.s))%*%cd)) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=zz$est,theta=theta,c=c,d=d,int=int,cv=jk1) } ## Fit multiple smoothing parameter density mspdsty <- function(s,r,id.basis,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,bias,skip.iter) { nxi <- dim(r)[1] nobs <- dim(r)[2] nqd <- length(qd.wt) nq <- dim(r)[3] if (!is.null(s)) nnull <- dim(s)[1] else nnull <- 0 nxis <- nxi+nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(theta) { ind.wk <- theta!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- qd.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[,,i] } } q.wk <- r.wk0[,id.basis] fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nxis), as.double(10^lambda*q.wk), as.integer(nxi), as.double(rbind(r.wk0,s)), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(t(rbind(qd.r.wk0,qd.s))), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nxis), wk=double(2*((nqd+1)*bias$nt+nobs)+nxis*(2*nxis+4)+max(nxis,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssden: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssden: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[,id.basis,],3,function(x)sum(diag(x)))) r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } ## theta adjustment z <- sspdsty(s,r.wk,r.wk[,id.basis],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,bias) theta <- theta + z$theta r.wk <- qd.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[,id.basis,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } mu <- apply(qd.wt*t(qd.r.wk),2,sum)/sum(qd.wt) v <- apply(qd.wt*t(qd.r.wk^2),2,sum)/sum(qd.wt) log.la0 <- log10(sum(v-mu^2)/sum(diag(r.wk[,id.basis]))) log.th0 <- theta-log.la0 ## lambda search z <- sspdsty(s,r.wk,r.wk[,id.basis],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,bias) lambda <- z$lambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta cd <- c(z$c,z$d) int <- z$int ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search counter <- 0 r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } theta.old <- theta ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssden: CV iteration fails to converge") break } } ## return jk1 <- cv(zz$est) qd.r.wk <- 0 for (i in 1:nq) qd.r.wk <- qd.r.wk + 10^zz$est[i]*qd.r[,,i] int <- sum(qd.wt*exp(t(rbind(qd.r.wk,qd.s))%*%cd)) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=lambda,theta=zz$est,c=c,d=d,int=int,cv=jk1) } gss/R/predict.ssllrm.R0000644000176200001440000001343613266665520014361 0ustar liggesusers## Calculate prediction and Bayesian SE from ssllrm objects predict.ssllrm <- function (object,x,y=object$qd.pt,odds=NULL,se.odds=FALSE,...) { if (class(object)!="ssllrm") stop("gss error in predict.ssllrm: not a ssllrm object") if ("random"%in%colnames(x)) { zz <- x$random x$random <- NULL } else zz <- NULL if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in predict.ssllrm: mismatched x variable names") if (!all(sort(object$ynames)==sort(colnames(y)))) stop("gss error in predict.ssllrm: mismatched y variable names") mf <- object$mf term <- object$term qd.pt <- object$qd.pt qd.wt <- object$qd.wt nmesh <- dim(qd.pt)[1] y.id <- NULL for (i in 1:dim(y)[1]) { if (!sum(duplicated(rbind(qd.pt,y[i,object$ynames,drop=FALSE])))) stop("gss error in predict.ssllrm: y value is out of range") wk <- FALSE for (j in 1:nmesh) { if (sum(duplicated(rbind(qd.pt[j,],y[i,object$ynames])))) y.id <- c(y.id,j) } } if (!is.null(odds)) { if (length(y.id)-length(odds)) stop("gss error in predict.ssllrm: odds is of wrong length") if (!max(odds)|sum(odds)) stop("gss error in predict.ssllrm: odds is not a contrast") if (sum(duplicated(y.id))) stop("gss error in predict.ssllrm: duplicated y in contrast") qd.pt <- qd.pt[y.id,,drop=FALSE] } ## Generate s, and r nobs <- dim(x)[1] nmesh <- dim(qd.pt)[1] nbasis <- length(object$id.basis) nnull <- length(object$d) nZ <- length(object$b) s <- NULL r <- array(0,c(nmesh,nbasis,nobs)) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] y.list <- object$ynames[object$ynames%in%vlist] xy.basis <- mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 if (is.null(xx)) { s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) wk <- matrix(s.wk,nmesh,nobs) } else { wk <- NULL for (j in 1:nobs) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- cbind(wk,phi$fun(qd.xy,i,phi$env)) } } s <- array(c(s,wk),c(nmesh,nobs,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 if (is.null(xx)) { r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) r <- r + as.vector(10^object$theta[nq]*r.wk) } else { wk <- NULL for (j in 1:nobs) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- array(c(wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } r <- r + 10^object$theta[nq]*wk } } } } ## random effects if (nZ) { nz <- object$Random$sigma$env$nz if (is.null(zz)) z.wk <- matrix(0,nobs,nz) else z.wk <- as.matrix(zz) if (dim(z.wk)[2]!=nz) stop("gss error in predict.ssllrm: x$random is of wrong dimension") z <- nlvl <- NULL for (ylab in object$ynames) { y.wk <- mf[,ylab] lvl.wk <- levels(y.wk) nlvl.wk <- length(lvl.wk) nlvl <- c(nlvl,nlvl.wk) z.aux <- diag(1,nlvl.wk-1) z.aux <- rbind(z.aux,rep(-1,nlvl.wk-1)) rownames(z.aux) <- lvl.wk pt.wk <- qd.pt[,ylab] for (i in 1:(nlvl.wk-1)) { for (j in 1:nmesh) { z <- cbind(z,z.aux[pt.wk[j],i]*z.wk) } } } z <- aperm(array(z,c(nobs,nz,nmesh,nZ/nz)),c(3,2,4,1)) z <- array(z,c(nmesh,nZ,nobs)) } ## return if (is.null(odds)) { pdf <- NULL for (j in 1:nobs) { wk <- matrix(r[,,j],nmesh,nbasis)%*%object$c if (nnull) wk <- wk + matrix(s[,j,],nmesh,nnull)%*%object$d if (nZ) wk <- wk + matrix(z[,,j],nmesh,nZ)%*%object$b wk <- exp(wk)*qd.wt pdf <- cbind(pdf,wk/sum(wk)) } return(t(pdf[y.id,])) } else { s.wk <- r.wk <- z.wk <- w.wk <- 0 for (i in 1:length(odds)) { r.wk <- r.wk + odds[i]*r[i,,] if (nnull) s.wk <- s.wk + odds[i]*s[i,,] if (nZ) z.wk <- z.wk + odds[i]*z[i,,] w.wk <- w.wk + odds[i]*log(qd.wt[y.id[i]]) } s.wk <- matrix(s.wk,nobs,nnull) r.wk <- t(matrix(r.wk,nbasis,nobs)) z.wk <- t(matrix(z.wk,nZ,nobs)) rs <- cbind(r.wk,z.wk,s.wk) if (!se.odds) as.vector(rs%*%c(object$c,object$b,object$d)) else { fit <- as.vector(rs%*%c(object$c,object$b,object$d)) + w.wk se.fit <- .Fortran("hzdaux2", as.double(object$se.aux$v), as.integer(dim(rs)[2]), as.integer(object$se.aux$jpvt), as.double(t(rs)), as.integer(dim(rs)[1]), se=double(dim(rs)[1]), PACKAGE="gss")[["se"]] return(list(fit=fit,se.fit=se.fit)) } } } gss/R/summary.ssanova0.R0000644000176200001440000000630512355360640014630 0ustar liggesusers## Summarize ssanova0 objects summary.ssanova0 <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") w <- model.weights(object$mf) offset <- model.offset(object$mf) if (is.null(offset)) offset <- rep(0,length(object$c)) ## Residuals res <- 10^object$nlambda*object$c if (!is.null(w)) res <- res/sqrt(w) ## Fitted values fitted <- as.numeric(y-res) fitted.off <- fitted-offset ## (estimated) sigma sigma <- sqrt(object$varht) ## R^2 if (!is.null(w)) { r.squared <- sum(w*(fitted-sum(w*fitted)/sum(w))^2) r.squared <- r.squared/sum(w*(y-sum(w*y)/sum(w))^2) } else r.squared <- var(fitted)/var(y) ## Residual sum of squares if (is.null(w)) rss <- sum(res^2) else rss <- sum(w*res^2) ## Penalty associated with the fit if (is.null(w)) penalty <- sum(object$c*fitted.off) else penalty <- sum(object$c*fitted.off*sqrt(w)) penalty <- as.vector(10^object$nlambda*penalty) ## Calculate the diagnostics mf <- object$mf mf.part <- object$mf.part if (diagnostics) { ## Obtain retrospective linear model comp <- NULL for (label in c(object$terms$labels,object$lab.p)) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,mf,inc=label)) } comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res) term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] term.label <- c(term.label,object$lab.p) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.ssanova0: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant if (!is.null(w)) comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) else comp <- sweep(comp,2,apply(comp,2,mean)) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rankenv$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k2 <- function(x) ((x-.5)^2-1/12)/2 k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 k2(x)*k2(y)-k4(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make phi function for cubic splines mkphi.cubic <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the phi function fun <- function(x,nu,env) { ##% Check the input if (!is.vector(x)) { stop("gss error in phi: inputs are of wrong types") } if ((min(x)env$max)) { stop("gss error in phi: inputs are out of range") } ##% Return the result (x-env$min)/(env$max-env$min)-.5 } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for periodic cubic splines mkrk.cubic.per <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 -k4(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for trigonometric splines mkrk.trig <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 -k4(abs(x-y))-2*cos(2*pi*(x-y))/(2*pi)^4 } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make phi function for trigonometric splines mkphi.trig <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the phi function fun <- function(x,nu,env) { ##% Check the input if (!is.vector(x)) { stop("gss error in phi: inputs are of wrong types") } if ((min(x)env$max)) { stop("gss error in phi: inputs are out of range") } ##% Return the result xx <- (x-env$min)/(env$max-env$min) switch(nu,cos(2*pi*xx),sin(2*pi*xx)) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for linear splines mkrk.linear <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k1 <- function(x) (x-.5) k2 <- function(x) ((x-.5)^2-1/12)/2 k1(x)*k1(y)+k2(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for periodic linear splines mkrk.linear.per <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k2 <- function(x) ((x-.5)^2-1/12)/2 k2(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } gss/R/nlm0.R0000644000176200001440000000505712355360640012253 0ustar liggesusers## minimization of univariate function on finite intervals ## using 3-point quadratic fit with golden-section safe-guard nlm0 <- function(fun,range,prec=1e-7) { ratio <- 2/(sqrt(5)+1) ll.x <- min(range) uu.x <- max(range) if (uu.x-ll.xuu.x)|(deltarange.l) nn.x <- uu.x - ratio*range.u else nn.x <- ll.x + ratio*range.l } ## Update middle points nn.fit <- fun(nn.x) neval <- neval + 1 if (nn.x1) { if (object$skip.iter) kl <- my.ls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.ls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) if (zz$code>3) warning("gss warning in project.ssanova: theta iteration fails to converge") kl <- my.ls(zz$est) } } else kl <- my.ls() yhat.wk <- forwardsolve(t(ww),yhat) one.wk <- forwardsolve(t(ww),rep(1,nobs)) ymean <- sum(one.wk*yy.wk)/sum(one.wk^2) kl0 <- sum((yy.wk-ymean*one.wk)^2)/sum(one.wk^2) kl <- sum((yy.wk-yhat.wk)^2)/sum(one.wk^2) kl1 <- sum((yhat.wk-ymean*one.wk)^2)/sum(one.wk^2) list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } gss/R/fitted.R0000644000176200001440000000433412355360640012661 0ustar liggesusers## Obtain fitted values from ssanova objects fitted.ssanova <- function(object,...) { mf <- object$mf if (!is.null(object$random)) mf$random <- I(object$random$z) predict(object,mf) } ## Obtain residuals from ssanova objects residuals.ssanova <- function(object,...) { y <- model.response(object$mf,"numeric") as.numeric(y-fitted.ssanova(object)) } ## Obtain fitted values in working scale from gssanova objects fitted.gssanova <- function(object,...) { as.numeric(object$eta) } ## Obtain residuals from gssanova objects residuals.gssanova <- function(object,type="working",...) { y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) offset <- NULL if ((object$family=="nbinomial")&(!is.null(object$nu))) y <- cbind(y,object$nu) dat <- switch(object$family, binomial=mkdata.binomial(y,object$eta,wt,offset), nbinomial=mkdata.nbinomial(y,object$eta,wt,offset,object$nu), poisson=mkdata.poisson(y,object$eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,object$eta,wt,offset), Gamma=mkdata.Gamma(y,object$eta,wt,offset), weibull=mkdata.weibull(y,object$eta,wt,offset,list(object$nu,FALSE)), lognorm=mkdata.lognorm(y,object$eta,wt,offset,list(object$nu,FALSE)), loglogis=mkdata.loglogis(y,object$eta,wt,offset,list(object$nu,FALSE))) res <- as.numeric(dat$ywk - object$eta) if (!is.na(charmatch(type,"deviance"))) { dev.resid <- switch(object$family, binomial=dev.resid.binomial(y,object$eta,wt), nbinomial=dev.resid.nbinomial(y,object$eta,wt), poisson=dev.resid.poisson(y,object$eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,object$eta,wt), Gamma=dev.resid.Gamma(y,object$eta,wt), weibull=dev.resid.weibull(y,object$eta,wt,object$nu), lognorm=dev.resid.lognorm(y,object$eta,wt,object$nu), loglogis=dev.resid.loglogis(y,object$eta,wt,object$nu)) res <- sqrt(dev.resid)*sign(res) } res } gss/R/project.sshzd.R0000644000176200001440000001640012355360640014177 0ustar liggesusers## Calculate Kullback-Leibler projection from sshzd objects project.sshzd <- function(object,include,mesh=FALSE,...) { if (!(object$tname%in%include)) stop("gss error in project.sshzd: time main effect missing in included terms") quad.pt <- object$quad$pt qd.wt <- object$qd.wt nx <- dim(object$qd.wt)[2] nbasis <- length(object$id.basis) mesh0 <- object$mesh0 ## extract terms in subspace nqd <- length(quad.pt) nxi <- length(object$id.basis) d <- qd.s <- q <- theta <- NULL qd.r <- as.list(NULL) n0.wk <- nu <- nq.wk <- nq <- 0 for (label in object$terms$labels) { vlist <- object$terms[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] xy.basis <- object$mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nqd,length(vlist))) names(qd.xy) <- vlist if (object$tname%in%vlist) qd.xy[,object$tname] <- quad.pt if (length(x.list)) xx <- object$x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- object$terms[[label]]$nphi nrk <- object$terms[[label]]$nrk if (nphi) { phi <- object$terms[[label]]$phi for (i in 1:nphi) { n0.wk <- n0.wk + 1 if (label=="1") { d <- object$d[n0.wk] nu <- nu + 1 qd.wk <- matrix(1,nqd,nx) qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,nu)) next } if (!any(label==include)) next d <- c(d,object$d[n0.wk]) nu <- nu + 1 if (is.null(xx)) qd.wk <- matrix(phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env),nqd,nx) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nqd),] for (k in x.list) if (is.factor(xx[,k])) qd.xy[,k] <- as.factor(qd.xy[,k]) qd.wk <- cbind(qd.wk,phi$fun(qd.xy[,,drop=TRUE],i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,nu)) } } if (nrk) { rk <- object$terms[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) if (is.null(xx)) qd.r[[nq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nqd),] for (k in x.list) if (is.factor(xx[,k])) qd.xy[,k] <- as.factor(qd.xy[,k]) qd.wk <- array(c(qd.wk,rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE)), c(nqd,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } if (!is.null(object$partial)) { for (label in object$lab.p) { n0.wk <- n0.wk + 1 if (!any(label==include)) next d <- c(d,object$d[n0.wk]) qd.wk <- t(matrix(object$partial$pt[,label],nx,nqd)) qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,n0.wk)) } } if (!is.null(qd.s)) nnull <- dim(qd.s)[3] else nnull <- 0 nn <- nxi + nnull ## random effect offset if (!is.null(object$b)) offset <- as.vector(object$random$qd.z%*%object$b) else offset <- rep(0,nx) ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta.wk[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta.wk[i]*qd.r[[i]]) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) z <- .Fortran("hrkl", cd=as.double(cd), as.integer(nn), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(t(t(qd.wt)*exp(offset))), mesh=as.double(qd.wt*mesh0), as.double(.Machine$double.eps), double(nqd*nx), double(nn), double(nn), double(nn*nn), integer(nn), double(nn), double(nn), double(nqd*nx), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sshzd: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sshzd: Newton iteration fails to converge") assign("cd",z$cd,inherits=TRUE) assign("mesh1",t(t(matrix(z$mesh,nqd,nx))*exp(offset)),inherits=TRUE) sum(qd.wt*(log(mesh0/mesh1)*mesh0-mesh0+mesh1)) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization if (nnull) { qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } else theta.wk <- 0 theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(q[,i])) fix <- rev(order(tmp))[1] ## projection cd <- c(10^(-theta.wk)*object$c,d) mesh1 <- NULL if (nq-1) { if (object$skip.iter) kl <- rkl(theta[-fix]) else { if (nq-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() ## cfit cfit <- t(matrix(object$dbar/sum(t(qd.wt)*exp(offset))*exp(offset),nx,nqd)) ## return kl0 <- sum(object$qd.wt*(log(mesh0/cfit)*mesh0-mesh0+cfit)) kl1 <- sum(object$qd.wt*(log(mesh1/cfit)*mesh1-mesh1+cfit)) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) if (mesh) obj$mesh <- mesh1 obj } gss/R/predict.sscox.R0000644000176200001440000000552612355360640014176 0ustar liggesusers## Evaluate hazard estimate predict.sscox <- function (object,newdata,se.fit=FALSE, include=c(object$terms$labels,object$lab.p),...) { if (class(object)!="sscox") stop("gss error in predict.sscox: not a sscox object") nnew <- nrow(newdata) nbasis <- length(object$id.basis) nnull <- length(object$d) nz <- length(object$b) nn <- nbasis + nnull + nz labels.p <- object$lab.p ## Extract included terms if (!is.null(object$d)) s <- matrix(0,nnew,nnull) r <- matrix(0,nnew,nbasis) for (label in include) { if (label%in%labels.p) next xx <- object$mf[object$id.basis,object$terms[[label]]$vlist] xnew <- newdata[,object$terms[[label]]$vlist] nphi <- object$terms[[label]]$nphi nrk <- object$terms[[label]]$nrk if (nphi) { iphi <- object$terms[[label]]$iphi phi <- object$terms[[label]]$phi for (i in 1:nphi) { s[,iphi+(i-1)] <- phi$fun(xnew,nu=i,env=phi$env) } } if (nrk) { irk <- object$terms[[label]]$irk rk <- object$terms[[label]]$rk for (i in 1:nrk) { r <- r + 10^object$theta[irk+(i-1)]* rk$fun(xnew,xx,nu=i,env=rk$env,out=TRUE) } } } if (!is.null(object$partial)) { vars.p <- as.character(attr(object$partial$mt,"variables"))[-1] facs.p <- attr(object$partial$mt,"factors") vlist <- vars.p[as.logical(apply(facs.p,1,sum))] for (lab in labels.p) { if (lab%in%include) { vlist.wk <- vars.p[as.logical(facs.p[,lab])] vlist <- vlist[!(vlist%in%vlist.wk)] } } if (length(vlist)) { for (lab in vlist) newdata[[lab]] <- 0 } matx.p <- model.matrix(object$partial$mt,newdata)[,-1,drop=FALSE] matx.p <- sweep(matx.p,2,object$partial$center) matx.p <- sweep(matx.p,2,object$partial$scale,"/") nu <- nnull-dim(matx.p)[2] for (label in labels.p) { nu <- nu+1 if (label%in%include) s[,nu] <- matx.p[,label] } } ## random effects if (nz) { if (is.null(newdata$random)) z.wk <- matrix(0,nnew,nz) else z.wk <- newdata$random rs <- cbind(r,z.wk,s) } else rs <- cbind(r,s) if (!se.fit) as.vector(exp(rs%*%c(object$c,object$b,object$d))) else { fit <- as.vector(exp(rs%*%c(object$c,object$b,object$d))) se.fit <- .Fortran("hzdaux2", as.double(object$se.aux$v), as.integer(dim(rs)[2]), as.integer(object$se.aux$jpvt), as.double(t(rs)), as.integer(dim(rs)[1]), se=double(dim(rs)[1]), PACKAGE="gss")[["se"]] list(fit=fit,se.fit=se.fit) } } gss/R/gssanova0.R0000644000176200001440000003034513475773315013317 0ustar liggesusers## Fit gssanova0 model gssanova0 <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, method=NULL,varht=1,nu=NULL,prec=1e-7,maxiter=30) { ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$prec <- mf$maxiter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) ## Generate terms term <- mkterm(mf,type) ## Specify default method if (is.null(method)) { method <- switch(family, binomial="u", nbinomial="u", poisson="u", inverse.gaussian="v", Gamma="v", weibull="u", lognorm="u", loglogis="u") } ## Generate s, q, and y nobs <- dim(mf)[1] s <- q <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 q <- array(c(q,rk$fun(x,x,nu=i,env=rk$env,out=TRUE)),c(nobs,nobs,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank=nnull)&(nnull>0))) { stop("gss error in sspregpoi: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } eta <- rep(0,nobs) nla0 <- log10(mean(abs(diag(q)))) limnla <- nla0+c(-.5,.5) iter <- 0 if (family=="nbinomial") nu <- NULL else nu <- list(nu,is.null(nu)) repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) nu <- dat$nu w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk swk <- w*s qwk <- w*t(w*q) ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(ywk), qwk=as.double(qwk), as.integer(nobs), as.double(0), as.integer(-1), as.double(limnla), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspregpoi: matrix s is rank deficient") if (info==-2) stop("gss error in sspregpoi: matrix q is indefinite") if (info==-1) stop("gss error in sspregpoi: input data have wrong dimensions") if (info==-3) stop("gss error in sspregpoi: unknown method for smoothing parameter selection.") } eta.new <- (ywk-10^z$nlambda*z$c)/w if (!is.null(offset)) eta.new <- eta.new + offset disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) limnla <- pmax(z$nlambda+c(-.5,.5),nla0-5) if (disc=maxiter) { warning("gss warning in gssanova0: performance-oriented iteration fails to converge") break } eta <- eta.new } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(list(method=method,theta=0,w=as.vector(dat$wt), eta=as.vector(eta),iter=iter,nu=nu), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Fit Multiple Smoothing Parameter REGression by Performance-Oriented Iteration mspregpoi <- function(family,s,q,y,wt,offset,method="u", varht=1,nu,prec=1e-7,maxiter=30) { ## Check inputs if (is.vector(s)) s <- as.matrix(s) if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3) &is.character(method))) { stop("gss error in mspregpoi: inputs are of wrong types") } nobs <- dim(s)[1] nnull <- dim(s)[2] nq <- dim(q)[3] if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs) &(nobs>=nnull)&(nnull>0))) { stop("gss error in sspregpoi: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } eta <- rep(0,nobs) init <- 0 theta <- rep(0,nq) iter <- 0 if (family=="nbinomial") nu <- NULL else nu <- list(nu,is.null(nu)) qwk <- array(0,c(nobs,nobs,nq)) repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) nu <- dat$nu w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk swk <- w*s for (i in 1:nq) qwk[,,i] <- w*t(w*q[,,i]) ## Call RKPACK driver DMUDR z <- .Fortran("dmudr0", as.integer(code), as.double(swk), # s as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(qwk), # q as.integer(nobs), as.integer(nobs), as.integer(nq), as.double(ywk), # y as.double(0), as.integer(init), as.double(prec), as.integer(maxiter), theta=as.double(theta), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), integer(nnull+nq), double(nobs*nobs*(nq+2)), info=integer(1),PACKAGE="gss")[c("theta","nlambda","c","info")] ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in mspreg: matrix s is rank deficient") if (info==-2) stop("gss error in mspreg: matrix q is indefinite") if (info==-1) stop("gss error in mspreg: input data have wrong dimensions") if (info==-3) stop("gss error in mspreg: unknown method for smoothing parameter selection.") if (info==-4) stop("gss error in mspreg: iteration fails to converge, try to increase maxiter") if (info==-5) stop("gss error in mspreg: iteration fails to find a reasonable descent direction") } eta.new <- (ywk-10^z$nlambda*z$c)/w if (!is.null(offset)) eta.new <- eta.new + offset disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) if (disc=maxiter) { warning("gss warning in gssanova0: performance-oriented iteration fails to converge") break } init <- 1 theta <- z$theta eta <- eta.new } qqwk <- 10^z$theta[1]*qwk[,,1] for (i in 2:nq) qqwk <- qqwk + 10^z$theta[i]*qwk[,,i] ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(ywk), qwk=as.double(qqwk), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspregpoi: matrix s is rank deficient") if (info==-2) stop("gss error in sspregpoi: matrix q is indefinite") if (info==-1) stop("gss error in sspregpoi: input data have wrong dimensions") if (info==-3) stop("gss error in sspregpoi: unknown method for smoothing parameter selection.") } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(list(method=method,theta=theta,w=as.vector(dat$wt), eta=as.vector(eta),iter=iter,nu=nu), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } gss/R/summary.ssanova9.R0000644000176200001440000000710412355360640014637 0ustar liggesusers## Summarize ssanova objects summary.ssanova9 <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") nobs <- length(y) cov <- object$cov if (length(object$zeta)) ww <- cov$fun(object$zeta,cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) offset <- model.offset(object$mf) if (is.null(offset)) offset <- rep(0,length(y)) ## Residuals mf <- object$mf res <- y - predict(object,mf) ## Fitted values fitted <- as.numeric(y-res) ## (estimated) sigma sigma <- sqrt(object$varht) ## R^2 y.wk <- forwardsolve(t(ww),y) fitted.wk <- forwardsolve(t(ww),fitted) one.wk <- forwardsolve(t(ww),rep(1,nobs)) mn.y <- sum(y.wk*one.wk)/sum(one.wk^2) mn.fitted <- sum(fitted.wk*one.wk)/sum(one.wk^2) r.squared <- sum((fitted.wk-mn.fitted*one.wk)^2) r.squared <- r.squared/sum((y.wk-mn.y*one.wk)^2) ## Residual sum of squares res.wk <- forwardsolve(t(ww),res) rss <- sum(res.wk^2) ## Penalty associated with the fit obj.wk <- object obj.wk$d[] <- 0 if (!is.null(model.offset(obj.wk$mf))) obj.wk$mf[,"(offset)"] <- 0 penalty <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,])) penalty <- as.vector(10^object$nlambda*penalty) ## Calculate the diagnostics if (is.null(object$partial)) labels.p <- NULL else labels.p <- labels(object$partial$mt) if (diagnostics) { ## Obtain retrospective linear model comp <- NULL p.dec <- NULL for (label in c(object$terms$labels,labels.p)) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,mf,inc=label)) jk <- sum(obj.wk$c*predict(obj.wk,mf[object$id.basis,],inc=label)) p.dec <- c(p.dec,10^object$nlambda*jk) } term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] term.label <- c(term.label,labels.p) fitted.off <- fitted-offset comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res) comp <- forwardsolve(t(ww),comp) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.ssanova: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant comp <- comp - outer(one.wk,apply(t(comp)%*%one.wk,1,sum))/sum(one.wk^2) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rank1) { if (object$skip.iter) kl <- my.ls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.ls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) if (zz$code>3) warning("gss warning in project.ssanova: theta iteration fails to converge") kl <- my.ls(zz$est) } } else kl <- my.ls() if (!is.null(wt)) { yhat <- yhat/wt.wk ymean <- sum(wt*yy)/sum(wt) kl0 <- sum(wt*(yy-ymean)^2)/sum(wt) kl <- sum(wt*(yy-yhat)^2)/sum(wt) kl1 <- sum(wt*(ymean-yhat)^2)/sum(wt) } else { kl0 <- mean((yy-mean(yy))^2) kl <- mean((yy-yhat)^2) kl1 <- mean((mean(yy)-yhat)^2) } list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } gss/R/gauss.quad.R0000644000176200001440000000117712355360640013457 0ustar liggesusersgauss.quad <- ## Generate Gauss-Legendre quadrature function(size,interval) { if (interval[1]>=interval[2]) warning("gss warning in gauss.quad: interval limits swapped") z <- .Fortran("gaussq", as.integer(1), as.integer(size), as.double(0), as.double(0), as.integer(0), as.double(c(-1,1)), double(size), t=double(size), w=double(size), PACKAGE="gss") mn <- min(interval[1:2]) range <- abs(interval[1]-interval[2]) pt <- mn+range*(z$t+1)/2 wt <- range*z$w/2 list(pt=pt,wt=wt) } gss/R/sshzd1.R0000644000176200001440000005743212355360640012625 0ustar liggesusers## Fit hazard model sshzd1 <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit,rho="marginal", partial=NULL,id.basis=NULL,nbasis=NULL,seed=NULL, random=NULL,prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { tname <- as.character(as.list(match.call())$time) if (!is.numeric(time)|!is.vector(time)) stop("gss error in sshzd1: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sshzd1: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sshzd1: time and start mismatch in size") if (any(start>time)) stop("gss error in sshzd1: start after follow-up time") if (min(start)<0) stop("gss error in sshzd1: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- mf$rho <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd1: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname ## model frame term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd1: time main effect missing in model") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf <- eval(mf,parent.frame()) ## Use sshzd in lack of covariate if (all(tname==names(mf))) stop("use sshzd when covariate is absent") ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sshzd1: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## set domain and type for time mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) if (is.null(type[[tname]])) type[[tname]] <- list("cubic",tdomain) if (length(type[[tname]])==1) type[[tname]] <- c(type[[tname]],tdomain) if (!(type[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd1: wrong type") if ((min(type[[tname]][[2]])>min(tdomain))| (max(type[[tname]][[2]])yy$start[i]) if (is.vector(rho.qd)) wk <- wk*rho.qd else wk <- wk*rho.qd[,x.ind[i]] if (is.null(cnt)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt[i]*wk } if (is.null(cnt)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt) ## Generate s, r, int.s, and int.r s <- r <- int.s <- int.r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nT)) int.s <- c(int.s,sum(qd.wt)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) { qd.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) int.s <- c(int.s,sum(qd.wk*apply(qd.wt,1,sum))) } else { int.s.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- phi$fun(qd.xy[,,drop=TRUE],i,phi$env) int.s.wk <- int.s.wk + sum(qd.wk*qd.wt[,j]) } int.s <- c(int.s,int.s.wk) } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) { qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) int.r <- cbind(int.r,apply(apply(qd.wt,1,sum)*qd.wk,2,sum)) } else { int.r.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE) int.r.wk <- int.r.wk + apply(qd.wt[,j]*qd.wk,2,sum) } int.r <- cbind(int.r,int.r.wk) } } } } ## Add the partial term if (!is.null(partial)) { s <- cbind(s,matx.p[yy$status,]) int.s <- c(int.s,t(matx.p[!x.dup.ind,])%*%apply(qd.wt,2,sum)) part$pt <- matx.p[!x.dup.ind,,drop=FALSE] } ## generate int.z if (!is.null(random)) random$int.z <- t(qd.z)%*%apply(qd.wt,2,sum) ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- int.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] int.r.wk0 <- int.r.wk0 + 10^theta[i]*int.r[,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("int.r.wk",int.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk int.r.wk0 <- int.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] int.r.wk0 <- int.r.wk0 + theta.wk*int.r[,i] } } q.wk <- r.wk0[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) int.r.wk0 <- c(int.r.wk0,10^ran.scal*random$int.z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } fit <- .Fortran("hzdnewton10", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk0,s)), as.integer(nT), as.integer(Nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(c(int.r.wk0,int.s)), as.double(rho), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*nT+nn*(nn+3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sshzd: Newton iteration diverges") if (fit$info==2) warning("gss warning in sshzd: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- fit$wk[1]+alpha*fit$wk[2] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.wk,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } v.r <- sum(rho*r.wk^2) if (nnull) { v.s <- sum(rho*s^2) theta.wk <- log10(v.s/nnull/v.r*nxi) / 2 } else theta.wk <- 0 if (!is.null(random)) { v.z <- sum(rho*random$z^2) ran.scal <- theta.wk - log10(v.z/nz/v.r*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.wk,] if (!is.null(random)) { r.wk <- cbind(r.wk,10^ran.scal*random$z) int.r.wk <- c(int.r.wk,10^ran.scal*random$int.z) } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (!is.null(cnt)) rho <- rho*cnt if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## theta adjustment for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.wk,,i]%*%cd[1:nxi]) } r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } v.r <- sum(rho*r.wk^2) if (nnull) { v.s <- sum(rho*s^2) theta.wk <- log10(v.s/nnull/v.r*nxi) / 2 } else theta.wk <- 0 if (!is.null(random)) { v.z <- sum(rho*random$z^2) ran.scal <- theta.wk - log10(v.z/nz/v.r*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.wk,] if (!is.null(random)) { r.wk <- cbind(r.wk,10^ran.scal*random$z) int.r.wk <- c(int.r.wk,10^ran.scal*random$int.z) } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (!is.null(cnt)) rho <- rho*cnt if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd1: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return if (!is.null(cnt)) rho <- rho*cnt r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk <- cbind(r.wk,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux) } gss/R/sshzd.R0000644000176200001440000006174312355360640012544 0ustar liggesusers## Fit hazard model sshzd <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,offset,na.action=na.omit, partial=NULL,id.basis=NULL,nbasis=NULL,seed=NULL, random=NULL,prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { tname <- as.character(as.list(match.call())$time) if (!is.numeric(time)|!is.vector(time)) stop("gss error in sshzd: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sshzd: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sshzd: time and start mismatch in size") if (any(start>time)) stop("gss error in sshzd: start after follow-up time") if (min(start)<0) stop("gss error in sshzd: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname ## model frame term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd: time main effect missing in model") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf <- eval(mf,parent.frame()) offset <- model.offset(mf) mf$"(offset)" <- NULL ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sshzd: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## set domain and type for time mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) if (is.null(type[[tname]])) type[[tname]] <- list("cubic",tdomain) if (length(type[[tname]])==1) type[[tname]] <- c(type[[tname]],tdomain) if (!(type[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd: wrong type") if ((min(type[[tname]][[2]])>min(tdomain))| (max(type[[tname]][[2]])yy$start[i]) if (!is.null(offset)) wk <- wk*exp(offset[i]) if (is.null(cnt)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt[i]*wk } if (is.null(cnt)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt) ## Generate s and r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nq <- nu <- 0 for (label in term$labels) { if (label=="1") { nu <- nu+1 s <- cbind(s,rep(1,len=nT)) qd.wk <- matrix(1,nmesh,nx) qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) qd.wk <- matrix(phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env),nmesh,nx) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy[,,drop=TRUE],i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) qd.r[[nq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Add the partial term if (!is.null(partial)) { s <- cbind(s,matx.p[yy$status,]) nu.p <- dim(matx.p)[2] qd.wk <- aperm(array(matx.p[!x.dup.ind,],c(nx,nu.p,nmesh)),c(3,1,2)) nu <- nu + nu.p qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) part$pt <- matx.p[!x.dup.ind,,drop=FALSE] } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- r.wk0[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) if (!is.null(random)) { qd.r.wk0 <- array(c(qd.r.wk0,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("hzdnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nT), as.integer(Nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(qd.r.wk0), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd*nx+nT)+nn*(2*nn+4)+max(nn,2)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sshzd: Newton iteration diverges") if (fit$info==2) warning("gss warning in sshzd: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) assign("mesh0",matrix(fit$wk[max(nn,2)+(1:(nqd*nx))],nqd,nx),inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.wk,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { if (nnull) v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } if (nnull) theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 else theta.wk <- 0 if (!is.null(random)) { v.z <- apply(apply(qd.wt,2,sum)*random$qd.z^2,2,sum) ran.scal <- theta.wk - log10(sum(v.z)/nz/sum(v.r)*nxi) / 2 qd.z.wk <- aperm(array(10^ran.scal*random$qd.z,c(nx,nz,nqd)),c(3,1,2)) } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration mesh0 <- NULL cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.wk,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { if (nnull) v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } if (nnull) theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 else theta.wk <- 0 if (!is.null(random)) { v.z <- apply(apply(qd.wt,2,sum)*random$qd.z^2,2,sum) ran.scal <- theta.wk - log10(sum(v.z)/nz/sum(v.r)*nxi) / 2 qd.z.wk <- aperm(array(10^ran.scal*random$qd.z,c(nx,nz,nqd)),c(3,1,2)) } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.wk,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } gss/R/gssanova1.R0000644000176200001440000001557712355360640013317 0ustar liggesusers## Fit gssanova model gssanova1 <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, method=NULL,varht=1,alpha=1.4,nu=NULL, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { if (!(family%in%c("binomial","poisson","Gamma","nbinomial","inverse.gaussian", "weibull","lognorm","loglogis"))) stop("gss error in gssanova1: family not implemented") ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in gssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) } ## Specify default method if (is.null(method)) { method <- switch(family, binomial="u", nbinomial="u", poisson="u", inverse.gaussian="v", Gamma="v", weibull="u", lognorm="u", loglogis="u") } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in gssanova1: use glm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank=30) { warning("gss warning in gssanova1: performance-oriented iteration fails to converge") break } } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(z,list(nu=nu,eta=eta,w=dat$wt)) } gss/R/sscden1.R0000644000176200001440000005100012355360640012732 0ustar liggesusers## Fit conditional density model sscden1 <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1.4, id.basis=NULL,nbasis=NULL,seed=NULL,rho=list("xy"), ydomain=as.list(NULL),yquad=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- mf$rho <- NULL mf$ydomain <- mf$yquad <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) nobs <- nrow(mf) cnt <- model.weights(mf) if (is.null(cnt)) data$cnt <- rep(1,nobs) else { data$cnt <- cnt mf$"(weights)" <- NULL } ## Generate sub-basis if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscden1: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in sscden1: response missing in model") xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in sscden1: missing covariate") ## Set type for given ydomain fac.list <- NULL for (ylab in ynames) { y <- mf[[ylab]] if (is.factor(y)) { fac.list <- c(fac.list,ylab) ydomain[[ylab]] <- NULL } else { if (!is.vector(y)&is.null(yquad)) stop("gss error in sscden1: no default quadrature") if (is.vector(y)) { if (is.null(ydomain[[ylab]])) { mn <- min(y) mx <- max(y) ydomain[[ylab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else ydomain[[ylab]] <- c(min(ydomain[[ylab]]),max(ydomain[[ylab]])) if (is.null(type[[ylab]])) type[[ylab]] <- list("cubic",ydomain[[ylab]]) else { if (length(type[[ylab]])==1) type[[ylab]] <- list(type[[ylab]][[1]],ydomain[[ylab]]) } } } } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] ## obtain unique covariate observations x <- xx <- mf[,xnames,drop=FALSE] xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) xx <- rep(xx,cnt) xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## calculate rho if (is.null(rho$fun)) { type <- rho[[1]] if (type=="y") { yfac <- TRUE for (ylab in ynames) yfac <- yfac&is.factor(mf[,ylab]) if (!yfac) { if (is.null(cnt)) cntt <- rep(1,dim(mf)[1]) rho <- ssden(response,data=data,weights=cnt,id.basis=id.basis, alpha=2,domain=ydomain,quad=yquad) qd.pt <- rho$quad$pt qd.wt <- rho$quad$wt env <- list(ydomain=ydomain,qd.pt=qd.pt,qd.wt=qd.wt,rho=rho) fun <- function(x,y,env,outer.prod=FALSE) { if (!outer.prod) dssden(env$rho,y) else t(matrix(dssden(env$rho,y),dim(y)[1],dim(x)[1])) } } else { qd.pt <- data.frame(levels(mf[,ynames[1]])) if (length(ynames)>1) { for (ylab in ynames[-1]) { wk <- expand.grid(levels(mf[,ylab]),1:dim(qd.pt)[1]) qd.pt <- data.frame(qd.pt[wk[,2],],wk[,1]) } } colnames(qd.pt) <- ynames qd.wt <- as.vector(table(mf[,rev(ynames)])) qd.wt <- qd.wt/sum(qd.wt) env <- list(qd.pt=qd.pt,qd.wt=qd.wt) fun <- function(x,y,env,outer.prod=FALSE) { if (!outer.prod) rep(1,dim(x)[1]) else matrix(1,dim(x)[1],dim(y)[1]) } } rho <- list(fun=fun,env=env) } if (type=="xy") { ydomain <- data.frame(ydomain) mn <- ydomain[1,] mx <- ydomain[2,] dm <- ncol(ydomain) if (dm==1) { ## Gauss-Legendre quadrature quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(ydomain) } else { ## Smolyak cubature qdsz.depth <- switch(min(dm,6)-1,18,14,10,9,7) quad <- smolyak.quad(dm,qdsz.depth) for (i in 1:ncol(ydomain)) { ylab <- colnames(ydomain)[i] wk <- mf[[ylab]] jk <- ssden(~wk,domain=data.frame(wk=ydomain[,i]),alpha=2, id.basis=id.basis,weights=cnt) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- wk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(ydomain) } ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } rho <- list(NULL) for (ylab in ynames) { if (is.numeric(mf[[ylab]])) { form <- as.formula(paste(ylab,"~",paste(xnames,collapse="+"))) rho[[ylab]] <- ssanova(form,data=mf,id.basis=id.basis) } if (is.factor(mf[[ylab]])) { form <- as.formula(paste("~(",paste(xnames,collapse="+"),")*",ylab)) resp <- as.formula(paste("~",ylab)) rho[[ylab]] <- ssllrm(form,resp,data=mf,id.basis=id.basis) } } env <- list(ynames=ynames,ydomain=ydomain,qd.pt=quad$pt,qd.wt=quad$wt,rho=rho) fun <- function(x,y,env,outer.prod=FALSE) { z <- 1 for (ylab in env$ynames) { yy <- y[[ylab]] if (is.numeric(yy)) { mu <- predict(env$rho[[ylab]],x) sigma <- sqrt(env$rho[[ylab]]$varht) ymn <- env$ydomain[1,ylab] ymx <- env$ydomain[2,ylab] if (!outer.prod) { wk <- dnorm((yy-mu)/sigma)/ (pnorm((ymx-mu)/sigma)-pnorm((ymn-mu)/sigma)) z <- z*wk } else { wk <- t(outer(yy,mu,dnorm,sigma))/ (pnorm((ymx-mu)/sigma)-pnorm((ymn-mu)/sigma)) z <- z*wk } } if (is.factor(yy)) { wk <- predict(env$rho[[ylab]],x) if (!outer.prod) { wk1 <- NULL for (i in 1:length(yy)) wk1 <- c(wk1,wk[i,yy[i]==env$rho[[ylab]]$qd.pt]) z <- z*wk1 } else { wk1 <- NULL for (i in 1:length(yy)) wk1 <- cbind(wk1,wk[,yy[i]==env$rho[[ylab]]$qd.pt]) z <- z*wk1 } } } z } rho <- list(fun=fun,env=env) } } ## Generate s, r, int.s, and int.r rho.wk <- rho$fun(x[!x.dup.ind,,drop=FALSE],rho$env$qd.pt,rho$env,outer=TRUE) rho.wk <- t(t(rho.wk)*rho$env$qd.wt) rho.wk1 <- apply(rho.wk*xx.wt,2,sum) nmesh <- length(rho$env$qd.wt) s <- r <- int.s <- int.r <- NULL id.s <- id.r <- NULL id.s.list <- id.r.list <- list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- rho$env$qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi id.s.list[[label]] <- NULL for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { id.s <- c(id.s,nu) id.s.list[[label]] <- c(id.s.list[[label]],nu) qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) int.s <- c(int.s,sum(qd.s.wk*rho.wk1)) } else { if (length(y.list)==0) { names(xx) <- x.list int.s <- c(int.s,sum(phi$fun(xx[,,drop=TRUE],i,phi$env)*xx.wt)) } else { id.s <- c(id.s,nu) id.s.list[[label]] <- c(id.s.list[[label]],nu) int.s.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.s.wk <- phi$fun(qd.xy,i,phi$env) int.s.wk <- int.s.wk + sum(qd.s.wk*rho.wk[j,])*xx.wt[j] } int.s <- c(int.s,int.s.wk) } } } } if (nrk) { rk <- term[[label]]$rk id.r.list[[label]] <- NULL for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { id.r <- c(id.r,nq) id.r.list[[label]] <- c(id.r.list[[label]],nq) qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) int.r <- cbind(int.r,apply(rho.wk1*qd.r.wk,2,sum)) } else { if (length(y.list)==0) { names(xx) <- x.list qd.r.wk <- rk$fun(xx[,,drop=TRUE],xy.basis,i,rk$env,TRUE) int.r <- cbind(int.r,apply(xx.wt*qd.r.wk,2,sum)) } else { id.r <- c(id.r,nq) id.r.list[[label]] <- c(id.r.list[[label]],nq) int.r.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.r.wk <- rk$fun(qd.xy,xy.basis,i,rk$env,TRUE) int.r.wk <- int.r.wk + apply(rho.wk[j,]*qd.r.wk,2,sum)*xx.wt[j] } int.r <- cbind(int.r,int.r.wk) } } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*trc,0) cv+adj } cv.m <- function(theta) { ind.wk <- theta!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- int.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] int.r.wk0 <- int.r.wk0 + 10^theta[i]*int.r[,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("int.r.wk",int.r.wk0+0,inherits=TRUE) assign("theta.old",theta+0,inherits=TRUE) } else { r.wk0 <- r.wk int.r.wk0 <- int.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] int.r.wk0 <- int.r.wk0 + theta.wk*int.r[,i] } } q.wk <- r.wk0[id.basis,] fit <- .Fortran("cdennewton10", cd=as.double(cd), as.integer(nxis), as.double(10^lambda*q.wk), as.integer(nxi), as.double(cbind(r.wk0,s)), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(c(int.r.wk0,int.s)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nxis), wk=double(2*nobs+nxis*(nxis+3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscden1: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscden1: Newton iteration fails to converge") aa <- fit$wk[1:nobs] assign("cd",fit$cd,inherits=TRUE) eta0 <- cbind(r.wk,s)%*%cd wwt <- wt*exp(-eta0) wwt <- wwt/sum(wwt) assign("scal",sum(wt*exp(-eta0)),inherits=TRUE) trc <- sum(wwt*exp(aa/(1-aa)))-1 cv <- sum(c(int.r.wk0,int.s)*cd) + log(scal) + alpha*trc alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*trc,0) cv+adj } cv.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } if (!nnull) { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 theta.wk <- 0 } else { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) v.s <- v.s - mu.s^2 theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration cd <- rep(0,nxi+nnull) scal <- NULL la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } if (nq==1) { lambda <- zz$est c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL return(list(lambda=lambda,theta=theta,c=c,d=d,cv=zz$min,scal=scal)) } ## theta adjustment r.wk <- int.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } if (!nnull) { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 theta.wk <- 0 } else { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) v.s <- v.s - mu.s^2 theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nxi+nnull) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } lambda <- zz$est ## early return if (skip.iter) { c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL return(list(lambda=lambda,theta=theta,c=c,d=d,cv=zz$min,scal=scal)) } ## theta search counter <- 0 r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } theta.old <- theta tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscden1: CV iteration fails to converge") break } } ## return c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL cv <- (zz$min-cv.shift)/cv.scale list(lambda=lambda,theta=zz$est,c=c,d=d,cv=cv,scal=scal) } gss/R/summary.gssanova.R0000644000176200001440000001013212355360640014710 0ustar liggesusers## Summarize gssanova objects summary.gssanova <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) offset <- model.offset(object$mf) if ((object$family=="nbinomial")&(!is.null(object$nu))) y <- cbind(y,object$nu) dev.null <- switch(object$family, binomial=dev.null.binomial(y,wt,offset), nbinomial=dev.null.nbinomial(y,wt,offset), poisson=dev.null.poisson(y,wt,offset), Gamma=dev.null.Gamma(y,wt,offset), weibull=dev.null.weibull(y,wt,offset,object$nu), lognorm=dev.null.lognorm(y,wt,offset,object$nu), loglogis=dev.null.loglogis(y,wt,offset,object$nu)) w <- object$w if (is.null(offset)) offset <- rep(0,length(object$eta)) ## Residuals res <- residuals(object)*sqrt(w) dev.resid <- residuals(object,"deviance") ## Fitted values fitted <- fitted(object) ## dispersion sigma2 <- object$varht ## RSS, deviance rss <- sum(res^2) dev <- sum(dev.resid^2) ## Penalty associated with the fit obj.wk <- object obj.wk$d[] <- 0 if (!is.null(model.offset(obj.wk$mf))) obj.wk$mf[,"(offset)"] <- 0 penalty <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,])) penalty <- as.vector(10^object$nlambda*penalty) if (!is.null(object$random)) { p.ran <- t(object$b)%*%object$random$sigma$fun(object$zeta,object$random$sigma$env)%*%object$b penalty <- penalty + p.ran } ## Calculate the diagnostics if (diagnostics) { ## Obtain retrospective linear model comp <- NULL p.dec <- NULL for (label in object$terms$labels) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,object$mf,inc=label)) jk <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,],inc=label)) p.dec <- c(p.dec,10^object$nlambda*jk) } term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] if (!is.null(object$random)) { mf <- object$mf mf$random <- object$random$z comp <- cbind(comp,predict(object,mf,inc=NULL)) p.dec <- c(p.dec,p.ran) term.label <- c(term.label,"random") } fitted.off <- fitted-offset comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res/sqrt(w),e=res/sqrt(w)) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.gssanova: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rankmx)) stop("gss error in hzdcurve.sshzd: time range beyond the domain") if (length(xnames)) { xx <- covariates[,xnames,drop=FALSE] xy <- data.frame(matrix(0,length(time),length(xnames)+1)) names(xy) <- c(tname,xnames) xy[,tname] <- time } else xx <- NULL if (!se) { if (is.null(xx)) zz <- hzdrate.sshzd(object,time) else { zz <- NULL for (i in 1:dim(xx)[1]) { xy[,xnames] <- xx[rep(i,length(time)),] zz <- cbind(zz,hzdrate.sshzd(object,xy)) } zz <- zz[,,drop=TRUE] } zz } else { if (is.null(xx)) zz <- hzdrate.sshzd(object,time,TRUE) else { fit <- se.fit <- NULL for (i in 1:dim(xx)[1]) { xy[,xnames] <- xx[rep(i,length(time)),] wk <- hzdrate.sshzd(object,xy,TRUE) fit <- cbind(fit,wk$fit) se.fit <- cbind(se.fit,wk$se.fit) } zz <- list(fit=fit[,,drop=TRUE],se.fit=se.fit[,,drop=TRUE]) } zz } } survexp.sshzd <- ## Compute expected survival function(object,time,covariates=NULL,start=0) { tname <- object$tname xnames <- object$xnames ## Check inputs if (!any(class(object)=="sshzd")) stop("gss error in survexp.sshzd: not a sshzd object") if (length(xnames)&&(!all(xnames%in%names(covariates)))) stop("gss error in survexp.sshzd: missing covariates") lmt <- cbind(start,time) if (any(lmt[,1]>lmt[,2])) stop("gss error in survexp.sshzd: start after follow-up time") nt <- dim(lmt)[1] if (is.null(covariates)) ncov <- 1 else ncov <- dim(covariates)[1] mn <- min(object$tdomain) mx <- max(object$tdomain) if ((min(start)mx)) stop("gss error in survexp.sshzd: time range beyond the domain") ## Calculate qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) if (is.null(covariates)) { zz <- NULL d.qd <- hzdcurve.sshzd(object,qd$pt) for (i in 1:nt) { ind <- (1:(2*qd.hize))[(qd$ptlmt[i,1])] if (length(ind)) { wk <- sum(d.qd[ind]*qd$wt[ind]) id.mx <- max(ind) if (lmt[i,2]=qd$pt[2*qd.hize]) wk <- d.qd[2*qd.hize]*qd$wt[2*qd.hize]*(lmt[i,2]-lmt[i,1])/gap[2*qd.hize] if ((lmt[i,1]>qd$pt[1])&(lmt[i,1]lmt[i,1]]) if (brk[i.wk]<=lmt[i,1]) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-lmt[i,1])/gap[i.wk] if (brk[i.wk]>=lmt[i,2]) wk <- d.qd[i.wk-1]*qd$wt[i.wk-1]*(lmt[i,2]-lmt[i,1])/gap[i.wk-1] if ((brk[i.wk]lmt[i,1])) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-brk[i.wk])/gap[i.wk]+ d.qd[i.wk-1]*qd$wt[i.wk-1]*(brk[i.wk]-lmt[i,1])/gap[i.wk-1] } } zz <- c(zz,wk) } } else { zz <- NULL for (j in 1:ncov) { zz.wk <- NULL d.qd <- hzdcurve.sshzd(object,qd$pt,covariates[j,,drop=FALSE]) for (i in 1:nt) { ind <- (1:(2*qd.hize))[(qd$ptlmt[i,1])] if (length(ind)) { wk <- sum(d.qd[ind]*qd$wt[ind]) id.mx <- max(ind) if (lmt[i,2]<=brk[id.mx+1]) wk <- wk-d.qd[id.mx]*qd$wt[id.mx]*(brk[id.mx+1]-lmt[i,2])/gap[id.mx] else wk <- wk+d.qd[id.mx+1]*qd$wt[id.mx+1]*(lmt[i,2]-brk[id.mx+1])/gap[id.mx+1] id.mn <- min(ind) if (lmt[i,1]=qd$pt[2*qd.hize]) wk <- d.qd[2*qd.hize]*qd$wt[2*qd.hize]*(lmt[i,2]-lmt[i,1])/gap[2*qd.hize] if ((lmt[i,1]>qd$pt[1])&(lmt[i,1]lmt[i,1]]) if (brk[i.wk]<=lmt[i,1]) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-lmt[i,1])/gap[i.wk] if (brk[i.wk]>=lmt[i,2]) wk <- d.qd[i.wk-1]*qd$wt[i.wk-1]*(lmt[i,2]-lmt[i,1])/gap[i.wk-1] if ((brk[i.wk]lmt[i,1])) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-brk[i.wk])/gap[i.wk]+ d.qd[i.wk-1]*qd$wt[i.wk-1]*(brk[i.wk]-lmt[i,1])/gap[i.wk-1] } } zz.wk <- c(zz.wk,wk) } zz <- cbind(zz,as.vector(zz.wk)) } if (ncov==1) zz <- as.vector(zz) } exp(-zz) } gss/R/print.R0000644000176200001440000001573412355360640012544 0ustar liggesusers## Print function for ssanova objects print.ssanova <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") if (x$method=="v") Method <- "GCV " if (x$method=="m") Method <- "GML.\n" if (x$method=="u") Method <- "Mallows CL " if (x$method=="m") cat("Smoothing parameters are selected by",Method) else cat("Smoothing parameters are selected by ",Method,"with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssanova0 objects print.ssanova0 <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") if (x$method=="v") Method <- "GCV.\n" if (x$method=="m") Method <- "GML.\n" if (x$method=="u") Method <- "Mallows CL.\n" cat("Smoothing parameters are selected by",Method) cat("\n") ## the rest are suppressed invisible() } ## Print function for gssanova objects print.gssanova <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssden objects print.ssden <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sscden objects print.sscden <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sshzd objects print.sshzd <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sshzd objects print.sscox <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssllrm objects print.ssllrm <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for summary.ssanova objects print.summary.ssanova <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") cat("\nEstimate of error standard deviation:",x$sigma,"\n") ## residuals res <- x$res cat("\nResiduals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss) cat("\nR square:",x$r.squared) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\n") invisible() } ## Print function for summary.gssanova objects print.summary.gssanova <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") if (x$family%in%c("Gamma","inverse.gaussian")) { cat("\n(Dispersion parameter for ",x$family, " family estimated to be ",format(x$dispersion),")\n\n",sep="") } else { cat("\n(Dispersion parameter for ",x$family, " family taken to be ",format(x$dispersion),")\n\n",sep="") } ## residuals res <- x$res cat("Working residuals (weighted):\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss,"\n") ## deviance residuals res <- x$dev.res cat("\nDeviance residuals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Deviance:",x$deviance) cat("\nNull deviance:",x$dev.null) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\n") invisible() } ## Print function for summary.gssanova objects print.summary.gssanova0 <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") if (x$method=="u") cat("\n(Dispersion parameter for ",x$family, " family taken to be ",format(x$dispersion),")\n\n",sep="") if (x$method=="v") cat("\n(Dispersion parameter for ",x$family, " family estimated to be ",format(x$dispersion),")\n\n",sep="") ## residuals res <- x$res cat("Working residuals (weighted):\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss,"\n") ## deviance residuals res <- x$dev.res cat("\nDeviance residuals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Deviance:",x$deviance) cat("\nNull deviance:",x$dev.null) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\nNumber of performance-oriented iterations:",x$iter) cat("\n\n") invisible() } gss/R/ssllrm.R0000644000176200001440000006173213267076744012737 0ustar liggesusers## Fit log-linear regression model ssllrm <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- mf$random <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Generate sub-basis nobs <- nrow(mf) if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssllrm: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in ssllrm: response missing in model") for (ylab in ynames) { if (!is.factor(mf[,ylab])) stop("gss error in ssllrm: response not a factor") } xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in ssllrm: missing covariate") ## Generate terms term <- mkterm(mf,type) term.labels <- labels(mt) facs <- attr(mt,"factors") ind.wk <- NULL for (lab in term.labels) ind.wk <- c(ind.wk,any(facs[ynames,lab])) term$labels <- term.labels[ind.wk] ## Generate quadrature qd.pt <- data.frame(levels(mf[,ynames[1]])) if (is.null(cnt)) wt.wk <- table(mf[,ynames[1]]) else { wt.wk <- NULL for (lvl in levels(mf[,ynames[1]])) wt.wk <- c(wt.wk,sum(cnt[mf[,ynames[1]]==lvl])) } qd.wt <- wt.wk/sum(wt.wk) if (length(ynames)>1) { for (ylab in ynames[-1]) { wk <- expand.grid(levels(mf[,ylab]),1:dim(qd.pt)[1]) qd.pt <- data.frame(qd.pt[wk[,2],],wk[,1]) if (is.null(cnt)) wt.wk <- table(mf[,ylab]) else { wt.wk <- NULL for (lvl in levels(mf[,ylab])) wt.wk <- c(wt.wk,sum(cnt[mf[,ylab]==lvl])) } qd.wt <- as.vector(outer(wt.wk/sum(wt.wk),qd.wt)) } } colnames(qd.pt) <- ynames nmesh <- dim(qd.pt)[1] x <- mf[,xnames,drop=FALSE] ## obtain unique covariate observations xx <- mf[,xnames,drop=FALSE] if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) xx <- cbind(xx,random$z) } xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) { xx.wt <- NULL for (x.wk in unique(xx)) xx.wt <- c(xx.wt,sum(cnt[xx==x.wk])) } else xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## Generate Random if (!is.null(random)) { ## z and qd.z z <- qd.z <- nlvl <- NULL for (ylab in ynames) { y.wk <- mf[,ylab] pt.wk <- qd.pt[,ylab] lvl.wk <- levels(y.wk) nlvl.wk <- length(lvl.wk) nlvl <- c(nlvl,nlvl.wk) z.aux <- diag(1,nlvl.wk-1) z.aux <- rbind(z.aux,rep(-1,nlvl.wk-1)) rownames(z.aux) <- lvl.wk for (i in 1:(nlvl.wk-1)) { z <- cbind(z,z.aux[y.wk,i]*random$z) for (j in 1:nmesh) { qd.z <- cbind(qd.z,z.aux[pt.wk[j],i]*random$z[!x.dup.ind,]) } } } nz <- dim(random$z)[2] nZ <- sum(nlvl-1)*nz qd.z <- aperm(array(qd.z,c(nx,nz,nmesh,nZ/nz)),c(3,1,2,4)) qd.z <- array(qd.z,c(nmesh,nx,nZ)) ## Sigma env <- list(sigma=random$sigma,nzeta=length(random$init),nz=nz,nlvl=nlvl) fun <- function(zeta,env) { ny <- length(env$nlvl) nze <- env$nzeta sigma <- env$sigma dm <- cumsum(env$nlvl-1)*env$nz zz <- matrix(0,dm[ny],dm[ny]) dm <- c(0,dm) for (i in 1:ny) { nlvl.wk <- nlvl[i] wk <- kronecker(diag(1,nlvl.wk-1)+1, sigma$fun(zeta[nze*(i-1)+(1:nze)],sigma$env)) zz[(dm[i]+1):dm[i+1],(dm[i]+1):dm[i+1]] <- wk } zz } Sigma <- list(fun=fun,env=env) ## init init <- rep(random$init,length(nlvl)) ## assemble Random <- list(z=z,qd.z=qd.z,sigma=Sigma,init=init) } else Random <- NULL ## Generate s, r, qd.s, and qd.r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.wk <- matrix(qd.s.wk,nmesh,nx) } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy,i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) if (!is.null(random)) { qd.r.wk0 <- array(c(qd.r.wk0,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("llrmnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.integer(cntsum), as.double(cnt), as.double(qd.r.wk0), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd+1)*nx+2*nobs+nn*(2*nn+5)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssllrm: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssllrm: Newton iteration fails to converge") assign("eta",fit$wk[1:(nqd*nx)],inherits=TRUE) assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[nqd*nx+2]-fit$wk[nqd*nx+1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } if (!is.null(random)) { vv.z <- 0 for (i in 1:nx) { mu.z <- apply(random$qd.z[,i,,drop=FALSE],2,sum)/nqd v.z <- apply(random$qd.z[,i,,drop=FALSE]^2,2,sum)/nqd v.z <- v.z - mu.z^2 vv.z <- vv.z + xx.wt[i]*v.z } ran.scal <- theta.wk - log10(sum(vv.z)/nz/sum(vv.r)*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration eta <- NULL cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } if (!is.null(random)) { vv.z <- 0 for (i in 1:nx) { mu.z <- apply(random$qd.z[,i,,drop=FALSE],2,sum)/nqd v.z <- apply(random$qd.z[,i,,drop=FALSE]^2,2,sum)/nqd v.z <- v.z - mu.z^2 vv.z <- vv.z + xx.wt[i]*v.z } ran.scal <- theta.wk - log10(sum(vv.z)/nz/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.basis,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } gss/R/mkran.R0000644000176200001440000000554713053636442012523 0ustar liggesusers## Make random effects for mixed-effect models mkran <- function(formula,data) { ## decipher formula form.wk <- terms.formula(formula)[[2]] terms <- strsplit(deparse(form.wk),' \\+ ')[[1]] if (length(terms)>1) { form <- as.formula(paste("~",terms[1])) zzz <- mkran(form,data) for (i in 2:length(terms)) { form <- as.formula(paste("~",terms[i])) zzz <- mkran1(zzz,mkran(form,data)) } return(zzz) } if (!("|"%in%strsplit(deparse(form.wk),'')[[1]])) stop("gss error in mkran: missing | in grouping formula") term.wk <- strsplit(deparse(form.wk),' \\| ')[[1]] with(data,{ ## make matrix Z z2.wk <- eval(parse(text=term.wk[2])) if (!is.factor(z2.wk)) stop(paste("gss error in mkran: ", term.wk[2], " should be a factor")) z <- NULL lvl.z2 <- levels(z2.wk) for (i in lvl.z2) z <- cbind(z,as.numeric(z2.wk==i)) ## make sigma function if (term.wk[1]=="1") { init <- 0 env <- length(levels(z2.wk)) fun <- function(zeta,env) diag(10^(-zeta),env) sigma <- list(fun=fun,env=env) } else { z1.wk <- eval(parse(text=term.wk[1])) if (!is.factor(z1.wk)) stop(paste("gss error in mkran: ", term.wk[1], " should be a factor")) ind <- lvl.wk <- NULL nz <- length(lvl.z2) nsig <- length(levels(z1.wk)) for (i in levels(z1.wk)) { zz.wk <- z2.wk[z1.wk==i,drop=TRUE] ind <- c(ind,list((1:nz)[lvl.z2%in%levels(zz.wk)])) lvl.wk <- c(lvl.wk,levels(zz.wk)) } if (max(table(lvl.wk)>1)) stop("gss error in mkran: ", term.wk[2], " should be nested under ", term.wk[1]) init <- rep(0, length(levels(z1.wk))) env <- list(size=nz,nsig=nsig,ind=ind) fun <- function(zeta,env) { wk <- rep(0,env$size) for (i in 1:env$nsig) wk[env$ind[[i]]] <- 10^(-zeta[i]) diag(wk) } sigma <- list(fun=fun,env=env) } list(z=z,sigma=sigma,init=init) }) } ## Combine random effects for mixed-effect models mkran1 <- function(ran1,ran2) { z <- cbind(ran1$z,ran2$z) env <- list(sz1=dim(ran1$z)[2],sig1=ran1$sigma,nz1=length(ran1$init), sz2=dim(ran2$z)[2],sig2=ran2$sigma,nz2=length(ran2$init)) fun <- function(zeta,env) { idx1 <- 1:env$sz1 idx2 <- env$sz1+(1:env$sz2) sig <- matrix(0,env$sz1+env$sz2,env$sz1+env$sz2) sig[idx1,idx1] <- env$sig1$fun(zeta[1:env$nz1],env$sig1$env) sig[idx2,idx2] <- env$sig2$fun(zeta[env$nz1+(1:env$nz2)],env$sig2$env) sig } sigma <- list(fun=fun,env=env) list(z=z,sigma=sigma,init=c(ran1$init,ran2$init)) } gss/R/ssanova0.R0000644000176200001440000002375213475773371013156 0ustar liggesusers## Fit ssanova model ssanova0 <- function(formula,type=NULL,data=list(),weights,subset, offset,na.action=na.omit,partial=NULL, method="v",varht=1,prec=1e-7,maxiter=30) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$method <- mf$varht <- mf$partial <- NULL mf$prec <- mf$maxiter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) ## Generate terms term <- mkterm(mf,type) ## Generate s, q, and y nobs <- dim(mf)[1] s <- q <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 q <- array(c(q,rk$fun(x,x,nu=i,env=rk$env,out=TRUE)),c(nobs,nobs,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL ## Prepare the data y <- model.response(mf,"numeric") w <- model.weights(mf) offset <- model.offset(mf) if (!is.null(offset)) { term$labels <- c(term$labels,"offset") term$offset <- list(nphi=0,nrk=0) y <- y - offset } if (!is.null(w)) { w <- sqrt(w) y <- w*y s <- w*s for (i in 1:nq) q[,,i] <- w*t(w*q[,,i]) } if (qr(s)$rank=nnull)&(nnull>0))) { stop("gss error in sspreg: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(s), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(y), qwk=as.double(q), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspreg: matrix s is rank deficient") if (info==-2) stop("gss error in sspreg: matrix q is indefinite") if (info==-1) stop("gss error in sspreg: input data have wrong dimensions") if (info==-3) stop("gss error in sspreg: unknown method for smoothing parameter selection.") } ## Return the fit c(list(method=method,theta=0), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Fit Multiple Smoothing Parameter REGression mspreg0 <- function(s,q,y,method="v",varht=1,prec=1e-7,maxiter=30) { ## Check inputs if (is.vector(s)) s <- as.matrix(s) if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3) &is.vector(y)&is.character(method))) { stop("gss error in mspreg: inputs are of wrong types") } nobs <- length(y) nnull <- dim(s)[2] nq <- dim(q)[3] if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs) &(nobs>=nnull)&(nnull>0)&(nq>1))) { stop("gss error in mspreg: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } ## Call RKPACK driver DMUDR z <- .Fortran("dmudr0", as.integer(code), as.double(s), # s as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(q), # q as.integer(nobs), as.integer(nobs), as.integer(nq), as.double(y), # y as.double(0), as.integer(0), as.double(prec), as.integer(maxiter), theta=double(nq), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), integer(nnull+nq), double(nobs*nobs*(nq+2)), info=integer(1),PACKAGE="gss")[c("theta","info")] ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in mspreg: matrix s is rank deficient") if (info==-2) stop("gss error in mspreg: matrix q is indefinite") if (info==-1) stop("gss error in mspreg: input data have wrong dimensions") if (info==-3) stop("gss error in mspreg: unknown method for smoothing parameter selection.") if (info==-4) stop("gss error in mspreg: iteration fails to converge, try to increase maxiter") if (info==-5) stop("gss error in mspreg: iteration fails to find a reasonable descent direction") } qwk <- 10^z$theta[1]*q[,,1] for (i in 2:nq) qwk <- qwk + 10^z$theta[i]*q[,,i] ## Call RKPACK driver DSIDR zz <- .Fortran("dsidr0", as.integer(code), swk=as.double(s), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(y), qwk=as.double(qwk), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Return the fit c(list(method=method,theta=z$theta), zz[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Obtain c & d for new y's getcrdr <- function(obj,r) { ## Check inputs if (is.vector(r)) r <- as.matrix(r) if (!(any(class(obj)=="ssanova0")&is.matrix(r))) { stop("gss error in getcrdr: inputs are of wrong types") } nobs <- length(obj$c) nnull <- length(obj$d) nr <- dim(r)[2] if (!((dim(r)[1]==nobs)&(nr>0))) { stop("gss error in getcrdr: inputs have wrong dimensions") } ## Call RKPACK ulitity DCRDR z <- .Fortran("dcrdr", as.double(obj$swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(obj$qraux), as.integer(obj$jpvt), as.double(obj$qwk), as.integer(nobs), as.double(obj$nlambda), as.double(r), as.integer(nobs), as.integer(nr), cr=double(nobs*nr), as.integer(nobs), dr=double(nnull*nr), as.integer(nnull), double(2*nobs), integer(1),PACKAGE="gss")[c("cr","dr")] ## Return cr and dr z$cr <- matrix(z$cr,nobs,nr) z$dr <- matrix(z$dr,nnull,nr) z } ## Obtain var-cov matrix for unpenalized terms getsms <- function(obj) { ## Check input if (!any(class(obj)=="ssanova0")) { stop("gss error in getsms: inputs are of wrong types") } nobs <- length(obj$c) nnull <- length(obj$d) ## Call RKPACK ulitity DSMS z <- .Fortran("dsms", as.double(obj$swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.integer(obj$jpvt), as.double(obj$qwk), as.integer(nobs), as.double(obj$nlambda), sms=double(nnull*nnull), as.integer(nnull), double(2*nobs), integer(1),PACKAGE="gss")["sms"] ## Return the nnull-by-nnull matrix matrix(z$sms,nnull,nnull) } gss/R/dsscden.R0000644000176200001440000001773012355360640013031 0ustar liggesusersdsscden <- ## Evaluate conditional density estimate function (object,y,x) { ## check input if (!("sscden"%in%class(object))) stop("gss error in dsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in dsscden: mismatched x variable names") if (length(object$ynames)==1&is.vector(y)) { y <- data.frame(y) colnames(y) <- object$ynames } if (!all(sort(object$ynames)==sort(colnames(y)))) stop("gss error in dsscden: mismatched y variable names") if ("sscden1"%in%class(object)) { qd.pt <- object$rho$env$qd.pt qd.wt <- object$rho$env$qd.wt d.qd <- d.sscden1(object,x,qd.pt,scale=FALSE) int <- apply(d.qd*qd.wt,2,sum) return(t(t(d.sscden1(object,x,y,scale=FALSE))/int)) } else { qd.pt <- object$yquad$pt qd.wt <- object$yquad$wt d.qd <- d.sscden(object,x,qd.pt) int <- apply(d.qd*qd.wt,2,sum) return(t(t(d.sscden(object,x,y))/int)) } } psscden <- ## Compute cdf for univariate density estimate function(object,q,x) { if (!("sscden"%in%class(object))) stop("gss error in psscden: not a sscden object") if (length(object$ynames)!=1) stop("gss error in psscden: y is not 1-D") if (("sscden1"%in%class(object))&!is.numeric(object$mf[,object$ynames])) stop("gss error in qssden: y is not continuous") if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain mn <- min(ydomain[[object$ynames]]) mx <- max(ydomain[[object$ynames]]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- object$ynames d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- object$ynames d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(p))[p>0&p<1] z <- NULL for (k in 1:dim(x)[1]) { d.qd.wk <- d.qd[,k]/sum(d.qd[,k]*qd$wt) p.wk <- cumsum(d.qd.wk*qd$wt) for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk2) { ## phi nphi <- 0 ## rk rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=fun.env) } else { ## phi phi.fun <- function(x,nu=1,env) { wk <- as.factor(names(env$env$code)[1]) env$fun(x,wk,env$env) } nphi <- 1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=fun.env) ## rk nrk <- 0 } } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist]][[2]] ## phi phi.env <- mkphi.cubic(range) phi.fun <- function(x,nu=1,env) env$fun(x,nu,env$env) nphi <- 1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.cubic(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- var.type[[vlist]][[2]] ## phi nphi <- 0 ## rk if (type.wk=="cubic.per") rk.env <- mkrk.cubic.per(range) if (type.wk=="linear") rk.env <- mkrk.linear(range) if (type.wk=="linear.per") rk.env <- mkrk.linear.per(range) if (type.wk=="sphere") rk.env <- mkrk.sphere(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="trig") { ## trigonometric splines range <- var.type[[vlist]][[2]] ## phi phi.env <- mkphi.trig(range) phi.fun <- function(x,nu=1,env) env$fun(x,nu,env$env) nphi <- 2 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.trig(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.env <- mkphi.tp(xdim,order,mesh,weight) phi.fun <- function(x,nu=1,env) { env$fun(x,nu,env$env) } nphi <- choose(xdim+order-1,xdim)-1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.tp(xdim,order,mesh,weight) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.env <- par$mkphi(par$env) phi.fun <- function(x,nu=1,env) { env$fun(x,nu,env$env) } iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) } rk.env <- par$mkrk(par$env) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- var.type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="trig") { ## trigonometric splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.trig(range) n.phi <- c(n.phi,2) ## rk rk.wk <- mkrk.trig(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi if (!all(as.logical(n.phi+bin.fac))) nphi <- 0 else { phi.env <- list(dim=dm,phi=phi.list,n.phi=n.phi,bin.fac=bin.fac) phi.fun <- function(x,nu=1,env) { ind <- nu - 1 z <- 1 for (i in 1:env$dim) { if (env$bin.fac[i]) { wk <- as.factor(names(env$phi[[i]]$env$code)[1]) z <- z * env$phi[[i]]$fun(x[[i]],wk,env$phi[[i]]$env) } else { code <- ind%%env$n.phi[i] + 1 ind <- ind%/%env$n.phi[i] z <- z * env$phi[[i]]$fun(x[[i]],code,env$phi[[i]]$env) } } z } nphi <- prod(n.phi+bin.fac) iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) } ## rk rk.env <- list(dim=dm,n.phi=n.phi,nphi=nphi, phi=phi.list,rk=rk.list) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { n.rk <- ifelse(env$n.phi,2,1) ind <- nu - !env$nphi z <- 1 for (i in 1:env$dim) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] if (code==n.rk[i]) { z <- z * env$rk[[i]]$fun(x[[i]],y[[i]], env$rk[[i]]$env,outer.prod) } else { z.wk <- 0 for (j in 1:env$n.phi[i]) { phix <- env$phi[[i]]$fun(x[[i]],j,env$phi[[i]]$env) phiy <- env$phi[[i]]$fun(y[[i]],j,env$phi[[i]]$env) if (outer.prod) z.wk <- z.wk + outer(phix,phiy) else z.wk <- z.wk + phix * phiy } z <- z * z.wk } } z } n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } term[[label]] <- list(vlist=vlist, iphi=iphi,nphi=nphi,phi=phi, irk=irk,nrk=nrk,rk=rk) } term } gss/R/ssanova9.R0000644000176200001440000004141212355360640013143 0ustar liggesusers## Fit ssanova model with correlated data ssanova9 <- function(formula,type=NULL,data=list(),subset, offset,na.action=na.omit,partial=NULL, method="v",alpha=1.4,varht=1, id.basis=NULL,nbasis=NULL,seed=NULL,cov, skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$method <- mf$varht <- mf$partial <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$cov <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssanova9: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate cov if (is.null(cov$fun)) { type <- cov[[1]] if (type=="arma") { pq <- cov[[2]] cov <- mkcov.arma(pq[1],pq[2],nobs) } if (type=="long") { if (nobsalpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*z$wk[2] if (method=="v") score <- score + (alpha.wk-alpha)*2*z$wk[2]/(1-z$wk[2]) } z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) score } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization tmp <- sum(r^2) if (is.null(s)) theta <- 0 else theta <- log10(sum(s^2)/nnull/tmp*nxi) / 2 log.la0 <- log10(tmp/sum(diag(q))) + theta ## lambda search fit <- NULL la <- c(log.la0,cov$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova9: iteration for model selection fails to converge") break } } } else { ww <- cov$fun(cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r) mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return lambda <- zz$est jk1 <- cv(lambda) q.wk <- 10^(theta)*q if (length(lambda)-1) ww <- cov$fun(lambda[-1],cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r) se.aux <- regaux(s.wk,10^theta*r.wk,q.wk,lambda[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL c(list(method=method,theta=theta,c=c,d=d,nlambda=lambda[1],zeta=lambda[-1]), fit[-3],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter (Gaussian) REGression mspreg91 <- function(s,r,id.basis,y,cov,method,alpha,varht,skip.iter) { ## get dimensions nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 nn <- nxi + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } q.wk <- 10^nlambda*r.wk0[id.basis,] if (length(theta)-nq) { ww <- cov$fun(theta[-(1:nq)],cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) } r.wk0 <- forwardsolve(t(ww),r.wk0) z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxi), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxi))), wk=double(3*nobs+nnull), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova9: evaluation of GML score fails") if (!nnull|method%in%c("u","v")) detw <- 2*sum(log(diag(ww))) else { wk <- qr.qty(qr(s),t(ww))[-(1:nnull),] detw <- sum(log(eigen(wk%*%t(wk))$value)) } if (method=="m") score <- z$score*exp(detw/(nobs-nnull)) if (method=="u") score <- z$wk[1]/varht+detw/nobs+2*alpha*z$wk[2] if (method=="v") score <- log(z$wk[1])+detw/nobs+2*alpha*z$wk[2]/(1-z$wk[2]) alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*z$wk[2] if (method=="v") score <- score + (alpha.wk-alpha)*2*z$wk[2]/(1-z$wk[2]) } z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment z <- sspreg91(s,r.wk,r.wk[id.basis,],y,cov,method,alpha,varht) theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } log.la0 <- log10(sum(r.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspreg91(s,r.wk,r.wk[id.basis,],y,cov,method,alpha,varht) nlambda <- z$nlambda log.th0 <- log.th0 + z$nlambda theta <- theta + z$theta ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search fit <- NULL counter <- 0 r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } theta.old <- theta theta <- c(theta,z$zeta) ## scale and shift cv if (length(theta)==nq) { ww <- cov$fun(cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) } tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova9: iteration for model selection fails to converge") break } } ## return theta <- zz$est jk1 <- cv(theta) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (length(theta)-nq) ww <- cov$fun(theta[-(1:nq)],cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r.wk) se.aux <- regaux(s.wk,r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL c(list(method=method,theta=theta[1:nq],c=c,d=d,nlambda=nlambda, zeta=theta[-(1:nq)]),fit[-3],list(se.aux=se.aux)) } mkcov.arma <- function(p,q,n) { ## check inputs if ((p<0)|(q<0)) stop("gss error in mkcov.arma: ARMA orders must be non-negative") if (p+q==0) stop("gss error in mkcov.arma: use ssanova for independent data") if (n<(p+1)) stop("gss error in mkcov.arma: AR order too high") env <- list(p=p,q=q,n=n) init <- rep(0,p+q) fun <- function(x,env) { p <- env$p q <- env$q n <- env$n ## arma coefficients if (p) { a <- (1-exp(-x[1:p]))/(1+exp(-x[1:p])) if (p-1) { for (j in 2:p) a[1:(j-1)] <- a[1:(j-1)]-a[j]*a[(j-1):1] } } else a <- NULL if (q) { b <- (1-exp(-x[p+(1:q)]))/(1+exp(-x[p+(1:q)])) if (q-1) { for (j in 2:q) b[1:(j-1)] <- b[1:(j-1)]-b[j]*b[(j-1):1] } } else b <- NULL ## psi psi <- 1 if (qq <- max(p-1,q)) { for(i in 1:qq) { wk <- ifelse(i<=q,-b[i],0) if(p) { for(j in 1:min(i,p)) wk <- wk + a[j]*psi[i-j+1] } psi<-c(psi,wk) } } ## autocovariance aa <- bb <- 1 if (p) aa <- c(aa,-a) if (q) bb <- c(bb,-b) if (length(bb)10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { z <- .Fortran("cdenrkl", cd=as.double(d), as.integer(nnull), as.double(aperm(qd.s,c(1,3,2))), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(t(fit0)), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nnull), double(nnull), double(nnull*nnull), double(nnull*nnull), integer(nnull), double(nnull), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sscden: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sscden: Newton iteration fails to converge") kl <- z$wt[1] } ## cfit cfit <- matrix(1,nmesh,nx) for (ylab in object$ynames) { y <- object$mf[[ylab]] if (is.factor(y)) { lvl <- levels(y) if (is.null(object$cnt)) wk <- table(y) else wk <- table(rep(y,object$cnt)) wk <- wk/sum(wk) nlvl <- length(wk) for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[id,] <- cfit[id,]*wk[j] } } else { if (!is.vector(y)) qd.wk <- object$yquad else qd.wk <- NULL qd.wk <- object$yquad form <- as.formula(paste("~",ylab)) wk <- ssden(form,data=object$mf,quad=qd.wk, domain=object$ydomain,alpha=object$alpha, id.basis=object$id.basis) cfit <- cfit*dssden(wk,qd.pt[ylab]) } } cfit <- t(cfit*qd.wt) ## return kl0 <- 0 for (i in 1:nx) { wk <- sum(log(fit0[i,]/cfit[i,])*fit0[i,]) kl0 <- kl0 + xx.wt[i]*wk } list(ratio=kl/kl0,kl=kl) } gss/R/project.ssden1.R0000644000176200001440000003771512355360640014255 0ustar liggesusers## Calculate square error projection from ssden1 objects project.ssden1 <- function(object,include,drop1=FALSE,...) { ## calculate log(rho) and integrals rho1 <- sum(object$rho.int) rho2 <- rho1^2-sum(object$rho.int^2)+sum(object$rho.int2) ## calculate cross integrals of rho, phi, and rk s <- object$int$s r <- object$int$r s.rho <- object$int$s.rho - s*rho1 r.rho <- object$int$r.rho - r*rho1 ## obtain ss, sr, rr int2 <- mkint2(object$mf,object$int$var.type, object$id.basis,object$quad,object$terms) ss <- int2$ss sr <- int2$sr rr <- int2$rr ## evaluate full model d <- object$d c <- object$c theta <- object$theta nq <- length(theta) s.eta <- ss%*%d r.eta <- tmp <- NULL r.wk <- r.rho.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d r.wk <- r.wk + 10^theta[i]*r[,i] r.rho.wk <- r.rho.wk + 10^theta[i]*r.rho[,i] sr.wk <- sr.wk + 10^theta[i]*sr[,,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } s.eta <- s.eta - s*(sum(s*d)+sum(r.wk*c)) r.eta <- r.eta - r*(sum(s*d)+sum(r.wk*c)) ss <- ss - outer(s,s,"*") sr.wk <- sr.wk - outer(s,r.wk,"*") rr.wk <- rr.wk - outer(r.wk,r.wk,"*") rho.eta <- sum(s.rho*d) + sum(r.rho.wk*c) eta2 <- sum(c*(rr.wk%*%c)) + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 + rho2-rho1^2 + 2*rho.eta ## calculate projection rkl <- function(include) { inc.wk <- union(names(object$mf),include) id.s <- id.q <- NULL for (label in inc.wk) { if (!any(label==object$terms$labels)) next term <- object$terms[[label]] if (term$nphi>0) id.s <- c(id.s,term$iphi+(1:term$nphi)-2) if (term$nrk>0) id.q <- c(id.q,term$irk+(1:term$nrk)-1) } ss.wk <- ss[id.s,id.s] r.eta.wk <- r.wk <- sr.wk <- rr.wk <- 0 for (i in id.q) { r.eta.wk <- r.eta.wk + 10^theta[i]*r.eta[,i] r.wk <- r.wk + 10^theta[i]*r[,i] sr.wk <- sr.wk + 10^theta[i]*sr[id.s,,i] for (j in id.q) { rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } } sr.wk <- sr.wk - outer(s[id.s],r.wk,"*") rr.wk <- rr.wk - outer(r.wk,r.wk,"*") v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s],r.eta.wk) nn <- length(mu) z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } ## projection if (drop1) { se <- NULL for (i in 1:length(include)) se <- c(se,rkl(include[-i])) ratio <- se/mse names(se) <- names(ratio) <- include } else se <- rkl(include) ratio <- se/mse list(ratio=ratio,se=se) } ## Calculate integrals of phi and rk for ssden1 mkint2 <- function(mf,type,id.basis,quad,term) { ## Obtain model terms mt <- attr(mf,"terms") xvars <- as.character(attr(mt,"variables"))[-1] xfacs <- attr(mt,"factors") term.labels <- labels(mt) vlist <- xvars[as.logical(apply(xfacs,1,sum))] ## Create phi and rk nbasis <- length(id.basis) phi.term <- rk.term <- list(NULL) nvar <- length(names(mf)) ns <- nq <- 0 for (label in term.labels) { ns <- ns+term[[label]]$nphi nq <- nq+term[[label]]$nrk phi.term[[label]] <- rk.term[[label]] <- list(NULL) vlist <- xvars[as.logical(xfacs[,label])] x <- mf[,vlist] dm <- length(vlist) phi <- rk <- NULL if (dm==1) { type.wk <- type[[vlist]][[1]] xx <- mf[id.basis,vlist] xmesh <- quad[[vlist]]$pt if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") fun <- mkrk.nominal(levels(x)) else fun <- mkrk.ordinal(levels(x)) if (nlevels(x)>2) { ## rk rk <- fun$fun(xmesh,xx,fun$env,TRUE) } else { ## phi wk <- as.factor(names(fun$env$code)[1]) phi <- fun$fun(xmesh,wk,fun$env) } } if (type.wk=="cubic") { ## cubic splines range <- type[[vlist]][[2]] ## phi phi.fun <- mkphi.cubic(range) phi <- phi.fun$fun(xmesh,1,phi.fun$env) ## rk rk.fun <- mkrk.cubic(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- type[[vlist]][[2]] ## rk if (type.wk=="cubic.per") rk.fun <- mkrk.cubic.per(range) if (type.wk=="linear") rk.fun <- mkrk.linear(range) if (type.wk=="linear.per") rk.fun <- mkrk.linear.per(range) if (type.wk=="sphere") rk.fun <- mkrk.sphere(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="tp") { ## thin-plate splines par <- type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.fun <- mkphi.tp(xdim,order,mesh,weight) nphi <- choose(xdim+order-1,xdim)-1 if (nphi>0) { for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } ## rk rk.fun <- mkrk.tp(xdim,order,mesh,weight) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="custom") { ## user-defined par <- type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.fun <- par$mkphi(par$env) for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } rk.fun <- par$mkrk(par$env) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } phi.term[[label]][[vlist]] <- phi if (is.null(rk)) rk.term[[label]][[vlist]] <- rk else { nmesh <- length(quad[[vlist]]$wt) rk.term[[label]][[vlist]] <- array(rk,c(nmesh,nbasis,1)) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic or linear splines range <- type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi id0 <- names(mf)%in%vlist nphi <- term[[label]]$nphi iphi <- term[[label]]$iphi if (nphi>0) { for (nu in 1:nphi) { ind <- nu - 1 for (i in 1:dm) { phi.wk <- phi.list[[i]] xmesh <- quad[[vlist[i]]]$pt if (bin.fac[i]) { wk <- as.factor(names(phi.wk$env$code)[1]) phi <- phi.wk$fun(xmesh,wk,phi.wk$env) } else { code <- ind%%n.phi[i] + 1 ind <- ind%/%n.phi[i] phi <- phi.wk$fun(xmesh,code,phi.wk$env) } phi.term[[label]][[vlist[i]]] <- cbind(phi.term[[label]][[vlist[i]]],phi) } } } ## rk n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) if (nrk>0) { for (nu in 1:nrk) { ind <- nu - !nphi for (i in 1:dm) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] xx <- mf[id.basis,vlist[[i]]] xmesh <- quad[[vlist[i]]]$pt if (code==n.rk[i]) { rk.wk <- rk.list[[i]] rk <- rk.wk$fun(xmesh,xx,rk.wk$env,TRUE) } else { rk <- 0 phi.wk <- phi.list[[i]] for (j in 1:n.phi[i]) { phix <- phi.wk$fun(xmesh,j,phi.wk$env) phiy <- phi.wk$fun(xx,j,phi.wk$env) rk <- rk + outer(phix,phiy) } } nmesh <- length(quad[[vlist[i]]]$wt) rk.term[[label]][[vlist[i]]] <- array(c(rk.term[[label]][[vlist[i]]],rk), c(nmesh,nbasis,nu)) } } } } } ## create arrays ss <- matrix(1,ns,ns) sr <- array(1,c(ns,nbasis,nq)) rr <- array(1,c(nbasis,nbasis,nq,nq)) for (label1 in term.labels) { if (!term[[label1]]$nphi) id.s1 <- NULL else id.s1 <- term[[label1]]$iphi+(1:term[[label1]]$nphi)-2 if (!term[[label1]]$nrk) id.r1 <- NULL else id.r1 <- term[[label1]]$irk+(1:term[[label1]]$nrk)-1 irk1 <- term[[label1]]$irk for (label2 in term.labels) { if (!term[[label2]]$nphi) id.s2 <- NULL else id.s2 <- term[[label2]]$iphi+(1:term[[label2]]$nphi)-2 if (!term[[label2]]$nrk) id.r2 <- NULL else id.r2 <- term[[label2]]$irk+(1:term[[label2]]$nrk)-1 irk2 <- term[[label2]]$irk for (xlab in names(mf)) { wmesh <- quad[[xlab]]$wt phi1 <- phi.term[[label1]][[xlab]] phi2 <- phi.term[[label2]][[xlab]] rk1 <- rk.term[[label1]][[xlab]] rk2 <- rk.term[[label2]][[xlab]] ## ss if (!is.null(id.s1)&!is.null(id.s2)) { if ((!is.null(phi1))&(!is.null(phi2))) { ss[id.s1,id.s2] <- ss[id.s1,id.s2]*(t(wmesh*phi1)%*%phi2) } else { if (!is.null(phi1)) { ss[id.s1,id.s2] <- ss[id.s1,id.s2]*apply(wmesh*matrix(phi1),2,sum) } else { if (!is.null(phi2)) { ss[id.s1,id.s2] <- t(t(ss[id.s1,id.s2])* apply(wmesh*matrix(phi2),2,sum)) } } } } ## sr if (!is.null(id.s1)&!is.null(id.r2)) { if ((!is.null(phi1))&(!is.null(rk2))) { for (i in id.r2) { sr[id.s1,,i] <- sr[id.s1,,i]*(t(wmesh*phi1)%*%rk2[,,i-irk2+1]) } } else { if (!is.null(phi1)) { sr[id.s1,,id.r2] <- sr[id.s1,,id.r2]*apply(wmesh*matrix(phi1),2,sum) } else { if (!is.null(rk2)) { for (i in id.r2) { sr[id.s1,,i] <- t(t(sr[id.s1,,i])* apply(wmesh*rk2[,,i-irk2+1],2,sum)) } } } } } ## rr if (!is.null(id.r1)&!is.null(id.r2)) { if ((!is.null(rk1))&(!is.null(rk2))) { for (i in id.r1) { for (j in id.r2) { rr[,,i,j] <- rr[,,i,j]*(t(wmesh*rk1[,,i-irk1+1])%*%rk2[,,j-irk2+1]) } } } else { if (!is.null(rk1)) { for (i in id.r1) { rr[,,i,id.r2] <- rr[,,i,id.r2]*apply(wmesh*rk1[,,i-irk1+1],2,sum) } } else { if (!is.null(rk2)) { for (j in id.r2) { rr[,,id.r1,j] <- aperm(aperm(rr[,,id.r1,j,drop=FALSE],c(2,1,3,4))* apply(wmesh*rk2[,,j-irk2+1],2,sum),c(2,1,3,4)) } } } } } } } } list(ss=ss,sr=sr,rr=rr) } gss/R/ssden1.R0000644000176200001440000005411412355360640012600 0ustar liggesusers## Fit density model ssden1 <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit, id.basis=NULL,nbasis=NULL,seed=NULL, domain=as.list(NULL),quad=NULL, prec=1e-7,maxiter=30) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$domain <- mf$quad <- mf$quad <- NULL mf$prec <- mf$maxiter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,sys.frame(sys.parent())) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Use ssden for 1-D estimation if (dim(mf)[2]==1) stop("use ssden to estimate 1-D density") ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssden1: id.basis out of range") nbasis <- length(id.basis) } ## Set domain and type, generate rho and quadrature if (is.null(quad)) quad <- as.list(NULL) rho <- rho.log <- as.list(NULL) rho.int <- rho.int2 <- NULL for (xlab in names(mf)) { x <- mf[[xlab]] if (is.factor(x)) { ## factor variable domain[[xlab]] <- NULL wt <- as.numeric(table(x)) rho[[xlab]] <- wt/sum(wt) quad[[xlab]] <- list(pt=unique(x),wt=rho[[xlab]]) rho.log[[xlab]] <- log(rho[[xlab]]) rho.int <- c(rho.int,sum(rho[[xlab]]*log(rho[[xlab]]))) rho.int2 <- c(rho.int2,sum(rho[[xlab]]*(log(rho[[xlab]]))^2)) } if (is.vector(x)&!is.factor(x)) { ## numerical vector if (is.null(domain[[xlab]])) { mn <- min(x) mx <- max(x) domain[[xlab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else domain[[xlab]] <- c(min(domain[[xlab]]),max(domain[[xlab]])) if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",domain[[xlab]]) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],domain[[xlab]]) } form <- as.formula(paste("~",xlab)) rho[[xlab]] <- ssden(form,data=mf,type=type[xlab], domain=data.frame(domain[xlab]), alpha=2,id.basis=id.basis) qd.wk <- rho[[xlab]]$quad rho.wk <- dssden(rho[[xlab]],qd.wk$pt) qd.wk$pt <- qd.wk$pt[[1]] qd.wk$wt <- rho.wk*qd.wk$wt quad[[xlab]] <- qd.wk rho.log[[xlab]] <- log(rho.wk) rho.int <- c(rho.int,sum(log(rho.wk)*qd.wk$wt)) rho.int2 <- c(rho.int2,sum((log(rho.wk))^2*qd.wk$wt)) } if (is.matrix(x)) { ## numerical matrix if (is.null(quad[[xlab]])|is.null(quad)) stop("gss error in ssden1: no default quadrature") else { qd.wk <- quad[[xlab]] qd.wk$pt <- data.frame(I(qd.wk$pt)) colnames(qd.wk$pt) <- xlab form <- as.formula(paste("~",xlab)) rho[[xlab]] <- ssden(form,data=mf,type=type[xlab],quad=qd.wk, alpha=2,id.basis=id.basis) rho.wk <- dssden(rho[[xlab]],qd.wk$pt) quad[[xlab]]$wt <- rho.wk*quad[[xlab]]$wt rho.log[[xlab]] <- log(rho.wk) rho.int <- c(rho.int,sum(log(rho.wk)*quad[[xlab]]$wt)) rho.int2 <- c(rho.int2,sum((log(rho.wk))^2*quad[[xlab]]$wt)) } } } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] int <- mkint(mf,type,id.basis,quad,term,rho.log,rho.int) ## Generate s, r, and q s <- r <- NULL nq <- 0 for (label in term$labels) { x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (!is.null(s)) { nnull <- dim(s)[2] ## Check s rank if (qr(s)$rankalpha,(alpha.wk-alpha)*trc,0) cv+adj } ## initialization mu.r <- apply(wt*r,2,sum) v.r <- apply(wt*r^2,2,sum) mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) if (is.null(s)) theta <- 0 else theta <- log10(sum(v.s-mu.s^2)/nnull/sum(v.r-mu.r^2)*nxi) / 2 log.la0 <- log10(sum(v.r-mu.r^2)/sum(diag(q))) + theta ## lambda search cd <- rep(0,nxi+nnull) la <- log.la0 tol <- 0 scal <- NULL mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } ## return jk1 <- cv(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=zz$est,theta=theta,c=c,d=d,scal=scal,cv=zz$min) } ## Calculate integrals of phi and rk for ssden1 mkint <- function(mf,type,id.basis,quad,term,rho,rho.int) { ## Obtain model terms mt <- attr(mf,"terms") xvars <- as.character(attr(mt,"variables"))[-1] xfacs <- attr(mt,"factors") term.labels <- labels(mt) vlist <- xvars[as.logical(apply(xfacs,1,sum))] ## Set types for marginals var.type <- NULL for (xlab in vlist) { x <- mf[,xlab] if (!is.null(type[[xlab]])) { ## Check consistency and set default parameters type.wk <- type[[xlab]][[1]] if (!(type.wk%in%c("ordinal","nominal","cubic","linear","per", "cubic.per","linear.per","tp","sphere","custom"))) stop("gss error in mkint: unknown type") if (type.wk%in%c("ordinal","nominal")) { par.wk <- NULL if (!is.factor(x)) stop("gss error in mkint: wrong type") } if (type.wk%in%c("cubic","linear")) { if (length(type[[xlab]])==1) { mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkint: wrong type") } if (type.wk%in%c("per","cubic.per","linear.per")) { if (type.wk=="per") type.wk <- "cubic.per" if (length(type[[xlab]])==1) stop("gss error in mkint: missing domain of periodicity") else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkint: wrong type") } if (type.wk=="tp") { if (length(type[[xlab]])==1) par.wk <- list(order=2,mesh=x,weight=1) else { par.wk <- par.wk1 <- type[[xlab]][[2]] if (length(par.wk1)==1) par.wk <- list(order=par.wk1,mesh=x,weight=1) if (is.null(par.wk$mesh)) par.wk$mesh <- x if (is.null(par.wk$weight)) par.wk$weight <- 1 } if (dim(as.matrix(x))[2]!=dim(as.matrix(par.wk$mesh))[2]) stop("gss error in mkint: wrong dimension in normalizing mesh") } if (type.wk=="sphere") { if (length(type[[xlab]])==1) par.wk <- 2 else par.wk <- type[[xlab]][[2]] if (!(par.wk%in%(2:4))) stop("gss error in mkint: spherical order not implemented") } if (type.wk=="custom") par.wk <- type[[xlab]][[2]] } else { ## Set default types if (is.factor(x)) { ## categorical variable if (is.ordered(x)) type.wk <- "ordinal" else type.wk <- "nominal" par.wk <- NULL } else { ## numerical variable if (is.vector(x)) { type.wk <- "cubic" mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else { type.wk <- "tp" par.wk <- list(order=2,mesh=x,weight=1) } } } var.type[[xlab]] <- list(type.wk,par.wk) } ## Create phi and rk nbasis <- length(id.basis) nvar <- length(names(mf)) s <- r <- s.rho <- r.rho <- NULL ns <- nq <- 0 for (label in term.labels) { ns <- ns+term[[label]]$nphi nq <- nq+term[[label]]$nrk vlist <- xvars[as.logical(xfacs[,label])] x <- mf[,vlist] dm <- length(vlist) phi <- rk <- NULL if (dm==1) { type.wk <- var.type[[vlist]][[1]] xx <- mf[id.basis,vlist] xmesh <- quad[[vlist]]$pt if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") fun <- mkrk.nominal(levels(x)) else fun <- mkrk.ordinal(levels(x)) if (nlevels(x)>2) { ## rk rk <- fun$fun(xmesh,xx,fun$env,TRUE) } else { ## phi wk <- as.factor(names(fun$env$code)[1]) phi <- fun$fun(xmesh,wk,fun$env) } } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist]][[2]] ## phi phi.fun <- mkphi.cubic(range) phi <- phi.fun$fun(xmesh,1,phi.fun$env) ## rk rk.fun <- mkrk.cubic(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- var.type[[vlist]][[2]] ## rk if (type.wk=="cubic.per") rk.fun <- mkrk.cubic.per(range) if (type.wk=="linear") rk.fun <- mkrk.linear(range) if (type.wk=="linear.per") rk.fun <- mkrk.linear.per(range) if (type.wk=="sphere") rk.fun <- mkrk.sphere(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.fun <- mkphi.tp(xdim,order,mesh,weight) nphi <- choose(xdim+order-1,xdim)-1 if (nphi>0) { for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } ## rk rk.fun <- mkrk.tp(xdim,order,mesh,weight) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.fun <- par$mkphi(par$env) for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } rk.fun <- par$mkrk(par$env) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } wmesh <- quad[[vlist]]$wt if (!is.null(phi)) { s.rho.wk <- rho.int*sum(wmesh*phi) s.rho.wk[names(mf)==vlist] <- sum(wmesh*rho[[vlist]]*phi) s <- c(s,sum(wmesh*phi)) s.rho <- c(s.rho,sum(s.rho.wk)) } if (!is.null(rk)) { r.rho.wk <- outer(apply(wmesh*rk,2,sum),rho.int) r.rho.wk[,names(mf)==vlist] <- apply(wmesh*rho[[vlist]]*rk,2,sum) r <- cbind(r,apply(wmesh*rk,2,sum)) r.rho <- cbind(r.rho,apply(r.rho.wk,1,sum)) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- var.type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic or linear splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi id0 <- names(mf)%in%vlist nphi <- term[[label]]$nphi iphi <- term[[label]]$iphi if (nphi>0) { for (nu in 1:nphi) { ind <- nu - 1 s.wk <- 1 s.rho.wk <- rho.int s.rho.wk[id0] <- 1 for (i in 1:dm) { phi.wk <- phi.list[[i]] xmesh <- quad[[vlist[i]]]$pt if (bin.fac[i]) { wk <- as.factor(names(phi.wk$env$code)[1]) phi <- phi.wk$fun(xmesh,wk,phi.wk$env) } else { code <- ind%%n.phi[i] + 1 ind <- ind%/%n.phi[i] phi <- phi.wk$fun(xmesh,code,phi.wk$env) } wmesh <- quad[[vlist[i]]]$wt s.wk <- s.wk*sum(wmesh*phi) id1 <- names(mf)==vlist[i] s.rho.wk[id1] <- s.rho.wk[id1]*sum(wmesh*rho[[vlist[i]]]*phi) s.rho.wk[!id1] <- s.rho.wk[!id1]*sum(wmesh*phi) } s <- c(s,s.wk) s.rho <- c(s.rho,sum(s.rho.wk)) } } ## rk n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) if (nrk>0) { for (nu in 1:nrk) { ind <- nu - !nphi r.wk <- 1 r.rho.wk <- outer(rep(1,nbasis),rho.int) r.rho.wk[,id0] <- 1 for (i in 1:dm) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] xx <- mf[id.basis,vlist[[i]]] xmesh <- quad[[vlist[i]]]$pt if (code==n.rk[i]) { rk.wk <- rk.list[[i]] rk <- rk.wk$fun(xmesh,xx,rk.wk$env,TRUE) } else { rk <- 0 phi.wk <- phi.list[[i]] for (j in 1:n.phi[i]) { phix <- phi.wk$fun(xmesh,j,phi.wk$env) phiy <- phi.wk$fun(xx,j,phi.wk$env) rk <- rk + outer(phix,phiy) } } wmesh <- quad[[vlist[i]]]$wt r.wk <- r.wk*apply(wmesh*rk,2,sum) id1 <- names(mf)==vlist[i] r.rho.wk[,id1] <- r.rho.wk[,id1]*apply(wmesh*rho[[vlist[i]]]*rk,2,sum) r.rho.wk[,!id1] <- r.rho.wk[,!id1]*apply(wmesh*rk,2,sum) } r <- cbind(r,r.wk) r.rho <- cbind(r.rho,apply(r.rho.wk,1,sum)) } } } } list(s=s,r=r,s.rho=s.rho,r.rho=r.rho,var.type=var.type) } gss/R/sscden.R0000644000176200001440000003735112355360640012666 0ustar liggesusers## Fit log-linear regression model sscden <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1.4, id.basis=NULL,nbasis=NULL,seed=NULL, ydomain=as.list(NULL),yquad=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$ydomain <- mf$yquad <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) nobs <- nrow(mf) cnt <- model.weights(mf) if (is.null(cnt)) data$cnt <- rep(1,nobs) else { data$cnt <- cnt mf$"(weights)" <- NULL } ## Generate sub-basis nobs <- nrow(mf) if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscden: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in sscden: response missing in model") xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in sscden: missing covariate") ## Set ydomain and type mtrx.y <- FALSE for (ylab in ynames) { y <- mf[[ylab]] if (!is.factor(y)) { if (is.vector(y)) { if (is.null(ydomain[[ylab]])) { mn <- min(y) mx <- max(y) ydomain[[ylab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else ydomain[[ylab]] <- c(min(ydomain[[ylab]]),max(ydomain[[ylab]])) if (is.null(type[[ylab]])) type[[ylab]] <- list("cubic",ydomain[[ylab]]) else { if (length(type[[ylab]])==1) type[[ylab]] <- list(type[[ylab]][[1]],ydomain[[ylab]]) } } else mtrx.y <- TRUE } } ydomain <- data.frame(ydomain) ## Generate terms term <- mkterm(mf,type) term.labels <- labels(mt) facs <- attr(mt,"factors") ind.wk <- NULL for (lab in term.labels) ind.wk <- c(ind.wk,any(facs[ynames,lab])) term$labels <- term.labels[ind.wk] ## Generate quadrature if (is.null(yquad)) { if (mtrx.y) stop("gss error in sscden: no default quadrature") yquad <- ssden(response,id.basis=id.basis,data=data,weights=cnt, alpha=2,domain=ydomain)$quad } qd.pt <- yquad$pt qd.wt <- yquad$wt nmesh <- length(qd.wt) ## obtain unique covariate observations x <- xx <- mf[,xnames,drop=FALSE] xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) xx <- rep(xx,cnt) xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## Generate s, r, qd.s, and qd.r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.wk <- matrix(qd.s.wk,nmesh,nx) } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy,i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- 10^(lambda)*r.wk0[id.basis,] qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("cdennewton", cd=as.double(cd), as.integer(nn), as.double(q.wk), as.integer(nxi), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(qd.r.wk0), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd+1)*nx+2*nobs+nn*(2*nn+5)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscden: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscden: Newton iteration fails to converge") assign("eta",fit$wk[1:(nqd*nx)],inherits=TRUE) assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[nqd*nx+2]-fit$wk[nqd*nx+1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration eta <- NULL cd <- rep(0,nn) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } if (nq==1) { jk1 <- cv.s(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=zz$est,theta=theta,c=c,d=d,cv=jk1,fit=t(eta))) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } lambda <- zz$est ## early return if (skip.iter) { jk1 <- cv.s(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=zz$est,theta=theta,c=c,d=d,cv=jk1,fit=t(eta))) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscden: CV iteration fails to converge") break } } ## return jk1 <- cv.m(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,theta=zz$est,c=c,d=d,cv=jk1,fit=t(eta))) } gss/R/project.gssanova.R0000644000176200001440000002750112355360640014671 0ustar liggesusers## Calculate Kullback-Leibler projection from gssanova objects project.gssanova <- function(object,include,...) { if (class(object)[1]=="gssanova0") stop("gss error: Kullback-Leibler projection is not implemented for gssanova0") nobs <- nrow(object$mf) nxi <- length(object$id.basis) labels.p <- object$lab.p ## evaluate full model family <- object$family eta <- object$eta y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) if(is.null(wt)) wt <- rep(1,nobs) offset <- model.offset(object$mf) if (!is.null(object$random)) { if (is.null(offset)) offset <- 0 offset <- offset + object$random$z%*%object$b } nu <- object$nu y0 <- switch(family, binomial=y0.binomial(y,eta,wt), poisson=y0.poisson(eta), Gamma=y0.Gamma(eta), inverse.gaussian=y0.inverse.gaussian(eta), nbinomial=y0.nbinomial(y,eta,nu), weibull=y0.weibull(y,eta,nu), lognorm=y0.lognorm(y,eta,nu), loglogis=y0.loglogis(y,eta,nu)) # calculate constant fit cfit <- switch(family, binomial=cfit.binomial(y,wt,offset), poisson=cfit.poisson(y,wt,offset), Gamma=cfit.Gamma(y,wt,offset), inverse.gaussian=cfit.inverse.gaussian(y,wt,offset), nbinomial=cfit.nbinomial(y,wt,offset,nu), weibull=cfit.weibull(y,wt,offset,nu), lognorm=cfit.lognorm(y,wt,offset,nu), loglogis=cfit.loglogis(y,wt,offset,nu)) # calculate total entropy kl0 <- switch(family, binomial=kl.binomial(eta,cfit,y0$wt), poisson=kl.poisson(eta,cfit,wt), Gamma=kl.Gamma(eta,cfit,wt), inverse.gaussian=kl.inverse.gaussian(eta,cfit,wt), nbinomial=kl.nbinomial(eta,cfit,wt,y0$nu), weibull=kl.weibull(eta,cfit,wt,nu,y0$int), lognorm=kl.lognorm(eta,cfit,wt,nu,y0), loglogis=kl.loglogis(eta,cfit,wt,nu,y0)) ## extract terms in subspace s <- matrix(1,nobs,1) philist <- object$term[["1"]]$iphi r <- NULL theta <- NULL nq.wk <- nq <- 0 for (label in object$terms$labels) { if (label=="1") next if (label%in%labels.p) next x <- object$mf[,object$term[[label]]$vlist] x.basis <- object$mf[object$id.basis,object$term[[label]]$vlist] nphi <- object$term[[label]]$nphi nrk <- object$term[[label]]$nrk if (nphi) { phi <- object$term[[label]]$phi for (i in 1:nphi) { if (!any(label==include)) next philist <- c(philist,object$term[[label]]$iphi+(i-1)) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } } if (nrk) { rk <- object$term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)), c(nobs,nxi,nq)) } } } if (!is.null(object$partial)) { nu <- length(object$d)-length(object$lab.p) matx.p <- model.matrix(object$partial$mt,object$mf)[,-1,drop=FALSE] matx.p <- scale(matx.p) for (label in labels.p) { nu <- nu+1 if (!any(label==include)) next philist <- c(philist,nu) s <- cbind(s,matx.p[,label]) } } ## calculate projection my.wls <- function(theta1=NULL) { if (!nq) { q <- matrix(0) sr <- cbind(s,0) z <- ngreg.proj(dc,family,sr,q,y0,wt,offset,nu) } else { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 sr <- 0 for (i in 1:nq) sr <- sr + 10^theta.wk[i]*r[,,i] q <- sr[object$id.basis,] sr <- cbind(s,sr) z <- ngreg.proj(dc,family,sr,q,y0,wt,offset,nu) } assign("dc",z$dc,inherits=TRUE) assign("eta1",z$eta,inherits=TRUE) z$kl } cv.wk <- function(theta) cv.scale*my.wls(theta)+cv.shift ## initialization if (nq) { r.wk <- 0 for (i in 1:nq) r.wk <- r.wk + 10^theta[i]*r[,,i] if (is.null(s)) theta.wk <- 0 else theta.wk <- log10(sum(s^2)/ncol(s)/sum(r.wk^2)*nxi) / 2 theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(r[cbind(object$id.basis,1:nxi,i)])) fix <- rev(order(tmp))[1] } ## projection if (nq) dc <- c(object$d[philist],10^(-theta.wk)*object$c) else dc <- c(object$d[philist],0) eta1 <- NULL if (nq>1) { if (object$skip.iter) kl <- my.wls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.wls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=1,ndigit=7) kl <- my.wls(zz$est) } } else kl <- my.wls() ## check kl1 <- switch(family, binomial=kl.binomial(eta1,cfit,y0$wt), poisson=kl.poisson(eta1,cfit,wt), Gamma=kl.Gamma(eta1,cfit,wt), inverse.gaussian=kl.inverse.gaussian(eta1,cfit,wt), nbinomial=kl.nbinomial(eta1,cfit,wt,y0$nu), weibull=kl.weibull(eta1,cfit,wt,nu,y0$int), lognorm=kl.lognorm(eta1,cfit,wt,nu,y0), loglogis=kl.loglogis(eta1,cfit,wt,nu,y0)) list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } ## KL projection with Non-Gaussian regression ngreg.proj <- function(dc,family,sr,q,y0,wt,offset,nu) { ## initialization q <- 10^(-5)*q eta <- sr%*%dc nobs <- length(eta) nn <- ncol(as.matrix(sr)) nxi <- ncol(q) nnull <- nn-nxi if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl+t(dc[-(1:nnull)])%*%q%*%dc[-(1:nnull)]/2 ## Newton iteration dc.new <- eta.new <- NULL kl.line <- function(x) { assign("dc.new",dc+x*dc.diff,inherits=TRUE) eta.wk <- sr%*%dc.new if (!is.null(offset)) eta.wk <- eta.wk + offset assign("eta.new",eta.wk,inherits=TRUE) fit.wk <- switch(family, binomial=proj0.binomial(y0,eta.new,offset), poisson=proj0.poisson(y0,eta.new,wt,offset), Gamma=proj0.Gamma(y0,eta.new,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta.new,wt,offset), nbinomial=proj0.nbinomial(y0,eta.new,wt,offset), weibull=proj0.weibull(y0,eta.new,wt,offset,nu), lognorm=proj0.lognorm(y0,eta.new,wt,offset,nu), loglogis=proj0.loglogis(y0,eta.new,wt,offset,nu)) assign("fit1",fit.wk,inherits=TRUE) fit1$kl+t(dc.new[-(1:nnull)])%*%q%*%dc.new[-(1:nnull)]/2 } iter <- 0 flag <- 0 flag2 <- 0 repeat { iter <- iter+1 ## weighted least squares fit if (!is.finite(sum(fit1$wt,fit1$ywk))) { if (flag) stop("gss error in project.gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl iter <- 0 flag <- 1 next } mumax <- max(abs(t(sr)%*%fit1$u+c(rep(0,nnull),q%*%dc[-(1:nnull)]))) w <- sqrt(as.vector(fit1$wt)) z <- .Fortran("reg", as.double(w*sr), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(w*fit1$ywk), as.integer(4), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), double(nn*nn), double(nn), as.integer(rep(0,nn)), double(max(nobs,nn)), integer(1), integer(1), PACKAGE="gss")["dc"] dc.diff <- z$dc-dc repeat { kl.new <- kl.line(1) if (!is.finite(kl.new)) { dc.diff <- dc.diff/2 next } if (!flag2) { if (kl.new-kl<1e-7*(1+abs(kl))) break } zz <- nlm0(kl.line,c(0,1),1e-3) kl.new <- kl.line(zz$est) break } disc0 <- max((mumax/(1+kl))^2,abs(kl.new-kl)/(1+kl)) disc <- sum(fit1$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(fit1$wt) if (is.nan(disc)) { if (flag) stop("gss error in project.gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl iter <- 0 flag <- 1 next } dc <- dc.new eta <- eta.new kl <- kl.new if (min(disc0,disc)<1e-5) break if (iter<=30) next if (!flag2) { flag2 <- 1 iter <- 0 next } warning("gss warning in gssanova: Newton iteration fails to converge") break } fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl list(dc=dc,eta=eta,kl=kl) } gss/R/predict1.ssanova.R0000644000176200001440000001056613053705502014566 0ustar liggesusers## S3 method predict1 <- function (object,...) UseMethod("predict1") ## Calculate prediction and Bayesian SE from ssanova objects predict1.ssanova <- function(object,contr=c(1,-1),newdata,se.fit=TRUE, include=c(object$terms$labels,object$lab.p),...) { ncontr <- length(contr) nnew <- nrow(newdata[[1]]) nbasis <- length(object$id.basis) nnull <- length(object$d) nz <- length(object$b) nn <- nbasis + nnull + nz labels.p <- object$lab.p ## Extract included terms term <- object$terms pmean.c <- ss.c <- rr.c <- 0 for (jj in 1:ncontr) { philist <- rklist <- NULL s <- r <- NULL nq <- 0 for (label in include) { if (label=="1") { philist <- c(philist,term[[label]]$iphi) s <- cbind(s,rep(1,len=nnew)) next } if (label%in%labels.p) next if (label=="offset") next xnew <- newdata[[jj]][,term[[label]]$vlist] x <- object$mf[object$id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { iphi <- term[[label]]$iphi phi <- term[[label]]$phi for (i in 1:nphi) { philist <- c(philist,iphi+(i-1)) s <- cbind(s,phi$fun(xnew,nu=i,env=phi$env)) } } if (nrk) { irk <- term[[label]]$irk rk <- term[[label]]$rk for (i in 1:nrk) { rklist <- c(rklist,irk+(i-1)) nq <- nq+1 r <- array(c(r,rk$fun(xnew,x,nu=i,env=rk$env,out=TRUE)),c(nnew,nbasis,nq)) } } } if (!is.null(object$partial)) { vars.p <- as.character(attr(object$partial$mt,"variables"))[-1] facs.p <- attr(object$partial$mt,"factors") vlist <- vars.p[as.logical(apply(facs.p,1,sum))] for (lab in labels.p) { if (lab%in%include) { vlist.wk <- vars.p[as.logical(facs.p[,lab])] vlist <- vlist[!(vlist%in%vlist.wk)] } } if (length(vlist)) { for (lab in vlist) newdata[[jj]][[lab]] <- 0 } matx.p <- model.matrix(object$partial$mt,newdata[[jj]])[,-1,drop=FALSE] matx.p <- sweep(matx.p,2,object$partial$center) matx.p <- sweep(matx.p,2,object$partial$scale,"/") nu <- nnull-dim(matx.p)[2] for (label in labels.p) { nu <- nu+1 if (label%in%include) { philist <- c(philist,nu) s <- cbind(s,matx.p[,label]) } } } r.wk <- matrix(0,nnew,nbasis) nq <- 0 for (i in rklist) { nq <- nq + 1 r.wk <- r.wk + 10^object$theta[i]*r[,,nq] } ## random effects if (nz) { if (is.null(newdata[[jj]]$random)) z.wk <- matrix(0,nnew,nz) else z.wk <- newdata[[jj]]$random r.wk <- cbind(r.wk,z.wk) } ## Compute posterior mean nphi <- length(philist) pmean <- as.vector(r.wk%*%c(object$c,object$b)) if (nphi) pmean <- pmean + as.vector(s%*%object$d[philist]) if (any(include=="offset")) { if (is.null(model.offset(object$mf))) stop("gss error: no offset in the fit") offset <- newdata[[jj]]$offset if (is.null(offset)) offset <- newdata[[jj]]$"(offset)" if (is.null(offset)) stop("gss error: missing offset") pmean <- pmean + offset } pmean.c <- pmean.c + contr[jj]*pmean if (se.fit) { ss <- matrix(0,nnull,nnew) if (!is.null(philist)) ss[philist,] <- t(s) rr <- t(r.wk%*%object$se.aux$vec) } ss.c <- ss.c + contr[jj]*ss rr.c <- rr.c + contr[jj]*rr } if (se.fit) { b <- object$varht/10^object$nlambda ## Compute posterior variance wk <- object$se.aux$hfac%*%rbind(ss.c,rr.c) pse <- sqrt(b*apply(wk^2,2,sum)) list(fit=pmean.c,se.fit=pse) } else pmean.c } gss/R/family.cv.R0000644000176200001440000001544212440620154013266 0ustar liggesusers##%%%%%%%%%% Binomial Family %%%%%%%%%% ## Calculate CV score for binomial regression cv.binomial <- function(y,eta,wt,hat,alpha) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]==1) { if ((max(y)>1)|(min(y)<0)) stop("gss error: binomial responses should be between 0 and 1") m <- rep(1,dim(y)[1]) } else { if (min(y)<0) stop("gss error: paired binomial response should be nonnegative") m <- y[,1]+y[,2] y <- y[,1]/m } wtt <- wt * m odds <- exp(eta) p <- odds/(1+odds) w <- p/(1+odds) lkhd <- -sum(wtt*(y*eta-log(1+odds)))/sum(wtt) aux1 <- sum(hat/w)/(sum(wtt)-sum(hat)) aux2 <- sum(wtt*y/(1+odds))/sum(wtt) list(score=lkhd+abs(alpha)*aux1*aux2,varht=1,w=as.vector(wtt*w)) } ##%%%%%%%%%% Poisson Family %%%%%%%%%% ## Calculate CV score for Poisson regression cv.poisson <- function(y,eta,wt,hat,alpha,sr,q) { if (is.null(wt)) wt <- rep(1,length(y)) if (min(y)<0) stop("gss error: Poisson response should be nonnegative") nxi <- ncol(q) nn <- ncol(sr) nnull <- nn-nxi lambda <- exp(eta) w <- as.vector(lambda) lkhd <- -sum(wt*(y*eta-lambda))/sum(wt*y) ## matrix H mu <- apply(wt*w*sr,2,sum)/sum(wt*w) v <- t(sr)%*%(wt*w*sr)/sum(wt*w)-outer(mu,mu) v[(nnull+1):nn,(nnull+1):nn] <- v[(nnull+1):nn,(nnull+1):nn]+q/sum(wt*y) ## Cholesky decomposition of H z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") while (v[rkv,rkv]=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") u <- nu*(delta-(xx^nu-zz^nu)*exp(-nu*eta)) w <- nu^2*(xx^nu-zz^nu)*exp(-nu*eta) lkhd <- sum(wt*((xx^nu-zz^nu)*exp(-nu*eta)-delta*(nu*(log(xx)-eta)+log(nu))))/sum(wt) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*abs(u))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } ##%%%%%%%%%% Log Normal Family %%%%%%%%%% ## Calculate CV score for log normal regression cv.lognorm <- function(y,eta,wt,hat,nu,alpha) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) u <- nu*(delta*(s.xx-xx)-(s.xx-s.zz)) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- ifelse(w<1e-6,1e-6,w) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*abs((s.xx-xx)*u))/sum(wt) s.xx <- ifelse(xx<7,log(1-pnorm(xx)),-xx^2/2-log(xx+1/xx)-log(2*pi)/2) s.zz <- ifelse(zz<7,log(1-pnorm(zz)),-zz^2/2-log(zz+1/zz)-log(2*pi)/2) s.xx <- pmin(s.xx,s.zz) lkhd <- sum(wt*(delta*(xx^2/2+s.xx-log(nu))+s.zz-s.xx))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } ##%%%%%%%%%% Log Logistic Family %%%%%%%%%% ## Calculate CV score for log logistic regression cv.loglogis <- function(y,eta,wt,hat,nu,alpha) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") xx <- 1/(1+exp(nu*(log(xx)-eta))) zz <- 1/(1+exp(nu*(log(zz)-eta))) u <- nu*(delta*xx-(zz-xx)) w <- nu^2/2*(zz^2-xx^2) lkhd <- sum(wt*(delta*(-log(1-xx)-log(nu))+log(zz)-log(xx)))/sum(wt) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*xx*abs(u))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } gss/R/project.sshzd1.R0000644000176200001440000001432012355360640014257 0ustar liggesusers## Calculate square error projection from sshzd1 objects project.sshzd1 <- function(object,include,...) { if (!(object$tname%in%include)) stop("gss error in project.sshzd1: time main effect missing in included terms") ## Initialization term <- object$term mf <- object$mf xnames <- object$xnames tname <- object$tname id.basis <- object$id.basis yy <- object$yy quad <- object$quad x.pt <- object$x.pt qd.wt <- object$qd.wt ## Calculate cross integrals of phi and rk s <- object$int.s r <- object$int.r ns <- length(s) nq <- length(object$theta) nx <- dim(qd.wt)[2] nbasis <- dim(r)[1] ## create arrays ss <- 0 sr <- array(0,c(ns,nbasis,nq)) rr <- array(0,c(nbasis,nbasis,nq,nq)) for (k in 1:nx) { ind <- (1:length(quad$pt))[qd.wt[,k]>0] nmesh <- length(ind) if (!nmesh) next qd.wt.wk <- qd.wt[ind,k] qd.s <- NULL qd.r <- as.list(NULL) iq <- 0 for (label in term$labels) { if (label=="1") { qd.wk <- rep(1,nmesh) qd.s <- cbind(qd.s,qd.wk) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt[ind] if (length(x.list)) qd.xy[,x.list] <- x.pt[rep(k,nmesh),x.list,drop=FALSE] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { qd.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.s <- cbind(qd.s,qd.wk) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { iq <- iq+1 qd.r[[iq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) } } } if (!is.null(object$partial)) { wk <- object$partial$pt[k,] qd.s <- cbind(qd.s,t(matrix(wk,length(wk),nmesh))) } ss <- ss + t(qd.wt.wk*qd.s)%*%qd.s for (i in 1:nq) { sr[,,i] <- sr[,,i] + t(qd.wt.wk*qd.s)%*%qd.r[[i]] for (j in 1:i) { rr.wk <- t(qd.wt.wk*qd.r[[i]])%*%qd.r[[j]] rr[,,i,j] <- rr[,,i,j] + rr.wk if (i-j) rr[,,j,i] <- rr[,,j,i] + t(rr.wk) } } } ## evaluate full model cfit <- log(object$cfit) d <- object$d c <- object$c theta <- object$theta s.eta <- ss%*%d r.eta <- tmp <- NULL r.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d r.wk <- r.wk + 10^theta[i]*r[,i] sr.wk <- sr.wk + 10^theta[i]*sr[,,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } eta2 <- sum(c*(rr.wk%*%c)) + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 - 2*sum(c(d,c)*c(s,r.wk))*cfit + cfit^2*sum(qd.wt) ## extract terms in subspace id.s <- id.q <- NULL for (label in term$labels) { if (label=="1") { id.s <- c(id.s,1) next } if (!any(label==include)) next term.wk <- term[[label]] if (term.wk$nphi>0) id.s <- c(id.s,term.wk$iphi+(1:term.wk$nphi)-1) if (term.wk$nrk>0) id.q <- c(id.q,term.wk$irk+(1:term.wk$nrk)-1) } if (!is.null(object$partial)) { nu <- length(object$d)-length(object$lab.p) for (label in object$lab.p) { nu <- nu+1 if (!any(label==include)) next id.s <- c(id.s,nu) } } ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq0-1) theta.wk[id.q0] <- theta1 ## ss.wk <- ss[id.s,id.s] r.eta.wk <- sr.wk <- rr.wk <- 0 for (i in id.q) { r.eta.wk <- r.eta.wk + 10^theta.wk[i]*r.eta[,i] sr.wk <- sr.wk + 10^theta.wk[i]*sr[id.s,,i] for (j in id.q) { rr.wk <- rr.wk + 10^(theta.wk[i]+theta.wk[j])*rr[,,i,j] } } v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s],r.eta.wk) nn <- length(mu) z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization nq0 <- length(id.q) tmp[-id.q] <- 0 fix <- rev(order(tmp))[1] ## projection if (nq0-1) { id.q0 <- id.q[id.q!=fix] if (object$skip.iter) se <- rkl(theta[id.q0]) else { if (nq0-2) { ## scale and shift cv tmp <- abs(rkl(theta[id.q0])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[id.q0],stepmax=.5,ndigit=7) } else { the.wk <- theta[id.q0] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } se <- rkl(zz$est) } } else se <- rkl() list(ratio=se/mse,se=se) } gss/R/cdsscden.R0000644000176200001440000001716412355360640013175 0ustar liggesuserscdsscden <- ## Evaluate conditional density estimate function (object,y,x,cond,int=NULL) { ## check inputs if (!("sscden"%in%class(object))) stop("gss error in cdsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in cdsscden: mismatched x variable names") if (nrow(cond)!=1) stop("gss error in cdsscden: condition has to be a single point") ynames <- NULL for (i in object$ynames) if (all(i!=colnames(cond))) ynames <- c(ynames,i) if (any(length(ynames)==c(0,length(object$ynames)))) stop("gss error in cdsscden: not a conditional density") if (length(ynames)==1&is.vector(y)) { y <- data.frame(y) colnames(y) <- ynames } if (!all(sort(ynames)==sort(colnames(y)))) stop("gss error in cdsscden: mismatched y variable names") ## Calculate normalizing constant if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain while (is.null(int)) { fac.list <- NULL num.list <- NULL for (ylab in ynames) { if (is.factor(y.wk <- y[[ylab]])) fac.list <- c(fac.list,ylab) else { if (!is.vector(y.wk)|is.null(ydomain[[ylab]])) { warning("gss warning in cdsscden: int set to 1") int <- 1 next } else num.list <- c(num.list,ylab) } } ## Generate quadrature for numerical variables if (!is.null(num.list)) { if (length(num.list)==1) { ## Gauss-Legendre quadrature mn <- min(ydomain[,num.list]) mx <- max(ydomain[,num.list]) quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- num.list } else { ## Smolyak cubature domain.wk <- ydomain[,num.list] code <- c(15,14,13) quad <- smolyak.quad(ncol(domain.wk),code[ncol(domain.wk)-1]) for (i in 1:ncol(domain.wk)) { ylab <- colnames(domain.wk)[i] wk <- object$mf[[ylab]] jk <- ssden(~wk,domain=data.frame(wk=domain.wk[,i]),alpha=2, id.basis=object$id.basis) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- wk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad.pt) <- colnames(domain.wk) } } else quad <- list(pt=data.frame(dum=1),wt=1) ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(object$mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } ymesh <- quad$pt[,ynames,drop=FALSE] yy <- cond[rep(1,nrow(ymesh)),,drop=FALSE] int <- apply(dsscden(object,cbind(ymesh,yy),x)*quad$wt,2,sum) } ## Return value yy <- cond[rep(1,nrow(y)),,drop=FALSE] list(pdf=t(t(dsscden(object,cbind(y,yy),x))/int),int=int) } cpsscden <- ## Compute cdf for univariate conditional density function(object,q,x,cond) { ## check inputs if (!("sscden"%in%class(object))) stop("gss error in cpsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in cpsscden: mismatched x variable names") if (nrow(cond)!=1) stop("gss error in cpsscden: condition has to be a single point") ynames <- NULL for (i in object$ynames) if (all(i!=colnames(cond))) ynames <- c(ynames,i) if (length(ynames)!=1) stop("gss error in cpsscden: y is not 1-D") if (is.factor(object$mf[,ynames])) stop("gss error in cpsscden: y is not continuous") if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain mn <- min(ydomain[[ynames]]) mx <- max(ydomain[[ynames]]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- ynames y.wk <- cbind(y.wk,cond) d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- ynames y.wk <- cbind(y.wk,cond) d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(p))[p>0&p<1] z <- NULL for (k in 1:dim(x)[1]) { d.qd.wk <- d.qd[,k]/sum(d.qd[,k]*qd$wt) p.wk <- cumsum(d.qd.wk*qd$wt) for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { nn <- nrow(qd.s) z <- .Fortran("drkl", cd=as.double(d), as.integer(nn), as.double(qd.s), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt)), mesh=as.double(mesh0), as.double(.Machine$double.eps), as.double(1e-6), as.integer(30), integer(nn), double(2*bias$nt*(nqd+1)+nn*(2*nn+4)), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssden: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssden: Newton iteration fails to converge") mesh1 <- z$mesh kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) } kl0 <- sum(bias$wt*(apply(qd.wt*log(mesh0)*mesh0,2,sum)+ log(apply(qd.wt,2,sum)))) kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) wt.wk <- t(t(qd.wt)/apply(qd.wt*mesh1,2,sum)) kl1 <- sum(bias$wt*(apply(wt.wk*log(mesh1)*mesh1,2,sum)+ log(apply(wt.wk,2,sum)))) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) if (mesh) obj$mesh <- mesh1 obj } gss/R/dssden.R0000644000176200001440000001233313475306162012663 0ustar liggesusersdssden <- ## Evaluate density estimate function (object,x) { ## check input if (!("ssden"%in%class(object))) stop("gss error in dssden: not a ssden object") if ("ssden1"%in%class(object)) return(d.ssden1(object,x)) else return(d.ssden(object,x)) } pssden <- ## Compute cdf for univariate density estimate function(object,q) { if (!("ssden"%in%class(object))) stop("gss error in pssden: not a ssden object") if (dim(object$mf)[2]!=1) stop("gss error in pssden: not a 1-D density") mn <- min(object$domain) mx <- max(object$domain) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- dssden(object,qd$pt) d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- dssden(object,qd$pt) d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) p.wk <- cumsum(d.qd*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) -sum(wt*(delta*(nu*(log(xx)-eta)+log.nu) -(xx^nu-zz^nu)*exp(-nu*eta))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } u <- nu[[1]]*(delta-(xx^nu[[1]]-zz^nu[[1]])*exp(-nu[[1]]*eta)) w <- nu[[1]]^2*(xx^nu[[1]]-zz^nu[[1]])*exp(-nu[[1]]*eta) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for Weibull regression dev.resid.weibull <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) z <- -delta*nu*(log(xx)-eta)+(xx^nu-zz^nu)*exp(-nu*eta) as.numeric(2*wt*(z+delta*(log(xx^nu)-log(xx^nu-zz^nu)-1))) } ## Calculate null deviance for Weibull regression dev.null.weibull <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) eta <- log(sum(wt*(xx^nu-zz^nu)*exp(-nu*offset))/sum(wt*delta))/nu eta <- eta + offset z <- -delta*nu*(log(xx)-eta)+(xx^nu-zz^nu)*exp(-nu*eta) sum(2*wt*(z+delta*(log(xx^nu)-log(xx^nu-zz^nu)-1))) } ##%%%%%%%%%% Log Normal Family %%%%%%%%%% ## Make pseudo data for log normal regression mkdata.lognorm <- function(y,eta,wt,offset,nu) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))+log.nu) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } xx <- nu[[1]]*(log(xx)-eta) zz <- nu[[1]]*(log(zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) u <- nu[[1]]*(delta*(s.xx-xx)-(s.xx-s.zz)) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu[[1]]^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- ifelse(w<1e-6,1e-6,w) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for log normal regression dev.resid.lognorm <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]|!zz[i]) dev0 <- c(dev0,0) else { fun.wk <- function(eta) { (nu*(log(xx[i])-eta))^2/2+log(1-pnorm(nu*(log(zz[i])-eta))) } dev0 <- c(dev0,nlm(fun.wk,log(xx[i]),stepmax=1)$min) } } xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- log(1-pnorm(xx)) s.zz <- log(1-pnorm(zz)) z <- -delta*(-xx^2/2-s.xx)-s.xx+s.zz as.numeric(2*wt*(z-dev0)) } dev0.resid.lognorm <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- ifelse(xx<7,log(1-pnorm(xx)),-xx^2/2-log(xx+.15)-log(2*pi)/2) s.zz <- ifelse(zz<7,log(1-pnorm(zz)),-zz^2/2-log(zz+.15)-log(2*pi)/2) s.xx <- pmin(s.xx,s.zz) z <- -delta*(-xx^2/2-s.xx)-s.xx+s.zz as.numeric(2*wt*z) } ## Calculate null deviance for log normal regression dev.null.lognorm <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]|!zz[i]) dev0 <- c(dev0,0) else { fun.wk <- function(eta) { (nu*(log(xx[i])-eta))^2/2+log(1-pnorm(nu*(log(zz[i])-eta))) } dev0 <- c(dev0,nlm(fun.wk,log(xx[i]),stepmax=1)$min) } } if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } eta <- nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(-xx^2/2-log(1-pnorm(xx)))-log((1-pnorm(xx))/(1-pnorm(zz))) sum(2*wt*(z-dev0)) } ##%%%%%%%%%% Log Logistic Family %%%%%%%%%% ## Make pseudo data for log logistic regression mkdata.loglogis <- function(y,eta,wt,offset,nu) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))+log.nu) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } xx <- 1/(1+exp(nu[[1]]*(log(xx)-eta))) zz <- 1/(1+exp(nu[[1]]*(log(zz)-eta))) u <- nu[[1]]*(delta*xx-(zz-xx)) w <- nu[[1]]^2/2*(zz^2-xx^2) w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for log logistic regression dev.resid.loglogis <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]) dev0 <- c(dev0,0) else { if (!zz[i]) dev0 <- c(dev0,2*log(2)) else { if ((xx[i]/zz[i])^nu<=2) dev0 <- c(dev0,nu*log(xx[i]/zz[i])) else dev0 <- c(dev0,2*log(2)-log(xx[i]^nu/(xx[i]^nu-zz[i]^nu))) } } } xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) as.numeric(2*wt*(z-dev0)) } dev0.resid.loglogis <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) as.numeric(2*wt*z) } ## Calculate null deviance for log logistic regression dev.null.loglogis <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]) dev0 <- c(dev0,0) else { if (!zz[i]) dev0 <- c(dev0,2*log(2)) else { if ((xx[i]/zz[i])^nu<=2) dev0 <- c(dev0,nu*log(xx[i]/zz[i])) else dev0 <- c(dev0,2*log(2)-log(xx[i]^nu/(xx[i]^nu-zz[i]^nu))) } } } if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } eta <- nlm(lkhd,mean(log(xx)-offset))$est + offset xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) sum(2*wt*(z-dev0)) } gss/R/cdssden.R0000644000176200001440000001431713475306140013026 0ustar liggesuserscdssden <- ## Evaluate conditional density function (object,x,cond,int=NULL) { if (!("ssden"%in%class(object))) stop("gss error in cdssden: not a ssden object") if (nrow(cond)!=1) stop("gss error in cdssden: condition has to be a single point") xnames <- NULL for (i in colnames(object$mf)) if (all(i!=colnames(cond))) xnames <- c(xnames,i) if (any(length(xnames)==c(0,ncol(object$mf)))) stop("gss error in cdssden: not a conditional density") if (length(xnames)==1&is.vector(x)) { x <- data.frame(x) colnames(x) <- xnames } if (!all(sort(xnames)==sort(colnames(x)))) stop("gss error in cdssden: mismatched variable names") ## Calculate normalizing constant while (is.null(int)) { fac.list <- NULL num.list <- NULL for (xlab in xnames) { if (is.factor(x.wk <- x[[xlab]])) fac.list <- c(fac.list,xlab) else { if (!is.vector(x.wk)|is.null(object$domain[[xlab]])) { warning("gss warning in cdssden: int set to 1") int <- 1 next } else num.list <- c(num.list,xlab) } } ## Generate quadrature for numerical variables if (!is.null(num.list)) { if (length(num.list)==1) { ## Gauss-Legendre quadrature mn <- min(object$domain[,num.list]) mx <- max(object$domain[,num.list]) quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- num.list } else { ## Smolyak cubature domain.wk <- object$domain[,num.list] code <- c(15,14,13) quad <- smolyak.quad(ncol(domain.wk),code[ncol(domain.wk)-1]) for (i in 1:ncol(domain.wk)) { xlab <- colnames(domain.wk)[i] form <- as.formula(paste("~",xlab)) jk <- ssden(form,data=object$mf,domain=domain.wk[i],alpha=2, id.basis=object$id.basis) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain.wk) } } else quad <- list(pt=data.frame(dum=1),wt=1) ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(object$mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } xmesh <- quad$pt[,xnames,drop=FALSE] xx <- cond[rep(1,nrow(xmesh)),,drop=FALSE] int <- sum(dssden(object,cbind(xmesh,xx))*quad$wt) } ## Return value xx <- cond[rep(1,nrow(x)),,drop=FALSE] list(pdf=dssden(object,cbind(x,xx))/int,int=int) } cpssden <- ## Compute cdf for univariate conditional density function(object,q,cond) { if (!("ssden"%in%class(object))) stop("gss error in cpssden: not a ssden object") xnames <- NULL for (i in colnames(object$mf)) if (all(i!=colnames(cond))) xnames <- c(xnames,i) if ((length(xnames)!=1)|!is.vector(object$mf[,xnames])) stop("gss error in cpssden: not a 1-D conditional density") mn <- min(object$domain[,xnames]) mx <- max(object$domain[,xnames]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- cdssden(object,qd$pt,cond)$pdf d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- cdssden(object,qd$pt,cond)$pdf d.qd <- d.qd/sum(d.qd*qd$wt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) p.wk <- cumsum(d.qd*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wkdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } if (xor(is.vector(mesh),dm==1) |xor(is.matrix(mesh),dm>=2)) { stop("gss error in mkrk.tp: mismatched inputs") } if ((min(weight)<0)|(max(weight)<=0)) { stop("gss error in mkrk.tp: negative weights") } ## Set weights if (is.vector(mesh)) N <- length(mesh) else N <- dim(mesh)[1] weight <- rep(weight,len=N) weight <- sqrt(weight/sum(weight)) ## Obtain orthonormal basis phi.p <- mkphi.tp.p(dm,order) nnull <- choose(dm+order-1,dm) s <- NULL for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env)) s <- qr(weight*s) if (s$rankdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } if (xor(is.vector(mesh),dm==1) |xor(is.matrix(mesh),dm>=2)) { stop("gss error in mkphi.tp: mismatched inputs") } if ((min(weight)<0)|(max(weight)<=0)) { stop("gss error in mkphi.tp: negative weights") } ## Set weights if (is.vector(mesh)) N <- length(mesh) else N <- dim(mesh)[1] weight <- rep(weight,len=N) weight <- sqrt(weight/sum(weight)) ## Create the environment phi.p <- mkphi.tp.p(dm,order) nnull <- choose(dm+order-1,dm) s <- NULL for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env)) s <- qr(weight*s) if (s$rankdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } ## Create the environment if (dm%%2) { theta <- gamma(dm/2-order)/2^(2*order)/pi^(dm/2)/gamma(order) } else { theta <- (-1)^(dm/2+order+1)/2^(2*order-1)/pi^(dm/2)/ gamma(order)/gamma(order-dm/2+1) } env <- list(dim=dm,order=order,theta=theta) ## Create the rk.p function fun <- function(x,y,env,outer.prod=FALSE) { ## Check inputs if (env$dim==1) { if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } } else { if (is.vector(x)) x <- t(as.matrix(x)) if (env$dim!=dim(x)[2]) { stop("gss error in rk: inputs are of wrong dimensions") } if (is.vector(y)) y <- t(as.matrix(y)) if (env$dim!=dim(y)[2]) { stop("gss error in rk: inputs are of wrong dimensions") } } ## Return the results if (outer.prod) { if (env$dim==1) { fn1 <- function(x,y) abs(x-y) d <- outer(x,y,fn1) } else { fn2 <- function(x,y) sqrt(sum((x-y)^2)) d <- NULL for (i in 1:dim(y)[1]) d <- cbind(d,apply(x,1,fn2,y[i,])) } } else { if (env$dim==1) d <- abs(x-y) else { N <- max(dim(x)[1],dim(y)[1]) x <- t(matrix(t(x),env$dim,N)) y <- t(matrix(t(y),env$dim,N)) fn <- function(x) sqrt(sum(x^2)) d <- apply(x-y,1,fn) } } power <- 2*env$order-env$dim switch(1+env$dim%%2, env$theta*d^power*log(ifelse(d>0,d,1)), env$theta*d^power) } ## Return the function and the environment list(fun=fun,env=env) } ## Make pseudo phi function for thin-plate splines mkphi.tp.p <- function(dm,order) { ## Check inputs if (!((2*order>dm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } ## Create the environment pol.code <- NULL for (i in 0:(order^dm-1)) { ind <- i; code <- NULL for (j in 1:dm) { code <- c(code,ind%%order) ind <- ind%/%order } if (sum(code)90)|(max(abs(x[,2]),abs(y[,2]))>180)) { stop("gss error in rk: inputs are out of range") } ##% Convert to radian lat.x <- x[,1]/180*pi; lon.x <- x[,2]/180*pi lat.y <- y[,1]/180*pi; lon.y <- y[,2]/180*pi ##% Return the result rk <- function(lat.x,lon.x,lat.y,lon.y,order) { z <- cos(lat.x)*cos(lat.y)*cos(lon.x-lon.y)+sin(lat.x)*sin(lat.y) W <- ifelse(z<1-10^(-10),(1-z)/2,0) A <- ifelse(W>0,log(1+1/sqrt(W)),0) C <- ifelse(W>0,2*sqrt(W),0) switch(order-1, (A*4*W*(3*W-1)+6*W*(1-C)+1)/2, (W*W*(A*((840*W-720)*W+72)+420*W*(1-C)+220*C-150)-4*W+3)/12, (W*W*W*(A*(((27720*W-37800)*W+12600)*W-600)+ (13860*(1-C)*W+14280*C-11970)*W-2772*C+1470)+ 15*W*W-3*W+5)/30) - 1/(2*order-1) } if (outer.prod) { zz <- NULL for (i in 1:length(lat.y)) zz <- cbind(zz,rk(lat.x,lon.x,lat.y[i],lon.y[i],env$order)) } else zz <- rk(lat.x,lon.x,lat.y,lon.y,env$order) zz } ## Return the function and the environment list(fun=fun,env=env) } gss/R/ssanova.R0000644000176200001440000004551612355360640013063 0ustar liggesusers## Fit ssanova model ssanova <- function(formula,type=NULL,data=list(),weights,subset, offset,na.action=na.omit,partial=NULL, method="v",alpha=1.4,varht=1, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$method <- mf$varht <- mf$partial <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in ssanova: use lm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rankalpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*trc if (method=="v") score <- rss/(1-alpha.wk*trc)^2 } if (return.fit) { z <- .Fortran("reg", as.double(cbind(s,10^theta*r)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) } } else { z <- .Fortran("reg", as.double(cbind(s,10^theta*r)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova: evaluation of GML score fails") assign("fit",z[c(1:5,7)],inherits=TRUE) score <- z$score alpha.wk <- max(0,log.la0-lambda[1]-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*z$wk[2] if (method=="v") score <- z$wk[1]/(1-alpha.wk*z$wk[2])^2 } } score } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization tmp <- sum(r^2) if (is.null(s)) theta <- 0 else theta <- log10(sum(s^2)/nnull/tmp*nxi) / 2 log.la0 <- log10(tmp/sum(diag(q))) + theta if (!is.null(random)) { ran.scal <- theta - log10(sum(random$z^2)/nz/tmp*nxi) / 2 r <- cbind(r,10^(ran.scal-theta)*random$z) } else ran.scal <- NULL ## lambda search return.fit <- FALSE fit <- NULL if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return return.fit <- TRUE jk1 <- cv(zz$est) if (is.null(random)) q.wk <- 10^theta*q else { q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^theta*q q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-zz$est[1])*random$sigma$fun(zz$est[-1],random$sigma$env) } se.aux <- regaux(s,10^theta*r,q.wk,zz$est[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(method=method,theta=theta,ran.scal=ran.scal,c=c,d=d,b=b, nlambda=zz$est[1],zeta=zz$est[-1]),fit[-3],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter (Gaussian) REGression mspreg1 <- function(s,r,id.basis,y,wt,method,alpha,varht,random,skip.iter) { qr.trace <- FALSE if ((alpha<0)&(method%in%c("u","v"))) qr.trace <- TRUE alpha <- abs(alpha) ## get dimensions nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 if (!is.null(random)) nz <-ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } qq.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk <- 10^nlambda*qq.wk else { r.wk0 <- cbind(r.wk0,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^nlambda*qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } if (!is.null(wt)) { y.wk <- wt*y s.wk <- wt*s r.wk0 <- wt*r.wk0 } if (qr.trace) { qq.wk <- chol(q.wk,pivot=TRUE) sr <- cbind(s.wk,r.wk0[,attr(qq.wk,"pivot")]) sr <- rbind(sr,cbind(matrix(0,nxiz,nnull),qq.wk)) sr <- qr(sr,tol=0) rss <- mean(qr.resid(sr,c(y.wk,rep(0,nxiz)))[1:nobs]^2) trc <- sum(qr.Q(sr)[1:nobs,]^2)/nobs if (method=="u") score <- rss + alpha*2*varht*trc if (method=="v") score <- rss/(1-alpha*trc)^2 alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*trc if (method=="v") score <- rss/(1-alpha.wk*trc)^2 } if (return.fit) { z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) } } else { z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova: evaluation of GML score fails") assign("fit",z[c(1:5,7)],inherits=TRUE) score <- z$score alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*z$wk[2] if (method=="v") score <- z$wk[1]/(1-alpha.wk*z$wk[2])^2 } } score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment return.fit <- FALSE z <- sspreg1(s,r.wk,r.wk[id.basis,],y,wt,method,alpha,varht,random) theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } if (!is.null(wt)) q.wk <- wt*r.wk else q.wk <- r.wk log.la0 <- log10(sum(q.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspreg1(s,r.wk,r.wk[id.basis,],y,wt,method,alpha,varht,random) nlambda <- z$nlambda log.th0 <- log.th0 + z$nlambda theta <- theta + z$theta if (!is.null(random)) ran.scal <- z$ran.scal ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search fit <- NULL counter <- 0 y.wk <- y s.wk <- s r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,z$zeta) ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } ## return return.fit <- TRUE jk1 <- cv(zz$est) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^zz$est[i]*r[,,i] } qq.wk <- r.wk[id.basis,] if (is.null(random)) q.wk <- qq.wk else { r.wk <- cbind(r.wk,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-nlambda)*random$sigma$fun(zz$est[-(1:nq)],random$sigma$env) } if (!is.null(wt)) { s <- wt*s r.wk <- wt*r.wk } se.aux <- regaux(s,r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(method=method,theta=zz$est[1:nq],c=c,d=d,b=b,nlambda=nlambda, zeta=zz$est[-(1:nq)]),fit[-3],list(se.aux=se.aux)) } ## Auxiliary Quantities for Standard Error Calculation regaux <- function(s,r,q,nlambda,fit) { nnull <- dim(s)[2] nn <- nnull + dim(q)[1] zzz <- eigen(q,symmetric=TRUE) rkq <- min(fit$rkv-nnull,sum(zzz$val/zzz$val[1]>sqrt(.Machine$double.eps))) val <- zzz$val[1:rkq] vec <- zzz$vec[,1:rkq,drop=FALSE] if (nnull) { wk1 <- qr(s) wk1 <- (qr.qty(wk1,r%*%vec))[-(1:nnull),] } else wk1 <- r%*%vec wk2 <- t(t(wk1)/sqrt(val)) wk2 <- t(wk2)%*%wk2 wk2 <- solve(wk2+diag(10^nlambda,dim(wk2)[1]),wk2) wk2 <- (wk2+t(wk2))/2 wk2 <- t(wk2/sqrt(val))/sqrt(val) wk2 <- diag(1/val,dim(wk2)[1])-wk2 z <- .Fortran("regaux", as.double(fit$chol), as.integer(nn), as.integer(fit$jpvt), as.integer(fit$rkv), drcr=as.double(t(cbind(s,r))%*%r%*%vec), as.integer(rkq), sms=double(nnull^2), as.integer(nnull), double(nn*nnull), PACKAGE="gss")[c("drcr","sms")] drcr <- matrix(z$drcr,nn,rkq) dr <- drcr[1:nnull,,drop=FALSE] sms <- 10^nlambda*matrix(z$sms,nnull,nnull) wk1 <- matrix(0,nnull+rkq,nnull+rkq) wk1[1:nnull,1:nnull] <- sms wk1[1:nnull,nnull+(1:rkq)] <- -t(t(dr)/val) wk1[nnull+(1:rkq),nnull+(1:rkq)] <- wk2 z <- chol(wk1,pivot=TRUE) wk1 <- z rkw <- attr(z,"rank") while (wk1[rkw,rkw]col(wk1)] <- 0 if (rkw Maintainer: Chong Gu Depends: R (>= 2.14.0), stats Description: A comprehensive package for structural multivariate function estimation using smoothing splines. License: GPL (>= 2) Packaged: 2019-06-05 17:36:06 UTC; chong NeedsCompilation: yes Repository: CRAN Date/Publication: 2019-06-09 17:00:03 UTC gss/ChangeLog0000644000176200001440000004167713475775602012657 0ustar liggesusersWed Jun 5 13:14:18 EDT 2019, Chong Gu * DESCRIPTION: Version 2.1-10. * R: i) Bug fixes in cdssden.R and dssden.R. ii) Minor edits in ssanova0.R and gssanova0.R concerning calls to FORTRAN routine dmudr0. * src: Minor edits in dsidr0, dmudr0, and init.c, and removal of dsidr and dmudr. Sun Apr 22 09:19:19 EDT 2018, Chong Gu * DESCRIPTION: Version 2.1-9. * R: Reworked ssllrm suite to add qd.wt. * man: Minor edit to reflect changes in R. * src: i) Changes and bug fixes in llrmnewton. ii) Minor edit in cdennewton. Wed Apr 18 11:46:02 EDT 2018, Chong Gu * DESCRIPTION: Version 2.1-8. * R: Edited ssllrm to allow for non-integer weights. Thu Feb 23 20:55:02 EST 2017, Chong Gu * DESCRIPTION: Version 2.1-7. * R: i) Added mkran1 and modified mkran to allow for multiple terms of random effects. ii) Added predict1.ssanova to allow for the evaluation of f(x1)-f(x2) along with standard errors. iii) Bug fixes in project.ssanova and summary.ssanova involving random effects. * man: Updated to reflect changes in R. Sun Aug 28 09:47:18 EDT 2016, Chong Gu * DESCRIPTION: Version 2.1-6. * src: Replaced obsolete declarations character*1 and real*8. Thu Jul 2 10:51:16 EDT 2015, Chong Gu * DESCRIPTION: Version 2.1-5. * NAMESPACE: Added 'importFrom(stats, ...)'. Sat Dec 6 10:36:46 EST 2014, Chong Gu * DESCRIPTION: Version 2.1-4. * R: Along with a bug fix, edited utility functions for the nbinomial family in the gssanova suite, eliminating unnecessary subtractions to preserve numerical precision. man Mon Jul 21 00:14:45 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-3. * R: Edited utility functions for the binomial family in the gssanova suite, eliminating unnecessary subtractions to preserve numerical precision. Tue Jun 10 18:52:28 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-2. * inst: created the directory and added CITATION. * man: Updated references. Wed May 28 11:25:14 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-1. * R: i) Tuned Newton iteration algorithms in ngreg and ngreg.proj. ii) Bug fixes in routines involving univariate minimization via nlm0. iii) Minor changes in makedata.x's. Tue Dec 3 01:02:41 EST 2013, Chong Gu * DESCRIPTION: Version 2.1-0. * R: i) Changed time domain specification in sshzd/sshzd1. ii) Removed from sshzd1 the option of external rho. * man: Minor edit in sshzd.Rd. Fri Nov 15 17:19:59 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-16. * R: i) Bug fix in survexp.sshzd. ii) Modified default values of qdsz.depth in ssden. * man: i) Updated references. ii) Added note in ssden.Rd. Wed Oct 9 11:44:05 EDT 2013, Chong Gu * DESCRIPTION: Version 2.0-15. * R: Bug fixes in summary.gssanova, summary.ssanova, and summary.ssanova9. Tue May 14 14:51:58 EDT 2013, Chong Gu * DESCRIPTION: Version 2.0-14. * R: Bug fixes in ssden1, sscden, sscden1 suites. Fri Mar 8 16:04:21 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-13. * R: Replaced direct calls to LINPACK dchdc by chol(), in ssanova, cv.poisson, project.ssden1, project.sscden1, and project.sshzd1. Tue Feb 26 14:42:15 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-12. * R: i) Bug fixes in summary.gssanova and project.gssanova. ii) Changes in ssanova and ssanova9 to supply sufficient work array for altered reg.f. iii) Replaced 'attach/detach' by 'with' in mkran, sscox, sshzd, and sshzd1 following suggestion by Professor Brian Ripley. * src: Replaced EISPACK routine rs by LAPACK routine dsyev in reg.f, and added $(LAPACK_LIBS) to Makevars. Tue Aug 28 18:28:31 EDT 2012, Chong Gu * DESCRIPTION: Version 2.0-11. * R: Bug fixes in fitting functions to prevent overflow in oversmoothing cases. Sat May 12 19:52:54 EDT 2012, Chong Gu * DESCRIPTION: Version 2.0-10. * R: Bug fixes in project.x to allow projections into spaces with only unpenalized terms. Tue Jan 24 09:35:43 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-9. * R: Removed the .First.lib function. * man: Edited documentation for Sachs. Fri Jan 6 12:39:56 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-8. * NAMESPACE: Manually created the file. * data: Added Sachs. * man: Added documentation for Sachs. Mon Jan 2 18:39:24 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-7. * R: i) Bug fixes in sscden. ii) Reworked survexp.sshzd. * man: Updated to reflect changes in R. Tue Dec 20 15:44:32 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-6. * R: Reworked the sshzd1 suite. * man: Updated to reflect changes in R. Tue Nov 15 21:47:30 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-5. * R: Reworked the ssden1 suite to improve memory management. * man: Updated to reflect changes in R. Mon Nov 14 00:35:22 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-4. * R: Bug fixes in ssden and ssden1. * data: Added NO2. * man: Added documentation for NO2. Tue Nov 8 14:09:09 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-3. * R: Added the ssden1 suite. * man: Updated to reflect changes in R. * src: Added dnewton10. Sun Sep 18 10:34:49 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-2. * R: Reworked the sscden1 suite. * man: Updated to reflect changes in R. Sun Jul 31 01:03:45 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-1. * R: Bug fix in gssanova1. * src: Bug fix in drkl. Sun Jul 24 12:26:15 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-0. * R: i) Added the ssanova9, gssanova1, sscox, sscden, and sscden1 suites. ii) Reworked part of the gssanova suite. iii) Reworked the ssden suite to allow sampling bias. iv) Changed the syntax concerning partial terms, and added partial in sshzd and sshzd1 suites. v) Minor changes in cpssden and cqssden. * data: i) Added ColoCan. ii) Reformatted clim, LakeAcidity, and penny. * man: Expanded and updated to reflect changes in R. * src: i) Added cdennewton, cdenrkl, cdennewton10. ii) Changes in dnewton and drkl. Wed Jan 12 11:58:55 EST 2011, Chong Gu * DESCRIPTION: Version 1.1-7. * R: Set alpha=1 as default in ssllrm. * data: Added eyetrack. * man: Added documentation for eyetrack. Wed Oct 13 18:00:47 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-6. * R: Bug fixes in sshzd and sshzd1 concerning subset in call. * src: Bug fix in llrmnewton. Mon Jul 5 15:28:48 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-5. * R: Reworked qssden and cqssden to eliminate calls to pssden and cpssden, and removed a now redundant operation in cpssden; qssden and cqssden now run much faster. * data: Added esc. * man: i) Added documentation for esc. ii) Removed the warning for the slowness of cpssden and cqssden, as the new versions are no longer slow. Wed Jun 23 10:59:50 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-4. * R: i) Bug fixes in project.ssanova, ssden, sshzd, and sshzd1, and minor tweaking in project.gssanova, mostly concerning weighted data. ii) Added support of random effects to the sshzd and sshzd1 suites for frailty models. * man: Updated to reflect changes in R. * src: Minor change in hzdnewton10. Sun Jun 13 17:28:13 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-3. * R: i) Fixed bugs and inefficient code in ssllrm. ii) Fixed a bug in project.ssllrm. iii) Minor changes in sshzd and sshzd1. * man: Updated to reflect changes in R. * src: Changes in llrmnewton triggered by ssllrm. Thu May 27 19:52:17 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-2. * R: Fixed bugs in the ssanova suite introduced in 1.1-0. * man: Updated to reflect changes in R. Wed May 19 22:38:22 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-1. * R: i) Added support of random effects to the ssllrm suite. ii) Fixed bugs in mspreg1 and mspngreg introduced in 1.1-0. * man: Updated to reflect changes in R. Mon Nov 23 12:52:38 EST 2009, Chong Gu * DESCRIPTION: Version 1.1-0. * INDEX: Edited to reflect changes in R. * R: i) Added sshzd1 and project.sshzd1. ii) Added ssllrm, predict.ssllrm, and project.ssllrm. iii) Removed the dimension limit in ssden and added user-control of quadrature size via qdsz.depth. iv) Added skip.iter to fitting functions, and rearranged computation to speed up theta iteration. This affect all but the legacy fitting functions ssanova0 and gssanova0. v) reworked quadrature in pssden and cpssden to guarantee monotonicity. * man: Updated to reflect changes in R. Mon Mar 9 15:53:42 EDT 2009, Chong Gu * DESCRIPTION: Version 1.0-5. * R: Fixed a bug in regaux. Wed Mar 4 16:42:23 EST 2009, Chong Gu * DESCRIPTION: Version 1.0-4. * INDEX: Edited to reflect changes in R. * R: Further tweaking of the calculations concerning standard errors in predict.ssanova; added internal function regaux. * man: Updated to reflect changes in R. Wed Mar 4 00:22:21 EST 2009, Chong Gu * DESCRIPTION: Version 1.0-3. * R: Redesigned the calculations concerning standard errors in predict.ssanova. Sun Sep 7 14:42:33 EDT 2008, Chong Gu * DESCRIPTION: Version 1.0-2. * R: Fixed a bug in predict.ssanova. Fri Jun 27 17:10:27 EDT 2008, Chong Gu * DESCRIPTION: Version 1.0-1. * R: Installed more stable calculations concerning standard errors in predict.ssanova. * man: Fixed format for documentation of methods. * src: Fixed a bug in reg (undeclared dasum), which was forgiven by g77 and also by gfortran on (some) 32-bit machines; revealed by gfortran on 64-bit. Mon Aug 6 21:21:47 EDT 2007, Chong Gu * DESCRIPTION: Version 1.0-0. * INDEX: Edited to reflect changes in R. * R: i) Added mkterm to replace multiple mkterm.x in earlier versions, and modified the fitting functions accordingly. ii) Renamed ssanova to ssanova0, ssanova1 to ssanova, gssanova to gssanova0, and gssanova1 to gssanova; renamed the respective methods accordingly. iii) Added support of factor variables in ssden. * man: Extensive editing was done to reflect changes in R, to update references, and to improve readability. * src: i) Fixed bugs in hzdnewton1 and dnewton1. ii) Pushed ratfor source code to a subdirectory ratfor. Thu Sep 23 16:27:00 EST 2004, Chong Gu * DESCRIPTION: Version 0.9-3. * man: Fixed formatting bugs in ssden.Rd and sshzd.Rd. Fri Mar 26 10:40:04 EST 2004, Chong Gu * DESCRIPTION: Version 0.9-2. * R: Added SE calculations to the sshzd suite. * man: Updated hzdrate.sshzd.Rd to reflect the added SE functionality. * src: Added support for the SE calculations in the sshzd suite. Sun Oct 19 23:16:01 EST 2003, Chong Gu * DESCRIPTION: Version 0.9-1. * INDEX: Added new utility functions for gssanova1 and project.gssanova1. * R: i) Added supports of nbinomial, weibull, lognorm, and loglogis families to gssanova1. ii) Restructured project.gssanova1 along with added family supports. * man: Added to family.Rd the new utility functions for gssanova1 and project.gssanova1. Sat Aug 16 01:31:27 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-6. * R: i) Added mkran and released the mixed-effect model functionality in ssanova1 and gssanova1. ii) Fixed project.ssanova1 and project.gssanova1 to treat random effects (in mixed-effect models) as offset. * data: Added bacteriuria. * man: i) Added mkran.Rd. ii) Added mixed-effect example in gssanova1.Rd. iii) To avoid confusion with the random effects in mixed-effect models, changed "fixed effects" to "unpenalized terms" and "random effects" to "penalized terms" throughout. Mon Jul 14 13:59:43 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-5. * R: i) Added stable GCV evaluation in rkpk1.R. ii) Improved the reliability of nlm calls in numerous functions. iii) Bug fix in sshzd. * man: Blocked out time-consuming examples from auto executions and added warnings. Thu Jun 26 16:39:30 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-4. * R: Bug fix in project.sshzd. Thu Jun 26 11:31:14 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-3. * R: i) Bug fixes in sshzd and project.sshzd. ii) Miner fixes in documentation. Sun Mar 2 10:43:35 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-2. * INDEX: Added gssanova1, sshzd, project.x, and related functions. * R: i) Added the gssanova1 suite for scalable non Gaussian regression. ii) Added the sshzd suite for hazard estimation. iii) Added code for Kullback-Leibler projection model diagnostics. iv) Code modifications and bug fixes in ssanova1 and ssden suites; added nlm0 for univariate optimization. * data: Added gastric. * man: Added documentations for the new entries in R. * src: Added routines to support the gssanova1 suite, the sshzd suite, and the projection code. Tue Dec 31 10:16:37 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-4. * INDEX: Added ssanova1 and related functions. * R: i) Added the ssanova1 suite for scalable Gaussian regression, with modifications in fitted.R to accommodate ssanova1. ii) Minor bug fixes in ssden suite. * man: Added documentations for the new entries in R. * src: Added routines to support the ssanova1 suite. Thu Jun 27 12:03:26 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-3. * R: Minor changes in ssden and related functions. * man: Minor changes to reflect code change. * src: Removed dchdc.f and dtrsl.f. Added an include line in smolyak.c as suggested by Kurt Hornik. Mon Jun 24 16:44:38 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-2. * INDEX: Added ssden and related functions. * R: Added the ssden suite for density estimation. * data: Added buffalo, aids. * man: Added documentations for the new entries in R and data. * src: Added routines to support the ssden suite. Tue May 14 06:35:45 EST 2002, Chong Gu * DESCRIPTION: Version 0.6-5. * src: Removed BLAS routines, as suggested by Brian Ripley. Thu Apr 25 23:41:09 EST 2002, Chong Gu * DESCRIPTION: Version 0.6-4. * R: Cosmetic changes to conform with the formats of generic methods. * man: Minor changes to reflect the code change and to meet R-1.5.0 CMD check standard. * src: Added the file Makevars, as suggested by Martin Maechler. Thu Jul 9 22:10:07 EST 2001, Chong Gu * DESCRIPTION: Version 0.6-3. * R: Minor changes to correctly reflect documentations. * man: Minor changes to meet R-1.3.0 CMD check standard. Thu Jul 5 16:05:21 EST 2001, Chong Gu * DESCRIPTION: Version 0.6-2. * INDEX: Added mkdata.x, dev.resid.x, and dev.null.x for weibull, lognorm, and loglogis. * R: Added support for accelerated life model families weibull, lognorm, and loglogis for censored data regression. * data: Added ozone, stan, wesdr. * man: Revised relevant files to reflect the added support for accelerated life model families. Mon May 14 13:18:12 EST 2001, Chong Gu * DESCRIPTION: Version 0.5-3. Added Maintainer field per the new format requirement by R-1.2.1. * man: Fixed keywords in a few files. Thu Dec 21 19:35:38 EST 2000, Chong Gu * DESCRIPTION: Version 0.5-2. Moved the Title in here according to the new format requirement by R-1.2.0. * INDEX: Added new functions mkrk.nominal and mkrk.ordinal. * R: i) Added support for factors; ii) corrected minor bugs; iii) grouped functions into smaller number of files. * data: Replaced lake.acid by LakeAcidity. Added Nox. * man: Expanded to cover all objects. Revised existing ones to reflect code expansion/revision. * src: Fixed an inconsequential bug in dmudr1.f. Wed Jun 23 20:22:12 EST 1999, Chong Gu * DESCRIPTION (Version): First Public Release is 0.4-1 * INDEX: Expanded and reorganized. * R: i) Added support for partial and offset terms; ii) added linear splines; iii) added the gssanova suite for non Gaussian regression. * man: Expanded/revised to reflect the code expansion/revision. Fri May 28 00:31:24 EST 1999, Chong Gu * DESCRIPTION (Version): First Release is 0.3-1 gss/man/0000755000176200001440000000000013266671123011630 5ustar liggesusersgss/man/bacteriuria.Rd0000644000176200001440000000207412355360640014411 0ustar liggesusers\name{bacteriuria} \alias{bacteriuria} \title{Treatment of Bacteriuria} \description{ Bacteriuria patients were randomly assigned to two treatment groups. Weekly binary indicator of bacteriuria was recorded for every patient over 4 to 16 weeks. A total of 72 patients were represented in the data, with 36 each in the two treatment groups. } \usage{data(bacteriuria)} \format{ A data frame containing 820 observations on the following variables. \tabular{ll}{ \code{id} \tab Identification of patients, a factor.\cr \code{trt} \tab Treatments 1 or 2, a factor.\cr \code{time} \tab Weeks after randomization.\cr \code{infect} \tab Binary indicator of bacteriuria (bacteria in urine). } } \source{ Joe, H. (1997), \emph{Multivariate Models and Dependence Concepts}. London: Chapman and Hall. } \references{ Gu, C. and Ma, P. (2005), Generalized nonparametric mixed-effect models: computation and smoothing parameter selection. \emph{Journal of Computational and Graphical Statistics}, \bold{14}, 485--504. } \keyword{datasets} gss/man/fitted.ssanova.Rd0000644000176200001440000000161212355360640015044 0ustar liggesusers\name{fitted.ssanova} \alias{fitted.ssanova} \alias{residuals.ssanova} \alias{fitted.gssanova} \alias{residuals.gssanova} \title{Fitted Values and Residuals from Smoothing Spline ANOVA Fits} \description{ Methods for extracting fitted values and residuals from smoothing spline ANOVA fits. } \usage{ \method{fitted}{ssanova}(object, ...) \method{residuals}{ssanova}(object, ...) \method{fitted}{gssanova}(object, ...) \method{residuals}{gssanova}(object, type="working", ...) } \arguments{ \item{object}{Object of class \code{"ssanova"} or \code{"gssanova"}.} \item{type}{Type of residuals desired, with two alternatives \code{"working"} (default) or \code{"deviance"}.} \item{...}{Ignored.} } \details{ The fitted values for \code{"gssanova"} objects are on the link scale, so are the \code{"working"} residuals. } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/ssllrm.Rd0000644000176200001440000001242212355360640013431 0ustar liggesusers\name{ssllrm} \alias{ssllrm} \title{Fitting Smoothing Spline Log-Linear Regression Models} \description{ Fit smoothing spline log-linear regression models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}. } \usage{ ssllrm(formula, response, type=NULL, data=list(), weights, subset, na.action=na.omit, alpha=1, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{response}{Formula listing response variables.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{weights}{Optional vector of weights to be used in the fitting process.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{alpha}{Parameter modifying GCV or Mallows' CL; larger absolute values yield smoother fits; negative value invokes a stable and more accurate GCV/CL evaluation algorithm but may take two to five times as long. Ignored when \code{method="m"} are specified.} \item{id.basis}{Index designating selected "knots".} \item{nbasis}{Number of "knots" to be selected. Ignored when \code{id.basis} is supplied.} \item{seed}{Seed to be used for the random generation of "knots". Ignored when \code{id.basis} is supplied.} \item{random}{Input for parametric random effects in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model is specified via \code{formula} and \code{response}, where \code{response} lists the response variables. For example, \code{ssllrm(~y1*y2*x,~y1+y2)} prescribe a model of the form \deqn{ log f(y1,y2|x) = g_{1}(y1) + g_{2}(y2) + g_{12}(y1,y2) + g_{x1}(x,y1) + g_{x2}(x,y2) + g_{x12}(x,y1,y2) + C(x) } with the terms denoted by \code{"y1"}, \code{"y2"}, \code{"y1:y2"}, \code{"y1:x"}, \code{"y2:x"}, and \code{"y1:y2:x"}; the term(s) not involving response(s) are removed and the constant \code{C(x)} is determined by the fact that a conditional density integrates (adds) to one on the \code{y} axis. The model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ The responses, or y-variables, must be factors, and there must be at least one numerical x's. For \code{response}, there is no difference between \code{~y1+y2} and \code{~y1*y2}. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{ssllrm} returns a list object of class \code{"ssllrm"}. The method \code{\link{predict.ssllrm}} can be used to evaluate \code{f(y|x)} at arbitrary x, or contrasts of \code{log{f(y|x)}} such as the odds ratio along with standard errors. The method \code{\link{project.ssllrm}} can be used to calculate the Kullback-Leibler projection for model selection. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. and Ma, P. (2011), Nonparametric regression with cross-classified responses. \emph{The Canadian Journal of Statistics}, \bold{39}, 591--609. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## Simulate data test <- function(x) {.3*(1e6*(x^11*(1-x)^6)+1e4*(x^3*(1-x)^10))-2} x <- (0:100)/100 p <- 1-1/(1+exp(test(x))) y <- rbinom(x,3,p) y1 <- as.ordered(y) y2 <- as.factor(rbinom(x,1,p)) ## Fit model fit <- ssllrm(~y1*y2*x,~y1+y2) ## Evaluate f(y|x) est <- predict(fit,data.frame(x=x), data.frame(y1=as.factor(0:3),y2=as.factor(rep(0,4)))) ## f(y|x) at all y values (fit$qd.pt) est <- predict(fit,data.frame(x=x)) ## Evaluate contrast of log f(y|x) est <- predict(fit,data.frame(x=x),odds=c(-1,.5,.5,0), data.frame(y1=as.factor(0:3),y2=as.factor(rep(0,4))),se=TRUE) ## Odds ratio log{f(0,0|x)/f(3,0|x)} est <- predict(fit,data.frame(x=x),odds=c(1,-1), data.frame(y1=as.factor(c(0,3)),y2=as.factor(c(0,1))),se=TRUE) ## KL projection kl <- project(fit,include=c("y2:x","y1:y2","y1:x","y2:x")) ## Clean up \dontrun{rm(test,x,p,y,y1,y2,fit,est,kl) dev.off()} } \keyword{smooth} \keyword{models} \keyword{regression} gss/man/penny.Rd0000644000176200001440000000142112355360640013243 0ustar liggesusers\name{penny} \alias{penny} \title{Thickness of US Lincoln Pennies} \description{ Thickness of US Lincoln pennies minted during years 1945 through 1989. } \usage{data(nox)} \format{ A data frame containing 90 observations on the following variables. \tabular{ll}{ \code{year} \tab Year minted.\cr \code{mil} \tab Thickness in mils. } } \source{ Scott, D. W. (1992), \emph{Multivariate Density Estimation: Theory, Practice and Visualization}. New York: Wiley. } \references{ Gu, C. (1995), Smoothing spline density estimation: Conditional distribution, \emph{Statistica Sinica}, \bold{5}, 709--726. Scott, D. W. (1992), \emph{Multivariate Density Estimation: Theory, Practice and Visualization}. New York: Wiley. } \keyword{datasets} gss/man/ColoCan.Rd0000644000176200001440000000323312355360640013433 0ustar liggesusers\name{ColoCan} \alias{ColoCan} \title{Colorectal Cancer Mortality Rate in Indiana Counties} \description{ County-wise death counts of colorectal cancer patients in Indiana during years 2000 through 2004. } \usage{data(ColoCan)} \format{ A data frame containing 184 observations on the following variables. \tabular{ll}{ \code{event} \tab Death counts.\cr \code{pop} \tab Population from Census 2000.\cr \code{sex} \tab Gender of population.\cr \code{wrt} \tab Proportion of Whites.\cr \code{brt} \tab Proportion of Blacks.\cr \code{ort} \tab Proportion of other minorities.\cr \code{lat} \tab Latitude.\cr \code{lon} \tab Longitude.\cr \code{geog} \tab Geographic location, derived from \code{lat} and \code{lon}.\cr \code{scrn} \tab Colorectal cancer screening rate.\cr \code{name} \tab County name. } } \details{ \code{geog} was generated from \code{lat} and \code{lon} using the code given in the example section. } \source{ Dr. Tonglin Zhang. } \references{ Zhang, T. and Lin, G. (2009), Cluster detection based on spatial associations and iterated residuals in generalized linear mixed models. \emph{Biometrics}, \bold{65}, 353--360. } \examples{ ## Converting latitude and longitude to x-y coordinates ## The 49th county is Marion, where Indianapolis is located. \dontrun{ltln2xy <- function(latlon,latlon0) { lat <- latlon[,1]*pi/180; lon <- latlon[,2]*pi/180 lt0 <- latlon0[1]*pi/180; ln0 <- latlon0[2]*pi/180 x <- cos(lt0)*sin(lon-ln0); y <- sin(lat-lt0) cbind(x,y) } data(ColoCan) latlon <- as.matrix(ColoCan[,c("lat","lon")]) ltln2xy(latlon,latlon[49,]) ## Clean up rm(ltln2xy,ColoCan,latlon)} } \keyword{datasets} gss/man/gastric.Rd0000644000176200001440000000126312355360640013552 0ustar liggesusers\name{gastric} \alias{gastric} \title{Gastric Cancer Data} \description{ Survival of gastric cancer patients under chemotherapy and chemotherapy-radiotherapy combination. } \usage{data(gastric)} \format{ A data frame containing 90 observations on the following variables. \tabular{ll}{ \code{futime} \tab Follow-up time, in days.\cr \code{status} \tab Censoring status.\cr \code{trt} \tab Factor indicating the treatments: 1 -- chemothrapy, 2 -- combination. } } \source{ Moreau, T., O'Quigley, J., and Mesbah, M. (1985), A global goodness-of-fit statistic for the proportional hazards model. \emph{Applied Statistics}, \bold{34}, 212-218. } \keyword{datasets} gss/man/buffalo.Rd0000644000176200001440000000065712355360640013542 0ustar liggesusers\name{buffalo} \alias{buffalo} \title{Buffalo Annual Snowfall} \description{ Annual snowfall accumulations in Buffalo, NY from 1910 to 1973. } \usage{data(buffalo)} \format{ A vector of 63 numerical values. } \source{ Scott, D. W. (1985), Average shifted histograms: Effective nonparametric density estimators in several dimensions. \emph{The Annals of Statistics}, \bold{13}, 1024--1040. } \keyword{datasets} gss/man/dsscden.Rd0000644000176200001440000000300612355360640013536 0ustar liggesusers\name{dsscden} \alias{dsscden} \alias{psscden} \alias{qsscden} \alias{d.sscden} \alias{d.sscden1} \title{Evaluating PDF, CDF, and Quantiles of Smoothing Spline Conditional Density Estimates} \description{ Evaluate pdf, cdf, and quantiles for smoothing spline conditional density estimates. } \usage{ dsscden(object, y, x) psscden(object, q, x) qsscden(object, p, x) d.sscden(object, x, y) d.sscden1(object, x, y, scale=TRUE) } \arguments{ \item{object}{Object of class \code{"sscden"} or \code{"sscden1"}.} \item{x}{Data frame of x values on which conditional density f(y|x) is to be evaluated.} \item{y}{Data frame or vector of points on which conditional density f(y|x) is to be evaluated.} \item{q}{Vector of points on which cdf is to be evaluated.} \item{p}{Vector of probabilities for which quantiles are to be calculated.} \item{scale}{Flag indicating whether to use approximate scaling without quadrature.} } \value{ A matrix or vector of pdf, cdf, or quantiles of f(y|x), with each column corresponding to a distinct x value. } \details{ The arguments \code{x} and \code{y} are of the same form as the argument \code{newdata} in \code{\link{predict.lm}}, but \code{y} in \code{dsscden} can take a vector for 1-D responses. \code{psscden} and \code{qsscden} naturally only work for 1-D responses. } \seealso{ Fitting function \code{\link{sscden}} and \code{\link{cdsscden}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/Sachs.Rd0000644000176200001440000000256312355360640013163 0ustar liggesusers\name{Sachs} \alias{Sachs} \title{Protein Expression in Human Immune System Cells} \description{ Data concerning protein expression levels in human immune system cells under stimulations. } \usage{data(Sachs)} \format{ A data frame containing 7466 cells, with flow cytometry measurements of 11 phosphorylated proteins and phospholipids, on the \code{log10} scale of the original. \tabular{ll}{ \code{praf} \tab Raf phosphorylated at S259.\cr \code{pmek} \tab Mek1/mek2 phosphorylated at S217/S221.\cr \code{plcg} \tab Phosphorylation of phospholipase \eqn{C-\gamma} on Y783.\cr \code{pip2} \tab Phophatidylinositol 4,5-biphosphate.\cr \code{pip3} \tab Phophatidylinositol 3,4,5-triphosphate.\cr \code{p44.42} \tab Erk1/erk2 phosphorylated at T202/Y204.\cr \code{pakts473} \tab AKT phosphorylated at S473.\cr \code{pka} \tab Phosphorylation of of protein kinase A substrates on 3 sites.\cr \code{pkc} \tab Phosphorylation of of protein kinase C substrates on S660.\cr \code{p38} \tab Erk1/erk2 phosphorylated at T180/Y182.\cr \code{pjnk} \tab Erk1/erk2 phosphorylated at T183/Y185.\cr } } \source{ Sachs, K., Perez, O., Pe'er, D., Lauffenburger, D. A., and Nolan, G. P. (2005), Causal protein-signaling networks derived from multiparameter single-cell data. \emph{Science}, \bold{308 (5732)}, 523--529. } \keyword{datasets} gss/man/predict.sscox.Rd0000644000176200001440000000313712355360640014710 0ustar liggesusers\name{predict.sscox} \alias{predict.sscox} \title{Evaluating Smoothing Spline ANOVA Estimate of Relative Risk} \description{ Evaluate terms in a smoothing spline ANOVA estimate of relative risk at arbitrary points. Standard errors of the terms can be requested for use in constructing Bayesian confidence intervals. } \usage{ \method{predict}{sscox}(object, newdata, se.fit=FALSE, include=c(object$terms$labels,object$lab.p), ...) } \arguments{ \item{object}{Object of class \code{"sscox"}.} \item{newdata}{Data frame or model frame in which to predict.} \item{se.fit}{Flag indicating if standard errors are required.} \item{include}{List of model terms to be included in the prediction.} \item{...}{Ignored.} } \value{ For \code{se.fit=FALSE}, \code{predict.sscox} returns a vector of the evaluated relative risk. For \code{se.fit=TRUE}, \code{predict.sscox} returns a list consisting of the following components. \item{fit}{Vector of evaluated relative risk.} \item{se.fit}{Vector of standard errors for log relative risk.} } \note{ For mixed-effect models through \code{\link{sscox}}, the Z matrix is set to 0 if not supplied. To supply the Z matrix, add a component \code{random=I(...)} in \code{newdata}, where the as-is function \code{I(...)} preserves the integrity of the Z matrix in data frame. } \seealso{ Fitting functions \code{\link{sscox}} and method \code{\link{project.sscox}}. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \keyword{models} \keyword{regression} \keyword{smooth} \keyword{survival} gss/man/gssanova0.Rd0000644000176200001440000002044412355360640014021 0ustar liggesusers\name{gssanova0} \alias{gssanova0} \alias{gssanova1} \title{Fitting Smoothing Spline ANOVA Models with Non-Gaussian Responses} \description{ Fit smoothing spline ANOVA models in non-Gaussian regression. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}} and \code{\link{glm}}. } \usage{ gssanova0(formula, family, type=NULL, data=list(), weights, subset, offset, na.action=na.omit, partial=NULL, method=NULL, varht=1, nu=NULL, prec=1e-7, maxiter=30) gssanova1(formula, family, type=NULL, data=list(), weights, subset, offset, na.action=na.omit, partial=NULL, method=NULL, varht=1, alpha=1.4, nu=NULL, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{family}{Description of the error distribution. Supported are exponential families \code{"binomial"}, \code{"poisson"}, \code{"Gamma"}, \code{"inverse.gaussian"}, and \code{"nbinomial"}. Also supported are accelerated life model families \code{"weibull"}, \code{"lognorm"}, and \code{"loglogis"}.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{weights}{Optional vector of weights to be used in the fitting process.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{offset}{Optional offset term with known parameter 1.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{partial}{Optional symbolic description of parametric terms in partial spline models.} \item{method}{Score used to drive the performance-oriented iteration. Supported are \code{method="v"} for GCV, \code{method="m"} for GML, and \code{method="u"} for Mallows' CL.} \item{varht}{Dispersion parameter needed for \code{method="u"}. Ignored when \code{method="v"} or \code{method="m"} are specified.} \item{nu}{Inverse scale parameter in accelerated life model families. Ignored for exponential families.} \item{prec}{Precision requirement for the iterations.} \item{maxiter}{Maximum number of iterations allowed for performance-oriented iteration, and for inner-loop multiple smoothing parameter selection when applicable.} \item{alpha}{Tuning parameter modifying GCV or Mallows' CL.} \item{id.basis}{Index designating selected "knots".} \item{nbasis}{Number of "knots" to be selected. Ignored when \code{id.basis} is supplied.} \item{seed}{Seed for reproducible random selection of "knots". Ignored when \code{id.basis} is supplied.} \item{random}{Input for parametric random effects in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model specification via \code{formula} is intuitive. For example, \code{y~x1*x2} yields a model of the form \deqn{ y = C + f_{1}(x1) + f_{2}(x2) + f_{12}(x1,x2) + e } with the terms denoted by \code{"1"}, \code{"x1"}, \code{"x2"}, and \code{"x1:x2"}. The model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. Only one link is implemented for each \code{family}. It is the logit link for \code{"binomial"}, and the log link for \code{"poisson"}, \code{"Gamma"}, and \code{"inverse.gaussian"}. For \code{"nbinomial"}, the working parameter is the logit of the probability \eqn{p}; see \code{\link{NegBinomial}}. For \code{"weibull"}, \code{"lognorm"}, and \code{"loglogis"}, it is the location parameter for the log lifetime. The models are fitted by penalized likelihood method through the performance-oriented iteration as described in the reference. For \code{family="binomial"}, \code{"poisson"}, \code{"nbinomial"}, \code{"weibull"}, \code{"lognorm"}, and \code{"loglogis"}, the score driving the performance-oriented iteration defaults to \code{method="u"} with \code{varht=1}. For \code{family="Gamma"} and \code{"inverse.gaussian"}, the default is \code{method="v"}. \code{gssanova0} uses the algorithm of \code{\link{ssanova0}} for the iterated penalized least squares problems, whereas \code{gssanova1} uses the algorithm of \code{\link{ssanova}}. In \code{gssanova1}, a subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \section{Responses}{ For \code{family="binomial"}, the response can be specified either as two columns of counts or as a column of sample proportions plus a column of total counts entered through the argument \code{weights}, as in \code{\link{glm}}. For \code{family="nbinomial"}, the response may be specified as two columns with the second being the known sizes, or simply as a single column with the common unknown size to be estimated through the maximum likelihood. For \code{family="weibull"}, \code{"lognorm"}, or \code{"loglogis"}, the response consists of three columns, with the first giving the follow-up time, the second the censoring status, and the third the left-truncation time. For data with no truncation, the third column can be omitted. } \value{ \code{gssanova0} returns a list object of class \code{c("gssanova0","ssanova0","gssanova")}. \code{gssanova1} returns a list object of class \code{c("gssanova","ssanova")}. The method \code{\link{summary.gssanova0}} or \code{\link{summary.gssanova}} can be used to obtain summaries of the fits. The method \code{\link{predict.ssanova0}} or \code{\link{predict.ssanova}} can be used to evaluate the fits at arbitrary points along with standard errors, on the link scale. The methods \code{\link{residuals.gssanova}} and \code{\link{fitted.gssanova}} extract the respective traits from the fits. } \note{ The direct cross-validation of \code{\link{gssanova}} can be more effective, and more stable for complex models. For large sample sizes, the approximate solutions of \code{\link{gssanova1}} and \code{\link{gssanova}} can be faster than \code{\link{gssanova0}}. The results from \code{gssanova1} may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. The method \code{\link{project}} is not implemented for \code{gssanova0}, nor is the mixed-effect model support through \code{\link{mkran}}. In \emph{gss} versions earlier than 1.0, \code{gssanova0} was under the name \code{gssanova}. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. (1992), Cross-validating non Gaussian data. \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 169-179. Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. GU, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## Fit a cubic smoothing spline logistic regression model test <- function(x) {.3*(1e6*(x^11*(1-x)^6)+1e4*(x^3*(1-x)^10))-2} x <- (0:100)/100 p <- 1-1/(1+exp(test(x))) y <- rbinom(x,3,p) logit.fit <- gssanova0(cbind(y,3-y)~x,family="binomial") ## The same fit logit.fit1 <- gssanova0(y/3~x,"binomial",weights=rep(3,101)) ## Obtain estimates and standard errors on a grid est <- predict(logit.fit,data.frame(x=x),se=TRUE) ## Plot the fit and the Bayesian confidence intervals plot(x,y/3,ylab="p") lines(x,p,col=1) lines(x,1-1/(1+exp(est$fit)),col=2) lines(x,1-1/(1+exp(est$fit+1.96*est$se)),col=3) lines(x,1-1/(1+exp(est$fit-1.96*est$se)),col=3) ## Clean up \dontrun{rm(test,x,p,y,logit.fit,logit.fit1,est) dev.off()} } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/mkcov.Rd0000644000176200001440000000257312355360640013242 0ustar liggesusers\name{mkcov} \alias{mkcov} \alias{mkcov.arma} \alias{mkcov.long} \alias{mkcov.known} \title{ Generating Covariance for Correlated Data } \description{ Generate entries of covariance functions for correlated data. } \usage{ mkcov.arma(p, q, n) mkcov.long(id) mkcov.known(w) } \arguments{ \item{p}{Order of AR terms.} \item{q}{Order of MA terms.} \item{n}{Dimension of covariance matrix.} \item{id}{Factor of subject ID.} \item{w}{Covariance matrix; only the upper triangular part is used.} } \details{ \code{mkcov.arma} generates covariance functions for ARMA(p,q) model. \code{mkcov.long} generates covariance functions for longitudinal data. \code{mkcov.known} allows one to use a known covariance matrix in \code{ssanova9}. } \value{ A list of three components. \item{fun}{Covariance matrix to be evaluated through \code{fun(gamma,env)} or \code{fun(env)}.} \item{env}{Constants in covariance function.} \item{init}{Initial values for correlation parameters.} } \note{ One may pass \code{list(fun=...,env=...,init=...)} directly to the argument \code{cov} in calls to \code{\link{ssanova9}}, or make use of the \code{mkcov.x} functions through \code{cov=list("arma",c(p,q))}, \code{cov=list("long",id)}, or \code{cov=list("known",w)}. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \keyword{internal} gss/man/ssden.Rd0000644000176200001440000002111012355360640013223 0ustar liggesusers\name{ssden} \alias{ssden} \alias{ssden1} \title{Estimating Probability Density Using Smoothing Splines} \description{ Estimate probability densities using smoothing spline ANOVA models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}, but with the response missing. } \usage{ ssden(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, na.action=na.omit, id.basis=NULL, nbasis=NULL, seed=NULL, domain=as.list(NULL), quad=NULL, qdsz.depth=NULL, bias=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) ssden1(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, na.action=na.omit, id.basis=NULL, nbasis=NULL, seed=NULL, domain=as.list(NULL), quad=NULL, prec=1e-7, maxiter=30) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{alpha}{Parameter defining cross-validation score for smoothing parameter selection.} \item{weights}{Optional vector of bin-counts for histogram data.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{id.basis}{Index of observations to be used as "knots."} \item{nbasis}{Number of "knots" to be used. Ignored when \code{id.basis} is specified.} \item{seed}{Seed to be used for the random generation of "knots." Ignored when \code{id.basis} is specified.} \item{domain}{Data frame specifying marginal support of density.} \item{quad}{Quadrature for calculating integral. Mandatory if variables other than factors or numerical vectors are involved.} \item{qdsz.depth}{Depth to be used in \code{\link{smolyak.quad}} for the generation of quadrature.} \item{bias}{Input for sampling bias.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model specification via \code{formula} is for the log density. For example, \code{~x1*x2} prescribes a model of the form \deqn{ log f(x1,x2) = g_{1}(x1) + g_{2}(x2) + g_{12}(x1,x2) + C } with the terms denoted by \code{"x1"}, \code{"x2"}, and \code{"x1:x2"}; the constant is determined by the fact that a density integrates to one. The selective term elimination may characterize (conditional) independence structures between variables. For example, \code{~x1*x2+x1*x3} yields the conditional independence of x2 and x3 given x1. Parallel to those in a \code{\link{ssanova}} object, the model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. The selection of smoothing parameters is through a cross-validation mechanism described in the references, with a parameter \code{alpha}; \code{alpha=1} is "unbiased" for the minimization of Kullback-Leibler loss but may yield severe undersmoothing, whereas larger \code{alpha} yields smoother estimates. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ In \code{ssden}, default quadrature will be constructed for numerical vectors on a hyper cube, then outer product with factor levels will be taken if factors are involved. The sides of the hyper cube are specified by \code{domain}; for \code{domain$x} missing, the default is \code{c(min(x),max(x))+c(-1,1)*(max(x)-mimn(x))*.05}. In 1-D, the quadrature is the 200-point Gauss-Legendre formula returned from \code{\link{gauss.quad}}. In multi-D, delayed Smolyak cubatures from \code{\link{smolyak.quad}} are used on cubes with the marginals properly transformed; see Gu and Wang (2003) for the marginal transformations. For reasonable execution time in higher dimensions, set \code{skip.iter=TRUE} in call to \code{ssden}. If you get an error message from \code{ssden} stating \code{"Newton iteration diverges"}, try to use a larger \code{qdsz.depth} which will execute slower, or switch to \code{ssden1}. The default values of \code{qdsz.depth} for dimensions 4, 5, 6+ are 12, 11, 10. \code{ssden1} does not involve multi-D quadrature but does not perform as well as \code{ssden}. It can be used in very high dimensions where \code{ssden} is infeasible. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{ssden} returns a list object of class \code{"ssden"}. \code{ssden1} returns a list object of class \code{c("ssden1","ssden")}. \code{\link{dssden}} and \code{\link{cdssden}} can be used to evaluate the estimated joint density and conditional density; \code{\link{pssden}}, \code{\link{qssden}}, \code{\link{cpssden}}, and \code{\link{cqssden}} can be used to evaluate (conditional) cdf and quantiles. The method \code{\link{project.ssden}} can be used to calculate the Kullback-Leibler projection of \code{"ssden"} objects for model selection; \code{\link{project.ssden1}} can be used to calculate the square error projection of \code{"ssden1"} objects. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. and Wang, J. (2003), Penalized likelihood density estimation: Direct cross-validation and scalable approximation. \emph{Statistica Sinica}, \bold{13}, 811--826. Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## 1-D estimate: Buffalo snowfall data(buffalo) buff.fit <- ssden(~buffalo,domain=data.frame(buffalo=c(0,150))) plot(xx<-seq(0,150,len=101),dssden(buff.fit,xx),type="l") plot(xx,pssden(buff.fit,xx),type="l") plot(qq<-seq(0,1,len=51),qssden(buff.fit,qq),type="l") ## Clean up \dontrun{rm(buffalo,buff.fit,xx,qq) dev.off()} ## 2-D with triangular domain: AIDS incubation data(aids) ## rectangular quadrature quad.pt <- expand.grid(incu=((1:40)-.5)/40*100,infe=((1:40)-.5)/40*100) quad.pt <- quad.pt[quad.pt$incu<=quad.pt$infe,] quad.wt <- rep(1,nrow(quad.pt)) quad.wt[quad.pt$incu==quad.pt$infe] <- .5 quad.wt <- quad.wt/sum(quad.wt)*5e3 ## additive model (pre-truncation independence) aids.fit <- ssden(~incu+infe,data=aids,subset=age>=60, domain=data.frame(incu=c(0,100),infe=c(0,100)), quad=list(pt=quad.pt,wt=quad.wt)) ## conditional (marginal) density of infe jk <- cdssden(aids.fit,xx<-seq(0,100,len=51),data.frame(incu=50)) plot(xx,jk$pdf,type="l") ## conditional (marginal) quantiles of infe (TIME-CONSUMING) \dontrun{ cqssden(aids.fit,c(.05,.25,.5,.75,.95),data.frame(incu=50)) } ## Clean up \dontrun{rm(aids,quad.pt,quad.wt,aids.fit,jk,xx) dev.off()} ## One factor plus one vector data(gastric) gastric$trt fit <- ssden(~futime*trt,data=gastric) ## conditional density cdssden(fit,c("1","2"),cond=data.frame(futime=150)) ## conditional quantiles cqssden(fit,c(.05,.25,.5,.75,.95),data.frame(trt="1")) ## Clean up \dontrun{rm(gastric,fit)} ## Sampling bias ## (X,T) is truncated to Tt)&(x<1) while(m<-sum(!ok)) { t[!ok] <- runif(m) x[!ok] <- rnorm(m,.5,.15) ok <- (x>t)&(x<1) } cbind(x,t) } xt <- rbias(100) x <- xt[,1]; t <- xt[,2] ## length-biased bias1 <- list(t=1,wt=1,fun=function(t,x){x[,]}) fit1 <- ssden(~x,domain=list(x=c(0,1)),bias=bias1) plot(xx<-seq(0,1,len=101),dssden(fit1,xx),type="l") ## truncated bias2 <- list(t=t,wt=rep(1/100,100),fun=function(t,x){x[,]>t}) fit2 <- ssden(~x,domain=list(x=c(0,1)),bias=bias2) plot(xx,dssden(fit2,xx),type="l") ## Clean up \dontrun{rm(rbias,xt,x,t,bias1,fit1,bias2,fit2)} } \keyword{smooth} \keyword{models} \keyword{distribution} gss/man/nox.Rd0000644000176200001440000000211412355360640012716 0ustar liggesusers\name{nox} \alias{nox} \title{NOx in Engine Exhaust} \description{ Data from an experiment in which a single-cylinder engine was run with ethanol to see how the NOx concentration in the exhaust depended on the compression ratio and the equivalence ratio. } \usage{data(nox)} \format{ A data frame containing 88 observations on the following variables. \tabular{ll}{ \code{nox} \tab NOx concentration in exhaust.\cr \code{comp} \tab Compression ratio.\cr \code{equi} \tab Equivalence ratio. } } \source{ Brinkman, N. D. (1981), Ethanol fuel -- a single-cylinder engine study of efficiency and exhaust emissions. \emph{SAE Transactions}, \bold{90}, 1410--1424. } \references{ Cleveland, W. S. and Devlin, S. J. (1988), Locally weighted regression: An approach to regression analysis by local fitting. \emph{Journal of the American Statistical Association}, \bold{83}, 596--610. Breiman, L. (1991), The pi method for estimating multivariate functions from noisy data. \emph{Technometrics}, \bold{33}, 125--160. } \keyword{datasets} gss/man/cdssden.Rd0000644000176200001440000000320612355360640013540 0ustar liggesusers\name{cdssden} \alias{cdssden} \alias{cpssden} \alias{cqssden} \title{Evaluating Conditional PDF, CDF, and Quantiles of Smoothing Spline Density Estimates} \description{ Evaluate conditional pdf, cdf, and quantiles for smoothing spline density estimates. } \usage{ cdssden(object, x, cond, int=NULL) cpssden(object, q, cond) cqssden(object, p, cond) } \arguments{ \item{object}{Object of class \code{"ssden"}.} \item{x}{Data frame or vector of points on which conditional density is to be evaluated.} \item{cond}{One row data frame of conditioning variables.} \item{int}{Normalizing constant.} \item{q}{Vector of points on which conditional cdf is to be evaluated.} \item{p}{Vector of probabilities for which conditional quantiles are to be calculated.} } \value{ \code{cdssden} returns a list object with the following components. \item{pdf}{Vector of conditional pdf.} \item{int}{Normalizing constant.} \code{cpssden} and \code{cqssden} return a vector of conditional cdf or quantiles. } \details{ The argument \code{x} in \code{cdssden} is of the same form as the argument \code{newdata} in \code{\link{predict.lm}}, but can take a vector for 1-D conditional densities. \code{cpssden} and \code{cqssden} naturally only work for 1-D conditional densities of a numerical variable. } \note{ If variables other than factors or numerical vectors are involved in \code{x}, the normalizing constant can not be computed. } \seealso{ Fitting function \code{\link{ssden}} and \code{\link{dssden}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/mkrk.nominal.Rd0000644000176200001440000000245112355360640014516 0ustar liggesusers\name{mkrk.nominal} \alias{mkrk.nominal} \alias{mkrk.ordinal} \title{ Crafting Building Blocks for Discrete Splines } \description{ Craft numerical functions to be used by \code{mkterm} to assemble model terms involving factors. } \usage{ mkrk.nominal(levels) mkrk.ordinal(levels) } \arguments{ \item{levels}{Levels of the factor.} } \details{ For a nominal factor with levels \eqn{1,2,\dots,k}, the level means \eqn{f(i)} will be shrunk towards each other through a penalty proportional to \deqn{(f(1)-f(.))^2+\dots+(f(k)-f(.))^2} where \eqn{f(.)=(f(1)+\dots+f(k))/k}. For a ordinal factor with levels \eqn{1<2<\dotsd}. \code{mkrk.tp.p} generates the pseudo kernel, and \code{mkphi.tp.p} generates the \eqn{(m+d-1)!/d!/(m-1)!} lower order polynomials with total order less than \eqn{m}. \code{mkphi.tp} generates normalized lower order polynomials orthonormal w.r.t. a norm specified by \code{mesh} and \code{weight}, and \code{mkrk.tp} conditions the pseudo kernel to generate the reproducing kernel orthogonal to the lower order polynomials w.r.t. the norm. \code{mkrk.sphere} implements the reproducing kernel construction of Wahba (1981) for \eqn{m=2,3,4}. } \value{ A list of two components. \item{fun}{Function definition.} \item{env}{Portable local constants derived from the arguments.} } \note{ \code{mkrk.tp} and \code{mkrk.sphere} create a bivariate function \code{fun(x,y,env,outer=FALSE)}, where \code{x}, \code{y} are real arguments and local constants can be passed in through \code{env}. \code{mkphi.tp} creates a collection of univariate functions \code{fun(x,nu,env)}, where \code{x} is the argument and \code{nu} is the index. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Wahba, G. (1981), Spline interpolation and smoothing on the sphere. \emph{SIAM Journal on Scientific and Statistical Computing}, \bold{2}, 5--16. } \seealso{ \code{\link{mkterm}}, \code{\link{mkfun.poly}}, and \code{\link{mkrk.nominal}}. } \keyword{internal} gss/INDEX0000644000176200001440000003212413053711146011643 0ustar liggesusers## SSANOVA, GSSANOVA, SSDEN, SSCDEN, SSLLRM, SSHZD, AND SSCOX SUITES ssanova Fitting smoothing spline ANOVA models predict.ssanova Predicting from ssanova fits predict1.ssanova Predicting from ssanova fits summary.ssanova Summarizing ssanova fits project.ssanova Projecting ssanova fits for model diagnostic ssanova9 Fitting smoothing spline ANOVA models with correlated data summary.ssanova9 Summarizing ssanova9 fits project.ssanova9 Projecting ssanova9 fits for model diagnostic ssanova0 Fitting smoothing spline ANOVA models predict.ssanova0 Predicting from ssanova0 fits summary.ssanova0 Summarizing ssanova0 fits residuals.ssanova Extracting the residuals from ssanova objects fitted.ssanova Extracting the fitted values from ssanova objects print.ssanova Print function for ssanova objects print.ssanova0 Print function for ssanova0 objects print.summary.ssanova Print function for summary.ssanova objects gssanova Fitting smoothing spline ANOVA models with non Gaussian data gssanova1 Fitting smoothing spline ANOVA models with non Gaussian data summary.gssanova Summarizing gssanova fits project.gssanova Projecting gssanova1 fits for model diagnostic gssanova0 Fitting smoothing spline ANOVA models with non Gaussian data summary.gssanova0 Summarizing gssanova0 fits residuals.gssanova Extracting the residuals from gssanova objects fitted.gssanova Extracting the fitted values from gssanova objects print.gssanova Print function for gssanova objects print.summary.gssanova Print function for summary.gssanova objects print.summary.gssanova0 Print function for summary.gssanova0 objects ssden Estimating probability density using smoothing splines d.ssden Evaluating pdf of ssden estimates project.ssden Projecting ssden fits for model diagnostic ssden1 Estimating probability density using smoothing splines d.ssden1 Evaluating pdf of ssden1 estimates project.ssden1 Projecting ssden1 fits for model diagnostic dssden Evaluating pdf of ssden estimates pssden Evaluating cdf of 1-D ssden estimates qssden Evaluating quantiles of 1-D ssden estimates cdssden Evaluating conditional pdf of ssden estimates cpssden Evaluating 1-D conditional cdf of ssden estimates cqssden Evaluating 1-D conditional quantiles of ssden estimates print.ssden Print function for ssden objects sscden Estimating conditional density using smoothing splines d.sscden Evaluating pdf of sscden estimates project.sscden Projecting sscden fits for model diagnostic sscden1 Estimating conditional density using smoothing splines d.sscden1 Evaluating pdf of sscden1 estimates project.sscden1 Projecting sscden1 fits for model diagnostic dsscden Evaluating pdf of sscden estimates psscden Evaluating cdf of sscden estimates with 1-D Y qsscden Evaluating quantiles of ssden estimates with 1-D Y cdsscden Evaluating conditional pdf of sscden estimates cpsscden Evaluating 1-D conditional cdf of sscden estimates cqsscden Evaluating 1-D conditional quantiles of sscden estimates print.sscden Print function for sscden objects ssllrm Fitting smoothing spline log-linear regression models predict.ssllrm Evaluating log-linear regression model fits project.ssllrm Projecting ssllrm fits for model diagnostic print.ssllrm Print function for ssllrm objects sshzd Estimating hazard function using smoothing splines project.sshzd Projecting sshzd fits for model diagnostic sshzd1 Estimating hazard function using smoothing splines project.sshzd1 Projecting sshzd1 fits for model diagnostic hzdrate.sshzd Evaluating hazard estimates hzdcurve.sshzd Evaluating hazard curves survexp.sshzd Computing expected survivals print.sshzd Print function for sshzd objects sscox Estimating relative risk using smoothing splines predict.sscox Projecting sscox fits for model diagnostic project.sscox Predicting from sscox fits print.sscox Print function for sscox objects ## UTILITIES FOR MAKING MODEL TERMS mkterm Making model terms mkphi.cubic Making phi function for cubic splines mkrk.cubic Making RK function for cubic splines mkrk.cubic.per Making RK function for periodic cubic splines mkrk.linear Making RK function for linear splines mkrk.linear.per Making RK function for periodic linear splines mkphi.tp Making phi functions for thin-plate splines mkphi.tp.p Making pseudo phi functions for thin-plate splines mkrk.tp Making RK functions for thin-plate splines mkrk.tp.p Making pseudo RK functions for thin-plate splines mkrk.sphere Making RK functions for spherical splines mkrk.nominal Making RK function for nominal factors mkrk.ordinal Making RK function for ordinal factors mkran Generating random effects in mixed-effect models mkran1 Combining random effects in mixed-effect models mkcov.arma Making covariance function for ARMA models mkcov.long Making covariance function for longitudinal data mkcov.known Passing known covariance function to ssanova9 mkint Generating integrals of basis terms for ssden1 suite mkint2 Generating integrals of basis terms for ssden1 suite ## UTILITIES FOR DISTRIBUTION FAMILIES mkdata.binomial Making pseudo data for logistic regression dev.resid.binomial Deviance residuals for logistic regression dev.null.binomial Null model deviance for logistic regression cv.binomial CV score for logistic regression y0.binomial Preparing for KL projection of logistic fit proj0.binomial Making pseudo data for projection of logistic fit kl.binomial Computing KL distance between logistic fits cfit.binomial Computing constant logistic fit mkdata.poisson Making pseudo data for Poisson regression dev.resid.poisson Deviance residuals for Poisson regression dev.null.poisson Null model deviance for Poisson regression cv.poisson CV score for Poisson regression y0.poisson Preparing for KL projection of Poisson fit proj0.poisson Making pseudo data for projection of Poisson fit kl.poisson Computing KL distance between Poisson fits cfit.poisson Computing constant Poisson fit mkdata.Gamma Making pseudo data for gamma regression dev.resid.Gamma Deviance residuals for gamma regression dev.null.Gamma Null model deviance for gamma regression cv.Gamma CV score for gamma regression y0.Gamma Preparing for KL projection of Gamma fit proj0.Gamma Making pseudo data for projection of Gamma fit kl.Gamma Computing KL distance between Gamma fits cfit.Gamma Computing constant Gamma fit mkdata.inverse.gaussian Making pseudo data for IG regression dev.resid.inverse.gaussian Deviance residuals for IG regression dev.null.inverse.gaussian Null model deviance for IG regression mkdata.nbinomial Making pseudo data for negative binomial regression dev.resid.nbinomial Deviance residuals for negative binomial regression dev.null.nbinomial Null model deviance for negative binomial regression cv.nbinomial CV score for negative binomial regression y0.nbinomial Preparing for KL projection of negative binomial fit proj0.nbinomial Making pseudo data for projection of negative binomial fit kl.nbinomial Computing KL distance between negative binomial fits cfit.nbinomial Computing constant negative binomial fit mkdata.weibull Making pseudo data for Weibull regression dev.resid.weibull Deviance residuals for Weibull regression dev.null.weibull Null model deviance for Weibull regression cv.weibull CV score for Weibull regression y0.weibull Preparing for KL projection of Weibull fit proj0.weibull Making pseudo data for projection of Weibull fit kl.weibull Computing KL distance between Weibull fits cfit.weibull Computing constant Weibull fit mkdata.lognorm Making pseudo data for log normal regression dev.resid.lognorm Deviance residuals for log normal regression dev0.resid.lognorm Pseudo deviance residuals for log normal regression dev.null.lognorm Null model deviance for log normal regression cv.lognorm CV score for log normal regression y0.lognorm Preparing for KL projection of log normal fit proj0.lognorm Making pseudo data for projection of log normal fit kl.lognorm Computing KL distance between log normal fits cfit.lognorm Computing constant log normal fit mkdata.loglogis Making pseudo data for log logistic regression dev.resid.loglogis Deviance residuals for log logistic regression dev0.resid.loglogis Pseudo deviance residuals for log logistic regression dev.null.loglogis Null model deviance for log logistic regression cv.loglogis CV score for log logistic regression y0.loglogis Preparing for KL projection of log logistic fit proj0.loglogis Making pseudo data for projection of log logistic fit kl.loglogis Computing KL distance between log logistic fits cfit.loglogis Computing constant log logistic fit ## UTILITIES FOR NUMERICAL INTEGRATION gauss.quad Generating Gauss-Legendre quadrature smolyak.quad Generating Smolyak cubature smolyak.size Getting the size of Smolyak cubature ## UTILITY FOR OPTIMIZATION nlm0 Minimizing univariate functions on finite intervals ## NUMERICAL ENGINE sspreg0 An interface to RKPACK driver DSIDR mspreg0 An interface to RKPACK driver DMUDR sspregpoi Performance-oriented iteration using RKPACK driver DSIDR mspregpoi Performance-oriented iteration using RKPACK driver DMUDR getcrdr An interface to RKPACK utility DCRDR getsms An interface to RKPACK utility DSMS sspreg1 Compute regression estimate with single smoothing parameter mspreg1 Compute regression estimate with multiple smoothing parameters sspreg91 Compute regression estimate with single smoothing parameter mspreg91 Compute regression estimate with multiple smoothing parameters sspngreg Compute NG regression estimate with single smoothing parameter mspngreg Compute NG regression estimate with single smoothing parameter ngreg Newton iteration for NG regression with fixed smoothing parameter ngreg1 Performance-oriented iteration using sspreg1 and mspreg1 regaux Obtain auxiliary information needed for se calculation ngreg.proj Calculate Kullback-Leibler projection for NG regression sspdsty Compute density estimate with single smoothing parameter mspdsty Compute density estimate with multiple smoothing parameters sspdsty1 Compute density estimate with single smoothing parameter mspdsty1 Compute density estimate with multiple smoothing parameters mspcdsty Compute conditional density estimate mspcdsty1 Compute conditional density estimate msphzd Compute hazard estimate with single or multiple smoothing parameters msphzd1 Compute hazard estimate with single or multiple smoothing parameters sspcox Compute relative risk estimate with single smoothing parameter mspcox Compute relative risk estimate with multiple smoothing parameters mspllrm Compute log-linear regression model with multiple smoothing parameters