eco/0000755000175100001440000000000013140010242011021 5ustar hornikuserseco/inst/0000755000175100001440000000000013061770754012025 5ustar hornikuserseco/inst/CITATION0000644000175100001440000000137313061770754013166 0ustar hornikuserscitHeader("To cite eco in publications use:") citEntry(entry = "Article", title = "eco: R Package for Ecological Inference in 2 x 2 Tables", author = personList(as.person("Kosuke Imai"), as.person("Ying Lu"), as.person("Aaron Strauss")), journal = "Journal of Statistical Software", year = "2011", volume = "42", number = "5", pages = "1--23", url = "http://www.jstatsoft.org/v42/i05/", textVersion = paste("Kosuke Imai, Ying Lu, and Aaron Strauss (2011).", "eco: R Package for Ecological Inference in 2 x 2 Tables.", "Journal of Statistical Software, Vol. 42, No. 5, pp. 1-23.", "URL http://www.jstatsoft.org/v42/i05/") ) eco/src/0000755000175100001440000000000013136253450011627 5ustar hornikuserseco/src/Makevars0000644000175100001440000000006313136253506013324 0ustar hornikusers PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) eco/src/rand.h0000644000175100001440000000146313136253506012732 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ double dMVN(double *Y, double *MEAN, double **SIG_INV, int dim, int give_log); double dMVT(double *Y, double *MEAN, double **SIG_INV, int nu, int dim, int give_log); void rMVN(double *Sample, double *mean, double **inv_Var, int size); void rWish(double **Sample, double **S, int df, int size); void rDirich(double *Sample, double *theta, int size); double dBVNtomo(double *Wstar, void* pp, int give_log, double normc); double invLogit(double x); double logit(double x,char* emsg); int bit(int t, int n); eco/src/fintegrate.h0000644000175100001440000000201413136253506014127 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ #include void NormConstT(double *t, int n, void *param); void SuffExp(double *t, int n, void *param); double getLogLikelihood(Param* param) ; void setNormConst(Param* param); double getW2starFromW1star(double X, double Y, double W1, int* imposs); double getW1starFromW2star(double X, double Y, double W2, int* imposs); double getW1FromW2(double X, double Y, double W2); double getW1starFromT(double t, Param* param, int* imposs); double getW2starFromT(double t, Param* param, int* imposs); double getW1starPrimeFromT(double t, Param* param); double getW2starPrimeFromT(double t, Param* param); double paramIntegration(integr_fn f, void *ex); void setNormConst(Param* param); void setBounds(Param* param); eco/src/gibbsDP.c0000644000175100001440000003366513136253506013324 0ustar hornikusers#include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" void cDPeco( /*data input */ double *pdX, /* data (X, Y) */ int *pin_samp, /* sample size */ /*MCMC draws */ int *n_gen, /* number of gibbs draws */ int *burn_in, /* number of draws to be burned in */ int *pinth, /* keep every nth draw */ int *verbose, /* 1 for output monitoring */ /* prior specification*/ int *pinu0, /* prior df parameter for InvWish */ double *pdtau0, /* prior scale parameter for Sigma under G0*/ double *mu0, /* prior mean for mu under G0 */ double *pdS0, /* prior scale for Sigma */ /* DP prior specification */ double *alpha0, /* precision parameter, can be fixed or updated*/ int *pinUpdate, /* 1 if alpha gets updated */ double *pda0, double *pdb0, /* prior for alpha if alpha updated*/ /*incorporating survey data */ int *survey, /* 1 if survey data available (set of W_1, W_2) */ /* 0 otherwise*/ int *sur_samp, /* sample size of survey data*/ double *sur_W, /* set of known W_1, W_2 */ /*incorporating homeogenous areas */ int *x1, /* 1 if X=1 type areas available W_1 known, W_2 unknown */ int *sampx1, /* number X=1 type areas */ double *x1_W1, /* values of W_1 for X1 type areas */ int *x0, /* 1 if X=0 type areas available W_2 known, W_1 unknown */ int *sampx0, /* number X=0 type areas */ double *x0_W2, /* values of W_2 for X0 type areas */ /* bounds of W1 */ double *minW1, double *maxW1, /* storage */ int *parameter, /* 1 if save population parameter */ int *Grid, /* 1 if Grid algorithm used; \ 0 if Metropolis algorithm used*/ /* storage for Gibbs draws of mu/sigmat*/ double *pdSMu0, double *pdSMu1, double *pdSSig00, double *pdSSig01, double *pdSSig11, /* storage for Gibbs draws of W*/ double *pdSW1, double *pdSW2, /* storage for Gibbs draws of alpha */ double *pdSa, /* storage for nstar at each Gibbs draw*/ int *pdSn ){ /*some integers */ int n_samp = *pin_samp; /* sample size */ int s_samp = *sur_samp; /* sample size of survey data */ int x1_samp = *sampx1; /* sample size for X=1 */ int x0_samp = *sampx0; /* sample size for X=0 */ int t_samp = n_samp+x1_samp+x0_samp+s_samp; /* total sample size */ int nth = *pinth; /* keep every nth draw */ int n_dim = 2; /* dimension */ int n_step=1000; /* The default size of grid step */ /*prior parameters */ double tau0 = *pdtau0; /* prior scale */ int nu0 = *pinu0; /* prior degree of freedom*/ double **S0 = doubleMatrix(n_dim,n_dim);/*The prior S parameter for InvWish*/ double alpha = *alpha0; /* precision parameter*/ double a0 = *pda0, b0 = *pdb0; /* hyperprior for alpha */ /* data */ double **X = doubleMatrix(n_samp,n_dim); /* The Y and covariates */ double **W = doubleMatrix(t_samp,n_dim); /* The W1 and W2 matrix */ double **Wstar = doubleMatrix(t_samp,n_dim); /* The pseudo data */ double **S_W = doubleMatrix(s_samp,n_dim); /* The known W1 and W2 matrix*/ double **S_Wstar = doubleMatrix(s_samp,n_dim); /* The logit transformed S_W*/ /* grids */ double **W1g = doubleMatrix(n_samp, n_step); /* grids for W1 */ double **W2g = doubleMatrix(n_samp, n_step); /* grids for W2 */ int *n_grid = intArray(n_samp); /* grids size */ /* Model parameters */ /* Dirichlet variables */ double **mu = doubleMatrix(t_samp,n_dim); /* mean matrix */ double ***Sigma = doubleMatrix3D(t_samp,n_dim,n_dim); /*covarince matrix*/ double ***InvSigma = doubleMatrix3D(t_samp,n_dim,n_dim); /* inv of Sigma*/ int nstar; /* # clusters with distict theta values */ int *C = intArray(t_samp); /* vector of cluster membership */ double *q = doubleArray(t_samp); /* Weights of posterior of Dirichlet */ double *qq = doubleArray(t_samp); /* cumulative weight vector of q */ double **S_bvt = doubleMatrix(n_dim,n_dim); /* S paramter for BVT in q0 */ /* variables defined in remixing step: cycle through all clusters */ double **Wstarmix = doubleMatrix(t_samp,n_dim); /*data matrix used */ double *mu_mix = doubleArray(n_dim); /*updated MEAN parameter */ double **Sigma_mix = doubleMatrix(n_dim,n_dim); /*updated VAR parameter */ double **InvSigma_mix = doubleMatrix(n_dim,n_dim); /* Inv of Sigma_mix */ int nj; /* record # of obs in each cluster */ int *sortC = intArray(t_samp); /* record (sorted)original obs id */ int *indexC = intArray(t_samp); /* record original obs id */ int *label = intArray(t_samp); /* store index values */ /* misc variables */ int i, j, k, l, main_loop; /* used for various loops */ int itemp; int itempA=0; /* counter for alpha */ int itempS=0; /* counter for storage */ int itempC=0; /* counter to control nth draw */ int progress = 1, itempP = ftrunc((double) *n_gen/10); double dtemp, dtemp1; double *vtemp = doubleArray(n_dim); double **mtemp = doubleMatrix(n_dim,n_dim); double **mtemp1 = doubleMatrix(n_dim,n_dim); double **onedata = doubleMatrix(1, n_dim); /* get random seed */ GetRNGstate(); /* read priors under G0*/ itemp=0; for(k=0;k qq[j]) j++; /** Dirichlet update Sigma_i, mu_i|Sigma_i **/ /* j=i: posterior update given Wstar[i] */ if (j==i){ onedata[0][0] = Wstar[i][0]; onedata[0][1] = Wstar[i][1]; NIWupdate(onedata, mu[i], Sigma[i], InvSigma[i], mu0, tau0,nu0, S0, 1, n_dim); C[i]=nstar; nstar++; } /* j=i': replace with i' obs */ else { /*1. mu_i=mu_j, Sigma_i=Sigma_j*/ /*2. update C[i]=C[j] */ for(k=0;k=*burn_in) { itempC++; if (itempC==nth){ if(*pinUpdate) { pdSa[itempA]=alpha; } pdSn[itempA]=nstar; itempA++; for(i=0; i<(n_samp+x1_samp+x0_samp); i++) { pdSMu0[itempS]=mu[i][0]; pdSMu1[itempS]=mu[i][1]; pdSSig00[itempS]=Sigma[i][0][0]; pdSSig01[itempS]=Sigma[i][0][1]; pdSSig11[itempS]=Sigma[i][1][1]; pdSW1[itempS]=W[i][0]; pdSW2[itempS]=W[i][1]; itempS++; } itempC=0; } } if (*verbose) if (itempP == main_loop) { Rprintf("%3d percent done.\n", progress*10); itempP+=ftrunc((double) *n_gen/10); progress++; R_FlushConsole(); } } /*end of MCMC for DP*/ if (*verbose) Rprintf("100 percent done.\n"); /** write out the random seed **/ PutRNGstate(); /* Freeing the memory */ FreeMatrix(S0, n_dim); FreeMatrix(X, n_samp); FreeMatrix(W, t_samp); FreeMatrix(Wstar, t_samp); FreeMatrix(S_W, s_samp); FreeMatrix(S_Wstar, s_samp); FreeMatrix(W1g, n_samp); FreeMatrix(W2g, n_samp); free(n_grid); FreeMatrix(mu, t_samp); Free3DMatrix(Sigma, t_samp,n_dim); Free3DMatrix(InvSigma, t_samp, n_dim); free(C); free(q); free(qq); FreeMatrix(S_bvt, n_dim); FreeMatrix(Wstarmix, t_samp); free(mu_mix); FreeMatrix(Sigma_mix, n_dim); FreeMatrix(InvSigma_mix, n_dim); free(sortC); free(indexC); free(label); free(vtemp); FreeMatrix(mtemp, n_dim); FreeMatrix(mtemp1, n_dim); free(onedata); } /* main */ eco/src/sample.h0000644000175100001440000000145513136253506013270 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ void rGrid(double *Sample, double *W1gi, double *W2gi, int ni_grid, double *mu, double **InvSigma, int n_dim); void GridPrep(double **W1g, double **W2g, double **X, double *maxW1, double *minW1, int *n_grid, int n_samp, int n_step); void rMH(double *W, double *XY, double W1min, double W1max, double *mu, double **InvSigma, int n_dim); void rMH2c(double *W, double *X, double Y, double *minU, double *maxU, double *mu, double **InvSigma, int n_dim, int maxit, int reject); eco/src/rand.c0000644000175100001440000001434513136253506012730 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ #include #include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "sample.h" #include "macros.h" #include "fintegrate.h" /* Multivariate Normal density */ double dMVN( double *Y, /* The data */ double *MEAN, /* The parameters */ double **SIG_INV, /* inverse of the covariance matrix */ int dim, /* dimension */ int give_log){ /* 1 if log_scale 0 otherwise */ int j,k; double value=0.0; for(j=0;j0) for(k=0;k0) for(k=0;kcaseP.mu[0]; MEAN[1]=param->caseP.mu[1]; SIGMA[0][0]=param->setP->Sigma[0][0]; SIGMA[1][1]=param->setP->Sigma[1][1]; SIGMA[0][1]=param->setP->Sigma[0][1]; SIGMA[1][0]=param->setP->Sigma[1][0]; rho=SIGMA[0][1]/sqrt(SIGMA[0][0]*SIGMA[1][1]); dtemp=1/(2*M_PI*sqrt(SIGMA[0][0]*SIGMA[1][1]*(1-rho*rho))); density=-1/(2*(1-rho*rho))* ((Wstar[0]-MEAN[0])*(Wstar[0]-MEAN[0])/SIGMA[0][0]+ +(Wstar[1]-MEAN[1])*(Wstar[1]-MEAN[1])/SIGMA[1][1] -2*rho*(Wstar[0]-MEAN[0])*(Wstar[1]-MEAN[1])/sqrt(SIGMA[0][0]*SIGMA[1][1])) +log(dtemp)-log(normc); if (give_log==0) density=exp(density); /*Rprintf("s11 %5g s22 %5g normc %5g dtemp %5g ldensity %5g\n", SIGMA[0][0],SIGMA[1][1],normc, dtemp, density); char ch; scanf(" %c", &ch );*/ Free(MEAN); FreeMatrix(SIGMA,dim); return density; } double invLogit(double x) { if (x>30) return 0; else return (1/(1+exp(-1*x))); } double logit(double x,char* emsg) { if (x>=1 || x<=0) { Rprintf(emsg); Rprintf(": %5g is out of logit range\n",x); } return log(x/(1-x)); } int bit(int t, int n) { t=t>>n; return (t % 2); } eco/src/subroutines.c0000644000175100001440000002325213136253506014363 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ #include #include #include #include #include #include #include #include "vector.h" #include "rand.h" #include "subroutines.h" /* * Computes the dot product of two vectors */ double dotProduct(double* a, double* b, int size) { int i; double ans=0; for (i=0; i0) { Rprintf("The matrix being inverted is singular. Error code %d\n", errorM); } else { Rprintf("The matrix being inverted contained an illegal value. Error code %d.\n", errorM); } error("Exiting from dinv().\n"); } } else { if (errorM>0) { Rprintf("The matrix being inverted was not positive definite. Error code %d\n", errorM); } else { Rprintf("The matrix being inverted contained an illegal value. Error code %d.\n", errorM); } error("Exiting from dinv().\n"); } for (i = 0, j = 0; j < size; j++) { for (k = 0; k <= j; k++) { X_inv[j][k] = pdInv[i]; X_inv[k][j] = pdInv[i++]; } } Free(pdInv); } /* inverting a matrix, first tyring positive definite trick, and then symmetric * Uses special syntax since we don't know dimensions of array * Prevents memory errors for matrices created with double[][] */ void dinv2D(double* X, int size, double* X_inv,char* emsg) { int i,j, k, errorM, skip; double *pdInv = doubleArray(size*size); skip=0; for (i = 0, j = 0; j < size; j++) for (k = 0; k <= j; k++) //pdInv[i++] = X[k][j]; pdInv[i++] = *(X+k*size+j); //Rprintf("test: %5g %5g %d",pdInv[0],pdInv[(size == 3) ? 5 : 2],i); F77_CALL(dpptrf)("U", &size, pdInv, &errorM); if (!errorM) { F77_CALL(dpptri)("U", &size, pdInv, &errorM); if (errorM) { Rprintf(emsg); if (errorM>0) { Rprintf(": The matrix being inverted is singular. Error code %d\n", errorM); } else { Rprintf(": The matrix being inverted contained an illegal value. Error code %d.\n", errorM); } error("Exiting from dinv2D().\n"); } } else { Rprintf(emsg); if (errorM>0) { /* The matrix is not positive definite. * This error does occur with proper data, when the likelihood curve is flat, * usually with the combination of NCAR and SEM. At one point we tried * inverting the matrix via an alternative method that does not rely on * positive definiteness (see below), but that just led to further errors. * Instead, the program halts as gracefully as possible. */ //Inverting the matrix anyway: //Rprintf(": Warning, the matrix being inverted was not positive definite on minor order %d.\n", errorM); //dinv2D_sym(X,size,X_inv,emsg); //skip=1; Rprintf(": Error, the matrix being inverted was not positive definite on minor order %d.\n", errorM); error("The program cannot continue; try a different model or including supplemental data.\n"); } else { Rprintf(": The matrix being inverted contained an illegal value. Error code %d.\n", errorM); error("Exiting from dinv2D().\n"); } } if (skip==0) { for (i = 0, j = 0; j < size; j++) { for (k = 0; k <= j; k++) { *(X_inv+size*j+k) = pdInv[i]; *(X_inv+size*k+j) = pdInv[i++]; } } } Free(pdInv); } /* inverting a matrix, assumes symmtretric, but not pos def * Uses special syntax since we don't know dimensions of array * Prevents memory errors for matrices created with double[][] */ void dinv2D_sym(double* X, int size, double* X_inv,char* emsg) { int i,j, k, errorM, size2; size2=size*size; double *pdInv = doubleArray(size2); double *B= doubleArray(size2); int *factor_out = intArray(size); //init pdInv and B. B is identity for (i = 0, j = 0; j < size; j++) for (k = 0; k < size; k++) { if (j==k) B[i]=1; else B[i]=0; pdInv[i]=*(X+k*size+j); i++; } //for (i = 0, j = 0; j < size; j++) // for (k = 0; k <= j; k++) { // pdInv[i++] = *(X+k*size+j); // } double *work0 = doubleArray(size2); int test=-1; F77_CALL(dsysv)("U", &size, &size, pdInv, &size, factor_out, B, &size, work0, &test, &errorM); int lwork=(int)work0[0]; Free(work0); //Rprintf("work size %d\n",lwork); double *work = doubleArray(lwork); //Rprintf("In A: %5g %5g %5g %5g\n",pdInv[0],pdInv[1],pdInv[2],pdInv[3]); //Rprintf("In B: %5g %5g %5g %5g\n",B[0],B[1],B[2],B[3]); F77_CALL(dsysv)("U", &size, &size, pdInv, &size, factor_out, B, &size, work, &lwork, &errorM); Free(work); //Rprintf("Out1: %5g %5g %5g %5g %d\n",B[0],B[1],B[2],B[3],errorM); if (errorM) { Rprintf(emsg); if (errorM>0) { Rprintf(": The matrix being inverted is singular. Error code %d\n", errorM); } else { Rprintf(": The matrix being inverted contained an illegal value. Error code %d.\n", errorM); } error("Exiting from dinv2D_sym() (dsytrf).\n"); } for (i = 0, j = 0; j < size; j++) { for (k = 0; k < size; k++) { *(X_inv+size*j+k) = B[i++]; } } free(factor_out); Free(B); Free(pdInv); } /* Cholesky decomposition */ /* returns lower triangular matrix */ void dcholdc(double **X, int size, double **L) { int i, j, k, errorM; double *pdTemp = doubleArray(size*size); for (j = 0, i = 0; j < size; j++) for (k = 0; k <= j; k++) pdTemp[i++] = X[k][j]; F77_CALL(dpptrf)("U", &size, pdTemp, &errorM); if (errorM) { if (errorM>0) { Rprintf("The matrix being inverted was not positive definite. Error code %d\n", errorM); } else { Rprintf("The matrix being inverted contained an illegal value. Error code %d.\n", errorM); } error("Exiting from dcholdc().\n"); } for (j = 0, i = 0; j < size; j++) { for (k = 0; k < size; k++) { if(j0) { Rprintf("The matrix being inverted was not positive definite. Error code %d\n", errorM); } else { Rprintf("The matrix being inverted contained an illegal value. Error code %d.\n", errorM); } error("Exiting from dcholdc2D().\n"); } for (j = 0, i = 0; j < size; j++) { for (k = 0; k < size; k++) { if(j #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "sample.h" #include "bayes.h" #include "macros.h" #include "fintegrate.h" void readData(Param* params, int n_dim, double* pdX, double* sur_W, double* x1_W1, double* x0_W2, int n_samp, int s_samp, int x1_samp, int x0_samp); void ecoSEM(double* optTheta, double* pdTheta, Param* params, double Rmat_old[7][7], double Rmat[7][7]); void ecoEStep(Param* params, double* suff); void ecoMStep(double* Suff, double* pdTheta, Param* params); void ecoMStepNCAR(double* Suff, double* pdTheta, Param* params); void ecoMStepCCAR(double* pdTheta, Param* params); void MStepHypTest(Param* params, double* pdTheta); void initTheta(double* pdTheta_in,Param* params, double* pdTheta); void initNCAR(Param* params, double* pdTheta); void setHistory(double* t_pdTheta, double loglik, int iter,setParam* setP,double history_full[][10]); int closeEnough(double* pdTheta, double* pdTheta_old, int len, double maxerr); int semDoneCheck(setParam* setP); void gridEStep(Param* params, int n_samp, int s_samp, int x1_samp, int x0_samp, double* suff, int verbose, double minW1, double maxW1); void transformTheta(double* pdTheta, double* t_pdTheta, int len, setParam* setP); void untransformTheta(double* t_pdTheta,double* pdTheta, int len, setParam* setP); void ncarFixedRhoTransform(double* pdTheta); void ncarFixedRhoUnTransform(double* pdTheta); void printColumnHeader(int main_loop, int iteration_max, setParam* setP, int finalTheta); /** * Main function. * Important mutations (i.e., outputs): pdTheta, Suff, DMmatrix, history * See internal comments for details. */ void cEMeco( /*data input */ double *pdX, /* data (X, Y) */ double *pdTheta_in, /* Theta^ t CAR: mu1, mu2, var1, var2, rho NCAR: mu1, mu2, var1, var2, p13,p13,p12*/ int *pin_samp, /* sample size */ /* loop vairables */ int *iteration_max, /* number of maximum iterations */ double *convergence, /* abs value limit before stopping */ /*incorporating survey data */ int *survey, /*1 if survey data available(W_1, W_2) 0 not*/ int *sur_samp, /*sample size of survey data*/ double *sur_W, /*set of known W_1, W_2 */ /*incorporating homeogenous areas */ int *x1, /* 1 if X=1 type areas available W_1 known, W_2 unknown */ int *sampx1, /* number X=1 type areas */ double *x1_W1, /* values of W_1 for X1 type areas */ int *x0, /* 1 if X=0 type areas available W_2 known, W_1 unknown */ int *sampx0, /* number X=0 type areas */ double *x0_W2, /* values of W_2 for X0 type areas */ /* bounds of W1 */ double *minW1, double *maxW1, /* options */ int *flag, /*0th (rightmost) bit: 1 = NCAR, 0=normal; 1st bit: 1 = fixed rho, 0 = not fixed rho*/ int *verbosiosity, /*How much to print out, 0=silent, 1=cycle, 2=data*/ int *calcLoglik, /*How much to print out, 0=silent, 1=cycle, 2=data*/ int *hypTest_L, /* number of hypothesis constraints */ double *optTheta, /*optimal theta obtained from previous EM result; if set, then we're doing SEM*/ /* storage */ //Theta under CAR: mu1,mu2,s1,s2,p12 //Theta under NCAR: mu_3, mu_1, mu_2, sig_3, sig_1, sig_2, r_13, r_23, r_12 double *pdTheta, /*EM result for Theta^(t+1) */ double *Suff, /*out put suffucient statistics (E(W_1i|Y_i), E(E_1i*W_1i|Y_i..) when conveges */ double *inSample, /* In Sample info */ double *DMmatrix, /* DM matrix for SEM*/ int *itersUsed, /* number of iterations used */ double *history /* history of param (transformed) as well as logliklihood*/ ){ int n_samp = *pin_samp; /* sample size */ int s_samp = *survey ? *sur_samp : 0; /* sample size of survey data */ int x1_samp = *x1 ? *sampx1 : 0; /* sample size for X=1 */ int x0_samp = *x0 ? *sampx0 : 0; /* sample size for X=0 */ //int t_samp=n_samp+s_samp+x1_samp+x0_samp; /* total sample size*/ int t_samp=n_samp+s_samp; /* total sample size, ignoring homog data*/ int n_dim=2; /* dimensions */ setParam setP; //set options setP.ncar=bit(*flag,0); setP.fixedRho=bit(*flag,1); setP.sem=bit(*flag,2) & (optTheta[2]!=-1.1); setP.ccar=0; setP.ccar_nvar=0; //hard-coded hypothesis test //hypTest is the number of constraints. hyptTest==0 when we're not checking a hypothesis setP.hypTest=(*hypTest_L); if (setP.hypTest>1) error("Unable to do hypothesis testing with more than one constraint"); if (setP.hypTest==1) { setP.hypTestCoeff=doubleMatrix(setP.ncar ? 3 : 2,setP.hypTest); setP.hypTestCoeff[0][0]=1; setP.hypTestCoeff[1][0]=-1; if (setP.ncar) setP.hypTestCoeff[2][0]=0; setP.hypTestResult=0; } setP.verbose=*verbosiosity; if (setP.verbose>=1) Rprintf("OPTIONS:: Ncar: %s; Fixed Rho: %s; SEM: %s\n",setP.ncar==1 ? "Yes" : "No", setP.fixedRho==1 ? "Yes" : "No",setP.sem==1 ? "Second run" : (bit(*flag,2)==1 ? "First run" : "No")); setP.calcLoglik=*calcLoglik; setP.convergence=*convergence; setP.t_samp=t_samp; setP.n_samp=n_samp; setP.s_samp=s_samp; setP.x1_samp=x1_samp; setP.x0_samp=x0_samp; int param_len=setP.ccar ? setP.ccar_nvar : (setP.ncar ? 9 : 5); setP.param_len=param_len; setP.pdTheta=doubleArray(param_len); setP.suffstat_len=(setP.ncar ? 9 : 5); setP.SigmaK=doubleMatrix(param_len,param_len); //CCAR setP.InvSigmaK=doubleMatrix(param_len,param_len); //CCAR /* model parameters */ //double **Sigma=doubleMatrix(n_dim,n_dim);/* inverse covariance matrix*/ //double **InvSigma=doubleMatrix(n_dim,n_dim);/* inverse covariance matrix*/ double *pdTheta_old=doubleArray(param_len); double *t_pdTheta=doubleArray(param_len); //transformed theta double *t_pdTheta_old=doubleArray(param_len); double Rmat_old[7][7]; double Rmat[7][7]; double history_full[*iteration_max+1][10]; /* misc variables */ int i, j,main_loop, start; /* used for various loops */ /* get random seed */ GetRNGstate(); //assign param Param* params=(Param*) R_alloc(t_samp,sizeof(Param)); for(i=0;i=1) { if ((main_loop - 1) % 15 == 0) printColumnHeader(main_loop,*iteration_max,&setP,0); Rprintf("cycle %d/%d:",main_loop,*iteration_max); for(i=0;i=0) Rprintf("% 5.3f",pdTheta[i]); else Rprintf(" % 5.2f",pdTheta[i]); } if (setP.calcLoglik==1 && main_loop>2) Rprintf(" Prev LL: %5.2f",Suff[setP.suffstat_len]); Rprintf("\n"); } //keep the old theta around for comaprison for(i=0;i=2) { Rprintf("theta and suff\n"); if (param_len>5) { Rprintf("%10g%10g%10g%10g%10g%10g%10g%10g%10g\n",pdTheta[0],pdTheta[1],pdTheta[2],pdTheta[3],pdTheta[4],pdTheta[5],pdTheta[6],pdTheta[7],pdTheta[8]); } else { Rprintf("%10g%10g%10g%10g%10g (%10g)\n",pdTheta[0],pdTheta[1],pdTheta[2],pdTheta[3],pdTheta[4],pdTheta[4]*sqrt(pdTheta[2]*pdTheta[3])); } Rprintf("%10g%10g%10g%10g%10g\n",Suff[0],Suff[1],Suff[2],Suff[3],Suff[4]); Rprintf("Sig: %10g%10g%10g\n",setP.Sigma[0][0],setP.Sigma[1][1],setP.Sigma[0][1]); if (setP.ncar) Rprintf("Sig3: %10g%10g%10g%10g\n",setP.Sigma3[0][0],setP.Sigma3[1][1],setP.Sigma3[2][2]); //char x; //R_ReadConsole("hit enter\n",(char*)&x,4,0); } main_loop++; R_FlushConsole(); R_CheckUserInterrupt(); } /***End main loop ***/ //finish up: record results and loglik Param* param; Suff[setP.suffstat_len]=0.0; for(i=0;icaseP.W[j]; //setBounds(param); //setNormConst(param); } Suff[setP.suffstat_len]+=getLogLikelihood(param); } if (setP.verbose>=1) { printColumnHeader(main_loop,*iteration_max,&setP,1); Rprintf("Final Theta:"); for(i=0;i=0) Rprintf("% 5.3f",pdTheta[i]); else Rprintf(" % 5.2f",pdTheta[i]); } if (setP.calcLoglik==1 && main_loop>2) { Rprintf(" Final LL: %5.2f",Suff[setP.suffstat_len]); history_full[main_loop-1][param_len]=Suff[setP.suffstat_len]; } Rprintf("\n"); } //set the DM matrix (only matters for SEM) if (setP.sem==1) { int DMlen=0; for(i=0; iparam_len; int i; if (!setP->ncar) { for(i=0;ivarParam[i]=1; } if (setP->fixedRho) setP->varParam[4]=0; } else { //constants double lx,mu3sq; pdTheta[0]=0; mu3sq=0; for(i=0;it_samp;i++) { lx=logit(params[i].caseP.X,"initpdTheta0"); pdTheta[0] += lx; mu3sq += lx*lx; } pdTheta[0] = pdTheta[0]/setP->t_samp; mu3sq = mu3sq/setP->t_samp; pdTheta[3] = mu3sq-pdTheta[0]*pdTheta[0]; //variance //fill from pdTheta_in pdTheta[1]=pdTheta_in[0]; pdTheta[2]=pdTheta_in[1]; pdTheta[4]=pdTheta_in[2]; pdTheta[5]=pdTheta_in[3]; pdTheta[6]=pdTheta_in[4]; pdTheta[7]=pdTheta_in[5]; pdTheta[8]=pdTheta_in[6]; for(i=0;ivarParam[i]=1; setP->varParam[0]=0;setP->varParam[3]=0; //if (setP->fixedRho) setP->varParam[8]=0; } int varlen=0; for(i=0; ivarParam[i]) varlen++; for(i=0; isemDone[i]=0; } /** * The E-step for parametric ecological inference * Takes in a Param array of length n_samp + t_samp + x0_samp + x1_samp * Suff should be an array with the same length as the number of params (+1) * On exit: suff holds the sufficient statistics and loglik as follows * CAR: (0) E[W1*] (1) E[W2*] (2) E[W1*^2] (3) E[W2*^2] (4) E[W1*W2*] (5) loglik * NCAR: (0) X, (1) W1, (2) W2, (3) X^2, (4) W1^2, (5) W2^2, (6) x*W1, (7) X*W2, (8) W1*W2, (9) loglik **/ void ecoEStep(Param* params, double* suff) { int t_samp,n_samp,s_samp,x1_samp,x0_samp,i,j, verbose; double loglik,testdens; Param* param; setParam* setP; caseParam* caseP; setP=params[0].setP; verbose=setP->verbose; t_samp=setP->t_samp; n_samp=setP->n_samp; x1_samp=setP->x1_samp; x0_samp=setP->x0_samp; s_samp=setP->s_samp; double **Wstar=doubleMatrix(t_samp,5); /* pseudo data(transformed)*/ loglik=0; if (verbose>=3 && !setP->sem) Rprintf("E-step start\n"); for (i = 0; icaseP); if (caseP->Y>=.990 || caseP->Y<=.010) { //if Y is near the edge, then W1 and W2 are very constrained Wstar[i][0]=logit(caseP->Y,"Y maxmin W1"); Wstar[i][1]=logit(caseP->Y,"Y maxmin W2"); Wstar[i][2]=Wstar[i][0]*Wstar[i][0]; Wstar[i][3]=Wstar[i][0]*Wstar[i][1]; Wstar[i][4]=Wstar[i][1]*Wstar[i][1]; caseP->Wstar[0]=Wstar[i][0]; caseP->Wstar[1]=Wstar[i][1]; caseP->W[0]=caseP->Y; caseP->W[1]=caseP->Y; if (setP->calcLoglik==1 && setP->iter>1) loglik+=getLogLikelihood(param); //Rprintf("Skipping %d, Y=%5g",i,caseP->Y); } else { setBounds(param); //I think you only have to do this once...check later /*if (verbose>=2 && setP->iter==12 && i==422) { Rprintf("Bounds: %5g %5g %5g %5g\n",caseP->Wbounds[0][0],caseP->Wbounds[0][1],caseP->Wbounds[1][0],caseP->Wbounds[1][1]); setP->weirdness=1; } else setP->weirdness=0;*/ setNormConst(param); for (j=0;j<5;j++) { caseP->suff=j; Wstar[i][j]=paramIntegration(&SuffExp,param); if (j<2) caseP->Wstar[j]=Wstar[i][j]; } caseP->suff=SS_W1; caseP->W[0]=paramIntegration(&SuffExp,param); caseP->suff=SS_W2; caseP->W[1]=paramIntegration(&SuffExp,param); caseP->suff=SS_Test; testdens=paramIntegration(&SuffExp,param); if (setP->calcLoglik==1 && setP->iter>1) loglik+=getLogLikelihood(param); //report error E1 if E[W1],E[W2] is not on the tomography line if (fabs(caseP->W[0]-getW1FromW2(caseP->X, caseP->Y,caseP->W[1]))>0.011) { Rprintf("E1 %d %5g %5g %5g %5g %5g %5g %5g %5g err:%5g\n", i, caseP->X, caseP->Y, caseP->mu[0], caseP->mu[1], caseP->normcT,Wstar[i][0],Wstar[i][1],Wstar[i][2],fabs(caseP->W[0]-getW1FromW2(caseP->X, caseP->Y,caseP->W[1]))); char ch; scanf("Hit enter to continue %c\n", &ch ); } //report error E2 if Jensen's inequality doesn't hold if (Wstar[i][4]X, caseP->Y, caseP->normcT, caseP->mu[1],Wstar[i][0],Wstar[i][1],Wstar[i][2],Wstar[i][4]); //used for debugging if necessary if (verbose>=2 && !setP->sem && ((i<10 && verbose>=3) || (caseP->mu[1] < -1.7 && caseP->mu[0] > 1.4))) Rprintf("%d %5.2f %5.2f %5.2f %5.2f %5.2f %5.2f %5.2f %5.2f %5.2f\n", i, caseP->X, caseP->Y, caseP->mu[0], caseP->mu[1], param->setP->Sigma[0][1], caseP->normcT, caseP->W[0],caseP->W[1],Wstar[i][2]); } } /* Use the values given by the survey data */ //Calculate loglik also for (i=n_samp; icaseP); Wstar[i][0]=caseP->Wstar[0]; Wstar[i][1]=caseP->Wstar[1]; Wstar[i][2]=Wstar[i][0]*Wstar[i][0]; Wstar[i][3]=Wstar[i][0]*Wstar[i][1]; Wstar[i][4]=Wstar[i][1]*Wstar[i][1]; if (setP->calcLoglik==1 && setP->iter>1) loglik+=getLogLikelihood(param); } /* analytically compute E{W2_i|Y_i} given W1_i, mu and Sigma in x1 homeogeneous areas */ for (i=n_samp+s_samp; iSigma[0][1]/setP->Sigma[0][0]*(temp0-params[i].caseP.mu[0]); Wstar[i][0]=temp0; Wstar[i][1]=temp1; Wstar[i][2]=temp0*temp0; Wstar[i][3]=temp0*temp1; Wstar[i][4]=temp1*temp1;*/ } /*analytically compute E{W1_i|Y_i} given W2_i, mu and Sigma in x0 homeogeneous areas */ for (i=n_samp+s_samp+x1_samp; iSigma[0][1]/setP->Sigma[1][1]*(temp1-params[i].caseP.mu[1]); Wstar[i][0]=temp0; Wstar[i][1]=temp1; Wstar[i][2]=temp0*temp0; Wstar[i][3]=temp0*temp1; Wstar[i][4]=temp1*temp1;*/ } /*Calculate sufficient statistics */ for (j=0; jsuffstat_len; j++) suff[j]=0; //CAR: (0) E[W1*] (1) E[W2*] (2) E[W1*^2] (3) E[W2*^2] (4) E[W1*W2*] (5) loglik //NCAR: (0) X, (1) W1, (2) W2, (3) X^2, (4) W1^2, (5) W2^2, (6) x*W1, (7) X*W2, (8) W1*W2, (9) loglik /* compute sufficient statistics */ for (i=0; incar) { suff[0] += Wstar[i][0]; /* sumE(W_i1|Y_i) */ suff[1] += Wstar[i][1]; /* sumE(W_i2|Y_i) */ suff[2] += Wstar[i][2]; /* sumE(W_i1^2|Y_i) */ suff[3] += Wstar[i][4]; /* sumE(W_i2^2|Y_i) */ suff[4] += Wstar[i][3]; /* sumE(W_i1*W_i2|Y_i) */ } else if (setP->ncar) { double lx= logit(params[i].caseP.X,"mstep X"); suff[0] += lx; suff[1] += Wstar[i][0]; suff[2] += Wstar[i][1]; suff[3] += lx*lx; suff[4] += Wstar[i][2]; suff[5] += Wstar[i][4]; suff[6] += params[i].caseP.Wstar[0]*lx; suff[7] += params[i].caseP.Wstar[1]*lx; suff[8] += Wstar[i][3]; } } for(j=0; jsuffstat_len; j++) suff[j]=suff[j]/t_samp; //Rprintf("%5g suff0,2,4 %5g %5g %5g\n",setP->pdTheta[6],suff[0],suff[2],suff[4]); //if(verbose>=1) Rprintf("Log liklihood %15g\n",loglik); suff[setP->suffstat_len]=loglik; FreeMatrix(Wstar,t_samp); } /** * CAR M-Step * inputs: Suff (sufficient statistics) * CAR Suff: E[W1], E[W2], E[W1^2], E[W2^2], E[W1W2] * mutated (i.e., output): pdTheta, params */ void ecoMStep(double* Suff, double* pdTheta, Param* params) { int i; setParam* setP=params[0].setP; pdTheta[0]=Suff[0]; /*mu1*/ pdTheta[1]=Suff[1]; /*mu2*/ if (setP->hypTest>0) { MStepHypTest(params,pdTheta); } if (!setP->fixedRho) { //standard pdTheta[2]=Suff[2]-2*Suff[0]*pdTheta[0]+pdTheta[0]*pdTheta[0]; //sigma11 pdTheta[3]=Suff[3]-2*Suff[1]*pdTheta[1]+pdTheta[1]*pdTheta[1]; //sigma22 pdTheta[4]=Suff[4]-Suff[0]*pdTheta[1]-Suff[1]*pdTheta[0]+pdTheta[0]*pdTheta[1]; //sigma12 pdTheta[4]=pdTheta[4]/sqrt(pdTheta[2]*pdTheta[3]); /*rho*/ } else { //fixed rho double Imat[2][2]; Imat[0][0]=Suff[2]-2*pdTheta[0]*Suff[0]+pdTheta[0]*pdTheta[0]; //I_11 Imat[1][1]=Suff[3]-2*Suff[1]*pdTheta[1]+pdTheta[1]*pdTheta[1]; //I_22 Imat[0][1]=Suff[4]-Suff[0]*pdTheta[1]-Suff[1]*pdTheta[0]+pdTheta[0]*pdTheta[1]; //I_12 pdTheta[2]=(Imat[0][0]-pdTheta[4]*Imat[0][1]*pow(Imat[0][0]/Imat[1][1],0.5))/(1-pdTheta[4]*pdTheta[4]); //sigma11 pdTheta[3]=(Imat[1][1]-pdTheta[4]*Imat[0][1]*pow(Imat[1][1]/Imat[0][0],0.5))/(1-pdTheta[4]*pdTheta[4]); //sigma22 //sigma12 will be determined below by rho } //set Sigma setP->Sigma[0][0] = pdTheta[2]; setP->Sigma[1][1] = pdTheta[3]; setP->Sigma[0][1] = pdTheta[4]*sqrt(pdTheta[2]*pdTheta[3]); setP->Sigma[1][0] = setP->Sigma[0][1]; //if(setP->verbose>=3) Rprintf("Sigma mstep: %5g %5g %5g %5g\n",setP->Sigma[0][0],setP->Sigma[0][1],setP->Sigma[1][0],setP->Sigma[1][1]); dinv2D((double*)(&(setP->Sigma[0][0])), 2, (double*)(&(setP->InvSigma[0][0])),"regular M-step"); /* assign each data point the new mu (same for all points) */ for(i=0;it_samp;i++) { params[i].caseP.mu[0]=pdTheta[0]; params[i].caseP.mu[1]=pdTheta[1]; } } /** * M-Step under NCAR * Input: Suff (sufficient statistics) * (0) X, (1) W1, (2) W2, (3) X^2, (4) W1^2, (5) W2^2, (6) x*W1, (7) X*W2, (8) W1*W2, (9) loglik * mutated (i.e., output): pdTheta, params */ void ecoMStepNCAR(double* Suff, double* pdTheta, Param* params) { setParam* setP=params[0].setP; //double Sigma[2][2]=setP->Sigma; //double[2][2] InvSigma=setP->InvSigma; //double[3][3] Sigma3=setP->Sigma3; /* covariance matrix*/ //double[3][3] InvSigma3=setP->Sigma3; /* inverse covariance matrix*/ int ii,i,j,verbose,t_samp; verbose=setP->verbose; t_samp=setP->t_samp; //set E[XW*] double XW1=Suff[6]; double XW2=Suff[7]; //for(i = 0;i<9; i++) Rprintf("%f5.2\n",pdTheta[i]); if (!setP->fixedRho) { //variable rho //pdTheta[0] is const pdTheta[1]=Suff[1]; /*mu1*/ pdTheta[2]=Suff[2]; /*mu2*/ //set variances and correlations //pdTheta[3] is const pdTheta[4]=Suff[4]-2*Suff[1]*pdTheta[1]+pdTheta[1]*pdTheta[1]; //s11 pdTheta[5]=Suff[5]-2*Suff[2]*pdTheta[2]+pdTheta[2]*pdTheta[2]; //s22 pdTheta[6]=(XW1 - pdTheta[0]*Suff[1])/sqrt((Suff[4] - Suff[1]*Suff[1])*pdTheta[3]); //rho_13 pdTheta[7]=(XW2 - pdTheta[0]*Suff[2])/sqrt((Suff[5] - Suff[2]*Suff[2])*pdTheta[3]); //rho_23 pdTheta[8]=Suff[8]-Suff[1]*pdTheta[2]-Suff[2]*pdTheta[1]+pdTheta[1]*pdTheta[2]; //sigma12 pdTheta[8]=pdTheta[8]/sqrt(pdTheta[4]*pdTheta[5]); //rho_12 //reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1, (5) sig_2, (6) r_13, (7) r_23, (8) r_12 //variances setP->Sigma3[0][0] = pdTheta[4]; setP->Sigma3[1][1] = pdTheta[5]; setP->Sigma3[2][2] = pdTheta[3]; //covariances setP->Sigma3[0][1] = pdTheta[8]*sqrt(pdTheta[4]*pdTheta[5]); setP->Sigma3[0][2] = pdTheta[6]*sqrt(pdTheta[4]*pdTheta[3]); setP->Sigma3[1][2] = pdTheta[7]*sqrt(pdTheta[5]*pdTheta[3]); //symmetry setP->Sigma3[1][0] = setP->Sigma3[0][1]; setP->Sigma3[2][0] = setP->Sigma3[0][2]; setP->Sigma3[2][1] = setP->Sigma3[1][2]; //if (verbose>=2) { //Rprintf("Sigma3: %5g %5g %5g %5g %5g\n",setP->Sigma3[0][0],setP->Sigma3[0][1],setP->Sigma3[1][1],setP->Sigma3[1][2],setP->Sigma3[2][2]); //} } else { //fixed rho //reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1 | 3, (5) sig_2 | 3, (6) beta1, (7) beta2, (8) r_12 | 3 ncarFixedRhoTransform(pdTheta); //need the fixed param (pdTheta[8]) to be the conditional correlation //CODE BLOCK D //compute beta based on previous sigma //beta is mu1,beta1,mu2,beta, which are pdTheta 1,2,6,7 double **InvSigma=doubleMatrix(2,2); double **Zmat=doubleMatrix(4,2); double **Zmat_t=doubleMatrix(2,4); double **tmp41=doubleMatrix(4,1); double **tmp42=doubleMatrix(4,2); double **tmp44=doubleMatrix(4,4); double **tmp21=doubleMatrix(2,1); double **denom=doubleMatrix(4,4); double **numer=doubleMatrix(4,1); for (i=0;i<4;i++) { for(j=0;j<4;j++) { if (j<2) { if (i<2) InvSigma[i][j]=setP->InvSigma[i][j]; Zmat[i][j]=0; Zmat_t[j][i]=0; } denom[i][j]=0; } numer[i][0]=0; } //Rprintf("InvSigma %5g %5g %5g\n",InvSigma[0][0],InvSigma[1][1],InvSigma[0][1]); for(ii=0;iit_samp;ii++) { double lx=logit(params[ii].caseP.X,"NCAR beta"); for(j=0;j<2;j++) { Zmat_t[j][j*2+1]=lx - pdTheta[0]; Zmat_t[j][j*2]=1; Zmat[j*2+1][j]=lx - pdTheta[0]; Zmat[j*2][j]=1; } matrixMul(Zmat,InvSigma,4,2,2,2,tmp42); matrixMul(tmp42,Zmat_t,4,2,2,4,tmp44); for (i=0;i<4;i++) for(j=0;j<4;j++) denom[i][j]+=tmp44[i][j]; //for (i=0;i<2;i++) tmp21[i][0]=(params[ii].caseP.Wstar[i] - pdTheta[i+1]); //Wtilde ?? for (i=0;i<2;i++) tmp21[i][0]=params[ii].caseP.Wstar[i]; //Wstar //matrixMul(Zmat,InvSigma,4,2,2,2,tmp42); //no need to repeat calculation matrixMul(tmp42,tmp21,4,2,2,1,tmp41); for (i=0;i<4;i++) numer[i][0]+=tmp41[i][0]; } dinv(denom,4,denom); matrixMul(denom,numer,4,4,4,1,numer); pdTheta[1]=numer[0][0]; //mu1 pdTheta[6]=numer[1][0]; //beta1 pdTheta[2]=numer[2][0]; //mu2 pdTheta[7]=numer[3][0]; //beta2 //pdTheta[8] is constant //Rprintf("Compare Suff1 %5g to pdT1 %5g \n",Suff[1],pdTheta[1]); //Rprintf("Compare Suff2 %5g to pdT2 %5g \n",Suff[2],pdTheta[2]); if (setP->hypTest>0) { MStepHypTest(params,pdTheta); } //CAR: (0) E[W1*] (1) E[W2*] (2) E[W1*^2] (3) E[W2*^2] (4) E[W1*W2*] (5) loglik //NCAR: (0) X, (1) W1, (2) W2, (3) X^2, (4) W1^2, (5) W2^2, (6) x*W1, (7) X*W2, (8) W1*W2, (9) loglik //0->1, 1->2, 2->4, 3->5, 4->8 //CODE BLOCK C //Compute sigma conditional on beta //reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1 | 3, (5) sig_2 | 3, (6) beta1, (7) beta2, (8) r_12 | 3 double Smat[2][2]; //the S matrix (divided by n) in the paper double Tmat[2][2]; //the T matrix (divided by n) in the paper double S1=Suff[1]; //S_1 = Sufficient stat of W1* - beta1 * (sum of [(X_i - \mu3)]) ; second term goes to zero double S2=Suff[2]; //S_2 = Sufficient stat of W2* Smat[0][0]=Suff[4] - 2*pdTheta[6]*(XW1 - pdTheta[0]*Suff[1]) + pdTheta[6]*pdTheta[6]*pdTheta[3]; //S_11 Smat[1][1]=Suff[5] - 2*pdTheta[7]*(XW2 - pdTheta[0]*Suff[2]) + pdTheta[7]*pdTheta[7]*pdTheta[3]; //S_22 Smat[0][1]=Suff[8] - pdTheta[6]*(XW2 - pdTheta[0]*Suff[2]) - pdTheta[7]*(XW1 - pdTheta[0]*Suff[1]) + pdTheta[6]*pdTheta[7]*pdTheta[3] ; //S_12 Tmat[0][0]=Smat[0][0] - S1*S1; Tmat[1][1]=Smat[1][1] - S2*S2; Tmat[0][1]=Smat[0][1] - S1*S2; pdTheta[4]=(Tmat[0][0]-pdTheta[8]*Tmat[0][1]*pow(Tmat[0][0]/Tmat[1][1],0.5))/(1-pdTheta[8]*pdTheta[8]); //sigma11 | 3 pdTheta[5]=(Tmat[1][1]-pdTheta[8]*Tmat[0][1]*pow(Tmat[1][1]/Tmat[0][0],0.5))/(1-pdTheta[8]*pdTheta[8]); //sigma22 | 3 //variances //CODE BLOCK B setP->Sigma3[0][0] = pdTheta[4] + pdTheta[6]*pdTheta[6]*pdTheta[3]; setP->Sigma3[1][1] = pdTheta[5] + pdTheta[7]*pdTheta[7]*pdTheta[3]; setP->Sigma3[2][2] = pdTheta[3]; //covariances setP->Sigma3[0][1] = (pdTheta[8]*sqrt(pdTheta[4]*pdTheta[5]) + pdTheta[6]*pdTheta[7]*pdTheta[3])/ (sqrt((pdTheta[4] + pdTheta[6]*pdTheta[6]*pdTheta[3])*(pdTheta[5] + pdTheta[7]*pdTheta[7]*pdTheta[3])));//rho_12 unconditional setP->Sigma3[0][1] = setP->Sigma3[0][1]*sqrt(setP->Sigma3[0][0]*setP->Sigma3[1][1]); //sig_12 setP->Sigma3[0][2] = pdTheta[6]*sqrt((pdTheta[3])/(pdTheta[4] + pdTheta[6]*pdTheta[6]*pdTheta[3]))*sqrt(setP->Sigma3[0][0]*setP->Sigma3[2][2]); setP->Sigma3[1][2] = pdTheta[7]*sqrt((pdTheta[3])/(pdTheta[5] + pdTheta[7]*pdTheta[7]*pdTheta[3]))*sqrt(setP->Sigma3[1][1]*setP->Sigma3[2][2]); //symmetry setP->Sigma3[1][0] = setP->Sigma3[0][1]; setP->Sigma3[2][0] = setP->Sigma3[0][2]; setP->Sigma3[2][1] = setP->Sigma3[1][2]; } dinv2D((double*)(&(setP->Sigma3[0][0])), 3, (double*)(&(setP->InvSigma3[0][0])),"NCAR M-step S3"); initNCAR(params,pdTheta); if (setP->fixedRho) ncarFixedRhoUnTransform(pdTheta); } /** * M-Step under CCAR * Input: params * mutated (i.e., output): pdTheta, params */ void ecoMStepCCAR(double* pdTheta, Param* params) { setParam* setP=params[0].setP; int k=setP->ccar_nvar; int ii,i,j,verbose,t_samp; verbose=setP->verbose; t_samp=setP->t_samp; double **InvSigma=doubleMatrix(2,2); double **Z_i=doubleMatrix(k,2); double **Z_i_t=doubleMatrix(2,k); double **tmpk1=doubleMatrix(k,1); double **tmpk2=doubleMatrix(k,2); double **tmpkk=doubleMatrix(k,k); double **tmp21=doubleMatrix(2,1); double **tmp21_b=doubleMatrix(2,1); double **tmp12=doubleMatrix(1,2); double **tmp22=doubleMatrix(2,2); double **denom=doubleMatrix(k,k); double **numer=doubleMatrix(k,1); //betas for (i=0;iInvSigma[i][j]; } denom[i][j]=0; } numer[i][0]=0; } //Rprintf("InvSigma %5g %5g %5g\n",InvSigma[0][0],InvSigma[1][1],InvSigma[0][1]); for(ii=0;iit_samp;ii++) { for (i=0;ihypTest>0) { MStepHypTest(params,pdTheta); } //conditional Sigma //start at 0 for(i=0; i<2;i++) for(j=0; j<2;j++) setP->Sigma[i][j] = 0; for(ii=0;iit_samp;ii++) { for (i=0;iSigma[i][j] += tmp22[i][j]; } dinv2D((double*)(&(setP->Sigma[0][0])), 2, (double*)(&(setP->InvSigma[0][0])),"CCAR M-step S2"); //variances //CODE BLOCK B setP->Sigma3[0][0] = pdTheta[4] + pdTheta[6]*pdTheta[6]*pdTheta[3]; setP->Sigma3[1][1] = pdTheta[5] + pdTheta[7]*pdTheta[7]*pdTheta[3]; setP->Sigma3[2][2] = pdTheta[3]; //covariances setP->Sigma3[0][1] = (pdTheta[8]*sqrt(pdTheta[4]*pdTheta[5]) + pdTheta[6]*pdTheta[7]*pdTheta[3])/ (sqrt((pdTheta[4] + pdTheta[6]*pdTheta[6]*pdTheta[3])*(pdTheta[5] + pdTheta[7]*pdTheta[7]*pdTheta[3])));//rho_12 unconditional setP->Sigma3[0][1] = setP->Sigma3[0][1]*sqrt(setP->Sigma3[0][0]*setP->Sigma3[1][1]); //sig_12 setP->Sigma3[0][2] = pdTheta[6]*sqrt((pdTheta[3])/(pdTheta[4] + pdTheta[6]*pdTheta[6]*pdTheta[3]))*sqrt(setP->Sigma3[0][0]*setP->Sigma3[2][2]); setP->Sigma3[1][2] = pdTheta[7]*sqrt((pdTheta[3])/(pdTheta[5] + pdTheta[7]*pdTheta[7]*pdTheta[3]))*sqrt(setP->Sigma3[1][1]*setP->Sigma3[2][2]); //symmetry setP->Sigma3[1][0] = setP->Sigma3[0][1]; setP->Sigma3[2][0] = setP->Sigma3[0][2]; setP->Sigma3[2][1] = setP->Sigma3[1][2]; dinv2D((double*)(&(setP->Sigma3[0][0])), 3, (double*)(&(setP->InvSigma3[0][0])),"NCAR M-step S3"); initNCAR(params,pdTheta); } /** * Exta M-Step for hypothesis testing * Input: params * Mutates pdTheta */ void MStepHypTest(Param* params, double* pdTheta) { setParam* setP=params[0].setP; double offset,denom; int dim,i,j,l,k; dim=setP->ncar ? 3 : 2; l=setP->hypTest; double** Sigma=doubleMatrix(dim,dim); double** temp_LbyD=doubleMatrix(l,dim); double** temp_DbyL=doubleMatrix(dim,l); double** temp_LbyL=doubleMatrix(l,l); for(i=0;iSigma3[i][j]; } else { Sigma[i][j]=setP->Sigma[i][j]; } } //transpose double** hypTestCoeffT=doubleMatrix(l,dim); for(i=0;ihypTestCoeff[i][0]; //numerator for(k=0;k<2;k++) temp_DbyL[k][0]=0; for(i=0;it_samp;i++) { temp_DbyL[0][0]+=params[i].caseP.Wstar[0]; temp_DbyL[1][0]+=params[i].caseP.Wstar[1]; } matrixMul(hypTestCoeffT,temp_DbyL,l,dim,dim,l,temp_LbyL); temp_LbyL[0][0]=temp_LbyL[0][0]-(setP->t_samp*setP->hypTestResult); matrixMul(Sigma,setP->hypTestCoeff,dim,dim,dim,l,temp_DbyL); for(k=0;k<2;k++) temp_DbyL[k][0]*=temp_LbyL[0][0]; //denominator //matrixMul(hypTestCoeffT,InvSigma,l,dim,dim,dim,temp_LbyD); matrixMul(hypTestCoeffT,Sigma,l,dim,dim,dim,temp_LbyD); matrixMul(temp_LbyD,setP->hypTestCoeff,l,dim,dim,l,temp_LbyL); denom=setP->t_samp*temp_LbyL[0][0]; //offset theta for(k=0;k<2;k++) { offset=temp_DbyL[k][0]/denom; int kindex= (setP->ncar) ? (k+1) : k; pdTheta[kindex]=pdTheta[kindex]-offset; } } /** * NCAR initialize * note that for fixed rho, the input is the UNTRANSFORMED PARAMETERS * input: pdTheta * mutates: params */ void initNCAR(Param* params, double* pdTheta) { setParam* setP=params[0].setP; int i; if (!setP->fixedRho) { //variable rho //reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1, (5) sig_2, (6) r_13, (7) r_23, (8) r_12 setP->Sigma[0][0]= pdTheta[4]*(1 - pdTheta[6]*pdTheta[6]); setP->Sigma[1][1]= pdTheta[5]*(1 - pdTheta[7]*pdTheta[7]); setP->Sigma[0][1]= (pdTheta[8] - pdTheta[6]*pdTheta[7])/sqrt((1 - pdTheta[6]*pdTheta[6])*(1 - pdTheta[7]*pdTheta[7])); //correlation setP->Sigma[0][1]= setP->Sigma[0][1]*sqrt(setP->Sigma[0][0]*setP->Sigma[1][1]); //covar setP->Sigma[1][0]= setP->Sigma[0][1]; //symmetry dinv2D((double*)(&(setP->Sigma[0][0])), 2, (double*)(&(setP->InvSigma[0][0])),"NCAR M-step S2"); //assign each data point the new mu (different for each point) for(i=0;it_samp;i++) { params[i].caseP.mu[0]=pdTheta[1] + pdTheta[6]*sqrt(pdTheta[4]/pdTheta[3])*(logit(params[i].caseP.X,"initNCAR mu0")-pdTheta[0]); params[i].caseP.mu[1]=pdTheta[2] + pdTheta[7]*sqrt(pdTheta[5]/pdTheta[3])*(logit(params[i].caseP.X,"initNCAR mu1")-pdTheta[0]); if(setP->verbose>=2 && !setP->sem && (i<3 || i==422)) //if(setP->verbose>=2 && i<3) Rprintf("mu primes for %d: %5g %5g (mu2: %5g p7: %5g p5: %5g X-T: %5g)\n",i,params[i].caseP.mu[0],params[i].caseP.mu[1],pdTheta[2],pdTheta[7],pdTheta[5],logit(params[i].caseP.X,"initNCAR mu0")-pdTheta[0]); } } else { //fixed rho //reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1 | 3, (5) sig_2 | 3, (6) beta1, (7) beta2, (8) r_12 | 3 //CODE BLOCK A setP->Sigma[0][0]= pdTheta[4]; setP->Sigma[1][1]= pdTheta[5]; setP->Sigma[0][1]= pdTheta[8]*sqrt(pdTheta[4]*pdTheta[5]); //covar setP->Sigma[1][0]= setP->Sigma[0][1]; //symmetry dinv2D((double*)(&(setP->Sigma[0][0])), 2, (double*)(&(setP->InvSigma[0][0])),"NCAR M-step S2"); for(i=0;it_samp;i++) { params[i].caseP.mu[0]=pdTheta[1] + pdTheta[6]*(logit(params[i].caseP.X,"initNCAR mu0")-pdTheta[0]); params[i].caseP.mu[1]=pdTheta[2] + pdTheta[7]*(logit(params[i].caseP.X,"initNCAR mu1")-pdTheta[0]); if(setP->verbose>=2 && !setP->sem && (i<3 || i==422)) //if(setP->verbose>=2 && i<3) Rprintf("mu primes for %d: %5g %5g (mu2: %5g p7: %5g p5: %5g X-T: %5g)\n",i,params[i].caseP.mu[0],params[i].caseP.mu[1],pdTheta[2],pdTheta[7],pdTheta[5],logit(params[i].caseP.X,"initNCAR mu0")-pdTheta[0]); } } } /** * CCAR initialize * Note that fixed rho is currently unimplemented * input: pdTheta * mutates: params */ void initCCAR(Param* params, double* pdTheta) { setParam* setP=params[0].setP; int i; if (!setP->fixedRho) { //variable rho //reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1, (5) sig_2, (6) r_13, (7) r_23, (8) r_12 setP->Sigma[0][0]= pdTheta[4]*(1 - pdTheta[6]*pdTheta[6]); setP->Sigma[1][1]= pdTheta[5]*(1 - pdTheta[7]*pdTheta[7]); setP->Sigma[0][1]= (pdTheta[8] - pdTheta[6]*pdTheta[7])/sqrt((1 - pdTheta[6]*pdTheta[6])*(1 - pdTheta[7]*pdTheta[7])); //correlation setP->Sigma[0][1]= setP->Sigma[0][1]*sqrt(setP->Sigma[0][0]*setP->Sigma[1][1]); //covar setP->Sigma[1][0]= setP->Sigma[0][1]; //symmetry dinv2D((double*)(&(setP->Sigma[0][0])), 2, (double*)(&(setP->InvSigma[0][0])),"NCAR M-step S2"); //assign each data point the new mu (different for each point) for(i=0;it_samp;i++) { params[i].caseP.mu[0]=pdTheta[1] + pdTheta[6]*sqrt(pdTheta[4]/pdTheta[3])*(logit(params[i].caseP.X,"initNCAR mu0")-pdTheta[0]); params[i].caseP.mu[1]=pdTheta[2] + pdTheta[7]*sqrt(pdTheta[5]/pdTheta[3])*(logit(params[i].caseP.X,"initNCAR mu1")-pdTheta[0]); if(setP->verbose>=2 && !setP->sem && (i<3 || i==422)) //if(setP->verbose>=2 && i<3) Rprintf("mu primes for %d: %5g %5g (mu2: %5g p7: %5g p5: %5g X-T: %5g)\n",i,params[i].caseP.mu[0],params[i].caseP.mu[1],pdTheta[2],pdTheta[7],pdTheta[5],logit(params[i].caseP.X,"initNCAR mu0")-pdTheta[0]); } } else { //fixed rho } } /** * input: optTheta,pdTheta,params,Rmat * mutate/output: matrices Rmat and Rmat_old (dimensions of param_len x param_len) * optTheta is optimal theta * pdTheta is current theta * Rmat_old contains the input Rmat */ void ecoSEM(double* optTheta, double* pdTheta, Param* params, double Rmat_old[7][7], double Rmat[7][7]) { //assume we have optTheta, ie \hat{phi} //pdTheta is phi^{t+1} int i,j,verbose,len,param_len; setParam setP_sem=*(params[0].setP); param_len=setP_sem.param_len; double *SuffSem=doubleArray(setP_sem.suffstat_len+1); //sufficient stats double phiTI[param_len]; //phi^t_i double phiTp1I[param_len]; //phi^{t+1}_i double t_optTheta[param_len]; //transformed optimal double t_phiTI[param_len]; //transformed phi^t_i double t_phiTp1I[param_len]; //transformed phi^{t+1}_i Param* params_sem=(Param*) Calloc(params->setP->t_samp,Param); verbose=setP_sem.verbose; //determine length of R matrix len=0; for(j=0; j=2) Rprintf("Theta(%d):",(i+1)); int switch_index_ir=0; int switch_index_it=0; for(j=0;j=2) Rprintf(" %5g ", phiTI[j]); } //if (setP_sem.fixedRho) { // phiTI[len-1]=pdTheta[len-1]; // phiTp1I[len-1]=pdTheta[len-1]; // if (verbose>=2) Rprintf(" %5g ", phiTI[len-1]); //} if (verbose>=2) Rprintf("\n"); for(j=0;j=2) { Rprintf("Sigma3: %5g %5g %5g %5g %5g %5g; %5g %5g\n",setP_sem.Sigma3[0][0],setP_sem.Sigma3[0][1],setP_sem.Sigma3[1][1],setP_sem.Sigma3[0][2],setP_sem.Sigma3[1][2],setP_sem.Sigma3[2][2],*(&(setP_sem.Sigma3[0][0])+0),*(&(setP_sem.Sigma3[0][0])+8)); } dinv2D((double*)(&(setP_sem.Sigma3[0][0])), 3, (double*)(&(setP_sem.InvSigma3[0][0])),"SEM: NCAR Sig3 init"); if (verbose>=2) { Rprintf("Check 1"); } if (setP_sem.fixedRho) ncarFixedRhoTransform(phiTI); initNCAR(params_sem,phiTI); if (setP_sem.fixedRho) ncarFixedRhoUnTransform(phiTI); if (verbose>=2) { Rprintf("Check 2"); } } //if (verbose>=2) { // Rprintf("Sigma: %5g %5g %5g %5g\n",setP_sem.Sigma[0][0],setP_sem.Sigma[0][1],setP_sem.Sigma[1][0],setP_sem.Sigma[1][1]); //} ecoEStep(params_sem, SuffSem); if (!params[0].setP->ncar) ecoMStep(SuffSem,phiTp1I,params_sem); else ecoMStepNCAR(SuffSem,phiTp1I,params_sem); //step 3: create new R matrix row transformTheta(phiTp1I,t_phiTp1I,setP_sem.param_len,&setP_sem); transformTheta(optTheta,t_optTheta,setP_sem.param_len,&setP_sem); transformTheta(phiTI,t_phiTI,setP_sem.param_len,&setP_sem); /*if (verbose>=2) { Rprintf("T+1:"); for (j=0;jsemDone[i]=closeEnough((double*)Rmat[i],(double*)Rmat_old[i],len,sqrt(params[0].setP->convergence)); } else { //keep row the same for(j = 0; j=1) { for(i=0;isemDone[i]) ? " Done" : "Not done"); for(j=0;j= 1) ? .9999 : ((params[i].caseP.X <= 0) ? 0.0001 : params[i].caseP.X); //fix Y edge cases params[i].caseP.Y=(params[i].caseP.Y >= 1) ? .9999 : ((params[i].caseP.Y <= 0) ? 0.0001 : params[i].caseP.Y); } /*read the survey data */ itemp=0; surv_dim=n_dim + (setP->ncar ? 1 : 0); //if NCAR, the survey data will include X's for (j=0; j0) { Rprintf("WARNING: Homogenous data is ignored and not handled by the current version of eco."); } if (setP->verbose>=2) { Rprintf("Y X\n"); for(i=0;i<5;i++) Rprintf("%5d%14g%14g\n",i,params[i].caseP.Y,params[i].caseP.X); if (s_samp>0) { Rprintf("SURVEY data\nY X\n"); int s_max=fmin2(n_samp+x1_samp+x0_samp+s_samp,n_samp+x1_samp+x0_samp+5); for(i=n_samp+x1_samp+x0_samp; iparam_len; //trying to print nicely, but it throws an error //char temp[50]; int hlen; //if (!finalTheta) hlen=sprintf(temp, "cycle %d/%d:",main_loop,iteration_max); //Length of cycle text //else hlen=sprintf(temp, "Final Theta:"); //for (i=0;ifixedRho || finalTheta) Rprintf(" r_12"); } else { //NCAR if (finalTheta) { Rprintf(" mu_3 mu_1 mu_2 sig_3 sig_1 sig_2 r_13 r_23 r_12"); } else { Rprintf(" mu_1 mu_2 sig_1 sig_2 r_13 r_23 r_12"); } } Rprintf("\n"); } /** * Parameterizes the elements of theta * Input: pdTheta * Mutates: t_pdTheta */ void transformTheta(double* pdTheta, double* t_pdTheta, int len, setParam* setP) { if (len<=5) { t_pdTheta[0]=pdTheta[0]; t_pdTheta[1]=pdTheta[1]; t_pdTheta[2]=log(pdTheta[2]); t_pdTheta[3]=log(pdTheta[3]); t_pdTheta[4]=.5*(log(1+pdTheta[4])-log(1-pdTheta[4])); } else { t_pdTheta[0]=pdTheta[0]; t_pdTheta[1]=pdTheta[1]; t_pdTheta[2]=pdTheta[2]; t_pdTheta[3]=log(pdTheta[3]); t_pdTheta[4]=log(pdTheta[4]); t_pdTheta[5]=log(pdTheta[5]); t_pdTheta[6]=.5*(log(1+pdTheta[6])-log(1-pdTheta[6])); t_pdTheta[7]=.5*(log(1+pdTheta[7])-log(1-pdTheta[7])); t_pdTheta[8]=.5*(log(1+pdTheta[8])-log(1-pdTheta[8])); } } /** * Un-parameterizes the elements of theta * Input: t_pdTheta * Mutates: pdTheta */ void untransformTheta(double* t_pdTheta,double* pdTheta, int len, setParam* setP) { if (len<=5) { pdTheta[0]=t_pdTheta[0]; pdTheta[1]=t_pdTheta[1]; pdTheta[2]=exp(t_pdTheta[2]); pdTheta[3]=exp(t_pdTheta[3]); pdTheta[4]=(exp(2*t_pdTheta[4])-1)/(exp(2*t_pdTheta[4])+1); } else { pdTheta[0]=t_pdTheta[0]; pdTheta[1]=t_pdTheta[1]; pdTheta[2]=t_pdTheta[2]; pdTheta[3]=exp(t_pdTheta[3]); pdTheta[4]=exp(t_pdTheta[4]); pdTheta[5]=exp(t_pdTheta[5]); if (!setP->fixedRho) { pdTheta[6]=(exp(2*t_pdTheta[6])-1)/(exp(2*t_pdTheta[6])+1); pdTheta[7]=(exp(2*t_pdTheta[7])-1)/(exp(2*t_pdTheta[7])+1); } else { pdTheta[6]=t_pdTheta[6]; pdTheta[7]=t_pdTheta[7]; } pdTheta[8]=(exp(2*t_pdTheta[8])-1)/(exp(2*t_pdTheta[8])+1); } } /** * untransforms theta under ncar -- fixed rho * input reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1 | 3, (5) sig_2 | 3, (6) beta1, (7) beta2, (8) r_12 | 3 * output reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1, (5) sig_2, (6) r_13, (7) r_23, (8) r_12 * mutates: pdTheta **/ void ncarFixedRhoUnTransform(double* pdTheta) { double* tmp=doubleArray(9); int i; for (i=0;i<9;i++) tmp[i]=pdTheta[i]; pdTheta[0]=tmp[0]; pdTheta[1]=tmp[1]; pdTheta[2]=tmp[2]; pdTheta[3]=tmp[3]; pdTheta[4]=tmp[4] + tmp[6]*tmp[6]*tmp[3]; pdTheta[5]=tmp[5] + tmp[7]*tmp[7]*tmp[3]; pdTheta[6]=(tmp[6]*sqrt(tmp[3]))/(sqrt(pdTheta[4])); pdTheta[7]=(tmp[7]*sqrt(tmp[3]))/(sqrt(pdTheta[5])); pdTheta[8]=(tmp[8]*sqrt(tmp[4]*tmp[5]) + tmp[6]*tmp[7]*tmp[3])/(sqrt(pdTheta[4]*pdTheta[5])); Free(tmp); } /** * transforms theta under ncar -- fixed rho * input reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1, (5) sig_2, (6) r_13, (7) r_23, (8) r_12 * output reference: (0) mu_3, (1) mu_1, (2) mu_2, (3) sig_3, (4) sig_1 | 3, (5) sig_2 | 3, (6) beta1, (7) beta2, (8) r_12 | 3 * mutates: pdTheta **/ void ncarFixedRhoTransform(double* pdTheta) { double* tmp=doubleArray(9); int i; for (i=0;i<9;i++) tmp[i]=pdTheta[i]; pdTheta[0]=tmp[0]; pdTheta[1]=tmp[1]; pdTheta[2]=tmp[2]; pdTheta[3]=tmp[3]; pdTheta[4]=tmp[4] - tmp[6]*tmp[6]*tmp[4]; pdTheta[5]=tmp[5] - tmp[7]*tmp[7]*tmp[5]; pdTheta[6]=tmp[6]*sqrt(tmp[4]/tmp[3]); pdTheta[7]=tmp[7]*sqrt(tmp[5]/tmp[3]); pdTheta[8]=(tmp[8] - tmp[6]*tmp[7])/(sqrt((1 - tmp[6]*tmp[6])*(1 - tmp[7]*tmp[7]))); Free(tmp); } /** * Input transformed theta, loglikelihood, iteration * Mutates: history_full **/ void setHistory(double* t_pdTheta, double loglik, int iter,setParam* setP,double history_full[][10]) { int len=setP->param_len; int j; for(j=0;j0) history_full[iter-1][len]=loglik; } /** * Determines whether we have converged * Takes in the current and old (one step previous) array of theta values * maxerr is the maximum difference two corresponding values can have before the * function returns false */ int closeEnough(double* pdTheta, double* pdTheta_old, int len, double maxerr) { int j; for(j = 0; j=maxerr) return 0; return 1; } /** * Is the SEM process completely done. **/ int semDoneCheck(setParam* setP) { int varlen=0; int j; for(j=0; jparam_len;j++) if(setP->varParam[j]) varlen++; for(j=0;jsemDone[j]==0) return 0; return 1; } /** * Older function. No longer used. **/ void gridEStep(Param* params, int n_samp, int s_samp, int x1_samp, int x0_samp, double* suff, int verbose, double minW1, double maxW1) { int n_dim=2; int n_step=5000; /* The default size of grid step */ int ndraw=10000; int trapod=0; /* 1 if use trapozodial ~= in numer. int.*/ int *n_grid=intArray(n_samp); /* grid size */ double **W1g=doubleMatrix(n_samp, n_step); /* grids for W1 */ double **W2g=doubleMatrix(n_samp, n_step); /* grids for W2 */ double *vtemp=doubleArray(n_dim); int *mflag=intArray(n_step); double *prob_grid=doubleArray(n_step); double *prob_grid_cum=doubleArray(n_step); double **X=doubleMatrix(n_samp,n_dim); /* Y and covariates */ int itemp,i,j,k,t_samp; double dtemp,dtemp1,temp0,temp1; t_samp=n_samp+x1_samp+x0_samp+s_samp; double **W=doubleMatrix(t_samp,n_dim); /* W1 and W2 matrix */ double **Wstar=doubleMatrix(t_samp,5); /* pseudo data(transformed*/ for (i=0;iInvSigma), 2, 1) - log(W1g[i][j])-log(W2g[i][j])-log(1-W1g[i][j])-log(1-W2g[i][j]); prob_grid[j]=exp(prob_grid[j]); dtemp+=prob_grid[j]; prob_grid_cum[j]=dtemp; } for (j=0;j=1 && trapod==1) { if (prob_grid_cum[j]!=prob_grid_cum[(j-1)]) { dtemp1=((double)(1+k)/(ndraw+1)-prob_grid_cum[(j-1)])/(prob_grid_cum[j]-prob_grid_cum[(j-1)]); W[i][0]=dtemp1*(W1g[i][j]-W1g[i][(j-1)])+W1g[i][(j-1)]; W[i][1]=dtemp1*(W2g[i][j]-W2g[i][(j-1)])+W2g[i][(j-1)]; } else if (prob_grid_cum[j]==prob_grid_cum[(j-1)]) { W[i][0]=W1g[i][j]; W[i][1]=W2g[i][j]; } } temp0=log(W[i][0])-log(1-W[i][0]); temp1=log(W[i][1])-log(1-W[i][1]); Wstar[i][0]+=temp0; Wstar[i][1]+=temp1; Wstar[i][2]+=temp0*temp0; Wstar[i][3]+=temp0*temp1; Wstar[i][4]+=temp1*temp1; } } } // compute E_{W_i|Y_i} for n_samp for (i=0; i #include #include #include #include #include int* intArray(int num) { int *iArray = (int *)malloc(num * sizeof(int)); if (iArray) return iArray; else { error("Out of memory error in intArray\n"); return NULL; } } int** intMatrix(int row, int col) { int i; int **iMatrix = (int **)malloc(row * sizeof(int *)); if (iMatrix) { for (i = 0; i < row; i++) { iMatrix[i] = (int *)malloc(col * sizeof(int)); if (!iMatrix[i]) error("Out of memory error in intMatrix\n"); } return iMatrix; } else { error("Out of memory error in intMatrix\n"); return NULL; } } double* doubleArray(int num) { //double *dArray = (double *)malloc(num * sizeof(double)); double *dArray = Calloc(num,double); if (dArray) return dArray; else { error("Out of memory error in doubleArray\n"); return NULL; } } double** doubleMatrix(int row, int col) { int i; //double **dMatrix = (double **)malloc((size_t)(row * sizeof(double *))); double **dMatrix = Calloc(row,double*); if (dMatrix) { for (i = 0; i < row; i++) { dMatrix[i] = Calloc(col,double); if (!dMatrix[i]) { error("Out of memory error in doubleMatrix\n"); return NULL; } } return dMatrix; } else { error("Out of memory error in doubleMatrix\n"); return NULL; } } double*** doubleMatrix3D(int x, int y, int z) { int i; double ***dM3 = (double ***)malloc(x * sizeof(double **)); if (dM3) { for (i = 0; i < x; i++) dM3[i] = doubleMatrix(y, z); return dM3; } else { error("Out of memory error in doubleMatrix3D\n"); return NULL; } } long* longArray(int num) { long *lArray = (long *)malloc(num * sizeof(long)); if (lArray) return lArray; else { error("Out of memory error in longArray\n"); return NULL; } } void FreeMatrix(double **Matrix, int row) { int i; for (i = 0; i < row; i++) Free(Matrix[i]); Free(Matrix); } void FreeintMatrix(int **Matrix, int row) { int i; for (i = 0; i < row; i++) free(Matrix[i]); free(Matrix); } void Free3DMatrix(double ***Matrix, int index, int row) { int i; for (i = 0; i < index; i++) FreeMatrix(Matrix[i], row); free(Matrix); } eco/src/gibbsBase.c0000644000175100001440000002123613136253506013662 0ustar hornikusers #include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" /* Normal Parametric Model for 2x2 Tables */ void cBaseeco( /*data input */ double *pdX, /* data (X, Y) */ int *pin_samp, /* sample size */ /*MCMC draws */ int *n_gen, /* number of gibbs draws */ int *burn_in, /* number of draws to be burned in */ int *pinth, /* keep every nth draw */ int *verbose, /* 1 for output monitoring */ /* prior specification*/ int *pinu0, /* prior df parameter for InvWish */ double *pdtau0, /* prior scale parameter for Sigma */ double *mu0, /* prior mean for mu */ double *pdS0, /* prior scale for Sigma */ double *mustart, /* starting values for mu */ double *Sigmastart, /* starting values for Sigma */ /* incorporating survey data */ int *survey, /*1 if survey data available (set of W_1, W_2) 0 not*/ int *sur_samp, /*sample size of survey data*/ double *sur_W, /*set of known W_1, W_2 */ /* incorporating homeogenous areas */ int *x1, /* 1 if X=1 type areas available W_1 known, W_2 unknown */ int *sampx1, /* number X=1 type areas */ double *x1_W1, /* values of W_1 for X1 type areas */ int *x0, /* 1 if X=0 type areas available W_2 known, W_1 unknown */ int *sampx0, /* number X=0 type areas */ double *x0_W2, /* values of W_2 for X0 type areas */ /* bounds of W1 */ double *minW1, double *maxW1, /* flags */ int *parameter, /* 1 if save population parameter */ int *Grid, /* 1 if Grid algorithm is used; 0 for Metropolis */ /* storage for Gibbs draws of mu/sigmat*/ double *pdSMu0, double *pdSMu1, double *pdSSig00, double *pdSSig01, double *pdSSig11, /* storage for Gibbs draws of W*/ double *pdSW1, double *pdSW2 ){ /* some integers */ int n_samp = *pin_samp; /* sample size */ int s_samp = *sur_samp; /* sample size of survey data */ int x1_samp = *sampx1; /* sample size for X=1 */ int x0_samp = *sampx0; /* sample size for X=0 */ int t_samp = n_samp+s_samp+x1_samp+x0_samp; /* total sample size */ int nth = *pinth; int n_dim = 2; /* dimension */ int n_step = 1000; /* 1/The default size of grid step */ /* prior parameters */ double tau0 = *pdtau0; /* prior scale */ int nu0 = *pinu0; /* prior degrees of freedom */ double **S0 = doubleMatrix(n_dim, n_dim); /* The prior S parameter for InvWish */ /* data */ double **X = doubleMatrix(n_samp, n_dim); /* The Y and covariates */ double **W = doubleMatrix(t_samp, n_dim); /* The W1 and W2 matrix */ double **Wstar = doubleMatrix(t_samp, n_dim); /* logit tranformed W */ double **S_W = doubleMatrix(s_samp, n_dim); /* The known W1 and W2 matrix*/ double **S_Wstar = doubleMatrix(s_samp, n_dim); /* logit transformed S_W*/ /* grids */ double **W1g = doubleMatrix(n_samp, n_step); /* grids for W1 */ double **W2g = doubleMatrix(n_samp, n_step); /* grids for W2 */ int *n_grid = intArray(n_samp); /* grid size */ /* model parameters */ double *mu = doubleArray(n_dim); /* The mean */ double **Sigma = doubleMatrix(n_dim, n_dim); /* The covariance matrix */ double **InvSigma = doubleMatrix(n_dim, n_dim); /* The inverse covariance matrix */ /* misc variables */ int i, j, k, main_loop; /* used for various loops */ int itemp, itempS, itempC, itempA; int progress = 1, itempP = ftrunc((double) *n_gen/10); double dtemp, dtemp1; /* get random seed */ GetRNGstate(); /* read the priors */ itemp=0; for(k=0;k=*burn_in){ itempC++; if (itempC==nth){ pdSMu0[itempA]=mu[0]; pdSMu1[itempA]=mu[1]; pdSSig00[itempA]=Sigma[0][0]; pdSSig01[itempA]=Sigma[0][1]; pdSSig11[itempA]=Sigma[1][1]; itempA++; for(i=0; i<(n_samp+x1_samp+x0_samp); i++){ pdSW1[itempS]=W[i][0]; pdSW2[itempS]=W[i][1]; itempS++; } itempC=0; } } if (*verbose) if (itempP == main_loop) { Rprintf("%3d percent done.\n", progress*10); itempP+=ftrunc((double) *n_gen/10); progress++; R_FlushConsole(); } R_CheckUserInterrupt(); } /* end of Gibbs sampler */ if(*verbose) Rprintf("100 percent done.\n"); /** write out the random seed **/ PutRNGstate(); /* Freeing the memory */ FreeMatrix(X, n_samp); FreeMatrix(W, t_samp); FreeMatrix(Wstar, t_samp); FreeMatrix(S_W, s_samp); FreeMatrix(S_Wstar, s_samp); FreeMatrix(S0, n_dim); FreeMatrix(W1g, n_samp); FreeMatrix(W2g, n_samp); free(n_grid); free(mu); FreeMatrix(Sigma,n_dim); FreeMatrix(InvSigma, n_dim); } /* main */ eco/src/bayes.h0000644000175100001440000000073613136253506013113 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ void NIWupdate(double **Y, double *mu, double **Sigma, double **InvSigma, double *mu0, double tau0, int nu0, double **S0, int n_samp, int n_dim); eco/src/vector.h0000644000175100001440000000130013136253506013276 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ #include #include int *intArray(int num); int **intMatrix(int row, int col); double *doubleArray(int num); double **doubleMatrix(int row, int col); double ***doubleMatrix3D(int x, int y, int z); long *longArray(int num); void FreeMatrix(double **Matrix, int row); void FreeintMatrix(int **Matrix, int row); void Free3DMatrix(double ***Matrix, int index, int row); eco/src/subroutines.h0000644000175100001440000000144613136253506014371 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ void SWP( double **X, int k, int size); void dinv(double **X, int size, double **X_inv); void dinv2D(double *X, int size, double *X_inv,char* emsg); void dinv2D_sym(double *X, int size, double *X_inv,char* emsg); void dcholdc(double **X, int size, double **L); double ddet(double **X, int size, int give_log); double ddet2D(double **X, int size, int give_log); void dcholdc2D(double *X, int size, double *L); void matrixMul(double **A, double **B, int r1, int c1, int r2, int c2, double **C); eco/src/gibbsXBase.c0000644000175100001440000002320613136253506014011 0ustar hornikusers#include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" /* Normal Parametric Model for 2x2 Tables with Contextual Effects */ void cBaseecoX( /*data input */ double *pdX, /* data (X, Y) */ int *pin_samp, /* sample size */ /*MCMC draws */ int *n_gen, /* number of gibbs draws */ int *burn_in, /* number of draws to be burned in */ int *pinth, /* keep every nth draw */ int *verbose, /* 1 for output monitoring */ /* prior specification*/ int *pinu0, /* prior df parameter for InvWish */ double *pdtau0, /* prior scale parameter for Sigma under G0*/ double *mu0, /* prior mean for mu under G0 */ double *pdS0, /* prior scale for Sigma */ double *mustart, /* starting values for mu */ double *Sigmastart, /* starting values for Sigma */ /*incorporating survey data */ int *survey, /*1 if survey data available (set of W_1, W_2) 0 not*/ int *sur_samp, /*sample size of survey data*/ double *sur_W, /*set of known W_1, W_2 */ /* incorporating homeogenous areas */ int *x1, /* 1 if X=1 type areas available W_1 known, W_2 unknown */ int *sampx1, /* number X=1 type areas */ double *x1_W1, /* values of W_1 for X1 type areas */ int *x0, /* 1 if X=0 type areas available W_2 known, W_1 unknown */ int *sampx0, /* number X=0 type areas */ double *x0_W2, /* values of W_2 for X0 type areas */ /* bounds fo W1 */ double *minW1, double *maxW1, /* flags */ int *parameter, /* 1 if save population parameter */ int *Grid, /* 1 if Grid algorithm is used; 0 for Metropolis */ /* storage for Gibbs draws of mu/sigmat*/ double *pdSMu0, double *pdSMu1, double *pdSMu2, double *pdSSig00, double *pdSSig01, double *pdSSig02, double *pdSSig11, double *pdSSig12, double *pdSSig22, /* storage for Gibbs draws of W*/ double *pdSW1, double *pdSW2 ){ /* some integers */ int n_samp = *pin_samp; /* sample size */ int s_samp = *sur_samp; /* sample size of survey data */ int x1_samp = *sampx1; /* sample size for X=1 */ int x0_samp = *sampx0; /* sample size for X=0 */ int t_samp = n_samp+s_samp+x1_samp+x0_samp; /* total sample size */ int nth = *pinth; int n_dim = 2; /* dimension */ int n_step = 1000; /* 1/The default size of grid step */ /* prior parameters */ double tau0 = *pdtau0; int nu0 = *pinu0; double **S0 = doubleMatrix(n_dim+1,n_dim+1); /* The prior S parameter for InvWish */ /* data */ double **X = doubleMatrix(n_samp,n_dim); /* The Y and covariates */ double **W = doubleMatrix(t_samp,n_dim); /* The W1 and W2 matrix */ double **Wstar = doubleMatrix(t_samp,n_dim+1); /* logit transformed W and X */ double **S_W = doubleMatrix(s_samp, n_dim+1); /* known W1, W2, X */ double **S_Wstar = doubleMatrix(s_samp, n_dim+1); /* logit transformed S_W */ /* grids */ double **W1g = doubleMatrix(n_samp, n_step); double **W2g = doubleMatrix(n_samp, n_step); int *n_grid = intArray(n_samp); /* grid size */ /* ordinary model variables */ double *mu = doubleArray(n_dim+1); double **Sigma = doubleMatrix(n_dim+1,n_dim+1); double **InvSigma = doubleMatrix(n_dim+1,n_dim+1); /* conditional mean & variance for (W1, W2) given X */ double *mu_w = doubleArray(n_dim); double **Sigma_w = doubleMatrix(n_dim,n_dim); double **InvSigma_w = doubleMatrix(n_dim,n_dim); /* misc variables */ int i, j, k, main_loop; /* used for various loops */ int itemp, itempS, itempC, itempA; int progress = 1, itempP = ftrunc((double) *n_gen/10); double dtemp, dtemp1; /* get random seed */ GetRNGstate(); /* priors */ itemp = 0; for(k=0; k<(n_dim+1); k++) for(j=0; j<(n_dim+1); j++) S0[j][k] = pdS0[itemp++]; /* read the data set */ itemp = 0; for (j = 0; j < n_dim; j++) for (i = 0; i < n_samp; i++) X[i][j] = pdX[itemp++]; /* Initialize W, Wstar for n_samp */ for (i=0; i< n_samp; i++) { if (X[i][1]!=0 && X[i][1]!=1) { W[i][0]=runif(minW1[i], maxW1[i]); W[i][1]=(X[i][1]-X[i][0]*W[i][0])/(1-X[i][0]); } if (X[i][1]==0) for (j=0; j=*burn_in){ itempC++; if (itempC==nth){ pdSMu0[itempA]=mu[0]; pdSMu1[itempA]=mu[1]; pdSMu2[itempA]=mu[2]; pdSSig00[itempA]=Sigma[0][0]; pdSSig01[itempA]=Sigma[0][1]; pdSSig02[itempA]=Sigma[0][2]; pdSSig11[itempA]=Sigma[1][1]; pdSSig12[itempA]=Sigma[1][2]; pdSSig22[itempA]=Sigma[2][2]; itempA++; for(i=0; i<(n_samp+x1_samp+x0_samp); i++){ pdSW1[itempS]=W[i][0]; pdSW2[itempS]=W[i][1]; itempS++; } itempC=0; } } /*end of stroage *burn_in*/ if (*verbose) if (itempP == main_loop) { Rprintf("%3d percent done.\n", progress*10); itempP+=ftrunc((double) *n_gen/10); progress++; R_FlushConsole(); } } /*end of MCMC for normal */ if(*verbose) Rprintf("100 percent done.\n"); /** write out the random seed **/ PutRNGstate(); /* Freeing the memory */ FreeMatrix(X, n_samp); FreeMatrix(W, t_samp); FreeMatrix(Wstar, t_samp); free(n_grid); FreeMatrix(S0, n_dim+1); FreeMatrix(W1g, n_samp); FreeMatrix(W2g, n_samp); FreeMatrix(S_W, s_samp); FreeMatrix(S_Wstar, s_samp); free(mu); FreeMatrix(Sigma, n_dim+1); FreeMatrix(InvSigma, n_dim+1); free(mu_w); FreeMatrix(Sigma_w, n_dim); FreeMatrix(InvSigma_w, n_dim); } /* main */ eco/src/gibbsZBase.c0000644000175100001440000003141513136253506014014 0ustar hornikusers#include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "sample.h" void cBaseecoZ( /*data input */ double *pdX, /* data (X, Y) */ double *pdZ, /* covariates Z */ int *pinZp, /* dimension of Z if =1, =gibbsBase =2 and Z=X, gibbsXBase >2 or Z!=X, regression*/ int *pin_samp, /* sample size */ /*MCMC draws */ int *n_gen, /* number of gibbs draws */ int *burn_in, /* number of draws to be burned in */ int *pinth, /* keep every nth draw */ int *verbose, /* 1 for output monitoring */ /* prior specification for imputation, (beta, Sigma)~N-InvWish*/ /* prior for Sigma~InvWish(nu, S)*/ int *pinu0, /* prior df parameter for InvWish */ double *pdS0, /* prior scale for Sigma */ /* prior for beta~N(b0, Sigma*A0^-1) */ double *pdbeta0, /* prior mean for beta*/ double *pdA0, /* prior PRECISION=1/SCALE parameter for beta*/ /* staring values */ double *betastart, double *Sigmastart, /*incorporating survey data */ int *survey, /*1 if survey data available (set of W_1, W_2) 0 not*/ int *sur_samp, /*sample size of survey data*/ double *sur_W, /*set of known W_1, W_2 */ /*incorporating homeogenous areas */ int *x1, /* 1 if X=1 type areas available W_1 known, W_2 unknown */ int *sampx1, /* number X=1 type areas */ double *x1_W1, /* values of W_1 for X1 type areas */ int *x0, /* 1 if X=0 type areas available W_2 known, W_1 unknown */ int *sampx0, /* number X=0 type areas */ double *x0_W2, /* values of W_2 for X0 type areas */ /* bounds of W1 */ double *minW1, double *maxW1, /* storage */ int *parameter,/* 1 if save population parameter */ int *Grid, /* storage for Gibbs draws of beta and Sigam, packed */ double *pdSBeta, double *pdSSigma, /* storage for Gibbs draws of W*/ double *pdSW1, double *pdSW2 ){ int n_samp = *pin_samp; /* sample size */ int nth = *pinth; int s_samp = *sur_samp; /* sample size of survey data */ int x1_samp = *sampx1; int x0_samp = *sampx0; int t_samp = n_samp+s_samp+x1_samp+x0_samp; /* total sample size */ int n_dim = 2; /* The dimension of the ecological table */ int n_cov = *pinZp; /* The dimension of the covariates */ int n_step = 1000; /* priors */ double *beta0 = doubleArray(n_cov); /* prior mean of beta */ double **S0 = doubleMatrix(n_dim, n_dim); /* prior scale for Sigma */ double **A0 = doubleMatrix(n_cov, n_cov); /* prior precision for beta */ int nu0 = *pinu0; /* prior df for Sigma */ /* data */ double **X = doubleMatrix(n_samp, n_dim); /* The Y and X */ /*The known W1 and W2 matrix*/ double **S_W = doubleMatrix(s_samp, n_dim); double **S_Wstar=doubleMatrix(s_samp, n_dim); /* pseudo data Wstar */ double **W = doubleMatrix(t_samp, n_dim); double **Wstar = doubleMatrix(t_samp, n_dim); double *Wstar_bar = doubleArray(n_dim); /* The covariates and W */ double **Z = doubleMatrix(t_samp*n_dim+n_cov, n_cov+1); /* Z*cholesky factor of covaraince matrix*/ double **Zstar = doubleMatrix(t_samp*n_dim+n_cov, n_cov+1); /* grids */ double **W1g = doubleMatrix(n_samp, n_step); /* grids for W1 */ double **W2g = doubleMatrix(n_samp, n_step); /* grids for W2 */ int *n_grid = intArray(n_samp); /* grid size */ /* paramters for Wstar under Normal baseline model */ double *beta = doubleArray(n_cov); /* vector of regression coefficients */ double **mu = doubleMatrix(t_samp, n_dim); double **Sigma = doubleMatrix(n_dim, n_dim); double **InvSigma = doubleMatrix(n_dim, n_dim); /*posterior parameters for beta and Sigma*/ double *mbeta = doubleArray(n_cov); /* posterior mean of beta*/ double **Vbeta = doubleMatrix(n_cov,n_cov); /* posterior varaince of beta */ /* matrices used for sweep */ /* quantities used in sweep */ double **SS = doubleMatrix(n_cov+1, n_cov+1); /* the sum of square matrix */ double *epsilon = doubleArray(t_samp*n_dim); /* The error term */ double **R = doubleMatrix(n_dim, n_dim); /* ee' */ /* misc variables */ int i, j, k, l, main_loop; /* used for various loops */ int itemp; int itempA=0; /* counter for alpha */ int itempB=0; int itempC=0; /* counter to control nth draw */ int itempS=0; /* counter for storage */ int progress = 1, itempP = ftrunc((double) *n_gen/10); double dtemp, dtemp1; double *vtemp = doubleArray(n_dim); double **mtemp = doubleMatrix(n_dim, n_dim); double **mtemp1 = doubleMatrix(n_dim, n_dim); double **mtemp2 = doubleMatrix(n_cov, n_cov); /* get random seed */ GetRNGstate(); /**read prior information*/ itemp=0; for (k=0; k=*burn_in){ itempC++; if (itempC==nth){ for (j=0; jW1*, 1->W2*, 2->(W1*)^2, 3->(W1*)(W2*), 4->(W2*)^2, 5->W1,6->W2 7->Log Lik,8->test * data point type: 0=general, 1= homogenous with (X==1), 2= homogenous with (X==0), 3=survey (W1 and W2 are known) */ enum e_sufficient_stats {SS_W1star, SS_W2star, SS_W1star2, SS_W1W2star, SS_W2star2, SS_W1, SS_W2, SS_Loglik, SS_Test}; typedef enum e_sufficient_stats sufficient_stat; enum e_datapoint_types {DPT_General,DPT_Homog_X1, DPT_Homog_X0, DPT_Survey}; typedef enum e_datapoint_types datapoint_type; /* parameters and observed data -- no longer used*/ struct Param_old{ double mu[2]; double Sigma[2][2]; double InvSigma[2][2]; double Sigma3[3][3]; double InvSigma3[3][3]; int NCAR; double data[2]; //collect the data double X; //X,Y here for ease of use double Y; double normcT; //normalized const on tomog line (integrating with parameterization) double W[2]; //if W is known, also handy place to store E[W1] when we calculate it each step double Wstar[2]; //place to store E[W1*] when we calculate it each step double W1_lb; //lower and upper bounds for W1 and W2 (not starred) double W1_ub; double W2_lb; double W2_ub; sufficient_stat suff; //the sufficient stat we're calculating: 0->W1, 1->W2,2->W1^2,3->W1W2,4->W2^2,7->Log Lik, 5/6,-1 ->test case }; typedef struct Param_old Param_old; /** * The structure that holds per-record infromation */ struct caseParam { double mu[2]; double data[2]; //collect the data double X; //X,Y here for ease of use double Y; double normcT; //normalized const on tomog line (integrating with parameterization) double W[2]; //if W is known, also handy place to store E[W1] when we calculate it each step double Wstar[2]; //place to store E[W1*] when we calculate it each step double Wbounds[2][2]; //[i][j] is {j:lower,upper}-bound of W{i+1} int suff; //the sufficient stat we're calculating: 0->W1, 1->W2,2->W1^2,3->W1W2,4->W2^2,7->Log Lik, 5/6,-1 ->test case datapoint_type dataType; double** Z_i; //CCAR: k x 2 }; typedef struct caseParam caseParam; /** * The structure that holds dataset infromation */ struct setParam { int n_samp, t_samp, s_samp,x1_samp,x0_samp,param_len,suffstat_len; //types of data sizes int iter, ncar, ccar, ccar_nvar, fixedRho, sem, hypTest, verbose, calcLoglik; //options int semDone[7]; //whether that row of the R matrix is done int varParam[9]; //whether the parameter is included in the R matrix double convergence; double Sigma[2][2]; double InvSigma[2][2]; double Sigma3[3][3]; double InvSigma3[3][3]; double** SigmaK; //for CCAR double** InvSigmaK; double** hypTestCoeff; double hypTestResult; double* pdTheta; }; typedef struct setParam setParam; struct Param { setParam* setP; //pointer to the singleton structure caseParam caseP; }; typedef struct Param Param; /***************************/ /** typedef functions **/ /***************************/ //typedef void integr_fn(double *x, int n, void *ex); //is already defined in Applic.h typedef double gsl_fn(double x, void *ex); # endif eco/src/preDP.c0000644000175100001440000000350513136253506013012 0ustar hornikusers#include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" /* Prediction for Nonparametric Model for 2x2 Tables */ void preDP( double *pdmu, double *pdSigma, int *pin_samp, int *pin_draw, int *pin_dim, int *verbose, /* 1 for output monitoring */ double *pdStore ){ /* some integers */ int n_samp = *pin_samp; /* sample size */ int n_draw = *pin_draw; /* sample size of survey data */ int n_dim = *pin_dim; /* dimension */ double *mu = doubleArray(n_dim); /* The mean */ double *Wstar = doubleArray(n_dim); double **Sigma = doubleMatrix(n_dim, n_dim); /* The covariance matrix */ /* misc variables */ int i, j, k, main_loop; /* used for various loops */ int itemp = 0; int itempM = 0; int itempS = 0; int progress = 1, itempP = ftrunc((double) n_draw/10); /* get random seed */ GetRNGstate(); for(main_loop=0; main_loop #include #include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "sample.h" #include "bayes.h" #include "macros.h" #include "fintegrate.h" //#include /** * Bivariate normal distribution, with parameterization * see: http://mathworld.wolfram.com/BivariateNormalDistribution.html * see for param: http://www.math.uconn.edu/~binns/reviewII210.pdf */ void NormConstT(double *t, int n, void *param) { int ii; int dim=2; double *mu=doubleArray(dim); double **Sigma=doubleMatrix(dim,dim); double *W1,*W1p,*W2,*W2p; double X, Y, rho; double dtemp, inp, pfact; int imposs; W1 = doubleArray(n); W1p = doubleArray(n); W2 = doubleArray(n); W2p = doubleArray(n); Param *pp=(Param *)param; mu[0]= pp->caseP.mu[0]; mu[1]= pp->caseP.mu[1]; Sigma[0][0]=pp->setP->Sigma[0][0]; Sigma[1][1]=pp->setP->Sigma[1][1]; Sigma[0][1]=pp->setP->Sigma[0][1]; Sigma[1][0]=pp->setP->Sigma[1][0]; rho=Sigma[0][1]/sqrt(Sigma[0][0]*Sigma[1][1]); //Rprintf("TESTING: %4g %4g %4g %4g", pp->caseP.mu[0], pp->caseP.mu[1], pp->setP->Sigma[0][0],pp->setP->Sigma[0][1]); X=pp->caseP.X; Y=pp->caseP.Y; imposs=0; dtemp=1/(2*M_PI*sqrt(Sigma[0][0]*Sigma[1][1]*(1-rho*rho))); for (ii=0; iisetP->weirdness) // Rprintf("Normc... %d %d %5g -> %5g %5g => %5g with %5g imposs %d\n", ii, n, inp, W1[ii], W2[ii],t[ii],pfact,imposs); //char ch; //scanf(" %c", &ch ); } } Free(W1); Free(W1p); Free(W2); Free(W2p); Free(mu); FreeMatrix(Sigma,dim); } /** * Integrand for computing sufficient statistic * Which statistic to estimate depends on param->suff (see macros.h) */ void SuffExp(double *t, int n, void *param) { int ii,imposs,i,j; sufficient_stat suff; Param *pp=(Param *)param; int dim = (pp->setP->ncar==1) ? 3 : 2; double *mu=doubleArray(dim); double **Sigma=doubleMatrix(dim,dim); double **InvSigma=doubleMatrix(dim,dim);/* inverse covariance matrix*/ //double Sigma[dim][dim]; //double InvSigma[dim][dim]; double *W1,*W1p,*W2,*W2p,*vtemp; double inp,density,pfact,normc; vtemp=doubleArray(dim); W1 = doubleArray(n); W1p = doubleArray(n); W2 = doubleArray(n); W2p = doubleArray(n); mu[0]= pp->caseP.mu[0]; mu[1]= pp->caseP.mu[1]; for(i=0;isetP->Sigma3[i][j]; InvSigma[i][j]=pp->setP->InvSigma3[i][j]; } else { Sigma[i][j]=pp->setP->Sigma[i][j]; InvSigma[i][j]=pp->setP->InvSigma[i][j]; } } } normc=pp->caseP.normcT; suff=pp->caseP.suff; imposs=0; for (ii=0; iisetP->verbose>=2 && dim==3) Rprintf("InvSigma loglik: %5g %5g %5g %5g %5g %5g\n",InvSigma[0][0],InvSigma[0][1],InvSigma[1][0],InvSigma[1][1],InvSigma[1][2],InvSigma[2][2]); vtemp[2]=logit(pp->caseP.X,"log-likelihood"); mu[0]=pp->setP->pdTheta[1]; mu[1]=pp->setP->pdTheta[2]; mu[2]=pp->setP->pdTheta[0]; } t[ii]=dMVN(vtemp,mu,InvSigma,dim,0)*pfact; //t[ii]=dMVN3(vtemp,mu,(double*)(&(InvSigma[0][0])),dim,0)*pfact; } else if (suff!=SS_Test) Rprintf("Error Suff= %d",suff); } } Free(W1);Free(W1p);Free(W2);Free(W2p);Free(mu);Free(vtemp); FreeMatrix(Sigma,dim); FreeMatrix(InvSigma,dim); } /** * Returns the log likelihood of a particular case (i.e, record, datapoint) */ double getLogLikelihood(Param* param) { if (param->caseP.dataType==DPT_General && !(param->caseP.Y>=.990 || param->caseP.Y<=.010)) { //non-survey data: do integration to find likelihood param->caseP.suff=SS_Loglik; return log(paramIntegration(&SuffExp,(void*)param)); } else if (param->caseP.dataType==DPT_Homog_X1 || param->caseP.dataType==DPT_Homog_X0) { //Homogenenous data: just do normal likelihood on one dimension double lik,sigma2,val,mu; val = (param->caseP.dataType==DPT_Homog_X1) ? param->caseP.Wstar[0] : param->caseP.Wstar[1]; if (!param->setP->ncar) { mu = (param->caseP.dataType==DPT_Homog_X1) ? param->setP->pdTheta[0] : param->setP->pdTheta[1]; sigma2 = (param->caseP.dataType==DPT_Homog_X1) ? param->setP->pdTheta[2] : param->setP->pdTheta[3]; } else { mu = (param->caseP.dataType==DPT_Homog_X1) ? param->setP->pdTheta[1] : param->setP->pdTheta[2]; sigma2 = (param->caseP.dataType==DPT_Homog_X1) ? param->setP->pdTheta[4] : param->setP->pdTheta[5]; } lik=(1/(sqrt(2*M_PI*sigma2)))*exp(-(.5/sigma2)*(val - mu)*(val - mu)); //return log(lik); return 0; //fix later } else if (param->caseP.dataType==DPT_Survey || (param->caseP.Y>=.990 || param->caseP.Y<=.010)) { //Survey data (or v tight bounds): multi-variate normal int dim=param->setP->ncar ? 3 : 2; double *mu=doubleArray(dim); double *vtemp=doubleArray(dim); double **InvSig=doubleMatrix(dim,dim);/* inverse covariance matrix*/ int i,j; for(i=0;isetP->InvSigma3[i][j]; } else { InvSig[i][j]=param->setP->InvSigma[i][j]; } } } double loglik; vtemp[0] = param->caseP.Wstar[0]; vtemp[1] = param->caseP.Wstar[1]; mu[0]= param->caseP.mu[0]; mu[1]= param->caseP.mu[1]; if (param->setP->ncar) { vtemp[2]=logit(param->caseP.X,"log-likelihood survey"); mu[0]=param->setP->pdTheta[1]; mu[1]=param->setP->pdTheta[2]; mu[2]=param->setP->pdTheta[0]; loglik=dMVN(vtemp,mu,InvSig,dim,1); } else { loglik=dMVN(vtemp,mu,InvSig,dim,1); } Free(mu); Free(vtemp); FreeMatrix(InvSig,dim); return loglik; } else { //Unknown type Rprintf("Error; unkown type: %d\n",param->caseP.dataType); return 0; } } /** ********** * Line integral helper function ********** */ /** * Returns W2star from W1star, given the following equalities * Y=XW1 + (1-X)W2 and the Wi-star=logit(Wi) * mutation: imposs is set to 1 if the equation cannot be satisfied */ double getW2starFromW1star(double X, double Y, double W1star, int* imposs) { double W1; if (W1star>30) W1=1; //prevent overflow or underflow else W1=1/(1+exp(-1*W1star)); double W2=Y/(1-X)-X*W1/(1-X); if(W2>=1 || W2<=0) *imposs=1; //impossible pair of values else W2=log(W2/(1-W2)); return W2; } /** * Returns W1star from W2star, given the following equalities * Y=XW1 + (1-X)W2 and the Wi-star=logit(Wi) * mutation: imposs is set to 1 if the equation cannot be satisfied */ double getW1starFromW2star(double X, double Y, double W2star, int* imposs) { double W2; if (W2star>30) W2=1; //prevent overflow or underflow else W2=1/(1+exp(-1*W2star)); double W1=(Y-(1-X)*W2)/X; if(W1>=1 || W1<=0) *imposs=1; //impossible pair of values else W1=log(W1/(1-W1)); return W1; } /** * Returns W1 from W2, X, and Y given * Y=XW1 + (1-X)W2 */ double getW1FromW2(double X, double Y, double W2) { return (Y-(1-X)*W2)/X; } /** * W1star(t) * W1(t)=(W1_ub - W1_lb)*t + W1_lb * mutates impossible to true if W1 is non-finite at t */ double getW1starFromT(double t, Param* param, int* imposs) { double W1=(param->caseP.Wbounds[0][1] - param->caseP.Wbounds[0][0])*t + param->caseP.Wbounds[0][0]; if (W1==1 || W1==0) *imposs=1; else W1=log(W1/(1-W1)); return W1; } /** * W2star(t) * W2(t)=(W2_lb - W2_ub)*t + W2_lb */ double getW2starFromT(double t, Param* param, int* imposs) { double W2=(param->caseP.Wbounds[1][0] - param->caseP.Wbounds[1][1])*t + param->caseP.Wbounds[1][1]; if (W2==1 || W2==0) *imposs=1; else W2=log(W2/(1-W2)); return W2; } /** * W1star'(t) * see paper for derivation: W1*(t) = (1/W1)*((w1_ub - w1_lb)/(1-W1) */ double getW1starPrimeFromT(double t, Param* param) { double m=(param->caseP.Wbounds[0][1] - param->caseP.Wbounds[0][0]); double W1=m*t + param->caseP.Wbounds[0][0]; W1=(1/W1)*(m/(1-W1)); return W1; } /** * W2star'(t) * see paper for derivation: W2*(t) = (1/W2)*((w2_lb - w2_ub)/(1-W2) */ double getW2starPrimeFromT(double t, Param* param) { double m=(param->caseP.Wbounds[1][0] - param->caseP.Wbounds[1][1]); double W2=m*t + param->caseP.Wbounds[1][1]; W2=(1/W2)*(m/(1-W2)); return W2; } /** * parameterized line integration * lower bound is t=0, upper bound is t=1 */ double paramIntegration(integr_fn f, void *ex) { double epsabs=pow(10,-11), epsrel=pow(10,-11); double result=9999, anserr=9999; int limit=100; int last, neval, ier; int lenw=5*limit; int *iwork=(int *) Calloc(limit, int); double *work=(double *)Calloc(lenw, double); double lb=0.00001; double ub=.99999; Rdqags(f, ex, &lb, &ub, &epsabs, &epsrel, &result, &anserr, &neval, &ier, &limit, &lenw, &last, iwork, work); Free(iwork); Free(work); if (ier==0) return result; else { Param* p = (Param*) ex; Rprintf("Integration error %d: Sf %d X %5g Y %5g [%5g,%5g] -> %5g +- %5g\n",ier,p->caseP.suff,p->caseP.X,p->caseP.Y,p->caseP.Wbounds[0][0],p->caseP.Wbounds[0][1],result,anserr); char ch; scanf("Hit enter to continue %c", &ch ); return result; } } /** * integrate normalizing constant and set it in param */ void setNormConst(Param* param) { param->caseP.normcT=paramIntegration(&NormConstT,(void*)param); } /** * Set the bounds on W1 and W2 in their parameter */ void setBounds(Param* param) { double X,Y,w1_lb,w1_ub,w2_lb,w2_ub; //int w1_inf,w2_inf; double tol0=0.0001; double tol1=0.9999; X=param->caseP.X; Y=param->caseP.Y; //find bounds for W1 w1_ub=(Y-(1-X)*0)/X; //W2=0 if (w1_ub>tol1) w1_ub=1; w1_lb=(Y-(1-X)*1)/X; //W2=1 if (w1_lbtol1) w2_ub=1; w2_lb=Y/(1-X)-X*1/(1-X); //W1=1 if (w2_lbcaseP.Wbounds[0][0]=w1_lb; param->caseP.Wbounds[0][1]=w1_ub; param->caseP.Wbounds[1][0]=w2_lb; param->caseP.Wbounds[1][1]=w2_ub; //param->W1_inf=w1_inf; //param->W2_inf=w2_inf; } eco/src/gibbsBase2C.c0000644000175100001440000001372713136253506014055 0ustar hornikusers#include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" /* Normal Parametric Model for 2xC (with C > 2) Tables */ void cBase2C( /*data input */ double *pdX, /* X: matrix */ double *Y, /* Y: vector */ double *pdWmin, /* lower bounds */ double *pdWmax, /* uppwer bounds */ int *pin_samp, /* sample size */ int *pin_col, /* number of columns */ /*MCMC draws */ int *reject, /* whether to use rejection sampling */ int *maxit, /* max number of iterations for rejection sampling */ int *n_gen, /* number of gibbs draws */ int *burn_in, /* number of draws to be burned in */ int *pinth, /* keep every nth draw */ int *verbose, /* 1 for output monitoring */ /* prior specification*/ int *pinu0, /* prior df parameter for InvWish */ double *pdtau0, /* prior scale parameter for Sigma */ double *mu0, /* prior mean for mu */ double *pdS0, /* prior scale for Sigma */ /* starting values */ double *mu, double *SigmaStart, /* storage */ int *parameter, /* 1 if save population parameter */ double *pdSmu, double *pdSSigma, double *pdSW ){ /* some integers */ int n_samp = *pin_samp; /* sample size */ int nth = *pinth; /* keep every pth draw */ int n_col = *pin_col; /* dimension */ /* prior parameters */ double tau0 = *pdtau0; /* prior scale for mu */ int nu0 = *pinu0; /* prior degrees of freedom */ double **S0 = doubleMatrix(n_col, n_col); /* prior scale for Sigma */ /* data */ double **X = doubleMatrix(n_samp, n_col); /* X */ double **W = doubleMatrix(n_samp, n_col); /* The W matrix */ double **Wstar = doubleMatrix(n_samp, n_col); /* logit(W) */ /* The lower and upper bounds of U = W*X/Y **/ double **minU = doubleMatrix(n_samp, n_col); double **maxU = doubleMatrix(n_samp, n_col); /* model parameters */ double **Sigma = doubleMatrix(n_col, n_col); /* The covariance matrix */ double **InvSigma = doubleMatrix(n_col, n_col); /* The inverse covariance matrix */ /* misc variables */ int i, j, k, main_loop; /* used for various loops */ int itemp; int itempM = 0; /* for mu */ int itempS = 0; /* for Sigma */ int itempW = 0; /* for W */ int itempC = 0; /* control nth draw */ int progress = 1, itempP = ftrunc((double) *n_gen/10); double dtemp, dtemp1; double *param = doubleArray(n_col); /* Dirichlet parameters */ double *dvtemp = doubleArray(n_col); /* get random seed */ GetRNGstate(); /* read X */ itemp = 0; for (j = 0; j < n_col; j++) for (i = 0; i < n_samp; i++) X[i][j] = pdX[itemp++]; /* read initial values of Sigma */ itemp = 0; for (k = 0; k < n_col; k++) for (j = 0; j < n_col; j++) Sigma[j][k] = SigmaStart[itemp++]; dinv(Sigma, n_col, InvSigma); /* compute bounds on U */ itemp = 0; for (j = 0; j < n_col; j++) for (i = 0; i < n_samp; i++) minU[i][j] = fmax2(0, pdWmin[itemp++]*X[i][j]/Y[i]); itemp = 0; for (j = 0; j < n_col; j++) for (i = 0; i < n_samp; i++) maxU[i][j] = fmin2(1, pdWmax[itemp++]*X[i][j]/Y[i]); /* initial values for W */ for (j = 0; j < n_col; j++) param[j] = 1; for (i = 0; i < n_samp; i++) { k = 0; itemp = 1; while (itemp > 0) { /* rejection sampling */ rDirich(dvtemp, param, n_col); itemp = 0; k++; for (j = 0; j < n_col; j++) if (dvtemp[j] > maxU[i][j] || dvtemp[j] < minU[i][j]) itemp++; if (itemp == 0) for (j = 0; j < n_col; j++) W[i][j] = dvtemp[j]*Y[i]/X[i][j]; if (k > *maxit) { /* if rejection sampling fails, then use midpoits of bounds sequentially */ itemp = 0; dtemp = Y[i]; dtemp1 = 1; for (j = 0; j < n_col-1; j++) { W[i][j] = 0.5*(fmax2(0,(X[i][j]/dtemp1+dtemp-1)*dtemp1/X[i][j])+ fmin2(1,dtemp*dtemp1/X[i][j])); dtemp -= W[i][j]*X[i][j]/dtemp1; dtemp1 -= X[i][j]; } W[i][n_col-1] = dtemp; } } for (j = 0; j < n_col; j++) Wstar[i][j] = log(W[i][j])-log(1-W[i][j]); } /* read the prior */ itemp = 0; for(k = 0; k < n_col; k++) for(j = 0; j < n_col; j++) S0[j][k] = pdS0[itemp++]; /*** Gibbs sampler! ***/ if (*verbose) Rprintf("Starting Gibbs sampler...\n"); for(main_loop = 0; main_loop < *n_gen; main_loop++){ /** update W, Wstar given mu, Sigma **/ for (i = 0; i < n_samp; i++){ rMH2c(W[i], X[i], Y[i], minU[i], maxU[i], mu, InvSigma, n_col, *maxit, *reject); for (j = 0; j < n_col; j++) Wstar[i][j] = log(W[i][j])-log(1-W[i][j]); } /* update mu, Sigma given wstar using effective sample of Wstar */ NIWupdate(Wstar, mu, Sigma, InvSigma, mu0, tau0, nu0, S0, n_samp, n_col); /*store Gibbs draw after burn-in and every nth draws */ if (main_loop>=*burn_in){ itempC++; if (itempC==nth){ for (j = 0; j < n_col; j++) { pdSmu[itempM++]=mu[j]; for (k = 0; k < n_col; k++) if (j <=k) pdSSigma[itempS++]=Sigma[j][k]; } for(i = 0; i < n_samp; i++) for (j = 0; j < n_col; j++) pdSW[itempW++] = W[i][j]; itempC=0; } } if (*verbose) if (itempP == main_loop) { Rprintf("%3d percent done.\n", progress*10); itempP+=ftrunc((double) *n_gen/10); progress++; R_FlushConsole(); } R_CheckUserInterrupt(); } /* end of Gibbs sampler */ if(*verbose) Rprintf("100 percent done.\n"); /** write out the random seed **/ PutRNGstate(); /* Freeing the memory */ FreeMatrix(S0, n_col); FreeMatrix(X, n_samp); FreeMatrix(W, n_samp); FreeMatrix(Wstar, n_samp); FreeMatrix(minU, n_samp); FreeMatrix(maxU, n_samp); FreeMatrix(Sigma, n_col); FreeMatrix(InvSigma, n_col); free(dvtemp); free(param); } /* main */ eco/src/sample.c0000644000175100001440000001571013136253506013262 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ #include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" /* Grid method samping from tomography line*/ void rGrid( double *Sample, /* W_i sampled from each tomography line */ double *W1gi, /* The grid lines of W1[i] */ double *W2gi, /* The grid lines of W2[i] */ int ni_grid, /* number of grids for observation i*/ double *mu, /* mean vector for normal */ double **InvSigma, /* Inverse covariance matrix for normal */ int n_dim) /* dimension of parameters */ { int j; double dtemp; double *vtemp=doubleArray(n_dim); double *prob_grid=doubleArray(ni_grid); /* density by grid */ double *prob_grid_cum=doubleArray(ni_grid); /* cumulative density by grid */ dtemp=0; for (j=0;j prob_grid_cum[j]) j++; Sample[0]=W1gi[j]; Sample[1]=W2gi[j]; free(vtemp); free(prob_grid); free(prob_grid_cum); } /* preparation for Grid */ void GridPrep( double **W1g, /* grids holder for W1 */ double **W2g, /* grids holder for W2 */ double **X, /* data: [X Y] */ double *maxW1, /* upper bound for W1 */ double *minW1, /* lower bound for W1 */ int *n_grid, /* number of grids */ int n_samp, /* sample size */ int n_step /* step size */ ) { int i, j; double dtemp; double *resid = doubleArray(n_samp); for(i=0; i (2*dtemp)) { n_grid[i]=ftrunc((maxW1[i]-minW1[i])*n_step); resid[i]=(maxW1[i]-minW1[i])-n_grid[i]*dtemp; /*if (maxW1[i]-minW1[i]==1) resid[i]=dtemp/4; */ j=0; while (j 0) { rDirich(vtemp, param, n_dim); exceed = 0; for (j = 0; j < n_dim; j++) if (vtemp[j] > maxU[j] || vtemp[j] < minU[j]) exceed++; i++; if (i > maxit) error("rMH2c: rejection algorithm failed because bounds are too tight.\n increase maxit or use gibbs sampler instead."); } } else { /* gibbs sampler */ for (j = 0; j < n_dim; j++) vtemp[j] = W[j]*X[j]/Y; for (i = 0; i < iter; i++) { dtemp = vtemp[n_dim-1]; for (j = 0; j < n_dim-1; j++) { dtemp += vtemp[j]; vtemp[j] = runif(fmax2(minU[j], dtemp-maxU[n_dim-1]), fmin2(maxU[j], dtemp-minU[n_dim-1])); dtemp -= vtemp[j]; } vtemp[n_dim-1] = dtemp; } } /* calcualte W and its logit transformation */ for (j = 0; j < n_dim; j++) { Sample[j] = vtemp[j]*Y/X[j]; vtemp[j] = log(Sample[j])-log(1-Sample[j]); vtemp1[j] = log(W[j])-log(1-W[j]); } /* acceptance ratio */ dens1 = dMVN(vtemp, mu, InvSigma, n_dim, 1); dens2 = dMVN(vtemp1, mu, InvSigma, n_dim, 1); for (j=0; j // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void cBase2C(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void cBaseeco(void *, void *, void *, void *, void *, void *, void *, void *, void *, 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 cBaseecoX(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, 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 cBaseecoZ(void *, void *, void *, void *, void *, void *, 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 cBaseRC(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 cDPeco(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, 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 cDPecoX(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, 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 cEMeco(void *, void *, void *, void *, 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 preBaseX(void *, void *, void *, void *, void *, void *, void *); extern void preDP(void *, void *, void *, void *, void *, void *, void *); extern void preDPX(void *, void *, void *, void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"cBase2C", (DL_FUNC) &cBase2C, 22}, {"cBaseeco", (DL_FUNC) &cBaseeco, 32}, {"cBaseecoX", (DL_FUNC) &cBaseecoX, 36}, {"cBaseecoZ", (DL_FUNC) &cBaseecoZ, 29}, {"cBaseRC", (DL_FUNC) &cBaseRC, 23}, {"cDPeco", (DL_FUNC) &cDPeco, 36}, {"cDPecoX", (DL_FUNC) &cDPecoX, 40}, {"cEMeco", (DL_FUNC) &cEMeco, 27}, {"preBaseX", (DL_FUNC) &preBaseX, 7}, {"preDP", (DL_FUNC) &preDP, 7}, {"preDPX", (DL_FUNC) &preDPX, 8}, {NULL, NULL, 0} }; void R_init_eco(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } eco/src/bayes.c0000644000175100001440000000410313136253506013076 0ustar hornikusers/****************************************************************** This file is a part of eco: R Package for Fitting Bayesian Models of Ecological Inference for 2x2 Tables by Kosuke Imai and Ying Lu Copyright: GPL version 2 or later. *******************************************************************/ #include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" /** Normal-InvWishart updating Y|mu, Sigma ~ N(mu, Sigma) mu|Sigma ~ N(mu0, Sigma/tau0) Sigma ~ InvWish(nu0, S0^{-1}) **/ void NIWupdate( double **Y, /* data */ double *mu, /* mean */ double **Sigma, /* variance */ double **InvSigma, /* precision */ double *mu0, /* prior mean */ double tau0, /* prior scale */ int nu0, /* prior df */ double **S0, /* prior scale */ int n_samp, /* sample size */ int n_dim) /* dimension */ { int i,j,k; double *Ybar = doubleArray(n_dim); double *mun = doubleArray(n_dim); double **Sn = doubleMatrix(n_dim, n_dim); double **mtemp = doubleMatrix(n_dim, n_dim); /*read data */ for (j=0; j #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" /* Conditional Prediction for Normal Parametric Model for 2x2 Tables */ void preBaseX( double *X, /* data X */ double *pdmu, double *pdSigma, int *pin_samp, int *pin_draw, int *verbose, /* 1 for output monitoring */ double *pdStore ){ /* some integers */ int n_samp = *pin_samp; /* sample size */ int n_draw = *pin_draw; /* sample size of survey data */ int n_dim = 2; double *mu = doubleArray(n_dim); /* The mean */ double *Wstar = doubleArray(n_dim); double **Sigma = doubleMatrix(n_dim, n_dim); /* The covariance matrix */ /* misc variables */ int i, j, main_loop; /* used for various loops */ int itemp=0; int itempM=0; int itempS=0; int progress = 1, itempP = ftrunc((double) n_draw/10); /* get random seed */ GetRNGstate(); for(main_loop=0; main_loop #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" void cDPecoX( /*data input */ double *pdX, /* data (X, Y) */ int *pin_samp, /* sample size */ /*MCMC draws */ int *n_gen, /* number of gibbs draws */ int *burn_in, /* number of draws to be burned in */ int *pinth, /* keep every nth draw */ int *verbose, /* 1 for output monitoring */ /* prior specification*/ int *pinu0, /* prior df parameter for InvWish */ double *pdtau0, /* prior scale parameter for Sigma under G0*/ double *mu0, /* prior mean for mu under G0 (3x1) */ double *pdS0, /* prior scale for Sigma (3x3) */ double *alpha0, /* precision parameter, can be fixed or updated*/ int *pinUpdate, /* 1 if alpha gets updated */ double *pda0, double *pdb0, /* prior for alpha if alpha updated*/ /*incorporating survey data */ int *survey, /*1 if survey data available(set of W_1, W_2,X)*/ /*0 otherwise*/ int *sur_samp, /*sample size of survey data*/ double *sur_W, /*set of known W_1, W_2 */ /*incorporating homeogenous areas */ int *x1, /* 1 if X=1 type areas available W_1 known, W_2 unknown */ int *sampx1, /* number X=1 type areas */ double *x1_W1, /* values of W_1 for X1 type areas */ int *x0, /* 1 if X=0 type areas available W_2 known, W_1 unknown */ int *sampx0, /* number X=0 type areas */ double *x0_W2, /* values of W_2 for X0 type areas */ /* bounds fo W1 */ double *minW1, double *maxW1, /* flags */ int *parameter, /* 1 if save population parameter */ int *Grid, /* 1 if Grid algorithm is used; 0 for Metropolis */ /* storage for Gibbs draws of mu/sigmat*/ double *pdSMu0, double *pdSMu1, double *pdSMu2, double *pdSSig00, double *pdSSig01, double *pdSSig02, double *pdSSig11, double *pdSSig12, double *pdSSig22, /* storage for Gibbs draws of W*/ double *pdSW1, double *pdSW2, /* storage for Gibbs draws of alpha */ double *pdSa, /* storage for nstar at each Gibbs draw*/ int *pdSn ){ /*some integers */ int n_samp = *pin_samp; /* sample size */ int s_samp = *sur_samp; /* sample size of survey data */ int x1_samp = *sampx1; /* sample size for X=1 */ int x0_samp = *sampx0; /* sample size for X=0 */ int t_samp = n_samp+x1_samp+x0_samp+s_samp; /* total sample size */ int nth = *pinth; /* keep every nth draw */ int n_dim = 2; /* dimension */ int n_step=1000; /* The default size of grid step */ /*prior parameters */ double tau0 = *pdtau0; /* prior scale */ int nu0 = *pinu0; /* prior degree of freedom*/ double **S0 = doubleMatrix(n_dim+1,n_dim+1);/*The prior S parameter for InvWish*/ double alpha = *alpha0; /* precision parameter*/ double a0 = *pda0, b0 = *pdb0; /* hyperprior for alpha */ /* data */ double **X = doubleMatrix(n_samp,n_dim); /* The Y and covariates */ double **W = doubleMatrix(t_samp,n_dim); /* The W1 and W2 matrix */ double **Wstar = doubleMatrix(t_samp,(n_dim+1)); /* The pseudo data */ double **S_W = doubleMatrix(s_samp,n_dim+1); /* The known W1 and W2,X */ double **S_Wstar = doubleMatrix(s_samp,n_dim+1);/* The logit transformed S_W*/ /* grids */ double **W1g = doubleMatrix(n_samp, n_step); /* grids for W1 */ double **W2g = doubleMatrix(n_samp, n_step); /* grids for W2 */ int *n_grid = intArray(n_samp); /* grids size */ /* Model parameters */ /* Dirichlet variables */ double **mu = doubleMatrix(t_samp,(n_dim+1)); /* mean matrix */ double ***Sigma = doubleMatrix3D(t_samp,(n_dim+1),(n_dim+1)); /*covarince matrix*/ double ***InvSigma = doubleMatrix3D(t_samp,(n_dim+1),(n_dim+1)); /* inv of Sigma*/ /*conditional distribution parameter */ double **Sigma_w=doubleMatrix(n_dim,n_dim); double **InvSigma_w=doubleMatrix(n_dim,n_dim); double *mu_w=doubleArray(n_dim); int nstar; /* # clusters with distict theta values */ int *C = intArray(t_samp); /* vector of cluster membership */ double *q = doubleArray(t_samp); /* Weights of posterior of Dirichlet */ double *qq = doubleArray(t_samp); /* cumulative weight vector of q */ double **S_tvt = doubleMatrix((n_dim+1),(n_dim+1)); /* S paramter for BVT in q0 */ /* variables defined in remixing step: cycle through all clusters */ double **Wstarmix = doubleMatrix(t_samp,(n_dim+1)); /*data matrix used */ double *mu_mix = doubleArray((n_dim+1)); /*updated MEAN parameter */ double **Sigma_mix = doubleMatrix((n_dim+1),(n_dim+1)); /*updated VAR parameter */ double **InvSigma_mix = doubleMatrix((n_dim+1),(n_dim+1)); /* Inv of Sigma_mix */ int nj; /* record # of obs in each cluster */ int *sortC = intArray(t_samp); /* record (sorted)original obs id */ int *indexC = intArray(t_samp); /* record original obs id */ int *label = intArray(t_samp); /* store index values */ /* misc variables */ int i, j, k, l, main_loop; /* used for various loops */ int itemp; int itempA=0; /* counter for alpha */ int itempS=0; /* counter for storage */ int itempC=0; /* counter to control nth draw */ int progress = 1, itempP = ftrunc((double) *n_gen/10); double dtemp, dtemp1, dtemp2; double *vtemp = doubleArray((n_dim+1)); double **mtemp = doubleMatrix((n_dim+1),(n_dim+1)); double **mtemp1 = doubleMatrix((n_dim+1),(n_dim+1)); double **onedata = doubleMatrix(1, (n_dim+1)); /* get random seed */ GetRNGstate(); /* read priors under G0*/ itemp=0; for(k=0;k<(n_dim+1);k++) for(j=0;j<(n_dim+1);j++) S0[j][k]=pdS0[itemp++]; /* read the data set */ itemp = 0; for (j = 0; j < n_dim; j++) for (i = 0; i < n_samp; i++) X[i][j] = pdX[itemp++]; /*Intialize W, Wsatr for n_samp */ for (i=0; i< n_samp; i++) { if (X[i][1]!=0 && X[i][1]!=1) { W[i][0]=runif(minW1[i], maxW1[i]); W[i][1]=(X[i][1]-X[i][0]*W[i][0])/(1-X[i][0]); } if (X[i][1]==0) for (j=0; j=n_samp && i<(n_samp+x1_samp)) { dtemp=mu_w[1]+Sigma_w[0][1]/Sigma_w[0][0]*(Wstar[i][0]-mu_w[0]); dtemp1=Sigma_w[1][1]*(1-Sigma_w[0][1]*Sigma_w[0][1]/(Sigma_w[0][0]*Sigma_w[1][1])); Wstar[i][1]=norm_rand()*sqrt(dtemp1)+dtemp; W[i][1]=exp(Wstar[i][1])/(1+exp(Wstar[i][1])); } /*update W1 given W2, mu_ord and Sigma_ord in x0 homeogeneous areas */ if (*x0==1 && i>=(n_samp+x1_samp) && i<(n_samp+x1_samp+x0_samp)) { dtemp=mu_w[0]+Sigma_w[0][1]/Sigma_w[1][1]*(Wstar[i][1]-mu_w[1]); dtemp1=Sigma_w[0][0]*(1-Sigma_w[0][1]*Sigma_w[0][1]/(Sigma_w[0][0]*Sigma_w[1][1])); Wstar[i][0]=norm_rand()*sqrt(dtemp1)+dtemp; W[i][0]=exp(Wstar[i][0])/(1+exp(Wstar[i][0])); } } /**updating mu, Sigma given Wstar uisng effective sample size t_samp**/ for (i=0; i qq[j]) j++; /** Dirichlet update Sigma_i, mu_i|Sigma_i **/ if (j==i){ onedata[0][0] = Wstar[i][0]; onedata[0][1] = Wstar[i][1]; onedata[0][2] = Wstar[i][2]; NIWupdate(onedata, mu[i], Sigma[i], InvSigma[i], mu0, tau0,nu0, S0, 1, n_dim+1); C[i]=nstar; nstar++; } else { /*1. mu_i=mu_j, Sigma_i=Sigma_j*/ /*2. update C[i]=C[j] */ for(k=0;k<=n_dim;k++) { mu[i][k]=mu[j][k]; for(l=0;l<=n_dim;l++) { Sigma[i][k][l]=Sigma[j][k][l]; InvSigma[i][k][l]=InvSigma[j][k][l]; } } C[i]=C[j]; } sortC[i]=C[i]; } /* end of i loop*/ /** remixing step using effective sample**/ for(i=0;i=*burn_in) { itempC++; if (itempC==nth){ if(*pinUpdate) { pdSa[itempA]=alpha; pdSn[itempA]=nstar; itempA++; } for(i=0; i<(n_samp+x1_samp+x0_samp); i++) { pdSMu0[itempS]=mu[i][0]; pdSMu1[itempS]=mu[i][1]; pdSMu2[itempS]=mu[i][2]; pdSSig00[itempS]=Sigma[i][0][0]; pdSSig01[itempS]=Sigma[i][0][1]; pdSSig02[itempS]=Sigma[i][0][2]; pdSSig11[itempS]=Sigma[i][1][1]; pdSSig12[itempS]=Sigma[i][1][2]; pdSSig22[itempS]=Sigma[i][2][2]; pdSW1[itempS]=W[i][0]; pdSW2[itempS]=W[i][1]; itempS++; } itempC=0; } } if (*verbose) if (itempP == main_loop) { Rprintf("%3d percent done.\n", progress*10); itempP+=ftrunc((double) *n_gen/10); progress++; R_FlushConsole(); } } /*end of MCMC for DP*/ if (*verbose) Rprintf("100 percent done.\n"); /** write out the random seed **/ PutRNGstate(); /* Freeing the memory */ FreeMatrix(S0, n_dim+1); FreeMatrix(X, n_samp); FreeMatrix(W, t_samp); FreeMatrix(Wstar, t_samp); FreeMatrix(S_W, s_samp); FreeMatrix(S_Wstar, s_samp); FreeMatrix(W1g, n_samp); FreeMatrix(W2g, n_samp); free(n_grid); FreeMatrix(mu, t_samp); Free3DMatrix(Sigma, t_samp,n_dim+1); Free3DMatrix(InvSigma, t_samp, n_dim+1); free(mu_w); FreeMatrix(Sigma_w, n_dim); FreeMatrix(InvSigma_w, n_dim); free(C); free(q); free(qq); FreeMatrix(S_tvt, n_dim+1); FreeMatrix(Wstarmix, t_samp); free(mu_mix); FreeMatrix(Sigma_mix, n_dim+1); FreeMatrix(InvSigma_mix, n_dim+1); free(sortC); free(indexC); free(label); free(vtemp); FreeMatrix(mtemp, n_dim+1); FreeMatrix(mtemp1, n_dim+1); free(onedata); } /* main */ eco/src/preDPX.c0000644000175100001440000000431313136253506013140 0ustar hornikusers#include #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" /* Conditional Prediction for Nonparametric Model for 2x2 Tables */ void preDPX( double *pdmu, double *pdSigma, double *X, int *pin_samp, int *pin_draw, int *pin_dim, int *verbose, /* 1 for output monitoring */ double *pdStore ){ /* some integers */ int n_samp = *pin_samp; /* sample size */ int n_draw = *pin_draw; /* sample size of survey data */ int n_dim = *pin_dim; /* dimension */ double *mu = doubleArray(n_dim); /* The mean */ double *Wstar = doubleArray(n_dim); double **Sigma = doubleMatrix(n_dim, n_dim); /* The covariance matrix */ /* misc variables */ int i, j, main_loop; /* used for various loops */ int itemp = 0; int itempM = 0; int itempS = 0; int progress = 1, itempP = ftrunc((double) n_draw/10); /* get random seed */ GetRNGstate(); for(main_loop=0; main_loop #include #include #include #include #include #include "vector.h" #include "subroutines.h" #include "rand.h" #include "bayes.h" #include "sample.h" /* Normal Parametric Model for RxC (with R >= 2, C >= 2) Tables */ void cBaseRC( /*data input */ double *pdX, /* X */ double *pdY, /* Y */ double *pdWmin, /* lower bounds */ double *pdWmax, /* uppwer bounds */ int *pin_samp, /* sample size */ int *pin_col, /* number of columns */ int *pin_row, /* number of rows */ /*MCMC draws */ int *reject, /* whether to use rejection sampling */ int *maxit, /* max number of iterations for rejection sampling */ int *n_gen, /* number of gibbs draws */ int *burn_in, /* number of draws to be burned in */ int *pinth, /* keep every nth draw */ int *verbose, /* 1 for output monitoring */ /* prior specification*/ int *pinu0, /* prior df parameter for InvWish */ double *pdtau0, /* prior scale parameter for Sigma */ double *mu0, /* prior mean for mu */ double *pdS0, /* prior scale for Sigma */ /* starting values */ double *pdMu, double *pdSigma, /* storage */ int *parameter, /* 1 if save population parameter */ double *pdSmu, double *pdSSigma, double *pdSW ){ /* some integers */ int n_samp = *pin_samp; /* sample size */ int nth = *pinth; /* keep every pth draw */ int n_col = *pin_col; /* number of columns */ int n_dim = *pin_row-1; /* number of rows - 1 */ /* prior parameters */ double tau0 = *pdtau0; /* prior scale */ int nu0 = *pinu0; /* prior degrees of freedom */ double **S0 = doubleMatrix(n_col, n_col); /* prior scale for InvWish */ /* data */ double **Y = doubleMatrix(n_samp, n_dim); /* Y */ double **X = doubleMatrix(n_samp, n_col); /* X */ double ***W = doubleMatrix3D(n_samp, n_dim, n_col); /* W */ double ***Wstar = doubleMatrix3D(n_col, n_samp, n_dim); /* logratio(W) */ double **Wsum = doubleMatrix(n_samp, n_col); /* sum_{r=1}^{R-1} W_{irc} */ double **SWstar = doubleMatrix(n_col, n_dim); /* The lower and upper bounds of U = W*X/Y **/ double ***minU = doubleMatrix3D(n_samp, n_dim, n_col); double *maxU = doubleArray(n_col); /* model parameters */ double **mu = doubleMatrix(n_col, n_dim); /* mean */ double ***Sigma = doubleMatrix3D(n_col, n_dim, n_dim); /* covariance */ double ***InvSigma = doubleMatrix3D(n_col, n_dim, n_dim); /* inverse */ /* misc variables */ int i, j, k, l, main_loop; /* used for various loops */ int itemp, counter; int itempM = 0; /* for mu */ int itempS = 0; /* for Sigma */ int itempW = 0; /* for W */ int itempC = 0; /* control nth draw */ int progress = 1, itempP = ftrunc((double) *n_gen/10); double dtemp, dtemp1; double *param = doubleArray(n_col); /* Dirichlet parameters */ double *dvtemp = doubleArray(n_col); double *dvtemp1 = doubleArray(n_col); /* get random seed */ GetRNGstate(); /* read X */ itemp = 0; for (k = 0; k < n_col; k++) for (i = 0; i < n_samp; i++) X[i][k] = pdX[itemp++]; /* read Y */ itemp = 0; for (j = 0; j < n_dim; j++) for (i = 0; i < n_samp; i++) Y[i][j] = pdY[itemp++]; /* compute bounds on U */ itemp = 0; for (k = 0; k < n_col; k++) for (j = 0; j < n_dim; j++) for (i = 0; i < n_samp; i++) minU[i][j][k] = fmax2(0, (X[i][k]+Y[i][j]-1)/Y[i][j]); /* initial values for mu and Sigma */ itemp = 0; for (k = 0; k < n_col; k++) for (j = 0; j < n_dim; j++) mu[k][j] = pdMu[itemp++]; itemp = 0; for (k = 0; k < n_col; k++) for (j = 0; j < n_dim; j++) for (i = 0; i < n_dim; i++) Sigma[k][j][i] = pdSigma[itemp++]; for (k = 0; k < n_col; k++) dinv(Sigma[k], n_dim, InvSigma[k]); /* initial values for W */ for (k = 0; k < n_col; k++) param[k] = 1.0; for (i = 0; i < n_samp; i++) { for (k = 0; k < n_col; k++) Wsum[i][k] = 0.0; for (j = 0; j < n_dim; j++) { counter = 0; itemp = 1; while (itemp > 0) { /* first try rejection sampling */ rDirich(dvtemp, param, n_col); itemp = 0; for (k = 0; k < n_col; k++) { if (dvtemp[k] < minU[i][j][k] || dvtemp[k] > fmin2(1, X[i][k]*(1-Wsum[i][k])/Y[i][j])) itemp++; } if (itemp < 1) for (k = 0; k < n_col; k++) { W[i][j][k] = dvtemp[k]*Y[i][j]/X[i][k]; Wsum[i][k] += W[i][j][k]; } counter++; if (counter > *maxit && itemp > 0) { /* if rejection sampling fails, then use midpoints of bounds */ itemp = 0; dtemp = Y[i][j]; dtemp1 = 1; for (k = 0; k < n_col-1; k++) { W[i][j][k] = 0.25*(fmax2(0,(X[i][k]/dtemp1+dtemp-1)*dtemp1/X[i][k])+ fmin2(1-Wsum[i][k],dtemp*dtemp1/X[i][k])); dtemp -= W[i][j][k]*X[i][k]/dtemp1; dtemp1 -= X[i][k]; Wsum[i][k] += W[i][j][k]; } W[i][j][n_col-1] = dtemp; Wsum[i][n_col-1] += dtemp; } R_CheckUserInterrupt(); } for (l = 0; l < n_dim; l++) for (k = 0; k < n_col; k++) Wstar[k][i][l] = log(W[i][l][k])-log(1-Wsum[i][k]); } } /* read the prior */ itemp = 0; for(k = 0; k < n_dim; k++) for(j = 0; j < n_dim; j++) S0[j][k] = pdS0[itemp++]; /*** Gibbs sampler! ***/ if (*verbose) Rprintf("Starting Gibbs sampler...\n"); for(main_loop = 0; main_loop < *n_gen; main_loop++){ /** update W, Wstar given mu, Sigma **/ for (i = 0; i < n_samp; i++) { /* sampling W through Metropolis Step for each row */ for (j = 0; j < n_dim; j++) { /* computing upper bounds for U */ for (k = 0; k < n_col; k++) { Wsum[i][k] -= W[i][j][k]; maxU[k] = fmin2(1, X[i][k]*(1-Wsum[i][k])/Y[i][j]); } /** MH step **/ /* Sample a candidate draw of W from truncated Dirichlet */ l = 0; itemp = 1; while (itemp > 0) { rDirich(dvtemp, param, n_col); itemp = 0; for (k = 0; k < n_col; k++) if (dvtemp[k] > maxU[k] || dvtemp[k] < minU[i][j][k]) itemp++; l++; if (l > *maxit) error("rejection algorithm failed because bounds are too tight.\n increase maxit or use gibbs sampler instead."); } /* get W and its log-ratio transformation */ for (k = 0; k < n_col; k++) { dvtemp[k] = dvtemp[k]*Y[i][j]/X[i][k]; dvtemp1[k] = Wsum[i][k]+dvtemp[k]; } for (k = 0; k < n_col; k++) for (l = 0; l < n_dim; l++) if (l == j) SWstar[k][l] = log(dvtemp[k])-log(1-dvtemp1[k]); else SWstar[k][l] = log(W[i][j][k])-log(1-dvtemp1[k]); /* computing acceptance ratio */ dtemp = 0; dtemp1 = 0; for (k= 0; k < n_col; k++) { dtemp += dMVN(SWstar[k], mu[k], InvSigma[k], n_dim, 1); dtemp1 += dMVN(Wstar[k][i], mu[k], InvSigma[k], n_dim, 1); dtemp -= log(dvtemp[k]); dtemp1 -= log(W[i][j][k]); } if (unif_rand() < fmin2(1, exp(dtemp-dtemp1))) for (k = 0; k < n_col; k++) W[i][j][k] = dvtemp[k]; /* updating Wsum and Wstar with new draws */ for (k = 0; k < n_col; k++) { Wsum[i][k] += W[i][j][k]; for (l = 0; l < n_dim; l++) Wstar[k][i][l] = log(W[i][l][k])-log(1-Wsum[i][k]); } } } /* update mu, Sigma given wstar using effective sample of Wstar */ for (k = 0; k < n_col; k++) NIWupdate(Wstar[k], mu[k], Sigma[k], InvSigma[k], mu0, tau0, nu0, S0, n_samp, n_dim); /*store Gibbs draw after burn-in and every nth draws */ if (main_loop >= *burn_in){ itempC++; if (itempC==nth){ for (k = 0; k < n_col; k++) for (j = 0; j < n_dim; j++) { pdSmu[itempM++]=mu[k][j]; for (i = 0; i < n_dim; i++) if (j <= i) pdSSigma[itempS++]=Sigma[k][j][i]; } for(i = 0; i < n_samp; i++) for (k = 0; k < n_col; k++) for (j = 0; j < n_dim; j++) pdSW[itempW++] = W[i][j][k]; itempC=0; } } if (*verbose) if (itempP == main_loop) { Rprintf("%3d percent done.\n", progress*10); itempP+=ftrunc((double) *n_gen/10); progress++; R_FlushConsole(); } R_CheckUserInterrupt(); } /* end of Gibbs sampler */ if (*verbose) Rprintf("100 percent done.\n"); /** write out the random seed **/ PutRNGstate(); /* Freeing the memory */ FreeMatrix(S0, n_col); FreeMatrix(X, n_samp); FreeMatrix(Y, n_samp); Free3DMatrix(W, n_samp, n_dim); Free3DMatrix(Wstar, n_col, n_samp); FreeMatrix(Wsum, n_samp); Free3DMatrix(minU, n_samp, n_dim); FreeMatrix(mu, n_col); Free3DMatrix(Sigma, n_col, n_dim); Free3DMatrix(InvSigma, n_col, n_dim); free(param); free(dvtemp); } /* main */ eco/NAMESPACE0000644000175100001440000000202113104457061012251 0ustar hornikusersuseDynLib(eco, .registration = TRUE) importFrom(MASS, mvrnorm) importFrom("stats", "as.formula", "coef", "model.frame", "model.matrix", "model.response", "predict", "quantile", "sd", "terms", "weighted.mean") importFrom("utils", "packageDescription") export(eco, ecoBD, ecoNP, ecoML, summary.eco, summary.ecoNP, summary.ecoML, print.summary.eco, print.summary.ecoNP, print.summary.ecoML, predict.eco, predict.ecoX, predict.ecoNP, predict.ecoNPX, Qfun) S3method(varcov, eco) S3method(varcov, ecoNP) S3method(coef, eco) S3method(coef, ecoNP) S3method(predict, eco) S3method(predict, ecoX) S3method(predict, ecoNP) S3method(predict, ecoNPX) S3method(summary, eco) S3method(summary, ecoNP) S3method(summary, ecoML) S3method(summary, predict.eco) S3method(print, eco) S3method(print, ecoML) S3method(print, ecoBD) S3method(print, summary.eco) S3method(print, summary.ecoNP) S3method(print, summary.ecoML) S3method(print, summary.predict.eco) eco/data/0000755000175100001440000000000013136253506011753 5ustar hornikuserseco/data/reg.txt.gz0000644000175100001440000001137713136253506013721 0ustar hornikusers‹mšÛ™ä¸Ž„ßÇ Yp>Þ/NìëÙõß‘ý)e÷TæôdeI €ÿûüßó?ÏóóßòOúOi³?é?kñ¿–øá—î?ƒ{1çl\™—¿ìÛÞôzZÓ Ü›íŠÚ{ÊÕî[iöµÒzêØºd4û¶ÖÕûÒ`«¥ncñEš¥ç\¸KMslûÓ.«Ïlç’QúØzú,iÌÔžµ»ß’{]mŸDN©´f‹Úc•Üóx “õ‰fÿ‰é{µYÐðŸ©ë’Ï¢ì‡ûÌFߟÖHŒŸô¨¹Ú¶)ìúc‘Äœs’%giÏñä—øJg\¨_³æb‹É Pc;ìáLA–VòÒ–q].\U–®Zi4ÖK+µ–¹5‘¶riÏ8£Í]×ßÚ®mMƒAžLµŒjß–:OyæøsCfM¹¯Yõa‹Z¯IJ)\3ͤs¥ZRWüÉ5çÑêÒ$0ô(BÛ>ë.¶„¶ÀÛªÏn3¬x¸fÚÀî¸Ûaà‘mØa7BXýƒÔÏÆ¿¤›éÒˆ´âÖ© &óµölµoÛéÝK]ü+³ÇÇ’?¬K?2RñŸ'ûœ^ôØÜ_Ìax½žî(ŽmçÀ,Íë×»O­¸÷¬eÊÒÀœöcO÷ŸõL7úµsjmÊv Ï-@æUǬ`~ÿù¬+Æ3ûœ™Öä6û[«Ã~Ã#âA½döñào0[y«AÉ eN˜Yøþ1Ð6@¥ê/4ÆTµŸìO¬{.è1áë(¶0w'+6îÉ—Âëí+ã‡öÀž6ðpÞšë¬O̰ŸÁ4múSÒa³¶Æ?Únx`â.‡éxr•ƒbf¾¯îÞ|ÅeÔTFÛOë5&7a‘âÏ*;7c;<¸ {¶pÑG/]þ.¯©æc=ï«Û_Üðh¿³¥Ò÷t¦\öšÏtoƒè[Þ5VˆÀ¢º®ïÒpä„ÐË‚„uó]üRdÛ¸ÜÑð¯š}‰}ç Až qµµœŸ77‡¹é.xÝf¸"8ÒÌvgrææÇ÷Ž!/e-±Ï*#-‹G&@ðìà§ÐüA®WgfºcÔµ±b2—vÍ󌺖èª8Ý{´´¿XÂ*›àÏ1ê0œºÁS$ðZ "V2ºÂˆÿj‰qxÂù ÎuŸ­ìh±øÕGÀ‡º™^Á‡ù¸À~}p ŸEw²‹+ÁÝf†v%»›=àîp`Q›¯ÓbtQþh€NÆš{œ³örˬnA®ñ4SźrÖÚð,ã“ÉyަýX|ÏÆ5±#ß —ÓöÀj†«âû£äõ­ qFÀ'Y.c„à,Ð6©»…¡û"ߺGZ&佤a¥Ÿls(Æe”V[MŽhÝsÙâe&, ’ÐTQëx§¤egÁAc•"ó|Uy0éÒð“v—&¹umÇX˜&$G9²™QTLêÛþ³_Ym"‚9”ŠTI‡ž ¤éßÕÇ'Ö™ÿˆ$ob ý^jPÖ/¦Æ¢Ž i"ãÌÿ¶Ÿ-©*µ5«8#é£(/Tz'B‚ÖÛ—¨¢¤¢äA²M's@=Ç—äO±¯Ÿ¤‚Ô°{„­[co‘›'"ƒ2{k~.©\#CôݾÅòÃø€Ý)¿5þÖ`ÝA2ƒR™š0‘yXÍ7Š pNafÚ%rRLÝ¡'H©Ä§âÙ”]õjûáSvšñ·ž£¼"³··?³çåÂ}DT;å•OÈe.PÇñ7xI¿%/u£PŠM‘·Ï¾vÒÞ˜²œŠÖ‘š²9ÁÙ{È®jo¸ÇýgšA‹gxVHô}m­ÀfÉ!`Ú“=£ÌIïV½-¨½}—Å¡^Wu6}ò©4~È Í„³ËkÜé“«D5F,§îwÇ üì«ò†­» k­e‰ù¢ô†£N—¯XQ»Óˆn„¦ÎE‹N–ŠÝHžèozôôü‡Ì*‚gÛ/ËC\5j †Ÿ.”³åmR0×òÛS ¥ñ£”‹Ç¤’eëœò¡·¸ðC.ñüœÙ¤¨­•n”vô—ž#ÿ³þ¼ÂôP…,\ÉU¹ýíu½-¦e]°Ùܵdì€MÙ®e nÆÞQ3ñPW5ÏOÝP_ú¶J~+¶œY½J´©UyŠé3œ°¼*¨t^1f#FšUìé‚}§eXóàùÖJÚ‘Ö…uÒs©>~K»p ògÒnû ¸î %î†Éý-LÉ¿C|^v´â“ÞÆ}[·*/Ëí¼ì]'xýb¤1÷„eY&·Ç®Í`õëÕ§ê=’”Þùiä굦:ÎY‡7Cj e,S–p"ÅïøX¢,3ߌv›"þGšœdHÒ¨WoQ‚¬ò &j(q®g[¬ˆÖ­—ÊiO‹l€•éíϳdOv’|ؽ.ñ<<¹‡ðígQ:ò`ÉMu…4¡Îág ë ×·YÕ[>ZÙÎOÄ9?ô„‰¼“$Y4bÕ^ÁËDžXNÖC8FßÅ‹?@œáçݦ7ˆÿ+Šç J÷pÑîóAñ÷Љ}W=¡W™õØ«ÇòšmŸ¢ã÷i§²8ƒâ¼7‰=WÆûnšz*ïùSšj,F×[VFSjüLù0Ðã]mu‚ª\%yŬ\oŸêˆk£·â·•çsýèJ€ÐoE[‡ªMžá Ó0½ÝB}t'£N-U;—æûL`¨VûØç¬Æ<äŒ.k!Iò“AMïoXKßN¡D±$GJ.0»VÌóÃ)Q~RÌOMÉŽˆÀP2¾-Ø*ªùtœ:AÚÚkB6îâ §èz>:ÍÇ•Äà|êk‘ëˆcDlÞÒ´­r6-¶æ“¹ŸÆ  &5Ä8Fè3Ôj…G<¾þé]Ë΢AAªÊúÙ =Ó?ßS‘ADí:??.çIb¦’Lo†¨nâaÖO²Ø0ǰóF'`°×öæ¦Iòì§ÐÐúxš\„ˆÛÒä?•ß`KÆ$2ÞçÅdnÄ‚[)×ô½6< Z{.Ÿ6TRÉï죴/»ÜN üƒ…â+MVÀW܈#íœ~ŒÓTg6Jܧ©6%ˆr;<5¢\]ï9¼è\yiný*MGzá2Òf?ºiîÊv9ÌÊ[çc ‘ÂÀ&ƒ<Ì5couYX³ ýÿÓ’Çhî¤Ø-Ù”Õ‰ÝÇxõ´€•Ѹ _ýKxW&E¤øIõkSÄ!6Ì’,3Š‚vÞrÎÓn8º­¼ þ=ìpìr„ˆ¶/obr.ž3'ɘ‹É%mR/o™Xç¢VYë>§5ê|ùD3ïlÖCöÑó÷xõÀ†õò¢ŸdÑi‹ú´|‡=¥E!7º¦äžfî'÷Ž(ä)+áj:r]Òà16Ò°ÔéecWa×Ö.½3øÞ«è¦9\ñ„ÿrOÿéeøèTyÂúÄÉòÉs¬»ãú8 [žà¾Î-Õ¹í=-`V¼ñÊ*e¦ãôÌ5¬kçF‰ÂÞñ@¿-ƒö‘>y!ÂÎTïãü¤Fj->?‰ êÁΊhYd_ÙŽ~íS¿‰#Jn¬mm²~KtëTk´YØ4Bfó°JŸxbõRǨ„ñ¡uüz÷ìlj«¢{MÒééjd3çTÙ=Y#§¾€xUk‹úÌâĪ=ÿóÿNÐR/eco/data/housep88.txt.gz0000644000175100001440000002163413136253506014624 0ustar hornikusers‹UœK’¬»m„çwµß±=°'GHyÿq~™ìs«Ã!ë¨ýH$`ýßçߟÿùü×ÿþÇ¿>ÿùßÿü×_å{·1ÚžçSþ1ç*mö³>m”=·~tÇ9»ïU?µT™¯¾ê©kvýnÜÚz[e|ZŸ{Ìçœw¬ÝeÞ0_ã¶Óë¶ù¼·ýië‹'ʼ¯6W¿Cæ]æm÷ÓG½ó¶×é½éémœÍn™}Ü¢_×20g5½–‰yÙ§Ô¶õðÛüy·Ý1õÑ<|ʺóä¶®—®=ë­eÈÊksÔVÛ”ùò›ê1³-/½¯~ŽþèÓKé»|ê§y;zßzÈ<^ð¸ú•^öÓfé=FlBÝmkÓŠ·øtÙתßõÒÖàƒ÷i§²ˆîgÞë÷×G¯¹µyŸVWkK?Úú/}Þ¸²l[ê ö¥rl£o>fŸ:³±»tmÔ™ìÔÜ}j£;æóäŽÖÇIÉ||=X?Ü¥^6Uá%ì»n=¶dS×ÝÚ®5½bÊÔ®6`לÁ­ò›®céÞÔŸw“i³u4mì¾XÕ^MÿW6ï¶eyÊÐY×í¥_¹NhûÁ|À,ìÙùzîÐ]3†kqÒ{.ýM=¬àÚ#×ÖçØgíS+®óÓNa§õ¸Züá§î5Í4›ž¹µ|øšSî¦8éÕ^p—ôÈDÿžz÷2‹vW+(1×öÛúgø€G;­žbÏê§íY=zúY½;†öQPè8‡OYgºv]{8(:[:äÓw»ÝÕ/uþ»~¦ŸÞöÙ2¾Ëû¡ã(S.ßôqwzã:«_Wæ~ºÞS›uíæ¬«%üuªö£uïi£}VÂϪ˜nÇA±µš!·V|¶–[ËëZ^àbk[eÔýô=µ9séñEÕìwrCÐùÔÄxqåæ˜W­ây–üg#»ö±iƒ1gñ“x=e²Ô®ÇŸ£ÕrÚ:~¼Qµö„Á«½€Ÿ?ªV'ÿ#\µn;·`L5±7À(¼pvBEÀˆ€ ´÷RèR§"{GC]rÏîÇë TŸÕ_:uíÔÀœhÖjyÇG¥¥ "@ò›Þòº­Nka¿¿ÂrN…©\äS0o'ô¶Þdlíj:”öÀnÎC\ hš}L¿ÒÁ.?š°Ð>+fb\vë¬VýÿÃä•£béŽvg•Mv^>QäGÚ˜*ö› ÁKì!aV¿>¨5³î¶jµ[ Ó…lÊ Ø7Ûëñ X?^»xîÕG鬇áív™2Œí9XÅßP^°ŸÉ»±bV½QW˜ Ì&ôÇžƒÕk)hš·S›£ðžøqUƱã•)—5˜¬ƒ:û½–©ÇsUî[½¶®Žc{;& ]*Å’‚•£PÞ Š i• +Ø;ñÉ­ûNµ®|n,#ž°õý¨ ‰ÑIrÒ“äñZ¿^±{?µ2Ž~TÓgÊ“ôvör-CÛ£õTÁ‰íñÙ¢¥mì¿pzAwÎEÈjÀ³eÎÚ¿r^%¹I¸ΨÚ}f ~£´`WN~ø4m²A¶W»¤7ÐþH:šò ~¹ä‹£öz¤qé4ÅÞé~´ýQAºô'Ð#þ 1±¡˜B.$Ë󸃀ÀùHNs7L^6 '–±ŠÍ&ÉÉ8MEH ˜™L*ÖÙÎw"Ëc,Ò£Àÿ/?“gu?_a!”>¤¢ì·è¿Þ{³9ˆ^aƒÆ,EÎ {P"Þ‰¢÷e¿ûÅãdD tŽ}˜]VYŽiÿ:š"F6x³oó_+T·¡¢sˆ[/ÏÈï”…‰zòXxÑMtJgš†¾÷Mª4ª<[©Lk†‡… Ê_H$5ìŽ2þç=ÑêÝH®‡¦ ÒI/H½ì“/%ñ©l­j 6£´{j m ››Áˆz(o–Óñ~…([دS·–£ã†È~¾ú®A£p[¨.Ò¢·%–ü|źZÅOÔê?Å…­5]\@ëõðé'¹ÆÙbî-¢²‹Q‹Ž#túu0JÑÇë9Ÿ“ GAI„?÷Õkr–‘¥\Wƒr?V¢SìCœ[ÏQY~Uò…,Ê>)㱩M%ðµ‹×¾&ž£UÍÎ*ꯒl“˜…êÚn×~*U‰ÌcÚRe68§­8ZŠ==Ù1A"S2°÷yŠõkeÍ^Ú©³ŽC_œÇ1w©ìœœ†3ÅhŠí™‚KÞ¯_ ¢ ‚!åJÊL¬ì ,¹ŽwQ¤Kç;p_Ç® \tÓëYßÞÙ+Ö‘µ©ø¾üàúU9Kyq§\ÇdsSk½^Š\AÿœÞp£‹BYŽnÔêªîîË«>z| ä{Øþ~…ó4Ú‘þ¡sÕá,Èp™1’&ä³K¥ˆY‡\J¿uÄFJ¼ü¸&²}€vTŒ‹"µ9õêÃS**T:m 'ŠázCìçÌø‹ ›îo~>‡ªÚL>1uÔ\0Ê'{àÉ6ÂVc†2¡Î²•p1 edÙovØ;©˜!Z°7hˆ>)M:„åF*Adª(s"RÎfÇ`´ %2Ñ£3“_:ÎÇÊõR'mê¸#°" `/bp?;\&uÏ€ *-ÒJF*:M§:CG£*0&Š&%Ð^ÏßIíÚýÒ¢X5~O:åE}[)x‚!©Rz•†BÅÞœD§>Ñ®vb]j»yþ‚ìL¯g¤Òª/WJZº¢}A+•û’San+ûiüPá$:Ô]5ʹ•X7/WÚ Z½° ޏ¯Æ½ÌBM ^^E ¿+BÍŠ V*5)á" ¨‚ô‰ 2V>ÊAýÝNè…ê]Õ·«±: ¡{K;¤OF4±Ê{°Ó}›êo‹\ióf °Ya¿’J;ŸPÈÔBH{–ò–œI`Œè”7“Ã>Q¨êߔɈB/•*¼”›ØctK¡æƒ™¼A¤åD;¸Wí\o f•ZO5;\Joɉò\^íY·Ab“3Fû”\ˆS“Çל ™ˆ ö®Hô±Êå¼D†ÜX–5&¥ÉGbô¾Ê´Ý¹Ðg¥€= 0¥¶±ßÖ‰¼ÞµÜέ ›$ÉWÞî蜕 —|ੵò‘Ì *›ÄÏa¢ãh“˜Ï[¢'RìR D;P®)Ô>«9©»KhGYmtúðþšåë\Q¼™ñÀqrϺ‰J½Ò¢lûFãO"ôk(@‰Âñ#" lJØå¼>Qå‰VÎ÷<…¯Ò±ßöXj¸æ €¡œÃ¦„¾O‚Tøj©û£…Éæ^>!HضmŠÚ‹rHâ"¥ ”•Ú Ryº–쬳R1¼;ÆwѳkÕÐXõ‹`Í ÕføÞt¤²ÁÆ÷#Òº´!®ë”Hã#XŒØ¥‚R[6óüžú@À¹T5„ήSð\¤<ç³mˆ`{Œï$ ¥éú|G§TÑlïÀmxfõi}+ …ý ÆT9ÀNu(÷:–¦£$ kË×]©+ËÉQCe?"j-¹j/~ò6)SL;ðpQô°N Œü”Ì}TŽXO”€ØÀG0áhcÑËAb®Ö¤Sƒ¡‘c£ºµcêSÖ£>PHŽ3õGCÛÈû7õî…üXé<½üN—A0ÚR_ýðß AÛ€XYã[ÅÙ6µh£ãÖîGöÔêßIÅ ˆQzXQH Ñå|íi¦CL¥9×èPªŠàå–ß-S˜¡}&PA+…j +((Yp 5 Ñ §‚êÔ—1yÕÜZ½þc­£Í§S @$Wëú£:éõ8’Åf‹£Ý ³ƒ–¯0öòE÷Ù#3¥Jޏ|¶5å¾JoÍJŸÌò‰¬+9¥TûmÇ 3ˆ¥ ݸ&ö¦À䈚c]P(K E8hÔ€íc€y€'¾=ÓöAFN²xñê`$ÊMí¶¡mT3‚µÀQË8žLZtò*lHY¯ÊRŽÑ©ÄàÎ !Öó’·JCdЬM'O ìòF^#EgC¯]ݤ´(wy¢¶n,÷.[áó×vȽ…ÉzÚ…»Vz±†^ŽÖ9ä)ÇöÖXµ`‚1MÁE/ˆÚõ‰k›ž• ‹TY0WÁﺴ dþ½#G(v¯0®²T/¨°0 ­ví €LŽ=Á6§s5Elå™é“*ádúpe(³Ö®4íöª‹²Js¹åD(øz†¢¸Ê³ôšìŸ^Ô—ìÇY(q<@º≂êÚEÿ^œ> ×û{ãUÎôCPÉ>-·ob¹˜–î¶>Ç·„tD>æ+ÕÛ¥§ÞI!Ãt¹÷ë*ÜÎñÓwž2â˜quŸÂ`V?_Æ ñ@?]ö.³§»)N`Ýõ=•oƒTD*B‚3N‡5˜Û×#ªBHýép­=ÎS ª¶LaÕS¬jɤÊðf÷™ìS8Ûã’rÈKÅjןË7íÆñn7T=®''£bê)Véu’õ}°t]Í‘kØÏ±V™„½aX09]>iÖ*ëTK‰’9xƒfs4Ó3o$Ö{ :Z‘¡ýL0h Ø "Â$å$Sø™ò ýZ??=~ o•.j& ô\OÉE%-­å÷†G©Ð±‘¢6§äuæ o±°T*ð|ün¹VçÿäáK«C0u0©Ýë±µƒ>_,àèOŠêbż‡¹“tTÇ„YÁt¡¾Ö§„=_€Þ§?.ËÚôBÑ+Qʯ5ߺ’èÌ(q4ì_”º NpŠŒËÃÚ ?Òâ€{Ÿ¾^@DÕ̹:psÐ2I:…„ˆ½åYÆE¬#Sû+ÒšKIök+bäýÍ+ÈÃçW†%*êÑ+ÙÏl^:'»2ËPÈ~r‚â¡Ñî°ÆÕîç+;¶7fCÍO5 A¯Ä‚Þ*Rò44Å\yÛcÌf~f¤¥°… J+ÝÎxžJM„‡…ý°m–^Û…4HH¦u tˆý‹½³j¶ZØ¡ê7Ó”¶IL“VÁÆ>±Gûkа’¼ ”¥Õ(Xùj~¼7_%hI¿œR›…ù}½¦¼OK°‡Ñ~W¸Íz*&pŽ4c_ƒ?¸ÙÓC€†ê©‹Âàø¤\ŒÐ±½èÂ¥}ÞC€ O»G(¡æšökHAd+<Á*¯INû=»‰\¦OcÜ@„<ëßL»ˆÄ`o¤”Ëé`ž ¨t7Hnrè䬋ú2:úKhe!G F`Ú„ºï þ(ܘ¸¸ØGûQ0? DUlgJú-O€öÌsX*awz¤ƒaFæÓŽZDF66šï£-cü@…˜6EV;´z™Í›î$©Ö£¼B…Ð…1+gg Œ^Ì ÐmÖwTëŇ²ˆ‹‰¿ÙUY\¦¬D„¥\\ÞÝNz¨_‰0xh ޵)c—SÚaj•bvÔÛheH™%–•Ì‚ÚäRHöin(ÚNïAnüR%ŠŽ*»¬äù©2çu?~¦óDyØ÷ÈJœ£‘~’‚:Ï¡- sÙ#E su7ÛaÇ£?B'ÝŽ·(,â×õ¤$êH¥ìíx•"ÆŬ1¥8“¿>â¥DHNejÇaÖPŽŸ¢©“(¬—!ÐFºÆzˤóŸ·D%7±™‚Ò‹iªñ29ÌywkŸ$ˆ6=„‚ž`¼£n=1ÿ>Iù–aÊPm(ç(JÉãGnVØ0?ao:BxE=ÛçCÁ ˤpU"®/Å©\3"à¼o˜ Euúñæ[‡ƒ;ó=~« 䘻ÛwòóÅYN0…ôIÐÝ#8×âÑé¯+ ÷/¡#Ø÷Ì1ˆHšde)|eScÒÖ/¡Cë Aè#X õgE1`Ð@ØŸ·êð°F]¼h¡G¤ã³ý}ùÏø5?(@tl²%¯[qXa©ED»ÂŠ«ˆötX¯’­AŒ­alMùû@V:M*ëh8€&âôN«CUÖ °O{™8h>)BE‡@6ÔY‡k oa±ÿîöÑ:šn$êŒ ÿt"E*¦‘uè'â„“‡ ¤Ò­5¥¥OA$χf7ª$\ÝF†>zgZo`—é*Où~†.õ¾Z5Lj"3å\¨3€*Wf2±× §ôS3¡sõ¾7S{ A"3Ô«ŒOfÏá´¿:DÛ£€ÏÊå¢6±`¸¨÷›Ï}y Á¡ˆ¶bo9S4N)¾½ àxZì#ÞS3q™cÐ'}Æø™n:´ÆOü‰lw„Oà¨Ð­o˜ê½éØÓkö”]½Eû0Â'„{ç¼é åÐU™Ñq†­Pâñh¬DyÜ r Õ¸˜ÀÐt+³‡Zhéº-#¢­€!+¡ú¬ÒØ®M§ÏðKi}S ÑÖñk¦nÁ=B—é8Z&Åö{µõw6nåh¹ %]ç(•‡2 |„.0@!026âyä×ãc{‚‰narD0Q¬‹á¯w­yí='ÙfÐzqe¸lÛ•ú˜kô¬«ØX‰•OV93SLÐHöôÌm5¢¢2ìô3§*ž^_gs +kËC†%ãòi¸@l»´÷ôêû'pis¶‹"1­‰$É"Z8,ª¾þ/ߟžf^<@Ø‘@ë¶©ïRôÆår_^#ïÞ©ßkš5m¬i{' =hÈdKí^ ý"ïe^jÑ $¬û¨(°Ùì‹.-„‹ÇS<ˆ2`oWoÔ|¯ý³3{‚çqÕÈ'Ù ì͈z IŠõ+”MŠ+žRÜ+#Ú&Ù￾GûÈäû¢yþñ˜sa`èbú=]ÛHc“‘«K7ÉÉa#¤tïÊ×dÈl©QÉ#¥rph‹Îþþš’ªÌˆèå’JÆÄ…Û•~-ýá/KÈ#”(_INTF‚ôÃRkæö“¥É"m¥X(#¥wè :’¹}¹§}©N {O;sg ¾8ÒÁ^¯~]_A; ápgGnUTpY Ëù½gâw&Ò‚=ƒºÔj¦ë{#¸ÐDˆCïÛ¢vj~ê§À¼t:HzÑIŸ’ž“½Uÿ5³|‘'H=Dg«ë ÞJ„ž·©3SÉå û˜@Š.燢¿}¦ž(úÊTQ«XP¡%…¥á©m¦”;eð‘Ê>Rñ4=e%˜u3:@­xï;cMûæ¾úË€zÔß»»P» Šâ;sÄŒ ây25”S £Þ¨g×6eâhŽ—ˆ× ¶íw….f&/´qƒŒ£¢‹Á«WD-”Ûÿºx$¢4¬ˆ ]´¬¾‰×§×¾¡^ 4†hŸéRÝQ1ß]8Õ •1»þ<ÐmOG4YÌÙ*öç+ŸéÜ0é…Ìê[X¸ýŒ¸&Ê#œÔÌwN¸|{¤Sš r;ZBF‡­:tò™2ú^¡GVQLWÓhœbú÷TàÀiÝ^] §,=×ê“xÂL ­VŒ¼túùà ­ŸöÚa•aLýz¦†¦‘Ó#~pÝHé‘ÎrX®3Ðz`öeF8ׯµÂLútÒÑ\ÚÚ=ÉzsHÉ {7uE¿Ñ>MXfWH8"*Oq¾Š›€ev7¬ˆ<äÆî~ý­kr³ ûÔ#Z°s/F;[ÒZ½Ôç aîôH‚)-²È@˜oÅ}ÊÜ ”ßj;)ûfûž~c¬u—yGî‡|2 eó££+)8Åìw|—\Z¹¬éÈÃZVûfæ^|™n´×DUØ7%^7šÝ,Xô1ä‘ïZ ÃZ{侑Q(ü¹1 3*Aã‚â9O—d<7²dDÔ"ª=¬½âì±åq `ËUÀc 3Au]3ŽR=»=<[y-QŸåûiÜW{·ç¸?ô#IìÅÊïù ÔŠOaÿ†iTFôSˆÿ9×ø†‚~IU­¹ÏL±| ¸ÌÊÑA˜~ßÜtN`vžËÉõ±­r‡ªhŽÇ›ˆL?OšhtVIrs½á¦ãåÄ¢«z†H¸@û†ðnQÕõ.(«HÞ<yBâç¿2á@ÖµÁ«>…¾{Ü+ÎW˜|¤?‚CE½6åÛª¿¦I¢UÚ°z+C¬R40áÆä’=Ž%?asÁÐhî•G:º´ÊÒ¤V½^_Ûö´&\<á¼ÞÍJ®Æ çû@™¾ÃQ™b‡ðcå³AêÙÁ›aBp<å+¸ï±ÊÌé%ä£ê(fJ”« 4öÉcr#Û¿a ýÅÍzˆ–Òª'•g׬“ÈgWU¤Ÿë‡¹Þ"~r[êóÍ`tzùzÓ„î×gD+îŒÏQ•r“U÷M€É”ù$Ãáë=Dïëµ®Nvõ(RF Î@ö›’hªî<ô¡Ñ¾paÀ}éNÕ¸›1 £Ð&_`ëo:„(j¾ÌV2 Åý¦#·"ì0Ç“ ãù[EH3n0ÕÈSßÍ]f1JuüŽy|‰×WAÚ«.¹ÞÃTÙZßB?C@Ü'T„öô„2±þÄÒ^@w¨gÚ×fÜ^ÓÄ„ ,Öz×jÁ2I£4Hv{ò6׌àç·[û z †œÜû§fóÀñYïö(^±}zÈLúæ+tîb{aŒAñ\4 ¨Õ¬ˆz+dÕwi ¶ÜœQH i¦úäý+e÷BðA3Ú„ŒªOîÑ™ ñFˆí;˜ÖÏ­¡4¿„²Ýs*„RcØ«Ý ®ª¯û†ƒ ¾éÕð³{O÷N쿓ѱM÷›NuîÓ)ªÜ€Ü TЊh_2ÈR,ø¯\îc¢ZüóäfaÓIŸ¥kV÷©ú%ñ­)±ìÓ9áàNyÅ¢ø'Y£¡x§, O[{'$¹( è‡û4n<—¢­ ¶Od^û®¯û})3Q¸™óÏœî*ô£‰r×_u+‰€›F¾‡ã¹€tj·3§…á*ŽÓ†H‘oêÕù’Œb[Çp9"×®È5J?C¨Î¢Žh½ùh÷q‡7òMŸ1'öff Óžú¬¯™Ì­­æ1½)}eÅ2üõnÏUÏY¨0÷‚híÌæCØæk¡ÔáCÉ·Pd2ˆÎ“ãhg6Ÿv+“fåƒäƒ ïk -O]!×B&Z.jí=jÛw?…ͤ¤ßÎWbéÌ)zž¦#­ÈÖ5eï 7Ú™Ò§¤WqÞ,?ÄŠ /Ý,â]³ ["¯-ºÛ#½-®Íé@á|wGÉÞ³ xÏ5™Ôƒ‚º‘xÞ»øÉàÍ0Þ ‰‘û’bË<¡Zëà*Ù„h®~2„BÆ`Ì!·D¸¹4¼wÚ'CT=S* /=ý ýrÃZ¹‡ù·þ°ÑuùæˆÊ½Ï¨ ­vá-ã7LÅYÕd›û®ÃúûFªýÈeìRˆ^æƒÌ‡Ö*…ÒMsø¢^LF˸Ál|à}ÑÒÐ|±töS“IµÅ|÷ˆ÷—¯‰#.fºÉßZÆNô\£¿z¹ö÷G軹¼† LÊp²^c½cläac|”V*K2þL&'îÏeà‚ïW|k‰ìÌÌ, xfS Ý—UH̹lÓnؼnO¥‚JÜÓŸ\&©Í¾˜y(qnãø}} tAvÞdšoûÖõ0vÛ¾_®µaþîξ"Ê«\¶¶dŒ7sZ¨w¼zÎOªÿònß"nï¶wWs2­™¼ÒMcúe deƒÑ0ϨîH=K¥Ÿ†÷ýT2ÆDOå+t¸¯%tijÎfŸï ìtºSV5ÚÔ'sà=·.ôeñe4~¬±¾HÃÁJ%ÁÇw„ßü¦Ð¿;JF1ƒEú~2±REÛ¥"{_z âõ ®Ÿ÷å‹kλØG É—L0‘|À´÷®>û÷÷1ýÌ¥8ëk¾¾HxÃaéÒüÀÎ&2ͶüÕ³´ ¦‡FÀ~]ðß|CÇÈ?÷ƒ @¦y|UÓN·—1¾”iù¶ þýæ•|ÑæËjÜbã{ß/â/Œè~§ÜiÑîï|£Ü‘’"s÷ûÍÀt–WêQüËm—c6øâ©ÅG5#šÌFsz¿K- çÒ Âù6söÇÅJ«~Λ¼¥…Nõ䓿¦¿UÁý®ˆ1å)ÿœöë HîÓWˆ÷ prûª3Ö‹iûëÿgx®Leco/data/wallace.txt.gz0000644000175100001440000001117513136253506014550 0ustar hornikusers‹e[KŽí:Žœ×*rK¢~h gÔ¤zÿi3‚ :³/qãH¦øIûýÏÿþëß?ÿùù¿´çi?Ï?·ÿ±îp8\ïŸÞÎ÷_ë¾&V÷û¯óþ7°è¿oà/lNÄ÷oßÚDȦC.¼Úuè„¶9¥íÐ)‡N··\lËáŽfò †š¶‚8r8ZB3Fò ÆLÇN8ð,Hí¤l ÕStOÎâ8ÅÿqèMß2Á»oy\3³¥f†9W¾e¸§4Þœ« ®f²1¯Îu¸œÔí¹y{0î\­™çnÀ4žáQ©¼» Ñ}’0ô0!®GLí6h.˜‡nºC˜ŒÂ¶Ð?~ƒ˜ZÉ#4 ›—g@f˜è¶„Ë)_ùîNA¬bŸÿ€ðNþ=§ÁÍ'\÷8¥6ÎpݵíxÒý¢ÁËôæ„àåÐG÷½psj×áþºykr±¶^ÅÑ/¤Ÿ`¸ÁÏ¡ÚîÏB)0!¡"ƹ £‡Ï4ø9tº]8øù 県pЙŽFî}­3àÝ~î–Aò‡ êÆù oL:¼ŒÇgûN§œ~ tøêo2ÖǪíxÔ>Xñö¡Ä×Àã FÏ›Œw‹„4ï&ä„Ìà›w* ‹7ÉÚ‹Ltì8Ä¿.v2Øaç­T6·}ÄG´m‡Þ°Û•AµíÏî'Ã:ˆ"Ph.<ÂÝ"”f„ûLWÃêþýìM>Ì…€FɧkŽiðÐç'ãr‚Ô–  òԃ؆b‡¯"Þ‹2ãÉÁÏe¼·’ß?*@̃8ÈM#ºˆwŠM·á_ù¬̽ƒA_¾Í¨7dµã0 éêcÔÓ+¶CyÄóòͰ‡nF†ý¨(a¤žÄàôˆ²7L>VÝp üqB½Œt8Îã\÷ý;$ìŸe¼ó0gu(í?~Ø"õx~¤(lHÐ$wÓ…u+ÏðE8c/8S…P ½?’ã ¯H¿W[gê·ž,{TySô(/òþêL>(> ?Tú‹/ú^†ýScÆ=Št,MúµÜ™{à© ìÁ¤O\© 䦸ƒa¦˜‡YvQJeä¾Òp÷L@‹Þç¶Z¿éo‚z±U„u+îpž©¤êÄ`/bØñM|@¹?rÿÌÈâñ¤< ïÄoª ¢mÉy=l„g÷MÒ ÑVÐ^壆õ]¶€í¶œz@›[®Br[¶Ù* Ê=âŽë§BŸxŠ{@^»?¸]{”!0%v_•4oÀ9†)†˜E^êÅÍ-Ǽé—ð æ¥‘†eZj2T䥞nËÌdRí§æ7­•Ÿî Þ#‘AÜÍpüaÕÑ™› 9Ä(“ÓZÚÏò[º`¶¢Ûq]C#FXКŽ,‰ ~2Ãðƒ9bPÎ`Ž sq½ b®ït„ÉuøÜÞ!Ä“rF”'#”9˜#,KÙÁÁ:䛚®÷&ÇÁ:ÕqB¼õÉ{P*t{PG”[/YŒäUÿÃÊsDŽàÕ¬K|›¡‚Â2%ÜðêÁ”03¨Stçò`JHÓ¨M ÈEË"]MÕêÈ1¾pëq?]:\cD}r~X®¦„ðËÁŒÍ P_u{CÖ•Ìu@¸ÃX¢€y¨Š 50 4Ë*R&N;r3Ãþ£fªa¢ÂÍ‘t”9b16#),9s;?àì)¨Û»s™~ÅönìÔ˜Ø«à‘§Á´L Ù4æ„r[F¹š®Q^Ò0i0§ê2j Wa Ôj60È˲‰!hf´Ï ˆ\f+‘ºœ×¯çÁ̰QÇÌÔ îÇóCmõ†2[Ãù–iuc¹‚ƒ³t ®«_ìĉ¨1ÌfzLct@ PÈ,û³j>î{°0T¼”™:Ø]yÿNhc)ôÁÍRMs’«€dh[9{·jnr¶¥¸Åuõ`ðäV;rV;•V°ÿȃûw²ŠØi7ãœäáù+›øïä‚é…§³àÏ@mW…·KÚ ^àTýQ[ì}ý‹Á òí¾Šs¬#lk½)<\W Íô¦7ïMyVï]V4¬w5t`¯ëîžÄUlƒ<¯ƒ%r#“©_…Å‹§,3€Rð©M×±©7§t¦¾¹?,%^¬úI·›Š8eŸêí¥úÔŒ9¼O5Šx§¶VúT!µqÞñNC!o²u»K)wçA[îš4á´-?$”ÛÒ¶ dœ½u߀ØQ~‹|ÖO¥LØÀŸUUþM}pà›–‡r§mƒüTMÝMMR©[ùÉx˜uWfwˆº4âÝÄyõLÂ!×Ak‰Ö„$¼¶-œð0âÏ$Œø!ÍrÖ MnµNÔä©Nûæõ ôOÑã~iŽôòCªº),Ù»ŸÅ¡ò¹»¼ŸoÃÞª‚lÏŽuumb]…ž Ntvˆ’¬ü"^@Ýô«ˆø£çùÎ MüÞy>ü,æ=¨±@wŒ$k>í|¦Ó\Þ©|ˆo¢¦ØÅØaEÛÓÑØÔ­´M«!(b˜=oÀõÞõÁq¦2eC:Úe×~õÆý50ÁñðU6u'ÆŽgÆAç:k]„.ðÍó ⮺n ÏRÔ¾¾>vLÀ!φ!ãcÍ!Ÿ¬öã½¾ãÑÔó/ä|–«kuáxÖAQI8Ö°ìµÞ‹ÙÔ£^ÇzÿÃ^W¿ð†¦c ûb½ªÀþMgs¬Wg°‘úA»ä˜SM†¦cÞ?è,_l*] çÁü­KþhÏlŽ«{ƒ:M×eÇùS—@‡ü³J|<_CpÊKÒ›.ù–Æy ÏÄØEŽ¥öƒ“(ä×Ô¸j¡öY E¡èxJü‡ Øõ†;ªsȦ&†úŽe «%rÈMœx1×W¬9ä+ïzkÂu™‚ÆÜ ] ËÂpŠÝS©ëG©¦ñ8Ã"ҠŇ4ŽÊÊo–±øv¦š G'»£½’°&ËNè†ùQ‡Ç+,¸]~<ÁMµÏÒL©ÈÕGÜ®Š!¶Ëï@}© X`¶>âhØÎ(@ùS,éÊÀlE Oç•å¨Å—3†âŸrp?àNr\•×ÑËÎ׉-?æ KÀP³°ê ÇëbJ¸+æÞügQ ÅGÅßÅu`Mèc]×åBÅPÔ‚ÅÐ(XÉ¿«Åy@½Õ]dÀL]ÚÏ™PÜýµEv´ýù€ôzqG|µŽýŸ¯‘p^5ˆ¸J¿‡°Â1×±ÉW‚â ¦:*Ý“a¾ý#—À2Î"¹z¡NÅñƒS"wˆÄ‰×ˆH‰rHI*Ê¡²çR¤äÌùâ˜Î‹Øäå rzÇ1À ]{éé]Æq[uáqúvx~”B&mé.GÉÙN¹ ×Õÿ§0§ ²y÷W²‚{¾ÿC·W z༫RîÓªS¬¾îÇR¨Ëý¢x‘»³öaékÀJÂÐ^¼á›lŸ>Ç)ï@ü4¥oÅÛ¿­e¸=§u áº1JeÄ'L[Ìë58y*«(Ë5RgÔ~<· •jù‹ÞþñSæ" j¦ æjðl–Bù>Ô¢jçCJ¿úeþІV_Ì h¼^Rg …KDeÑ¥r Ì‚hÞŒD|ß ›ð ÜýáhWÍ‘¿LqM,¹ÉÓÖÕI½œ*‰ÁÓÑ4–~ptÙQ†“ãNîÎö‹q`ŒóÀßëZÌG|n`1T|Å<ðcƒ˜Ö—p3Álˆ-f‚=ª<‹™ ä;ŸJ†ûYâCÇÄ blÖX,³œÝa¢ >1=¶ ꈡ`½² ¶[;t+uœ8ª&lj´÷’@ö-{-Æ‚- cÁg}N´ûûÄ©]yEœ8Õ4ÑŠ|‹£fi0à;¬-––BoÀ®K]žP- ŽÖ/'Œ¡ªŽóùÌkߪ.ˆ¡nòö#–ÏŸ`ŽaÏ«ä|>£]?}ðV­ÐA‘©¿ü‚Åþþœpçß3ïÖ/ò~«™˜Rˆ¬ ±^ZÀusÿŸŒ“ÂRK«Xñ“¼œcð÷]®pìÀ*î¸Þ+ýðùßžÈ+ Õñ¬–ÖùíÈø0<~{b\³žøs Äxð‘Ûs"šx Tzà-Ð㳋qarø|b<>ËÌ`€ýU–ˆ1-¤ .°üOiŒ&bGŒjÛ×<8~©º¦4+#¯s¹ê7p³‹»PG ÉEó¢ŸÈ%Lþ=>,t\q‡óŽÊs°wÔšt.Ï Ä5sSÐ0û÷òØ›ä¿eÝ`÷Êóé ×÷ÜÍ]Œƒ´¨_(q½Ñ;ü6äSà~’_;Ö8ð3Nø¼¥Îùyȳ¿;”ÈÓçF®…ûÙ§øÈÈ2ðôê‘øÈ7Œûg¦Š>w ´ð¹Q¸_ùšð÷…ÂODbÀí°|0Î3™fïÑ}wÔ­<ëZMÞ(¥õºQàgüJ¤gúçG"¤üHäùÜ0üLdèùUô ³UVÎ4;B öO¨@ëüðOyƒŸŠ„­ómÔ‡à–™¼¾=üx„®‚§ýñh…Çë{@^â·"Ôÿ4Êxüª4ì\ÿ=øõ_êÎË_*¿:ŽF²ˆ>ü`„÷Ï.¿q+Å ñ¥«cM|lrâ !zœ–*¿ú@°?¡3>W9R×ȦÕùDÿUb¿øWÇøâ >7Ë`¬Äÿˆç¸dŠ£RöÞÿµƒ¯SÒÃôŽ$wXÍâ@Ãjô.lÿYWbDÌ©É5=cVÑÉí[† ¦Ü'©Þ‚°ê\j×Ë{`ÛUzGŸa+öïšAÂ­Ì ÷V8?»Š‡çO«òþ¢¡IœòÆÜ‘íeco/data/forgnlit30c.txt.gz0000644000175100001440000012675713136253506015307 0ustar hornikusers‹mýK¶-9²e‰Õ³·9€P´$™EVɃöž2—,Á>þ<ÍìE\7;ûlýù¬Ïÿùïÿöïÿhÿþþïÿó¿þïÿëÿùïÿñÿþÿþ¿þ×ÿï{þ÷ç9ßó}cþãϻͳÇËŸþÅéã™ïþ×û¿y~þýÚ×Îñ>ã}Lj?¿ü?Oüùì3þÍõ¯=´>¾3÷ÙúÀ\}ÍÖãÏíû§ÿ8÷_ø>ÿÚÚú‚6ÇÓ¿¥/hÏ£/~>~mçÿšþý»ž3ãWÄGg~ì}ÖØ3¯½=k=;®&ÿ§?Æ­´óuîfçÝô½Û·×ÊOõ¶çÓþǧú~ÏøÖ÷/¾ºõü²Ñö^çÓ=µ6¿5§~ö;ÿÓ¯­Å¯ˆ½ç_<°ü\ü×qtëÏòý>Ý[?ok{éwŒç<«Å‡fÿOSïhïÑâ]èëv{û7ùêx:ß;Úð£=_\q¼§Q¯j¬3úÌ'_|žýæs8O;ëÑUŒõõ~â¼ß¿ÏßÖv¼€©o{ÇÛûÖÖJ§ëß?mŒÙÚøï¦Å%ó¹xNÏ7z¾¸ÍÕ||®½sÅÕ/}Ý«ÅCØ|Ý›{âÎn+àˆ«Ëçðœ?8ü¬â‡ÇÖûþZ¾ïÕZ,½ï>ç8Ãoî›oÜ”®"VÉŒÇÂêªOõw¿íóêý{âvô£ý‹ÿO/^r®x¯±¦ö|}ïñ^ý9^ýЇ©{k,ß?Ö{~G<¤Xây¿#Þv¬¤/_rüÛžWlí¸T.mÍ'þxãÉŸ|Öß³æ^z³±Òbî\lýÄCz^c¯×5ÚZ¹Ø×÷ÆÊ?+ï)¶IüÎþý‹k¹$>–mì(oÆùœ×{žûr±Âø¾7ÞmË{j±@Ïë¥ôöurÝ6]™÷ê‰OõxG±cMæöZ;VWŸyéñÜc êQ|q¡-m§?6y„qÁyO†ú^ù¨¾K4—àûåÓ¨X+p²¿º·óyã~ùšâÕ³Ãâ"Zô\Jg¬ˆ±GâÛrÆ/é¯6T€ø"ï6Y<Ç!âA,÷so„„×/sÆ:{ò‰è{Ç›ïˆ2‹êݾ±øîïÉ›é}Ž™íÝ«¯z›ì­QËö™_„³‘[ï›ë‹åwölüÈúˆD±éâõûÊbÅ_z cý•!6Ö—¡îy.^»>yëï-_œø½z(#bÖŒ!’ǯêøûÆŽ»uK±ÿãµfĉ-9b×ç+æVâÿ‰8xƒSÕûæŽÛþâÛÎ},–ڈ璗Ù~/¹5?Á5ß ¡ù¡¶¿¼Ìر:8šch\ÕzºW\|áxõâ7Eˆžùˆ8‰ŽB/ÁÃ'ĈxÒ²õBµCÇXo|õq@X/ç”ÞÝö›Ž×Ü ¾7žŒOâÉ?¾Ž÷»ÿŹå—ðFX[yǥſù??q8¢ÑÒ>ûŽCïé»×²ŠóïÉÈ»Wÿøa½º.2Ö…"ã·Ö7jÛÇ~ˆà¨Z±¤c±(2ÆÉ¶"ÊM.rå½Å†‰€>ò°/¥é{N,…¡{^‘)Ä"R@=> âpïðFŒ§=2™ˆ/ŠMؽ#(­Xazå^aq’¼÷Qr$Íñ_ŸcFùÿ3ViîìùÆú˜™hDx‹0’O%Õî¹G_‚KÄ­å—Ð"…ù|mqüÇ]ûg¿È«œbD\¥¥yEÇû"xì{™{ÿëc'öÒ£MÞ}w±úv, ÜwKÆðI6ŸX±I©œQEt|ü±ãV˜oúÛIE¬ŒÈ"ÇcÈãïc5B°óX̓s%R¶•ÿèhâþ"°ÆKε{…MRE¬Êéõ›ÿüË9‘<-Å`áxºü_.‡Oÿç/& ;ä?ä³^ñ³ú“=Â󌘖I_ì'ID ¶ÄÇë}ñõqåv‰óé:ñ¿åu߇“ýqð‰ßk:7ý‰P¸3ÖýçUF¡Fû¥§}±ª›{¼*þ”§.¹vú\•±¼"bÄf™ÿºSíyD¯…º÷Yy½d1û«…ïð(¡:uXÄÒyü“ú¹>òÙGL¼¬ÆÅG`8–/îÛ¯Öa¬æ÷~[‘FR˜éŽ×oD¨~œ§EºÇÍÿüX¤Õ±êcðLœDè[µ›"ì´Jí¿ÈÈO?Ž'‹4IÉ©ß\G'¡ò¢9ìãb‰R‘INO?ÇøÉW+½Ï¨v†Wu¤Š~Û›mOØá´®—gßÛ¼ÏȳjæwåWEÆÇÙÔc|*·a.×ÖŒ„7/1¾io§XqŸGkëfX‘œGàÉ30ÎÙÈr³,"p.åˆ ‘ /­-/­XOÔ=áu¾|¤qÚ€óWèµ7ƒ•3³8±¶§½Ó‰N<ÛHÁòˆ§Ç;lîQéËÇÁ“"*‡ø×Þ¦‘qÄÿ›k+VÔˆçÉéËœœ‡.)£FìÛ[3Ž·È¼ômsr>·,se)½‹4Á„ÿ•©ET”ßp&Ogí­Í:/z<ôLˆœÍYF\‹¯Ì‹¤ÎŒS-Žú¯bÉ7"Ý?¹´âùï³þëcñ‘M‰ïɧ¹Æë°¯ü’ kQ\Pµ5‡}ŽçCxu%øÆB>O÷rxX±¯òй±¢r÷F±yLÓþ6Ž{’pçA?}¦Æ†oS•ªóƯªÌH-â1«tÌ»‰[YCÇÊ𫊿ãxSDõ´–kƨr·‹ÈžV$z:4Y Ç {|(¾ñu‚úQY å8¾¤E’çgE«yyoœü##Fðq~f Y^é‘ÔÄáåjö‹e–YYüòÈ#ò*cÅG ‹hìæ™ÜQVcÇc'eìOÄp%4ÿ-KuïÇ8@b=ºmI[ŸM±Ä"ËËU—Lj¢þxüwÆ;Ò¬Xi<’:Øßx-> мJÖÔØ^³”âSÕ£ÛB±”ö[M5jŒöß‹‹³ÕgسŽ]Ú8¹Q£j>c5¹ Œã—’O½Ì÷É -¢GÀáçÁD‰Nìµ§âÊæë¦•äw_¹ö˜Q"›Ý>5h5´ {‘=DþÒW6l£~pÈÇ93Ñ?‰ü§ZESùññvvl£|Xq¦­ÙªóA摉$DAµvä¡t󓊼ù¥ñ'þÉ ÌToº¹|áß½n/F ܵš?þÉq?¢´'_ÉûSÝLZ`:Ú3ïx·‘jÑ¢­Ãeëu?J׿øãö®?ßG3(bЮ2 Nô×aŽîSm7ÿÉwû Î\kÍ#Z$óu6Ç’¨u»Ö¯;ë› {+ýªÊ4ÂtlÏüÜŠ¤oä@¢û/Çk2A=´Û#™´wr‰Å®< @öÁÒŸ‹ˆK2¢‡_QÔu‘€eD‹mÚ¬x4ed¼V[¨+ž»¹5"aŠÐýú¿?YŸ´áJ{3\DHdýS«xåÅ/ºf£3}œ°d°Ëàôž¦=ëjŒGP­xÒ¸‰S+bÆñ£:[a„GòU'‚p½ÜnYœ>úqÖJš!2[ÏÃá‚á™döܲÎJÌ~$/d»qŒU‰Ï)ú9ˆšO!Ž›XyÌFÊë’nI¯2,,Š )º Å(Š¢ÐʧøPÜ M>êU¿4êÜìkœ+Wgœð´2TKZEXµfÏaÄ¡;sZ6³¥áæD>âQ®•-„¿_ÑG.lM j*Ió8nMŒ8.µ7ß·ÿÚ8´¼ãvÓîÉÇÖû6Ÿ¦nõ³Ú:˯ŽÆ•nÞ°6âôtFçwä Q3Eør~Ôª¥“éU«nº3³X§ŸûMñë°*è«¨Šˆ÷v7z&9a…¦X/ÍpjG™(ë¢jxz­U6® úg§æäf‰SÚ¸Œ'qk^•‡Ý§ò–d!N€¼¥—ñ”Ò&w¤Ö;O&Ú¢[ñ3bÕG}»2ù‰3óýtø.ÏÞ(7ý¡x®œ*[cE×%ÄÏÄá‰Äot€Ù,·,;3¸\«ƒ™â“3îÍk IÛSźçq¸K#y:·Ì2MK•ÉøÔ9Õ묧 s­gG\ôÖ_ž\Æ"eàØû}US©×™IIœ5n¡Ì¥]wtQñŸœ¥Æ¯^ñ_såF©_]ö± Ö®D}¨Zôq™Óëþ­%þÊsœY`ÆZ$q|§–Fl=ø8"Ùs"ÕZÊTAÿÜNŠÝ´™*gÓYáù;e­ß‚Æ¢C*éÜîqf1Ç÷ŠÿJ†ŸÛ=Âf¼o%<#šßT ßËôÚŽœ5ÏøÃ)¿c1Ñ\®ÆüÇóöD$>vÜGe¬çØjpVŒ_&G¾¹2È­â†ÝM‹íU^¼„él?óø»?Õœš\Þ;šåµøéÊÆÌ1ªR·°^š?~áäñ/C4v~•ÁQŠºâhGTÏƒŽ ×[)c¿©¦Æ[Ó÷Ø:ÿ¶qbžBŸOª—ûR~0ÜáyxhIéœÉ“~ADæyMÄõ,Ãý8_ z0",øÂ˜NyÚÚ¹Žx<‚Tû¨Š/ì¡©t ¼´PÜÙ´£òõ›@Æ¿óêì̇³Ôžgݧ¶aèõ›•‘`Æ!•Ï—–rvM™Ãl®.ƒ™ÓR‘ÿ›±Ñ%<®Ê"~2aí\ýÎ6"øP¡×Ù+¿ˆÝµ ë4õ}¹aXcŸ‹lò×OÅçäȤOûpøðçë Xꮇ„ëý5w#៙4®–ÞHÀ¸¸\UçÍlpÜæÕøXkÕª¤Îz«_•|n¶Áë}?RÞª§GZ…ŽÉ1ž?™Óíø™Ø¡{ê´¬Qzä0.QkwýÏÏöxÜ_oŽ4ˆÇü*ëˆÐ˜•ÀlÊërÃn:B±kn1OȺ$.9Ò‚º¥Mµ­0/’‰ÜT#Ìq`1@}«1«Ôû%ªC2Óü÷TJëÕ;¯s3–ÏøÜÓ`*Õ]~æçò›;9-M±êßvÆBÃýqíBêOs¢S®3–â™T» =O«!Êd°šþ¬Qv€6Цê¼%N8b0žèÛï.ÕtItèð‘²ôʨÞZ4<äÿû1öX<eÌÕ¾›‡SÁ'e|,Q^ èÞ0ƒX%hN<ñÛÃ¥;îhù]”š+÷Äž 33ðwm‰þ©&P¶'ópfXÛõrƒ×ùsˆ/~(.øâLMêYH\™Æ€ä.yg¢gã5Jqô× 2ž3¨ÅIz¢ž7teÆ:¯ [÷’RôÊ)"Å]^2ѽfpqööm¢Çñ3 ô‹ÔÓ™Œâ#¿¹1^GMD/.&-_"Ab{œ ±ˆÂ<—±ØQGðŽ[¦k7yð5VóiüçYÞÀ ÆXN>éíØ6Ç[e˯J'¡˜;ÁJûŽÝèŒw6×3rö·É&ËŸ‰h¿„¡pr±TÌæ¡=ÐðŒã©Ä1ï[‰gµŽ–†¼ºÄ¸&ãL£&Ëöà´™DóB±‘ÿÊXðó‘ âòÜÜÉM#Sð <¬uV£PÞG"qnlAÇS¨¯Um= ¥FøšœØ)jÎ'5§êNÉ1Þv[ÌŠ2 èC®G):Ï*ˆLõÝÈô’HJóWIJРâQGÄzþ¢^±u3³wùΓœˆrc]¬ÙÏùãoîO–„FÉìÒóï\ZõÞXF»×óo‹êd¹4‹z¶ð÷c[èß#”Cd¼Þ§ûpK ˆþL['2 7üÀtrcëæï¾¨ã å#;DÏdñ2 Ïõ`[Zpï}sqJ¹è‰ò¬õŠÅ:£~º—Y?;RóÝêÊkZtèZyI³ãýû”ý¾&|Ná¤ãPÓãj:è½4R\ö¸ÆxV‚›æ›zFεmÝ ÃY&DÞ¶¢æÍ:>ÓÞ¡>Dnâ RE%!M¼õ8ÑY*¢èÝ0 ç—6!]ó©Gm8wÚ™4 ðýâ@›EæèÖvœƬ€Xœ'E¤à±¸–š!UÖпèî"EÊÌ8Ú çïûŽmEîSc¦XSÒ–ø/@;‰ÚÇ,°£²žº>«· *<§×œÏT{¸‡–š'^Šq…o+Üýgª§÷›«PON..‹LÎ!*âÝãòðï5FàŠº‡Rðµ8÷£^¬³z ø/ú'~[\ÆÈ²µbãxDÎü†‡Q\±ášû´=ê6’ö=~{sÑ6q ˆ½ÿzoþù0¿'ÛÕµ.˜Ï|“ñ‹Zuz~jà€ _)…zT¹ä#ä(a,›#“xJv™±žBD:sŒm ÙšO öqütÆ”Éß»e9TÍRŽî'¢ò䲯SÆýì ¿ê9»…UEo*igbq§4yòìS”e\ámBc`5Kñóîì4-\bгxh׎_0Üj¹½WOðTÄO…~ÇÐÜ`e èo›à2•½‘«ÇçJLË% X@r²ÛX#­ÜFáÑ37tqßÝpßÉxûS[³r«H–hŸe´¡ç9A„cþö¢šá(wÑLÐÜ&my?áI±[Hœ_Ž¥º·{Å`Ó:½ÏÛŠŒ¿Ù1:‰|jwCr¨ƒíx¿Í™ 3ƒO³´ö«)y'o½8Ø;c8…äi•>=NAÚÅÄÓ½¸³ÀHG÷ÿ¼µ¦¡~¶EÚª•ÑÅ!Ÿ8ÞýÞòË ·O›=ƒA•õ“‘]D/žÜ XàÎåd› ?ãÈÞ cÄÅ9á¤WåjoBÈ1Q, D¶Í©o"ä87Är¤Ü£}5zcQäü³êIZE±xoM)¢€ur2ÅÞ9­øgRÆ ª o¶ögžÇÚŠ¬`ЦQëÿ«”ù9ò}ÿÝYÖ1ñ:Å…±€J_ÐßdzÝñ;8nT“I¶iM؃]xþO ÊyñT²^HS¦¥ÆòÑtXfOÅrˆcÍ5Þu„ߥ¯«¢÷û¾×Sa2ðž+ ¤X?•Ó|qä„·±f}°î®1;q›•Ì®ð@·ö­»£®<5ª:±÷`¨_åéd$Ÿ_Wµr¬È89³ÑîÏ ¯kaöôÑÄ[tëï(–. 3)’ï®,í_þ~ãRÖXsØÆ¥wÆòIŽc~<Šiyä 1»Šä[/©ñàϹ@q>—¡ì^w…iͯ_¯Y®¼ð–Î6ÅM‹¥a ‚¯ªu ›[q"_™I~¢m0ÝcDpn¤ÿfÙÔoO•Åœ ã¿.2òĨý†‚ȹù÷1øÜþŠˆv 4j“ôK®ZRñFºóû¥r‘Èæműì"Æ|šÒ{OíêU>ÓÉOÈÌ;eÎÙÉ[Ɇ«®&£Ìbn‚ª»Ný“o-¯žjÜÅ—]8äØÒŽT²ývQ[èW÷ÌFw» N7:úãŒ_K¤ô¨Ó0Žóœ|êÛbÍfjwþtÝu @\|át¶üò™óh|HÇò»ýñ€ßˆ”ëG±ã­‚t06q<ém¢M½=7fcC²“úX2‰OÍ=ƒò¿ø( Ìo×ì½Ä_˵z±ñßgasâÆx3 $ðÊŠ§l‚&ÏF–D•8ªßDÓ Qû ¨¹â0yÝ«ü@m¹yüC“2bdí@­Püíbðïýǧ‘p%Q©.’|ÁèCVYóz"M8͸Áaù¹Ëd}aZz’ñËá2/¹°ÞÀ¬ \qúæBŒŸ­¾DÒÝdψ04˜]”;¹·×ú OêÛbGõ"³äˆ³6‡3•kño\LŒ.¬\.ûxó݈ÊN-Áþ[' d2XMÀüS¢~žÏ-ºNn)*Õ¨M Á$ÂÈüf @¶*É<~6]ã¼ ŸÕF5ÇYŸ1 ¿|dFÜFÔ_$!§ªgôˆ^ç¿6!ëñq9~‘ K>Gè-“Þ3¶³,õOB+ jÒ –ÍéKqš÷58Ö‰Q%ªó]Wñ¤ò|Ž×©øx/MŽfW"á5«&bÎWO朚\® Ç ·PÄ$¦dº¬«:Ã'­¦oÉ,›ˆ> øF^3دl Õ›Ší®~£ î1 @9÷ÏM ÷2VÁèD˜ß•qB}"V“ýe~ƒRô]Ãà‡ÌÍ,­Ø‹3ë§¿«ø½¼ø¸WJ¶º ð¼³—¾½¦4ë a¡µ%ö³Òï9Õ,lH&ŠC5‡µð_Ø• í$Üר®€·i“·^â‡Ô”ˆ³¿À#DÃ) ªš±‘àôâ0Ð ›[¿^j¬ìQ®H£MÕ`j ¹…?^8þÛƒŠôâ4ƒ4¨ÛkˆO^f^|Üå3tļu EÕ] Àa_‰7ˆÕß~†ZÀÅ»LÅšqŽÛ©Æ¿"VO¤LÇ\ZÇ·Ï·¦N‘9¼&¾ÿ>ÅÓ‚\4ᣮº#[Ø$†Lýíšáû'vê.Ò@\¡QøÌ##Ά»ÿ΀|>qéh\Å‘VÇç8â3xÃÖXÎçi”Å „ÅšËÐó7®%u„ÃO|¹‡Qu¶2 ÏìA,/¢òãœQëûíþNU"Ï_\¸í3MƒLÏß:¡c 1U…"°«Âß¶~›Æ:ÿЖüŸî]ÿÑ úS„l€êýqÁøwLz·ùæu¡Ù€ˆ[ÃeYÐü¥F‚£‰…§žôIGæ ¹Ø|m¨_ËLGÔk.ú0áÍÝÕæµStv×ãï~YÅ‹cp(>‚µQ+œ¤Ãéˆzज़Ÿn¬¢ý ߪ^íÇEh>zúž8¡ôõªˆÃ ­{)ÔKñýd·AHC¼à]Ó¶a+ÆØŸŸØ_!‚ŽÔwDÎ]'&h™ü‚l×ùÂñfxõ—¯ÌÔ`[ÄÜKkþZÂ#"md5}í?Xa1Æ çQXéyP82 †¸’oçüim1‘?©ÓážpÜ.ƒÂ§p-€” ÑIT»Øxw¼qõ˜nJe)S”HãøgÑ¥ EЇkîö?ëb¬Ì3‰oEVþèÙ¨1àÏŒæN÷ãìqm»#hÆÃnŽüIª‘ºJ 6z5:;dãH~jU„0–Wªö? * 1M*f¯+µÈX’ôe[ÀIóK×Ô½cÐLŸcù)sõéC‚çËjN ×ãM¹à£å?¦qŽ"+ËßåÂúJDÞIqäóïL?`>Oñå¿¢Pp¯=à‚t•ßü—éÉ´zÁÉŒôUjÜ hn©8/b׸‹Ù6ÃÆQ§r¼]ë‰pžtSPßXÁÃ’U á#„+úEüK­¡¿ Ÿxo Rœ%ð˜+T(kôûª$m4ô_ƒæÑ3N.þ1ņ‡K³ÿ:p¤ £h«ÐãzvÉS¿+Æõ`* ÈÅR Y_¯º÷ ·b&\õQ”€j,¦+¶Áøê›ùªšAÐPeFÛEAt&ÕK›æå4ðD¤F•È é,/ôGìCp¸FGgtã?ôÈõ¬qSøJkO“Ö±ŒŽsÌžŒ2ÕK'm° \Š…Ò,´þ0r€NÌøeI·¨˜I¯ 0:Õ˜j[ø°P1JnMÉ@È.’øŠöÙþz!û~²íÉwÜS“Œ ¾6ö«6_Q:âey‰šgd*±¥ÊRvB/j3>óFˆsÙØoØSÜ‚ú­~ÕŸf.¥N0Ú!¾i¼¥ Á26n¿%;9)ðÔ óÛåELT†°ÊWu =ÙÇ剀˜ô~ v-õÜê?ù %wÞöïx]€ü‡Æº=Hu‘Ûßói€³Íü#öïöXtš`“QitÕ‡›—Ÿ~-˜ª"g’òâF‰5(ϽŒ¦´›¥Z¶‡QdÈ@æQ»uÏ\$«¿ÎZ'þ]EÛ!âäâ’"à–ü”I„RÊø¼5õg<üÕÐÌ5ÀidOØa®-Ú„½¬ŒgÍùt:£ŒUÕR@:ՈϟUïÐ!WȉFž¤ŒÖ9w<èñß‹»lŠÝ+>kú¦c/À8fç|7½‚H™±*ŽøùÜ© A­[*¹ƒÄX—ÖÒÁör'À—˜óæÏ¹C> ¢çFræ©îìDòk4<vÍYõ€%7ô˜X¦eùóó‰Ì=­ÓÔ72ÂØPë&¼¹å(ð´ÞüºþA£ÖöÓÈo•Í#â’’D]kã`T¯@êU»O5ñÉ?èòÉõÏþºµ’?1“}?îÝ}>\W+BÃO„\£ì#mZu˜¢&³/ëä1æý/t“Yäkô¾_8˜öå 32åùEäÉW¨ìv‹oˆúù^Ø¢îP˜V1`s$é&YãÓ*×>¡ ùÔ@šŽ£ç¤”â‘^æ³ð›Ð/ ˜³ÊÔ@Î l6™!ѧÂ83ÎV &f’ÏÏ™¿M'[µŸ T)°à /£ÏÚŸfè&ÏÊ6o¡È6µŸgË "›1/óç]Ìn…Òͼâf‹ÚÂm.iíÿúØ y2 \¡6 Ê-^lééä·ÅV%“u“f¤|G[Õ?±ŽÞ",ît°ÊîA}Á¢õëdD`rx‹ ÙÕK¢m%-a?µÓÜ7£ù™î¨6o‰šÄáE ô¯ßê„,g|ÖÛYìñ\–=¯¯]ÇDÈAÉ­$7cÌæ6Ï$;8ÓU§öÖ(.Ú¬º€2sø ü?»G¤±´èã]X?BèVò?ZeZñˆ?Œ\âÅÕµˆBè^Ì2‹ÝM¡½ŠÊŽªRé{©ý÷|ÚÔ•!Çø,½À[\?€Ioî¹Åù–V$h¥ÂŠ f…ÜúЗÐÝš¿ûÐF¢T "‡‹Ioõíhr>(I5²Ï}[Ü âlùÿz£G)œWã€óãØ£ÍWÜûÿ¸·ˆqYÑѹ.«ä)éÆï–õp,š%€š4§ëê34(ÒÙ‚&%A¶'OR–¶a:äÿj›(w̓”VšÉÒÒÓñL³ÚùÚ¤(Щ=ïËÑâ#l”c•Cfß)”U#½."µën o§ŸýM×C”À&púWµ²€á~„`ª_—ÛßEÓGjIPbÞnë5òó·Ž´/¦Uzê$$Áð7~ÉAS‡½Æ§h-'¡Oómãh’DrYãMUÆ>üŸ8¹=–$¨à&¢ªAïg=®;ÁÓ¯Q¸—6—ÎÍzàÅé£YŒ·¿TU47¾4ÿv`£U Ïö<ÎRô:é5–Â!¿?¶‘=rPByÅA`°OÿJóièˆl žªi•Bfù3_”ÉM,¦ª=ãò¤k‚€*…¥•"®W@i¨OäÓQÏdö¾F°æJ„t €™ûÖSê=™mœ8s›wÂÚn9Ò}àŒm7ëî´™îMJ¿oi7ûLg†à&u缟²pðâðY0è(v~ù#§iÀLZí}¨Ø®â˜ï»ìo m²× Ž‚÷ óZ¬øoû) ¶’.;ï¯ÃFÀØ.A^:ŒWe÷l"ÅûJqá l/Jbè•p£&ŽÄZ~ÛQ¨ó$2wn;šŸ <Þ;•Ž“-’\ÿ爡´­õš¢Æ+f?ï5³Ä×n9ˆ(™ùbݺÙFSó-¦ÔGI˜yw‰Òñô,ÄÀÚA-NpAår¿€lR÷ävËaÊf—dr½Ý³½?˜yÒ$UõñÒJ,9 ýÙ¡ÿ‡æ ÙÔHòpq_©ÿÜo|iµeC¤wÅÏR³=œ¼R޾ fÍ¢ŽƒhW#{]ö_”.€"2Ã×Ǻ‹ïÎ$JïÆ ‚ÿš/Aå/ôOaÑ—Èô3ï€îwAµ›X÷NŽÉ€Ý*;Õ%î½Ï:º¡÷èpaeG(v«†ô+”+³vϬ>`q~ ñ,>oY8ûÉqÏþÍ{Š¢ ™µóÄײ0ù1h{0Œºg"^ƒdIçKË1 £bGÉÍ­µÇïÉq*ÚØËKl lö]@;ð¨ù)_/øÏÛþ Ù•)Ï–RW¥€¸I`ÊËgB8}/â©*ÐÌÇQxÓƒ±*å§[¿cÅ}³ˆ#M$äýržçß¿âtjزyÿ™qÌ»>f÷±ä°ì?£öÇÃ_:áñ^^U3Zêþº‹ÈÉ=³û×m«ð<¢:©º"›=,q°A•z(‰6z1¶W±Ùæ4ݘ9¢G%ïFd¨È-‡D3Ú½vÂé´š,è¼ycç|}‹Û…d,þ[m\mtBõt()Þ",£(Ášê•¡S74§,°âŒÉS:N_¦cKóµ 6¼ï˜þWð!¾Ë[¦}«µ ÁàÜDqÔÜýŸãó(¢Ö3`, sb]Ú #‹ej`‹ÝåDZ~y¾z!IŠ~n-a#W?ðNÏE¾Ø*itíÎÐênò{×Ïp7 CS8 ç쟄±„׳V“àPðT—Ò˜\)·„îZ¢$̱jQ5ùüì¤ÈÚ?ÈyAÞ\ù+´’­4Sâà6ñ°Cãà\½ï¾:]ù×7”QÜVƤۘû—7À_>@ä×К£ÕÎ&H³Ž(ÚrD5ûŸ‚–Ó;s@è-0¥Pmþú¬¡I}çlxpÑG"nÓ#4<>è<ÔèX0y vƒÔˆFE’IYKýÈ/ƒ?}ÆGc¤åñ}qEó*Ρ3ø€ÎWͦѫì¥çHþòfã¤JŠÆ.^ïGN«_ñm)­ø˜g€§Vv¨ðfëäqrÚ ^”ª®FlJo«×»¥$첞‘›å¤Â34oÁϦ6Kõ’€EJ¾¿ÿq‘€YàœQW©ë,ë=£õ^á{½brå)êüg¶¸[ñD¤±»Ì»úž"*R)"õÀ“¬Xv<•øb=ß„#¬ ¦'ƒæõ¤#‹šIžé@Új”ˆÒAù•ïP•Ç©¾<8‚§W{DüUq¦˜ˆlQaTÍßQ<ó¿#μ+¥)¹§.®®äÂßJG",Æ4 ¾Lð:í²Ý­‹äŠXuÚìuv!h÷ZþSe(É<‰ÛÎÒs~³¦éÐrDþ Ô‰õgXæŸÎ< ÿ8§u|¦Ï­aÀ2ßpayÂBÖÉÆÄÍ4n.¹4Ä#ã¦þày”Ô@Ëm§ð½žïýU­QGO‘uÖVKM_34᯴NTQqÿ'‡´ç& éݾFƒÍ-Qà=V—Z*̯ñkœK5EWè) Ó§Њ~›”¼nVݑϗz¨b«8_ëûšÚ¹b²rö‚ÄŸ¶s„õgH ô¯@ÄÕqiX ˜8 ô[–aqu—aô+…PqDP÷´µ1ÖÎÜñ¸ëÀ©(û©á?×X²îßóü_HåD<ú¾‘¿fÿ”Ô®ré4¼Õúƒãì–`”ìçb ¦ÏäâÓÌA­OA½1¬I”‰¯$# É®$-yÆ•3ëˆR&>PuìZß QÄG'ø’"³ù–e˜ôX#%y³Qþû ü“"d^æ:bñæ”$ù=ÞZ 逶›î¡µire|dXšsTÌlK9ƒ¥PU"vˆ•˜ãÂ󨩣ì]…óbë¤'^óÕÙÜ–‹:}Öq+¡áèÑÄ{9M¿ø‡Ô†ÍG2K6Äë©Y>PÓRùá*™nŠ»¼ ¤Âzû¯ÏÁú|‘éF ÿ3m ³µ‘¾ÿŒ“ù+©3¦ À- 6ºÆ©¦t,"è™ÆVJÍß6$½”Ý÷;gv˜BÑ9~zcÕœeÒ­Õ±{u#/ÉxÈ:»'@¼g\âP¤ò¿j‹kyÑÀ8—ýEéZt„ @ÂëöVÓ_H+ê©=ÿ¡YÅyþjnúÇXù±¨­å¨ƒˆEÏ៵+‡„ÐÛJ› ûVYÂ\oÁ=ûv+ÞÍó£~2 3ñ/ý `-ÒïB‘Có½m㿹¿Ðˆ+Ö’%V­Ýnìѹºr§hfGÄ YHÞ‹,Àªã3Ó‚ÆN<#s‚ÿ(ñlùù¥ìL» Y²ŽH´™—u"}8ÇQÂ0ÃvgJH´ÏmµÙ™ MO\;s¶X6ëçì€)—ù™âC?­ê…©ÁÖ*%#Š ô® u±µše‚Á8ðþòs œ‰N½ãˆ…vsbÏø'ùç”Æ)Ìzºâ­[ýÓºçï®*.‚6t‰ûúëh‘OÐCóHƒiV •ï’ ‘Ém‘œ£²”lØ]X“d,7"=æ4ÀŠ ì~%ÉÍ£™ÚüÓŽZªŃ«?†khÝB䉑CV½‹g°¥…:ÚŸhßñãóî‰Öp1ˆä×±¬¥pªÙÊdÔçÛ¡k^êéj•$g`ê‚»»22Ç«—Ñ =ꂵ<½´5é¸GQÔRWRäÎ’…ˆ%ºuKˆ´Ló•ŸÒÞYn×B±¢‘îË—JCpÎkQ3^ïÓxƒ{;X,½R>‰ŒEk1kl–á—ÃÕ-J±j<'DÎa»–)Ø®VL§gßÊþ¶•Æ=I î&éÓ® Ë|¹ûÇ*i9Qäkñ˜2j…ðWP‘I~òñ#Q‰5°sÂÉUºüîçŸìŒyFSߌ)¨t: ÄsÁ¿R½ìb$üˆÀ¯ÄJuY°i÷ç9ÍC÷ª+½½¶õ ›3ts <Õè­6qÙÌ?­zµ[Œ€¿‘oDÃ2(’«Ý¹/4N%æíº'j—R;yÉvÜmš©ñR<4X¼ ã'GÁç˜=%ô:¤G‘˜ñbp2ѲëöËŠ5ñó?ÜùUŒq¾Õ\>èŠ Ãjh,¨áì-:5•P¸­ÝùâìÏQpºIÀ´å-ûäûÔ‚–ýö—anÄ2Ž”‹’Ižk«IjjþÜÇñ·¼ÌÐå§’ÊçŠÎ!6>ULðB¤#¦my‰)̬ëK1Û¼…Ê”+”gàTŽþßqžEÜ ²½±~Íöw)'QƒŒ“bUƒ¿Ñ-/Äìoaëô¤ЗOÏy!ÿ8î§Ê\:¥Ú+ål ÅËü`i§œÇLtêð)¿t|¬¤αó+N#t¯á+«¢÷[. îWξŠoqPxʹ}©º3’EÃ:©óÁCÖ(„Wô@CÝh ,üìH¶ÀœÖ[´4žÎõáF oTÍ<@xX*Ï}@5Ètg{¾—Lp†ÅRìÊBju¼pn3cmWËKd|¾òm$¾C‹}†¶YM˜Î¨äx)ügŽª`ÀÎÅŸß?À}”[,8Úzª bÂ8`_=%ÄòNÔ1ïÉÆ´¦­NY^F ®NDy}s¢^ùËq$[ßÜ~††wˆÂ^²¨»ždá µ¸àT@¬Eþ¨8©¢'ílíßoö΃fø×Mƒ˜P¦~¾h"HßýòÐ0ÉÎ@ƒ[ozå_ÕDÕ˜D4þj ž„Åi‰É?²æ*•‰BxÔAMãÊÙ Ý×”Ãð|þ»¡÷­Þô´Ž„NðЦ-åHkëmÕ›Æ?¡Ù¸úÎ:_¸e¥Ëç¶FǦÙH\xªT)þ­î§û4óx5¶·F¦r'ÔЯƒÎahÁ¼ï+©Œ¿{²Tåà „-Ö¶‡SŽ× ufÍ ž:ÎñøõÌ"΀õÏ:9ÞŒ‘±Zñš„ù*€ßí"Æyy,v‡®Qó0.ô0¥ê[.â¼3ÂCZµ‹x|š¬ÿáØ*ŠŠ@WÒ QF3Fî:Œ¤9P0RÖ†?¹ޤiø¯¼ÄÆlXŸö®wšËU gcLÝÌØŠ”Dšïú³$¨“ÄVåòìiJ­À¶`?d|˜J©…KeugS'¹âÆš%x6ç)FÛ *$Di£!ê{œª®V©>Anz·&|³¿3tØ3)þ?üðÜØŠ´ÜÆ­`±EKFþöqÀ温’è—é(tiEU¿BA'ÑhHÖ2O „mÍØm r Qú§Ç|zŒUœAAFý*bJ4,3\wøâ¾Ÿª+fQ @wuX†jc&Ÿ¾’ðå)‚”¯‹Ìö½øò¡.€åõ“¢i¾j„3|ü¾Oô˜–©2¼ð¯|$r\¹ÿõ÷» F±Yû¯¼`ÆifRçT‚»Ñçé?æÆC.;KŠPÐgæÆBoÌgQ±K9g!QªÔ³t9âiؤ)VME9Ýÿ1³ pZ-d£J· Ò¦ÕˆàQà8*‹òŸ2Ýã™xGûòí¾¦9dŽDÛgþõ ³”&Ê»ž-ÿʉÈðl<¤&·§#XjùýižÚc%Ñ”M¸ÂÄC:-øE™èÊ¥^7w˜æRUù$0BœóLæ?º?î .2RioÕ$$¸•Ù‘âö€™.ÜÈ´óÒôÞÙë¿ÊÀ9‹¶Ð5&E\S’V¤óââ0Ì)L!ENiP”¦6k=õ&$—~­…¬ç) ™(›b ø–¾öúÁ1_p‹ùm0—¶sÜ¢9)ìR^ˆíº¼BÃ)‚2‰3áô?b`!ìˆ|)@iÜDo­[<Ýô¯—‡ÆI=t‰û8Ùô%  w]fÑTªMö2g–@ÕÚh½û•3í~‹~ ;= ×øUÅî.£¸RÐ`_.;Š;“w£ÈŒOe€·ì$Ȫ)3Ñp4; §ô6¸Ú‚Š9}9*ʉ¡Á„b±hÒ .yãSڷ׌d,:eæ`ç£ÒlgÔV¥&*B†B5†3%|¦‘q:ÎTýyZåS--wŸ|×ÈbP·–«÷“úô™¨‚ä´)Ñ”oûèÇ| §·94N—Wù•ÓŠ ZÈ¥< hòŽþKTW™F†•ö{U«Ðî |T©y9R·ì^ëg#"nqe©tRu¹šÚã}K0QÄÀ²*ä*Yò¨Ô™š‚'à!ò„x0j]J~ m ÍënSÌêÛæ'yEZdzÓ‘I<žwÃÝŽ²9 iŠJ}׌»ÅvpøŒV‹³Û¡iž §DŒ4c¸²¸¨é$$°1´ŽÍ<æ“]J%œ©O5îø‰JmY¯çÌýx„ŠT¹9âryˆs Ý÷&ú„ ôsìªHßJæv´¨¤†rr‘9Ì6ÅÁœÏ`4…ÍPNf7¬äË3€Bfk=äU¶MB6£š²b\ˆSÌl>ÅÀîŽåËñ ÈÞ³‹ó|$}ße³ˆ¨ÞÃ[æÿRXsÙú1¬dï ØpyÚ(¢§„ÜèZƒãÅó7ïæëËòvša¸[ú´r½ý ¯Ä‚ZÍ·)e™j©:~ö7úaI(¹}?FoaÕŽV¶Nú^£ç›Zéb?–ES­–yÕAÍÉúÞpËjx$]’:¹ßml”{BwÝZ­™ž” m„^.Ó ‹€×Š÷žz3êÜærXFï#;ºÊ"$_ÍäÇW­e¨Í­„é¡"§öŸjÙ¢ŠGpßâ°ñXã'\`ù”ñÞc°ÐSü\Âñòˆ‡¤Š«>5ÁälçX Ó3ä« 3X­Sæðl:í:½­!8pÔ&rØ9Kz…ùÆtcä½§=¼’Ô¡Ç4ª‹)&W‚¿eä‰òW GPqûòï|Àž¾´îwú?;^Sõª;ÛÐÝ ê¤¡ô›b;ÅGüÕæ”ô¸Í¡ö¹»ö¦fñHcárõ )Œ£ˆ0Ub‚^Hú–Ù«”:@ñdõóôl"ïaY½&›Ó€…?Vþ(ŠbXBû_ö-¢È%¼.|@Î#G"ðólŒãê!ä_‚˜$<¹¡ù÷^Cn¬k<År~äCý'â ÚgŽ0à •°,¯pEÂð½2È*Ç“7#y“ ë*Y|œ†z·leíäÍ7˜–‘Cì|2èg•ÙiMPǯ>ààxÊ%ˆÄ±š«¡?i´{_PL«!‡Õ©ÍUhIÙ¡âѰ*ó«qgFñªr9 kÔŒŸ!OÖ¿¦a»R˜™kcy÷Zíø¬eõÚ‡»Ûñ›'W·{ñCAƒP—NÄ14<Í}ò`kó„ŸûÃh%#õöªäþ´¬Ôûy[²ûjУ%ÁÓ†ñ6xöa}ð\HųŠUðoÜÔz™}~Zr$¡^ÛüQà`)¬?YÆ»ä· ÕìbLŠfF5¨ñ+´ØÃK÷Î:KàÔ;ÒÑ.ïWæÎ[Uh7ky.Ʀ_Õæ/êŸ# ’ã¶šTV¹Ô‚*¥.tO¥·ópä¸%ÄÖ4–fŸi Í‚/á$›F©w§¦ÐŠžÃx÷±óÛ²6‰'âÔ™g\õ[®¶°f¶çèÌ]/Aàó$OÞ—HãUB!å;ýÉfÆ(ë…ö3Û£oRH;Pr¯Â"LÆQçìxHZ1•Òêôd áQËfgÑÌŽ:Žé~šr!ü=~Š£KcõjÙm1ãà‚«e,ÉkvûÁ~"¹è˜×Ÿÿ:²ù>ÆÍ|á G¬€ó\ïM:Ë*/ïO|ªkI2˜Å›‡ŸMe&]Zcgd’×túTów>Æ£ñ¸Œ&¸1«¹‹ïiO9Õ·J¨AÆ Ã:Ê~K²• Ág#¡¿ú›ÐâútÔ×B›ýRà×$ž[í2_hc¹cÙ_=ç<µ*šG‡LÒ–øz˜r9 ÓÄÉ‘c ä¼¹A¤o ­PÈͶ©÷l9ÿé’Óž”tîOño¹~=5FrúÜ—½­ðõsCöÚ2Uq“—øˆ•á O”ùX^—ØÄHp CgäL';t^œ3ÒñÇ‘˜½Q…­¥ÛN:TJŸ¢˜a“ü©÷XÈ™µwiNõ%€²Þà'H k>œ¥»œu®Ž>N$8j›ŸÒ¶9¶H@)ÜQÄ×›µd s‰æE¿é†õ‡:ðjž­%†‡R¾ô%~ƒ«<<>y×ù‹,Ê*"†J§øÏï]'¤Ô?'5íÿòŒ<Ë·""†yQß’n‹6%vÆ“–É$t óDes–€4AÀÓ\k OŽÑíÛÖ†XyU‘Kíì›yoÜ->pÍF¾¯ñó`úXDéDUó´?üFôÖ÷e°±°«—"|q²?káï§P«-Ï‘þÚj³§®€ÿuV€½À÷ûC¯¡–œ\ëKk¹«‰»Ò?ü`Îÿ•@Ä–K}ÿi(ÀOL¹‰Õ•á'Í‹h3ôø˜æŒ‹½{P"¶ðlðu=NÀÒ¹ÕôôFÿþ4~¶Ö•l¹=\€õ¯Ða?J“•’•cߎ-°Ü$4ª½F¢zÕîÉ'I–úó:†K{Ø59,§\6ÞÎо˜p“nzÁf«<áðl/p7zª«häCìGz@G†° ÊpÏ07_ñ¦<_OÔAuë¿J8Ä—){ItÉ (âejò¾‰n¾kBJ#ÚYª\:Oc¥ÂØÕ>Š%S.BËì‚ü¬xÁæ‹ 5o…6IØ2Ê}²')Õ‰º¹o)£À“Fµ axäÕ|5Ú‚†f…g´Ç§üùö4½èå¸ +yW+?CL gæ,)ì{uU(müPÀjnãª#Öš¹C¿Á÷øÂsÅÀüõ¡hk-ç¿“Zi¶¦Sy½np™> 'uˆÚ§0ò™@NDKcüV :§ø2À0 ÷cÄëÌC‹ÔÌÏa\ts™ã³s¶Iã é'߉¹SYØÇjäbdqý+ìÓá¯õÒyûÒêÐå/v^ÙÜ`–{1ËßSD*… … ²hlÇêÍ“e²\sMI‡æÛú©‰ÏwW/•Þ™kR†(ù¼I¹Ja/9Ÿ~é¥O‘™šhÏ$n ‚£áç…pMÑǞIJ¶¯87‹æ£&dm;'ëU—ÐiÉ6[D tÛÁ{[€‡5…`‘ÿNž>zN¼ • ž_N^và›å»ËƒZU+ø£ŸY6Ÿ€jW§¥(BN”Ú•íå·_ Ó¦›â^ ¹ò{GDµÀÚu®ÿÝ¡Ì×Ï«Ê,ôÀ{¼´]0ÓR(æø_%ê¡xâ#ôaK‚®^‚6†DÈ8%{½`…©)¸Øê¾¢ÁèZ$ÂRÃì"¾Z÷ˆÅEÔwM1›“DN²â¡Åÿ[¾¬ßTOp\z+ñÂð–lÂê8Ì]ú]“‡W\¥+ð7Úª=¹jÈ»ž’úFn`”Òü-vq®µ¾:%ay@"úvÛ'î@R˜o#P}2%9¿~VµÖÞ.eNÊ¥Š¿Ó"70Ò¾e`1RªX`‹« M‘&ªÇö’&¶#@žšWdžà•‡î½ÆãŸXù©.ö©2VPE=ÈȰ"ž Ý¸§3gÓtbþª$m^e+/„“i+Ý(Áß‚JËJ^Èåï’jq:A¥ÒJ”SZõ2íwõ¼ª¡wh>ä2 q§½FÛÙ°gŸæ7@è'[$tÍ 8Pvª¼BàÀ¥‹—aM­áF2<žl4àÿåó÷ÐÖ¦é§åtÛµO÷KE¸úµüâü™Å[b<ÿ¤+ú³È‘J¯gÆ(SŽ}EoPíÕ5ú‘¼ÂKéÖ†*C£ƒ·¼€Nî‘ÚáåE‡û€‘ jPefù׎žÍJtYºpÅÀ-ž8Ч\™öóÚ•S¡‘× ËÙfÏînè½Î}ÁŒZѾ ‹‘s#ï0È„a®ö_Ô úî@-µ~i°Oy0hƒÝÊþ&fµxZúŒéâJ¿:ólHïzHÚ‰$w«Õ$Œ†? ¿~=§Á,?‰kð¤†Y¦÷ ƒã¤Ip±hH› ,wR³?þ®UüJ#¸ÿfuˆ:drd²áþ#j)dЃ8Ï­®ƒ+… a‘~ÆÐ$õȨËò^GQÅÃÙ˱ãH÷/3Û¬’êÙÓœ˜ISï…»’C6 O*o!…õ—á–ô(çΆ{ ›%/þk/©m*»·zA¯ìÅDï½6g³Ï«´‚(HÒá@}ØVÍ’ 0¿]ù‡l<>ÛOvæjüŸ¨ØÂ¤¦&.M*,²ma=PHw“a2²–*û• düÖþ(Ó¼"f ø@Á7Ÿ½²÷?âã4Kc¿ÑJx]ESiœ¡¾ùõµ`óÌVšÞº`üÐ-ç1¹·e›ÿJõNvïÎõËÒ=¥d7 <»çá^a‡Ú¾Þ5ûwC¯ ÅÅþ#|àF=:ÄÚÛ=†ðåñ ª…Ð(/:>Ù…NŒÄùÊ®i_´<>%€—ÑÄìÑ# yZñg˜%}Œ'õPûá“>˜¯¶XšâdÒ—.TUìáØõo¶³-ß¶i ”¦kÃ~Û%´ÛÄ­ïb—-î—)¤Åãõ9ª±û‹:'} ÛJfX¯ìÆùøÊsêÅw»~ˆðÒî®}ôÕÔ /Ì"™øç.£ËžOìu&/¬šÇñÞïpŠôŸuËAN<‡ôšVy/Â¼Š¹ª½lšˆeQ‘ý,qXÏðCîê3jbÒp²Ê‰—æUÎó+›­»• ði¿åbŽS–~ÅNb"pMÐÚÂè±*x`Xfð7¸ºÜLJjh%eõ[}Àunó9‰Ë+ב ežd_…߸¦ˆ£TéÀ7ªåáó¯m‘Y­‡=]3ݧIE*‡fûûÜé i¾]Â¥¿.×®lÍ¢o¤0ôo\ïÙ89 ×쥦ȹŽj®ªE/G[W¸c ÏDa žÒm§Ýo±\êÇ)Ž×¥ E‡„¡‰Y`®K‚³…"k’dìl?(eD¸ò0E®urð×FË'¯ï+ÌMdeéNcTùØ4Pù˜ #9×gU´ÏŽÌ¹C½W$×N÷y¨ T(³¬”¨T[Iÿ‘Ç¡¼Søêº¨½r³ÔoL]g_ Êb}‘ZH{Æ!ØKºL@¥ \ÑÙJ½s!ô(Ø÷¼EÏéö!BR°ÞßâÔ·™gëV¶ëΘþ3“>Q«óñàÐg±pð»H=اfªhxžÔXCfКê5FH<‘ó¥ca¡¾T{ÕrLîeÆË¼(!Ùåj>]&”ülèBOóªôŒL’6ÏáF•>[ÊM¡´ü±¯»û'–¾,5nŠÚWY§Ó0>Å»JNžQöÁÁÚ¥Ú@~Ož†òçÑÏG)¾ªîįrN½/¯ÑLÁŽç¶¦‡»ôNVoüÞ5~Óöõo´>çrª^£éÕ“9…SÚøŒ²xÑ˲.;HÉÈmH'ŠnEØÉ^Ķ#”K.^þ#•@„¬¾Ö¸»%•æË¿uWê›É tmº‘ÎEIŠƒï,×n‰vt-oAáfTSð(›%]À­ôQÂ|_iÈdX‚u:C4A<ßúÒJNÉPr6Z^ð¶X2u­*Ó“hù£ÑÑsºˆy”Iÿˆ~YcÀ‰Lù5ádä $<VS/„]A è[d{€fÈ´>yD™QhØG>KSÈ©JRi:嫱Ú:æ­ KHæ Xœ ¡ÕETl[w ƒ§e¼xì‹UÇ.E0]š}ÏBx¨îg,ÀŒ^$|Õ‘Ù…’¨Ý$¥°Ã°oJ“7W'š]ŸÃ¿’MyÿÙCƒ7Äabžl]‚ÿTJÀÄ#ÕL®¾L)W &]Íù ¦\3 æ`·?Å?õ|zò­Ê¬ú¯ŠÚápˆúm0@z/;Åå–š6ÃîÆDa \’ÂÐnòøÍcåú ¡Qæ¯æÍ¦‚KÓÈœ·ú¹þZïaØjÖ婼ÕPâm~Cí“z(qo'ÃÝT©A9w¥á¸Û½=oŽ ]š|Eذº\¦+a*¬H)4ÆO?¹è]~ÐTï¬Ò"Khv„£¾ÁbÆ0“k1¢¬‡½8R—zÍ’&”ôS³–)â*l褙¡6`í8Ñ`æÄ ­S-it¥Ì?xi÷ŽYÔ0ˆPF¾P¸À¨è*Z•®qblÒfœ­í–THê!5èeÅ.czuÀ·¼rÒ&'¼¢²¡ùꬾپÚU=Qõ[öƒÃcÛ¡½ér×NbÛ¯Ð8æu)Ò{¸Q¾„ѱ í©YZñ°¸ÛãR…}ÎÞ>F¥ý:)Ë%´/>QæLññgižú÷¿Jkq(/~‡’ºbÅï‘ÖI@«`lzBËØ¤ìæºî.(Èl•Øa_’Æm…Ø~d™ ¶ ¨<2*³í}$ÛZ‡vhiaEB—0ï®ß"ê)þöDŽƲç8¡Mscajn9ØÌã9bHO)%Áè{"/ *­ù½4uTîFÒùU+Œ!`º†þ*vf3!”Õöì–SJ»$>ñ+ö…»ÐžhÅïíòʵ…Ìl¯t;péñÝsqL‹Ìwµ{ÜG+Ï!¡ÉNå×õuÀyÀ½˜!c(CzâP+ÙPLR°®dQ ÿ¬²W€mxýÒä¿¢2ˆúœ—Ô‘#à‚æÜñ–Ýæ vÛ’ŸrûÌï ~¬Õ˜¥Ë°2î‘âê”6¹<{Hņ![îò9gLYb N;.¡Uk·GªQö_KµºSå&|«NŽ×tGX¹ìb¡â•ÕžüPË·ëŒÈ-笖3|6žJ[»\bÎ>ËNÎj9žÑM°[ÒÁyŠjƒèºo@æ#Ûƒ7yÂ~ÂlÑ­5Ï·ÀSâ5KšÀÁ$Œ_”6¸“ZÓ8%͸O™Xå3u‘à5ûŸ4~Ó—ÑcÕÑ%HÍ…«–ö<9l¯¬‚l9ú¦·q~jGÑr¾PÕÊæÓ\ Ü–™ÂÀ´jƒ+Ñ(ü!öØŽv° ûð­Ô }‘¼{º(½ý• ¢Í£çY‚—¬‚Jñð@@Årÿ,v­Ç-ª†ŽK>’‰Š1ŒŠ•VçÕðc,u^c«?ˆ6N=ÉKJ8¶W9~LB´8œRéáh:×òX>ÜÅšKS±Üö¡‰¦U¶J,@UÁYû¹º>¬êÓŠA:`Á»¢}±âÑ ·†°ß3˜v X[ãàM~²éŸC½LžãÍ·¦´Uõ£ô!<¿ÃUo^3²OØikuõœÀˆ)JB÷@E6ïíÍ€)”øM žíñÏn*ËÏ  j-åˆ*4ñQë¹ð(Ôf3qÚØ •ãû³¥0ðd! ÙÍX\Õ‹¥>¦G½KSÿþó<—6ìGÁ«8]bê™À3O8JCÜÎøÅÍ_c€¶¿5>1‚  ‡àÁ‹øSsþ f1ÓýoL­¬u¢b©'>ûJÿ¬ÿ)yHK Épí¶Ÿ‘"qÎ-1ÖU2pCÚÏTHR¶î±ËîgêÕà–¶æk• @l–ô³þ¶Ÿ÷D”\äÇGî âGq W*/pë~ÄíY(–$9Rî–XÊyÒ{wñŒ†«Ý‡ª A?Ôì¢ - “PeÒÊß›†#7!o%‰Jï§æ±<‹˜…èw˜ Ï%wÓ©~JúC¥>öÈæžäçÖ [s=ôOÆóùD#µj/ùÐQÝ\Í»sJ3ƒÐaÙéHžï]ß…¯¼Z Øgµ ²ÛEiœ÷qü_È ¤ô¨W2µç»J+4‚lÕ÷/G0ö'ÝÂùã”`®þ~>mÀG•Wü«}Œè©Nêý÷ôÐùûKßâ¼*W=)M¿YH]± ô@Ì…gN&:å­@g47±ïLpÍÈZб#ƒƒ=³[FâÅæ¬é6•³V°ƒì>Ú¦žQL¬RÅ Ïå¬ ^˜Nt·ÙÆô¿ø±ºÅ8ÑkNþÜUs>â/ˆ_;kP†Ct1VH ÑZþ[³B}8ô2uƒs7ŠÖ =èËNa-äù6kZ! ôÍê]Ÿ]c³GÄRDÇÍd’î¢÷ã,0+›nË[Š,Ø7 [¿·="N¦ q®ºÇ±÷ßÜH™}Äz S6SÞ¤KÅ,á˜.fÉ€‚šájï² /œQÙVm€mʉø-ä³ã§=½óIs’bŒ®Þ<2ÈE3“õ\9­äw^dË,€ñ!t—µiø)vm,‡¦[«S›"Î1Ÿ_¿ÜŸý¤Jnüªg‰XéȹZf4ß§ä=õ·34 «‚É•²î8]zΣ?™e ¢=‹¯-Þ)äå.žÎ$qý@ÃQ±ùD¥¡+êŸâø¬Žxë¡v¤Øk˜KÓ¼î ¾!Œ–@ͤømÙôFåëóø`{€A…‹[¤?—ãǨ݊_À…Ë¥Š^ŠËÜ­_|“Ïol£ëý£4ù%£ìÇÚœT²Êâêä« YñeYbºxþB &­Œñ“%‹, ¬®‘môñrE­âa8ÒƒÒ!~/¼Ë—`Œ&SÉeýÍjlEzÄ{E|ÎqÍ 3+wóèýÐñ÷aHsòÏ{ÿê@“ äbÂ}YýkP5³bÉÌÉ= Y?Fÿp×s“)ص…’M÷qœ´,)4lf$0ÚmžóGÖ<=áæ5po ^¿Üiôl²O7å#E%‡UÈImïËj{OSÈ\=/JÓÒœŽs’¢»¤Ì’?@õˤa{PBܸXwÁÖêQ¢&ùúÈóñços,Š‘­MªÏUNU•C§^$5kT<3‡u?´,2µCÍbŸ]Ó­Y‡½þVó§>%´·ìj?x×¢í÷B7Ç0Ò!’^õpûSBýŽÜÏáó»ªNòÀUô+Æj(Ù|¨¤•^ÇòØ»K3Ï´ ³¤ö â%I«º',†êq?»|#ÝxG¿£mš”éèì¥ ¡•åjœûyÈ¡„ RÆí£OÆ>Z\W|Ã:£?ls4¦5R Ïƒô•dYù5¼¬í\ÌkÛW³\¤¡î¯‹€Öhvs%®jýiZ~óÊ‚w²¿~©e/.|®<²ŒHð"á«§ÑleÉl‡õHÈq=ÅŸI£óÉÁÜ™uüÛp ùæ_oN ¥ó¹m 9†k T+MÎÆi-ˆâÌ ƒý3ͰrdiYç6Z©|‰·c,e;†sV¿Ö.…ÂÆgƒ_þUcæ[ Çñ”/)e¾dŠyw6Ë®ä)O©¿dÑh¿dfU3‡¦˜óžƒ$µ¹!„Vè¼—03þÈE²Ï’§gY¨ tì•TÔ¬]eJ¿9 û0)¹ ¸FQüvÂäô¹,x%ÊU2&“ÉgnpÀÄžÂt²¿î ûrµÄLº#´×ùV÷šL–åÒãÊßë)«ú$Y·”޲žÝ,—Ó€Û—m´‚þ`•ëa,†wÇö’)Ó\t܃ÒÀï¶¶*6ÂrY Ì…\¦çLo:õ(¬,Ù<»TG²Ë/£@¼ÚV&x¶½ç*šãN­Mˆ¿  zžQªl°²›,Ýv ˆ” È‚›«l>£›e«E‰Hß·Ñ´F•f8ó‚Ì×< …yÃà$:vW¤™L7Á¬ÜÙ.¼è\O1w¾“ˆ"x™¨,<ÆË‡^^Où 3¥1 <é'åúÚŽ…²ìx}ar8Jø š) 9¡tk{R•§<å«ölEÈxЫ:?°s†ZÝ7B‚-öÕ’ˆv¸ŠÂå¾ 4TÁà˜e )8­¼4OE„¹8ÅúMÒãà‹?œ¦\ yW¨‰Õ,¬´6¹|c¨Ð"¯·E§<•±JNáPy—]§‰E¹ÒçÄÍA:ñGÝ©jüƒjNdA.ñ2+³ Š[ur+…d:tÁFœKS@ÔÞ€ýºÆéŸ½ês‡^PU³k†½Ó´[.¤í¶ß­N̵BtùÃû$i™ðž_ÔÃ]2:\ï?ºVùHÏ >¶w¹Œ#ÜE&»“Pú3cŠ@D—Îlã¨Ý—Ñ…2Ö¯š³Ìª2D<§'I©XCùêü¶®Æÿ¼ N,;ƒ6šÆ—ô; ¿‰Kh'øïŸ\í°*6ç?`497@eïM$rÍFh'ÃP­Êç9 …~<ß±éOñå1ø6e {Èz‹Ð™-!‹×ÙE¿w¦ß;éÙºÝFüøW1€ÝÕƒ¬Cã±¼¸Fu]8ÔFçÀGœ*¯±¾-¶£ý"16U,´eͶÿàmK8ï *ŽìW 9]g’õÖ[4M5Ô¼âBŒ Ž[apÐ'X¼÷·ž?(ôKËqŒ3óÍÿ¸õ«+ƨÛ2ÌîÑqÏ‹UîZÐUÚ)ÌøB¿ÔA«/ik)›«Èʪ±ÄÒÇOÕ]?òû£Ä’üÔu#y,˜ ÜUFãú¶ƒ fmãnLÜ.ýðü2´@¬oÄYÞZdyŸ»ÕמGûxȉ¯–1õtäSÛ5v¼°ŠN£—iä ­0fyôÒ¨Ýl×M¨§MÚ£æåª`±T%DìG Véûo¢šÃ:"®–›$J¶ŠZB,‹Tæ>¹¦£?ïÛæ ¨ý˜ë‘F²?òc 6ÔIÄÐìŸO .§FMö:|Ì% D’eôìÁÏÏ„yÃÿã¸Âë˜7P#&“s¤w/$ÏuH`gõ¡ºnwŠc=r¾`´pœ€o¹ ˆ~<Õ@¾9õ¤NÎÚ'¥Ð|“‹*ƒ:™NÎ&ê<<+¥!äo O~û©=а:Ïÿg{Ê¿ê¦×Èú'#:Ùµ#àpÇ“,[F 5g¶ñf4Æ’…eËIèö;Rtæv˜ÕõŠn»B‘±ÙÑÛw“)Bõ[ÊJ´ÓëŒqPûÐçjûIñ¤’©¤häÓQô˜&>/1Ëòé/° o&ƒW™µd-ý©½o{¿ˆÆ[Ê,nUê©c/³ˆ:Ûºmâª÷zÜ›^€›ã¢4=·ž½B†ÔY©`ø2ì¦þ~Jå…‰lø¯ÙÅ!rÈoŒ¾MÙ¬©ÍTp@|KN>çcºy6žg%iìy©€çyÈÞl̆µwÎËVØy‘ƒÃ'«÷—ÃoÃw^ùZ8ŒÒ¢¼g¦HûŠä?“¸½ÝúD”øJÃí GøÏQû³äº#½5‹¸ÅîÊ 5ÞÓ ©ûÿ»ˆJ|åÌ&dêGˆ2~awâyó*Ä1fìfèÆÒEÄ,wÏá¹ÕÌ[±Œ…e"â[<ƒ©Üë‚ø¾s{¡p o ¯oø¼À†ô—ÊÆ;ÿÁE.x+©«`¬ÖÙ$H'˜w×ÅÉ)$d‚—.òÇO@5ÍÔTË›q¸”NÇ)q†Ë©|WB9ÔH~¦ðg™r”H/rýWqgn éÁf¡ÚHò<#ô¤#ì¾³5´põ 7“ª‡÷.a'ÌyroV9às3¥ïSø•ü¦I¨²|º“µˆlˆˆ¨{÷R Uš,K‚Öݯ{¤dž‡ ½®h¨Äç[$ÓœDvJËoXTVàc‚“°®:BmVý+P¦  °½·]Êãœ7s’ñk6ú«P:¤Îz ÷Þnr‹ í¾Ð +ÉþGŽÚe¥Ö‰8uÊ Ãb`P`(öåî¦OÖ³¤gû4 N]k)(—6}o©º®Cë~—²rQ=Jó7—dËìUÏÙ«_âËV1¥­õJzÍoàsR ô?…ܼ\…Î;Å™ —y® t|tÎT^J8©àñÑuÏMñî¯h¨±ªÇoœ¡ÂÚ»™Íõzœ×þ¸w†( \år_³Hç5§2ïŸcá'Éàq[Çx þ2Úx’‘¤’aœ·Ð“žäÞ´ÎìñÈ!PÞ0 6«{Eí°‹Y?FwÇËÑ`šæwÎB‡óvÁ4Kyâ ‘ß~ªµñq†ºÎ˜Q¼œ’‘XVšüõÚ§0%œK«Wçé|——ÚW@iêìBÞüL'Z&’Óõ øEo¹ì>qáJ×=èÁ<~ÞeðB&ÿL°{9%Äá‚à1eý…÷Fm—yuË6“î­X_ ÐÏÈÔ¬&©@£zbÝ6B‚ùᱤš>˜›¡[+ä°˜*ŸŒ ¬ÂÁC‚¦êÉFŒ÷vÎí3Â~Š2-zÕ)ø mS±ª8Œr®-Ó :’žpjûߣ7p 'DŸF˜IÚ#ðrÅ (û9DtxU W¥MŒbeƒýÍö%IIµí±­ L»L¿jP[˜ ‹€Ç7²E[¶„¹p‡XãË9*Ø(®×þfAÛyƒÛ¨ ’r›7&†$µ&¹ ðç…ÄcO+H^…ŸO@=½·³Ó°‡oûCA ô9‚rh(¯eÁ¯ëšI©¿€Ún†ÖÐßÉéý5=§Y/ [©YŸMS˧ö‚„´USº ?yMÖl‰àq†VÇ[ÎŒRhúâñ—qMìÿîÐ=±‰_Õ?ˆÓÌý3Á6Nús_±f€® ^‡]¯)‘)%s.¡SMô¬ÐP)«9-ÕÑî ‚“Kæ¸KäÊå#8ûXW&½˜žr”ëHFÈ’´[™cÊùpú€é‡ vuFÍ KÛ¸•BÏYêË.1O„x Ì2×¹ÓeF¡y;p´KŸ‡3aUoVm_ÛX_­ $Óuæâ,²Ü×Ãæ°­jú“Q=éúv,žcüÆ”T®^õ¥Œ:UçŽ.üºÍ˜#ÎgMì*ŠÅÌû+gWŸªÊ Pþ6ägRŒ•)Í(þÑÑs•±¨³{ml‚R®¿Rq„RãF ¿Ò=ÕÓ…'òXãôzFÚ¶%qØ"uõ/‹‹Ûså"ZFRB~˜»v6.% 9Úïm#0Ó«iv¤ ž)ò¤ÃºêÐÆ§ •1}‰JÐU!¢`h®Öô©nµ™ø|O œ’û‚ï8ªšçûôÅN1 Ò>iw–•F#|íÇú§Q²f „C/ï% 3±à`ŠwþÄ:²KÞ5±í¬½‡Lc°ä:¬œú8 _ƒ™ÝÞhlÏUÈöO>=©‡P–´iRƒÑt y{ŽwX™³Ô—º¢R0ÈdŠÁdÒdO»ƒÜ£ ± è_,鉙ð§ŸÊ×c‹Fò*ò¡ý¯$/ ½)´ ùÙqĘÅQÚ"£2³-ñæ‰ÚG6 ÔD–Ô\¬ É\Z{²Žá›Ñؘ¥5#Ô§üfJ½͇¡ªzn U¿Ü’©øl8Ó†6¶^àG¨bÈTCͪÆ,“ú¿ZÄ”C>Ÿ¢R[ê‚•;ÉSK¹z$[]Ì‚|4ðäJV·Ë¬HTa?Ŧ¡àÁt(+#8v1*£¯£á••n­ﺘŒxâB2é¤m£®fÊíî±3ù`VB£Œ+‹©Ù´eö›UeÉíHòŸ‹ŸVÞ;dW«À¯Ü7 ¿fʳrE_ey“¹öªL%ëLLÛ×VâNÓ:û Sqo¸uýD!i2«rG‡ñ›N1€ zø%ÂSjÔñÞÂþoQÛÕ ÚŒNxE‹zVÉr|…®‚ lIÕ„fLw­Å™0ôLý—±çªyª Ÿ™?ý¡Ç”†Ãú1?#¾–n‘F'W%¨¦·(–”ÿ ÃÔä¥ýe? ä+ ;ž‰|&J9Y¥¡CTÇ:nçGR7 UhI[Å ´,br¡÷O‰ôsOŒešç:rõÉOIÀý‘Õ‘VÈN‘ÄÀÍ9Ä Õ/øJM ö;2#?ˆôíÆqŸ%7€üרæ6CBˆ“*`ošõ¤-wWöÎ4 û)N%ùTW9s;LoÒÓˆмl㋵mÉÿ÷ys ßÞÞò@ˆƒS¼<ä9?ØQ DðƒyʺæŸàúD[þ± ËÆ=³ 0ë†}JåÌj±P»”ÌWSîÚC0mÉ þæÐ¾ÛÌG€ÃÆ­”h€LœšÍDg+ª¡O¿”F†˜l9'ÜŠÛZ©0sÏÏ(Îòþ” _>A_Bó>ô'GMÏ7;u‘~žQ``途’:4Iòª¦$ÊÄ´/hÄFÍwp%ì†[FÏ‘t©”‚¶7ÝF}Áη4Gu!ãÌú o®;–Ä>ÐǪ5“4jŒêªGÊÀNH©ª[`ã•)VäËéä¿×c%š›¾þ×@ïC|+³*JVØ2Þ!ù}Ù‘]Ö¸©3#Õýä…S}»†›Œ_QRÙC ܽæÙqì¸WÉEÍvP:¢ˆÞ?m·’"g®\‚ ±%÷[v‰ ðm6_ãG³nš$„ɱÙr„Çåê’ÍŠöˆñ"ÕÓOkžÊC*3ì¬Ûc@åWA bÜ5Â?‰N©H,%7÷åÏFДˆŒ8êáSÉd‡"Nwé‰,ö[Š™¸ž¨…Òçwr­@*to<*«WùÔµ»¦¶ÍAë$AF3ŽZ¼—QHHA…ê*g¤YÜÈŽ3w½<{=¨²£Ap59­ÏS!ò5Ѓ‘hÒÏ»í)u-Z1 ,]"8õù²%ýÓ,vDžlK*¸®MCâ+ô€Ø\7N&³‡kqp÷B]¢úÀ*ë¿$飞¡5.D™<ôk‹ÒÏf&1òÖ ttùÁ•äšÆÀÐIªTì¸w\#Ÿ×ùX¼²È¶-î8…¢+s/h»˜Ib‚*f!-;¯àW”Øå„c}–óWûHJì~‘Úe¨6.‹´OúÝYæÚ—tÞ†¸Ó° ¨;Ã`Io~+-ë¨ÆæÏ¸æCÌÊ`ü1–+ŸhÚx#MÄžZVÚs} HºLt[´*[’{Nò¹+ëÙRšÌ$ëe2ºKmÑÖ^:ÿúuªd4ØM݇°êÙE6×é’äMA­ú2Юó%Ïþ船ˆ{&äX`(¦>´>º©Žó‚Õ§æoNÊcäòÍæ””±¨`åŠæü³˜`Waò%½¨6èµ#‹AˆÞ~rè¯_4~pCX€JÁyÚÝŠ(P—_ŒÑ ÙÇ@ ¿µHÃë)rn%5ûW³œ¾`â*7öÙ§ÇXók&†I°¢z\¹¢úÔ\ÑRU‚g”žYI”¼Çff À˜'Žû‡?¿¹©/ ŠÒSl->ki̸{¥<ÅÉû^Mñw%ÜHðUZWT绨þ4¹›€‚ñá¸j)cÇøc (µ¹Ýn`‘sÅzøWÌù~OgâZ\@–>ÃqŒÉÓQJ^²Cï)x„¦{7ô´¡ll¹êQxU±íÒJ®ÓY3^3•iœ3¡\áúN“ïñRgùg–¯:œÄë‡+Çgx.§Òï±O‘ò¸×È %²'Y¥£úîj¹j}hæä©hœm8mTm‡ÑnšÚ×QAg4ËzpÝí,$ ¦:Èðpm”ÿ$,çWÕ…È™IKˆÂÜbà;Ó:; 0OÙ•á4ï€û*Å‚ç÷%X¡ÝfÃs5¬ÞZh§—)¼8¦I=¾*{¤ò‡ì§Ø^ú²I5{ŠSqy}¯Õ0-ã+Ô ÐÚþJ ê횯bç Vä66«0Ó¶ˆ„ÉVvݯèÄ#c-m-L¯_#+(òVpžO ~ÁÞ4Їñ1MnNmÑ·õ"i0øW߯4ò‹§{ CJ÷Ö@‡ÄЋ 2i&q^ŽŒ%‹®†{Uæ¨snÙÕd`Dgx§'„³²EAÔ3;Bmv$„ŒPµJkDé8Ö]¹£Z,7-ˆnU";Ã"±¢Ã3 R.ì–’¾.6Ôë¡4­µÒEyZ#ÀrPßS •(éW3=5UÁ‘+q¿±}±K6™`>uhíN‚¢E¢æÉƒ ï mëËÄûŽ»)z:&ç@1ú%d€µÜÍÄ¥¬˜buOk–<¢¹ªpIíØäá?&çÄ|:h'׺#g¶dT="™)ô¿{<%3‹pÑéæT#^!]·õ㹡|”;yŒi ö «f ¨[Q²Q–smÂþåxauóÕÎÿÜœ7Ôº’÷:1ÔeÌ6ñ”—é0 퓸‚Ó—8— tW‡; ÷ ÑxÔÔYL¥Y·Gz –¸ ?øA²ú–-pRêQŒzÓ8çêjhj_òT`ÏÝ7Ö•¸ ƒ-q¿5(…çõdâ²3>S›·UE3Äi¿±P¶¯Ûõ“²0Éž ÷Zâü ¼Ëä»ÚÍ«O÷7è7–5•ÝÆÆíW3;uJ>ýy2’샖%zOÆu®®#]hi3_³&L.ÐâÌŽC“´w÷Öm0í£YØ£Yè$Èå¦àåp“@ú×.,{¶ácdwíâ€ñúÉÏý,lem¢ïëtQì(ü§yñ’ѬWoê’Rè‰}’‡Ã.øüW˜{ÜÉÙ#ø%]½o/``A|e”al¹™ædŽœfÔSÁ¨~»’ß24´¨ÙüEþ4Vñ{1÷-UõhÆ«·0ížð‹kØ‘7W×픾¥p‰VɶòÝ hçÞÝ“Á Llo‡é©j^èç”9‹]¥þ QUžQ&->¤þ­û²ˆXmº.ë/Æ6ãg"+`Q†¿f’ƒÅ÷hý_ÍBÀ#"w«¯¢òɨ—È«ê‘nV)è>æ5Ñ17Rèr†D¢,[ѸÇÁÆ(,ôz=È“–S¯¶Ï°:ϼQ Fô2 r :åñÚ ³êóø¡ž<•Qþ«ôAM×ÇO¸ä{ ³+ûòüÂ.ȪµÇ {T½·• _ÌüÊÙ 4ñ±°!4ävÙ2îR‚™yw߉Õo±0þÃ^’½^5 œiÂ_ÅsT7·{Y!IÌ5'Îÿ#Û¥jRßÑ‘j¯†ëð%¾èƒÖ~Srä/Û“ØŒÎ$ŽÖ~¿zMd?—z?žD!’ÆÀžÌ‡·0x)ß\–Vª3ú iþ™ay±Ü{b¥åóv Rÿѱ'@gáñÃHµe™_¡"’áÔ®yK¬ ½©ˆ6Û“<ÛúEõÓ ŠT ìgŒ¬.Q-'–_Fÿ,P;žäXKœðeâû™ü>…¨Þòæ*ÉžÔLé¹ë…M}õ«§¶@h¹F°˜Q|ÉèðE²° DKÊò!ƒÐ#Ç5- Êoü%çoX [L‹k"’YW“x/å’‰%Jò"#=52sSçe”t#›ôý \VšuW_fó–¯ÖúòÍaÐ-Iêòw‹îab$Pö¸` ïÚª¿d ¨¼gP8ÊG°Ùã?í›]é5õr¡HJn¿c¶€ñóÒÎÓ/ Ó[.‰®ƒ ¦yî6ü0>ðÛ6Hˆ:Š„¶?}A“gEÏÓü7Š`+Ák5C¾¥N¼ùÚJvJ¨æv÷Y}ÿ­qþG(©YÙûT=qæ” G|ú)çy¡Ÿ# Q9_‘¤ic:Ç¢2tç[Ô¿ô>úÏRQþ=÷)\úJJ€®}ó» |sÔ¢õ~‹tUª§†Ê¢2BáÙ!Ò#ÕUdÚqK&8FÛm©4sÂé5ÁѺq R\šFÉbm¾ÿFÝÉÕ6}Ÿ#—„ãfò—ÀÀï1w½ ­¡~ö&¹úNS±{1þSY·»8øž¿Mh'íí¢âlpkŠÉ¸Í5mRVñ‰• É!+ën àÞÒõ[ò™ýx)² íí?BÞ@ =·õ@ÕÚ¶MQÖ¯i; òžÊݬ,R†Z:“ V±4hý=å:_‰½¿ãÎׯtÇö’9¼®IÓcZ7÷áéQÒ· @Rf59ƹ³5³E4~´qÐ.ifßhõ’ØAcÖœ7§ùLf—wl"i"þ.SÏ7µïkÀ3 ¿=Ñúý&ÖòÀü§v@“?—~”èT—ªXW¿ÐTîÝc&BÑ¥…ˆv¹F„õ@#‚Rê¢ÅÁšîÙÓ Gñ1ù;¹ö™—õ(ÿJuiÚ|s!¶VªÎÈB¥ŒUŠ-ø™Hð6kWd/ÖÞ6‡W°;B+@Ñû¥8ÆÂknó8F¸ÕÔiáõÂ[Á 껆!ä¹n[¿yÕ¸éBßXQ]¹GgUêmÞÇc8ôFÝÇ,ÀM¦â¸Oa4yNÅ9ÁÜ“–ĈÌÓr 7y!¤FÍ/¤[‘@Øn£ÃIc ¯ã"mãKÞ6Uö?>Át–³x\¤­¨'nD—<¤É5:g€• ÈäT%ê‘¢»à&9uç—¦ÄîÖ-šmY2îÍ= šé«Á}Iºe(øU•’½"ŠEðÝÏ#–¥øâ·AT~vO´³4‚ÞÏû¼%übºŒ“ãOh…Ž?ÀôÁ¿Ê²þeYY_¬Ü¨-žÈÍ?~€”ìfÂüP‘Ÿe>T$‰ŠìŒ-ÜVUyn¥ÝSÿ*¶y~ 5ß­!e–“óKm_BUçÚdM›ËÁww#qa{VÆþvl삲¯ÅtÙ5“˜r™PëêºÓ/h4ËÔtàï*Râä®´w"X„7,Ýï%í–Ìa d×ia÷ä6±Œ$™­ëV@µZ¨"îÅû¥”,šî„žš}}äêƒ`šp¦-+7¹* |¥¤á´~é=YC‘z“w:d¥LÛüÏ~ݵÄ"l®Á´GÉ ½’*ƒoUzŸ=dÑÎêÅmq”<=hÊÄpy¯Î§qäUf¿të e>9çàÔ1Nd˜…ÃkI8ª‘³Ø!ª¸+ ¼Æ^ZÛK/HYÇS"êšOÇ¿‚øOvw'÷D'"*Ù¥TtiôP(èY`œ ¬ß5˜2ïrŠr7ß+ÄV®Š‘'µ™@z‡IìhäJg—©w|+ÅxÅ©vËõ;`}ç)óRTkœ¬B[‰ªZc™ÏÒ·S¦Ç Àû ´žŽ$^ >ë6GP†ö8ðà"cÍ¢ÆÔÊýLŠ;VÆObÖ×ãH¡YuƒžRªƒÀ¸T^ãÈfÝf”åäÈàS-¢³ûÎ2‘È>kÁ"£[» ¨´"Sk°©×kï† [¦'y§æ.UºÁÿÉäÖd; v;š‡Ö“ÔŠ½Ù”ðçúG¤>™ÜÚL‹mŽë?„f«ô…sèƒ8lºe}(¾·M` Ðl@ž3EïÓy.c¿™¸ol``™GȆݲÙî¥Ãê–RB'¯ä€ - )’ ·™•€ß+.Q&„çïTÕ½>ËËÓüYò˜˜wyÑ2?Κà´ãMœ›omC%É#õVóûîk÷¬:éÎtþÒ‚±w#s´‡êjôšRôì§ ÿ?*}ìJ¶3ä5Œ¼¤ÏY‚¸P¥4å<œ˜Vâ;”»æØPÛɱ®ÂæƒôkŸœ¢¬”ýá?Õ Þ%'%ʪÕ– TY‹T÷*’ÅtÛúø£¶ûgý'õJ`z‰FŒ¦ ô¿t(R‰Lx»õãÙ|Q¸«@bPðêr ¥sžµeéÏ­Fd$¦ÏÒW~MýWnpøUiBÇ¿ZÊÔϯñX‚atƒ€a7"ã¨-N$„›òV-@)­ô $ѰÿÌë@•{ž2 %¯ÊÕ5ª³‹©‘‘è+ØÛãcð¶ËDÔ—,¶+›„5h˜sd¿W3{Ìq‹)Üt“êÇÙzmóCæ)!Å!áë’³Y‹´¬ÿT™&¨¬HüàcYyª*£œ~ů™Ê­ž#­<æãðD*S± žë´{@²Dº?5¢^4w«C`nìj QšÕ%’+L¡)ÝŒ‰ßoÆ×Û0l à§ú#Ôø^,]ž:I¹Ìׯ¢ör”ZxcX\ÌË‘AFϮޔ¢•eGþLHÉå‰×J0îԘθّSx }Ý+…K³qfUñù"Á!&C´§1­„}¯Qf ØÅö“G=ú—ÖéaÀ°ó¡¼ÌjÛÈ7G‘¤ÂòÖWó…¨Bí‹M¯;‰{* Íþ5|Ûb¾€^ë3GÂðYˆŽû® §[½0š{¢Ã™ kÌÓ ßräÌ虎çJ‚¹¯8-­Þ½^I½¹É±äM› YnþOLUÃb¯eÉÏI)âdÊZOb0ºzöM¸tˆûm_á™PÈ|\Å…€Æ¹Ò'mxÀC¢ibp·Ä¾²²øÜæâ$8¨Ú«¯*B²” ®1ºÇ ²7O['ìÕrj#…2 Z§DÜÜüDÎËœ#çU´•K\2Ø,Ù·ÔÆBå^;6›aŸ\7Ïl³ý²è˜(­y‰‰ïœs´¸Xi!LˆkîDAaôm¹U–š6ÀÀnËi*0ž¤†Ùoý5ø~éX缼¦z3¯’ºëtU/$HÑ9þMBÖáY\ÿ| 's¨z%ÏÚ®3"þ ÕØÛ¦dÖë]Ÿ*ÿ?¡ðẚHÀD²øÁ…W’. «(ƒ‘oI®|²š?w·HÙÞÇ ÂíjŸý'ç0h̶<ÿn;”™sWìx]|ÐÀ¼0[d×ÞTÄÛÕ°ßtLm‰…5.WέßÚF^Mí9gb¤zOyˆ«5èüv Ã•Ñá%ÙzÝê,ÐNÇfÔñh†+rã¥ÐådŠÈ»®üB[ÅoåqOb×Jò©ÉöK½À+8=8sZ&ÊÎÛ ‘k-n-éñ[¼°ɼ9…ðû>Ùk#¹8ßs¡ð_u–ÿ}Õh(ö<:A–L3g¼ÈÈîbŒ;;%˜FÄ!¶{Û˜štÓáq}& OŒ[uõ°f~}>åÈ5¦%æì™.©ÙZñ‡sOæ^? h©çI]æ[Ñx÷”¾@Ú”^~e ÿ(-×zD‹6u~N%_·ï–”‹#<ôYn*&zâI¯O>ˆž2÷X¯s’/uAÐdŸdB*C…— ,}éfü6ÞùU†ŠáÂNh\éµÒ1Jó«–"] ÝAƒ¥DAºlR[ÉCéßècC®­ÉDjèÇb°ê2¦%Wriaoü:EDôê¤Ë5à—uÜÒ…¤t~þ0¶ŒâÓÉ0Îà¬%$ ZÎ92×>š„ÖÈ•Òãxv*æU¢›ß.ñÌôðñâªwí½éþÃÜPN»ë…å{eàâìøŠ- Êiäñ‡šN²hþ‰–ª¦ãì§öòâ •×ÅÙ8ê\ƒ­3³Œ,•…HÖ‘1Ï|G”µÄ}ÈÔl~ફZ· ÐJ0ÄMF|¥Šš]mlf’¾viÈž½C)³1Âä+`zR«Qc\}ˆ+#+šFí„ï¥x$uÉwÍ!Þò§µ5sgr¥ƒb•N2&hnh@´5îôzâáLnÑÏ(ØàÒ ÞµÑUÉçXê쯢LR™­Ò€Òþ‹ GŠxïoÆŽ¿Üq“9‚dɬ£«°mÎA‹ùû¿×É8$9Æä`bž½žüH†c*tözåtMŠ'ù<äÈm&eÇÊfÿL-ñ;S&XiHxÝo ôà6ß™Ð>ÓXµþÝæ„z/ÕWº¨È”¾çgƤ¾Þ¾=Q(#ν™µ¿Ö>*Š·¢0EÞF×ùØæ¥—U‚±î ¶5Ý¢\ç5;ÞŠÒ›VMf)½YE;Öè\6nÅîRXõÐ YG£¨'iŠúœç`tÕUÜ Z°Õ8£˜¥!ý¤ÏC'”Ê—8.(±¡ÌõüŽ /PdüÊ}ô[ðS•ˆ{ÆØ—Œ‡sÆç_½ëµ1HZ…ø¤kW" ­GI¿×<:pYD~HõN we>oª6ÀœAÕ:÷7¦U]È]Qõ½;Ia’h‚:K>TÛX¢híÎ샛ÍåÝ~îTX|Ûã‚Úª‰D×"‰ÂPY*º _›"¡9¬Às 66aÔ:€Óx-±àà¸Ñ÷1­Z¶!&IÐqëÑ<›.À$î@Yc|žÖ³ÓUT¾F•ÊÀ]sÚQ9}ô„.v¹+ÃjÇûð4lóeàðÑ3ƒmMkè½ñ @‚m2ämCJ#¿xÞˆ}æ ûa Vz]ãSñ®÷‚¶Ï5Kçß¾ÎÅÖn¢ŠP—GC%Úï¦iöFDüíâKÕÅ]ívlÞ­ÚŒõ¤Å%[ªõ”f Ýésu¾gáæ7 ¿ì-¢è†8ϧ;ùí!>¨ô˜ºMßÐ0CÚz½ì/cµì·/x`È=%»UºlàѨÀš+E«Äµêb P EëÑ›~+Ï ºÿš>Q$0?OÚ8D‹)¡ø¶‹ÎÄY&–+½}¾BkeûY00žþ~-mÍIÖÕÂVL{’ï‰I¯M—Ár;¨=ènªÌ¸j2€-mƒßHºŸ¤x~â8Y#ç}¿yëvWc#¢ü½æšˆ™NXÛaåôº6÷–œ>÷•»Fä‘s¯Ë@xA•ɾRA„.0úÿ(næ÷”¤/šÃ]#5}#™M²ºAÐ8J!ÍZYª˜D‡kþü&΋Í9§-ûнËåE­rÚeÙ‚7Ra³ö#ô„ÃðDã ÷5%(]®3 Ö|g4¾¦‹„ËB]uºûZè"'·¬áØã`$Gkï#@Fªm]wæÉJVÇâÓr)$çTã£ä¿…d™`"BÎ÷)â0å‰el€Q ZNɪyãÔÕ–ó)rÒÝ#³“ííúiD±.GúÍ'™©ÙGÁ‘b;5²å(¤¥€‡‡žÜ0¢Å”Sܰþ³p4Md†˜W–'Jlp+ÙFc„ÊA3ÐòFÔǨri\RigËs$±!û3œ–9gLp-¿„òúÞdJèÔvCêÉ.6L33’þ •Á¼ò8‹5"Î:xÐeK{š¼O,#*ÊÂ^ãÛçiÅg·æ brêüwç%܃s>¥ ›|ººÏ |‹ûJ¸m©ÿV8 ³†ôŒyJËö,h²¶—'ùI˜fµ}·½.>Xè&‹¢[| µÊ¿fqÁ<.q‘igH²6æGc ¼m]Ì6²1âîh‰Ä Èe~—ᯭ¨Ñ®ÜYÌ.>ñß<Ã-g®°ìˆ±|9½+fÑÀG^#—‘ü?ËW@»>=8-f+àºáüw¿âàµ9}pAR§YéÖ&ŽAöÖ  Ê×[¢lï©D÷õÞµÝY?²eóE‘,ŠWïùÎDSåÉÅmÕµz7§^±ÑHSšÙÇ0vÞZ¥ñx[¤M‹Çð¨:x$A<Й]gŽr­Òqjkö øfi hãÎQ˜¡y¤xW0–¸pg»hyÓĄ̃å®ìõ:†‘)œPi ¯¦[½4|õüéX6'$ à3"¶…÷#ןلB¶/kˆ š0ÜRîŒ)2¬K_«0ÿ˜{û<"!å!íIÙ¯>$ÂÝ@aòá|пK5Àß‘:²´÷q;ųÏŠÉôÒÚEÌ„(ç…Íwè ٥Π(‚ÊVñÓ—¤ÿúZÑâ,±È=ª6†>È{=>êrˆj{è#HÚ"ö£,ò©Ï¼·Ãe"¤’´ö:µAP[ Ð| ðÍ´õsÄÎKiõe•ÎÌK»$DýƒB«=%E­™"GEتó²ôB$ߪé¤bç2¾F°_ÛïxÕ«¥ÿ ˜aú¨Ãø’ßÙ#EÕþgÞ‚x´é:ì9ïOPxE–øËØSL]uºÖáäÙMR£?b21d±×ùËöí¥¡ÁÞ.Ù òÇpW•Z¼é"ÑwÙ›ºã† ž§;`l¦ 4ŽD“nJe¹$6eÉ‹°ë•άTK‚D²šªdœ‹vžrçsÜå—gž %:*5HŠÒÚ‚7»tqªéÓ.­=ŸŒ<+ÇÕþˆ]–‰{Ú¬±ÕK †Pú¬Ö!÷œc?½ÆÂ‘ˆ‘0ä*F´ýy]üäŒn#ÜÚt¹iW^7ˉè¥ÐÃöÎ ‚r¸¹f¦™™tj_.ÞæƒY‘ýX«Æüô5œ‡B“‘Wtÿ;9ËÅjÐe6‰†ù_û£R aÍõø*ã=ZÆS¨N¯á”Ê>ý¾&±ÑB¿Ï§@s:Çì>‡_Ïç®xc„Ð !­ ¨Á›&.qzœRH+&Ø=lê¨ fȳ5:ð®ÍýSBÇd”Mp ç"(ëÙ¼íÉR4¨n=•ÎÓTQ5ž¿=9Ù) ô!._&;[0:GU*Q¥¹ãzªÒâK–9vË_^סùq[L€ë^ íþ^æµ@)ù†á‡q†S"€¼ŸHW'Å; f¦‹ýfàž4mJJt¨úþ»f¸”kOêQ\åEº.ΦK4—ëÑP¢šuSvQ!O+¬Ô¾Y()øi-ٲמ–%ð¯ù3lÓþÁ¦0ÞlÊÌFETYG!MbMæGoÏMŠúÆ021ÎûÏ¿y›uàW3G]ôÌ—l,(m’( ¿Wv;7…WMäo`¡dÿŒT³äS4šê¢‹×Á'’›L’ùz트C~˜ S ÿ¹¬ç§ ÖjÞÙà”Mõ‘1§ßqoì‡84]@Ó=…¦»²­“@J#ر"«çyLØélãne©…¶¡“\”²5ÕnuòâÈᩉª]à3vé-Î% rc?ò[AÄ2†P™”Ð;åRõiì0ã¤ñžÀ8ÿãfì;¿¼\Á Ì`uò Äû®Šb‡CiÜKÑÍ#‰X¥ŒuTÝÜkº® !‰%ԕئT; 0Ø”‡93Þd¤{J~‚™}‹æ+yÒë¸ p¤Á·P¥ Ðñ½"2º/N v'ëÞ™ ¥ÏoZv< ÿšeiSbÖ ëv=i$L0ò¸8­ÿɸüÿÐØFcÿ„Ï!­dR ¹Rùò›ŽÀ1Íxì8þÊ<3O$p–s µúý¶Ç0ͳ]M zAÃ4ÔÊÍ•‘h›_?R3oÁkïlaÞ*©îØ™­¬/%eÚugƬ ÓÔÞ¤käLz Nw7Uœ{jÈ,"‰Í]ž1ƪ¾’¥hn}·¦¹þ´ÍˆâͶî"Úuë©|ÕþeŒt†Æ´±9"€€¶Ã<§«U2^Ú•žïØJ¹ªÙâ3#ã~»Õ‘(K_÷Ë ŒœåËÐ zÌZhg:ܵME­:£­®ÛE,áØ½²ìÚå ·1Ô·U§z†*ºnœEnœ={jç Œúý{3€¾™ I:}9Ó…´S¬À‚›gË×ùU:~SßSÔW`*«¦ûøTÍO¤jR¥÷©ðÁ`b™›ÂõIÁ;—KûU“{”ƒýwLéAÙdO†^žF'ì•DdÔ©=$æn‚âÏ6Š#Ü òH÷óßOÔÞò˜‘Ù¸ótÏç.cÕžj,â¸îúh¡%W«7•‰¡eŠÔ¨#“ϪâTI¢G—ƒ¤M\‘Ôi•ØÑ>9ýçr НaÀ)“\Mwø¹˜E%ýižäa/䪬›:à€÷)à0Ðfs²'úü©'°JWÍáLÀ`1SŒ«mÍjÂà¯y€2?©ñ¹=£˜"<]Z°?³ŒnDý!Åô ö~%î§ôžD©»êj”ç‘]DK•iKM¤;ÔôDæNÉ8[‰žÝþÉmí¥ª)qªB&¼Á1_ѧ6\–W€58R¾¿àì´†šyxé&5“Á\%ò~TÄíÛJÔÔ*Ө螒sñsš×~ü'ƒ¾{«`Ï­ÄB­7éR™hg´G^ÔwÖÅׂo°·xÇŒ‰¼ø[öqˆó+àÞ‚ÕXÒ7âŒé¦C"özìDt# ¬JVwbøŸL¨P½õlzI7ÆB]fjÇxÍ*n€P(Ȳo©Íõ—ýšùK©ý!!ûX$ª‹×¤áý½Š(yØ+êEÕ-l R•$òlY“&Ø0-\Ð^‘²é=‰!F‚I2·J&½€hš†k¥µÊñÈ¡mÑÛÈ.öîwÚ»(¤›ëbßW#Ôè.Ieˆ\P¼aJ]¹z²;šC=¹([öH¸¨…:Û/ìvOÝ8X–5ô™¤ë–øR̯Í?]ÈÌŽl’úÐÌ“9iàVP“¥yA†JU†‰Œ+ 0kÒzTq-K2£E¿žR'Š`H{#ù ç}—'?(Ÿb&ÎCµjVöÙç¯O ²ÙTã>“ƒýÂVså!Mid^Þ.Sí9F—¹¸ »“êtÿ@ű³ EEøõ½(C†Y+TÈ]R?h¤Á ÉCµÇdèùN:{MP ŸF-üŒTÊï×:¶MÂ4Z•Šúrô™*ñ"âdt»ÁÐZ·^uiFÓY•ÀréËìôѪ“Ë4Z²j7w„u›¼J0 ©3ía¢í)e͇ëC€òN‚3…ÛqË;ŠØ5nà7u #ܼõrµÓ±P”äkFbõh´Ÿ‰tMÊW©ÃÕL¼ëëûJ œøÑÈärA‘ì˰M51 ½a;œX¸3`]ÇÊt¿q툇´*Ê¥4uûaráw1Ð%I257¾ùUúALª‚û¤ÿy€d“\>è¦ðò3ŸÚ=¥aEpK–=e•¯©¸LEë"ÁÉ¥‚ahh6Œê’RDäšBL;¶_JÄ¡ECB+%Ƀý¬E 5Ö¨t1ñeÒiEø³ß¼½iµ8„‘J¼ ƒ@§ˆŒ FÊœ]¥-„•X&=ãÃßmW.“ Å53/%“³k•P~*ÓJ‘”™Ïä˜ëYËß*~Äòÿ(’¦Ҥ蘗B“ýÄÃÔÑËÁd*³`ûyoH𔄹8±8œü¨Æô³INX¤Ð¿z"ø?¡lH/÷g |’ÕÌx{ÞÚ)'Wn›æ€BÿÍr1 ÌÀCãÛ½zi5J¬–ªûÕ¯}¤õÑe@‘£?tÝzÙêAfIè7@cï4§ïñž„Γ¬¢ËbR?Úÿq•Ö—b $(fæÈ©Ó¸ÎuQ—k5¬Üê¾PѾ¶¹Œhs^ú¢±›Á&»âjgEýŽYKõ(hÙ’fîjÅýûˆ¢êÙ_ü¹¦åħ4–ÜÚ :–eÔÀ{ZÏþÚ¥Ñ2¯q<Îÿ¢`‚.âjÃNÚÕIÔ —nàjÄas¥¯þÃtû¤3Ä®öÓsWaä`ži@1Ð÷Ƽˆ*õLmÀ1¹)#`È›@2Á¿>qµ×®á!@Ú¹@à¦<Œ¼Èª‚F‚Ëëjl¼sò]Œê³…a’Ø y‘qrT,³-)†îm!5ãH €¢¬Š[Ý]© ÍE›‰E¡UÙvƒ£„†î`nÜn™]¢Yd`˜5 ÊÍÕ´GAZ8¶vUOd[–#ržã±ª±„Á ËÁ›„&-ùìjZ¢&“²'K´…nίh?I†F`À½ yFÝØ‚"ÚL%ǃµ%t9I™ÈM¨Ý™¥I {E·f«Iㆎ#¸Ž( fªk17o«[SúhI«&â’¢m̱þÈNsGD¡•WýÐ ‚OzÓ`®”¡çÀe75¸µÊ,3"Qÿì£åÑÓ†=½ÍX~ n+ï Ót—D"hJ)·ò%öâ´<®äØóyз2ÅeåP+¬ÕúŸ3ÙÑDˆëë8ê¾SEo¤”oöGëà•ѧ ¬y¸i»£öP{r_焎Tù*]üG`ô<:8#G ”´o&L>›âÆ ±ÓÛ-˜¶ßb?ŸSð)© ‘8Ÿ,qZØ¢ Ñ›Ñ]Tƒ®­]ŸœÍOóì Gçë—r#ŠùÛèœóùjW$4ŸKBÆd}© Xˆ'&fO¾]ÄàÛëÀ€0BQ£}T<ÕIˆeAfÐÔF•¯œg=Ò¤i bÿL!^‰Âf YP(³C2!¬Ÿ»†ÔŒÚ_]=S—<–C,ï*«K–0€½ê¥eÓídá ƒS3MÄ Oú?;1 b.«j‘¦e…Çsu‡çÿiÚÌç§K "/‡8S‰B“%—•÷Ù{[ ŽO¯Üö„]Xz^¨;€£ûWÄ ðy@£¶·¶§½(ãWò IYxí×l@81“²ØÎì×”èª@O…±uc—чá±^Qlý¦ ÑhÖ‡MGsÿMú­9~ä$xyx) ǘ’Bi?RåM7Ñ‘h|Ü2~OÄ.”øy@b6™áöoÛ^,½õž€JKH³ýJVq—­¤F›3ãõÅáƒYÈg}îÎ,«<"ò æ<¢ ä•ÚÄ"êÙßlsÀqÊÇÏ>ŸAs©TYh45ÌjÕ3I€;Ä¢r)Jhþ­G/]‡|ôUÂS°›!®ç|§ž*àÄþ =0V%p< Ý0[yJmæÉQvU¯KG‹æ‰M•/Pt晴µ£ó‡öDÉŽœs›È‚ŠÀ¶'®zèUËzëj+Ò:Ìðý~ÒÕã›×Ч Ìçu¸”&²fa¿¼´¼4°¿®ÂÒúª%n©hÀ8÷~zÝ™¯Ð*”4£J¼{s }Cñhe)«€²Á¡ÍT“ÀƒÙªö4¼+{Hl¾üµvØîU²³‰5>UñdTLØsÇtjJsõƒ­Häâè˜fÖ[ù=~„‘+•ËYh’ŠªI±„‘Vÿ‰ü|{½ øöº2UD¾sù…/šÑ™˜"GìÊ®b/®”xì¹°®ÃÔaBªüµ¸]D€æ};6¨6jvTО)8}Q ­šbˆÍ`Mò¹É¥ñÅUžb?™’©§d»çØ;Ç4XÚDbÕÕî»#We'±8ºˆ‘ĥݥÄHäZ”Sã·Áu è耞wß›…›#Ú_›5ÃÆ, Â{ðYÏ•ðA õéÇŠx(ÐïTâL<(ÞK×tºNÅå5Ó¥)¡´]Ì’r¹r‘Òð…Æ’é4\þÖ“K°À Ï–¨îŽ¥d÷?鞦<ׇH_žùøF”}4:=D)‹”ô8 î³NÞ[mÎ¥™‘k™‰Fè—Ë¿¤n&žÝ)¶Bƒ~yVØ$/íqrôñD(%ÙÜ'sžiÛë!ñ—F’yol™WV×hÛ0"ehuæd=¹o” 91ñŸHPOw¥€À›»ÄÁ(›d|Áà(öÛ ¤ j»Åƒ1­uÀ¯ïëÑ·dmöf÷iÉ;ôÆA3åw!Q%!·0õ™Ÿ$Ë2<²ä]D ÚFniÓÇJ0té¾Iï'-G±LÛ'[þÊ}ÙaË,Fp¥kh‹Rb#»40ṧl¯|ЯGŽÔäXu<áŠbqêÇÓzé±Bd™ôøZI—v) d£ ·ìi J ú)p¡=®^óI ç&V]#jç%6‡œ\óÄ®é~ÄaÅ©Üû‚þâ댶¡T?!¸Sf!ÔF#+´ŒF9>±?hG¹Ï¼F¤÷2£ùY¿œ‹oˆ¼®^û @ÐçKF,À\„E3"¼ò vÊ8OŸ©ØJµÛÝá‘GŽá¾ ­ q,­œHûUµ£†x½×âÌyîÛ€*8Štöb‡oãÍas<Ø5*1m[u×ôÌNÞ—ŸW” &øÉ4…dÝåQ·D·ºp©IG2aä£ãiy¸#µÈNˆU¶»Ci‡dJ€õ÷dŠ%ÓVgÇ$…°J0ålypiñã—ä6 m¬³MUØ2ã–ðRí5š3m¡ví£šÚcUã—uEFËê»së8ì ¿EÒ¢ ô·ýê8C¥ŸSåµké8PÍ«ÕÓ/S„QþÉfú‹ŸeZ)ŽÛ­ƒ¤ìœÉê©C³¬M"Ì9‹‹÷ÕÌtñ«îIBÒS¦åË„%[_y á;ÕÑþµS «9+°gÌÛR—¤D:šü]œŒéÈÜ›²[ŠÅº)5’IS’ø¿!i €69-q¥\S8KOžµ<`?ô’ü€™Ëcä L0¹Èôç^#Æ&éŽH¶Äøœ.uìû†«)¼œÏàÔXKIRC;þ[–OŽoÛ¼xû‰b¾òµÎ]¥4C¢o@Dô>{‰ Y*YXŒ™ŸvLeM#‚œ¢©ÓmõžËZ /L‚tf7Z¹Ç÷¾º=K¿Òòò™epT ¯Ôî×9…ÔÕdÁ#¦¤X™L²¶ý—iüÐâò{;ÒáhW;™RÄ×Òå´4&rÇ·ìhÆí‘¹^˜6*!¼éÆšaç´õ¿š¯Ðjƒûé‹«›ʨO C?´?ÊÁ9 L¦!:*ü8&C¾Dàùô¤CÃÊU´f94~c8žt¥šÕ݇m/ #y6 Úâ­3 Btô@¡[V…&ÁØÝM‡Ï• ?9Ú«x„”íëO kÃLQd¸ƒx©¯ü»¹K²l~:|îzŠXKÔ4ؼ÷ã’EfÎÀ†èoÖrí{ªÁ¯õK0²®ßœ¬RD2Iô'jOáú¢Í`å„P•}¸.’ŒOÝŽðη«I|ÔEi?> IúìB'À•ì†!ãÕnÜ|`²Ì² Ð@veÛ<ÖªÜ}üÚ=ÍhÈm ±ÐÃZ§då1½rk’1¿ QQŒ¤Êó£¸LÕ¼Þ÷ÊÆ’²ÿ«‡Hϰç¾Eú‹\ÁU í¥r ô`‰¸"­Ÿ#œ¡Þij…Ì=çe6!S÷¯ÚAxhõMVUÙsy ñ6¡ãn)=›Q°šk&y¼åÚ¢þkÖ‹Šœ?EpIùŽ?&LF“ 9¸ªÊWµe¼JiPȳF)÷ÙJMà ^žÌ w/o»Ñ³½0÷|tvñ“ЭøDù÷öz©fsVçà;òèæ'è—7å£ ^‰u©Hf‹nâò¨’æ¦)TÌ è(–:X?z””½póø{s±I„Ec) yçÝeÂnµýÌ"ÀqÒ~$Ñíb²Q’]©¹Â·qèæ§6N#…Ý«ü²ŠF€¥Û•Û’®fv˜€ußÚ ²HQÉ*5µD®©ÜmšhB¾Bt¤£|/S®Dˆ.ÆÎÃà]†Î ­ŸïßO6µÆL‡p _ÍVCläõS.VkOÐøMñÍÎØÑbÌ!N“¥I™‰}„¿ÔÁïmVCA˜~}bÝ’ìõ—Á¾×¬8.Œƒ¬Ò ¯¨Ù“L¾>»Þ$–`²jÈK‡4T*5;ËãѯÚ/@F>3o”=ÉHIºù¢>]ä5À‰Uþ¥ÞqÆDÈõ_±× ¼å#À´ŠÏ@¶evä¡<ÚG+— êÉÙœŪ‰w k¸]™;ޱ'“ Ú¡àöó‘ôK°!n/2ÑžzÇÿïÑX¥eco/data/forgnlit30.txt.gz0000644000175100001440000000214513136253506015124 0ustar hornikusers‹5V9®d7 Ìç:Á@ÜÉØ‘3ÃƾÿE\b½~Ðè/Šdmêÿο痜óKÏùó¿þùûÇýy=ôªgžûSGÚ³¦ðY<Ò2cðù^kq;ò*4ÃEåUH˜M^žê°Ò~Ÿ$º%t޾ó÷нKíŠhºø+½9håÉÓUéÇØ ǽå$•½wbSmAu{Xß:­s[¤xêôî •™{*ĬÊOl Œç}cO™ê$[”Þº3º[Ø-œñ“[œl¸étH¥ê×CT}¿µTA?Y ¬Wå;¦iã5óމvädnÃëS…FGˆU]Ü»s™ÜÀ†Äù¶¹Ýɯ$ܱ‰,ZvÝïp˜Œì©(RÓ¦}Yc1 /Õ*|÷ºè½ï/£Áer‹)…î*Xçsÿ@5nØÎ%#‹åCõè®"c¶=õw·šìq±;ðQÒ~£‚™„„/‡’ö1ýq¸Œè®!õ:® p ŸP³$öÓ%¥8m €êòþØ;o+T–½Ç€Ž n'¾ÐždbÝ]j—,Õ@ÖÉßk˜¢€k´.]eu=šk;¸A@ÊfYvÌöªäµ&Mýak}w­²¼Ã­m7èŠåIh¹¤ã&¼ónøLû©c»9@}ÿ³å\P-,q¨Gª?1*Ì`°arw å-%®‘¾*{"U‘þœá ùXщ}…œþ!]€sĶ4<~?낪`l¨  p†‰Ã0ò•à¼y§­ X‹KN–¿¤yËGcÇÞï 3Á‰s\iw“²µ-]ÂÑò 9éV¯Òã´Ú L¨x*†Lø½-w¿Æ…Ôêø’O!ª¼Øÿ©eý*ðúpF D³<Î*xLý³,N´^— ¡^8öø’©í_ ÞK>:\ɵr£ €-)!Ö0)Kê)à¼×5Ëß¾¸Ê{Õ}W 0=BM*í[™`֠·ƒE‹q‘Y‘ì͈!ø@Ù1 QEó%ÁêLI8´ß¾1¦øG|¬>ÊsiÐ^e\ÚèA×JŠ"Þ–AáA͉%2 >Äß÷ ”Šéµ8ÍH"]œà{Ÿààö‡B°Î&œà}œPrŸ ‚`§ø¬‚€1‚U¸ ÜQØø~¹‚gc Éd¤&D=;2âýå>·ê|ÑÍqÜhw¿¸õ:óÑrG| ÂŒwÛÙô”:i ŠÀʵB!",U¬‰|ù<¤ùzöI¦jÀ ëg;¤CêÒËŸÈgEFåjÉ…Èa@¿²ôûd}žÃ»šïÎ$ZÈA¼ö‹)^$2¥bÀ ËÝ!ózMŠóÀV¼ðå›ã˜%¥'Òˆ“”ðKÈêT#;ñ¢|DÈå 6¬–§¾°·ÐR‚ðódžswD KæÕø)r‚ -£lñ£'=ùˆàmÁÀõ» à--ûñ?J„ eco/data/census.txt.gz0000644000175100001440000003327013136253506014440 0ustar hornikusers‹UɵdInD÷)EHÀãó ·$õW„€]óøÑ›ê®ÊÈ7¸ÃƒÁ€÷Ÿÿýü÷çêçÚ¿ò_»ïö)ÿ5o™Ÿ:ÆÝñ/«¬ÿsÛÊ_œYOü[;¥jo«ç/ÆÊôüóuºþSûÓz½ù/³ï‘?¨+/Ð[þ·>ãwu•^â_vÙyÑ[J×-Ú+óäC¬qu==ÄY;¯±FÍÇmÎS´zÌ^õ˜¥æ#Õvs%nËÛ¯¦ÿ––¿hzÌVƉWíE/2»ÞcÌ|«{¬TÛºy÷9¯nRëÔ†­àÌiåøE6Ë9ò&«=ÆÖ–ͼcÜëèEÖÖc¬©õŒuÊ¿¤ îùö§ß|ν»ö´ÅÎÔS›–s\-q×›ìÛò=ÖÿS÷>ºI[79ù{êc¥]̦…œwk=Ï®º†Œ¥Ç?ãÝ´ÅóxKÆÑjþ ìlÄ»žî×Mæê¼Iþ[¯ełޣ]“w½]×èC×ȧ¨z¤0fLG–K”ÿRNýŒÒu…xZÙ¯LkYÎØqÖ9õØV_¹%±@ùó^â1ãèÖÔ¢Ó°­-Ë8q‰}µ«ëö]OyúÈÿXküO­•Ó«ž,n¦›”ü·*Óé±óúEgKªÌór“»Zcd¬{êU‡®1ã°°v¹Zmi1Jiz×’›ÿ1`Ç_ÿÔ{LmtŽ{ã m-ÇŠZG/K»¶xÙËr耶[sÓ¦ìyN½ÊÑMN­ù·Ê ÓlíÎ%q8ÀçÈ„e”£¥×‰;ê(í¡}½³ë(Í£õØñJµ^½ËjÚˆ[XÓ&×Õz×ÔzÅRƱÔÏÕäŠc½šÎl¼CüíònZƒƒ»Œ›7I›Ã1È÷l]b.ÂG‰_„=ŽþÖ=Dlø–8+kk»Vã¨h½Ã^å!c›Z,…ž²k%o/ +”p½}ì‹ÕߊÓ6ñ=yÙzÄå¶.vórzqØÂ}•*Ÿ<Ïýs¡ çtJl\‹¥"(±§käR\¹XœXªzô‚ñj ¿hmiÆØ(U1> ÷ï ÄùÉëÖkléÄά=UXë#–q¹W‘+½]á$\é?Ž}^¢ ™…HœJy·¡ 9øºž¾Moø¡ë&…®•#Þ¸.ƒ€Å™0´eéAçV §•émÝ#ÎÑ7n>VK·‡\í‹àœÎ’>¼î¢Ó¾'~:N¬\¨BÄáòë®— ÷Ë*.´4óÍÑ»z“zâ¤CpÝŠI7v¯¤¿”¶ñ™ÀÜ©ÐKÍ®¦ßš 8³uRî’;¸E{Ç#±]o\P?ŒMó¼©p{aá,4ô»«3t«"X-;]ÎÀp|P×ÄçF$CF4Û„0F—Ðy¨=.@•«Å»ª=»²…ïiÀø‹p26®¥k hØo¸u½ÇV,‰MÚ ®üy‹[Ç›^Å»M¸“§ÅÒ¿í«G¸²!\"°ÅŸÇ™-v)b¯,çØÎžâäÓý†_Ò5ìwP‚Ί¿‡Œ=í‡/ë“ÕÀñqSí¨.yÖ=a&_3A~3@£nÀJuý"¥'¸$dÎÃ~É7-}Ĩ îK>7\n“•*rYa aÝccÝ­Û2'§P'½&ÒÑö/ ˆOñ$<~ü þqÿŽXø#c\Kz³ÏºÝƇݻSœËXŽfw¹}ŠãQ0Ü|®’˜?°¹vsêwqFuе’5ø¿CÂ?ü³.pÒaò›Ã!ƒ ÜFöÓc»«–Á‡g »®ÝŠ€}›y6Èt‚ KO+°{Çl«6ôh‡jnx .…§B‚eØC!¨&ÈïñDd+åÔ¿‚¡q6šŽÆùÒ¢çßÕc`5=þVø‡CÂ舮˜©"‹¡3ÚÁ˜Dù°šúäg˜sÚÕÆ)ú.³±G×È0uð ÛîHÆ{‹üYË8Ö"špðxskS ú5S¨Œ1x|ô;@W{{Ü?=ö]Æwq¬½+e'3Qå$­ŠœŒC´t ãÏÖ'ðIA5öB¯ –ká¼cßyS‚iUvv»N»ñÙ0-Ò" Þ!léTgÁIW»8`Êy6iÌŒ @ î„…X«ÇŠƒÑ>±Ö„kv£^† sþ3r›Å Å Ž^¢A„âsWqŽ,Ó½£æ÷ mÀÒ:ˆ Xõ@3ƒÛª†£ƒ$õ‡3Ž)¶3އöêâi¦ÒÃÈ&ô‹4µA,ÇjùS“Â+6¹ŸÞæ6~q˜,œC`¹¥fÀ«½Ýà*:oÂCÀÉSMkî”!ÞšM¹‚rܽ`–àF2è-dÀmÂÔ¬¶|y<ÿ—+YŽg„ÉÚ…“kZØš: <«0€Èqøÿ)¦èï'3ÁÂÀ €o°Yf¾h9î6YýÞGPuðøq'¨rÊ6úM ~’­Ò«Çc*¹ƒCŽÝºlc„,m0åþgâëËcN$U¸×fˆƒJ‡¨1¼Övmž,òðÏtä?ö¤# ÷q^À¥ð8xÎ^”¸käŽÞ-àXÑb‡S‘iýE.Š“ÙÇý[¨§0,VWS6.üoÈŽˆšƒ ¯z9üâ5Ãù¬8A/ŸϨȜË¡pâãðC]ÿ_2Ž„#†‰lü¾¼hõ#2&9÷^s9%‘t+©N¼AÀ|ñHð‘‘g°’ºB¼'iˆ£Å"‰€´Íìh^n°;”)ÄVÀŠÐ¡ôÞ@ÎMä>z€ž\K9…ˆò×äè:¶IÓ›!‰4uýž?YÛ³õ(‘΀Vuê6pjΞÄÎbÉôd‡Ù|œIæM@ܼ8ú %lsM$ê~6Î ¨ÎN4 N&¼M!*ûà…¹…›½8^™Â21%2@CmØ $½‚S¢úÈMæâ!ëÎæ87±½ 2û6æ98Ué³ðÂ9ƨE#˜×%a £Øë=h•N¾¶éâÙ¬ãÁü"J$ ö0õi„¤w— ÿ‹KÄÌδ*ãfÜ^8Ø@*¤Z L[Ôó¬T£« {VOf ?•~rª™Õäèë~-V-rJ?ÛìTžè¹JÚ@À íÀ þªìAØ2¾„¸ž°Uø‰¿©Uˆ'wC‘l0§Pcƒ„XÕ µ’NÄ]ォIS’ﻵבûéÓÑW×ÐÂΉw¼B¸gí'ó8¸zÿVi]|h‚íÈÿƒ/7øèúEâD³a^d/ËpVvŸdT8707¤èvv¢ä^UŒÀKxúå9eÕýxw‚‹.œY!P 5ÿcDá´~)¢qÂ+lV–@jøcJO0[zC^=Thñ*^(.-&‡×“^4º4^3ŒR«#ü1zƒû¥ðÔÌG»3f;fmâµÐ‘¶[Áh¼ñÕ>D“@®Ô E¸Û(Ï’ž*à=̬©±U-LK”"’XeV›º¬s˜DÅ,æ·lpu-OQcˆ4RgCÿløçüã#'¯EÀEñÝ‹ñ ÎNð€Sqy“¡f™¥Å^Rm†e¯ºÀ¡¨¨ëZrÄp‘"Tø²Ë¹Þ£8å>¤izÅxûé×=>;P5]Û2[¨½3Ä̲¸¦$#œuÖ"Jí "¦Œ‘hks6džÝä1ÄMþrpöâwÔæd•ñ ‘ ‘{.\Ä™È1-iù$ñ?ãè&y»ÕC0)þiI„.%ÝÀÜEÚñxvÈr2ë,léxCGüÌBŠ4.矊mÑêLyº9ya¢GKå`†œdQwt…"\,&¬~¤Gãû†#Ž¿b·7‚tƒc7Ç/Ytð¾³¢VpTÛ\¨y/Ò‹™Á“˜±¾k0æxfãkùós©¼—1’è$œ‹š]s öN` TÅ¥wÓ¹Ò±ÆhtrÚf­HZ’7}Ã†Ø  DЀ)J&¨NÕ\&ÄÈqMQ‡¡Ná²AçˆcÑÕ:®¶‰Ì]Ôˆwþ{1òí Y»$ZVœÇE*‹¢°cºr»cìÕs¶\óH~5`N‡KåE”2¥…~“oêw¸ˆ_,F„ê˜è‚®?À,ð(—¢›%9íè=‚²â´ê˜FTp„gWòêûY»At{:ü¹N×N'aINâÂPlø¤id}2ŰØf½vOgærÀz„ßI*Ö¶óØ&ãT £>r õ«<,qƒ‚Ka¡ž€še\(п€ãEÉ àÚÌ2!omJ}\®¹HsƒßÇu&FDh ¬Q |Ø ¶å]WærËb0£œ-¥­ƒ±pä… ãr2H¶3›¬Æs¾ßdbç¹±F©'h%àXø×@)œêÉuKsX£8ú–…2¥zþ¡ópwñÃüÅ [P òý\eÅN2…pvÀN§Q²Èg5ÛI*æ"•Hƒ­+»)é?ÅÑÈ’å£W5·ï‘I¤ìÁ²(-Nc<L  Œª¥º^²2Ö]Áâ? ɺQ¶¬Ì„ å"ÞðñRIK¸P^Ó¥ak šN÷º—z?º\*‘I!]Y³ßèOæv2I—³ZE gSÓ„¸; x=³üˆAÌôû]@ô®\Òg¶ gpý9ª¬Yæ»f±²ÒvMÇ,é™HþO˜¬Þ+ õ%T—òc™YL @MËZTpŸ%ö9#?YÈõÃEd18Uê4EˆLz”’Ù`.c›3>ªØ\|n9a$ƒ–Ù¦EõÇk¦â„¢­µ?÷ˆpEAQòâZQÀ!FŽ åÊÔ%rÁN¦¤A¼paǃ/b@CÜâò˜Ú×’¸9À+̺Kúè•’ó|ö¹šq)o‚[ÄS¶Y¬“kF^¼§Œ«æýÂ3˜ EvÉýËŠóÑí&H9Ãdu ’ï’Å”8}P Ü%»[g«$5èÕR;PìQŒ»@Ò2UXâYâˆÖí¢†¨ Î#ð`~SRTíhV.ŸŒÃJ·óÊË,f ojeâÜâõrØãÁÂj`¸¦Õ œ"4’³¾· »Ñ f ”êÈÄê±Ö¼¼­¼‰µ'Orµ,í!û»•šKê@ÂLô srLLij{OŸ7`v(‘ÄŸS ;°¢7I°QGüÔ ~¸H(7q.ŽÞmÏô*é_!Š; ˜+˜¸T –ÕÉA«‘å†ÂjÏÌ¡~¶Ë *uWbYR>'L¯hh,ëDų÷‚†Êz¨[Dz"C»“˜…¢\D;$='§*l] 7µCÅÊ_݆G‹D7-Û•òíz(dÝ"‡5R\ÀÂ+Nt9ìXÉl6Ð9hÏð­ƒ’âÕÛ¤w!f9c•ØS¹´–.8²bÒ´>ˆRøÀ£ÅžvXÙÝzzÆ‚ê&8=GçËö¬¹è:+%#ExõúW l¸nJ)X¤ *²å Šø.@ÅÐŽ;Œ{S–“,'?ÁǧnD98ÿD ÷9‘…eP&£\_Ä}€ð(§Ý¡ã,©Yý¨š~wî+´Ëø³N×ú ®€p+DÌÆkØUUŽVÆb÷‚V4Q ¬±î'Á]±cayðÖª£%Ë=åOé?ÜÇaE9Þ;©lX¿‡8‚—‘a–cÉÂéÅ™m“ñéªÐŽù)3òåZžqr °ÛâãÕc»\¹R>’·,½EhrnÎ"½8¸µHõÂC RÊ Åº%„Yh{SE3e·€VWñ¬$޽^hg,Hª–?ìÙÒà>zÍ*=[àr°tÜ-Ô,ôhÐm±øBK÷PÔa¶Q?Šë®MEæ¹…3°`Q"RH›„àÀ˜±»²( ä!Õ>ØxKš>¼"ù›eñOîFÎ’À…eî‡Ê ò+‚#záF “!ëx•Ü‚C–”W'J4/Dün^*Ô^¡(zíg†&\©´ÅIA n¢|œÑFbÁ â§”_l‰Sí\>Gg°að-JìÚ€nå`ÌÅÁÖ¨)¥9~N"í-ÊŽ-ñHç3'Äpøs8„¤¡Óò h8ž€YMEiíh¥){Ë*HJÖeº«;îè„£X©-‰ƒql5°ö¦xŽÇHÝô¾d&$y¦—^“¾©¥9ÈN6Õ!¥§â3”ãO©ˆr4_Owi ¶Ôf)ÿ_&P(IJ5ËŸ¸Ó¤Ánd ‹+ÃÿdÿIÝŒ>*ù ¿ãðÆTAÐ%ãíÒÌõf5•ì˜vd°ÕÚ_ÕŠ@¶´Æà¦ŒO[Îtx=]Tk„MÙž;`ÖOÖP‘—‹‰\&ެk›)1ÜÔb–gz„XÈ 7)$iÔð:.m!óZ¸Š™º‡ñ^š7¢/Øç™“j®j,ˆ»¥HC‹xÿˆ>Ȭ©n4¡Ó[Ò_2ͱ9†–³P{SÉ©¹²÷8 $è³û8dêŽ@Ç%ùŠUL²¤á V‚.±û?½¯v1éK{·Ž6$CÒ *ZBÒºx/Ü.‚þ23°Ff9,#¢›É%Vjè[‡H öBçH1 eqévS»<%VØSHqBX8H¢¡Ør&ŠbËh›ž’ˆ ùƒäë"„/‚°YJÿDX艛ñFw*¦ê£Åì™¶ÇQ†QrQ{B•ëö"¸î¦ClåÝA8®Ë?;W»|ÚZLÕþ_•2Í*¶i l¯ÜQXÄcb»‰J§_³²íkù‘zx"F!Š1ÇÐ`ï&¤`–/p|sÊÂ,¯œ0ßÀ»#;= ·±] W™àÅ;ÚPT áX‘;Ç:¥¼"2žb›9Óén ÝU¼&Ë›.™%¤®I1àz(~tP´ô%HOÕ´uá‚Ã"ìxIýÃÝ €„<&EE¦ØX÷¼ yîðNúùHv)œ‘pÇ˺a}±Ý™0.R9­I¼M™o¡áž™¿‡ãaSá“A ˆ¬‘¥£¬ É8uá.Ó<ýP*>Ä鼕Îa6ýè.´]È2¶?YcQª}ª€ç]À‘KÀžñ´UÀËDfqP¦ T<7ùÊÚ)ÔöùO¼á"²®À ¸#oMúÉ>{1ª½îÃi³±ñÄõåÛM7I?x¿ciª^RI'?ΩÊ.¡í:¦,¡¬ŒÊ&ºAÀ&3¹ûiþu‰,š7W¥Õh÷“ªfñ'#5·ò)›²°#Üm–°»•”>O”—a’y q“ÖöÏñéÉ`Ôp³¤„Vê@¼6‰Tw5“Í3:é%uÓ¼”Û-sß&K„&Ñq7oÑ ë‚s“ÄÔ¸D!r;¸Ø–!*VuÌaA¾¸3’^³%Y .‹Ž†; zš²Ç°Þën+ʼ*ùMä0‘Þ6gdp:cPeqóðugë±JQÁéÈa5q *kQW»ÝB/@ÍÎ^’UÜPíŽ*EݾR=J{;‹×j¡ ÔZÞꢯc 7êÆÊ6mÙia®¼ÿªå?EvÈ!¥ê™N$¯±É'´´Y?Ø}Wwýe“±;sä÷݈AØâ™Š™ð ôˆ6·oB, €÷VØüLþÖs»k";³#¤:Ç¥»\G¥l.V¼ê"uø<êÿ¢jÄtÆ™ÖiÃjÈ$›j±h²¿m”biè)®°^ÎAþª›&W(ô•UÜý§{¸gËï¡Eo»g×/á–ðsÜCüTW0uŽ·uթЖý,{vªìl‡‰F1¿ŸÎR ‚k!=)®RÒ9Ø.*Ör$²..Íù¤Ï?ÆBMÅÉÈ£Ÿ.BÞ’ô%±“”Vó*©ˆwX T†Ï¶\ ê˜tÍ̼Ôjà:¦«{Ô$[D÷ñ*?|¼µs3³›ä\q¶,– Gå æuNÈr¢ñD¯…ŸîqÁÔÿX*e}0i M¬Y1îƒ'^ýö¿×8Ý=åÐç ¶z=ÃnG7Ÿ—³A3êµBŒqh{ p—¯jÙêEß‹jtÑ6s²€ÓÔ§§]_ð7Tóyë=ÖlÇšÏiqºà…p]…?$ŸÔ*O¶¸¶W0}BÂ’Ø~e:ȯ7ÒŠØ4†@pHrO.Á~µîrg‘#k3‘ΰ¢Ì¯ˆH—>¸)‘@8j쯩—–,Tku©)¦ñÛ’AÐÛ}%éø®Ù“þw‰µ<  –>Öé—»©6Õc²Ò¥<¸S%{óE–40ëZå’‡FÚ7}—y¬(’Gaÿöª禸­C15; Ðk/–ç\;Ùo×¶¤nU53ri7Õ¤ºÛC›ÅYä“.Õ­ª-j-ëìèEB}“õÑC¸Àמg°ÑjÒ·|Rá[" eÆ ëŸá0 Œ»å$±~+õÐйæóÞô=õfªRÙÖÚ‰Ÿ©Ã­žˆbÊÍå"…ÓE‹¹š÷+¢Ë'{€ ÃZ3aoaÅDqçÍÚ^l1'¹P¬Â×3€ÙjÞ¨*¡VÔ¦·å|ˆvûy}÷ìN‹ÖpËMþY6nÍa—ÅúuK-U ŠPn¡Šà|Y#œ}Qg<âžljuW’3>Í{Çë85ºŽGQvÚ€&ÄJsiVζçì’#ïñŠÃÿ¾8]*­ÚÆúB˜¶‚¡†ï¼&SrÖóz3‹[±aÛÍ_\Þ Îè‰òØ;J\Qz×íˆnòäÐ! +[3”Æ!qL.nQ ¡Õ/²eYI†@wW½”RoºŽLUQê÷Õì x¬Þ6Eº}Ÿ®± ŠccòåN+Ô8Eš³~ÖáR±/ ]ÔÞÌ-‰ D¾‡t'´õn†|H=aŠáÈ𠬟íàÑSø,æÜÚe~A•T\²­)<šGÕÐ&êþOCú"eb8W–&òʈWSKŽû ý¤ì)1%åOR·›ŸÃ—Ðr§ø*Á­S§R¢‚§Ñbi¢±ø³g5Ù‘Ï ÃPáÃ1•tˆU®[Y'Ëí:†V"GˆdÛ«›)¡7fÑTÚ3—µ=¥b›Dod¤ÏÛñ³¢{äÎJmÒtÜwÔ6U]`ˆX˜{`mðEß ô”ôŽ‹ã^-Û.¥ç¥¤¹£ÀÓ‘V”Ì Â¸©ôS ºt¼\t\%'ˬy±Qc===ò%{H"jÖã˜*?G¨‰ŠE^¶½É%ìÄ»Ž ¤½x3 RÈÜ"µÐT[­r–ó6UÝhs×ß@ïC<Ö|&üñ>Ð*œÃlh3Œèkþ^PÎÆYò9zž%ÆzvÌ›i 'ë²ðw.­[ÔàT%âAœe&õБ·Ä ­º^`·X"ègJ2¶ÖÅ,D$ì "ŒORÚ&$¦¦£œŸèÚf'Êò [Ž29é¡Eƒàx(OÍ6¤Ú:M¢«–:gW­Äª xéð$?êd>Ý¥38‰Ei $ÈÁmñœtP8=O3.5M¤³nîÅ…»õ„j¾ZRÇpé”véN‡¾g~>ŠuE´kY¾Û)!Oͨ±{¸¾Kû¨š„…ÊøþÎG:µ+ÐýÁeHorߤªªÇYJx’S·é¬ŠÎ ¸xW¬9Í)VíI—´Óû¡(×[ž'¦„Ìt†áñnÉG;‡\Ç¢4O™C™š]A˜°qqα„WwI¾yzp‘»ZA³#¨žÜdÇ5C:û„,ŽçEœ=xN¥îÚl7Ÿˆtб–£ÓݦîS±’: áÌí©DZíä› 70ܺò¤™lg¹@¦xÐ^{ºk·±crÄLÒ¢+k½õÈ=¨µ ÏŽñ°ËÔIéEºÃ4†•0éÀ„ÝH„é—­nã¡îÂj’æ«WúsÁ‘óØ ØQŒc:NùKj»Ç,(¼Q¢$š®¦)Q¶šÓ,ó<ÉÄÅYyò›ÝÙf CÒ9àÆýØ.£P Îì„2¹žH{, „êþr~äá+É'ê=dK©KØ0 ” Ài’üvÙÉRÊoKEdçtêQ°‰UHV1  Íš˜å[«›~EÓôËç-7Ž[àä8”N¢6Róý¨H/ãâŸüF‰ fÃEŒ†sq‰osüÙLÏeÏ#õ Ê 2°¥³£n ·&Ú öùnqÖàÔ}“7;¬SøHuÐ+ÒAšÄQØéùH§¶íÆ,Çsh^ZÁ¦FÚ_.Ø9æ2Ý–zï m MAÝB®‹?Ë´×wXVaÑTÈx¢œÇ´‹-ÂÝúÄ4´xÍFíÁÌÁõ{…0;’õrVÔ*ò¼Ä&µØž~áf`añ¢ ÀN²èîu&¤Þ5¬”î°Àóû”\kâ’€‹ð[ôÀ b$ªÄö­zðLw-çsÀoe5¤°ù¦T6j¨©‘ì&õWGz㙸¾–"ÿ¶j7–A0õÅ…vµÁ¹Cê«'±4cÝ#©¿[;ˆOƒ"-«=y×lDÑFó·#=‰SÃE ŠÊ€¡øЇ¬ô~{±šG‚B•zl-­'žÄÙÕ†!!Ζ磕XÞÎß-Pç&µ;i÷݇vèÃAlIv³ÜˆtŽõ¦ø©Í„Jˆ­æHÏJ¡ó©4­Ó½ayÃê $)&% Å4ž¬—…À¡ôN –s;ÍEÌ­â›FЋëÄCOÙpǃs™ ÊGwâ{†Ý´/MøÌ+®…À[í3p¾[uÆZûã]?åµCÛ¯.ù…»r`aâÎB0®_¤ä´´[‹9‡mÛÇSÈ ÇqU§ ø)é)ÈÕ7òļ£õŠÓ´§ÿ¦2‰Ú;ÞY5<¦Äž”,Ä XLJ¨Y/{º“„žÜÑR`!:aT!=™ýÍ«‡Ô µù ô8/%“»ËbdpàzÇ#e<=§Úºe{VGÌÒûB,©4«á5å ÝV쾪’lûõø;0å±hÙ¥ô[Ý´0“ãi¯ó¯â8 Úœô4~áQ«²½,eî¥}<Áà ;¦oæÃÄ…–áû©œ wŸ|ôìxm<‡…›ý3hݽ͗&‹©zÔ,æ¾9$ÈÆ/ÂZëdh>­ÙeVŽÊ°â¼Yº|W—¿‡_/:MŸ=™å€6ÊZ¬xÄlLÍëË3çëÁE±C, «M$¹ärúè¼:6Ìv/ƒÙp׬ç|_v,¥s9…Ë`Å?üÝÙg ï{hH ^&ù­Z5],€UáÌQ‡µTÇ¿ü SÂ1½“ì"Á1,a×õ™ ÂÜ[„djÌfš²ØÞÝi-Ó„-«¤¸™Hwª¥±«ò1K#êü«m5×+‡ªr­+T­ç]Õ®Ù½¦ÚÆ–n½Erg.<€úHúf=ï#Ï_Ì—`'ÖÆ >ºôwÒˆbTƒô¸q )SËž¼8,ó<éòдҗô,žY  )‡°'»=²ë‹»xl2Þ9DÎŽþäP7ÖÙVƒ·i|MÊ}ƒÝi7•j>C)%é¶Ø“ G0¦ð”˜à⌬ÖSÝÒÚn e챃ºÞXúHRêg2Vâb虘hd„Z”m6˜@¨¶Âæù²n*ç5Üt›¶·¶Ã‡Òßã _,¯áƒIKž(>е ­ž¦›@õpTDµ\Kt˜i ¼w¹³]»ØóÉ’¶³DÛË-²Š2PIˆSÝæyPj‡Wå ¬U×L>ÐyØ:¯gY ³yÝ*Úö8³ËÍýeß`a€òû– IÐE7P¶>í´ÜôÔŸ¾ï£Jý}=Òa~²gU/Çè/àñM‹Ë¨`}°¢aï{¸/‹R³Å[6·Š­W1þ2€BKšáßÜ[WªèÈKöüx¥ƒI.ƒŽ;RphýÁ¯íÏB‹xÖ{KÖ¥û³f.ÉÔîn Ëâ(#K»ÝO„mXet~´³dû³náZZ,g¤Ð´YôháÌðLû¢/1¸oÊÓàÙx"´øØÉŒäõ”—äÆe2W3ÈxÍí*+_r`B`~íòñƒó†%{H Cïvïò'-s€pXÉ~“¶^RèV×c¯!›DcZ«Ë:ëÍm‹‚ÕÝF¦A«›Øˆë™‡t:k÷tÿ G‘ÆûZ0²67LÐñ(õ¤3Ї‰X6R»”ÜK¦}ᧉ®ë±@0äñ§ã9Α‘%È‹u´î_qƒï¤œæ/!$†ˆŒ‡@áiÄž^÷Žª¾¿1ÞP#K7ápFFêoÜÝèA½“cƽf2§f…ç¿òæp异XÐe&’–=œŸ¾È³›ÔNå ÷ï,Ýî9†âVf¾û+þŠûªè\\Άü@ò%l¯g »/­Y@ÚÊ$ iúv£?…é–±pH|l…ö—t4Ù$Ži¹¯PJï8N¬e¦–(âñÏ{xŽŸn‘’òí¡ÉNSø4i¼’ÎT~àf£U|_òÇÀé=‡yF„cÔš¿ÊxÐ jÒFn–1)qç-Ì4$Ç­˜ÇºÓù¯¿p%€“]ñÛ_­\aìÜ7]ú7Áï Ï<›„x‘.¶§Ï+L´Í4%Ù³!®6CPb¿y:‚9+îã¯bl×Ùúˆ£€+éÎÌÌÎ÷+™µ›dÚ9,e§HŒfÌrÆ’iРïucYž q@X-…$áá1ˆêiUpï@)¯{ …2þÆÌUº"f*Zâϙ눎`]¾^¦¡vþ0ëêèÔ÷´Z„úVÖÏòG ÜO{¾¸”™ØušMÁ;ÅÛº7ùPÀêÉmE¼7Vug>Jwd‚ÛYçaO©ÐZpèÍj’äûsF{zdK4索ʟññ§‡Ý±²)vMÑè ›û N倸çvøk'nísã2lÍbV¶sÿ2ŽFÃÅÖÈËÝ¢þ„–¯®«´:ß}˜„?ø] ¿lp¦îGéó‡‡ÖDðüúvpâ8Þx¤¿¨•âÍ;ï 5…ž6N³|Æ#„7tØSõ“ê.lŒÍÒ˜ž•7é ðƒDc3ø`V Kä»Qk¸¾rüŠÁr§ÒÄb_¼êW2Ó¿Øéiù×½RþBŒ[ …hŠÛ©ñ7Ë_Ãð—ã¯-pèû–׿ =™ÙxÙ Ðϼ¾;¨=d ka \Ž&‹÷Ù"ª\ñ׬`ß|2Ùc dš>17ù”ï^nãƒgÞÆ,M3{æüáÞoŽçUëðc%áx͹è9.¼Óô0D>oàútSÓ×ÐñפLxø›…©s‹cÔ¬Ht°¦JÂGš“I8þ#EÕ6 ót;šf$±˜ëGÁjÆ]ôµ]í‡àâ)‹Â}Mˆ=3¶`›6•R…_é˜Õ¡H:,¤§i‡?‹\1»FZl}ô¡$~LÜ,?„b×·å[£ˆþí¬á9"ŒT%tH¸9“–žNœvÊ(›ï¬ÚßÂÀÈC8Á–ÇàOIÀ!ÏŒ¥.Àx¢©§1NìÈÁ=ñ†®4¸§á¯*Ä’/$yL÷ú’òÏÌŒ·?n7`ò›¨¦ú‹™‹Õ ³ƲÖKõ÷øQhyñ½ÂTS'ï…Z7ÄKz®ííaÕØüÉÛSÿÆ4”~åd^S_¼ñw² ïvûsº3SÚi»Çûâ0ú¿œ5§‚šL>§ ¢ÕçcýyHçb{´8tšl]wÕ¡1ÇŸþ‰í쬞U_!8¹CÃNÃX'vøkš°Ù\§åƒBoÆê#õËìë†KK¤–güéɤ²-VO÷²[I¯Ð…{¯ûBq†Äaôd ¢¥¿é²þ±…ºú2¨{Ò†”3‘þTOtVÆëÌó>µD¨öbÑû¤t\ƒÝö]Íì4  -VºäÉè>LÞ}Ÿþ8@ËZ«?"ú¾É÷Z8ø2wŽ¢:”iŸÄ¼xÀ<Æb4 C˜’p<—ŸN:@éêUR¹ÂÒŒ=“7˜Õáë>>š³ΰUÇ ·ô»šK(KÕJ¯§æ/Î~¬•Ì,ìçé’g´TÕódš¢é2L>Ìmè ô²ÚjÝ3 ½º5Hg4“Ï6ãk'O@à ˜,Z{2O@loâ< üz´1ææ-=SImZþÆŽ#û1‚7ÍOEvó~OL‚Ö-Œ[ÌÈz¼î/Rññ™’:ÃvذÛ¹\-gS­I~k5Þp"bIsŠŒØ‰ò¼›Ô-¨ú ­¿ôÂW~«Ã’3)+8Ñ´œ×-C¿±cô¤iÂuößT“/„é{”þäÎvM‚9V—¯ÎLZ•Ž)’î±§Sãå1•{CjÍõC.wM½¿„U_¦£dûUª=—6‹V5¦$—Þr^·h™.Ì¿ÐîÙqÖ'$|e $¯!ÛÏ/Ð{VïŠÏ˜,N­l=¶ê zž®ŸKÀ,Ù{ù@¢¡ïûÐ u!õíUžr?)ƒ ­‹:+üõ©1ñº×IVSóWL]p¹) ý>õãJ\‡eco/R/0000755000175100001440000000000013104457061011240 5ustar hornikuserseco/R/ecoRC.R0000644000175100001440000000602513061770754012372 0ustar hornikusersecoRC <- function(formula, data = parent.frame(), mu0 = 0, tau0 = 2, nu0 = 4, S0 = 10, mu.start = 0, Sigma.start = 1, reject = TRUE, maxit = 10e5, parameter = TRUE, n.draws = 5000, burnin = 0, thin = 0, verbose = FALSE){ ## checking inputs if (burnin >= n.draws) stop("n.draws should be larger than burnin") mf <- match.call() ## getting X, Y, and N tt <- terms(formula) attr(tt, "intercept") <- 0 if (is.matrix(eval.parent(mf$data))) data <- as.data.frame(data) X <- model.matrix(tt, data) n.samp <- nrow(X) C <- ncol(X) Y <- matrix(model.response(model.frame(tt, data = data)), nrow = n.samp) R <- ncol(Y) ## fitting the model n.store <- floor((n.draws-burnin)/(thin+1)) tmp <- ecoBD(formula, data=data) res.out <- list(call = mf, X = X, Y = Y, Wmin = tmp$Wmin, Wmax = tmp$Wmax) if (R == 1) { mu0 <- rep(mu0, C) S0 <- diag(S0, C) mu.start <- rep(mu.start, C) Sigma.start <- diag(Sigma.start, C) res <- .C("cBase2C", as.double(X), as.double(Y), as.double(tmp$Wmin[,1,]), as.double(tmp$Wmax[,1,]), as.integer(n.samp), as.integer(C), as.integer(reject), as.integer(maxit), as.integer(n.draws), as.integer(burnin), as.integer(thin+1), as.integer(verbose), as.integer(nu0), as.double(tau0), as.double(mu0), as.double(S0), as.double(mu.start), as.double(Sigma.start), as.integer(parameter), pdSmu = double(n.store*C), pdSSigma = double(n.store*C*(C+1)/2), pdSW = double(n.store*n.samp*C), PACKAGE="eco") res.out$mu <- matrix(res$pdSmu, n.store, C, byrow=TRUE) res.out$Sigma <- matrix(res$pdSSigma, n.store, C*(C+1)/2, byrow=TRUE) res.out$W <- array(res$pdSW, c(C, n.samp, n.store)) } else { mu0 <- rep(mu0, R-1) S0 <- diag(S0, R-1) mu.start <- matrix(rep(rep(mu.start, R-1), C), nrow = R-1, ncol = C, byrow = FALSE) Sigma.start <- array(rep(diag(Sigma.start, R-1), C), c(R-1, R-1, C)) res <- .C("cBaseRC", as.double(X), as.double(Y[,1:(R-1)]), as.double(tmp$Wmin[,1:(R-1),]), as.double(tmp$Wmax[,1:(R-1),]), as.integer(n.samp), as.integer(C), as.integer(R), as.integer(reject), as.integer(maxit), as.integer(n.draws), as.integer(burnin), as.integer(thin+1), as.integer(verbose), as.integer(nu0), as.double(tau0), as.double(mu0), as.double(S0), as.double(mu.start), as.double(Sigma.start), as.integer(parameter), pdSmu = double(n.store*C*(R-1)), pdSSigma = double(n.store*C*(R-1)*R/2), pdSW = double(n.store*n.samp*(R-1)*C), PACKAGE="eco") res.out$mu <- array(res$pdSmu, c(R-1, C, n.store)) res.out$Sigma <- array(res$pdSSigma, c(R*(R-1)/2, C, n.store)) res.out$W <- array(res$pdSW, c(R-1, C, n.samp, n.store)) } class(res.out) <- c("ecoRC", "eco") return(res.out) } eco/R/ecoNP.R0000644000175100001440000003710013104457061012370 0ustar hornikusers#' Fitting the Nonparametric Bayesian Models of Ecological Inference in 2x2 #' Tables #' #' \code{ecoNP} is used to fit the nonparametric Bayesian model (based on a #' Dirichlet process prior) for ecological inference in \eqn{2 \times 2} tables #' via Markov chain Monte Carlo. It gives the in-sample predictions as well as #' out-of-sample predictions for population inference. The models and #' algorithms are described in Imai, Lu and Strauss (2008, 2011). #' #' #' @param formula A symbolic description of the model to be fit, specifying the #' column and row margins of \eqn{2 \times 2} ecological tables. \code{Y ~ X} #' specifies \code{Y} as the column margin (e.g., turnout) and \code{X} as the #' row margin (e.g., percent African-American). Details and specific examples #' are given below. #' @param data An optional data frame in which to interpret the variables in #' \code{formula}. The default is the environment in which \code{ecoNP} is #' called. #' @param N An optional variable representing the size of the unit; e.g., the #' total number of voters. \code{N} needs to be a vector of same length as #' \code{Y} and \code{X} or a scalar. #' @param supplement An optional matrix of supplemental data. The matrix has #' two columns, which contain additional individual-level data such as survey #' data for \eqn{W_1} and \eqn{W_2}, respectively. If \code{NULL}, no #' additional individual-level data are included in the model. The default is #' \code{NULL}. #' @param context Logical. If \code{TRUE}, the contextual effect is also #' modeled, that is to assume the row margin \eqn{X} and the unknown \eqn{W_1} #' and \eqn{W_2} are correlated. See Imai, Lu and Strauss (2008, 2011) for #' details. The default is \code{FALSE}. #' @param mu0 A scalar or a numeric vector that specifies the prior mean for #' the mean parameter \eqn{\mu} of the base prior distribution \eqn{G_0} (see #' Imai, Lu and Strauss (2008, 2011) for detailed descriptions of Dirichlete #' prior and the normal base prior distribution) . If it is a scalar, then its #' value will be repeated to yield a vector of the length of \eqn{\mu}, #' otherwise, it needs to be a vector of same length as \eqn{\mu}. When #' \code{context=TRUE }, the length of \eqn{\mu} is 3, otherwise it is 2. The #' default is \code{0}. #' @param tau0 A positive integer representing the scale parameter of the #' Normal-Inverse Wishart prior for the mean and variance parameter #' \eqn{(\mu_i, \Sigma_i)} of each observation. The default is \code{2}. #' @param nu0 A positive integer representing the prior degrees of freedom of #' the variance matrix \eqn{\Sigma_i}. the default is \code{4}. #' @param S0 A positive scalar or a positive definite matrix that specifies the #' prior scale matrix for the variance matrix \eqn{\Sigma_i}. If it is a #' scalar, then the prior scale matrix will be a diagonal matrix with the same #' dimensions as \eqn{\Sigma_i} and the diagonal elements all take value of #' \code{S0}, otherwise \code{S0} needs to have same dimensions as #' \eqn{\Sigma_i}. When \code{context=TRUE}, \eqn{\Sigma} is a \eqn{3 \times 3} #' matrix, otherwise, it is \eqn{2 \times 2}. The default is \code{10}. #' @param alpha A positive scalar representing a user-specified fixed value of #' the concentration parameter, \eqn{\alpha}. If \code{NULL}, \eqn{\alpha} will #' be updated at each Gibbs draw, and its prior parameters \code{a0} and #' \code{b0} need to be specified. The default is \code{NULL}. #' @param a0 A positive integer representing the value of shape parameter of #' the gamma prior distribution for \eqn{\alpha}. The default is \code{1}. #' @param b0 A positive integer representing the value of the scale parameter #' of the gamma prior distribution for \eqn{\alpha}. The default is \code{0.1}. #' @param parameter Logical. If \code{TRUE}, the Gibbs draws of the population #' parameters, \eqn{\mu} and \eqn{\Sigma}, are returned in addition to the #' in-sample predictions of the missing internal cells, \eqn{W}. The default is #' \code{FALSE}. This needs to be set to \code{TRUE} if one wishes to make #' population inferences through \code{predict.eco}. See an example below. #' @param grid Logical. If \code{TRUE}, the grid method is used to sample #' \eqn{W} in the Gibbs sampler. If \code{FALSE}, the Metropolis algorithm is #' used where candidate draws are sampled from the uniform distribution on the #' tomography line for each unit. Note that the grid method is significantly #' slower than the Metropolis algorithm. #' @param n.draws A positive integer. The number of MCMC draws. The default is #' \code{5000}. #' @param burnin A positive integer. The burnin interval for the Markov chain; #' i.e. the number of initial draws that should not be stored. The default is #' \code{0}. #' @param thin A positive integer. The thinning interval for the Markov chain; #' i.e. the number of Gibbs draws between the recorded values that are skipped. #' The default is \code{0}. #' @param verbose Logical. If \code{TRUE}, the progress of the Gibbs sampler is #' printed to the screen. The default is \code{FALSE}. #' @return An object of class \code{ecoNP} containing the following elements: #' \item{call}{The matched call.} #' \item{X}{The row margin, \eqn{X}.} #' \item{Y}{The column margin, \eqn{Y}.} #' \item{burnin}{The number of initial burnin draws.} #' \item{thin}{The thinning interval.} #' \item{nu0}{The prior degrees of freedom.} #' \item{tau0}{The prior scale parameter.} #' \item{mu0}{The prior mean.} #' \item{S0}{The prior scale matrix.} #' \item{a0}{The prior shape parameter.} #' \item{b0}{The prior scale parameter.} #' \item{W}{A three dimensional array storing the posterior in-sample predictions #' of \eqn{W}. The first dimension indexes the Monte Carlo draws, the second dimension #' indexes the columns of the table, and the third dimension represents the observations.} #' \item{Wmin}{A numeric matrix storing the lower bounds of \eqn{W}.} #' \item{Wmax}{A numeric matrix storing the upper bounds of \eqn{W}.} #' The following additional elements are included in the output when #' \code{parameter = TRUE}. #' \item{mu}{A three dimensional array storing the #' posterior draws of the population mean parameter, \eqn{\mu}. The first #' dimension indexes the Monte Carlo draws, the second dimension indexes the #' columns of the table, and the third dimension represents the observations.} #' \item{Sigma}{A three dimensional array storing the posterior draws of the #' population variance matrix, \eqn{\Sigma}. The first dimension indexes the #' Monte Carlo draws, the second dimension indexes the parameters, and the #' third dimension represents the observations. } #' \item{alpha}{The posterior draws of \eqn{\alpha}.} #' \item{nstar}{The number of clusters at each Gibbs draw.} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{eco}, \code{ecoML}, \code{predict.eco}, \code{summary.ecoNP} #' @references Imai, Kosuke, Ying Lu and Aaron Strauss. (2011). \dQuote{eco: R #' Package for Ecological Inference in 2x2 Tables} Journal of Statistical #' Software, Vol. 42, No. 5, pp. 1-23. available at #' \url{http://imai.princeton.edu/software/eco.html} #' #' Imai, Kosuke, Ying Lu and Aaron Strauss. (2008). \dQuote{Bayesian and #' Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data #' Approach} Political Analysis, Vol. 16, No. 1 (Winter), pp. 41-69. available #' at \url{http://imai.princeton.edu/research/eiall.html} #' @keywords models #' @examples #' #' #' ## load the registration data #' data(reg) #' #' ## NOTE: We set the number of MCMC draws to be a very small number in #' ## the following examples; i.e., convergence has not been properly #' ## assessed. See Imai, Lu and Strauss (2006) for more complete examples. #' #' ## fit the nonparametric model to give in-sample predictions #' ## store the parameters to make population inference later #' \dontrun{res <- ecoNP(Y ~ X, data = reg, n.draws = 50, param = TRUE, verbose = TRUE) #' #' ##summarize the results #' summary(res) #' #' ## obtain out-of-sample prediction #' out <- predict(res, verbose = TRUE) #' #' ## summarize the results #' summary(out) #' #' ## density plots of the out-of-sample predictions #' par(mfrow=c(2,1)) #' plot(density(out[,1]), main = "W1") #' plot(density(out[,2]), main = "W2") #' #' #' ## load the Robinson's census data #' data(census) #' #' ## fit the parametric model with contextual effects and N #' ## using the default prior specification #' #' res1 <- ecoNP(Y ~ X, N = N, context = TRUE, param = TRUE, data = census, #' n.draws = 25, verbose = TRUE) #' #' ## summarize the results #' summary(res1) #' #' ## out-of sample prediction #' pres1 <- predict(res1) #' summary(pres1)} #' ecoNP <- function(formula, data = parent.frame(), N = NULL, supplement = NULL, context = FALSE, mu0 = 0, tau0 = 2, nu0 = 4, S0 = 10, alpha = NULL, a0 = 1, b0 = 0.1, parameter = FALSE, grid = FALSE, n.draws = 5000, burnin = 0, thin = 0, verbose = FALSE){ ## contextual effects if (context) ndim <- 3 else ndim <- 2 ## checking inputs if (burnin >= n.draws) stop("n.draws should be larger than burnin") if (length(mu0)==1) mu0 <- rep(mu0, ndim) else if (length(mu0)!=ndim) stop("invalid inputs for mu0") if (is.matrix(S0)) { if (any(dim(S0)!=ndim)) stop("invalid inputs for S0") } else S0 <- diag(S0, ndim) mf <- match.call() ## getting X, Y and N tt <- terms(formula) attr(tt, "intercept") <- 0 if (is.matrix(eval.parent(mf$data))) data <- as.data.frame(data) X <- model.matrix(tt, data) Y <- model.response(model.frame(tt, data = data)) N <- eval(mf$N, data) ## alpha if (is.null(alpha)) { alpha.update <- TRUE alpha <- 0 } else alpha.update <- FALSE ## checking the data and calculating the bounds tmp <- checkdata(X, Y, supplement, ndim) bdd <- ecoBD(formula, data=data) W1min <- bdd$Wmin[order(tmp$order.old)[1:nrow(tmp$d)],1,1] W1max <- bdd$Wmax[order(tmp$order.old)[1:nrow(tmp$d)],1,1] ## fitting the model n.store <- floor((n.draws-burnin)/(thin+1)) unit.par <- unit.w <- tmp$n.samp+tmp$samp.X1+tmp$samp.X0 n.par <- n.store * unit.par n.w <- n.store * unit.w unit.a <- 1 if (context) res <- .C("cDPecoX", as.double(tmp$d), as.integer(tmp$n.samp), as.integer(n.draws), as.integer(burnin), as.integer(thin+1), as.integer(verbose), as.integer(nu0), as.double(tau0), as.double(mu0), as.double(S0), as.double(alpha), as.integer(alpha.update), as.double(a0), as.double(b0), as.integer(tmp$survey.yes), as.integer(tmp$survey.samp), as.double(tmp$survey.data), as.integer(tmp$X1type), as.integer(tmp$samp.X1), as.double(tmp$X1.W1), as.integer(tmp$X0type), as.integer(tmp$samp.X0), as.double(tmp$X0.W2), as.double(W1min), as.double(W1max), as.integer(parameter), as.integer(grid), pdSMu0=double(n.par), pdSMu1=double(n.par), pdSMu2=double(n.par), pdSSig00=double(n.par), pdSSig01=double(n.par), pdSSig02=double(n.par), pdSSig11=double(n.par), pdSSig12=double(n.par), pdSSig22=double(n.par), pdSW1=double(n.w), pdSW2=double(n.w), pdSa=double(n.store), pdSn=integer(n.store), PACKAGE="eco") else res <- .C("cDPeco", as.double(tmp$d), as.integer(tmp$n.samp), as.integer(n.draws), as.integer(burnin), as.integer(thin+1), as.integer(verbose), as.integer(nu0), as.double(tau0), as.double(mu0), as.double(S0), as.double(alpha), as.integer(alpha.update), as.double(a0), as.double(b0), as.integer(tmp$survey.yes), as.integer(tmp$survey.samp), as.double(tmp$survey.data), as.integer(tmp$X1type), as.integer(tmp$samp.X1), as.double(tmp$X1.W1), as.integer(tmp$X0type), as.integer(tmp$samp.X0), as.double(tmp$X0.W2), as.double(W1min), as.double(W1max), as.integer(parameter), as.integer(grid), pdSMu0=double(n.par), pdSMu1=double(n.par), pdSSig00=double(n.par), pdSSig01=double(n.par), pdSSig11=double(n.par), pdSW1=double(n.w), pdSW2=double(n.w), pdSa=double(n.store), pdSn=integer(n.store), PACKAGE="eco") ## output W1.post <- matrix(res$pdSW1, n.store, unit.w, byrow=TRUE)[,tmp$order.old] W2.post <- matrix(res$pdSW2, n.store, unit.w, byrow=TRUE)[,tmp$order.old] W <- array(rbind(W1.post, W2.post), c(n.store, 2, unit.w)) colnames(W) <- c("W1", "W2") res.out <- list(call = mf, X = X, Y = Y, N = N, W = W, Wmin = bdd$Wmin[,1,], Wmax = bdd$Wmax[,1,], burin = burnin, thin = thin, nu0 = nu0, tau0 = tau0, mu0 = mu0, a0 = a0, b0 = b0, S0 = S0) ## optional outputs if (parameter){ if (context) { mu1.post <- matrix(res$pdSMu0, n.store, unit.par, byrow=TRUE)[,tmp$order.old] mu2.post <- matrix(res$pdSMu1, n.store, unit.par, byrow=TRUE)[,tmp$order.old] mu3.post <- matrix(res$pdSMu2, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma11.post <- matrix(res$pdSSig00, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma12.post <- matrix(res$pdSSig01, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma13.post <- matrix(res$pdSSig02, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma23.post <- matrix(res$pdSSig12, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma22.post <- matrix(res$pdSSig11, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma33.post <- matrix(res$pdSSig22, n.store, unit.par, byrow=TRUE)[,tmp$order.old] res.out$mu <- array(rbind(mu1.post, mu2.post, mu3.post), dim=c(n.store, 3, unit.par), dimnames=list(1:n.store, c("mu1", "mu2", "mu3"), 1:unit.par)) res.out$Sigma <- array(rbind(Sigma11.post, Sigma12.post, Sigma13.post, Sigma22.post, Sigma23.post, Sigma33.post), dim=c(n.store, 6, unit.par), dimnames=list(1:n.store, c("Sigma11", "Sigma12", "Sigma13", "Sigma22", "Sigma23", "Sigma33"), 1:unit.par)) } else { mu1.post <- matrix(res$pdSMu0, n.store, unit.par, byrow=TRUE)[,tmp$order.old] mu2.post <- matrix(res$pdSMu1, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma11.post <- matrix(res$pdSSig00, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma12.post <- matrix(res$pdSSig01, n.store, unit.par, byrow=TRUE)[,tmp$order.old] Sigma22.post <- matrix(res$pdSSig11, n.store, unit.par, byrow=TRUE)[,tmp$order.old] res.out$mu <- array(rbind(mu1.post, mu2.post), dim=c(n.store, 2, unit.par), dimnames=list(1:n.store, c("mu1", "mu2"), 1:unit.par)) res.out$Sigma <- array(rbind(Sigma11.post, Sigma12.post, Sigma22.post), dim=c(n.store, 3, unit.par), dimnames=list(1:n.store, c("Sigma11", "Sigma12", "Sigma22"), 1:unit.par)) } if (alpha.update) res.out$alpha <- matrix(res$pdSa, n.store, unit.a, byrow=TRUE) else res.out$alpha <- alpha res.out$nstar <- matrix(res$pdSn, n.store, unit.a, byrow=TRUE) } if (context) class(res.out) <- c("ecoNPX", "ecoNP", "eco") else class(res.out) <- c("ecoNP", "eco") return(res.out) } eco/R/logit.R0000644000175100001440000000014413061770754012511 0ustar hornikuserslogit <- function(x) return(log(x)-log(1-x)) invlogit <- function(x) return(exp(x)/(1+exp(x))) eco/R/onAttach.R0000644000175100001440000000043413061770754013136 0ustar hornikusers".onAttach" <- function(lib, pkg) { mylib <- dirname(system.file(package = pkg)) title <- packageDescription(pkg, lib.loc = mylib)$Title ver <- packageDescription(pkg, lib.loc = mylib)$Version packageStartupMessage(paste(pkg, ": ", title, "\nVersion: ", ver, "\n", sep="")) } eco/R/summary.ecoNP.R0000644000175100001440000001607213104457061014071 0ustar hornikusers#' Summarizing the Results for the Bayesian Nonparametric Model for Ecological #' Inference in 2x2 Tables #' #' \code{summary} method for class \code{ecoNP}. #' #' #' @aliases summary.ecoNP #' @param object An output object from \code{ecoNP}. #' @param CI A vector of lower and upper bounds for the Bayesian credible #' intervals used to summarize the results. The default is the equal tail 95 #' percent credible interval. #' @param param Logical. If \code{TRUE}, the posterior estimates of the #' population parameters will be provided. The default value is \code{FALSE}. #' @param units Logical. If \code{TRUE}, the in-sample predictions for each #' unit or for a subset of units will be provided. The default value is #' \code{FALSE}. #' @param subset A numeric vector indicating the subset of the units whose #' in-sample predications to be provided when \code{units} is \code{TRUE}. The #' default value is \code{NULL} where the in-sample predictions for each unit #' will be provided. #' @param ... further arguments passed to or from other methods. #' @return \code{summary.ecoNP} yields an object of class \code{summary.ecoNP} #' containing the following elements: #' \item{call}{The call from \code{ecoNP}.} #' \item{n.obs}{The number of units.} #' \item{n.draws}{The number of Monte Carlo samples.} #' \item{agg.table}{Aggregate posterior estimates of the marginal #' means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If #' \code{param = TRUE}, the following elements are also included: #' \item{param.table}{Posterior estimates of model parameters: population mean #' estimates of \eqn{W_1} and \eqn{W_2}. If \code{subset} is specified, only a #' subset of the population parameters are included.} If \code{unit = TRUE}, #' the following elements are also included: #' \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} #' \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} #' #' This object can be printed by \code{print.summary.ecoNP} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{ecoNP}, \code{predict.eco} #' @keywords methods summary.ecoNP <- function(object, CI=c(2.5, 97.5), param=FALSE, units=FALSE, subset=NULL,...) { n.obs <- ncol(object$W[,1,]) n.draws <- nrow(object$W[,1,]) if (is.null(subset)) subset <- 1:n.obs else if (!is.numeric(subset)) stop("Subset should be a numeric vector.") else if (!all(subset %in% c(1:n.obs))) stop("Subset should be any numbers in 1:obs.") table.names<-c("mean", "std.dev", paste(min(CI), "%", sep=" "), paste(max(CI), "%", sep=" ")) agg.table <-agg.wtable <-NULL N<-rep(1, length(object$X)) W1.agg.mean <- as.vector(object$W[,1,]%*% (object$X*N/sum(object$X*N))) W2.agg.mean <- as.vector(object$W[,2,]%*% ((1-object$X)*N/sum((1-object$X)*N))) agg.table <- rbind(cbind(mean(W1.agg.mean), sd(W1.agg.mean), quantile(W1.agg.mean, min(CI)/100), quantile(W1.agg.mean, max(CI)/100)), cbind(mean(W2.agg.mean), sd(W2.agg.mean), quantile(W2.agg.mean, min(CI)/100), quantile(W2.agg.mean, max(CI)/100))) colnames(agg.table) <- table.names rownames(agg.table) <- c("W1", "W2") if (!is.null(object$N)) { N <- object$N W1.agg.wmean <- as.vector(object$W[,1,] %*% (object$X*N/sum(object$X*N))) W2.agg.wmean <- as.vector(object$W[,2,] %*% ((1-object$X)*N/sum((1-object$X)*N))) agg.wtable <- rbind(cbind(mean(W1.agg.wmean), sd(W1.agg.wmean), quantile(W1.agg.wmean, min(CI)/100), quantile(W1.agg.wmean, max(CI)/100)), cbind(mean(W2.agg.wmean), sd(W2.agg.wmean), quantile(W2.agg.wmean, min(CI)/100), quantile(W2.agg.wmean, max(CI)/100))) colnames(agg.wtable) <- table.names rownames(agg.wtable) <- c("W1", "W2") } if (units) { W1.table <- cbind(apply(object$W[,1,subset], 2, mean), apply(object$W[,1,subset], 2, sd), apply(object$W[,1,subset], 2, quantile, min(CI)/100), apply(object$W[,1,subset], 2, quantile, max(CI)/100)) W2.table <- cbind(apply(object$W[,2,subset], 2, mean), apply(object$W[,2,subset], 2, sd), apply(object$W[,2,subset], 2, quantile, min(CI)/100), apply(object$W[,2,subset], 2, quantile, max(CI)/100)) colnames(W2.table) <- colnames(W1.table) <- table.names rownames(W1.table) <- rownames(W2.table) <- row.names(object$X[subset]) } else W1.table <- W2.table <- NULL if (is.null(param)) param <- FALSE if (param) { if (is.null(object$mu) || is.null(object$Sigma)) stop("Parameters are missing values.") } if (param) { mu1.table <- cbind(apply(object$mu[,1,subset], 2, mean), apply(object$mu[,1,subset], 2, sd), apply(object$mu[,1,subset], 2, quantile, min(CI)/100), apply(object$mu[,1,subset], 2, quantile, max(CI)/100)) mu2.table <- cbind(apply(object$mu[,2,subset], 2, mean), apply(object$mu[,2,subset], 2, sd), apply(object$mu[,2,subset], 2, quantile, min(CI)/100), apply(object$mu[,2,subset], 2, quantile, max(CI)/100)) Sigma11.table <- cbind(apply(object$Sigma[,1,subset], 2, mean), apply(object$Sigma[,1,subset], 2, sd), apply(object$Sigma[,1,subset], 2, quantile, min(CI)/100), apply(object$Sigma[,1,subset], 2, quantile, max(CI)/100)) Sigma12.table <- cbind(apply(object$Sigma[,2,subset], 2, mean), apply(object$Sigma[,2,subset], 2, sd), apply(object$Sigma[,2,subset], 2, quantile, min(CI)/100), apply(object$Sigma[,2,subset], 2, quantile, max(CI)/100)) Sigma22.table <- cbind(apply(object$Sigma[,3,subset], 2, mean), apply(object$Sigma[,3,subset], 2, sd), apply(object$Sigma[,3,subset], 2, quantile, min(CI)/100), apply(object$Sigma[,3,subset], 2, quantile, max(CI)/100)) colnames(mu1.table) <- colnames(mu2.table) <- table.names colnames(Sigma11.table) <- colnames(Sigma12.table) <- colnames(Sigma22.table) <- table.names param.table=list(mu1.table=mu1.table,mu2.table=mu2.table,Sigma11.table=Sigma11.table,Sigma12.table=Sigma12.table,Sigma22.table=Sigma22.table) } else param.table <- NULL ans <- list(call = object$call, W1.table = W1.table, W2.table = W2.table, agg.table = agg.table, agg.wtable=agg.wtable, param.table = param.table, n.draws = n.draws, n.obs = n.obs) class(ans) <-c("summary.eco", "summary.ecoNP") return(ans) } eco/R/predict.ecoX.R0000644000175100001440000001071413104457061013715 0ustar hornikusers#' Out-of-Sample Posterior Prediction under the Parametric Bayesian Model for #' Ecological Inference in 2x2 Tables #' #' Obtains out-of-sample posterior predictions under the fitted parametric #' Bayesian model for ecological inference. \code{predict} method for class #' \code{eco} and \code{ecoX}. #' #' The posterior predictive values are computed using the Monte Carlo sample #' stored in the \code{eco} output (or other sample if \code{newdraw} is #' specified). Given each Monte Carlo sample of the parameters, we sample the #' vector-valued latent variable from the appropriate multivariate Normal #' distribution. Then, we apply the inverse logit transformation to obtain the #' predictive values of proportions, \eqn{W}. The computation may be slow #' (especially for the nonparametric model) if a large Monte Carlo sample of #' the model parameters is used. In either case, setting \code{verbose = TRUE} #' may be helpful in monitoring the progress of the code. #' #' @aliases predict.ecoX #' @param object An output object from \code{eco} or \code{ecoNP}. #' @param newdraw An optional list containing two matrices (or three #' dimensional arrays for the nonparametric model) of MCMC draws of \eqn{\mu} #' and \eqn{\Sigma}. Those elements should be named as \code{mu} and #' \code{Sigma}, respectively. The default is the original MCMC draws stored in #' \code{object}. #' @param newdata An optional data frame containing a new data set for which #' posterior predictions will be made. The new data set must have the same #' variable names as those in the original data. #' @param subset A scalar or numerical vector specifying the row number(s) of #' \code{mu} and \code{Sigma} in the output object from \code{eco}. If #' specified, the posterior draws of parameters for those rows are used for #' posterior prediction. The default is \code{NULL} where all the posterior #' draws are used. #' @param cond logical. If \code{TRUE}, then the conditional prediction will #' made for the parametric model with contextual effects. The default is #' \code{FALSE}. #' @param verbose logical. If \code{TRUE}, helpful messages along with a #' progress report on the Monte Carlo sampling from the posterior predictive #' distributions are printed on the screen. The default is \code{FALSE}. #' @param ... further arguments passed to or from other methods. #' @return \code{predict.eco} yields a matrix of class \code{predict.eco} #' containing the Monte Carlo sample from the posterior predictive distribution #' of inner cells of ecological tables. \code{summary.predict.eco} will #' summarize the output, and \code{print.summary.predict.eco} will print the #' summary. #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{eco}, \code{predict.ecoNP} #' @keywords methods predict.ecoX <- function(object, newdraw = NULL, subset = NULL, newdata = NULL, cond = FALSE, verbose = FALSE, ...){ if (is.null(newdraw) && is.null(object$mu)) stop("Posterior draws of mu and Sigma must be supplied") else if (!is.null(newdraw)){ if (is.null(newdraw$mu) && is.null(newdraw$Sigma)) stop("Posterior draws of both mu and Sigma must be supplied.") object <- newdraw } if (cond) { ## conditional prediction mu <- coef(object, subset = subset) n.draws <- nrow(mu) if (is.null(subset)) subset <- 1:n.draws Sigma <- object$Sigma[subset,] if (is.null(newdata)) X <- object$X else { mf <- match.call() if (is.matrix(eval.parent(mf$newdata))) data <- as.data.frame(data) tt <- terms(object) attr(tt, "intercept") <- 0 X <- model.matrix(tt, newdata) } n <- nrow(X) res <- .C("preBaseX", as.double(X), as.double(mu), as.double(t(Sigma)), as.integer(length(c(X))), as.integer(nrow(mu)), as.integer(verbose), pdStore = double(n.draws*n*2), PACKAGE="eco")$pdStore res <- array(res, c(2, n, n.draws), dimnames=list(c("W1", "W2"), rownames(X), 1:n.draws)) class(res) <- c("predict.ecoX", "array") } else { res <- predict.eco(object, newdraw = newdraw, subset = subset, newdata = newdata, verbose = verbose, ...) colnames(res) <- c("W1", "W2", "X") } return(res) } eco/R/ecoCV.R0000644000175100001440000000620013061770754012371 0ustar hornikusersecoX <- function(formula, Z, supplement = NULL, data = parent.frame(), nu0 = 4, S0 = 10, beta0 = 0, A0 = 100, grid = FALSE, parameter = FALSE, n.draws = 5000, burnin = 0, thin = 5, verbose = TRUE){ ## checking inputs if (burnin >= n.draws) stop("Error: n.draws should be larger than burnin") call <- match.call() ff <- as.formula(paste(call$Y, "~ -1 +", call$X)) if (is.matrix(eval.parent(call$data))) data <- as.data.frame(data) X <- model.matrix(ff, data) Y <- model.response(model.frame(ff, data=data)) ##survey data if (length(supplement) == 0) { survey.samp <- 0 survey.data <- 0 survey.yes<-0 } else { survey.samp <- length(supplement[,1]) survey.data <- as.matrix(supplement) survey.yes<-1 } ind<-c(1:length(X)) X1type<-0 X0type<-0 samp.X1<-0 samp.X0<-0 X1.W1<-0 X0.W2<-0 ##Xtype x=1 X1.ind<-ind[along=(X==1)] if (length(X[X!=1])= n.draws) stop("n.draws should be larger than burnin") if (length(mu0)==1) mu0 <- rep(mu0, ndim) else if (length(mu0)!=ndim) stop("invalid inputs for mu0") if (is.matrix(S0)) { if (any(dim(S0)!=ndim)) stop("invalid inputs for S0") } else S0 <- diag(S0, ndim) if (length(mu.start)==1) mu.start <- rep(mu.start, ndim) else if (length(mu.start)!=ndim) stop("invalid inputs for mu.start") if (is.matrix(Sigma.start)) { if (any(dim(Sigma.start)!=ndim)) stop("invalid inputs for Sigma.start") } else Sigma.start <- diag(Sigma.start, ndim) ## getting X, Y, and N mf <- match.call() tt <- terms(formula) attr(tt, "intercept") <- 0 if (is.matrix(eval.parent(mf$data))) data <- as.data.frame(data) X <- model.matrix(tt, data) Y <- model.response(model.frame(tt, data = data)) N <- eval(mf$N, data) # check data and modify inputs tmp <- checkdata(X,Y, supplement, ndim) bdd <- ecoBD(formula=formula, data=data) W1min <- bdd$Wmin[order(tmp$order.old)[1:nrow(tmp$d)],1,1] W1max <- bdd$Wmax[order(tmp$order.old)[1:nrow(tmp$d)],1,1] ## fitting the model n.store <- floor((n.draws-burnin)/(thin+1)) unit.par <- 1 unit.w <- tmp$n.samp+tmp$samp.X1+tmp$samp.X0 n.w <- n.store * unit.w if (context) res <- .C("cBaseecoX", as.double(tmp$d), as.integer(tmp$n.samp), as.integer(n.draws), as.integer(burnin), as.integer(thin+1), as.integer(verbose), as.integer(nu0), as.double(tau0), as.double(mu0), as.double(S0), as.double(mu.start), as.double(Sigma.start), as.integer(tmp$survey.yes), as.integer(tmp$survey.samp), as.double(tmp$survey.data), as.integer(tmp$X1type), as.integer(tmp$samp.X1), as.double(tmp$X1.W1), as.integer(tmp$X0type), as.integer(tmp$samp.X0), as.double(tmp$X0.W2), as.double(W1min), as.double(W1max), as.integer(parameter), as.integer(grid), pdSMu0 = double(n.store), pdSMu1 = double(n.store), pdSMu2 = double(n.store), pdSSig00=double(n.store), pdSSig01=double(n.store), pdSSig02=double(n.store), pdSSig11=double(n.store), pdSSig12=double(n.store), pdSSig22=double(n.store), pdSW1=double(n.w), pdSW2=double(n.w), PACKAGE="eco") else res <- .C("cBaseeco", as.double(tmp$d), as.integer(tmp$n.samp), as.integer(n.draws), as.integer(burnin), as.integer(thin+1), as.integer(verbose), as.integer(nu0), as.double(tau0), as.double(mu0), as.double(S0), as.double(mu.start), as.double(Sigma.start), as.integer(tmp$survey.yes), as.integer(tmp$survey.samp), as.double(tmp$survey.data), as.integer(tmp$X1type), as.integer(tmp$samp.X1), as.double(tmp$X1.W1), as.integer(tmp$X0type), as.integer(tmp$samp.X0), as.double(tmp$X0.W2), as.double(W1min), as.double(W1max), as.integer(parameter), as.integer(grid), pdSMu0=double(n.store), pdSMu1=double(n.store), pdSSig00=double(n.store), pdSSig01=double(n.store), pdSSig11=double(n.store), pdSW1=double(n.w), pdSW2=double(n.w), PACKAGE="eco") W1.post <- matrix(res$pdSW1, n.store, unit.w, byrow=TRUE)[,tmp$order.old] W2.post <- matrix(res$pdSW2, n.store, unit.w, byrow=TRUE)[,tmp$order.old] W <- array(rbind(W1.post, W2.post), c(n.store, 2, unit.w)) colnames(W) <- c("W1", "W2") res.out <- list(call = mf, X = X, Y = Y, N = N, W = W, Wmin=bdd$Wmin[,1,], Wmax = bdd$Wmax[,1,], burin = burnin, thin = thin, nu0 = nu0, tau0 = tau0, mu0 = mu0, S0 = S0) if (parameter) if (context) { res.out$mu <- cbind(matrix(res$pdSMu0, n.store, unit.par, byrow=TRUE), matrix(res$pdSMu1, n.store, unit.par, byrow=TRUE), matrix(res$pdSMu2, n.store, unit.par, byrow=TRUE)) colnames(res.out$mu) <- c("mu1", "mu2", "mu3") res.out$Sigma <- cbind(matrix(res$pdSSig00, n.store, unit.par, byrow=TRUE), matrix(res$pdSSig01, n.store, unit.par, byrow=TRUE), matrix(res$pdSSig02, n.store, unit.par, byrow=TRUE), matrix(res$pdSSig11, n.store, unit.par, byrow=TRUE), matrix(res$pdSSig12, n.store, unit.par, byrow=TRUE), matrix(res$pdSSig22, n.store, unit.par, byrow=TRUE)) colnames(res.out$Sigma) <- c("Sigma11", "Sigma12", "Sigma13", "Sigma22", "Sigma23", "Sigma33") } else { res.out$mu <- cbind(matrix(res$pdSMu0, n.store, unit.par, byrow=TRUE), matrix(res$pdSMu1, n.store, unit.par, byrow=TRUE)) colnames(res.out$mu) <- c("mu1", "mu2") res.out$Sigma <- cbind(matrix(res$pdSSig00, n.store, unit.par, byrow=TRUE), matrix(res$pdSSig01, n.store, unit.par, byrow=TRUE), matrix(res$pdSSig11, n.store, unit.par, byrow=TRUE)) colnames(res.out$Sigma) <- c("Sigma11", "Sigma12", "Sigma22") } if (context) class(res.out) <- c("ecoX","eco") else class(res.out) <- c("eco") return(res.out) } eco/R/coef.ecoNP.R0000644000175100001440000000072113061770754013313 0ustar hornikuserscoef.ecoNP <- function(object, subset = NULL, obs = NULL, ...) { mu <- object$mu if (is.null(subset)) subset <- 1:nrow(mu) else if (max(subset) > nrow(mu)) stop(paste("invalid input for `subset.' only", nrow(mu), "draws are stored.")) if (is.null(obs)) obs <- 1:dim(object$mu)[3] else if (max(subset) > dim(object$mu)[3]) stop(paste("invalid input for `obs.' only", dim(object$mu)[3], "draws are stored.")) return(mu[subset,,obs]) } eco/R/housep88.R0000644000175100001440000000302213104457061013043 0ustar hornikusers #' Electoral Results for the House and Presidential Races in 1988 #' #' This data set contains, on a House district level, the percentage of the #' vote for the Democratic House candidate, the percentage of the vote for the #' Democratic presidential candidate (Dukakis), the number of voters who voted #' for a major party candidate in the presidential race, and the ratio of #' voters in the House race versus the number who cast a ballot for President. #' Eleven (11) uncontested races are not included. Dataset compiled and #' analyzed by Burden and Kimball (1988). Complete dataset and documentation #' available at ICSPR study number 1140. #' #' #' @name housep88 #' @docType data #' @format A data frame containing 5 variables and 424 observations #' \tabular{lll}{ X \tab numeric \tab proportion voting for the Democrat in the #' presidential race \cr Y \tab numeric \tab proportion voting for the Democrat #' in the House race \cr N \tab numeric \tab number of major party voters in #' the presidential contest \cr HPCT \tab numeric \tab House election turnout #' divided by presidential election turnout (set to 1 if House turnout exceeds #' presidential turnout) \cr DIST \tab numeric \tab 4-digit ICPSR state and #' district code: first 2 digits for the state code, last two digits for the #' district number (e.g., 2106=IL 6th) } #' @references Burden, Barry C. and David C. Kimball (1988). ``A New Approach #' To Ticket- Splitting.'' The American Political Science Review. vol 92., no. #' 3, pp. 553-544. #' @keywords datasets NULL eco/R/forgnlit30.R0000644000175100001440000000215013104457061013350 0ustar hornikusers #' Foreign-born literacy in 1930 #' #' This data set contains, on a state level, the proportion of white residents #' ten years and older who are foreign born, and the proportion of those #' residents who are literate. Data come from the 1930 census and were first #' analyzed by Robinson (1950). #' #' #' @name forgnlit30 #' @docType data #' @format A data frame containing 5 variables and 48 observations #' \tabular{lll}{ X \tab numeric \tab proportion of the white population at #' least 10 years of age that is foreign born \cr Y \tab numeric \tab #' proportion of the white population at least 10 years of age that is #' illiterate \cr W1 \tab numeric \tab proportion of the foreign-born white #' population at least 10 years of age that is illiterate \cr W2 \tab numeric #' \tab proportion of the native-born white population at least 10 years of age #' that is illiterate \cr ICPSR \tab numeric \tab the ICPSR state code } #' @references Robinson, W.S. (1950). ``Ecological Correlations and the #' Behavior of Individuals.'' \emph{American Sociological Review}, vol. 15, #' pp.351-357. #' @keywords datasets NULL eco/R/print.ecoML.R0000644000175100001440000000224313061770754013527 0ustar hornikusersprint.ecoML <- function(x, digits = max(3, getOption("digits") -3), ...){ cat("\nCall:\n", deparse(x$call), "\n\n", sep="") n.col<-5 if (x$fix.rho) n.col<-4 n.row<-1 if (x$sem) n.row<-3 param.table<-matrix(NA, n.row, n.col) if (!x$context) param.table[1,]<-x$theta.em else if (x$context && !x$fix.rho) param.table[1,]<-x$theta.em[c(2,3,5,6,9)] else if (x$context && x$fix.rho) param.table[1,]<-x$theta.em[c(2,3,5,6)] if (n.row>1) { if (!x$context) { param.table[2,]<-sqrt(diag(x$Vobs)) param.table[3,]<-Fmis<-1-diag(x$Iobs)/diag(x$Icom) } else if (x$context && !x$fix.rho) { param.table[2,]<-sqrt(diag(x$Vobs))[c(2,3,5,6,9)] param.table[3,]<-Fmis<-(1-diag(x$Iobs)/diag(x$Icom))[c(2,3,5,6,9)] } else if (x$context && x$fix.rho) { param.table[2,]<-sqrt(diag(x$Vobs))[c(2,3,5,6)] param.table[3,]<-Fmis<-(1-diag(x$Iobs)/diag(x$Icom))[c(2,3,5,6)] } } cname<-c("mu1", "mu2", "sigma1", "sigma2", "rho") rname<-c("EM est.", "std. err.", "frac. missing") rownames(param.table)<-rname[1:n.row] colnames(param.table)<-cname[1:n.col] print(param.table) cat("\n") invisible(x) } eco/R/print.summary.eco.R0000644000175100001440000000506513104457061014766 0ustar hornikusers#' Print the Summary of the Results for the Bayesian Parametric Model for Ecological #' Inference in 2x2 Tables #' #' \code{summary} method for class \code{eco}. #' #' #' @aliases print.summary.eco #' @param x An object of class \code{summary.eco}. #' @param digits the number of significant digits to use when printing. #' @param ... further arguments passed to or from other methods. #' @return \code{summary.eco} yields an object of class \code{summary.eco} #' containing the following elements: #' \item{call}{The call from \code{eco}.} #' \item{n.obs}{The number of units.} #' \item{n.draws}{The number of Monte Carlo samples.} #' \item{agg.table}{Aggregate posterior estimates of the marginal #' means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If #' \code{param = TRUE}, the following elements are also included: #' \item{param.table}{Posterior estimates of model parameters: population mean #' estimates of \eqn{W_1} and \eqn{W_2} and their logit transformations.} If #' \code{units = TRUE}, the following elements are also included: #' \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} #' \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} #' #' This object can be printed by \code{print.summary.eco} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{eco}, \code{predict.eco} #' @keywords methods print.summary.eco <- function(x, digits=max(3, getOption("digits")-3), ...) { cat("\nCall: ") cat(paste(deparse(x$call), sep="\n", collapse="\n")) cat("\n") if (!is.null(x$param.table)) { cat("\nParameter Estimates:\n") print(x$param.table, digits=digits, na.print="NA",...) } cat("\n*** Insample Predictions ***\n") cat("\nUnweighted:\n") print(x$agg.table, digits=digits, na.print="NA",...) if (!is.null(x$agg.wtable)) { cat("\nWeighted:\n") print(x$agg.wtable, digits=digits, na.print="NA",...) } cat("\nNumber of Units:", x$n.obs) cat("\nNumber of Monte Carlo Draws:", x$n.draws) if (!is.null(x$W1.table)) { cat("\n\nUnit-level Estimates of W1:\n") print(x$W1.table, digits=digits, na.print="NA",...) cat("\n\nUnit-level Estimates of W2:\n") print(x$W2.table, digits=digits, na.print="NA",...) } cat("\n") invisible(x) } eco/R/predict.ecoNPX.R0000644000175100001440000001077013104457061014155 0ustar hornikusers#' Out-of-Sample Posterior Prediction under the Nonparametric Bayesian Model #' for Ecological Inference in 2x2 Tables #' #' Obtains out-of-sample posterior predictions under the fitted nonparametric #' Bayesian model for ecological inference. \code{predict} method for class #' \code{ecoNP} and \code{ecoNPX}. #' #' The posterior predictive values are computed using the Monte Carlo sample #' stored in the \code{eco} or \code{ecoNP} output (or other sample if #' \code{newdraw} is specified). Given each Monte Carlo sample of the #' parameters, we sample the vector-valued latent variable from the appropriate #' multivariate Normal distribution. Then, we apply the inverse logit #' transformation to obtain the predictive values of proportions, \eqn{W}. The #' computation may be slow (especially for the nonparametric model) if a large #' Monte Carlo sample of the model parameters is used. In either case, setting #' \code{verbose = TRUE} may be helpful in monitoring the progress of the code. #' #' @aliases predict.ecoNPX #' @param object An output object from \code{ecoNP}. #' @param newdraw An optional list containing two matrices (or three #' dimensional arrays for the nonparametric model) of MCMC draws of \eqn{\mu} #' and \eqn{\Sigma}. Those elements should be named as \code{mu} and #' \code{Sigma}, respectively. The default is the original MCMC draws stored in #' \code{object}. #' @param subset A scalar or numerical vector specifying the row number(s) of #' \code{mu} and \code{Sigma} in the output object from \code{eco}. If #' specified, the posterior draws of parameters for those rows are used for #' posterior prediction. The default is \code{NULL} where all the posterior #' draws are used. #' @param obs An integer or vector of integers specifying the observation #' number(s) whose posterior draws will be used for predictions. The default is #' \code{NULL} where all the observations in the data set are selected. #' @param cond logical. If \code{TRUE}, then the conditional prediction will #' made for the parametric model with contextual effects. The default is #' \code{FALSE}. #' @param verbose logical. If \code{TRUE}, helpful messages along with a #' progress report on the Monte Carlo sampling from the posterior predictive #' distributions are printed on the screen. The default is \code{FALSE}. #' @param ... further arguments passed to or from other methods. #' @return \code{predict.eco} yields a matrix of class \code{predict.eco} #' containing the Monte Carlo sample from the posterior predictive distribution #' of inner cells of ecological tables. \code{summary.predict.eco} will #' summarize the output, and \code{print.summary.predict.eco} will print the #' summary. #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{eco}, \code{ecoNP}, \code{summary.eco}, \code{summary.ecoNP} #' @keywords methods predict.ecoNPX <- function(object, newdraw = NULL, subset = NULL, obs = NULL, cond = FALSE, verbose = FALSE, ...){ if (is.null(newdraw) && is.null(object$mu)) stop("Posterior draws of mu and Sigma must be supplied") else if (!is.null(newdraw)){ if (is.null(newdraw$mu) && is.null(newdraw$Sigma)) stop("Posterior draws of both mu and Sigma must be supplied.") object <- newdraw } n.draws <- dim(object$mu)[1] n <- dim(object$mu)[3] mu <- aperm(coef(object, subset = subset, obs = obs), c(2,3,1)) if (is.null(subset)) subset <- 1:n.draws if (is.null(obs)) obs <- 1:n Sigma <- aperm(object$Sigma[subset,,obs], c(2,3,1)) if (cond) { # conditional prediction X <- object$X res <- .C("preDPX", as.double(mu), as.double(Sigma), as.double(X), as.integer(n), as.integer(n.draws), as.integer(2), as.integer(verbose), pdStore = double(n.draws*2*n), PACKAGE="eco")$pdStore res <- matrix(res, ncol=2, nrow=n.draws*n, byrow=TRUE) colnames(res) <- c("W1", "W2") } else { # unconditional prediction res <- .C("preDP", as.double(mu), as.double(Sigma), as.integer(n), as.integer(n.draws), as.integer(3), as.integer(verbose), pdStore = double(n.draws*3*n), PACKAGE="eco")$pdStore res <- matrix(res, ncol=3, nrow=n.draws*n, byrow=TRUE) colnames(res) <- c("W1", "W2", "X") } class(res) <- c("predict.eco", "matrix") return(res) } eco/R/coef.eco.R0000644000175100001440000000040413061770754013053 0ustar hornikuserscoef.eco <- function(object, subset = NULL, ...) { mu <- object$mu if (is.null(subset)) subset <- 1:nrow(mu) else if (max(subset) > nrow(mu)) stop(paste("invalid input for `subset.' only", nrow(mu), "draws are stored.")) return(mu[subset,]) } eco/R/predict.ecoNP.R0000644000175100001440000000762413104457061014031 0ustar hornikusers#' Out-of-Sample Posterior Prediction under the Nonparametric Bayesian Model #' for Ecological Inference in 2x2 Tables #' #' Obtains out-of-sample posterior predictions under the fitted nonparametric #' Bayesian model for ecological inference. \code{predict} method for class #' \code{ecoNP} and \code{ecoNPX}. #' #' The posterior predictive values are computed using the Monte Carlo sample #' stored in the \code{eco} or \code{ecoNP} output (or other sample if #' \code{newdraw} is specified). Given each Monte Carlo sample of the #' parameters, we sample the vector-valued latent variable from the appropriate #' multivariate Normal distribution. Then, we apply the inverse logit #' transformation to obtain the predictive values of proportions, \eqn{W}. The #' computation may be slow (especially for the nonparametric model) if a large #' Monte Carlo sample of the model parameters is used. In either case, setting #' \code{verbose = TRUE} may be helpful in monitoring the progress of the code. #' #' @aliases predict.ecoNP #' @param object An output object from \code{ecoNP}. #' @param newdraw An optional list containing two matrices (or three #' dimensional arrays for the nonparametric model) of MCMC draws of \eqn{\mu} #' and \eqn{\Sigma}. Those elements should be named as \code{mu} and #' \code{Sigma}, respectively. The default is the original MCMC draws stored in #' \code{object}. #' @param subset A scalar or numerical vector specifying the row number(s) of #' \code{mu} and \code{Sigma} in the output object from \code{eco}. If #' specified, the posterior draws of parameters for those rows are used for #' posterior prediction. The default is \code{NULL} where all the posterior #' draws are used. #' @param obs An integer or vector of integers specifying the observation #' number(s) whose posterior draws will be used for predictions. The default is #' \code{NULL} where all the observations in the data set are selected. #' @param verbose logical. If \code{TRUE}, helpful messages along with a #' progress report on the Monte Carlo sampling from the posterior predictive #' distributions are printed on the screen. The default is \code{FALSE}. #' @param ... further arguments passed to or from other methods. #' @return \code{predict.eco} yields a matrix of class \code{predict.eco} #' containing the Monte Carlo sample from the posterior predictive distribution #' of inner cells of ecological tables. \code{summary.predict.eco} will #' summarize the output, and \code{print.summary.predict.eco} will print the #' summary. #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{eco}, \code{ecoNP}, \code{summary.eco}, \code{summary.ecoNP} #' @keywords methods predict.ecoNP <- function(object, newdraw = NULL, subset = NULL, obs = NULL, verbose = FALSE, ...){ if (is.null(newdraw) && is.null(object$mu)) stop("Posterior draws of mu and Sigma must be supplied") else if (!is.null(newdraw)){ if (is.null(newdraw$mu) && is.null(newdraw$Sigma)) stop("Posterior draws of both mu and Sigma must be supplied.") object <- newdraw } n.draws <- dim(object$mu)[1] p <- dim(object$mu)[2] n <- dim(object$mu)[3] mu <- aperm(coef(object, subset = subset, obs = obs), c(2,3,1)) if (is.null(subset)) subset <- 1:n.draws if (is.null(obs)) obs <- 1:n Sigma <- aperm(object$Sigma[subset,,obs], c(2,3,1)) res <- .C("preDP", as.double(mu), as.double(Sigma), as.integer(n), as.integer(n.draws), as.integer(p), as.integer(verbose), pdStore = double(n.draws*p*n), PACKAGE="eco")$pdStore res <- matrix(res, ncol=p, nrow=n.draws*n, byrow=TRUE) colnames(res) <- c("W1", "W2") class(res) <- c("predict.eco", "matrix") return(res) } eco/R/emeco.R0000644000175100001440000004405613104457061012464 0ustar hornikusers### ### main function ### #' Fitting Parametric Models and Quantifying Missing Information for Ecological #' Inference in 2x2 Tables #' #' \code{ecoML} is used to fit parametric models for ecological inference in #' \eqn{2 \times 2} tables via Expectation Maximization (EM) algorithms. The #' data is specified in proportions. At it's most basic setting, the algorithm #' assumes that the individual-level proportions (i.e., \eqn{W_1} and #' \eqn{W_2}) and distributed bivariate normally (after logit transformations). #' The function calculates point estimates of the parameters for models based #' on different assumptions. The standard errors of the point estimates are #' also computed via Supplemented EM algorithms. Moreover, \code{ecoML} #' quantifies the amount of missing information associated with each parameter #' and allows researcher to examine the impact of missing information on #' parameter estimation in ecological inference. The models and algorithms are #' described in Imai, Lu and Strauss (2008, 2011). #' #' When \code{SEM} is \code{TRUE}, \code{ecoML} computes the observed-data #' information matrix for the parameters of interest based on Supplemented-EM #' algorithm. The inverse of the observed-data information matrix can be used #' to estimate the variance-covariance matrix for the parameters estimated from #' EM algorithms. In addition, it also computes the expected complete-data #' information matrix. Based on these two measures, one can further calculate #' the fraction of missing information associated with each parameter. See #' Imai, Lu and Strauss (2006) for more details about fraction of missing #' information. #' #' Moreover, when \code{hytest=TRUE}, \code{ecoML} allows to estimate the #' parametric model under the null hypothesis that \code{mu_1=mu_2}. One can #' then construct the likelihood ratio test to assess the hypothesis of equal #' means. The associated fraction of missing information for the test statistic #' can be also calculated. For details, see Imai, Lu and Strauss (2006) for #' details. #' #' @param formula A symbolic description of the model to be fit, specifying the #' column and row margins of \eqn{2 \times 2} ecological tables. \code{Y ~ X} #' specifies \code{Y} as the column margin (e.g., turnout) and \code{X} (e.g., #' percent African-American) as the row margin. Details and specific examples #' are given below. #' @param data An optional data frame in which to interpret the variables in #' \code{formula}. The default is the environment in which \code{ecoML} is #' called. #' @param N An optional variable representing the size of the unit; e.g., the #' total number of voters. \code{N} needs to be a vector of same length as #' \code{Y} and \code{X} or a scalar. #' @param supplement An optional matrix of supplemental data. The matrix has #' two columns, which contain additional individual-level data such as survey #' data for \eqn{W_1} and \eqn{W_2}, respectively. If \code{NULL}, no #' additional individual-level data are included in the model. The default is #' \code{NULL}. #' @param fix.rho Logical. If \code{TRUE}, the correlation (when #' \code{context=TRUE}) or the partial correlation (when \code{context=FALSE}) #' between \eqn{W_1} and \eqn{W_2} is fixed through the estimation. For #' details, see Imai, Lu and Strauss(2006). The default is \code{FALSE}. #' @param context Logical. If \code{TRUE}, the contextual effect is also #' modeled. In this case, the row margin (i.e., X) and the individual-level #' rates (i.e., \eqn{W_1} and \eqn{W_2}) are assumed to be distributed #' tri-variate normally (after logit transformations). See Imai, Lu and Strauss #' (2006) for details. The default is \code{FALSE}. #' @param sem Logical. If \code{TRUE}, the standard errors of parameter #' estimates are estimated via SEM algorithm, as well as the fraction of #' missing data. The default is \code{TRUE}. #' @param theta.start A numeric vector that specifies the starting values for #' the mean, variance, and covariance. When \code{context = FALSE}, the #' elements of \code{theta.start} correspond to (\eqn{E(W_1)}, \eqn{E(W_2)}, #' \eqn{var(W_1)}, \eqn{var(W_2)}, \eqn{cor(W_1,W_2)}). When \code{context = #' TRUE}, the elements of \code{theta.start} correspond to (\eqn{E(W_1)}, #' \eqn{E(W_2)}, \eqn{var(W_1)}, \eqn{var(W_2)}, \eqn{corr(W_1, X)}, #' \eqn{corr(W_2, X)}, \eqn{corr(W_1,W_2)}). Moreover, when #' \code{fix.rho=TRUE}, \eqn{corr(W_1,W_2)} is set to be the correlation #' between \eqn{W_1} and \eqn{W_2} when \code{context = FALSE}, and the partial #' correlation between \eqn{W_1} and \eqn{W_2} given \eqn{X} when \code{context #' = FALSE}. The default is \code{c(0,0,1,1,0)}. #' @param epsilon A positive number that specifies the convergence criterion #' for EM algorithm. The square root of \code{epsilon} is the convergence #' criterion for SEM algorithm. The default is \code{10^(-6)}. #' @param maxit A positive integer specifies the maximum number of iterations #' before the convergence criterion is met. The default is \code{1000}. #' @param loglik Logical. If \code{TRUE}, the value of the log-likelihood #' function at each iteration of EM is saved. The default is \code{TRUE}. #' @param hyptest Logical. If \code{TRUE}, model is estimated under the null #' hypothesis that means of \eqn{W1} and \eqn{W2} are the same. The default is #' \code{FALSE}. #' @param verbose Logical. If \code{TRUE}, the progress of the EM and SEM #' algorithms is printed to the screen. The default is \code{FALSE}. #' @return An object of class \code{ecoML} containing the following elements: #' \item{call}{The matched call.} #' \item{X}{The row margin, \eqn{X}.} #' \item{Y}{The column margin, \eqn{Y}.} #' \item{N}{The size of each table, \eqn{N}.} #' \item{context}{The assumption under which model is estimated. If #' \code{context = FALSE}, CAR assumption is adopted and no contextual effect #' is modeled. If \code{context = TRUE}, NCAR assumption is adopted, and #' contextual effect is modeled.} \item{sem}{Whether SEM algorithm is used to #' estimate the standard errors and observed information matrix for the #' parameter estimates.} #' \item{fix.rho}{Whether the correlation or the partial #' correlation between \eqn{W_1} an \eqn{W_2} is fixed in the estimation.} #' \item{r12}{If \code{fix.rho = TRUE}, the value that \eqn{corr(W_1, W_2)} is #' fixed to.} #' \item{epsilon}{The precision criterion for EM convergence. #' \eqn{\sqrt{\epsilon}} is the precision criterion for SEM convergence.} #' \item{theta.sem}{The ML estimates of \eqn{E(W_1)},\eqn{E(W_2)}, #' \eqn{var(W_1)},\eqn{var(W_2)}, and \eqn{cov(W_1,W_2)}. If \code{context = #' TRUE}, \eqn{E(X)},\eqn{cov(W_1,X)}, \eqn{cov(W_2,X)} are also reported.} #' \item{W}{In-sample estimation of \eqn{W_1} and \eqn{W_2}.} #' \item{suff.stat}{The sufficient statistics for \code{theta.em}.} #' \item{iters.em}{Number of EM iterations before convergence is achieved.} #' \item{iters.sem}{Number of SEM iterations before convergence is achieved.} #' \item{loglik}{The log-likelihood of the model when convergence is achieved.} #' \item{loglik.log.em}{A vector saving the value of the log-likelihood #' function at each iteration of the EM algorithm.} #' \item{mu.log.em}{A matrix saving the unweighted mean estimation of the #' logit-transformed individual-level proportions (i.e., \eqn{W_1} and \eqn{W_2}) #' at each iteration of the EM process.} \item{Sigma.log.em}{A matrix saving the #' log of the variance estimation of the logit-transformed individual-level #' proportions (i.e., \eqn{W_1} and \eqn{W_2}) at each iteration of EM process. #' Note, non-transformed variances are displayed on the screen (when #' \code{verbose = TRUE}).} #' \item{rho.fisher.em}{A matrix saving the fisher #' transformation of the estimation of the correlations between the #' logit-transformed individual-level proportions (i.e., \eqn{W_1} and #' \eqn{W_2}) at each iteration of EM process. Note, non-transformed #' correlations are displayed on the screen (when \code{verbose = TRUE}).} #' Moreover, when \code{sem=TRUE}, \code{ecoML} also output the following #' values: #' \item{DM}{The matrix characterizing the rates of convergence of the #' EM algorithms. Such information is also used to calculate the observed-data #' information matrix} #' \item{Icom}{The (expected) complete data information #' matrix estimated via SEM algorithm. When \code{context=FALSE, fix.rho=TRUE}, #' \code{Icom} is 4 by 4. When \code{context=FALSE, fix.rho=FALSE}, \code{Icom} #' is 5 by 5. When \code{context=TRUE}, \code{Icom} is 9 by 9.} #' \item{Iobs}{The observed information matrix. The dimension of \code{Iobs} #' is same as \code{Icom}.} #' \item{Imiss}{The difference between \code{Icom} and \code{Iobs}. #' The dimension of \code{Imiss} is same as \code{miss}.} #' \item{Vobs}{The (symmetrized) variance-covariance matrix of the ML parameter #' estimates. The dimension of \code{Vobs} is same as \code{Icom}.} #' \item{Iobs}{The (expected) complete-data variance-covariance matrix. The #' dimension of \code{Iobs} is same as \code{Icom}.} #' \item{Vobs.original}{The estimated variance-covariance matrix of the ML parameter #' estimates. The dimension of \code{Vobs} is same as \code{Icom}.} #' \item{Fmis}{The fraction of missing information associated with each parameter estimation. } #' \item{VFmis}{The proportion of increased variance associated with each #' parameter estimation due to observed data. } #' \item{Ieigen}{The largest eigen value of \code{Imiss}.} #' \item{Icom.trans}{The complete data information #' matrix for the fisher transformed parameters.} #' \item{Iobs.trans}{The observed data information matrix for the fisher transformed parameters.} #' \item{Fmis.trans}{The fractions of missing information associated with the #' fisher transformed parameters.} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University, \email{ying.lu@@nyu.Edu}; Aaron Strauss, #' Department of Politics, Princeton University, #' \email{abstraus@@Princeton.Edu}. #' @seealso \code{eco}, \code{ecoNP}, \code{summary.ecoML} #' @references Imai, Kosuke, Ying Lu and Aaron Strauss. (2011). \dQuote{eco: R #' Package for Ecological Inference in 2x2 Tables} Journal of Statistical #' Software, Vol. 42, No. 5, pp. 1-23. available at #' \url{http://imai.princeton.edu/software/eco.html} #' #' Imai, Kosuke, Ying Lu and Aaron Strauss. (2008). \dQuote{Bayesian and #' Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data #' Approach} Political Analysis, Vol. 16, No. 1 (Winter), pp. 41-69. available #' at \url{http://imai.princeton.edu/research/eiall.html} #' @keywords models #' @examples #' #' #' ## load the census data #' data(census) #' #' ## NOTE: convergence has not been properly assessed for the following #' ## examples. See Imai, Lu and Strauss (2006) for more complete analyses. #' ## In the first example below, in the interest of time, only part of the #' ## data set is analyzed and the convergence requirement is less stringent #' ## than the default setting. #' #' ## In the second example, the program is arbitrarily halted 100 iterations #' ## into the simulation, before convergence. #' #' ## load the Robinson's census data #' data(census) #' #' ## fit the parametric model with the default model specifications #' \dontrun{res <- ecoML(Y ~ X, data = census[1:100,], N=census[1:100,3], #' epsilon=10^(-6), verbose = TRUE)} #' ## summarize the results #' \dontrun{summary(res)} #' #' ## obtain out-of-sample prediction #' \dontrun{out <- predict(res, verbose = TRUE)} #' ## summarize the results #' \dontrun{summary(out)} #' #' ## fit the parametric model with some individual #' ## level data using the default prior specification #' surv <- 1:600 #' \dontrun{res1 <- ecoML(Y ~ X, context = TRUE, data = census[-surv,], #' supplement = census[surv,c(4:5,1)], maxit=100, verbose = TRUE)} #' ## summarize the results #' \dontrun{summary(res1)} #' #' ecoML <- function(formula, data = parent.frame(), N=NULL, supplement = NULL, theta.start = c(0,0,1,1,0), fix.rho = FALSE, context = FALSE, sem = TRUE, epsilon=10^(-6), maxit = 1000, loglik = TRUE, hyptest=FALSE, verbose= FALSE) { ## getting X and Y mf <- match.call() tt <- terms(formula) attr(tt, "intercept") <- 0 if (is.matrix(eval.parent(mf$data))) data <- as.data.frame(data) X <- model.matrix(tt, data) Y <- model.response(model.frame(tt, data=data)) #n.var: total number of parameters involved in the estimation #n.par: number of nonstatic paramters need to estimate through EM # also need SEM #ndim: dimension of the multivariate normal distribution ndim<-2 if (context) ndim<-3 n.var<-2*ndim+ ndim*(ndim-1)/2 n.par<-n.S<-n.var if (context) { n.par<-n.var-2 } r12<-NULL if (fix.rho) r12<-theta.start[n.par] if (!context & fix.rho) n.par<-n.par-1 flag<-as.integer(context)+2*as.integer(fix.rho)+2^2*as.integer(sem) ##checking data tmp <- checkdata(X, Y, supplement, ndim) bdd <- ecoBD(formula=formula, data=data) W1min <- bdd$Wmin[order(tmp$order.old)[1:nrow(tmp$d)],1,1] W1max <- bdd$Wmax[order(tmp$order.old)[1:nrow(tmp$d)],1,1] n <- tmp$n.samp+tmp$survey.samp+tmp$samp.X1+tmp$samp.X0 wcol<-ndim if (context) { wcol<-wcol-1 } inSample.length <- wcol*tmp$n.samp #if NCAR and the user did not provide a theta.start if (context && (length(theta.start)==5) ) theta.start<-c(0,0,1,1,0,0,0) ## Fitting the model via EM res <- .C("cEMeco", as.double(tmp$d), as.double(theta.start), as.integer(tmp$n.samp), as.integer(maxit), as.double(epsilon), as.integer(tmp$survey.yes), as.integer(tmp$survey.samp), as.double(tmp$survey.data), as.integer(tmp$X1type), as.integer(tmp$samp.X1), as.double(tmp$X1.W1), as.integer(tmp$X0type), as.integer(tmp$samp.X0), as.double(tmp$X0.W2), as.double(W1min), as.double(W1max), as.integer(flag),as.integer(verbose),as.integer(loglik),as.integer(hyptest), optTheta=rep(-1.1,n.var), pdTheta=double(n.var), S=double(n.S+1),inSample=double(inSample.length),DMmatrix=double(n.par*n.par), itersUsed=as.integer(0),history=double((maxit+1)*(n.var+1)), PACKAGE="eco") ##record results from EM theta.em<-res$pdTheta theta.fisher<-param.trans(theta.em, transformation="Fisher") iters.em<-res$itersUsed mu.log.em <- matrix(rep(NA,iters.em*ndim),ncol=ndim) sigma.log.em <- matrix(rep(NA,iters.em*ndim),ncol=ndim) loglike.log.em <- as.double(rep(NA,iters.em)) nrho<-length(theta.em)-2*ndim rho.fisher.em <- matrix(rep(NA,iters.em*nrho),ncol=nrho) for(i in 1:iters.em) { mu.log.em[i,1:ndim]=res$history[(i-1)*(n.var+1)+(1:ndim)] sigma.log.em[i,1:ndim]=res$history[(i-1)*(n.var+1)+ndim+(1:ndim)] if (nrho!=0) rho.fisher.em[i, 1:nrho]=res$history[(i-1)*(n.var+1)+2*ndim+(1:nrho)] loglike.log.em[i]=res$history[(i-1)*(n.var+1)+2*ndim+nrho+1] } ## In sample prediction of W W <- matrix(rep(NA,inSample.length),ncol=wcol) for (i in 1:tmp$n.samp) for (j in 1:wcol) W[i,j]=res$inSample[(i-1)*2+j] ## SEM step iters.sem<-0 suff.stat<-res$S if (context) { suff.stat<-rep(0,(n.var+1)) suff.stat[1]<-mean(logit(c(X,supplement[,3]))) suff.stat[2:3]<-res$S[1:2] suff.stat[4]<-mean((logit(c(X, supplement[,3])))^2) suff.stat[5:6]<-res$S[3:4] suff.stat[7:8]<-res$S[6:7] suff.stat[9]<-res$S[5] suff.stat[10]<-res$S[8] } if (sem) { DM <- matrix(rep(NA,n.par*n.par),ncol=n.par) res <- .C("cEMeco", as.double(tmp$d), as.double(theta.start), as.integer(tmp$n.samp), as.integer(maxit), as.double(epsilon), as.integer(tmp$survey.yes), as.integer(tmp$survey.samp), as.double(tmp$survey.data), as.integer(tmp$X1type), as.integer(tmp$samp.X1), as.double(tmp$X1.W1), as.integer(tmp$X0type), as.integer(tmp$samp.X0), as.double(tmp$X0.W2), as.double(bdd$Wmin[,1,1]), as.double(bdd$Wmax[,1,1]), as.integer(flag),as.integer(verbose),as.integer(loglik),as.integer(hyptest), res$pdTheta, pdTheta=double(n.var), S=double(n.S+1), inSample=double(inSample.length),DMmatrix=double(n.par*n.par), itersUsed=as.integer(0),history=double((maxit+1)*(n.var+1)), PACKAGE="eco") iters.sem<-res$itersUsed for(i in 1:n.par) for(j in 1:n.par) DM[i,j]=res$DMmatrix[(i-1)*n.par+j] } if (!context) names(theta.em)<-c("u1","u2","s1","s2","r12") if (context) names(theta.em)<-c("ux","u1","u2","sx","s1","s2","r1x","r2x","r12") ## output res.out<-list(call = mf, Y = Y, X = X, N = N, fix.rho = fix.rho, context = context, sem=sem, epsilon=epsilon, theta.em=theta.em, r12=r12, sigma.log = theta.fisher[(ndim+1):(2*ndim)], suff.stat = suff.stat[1:n.S], loglik = res$S[n.S+1], iters.em = iters.em, iters.sem = iters.sem, mu.log.em = mu.log.em, sigma.log.em = sigma.log.em, rho.fisher.em = rho.fisher.em, loglike.log.em = loglike.log.em, W = W) if (sem) { res.out$DM<-DM #print(dim(data)) # n<-dim(data)[1] if (!is.null(supplement)) n<-n+dim(supplement)[1] #cat("n2=", n,"\n") res.info<- ecoINFO(theta.em=res.out$theta.em, suff.stat=res.out$suff.stat, DM=res.out$DM, context=context, fix.rho=fix.rho, sem=sem, r12=res.out$r12, n=n) res.out$DM<-res.info$DM res.out$Icom<-res.info$Icom res.out$Iobs<-res.info$Iobs res.out$Fmis<-res.info$Fmis res.out$Vobs.original<-res.info$Vobs.original res.out$Vobs<-res.info$Vobs res.out$Iobs<-res.info$Iobs res.out$VFmis<-res.info$VFmis res.out$Icom.trans<-res.info$Icom.trans res.out$Iobs.trans<-res.info$Iobs.trans res.out$Fmis.trans<-res.info$Fmis.trans res.out$Imiss<-res.info$Imiss res.out$Ieigen<-res.info$Ieigen res.out$Iobs<-res.info$Iobs } class(res.out) <- "ecoML" return(res.out) } eco/R/checkdata.R0000644000175100001440000000261613061770754013310 0ustar hornikuserscheckdata <- function(X,Y, supplement, ndim) { # check and reorganize inputs if (any(X<0) || any(X>1) || any(Y<0) || any(Y>1)) stop("Values of X and Y have to be between 0 and 1.") ind <- 1:length(X) res <- list() res$X1type <- res$samp.X1 <- res$X1.W1 <- 0 res$X0type <- res$samp.X0 <- res$X0.W2 <- 0 ## X = 1 X1.ind <- ind[along=(X==1)] if (length(X[X!=1])1)) stop("survey data have to be between 0 and 1.") if(is.null(supplement)) res$survey.samp <- res$survey.data <- res$survey.yes <- 0 else if (dim(supplement)[2] != ndim) stop("when context=TRUE, use n by 3. Otherwise use n by 2 matrix for survey data") else { res$survey.samp <- length(supplement[,1]) res$survey.data <- as.matrix(supplement) res$survey.yes <- 1 } return(res) } eco/R/Qfun.R0000644000175100001440000000405713104457061012302 0ustar hornikusers#' Fitting the Parametric Bayesian Model of Ecological Inference in 2x2 Tables #' #' \code{Qfun} returns the complete log-likelihood that is used to calculate #' the fraction of missing information. #' #' #' @param theta A vector that contains the MLE \eqn{E(W_1)},\eqn{E(W_2)}, #' \eqn{var(W_1)},\eqn{var(W_2)}, and \eqn{cov(W_1,W_2)}. Typically it is the #' element \code{theta.em} of an object of class \code{ecoML}. #' @param suff.stat A vector of sufficient statistics of \eqn{E(W_1)}, #' \eqn{E(W_2)}, \eqn{var(W_1)},\eqn{var(W_2)}, and \eqn{cov(W_1,W_2)}. #' @param n A integer representing the sample size. #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} Aaron Strauss, #' Department of Politics, Princeton University, #' \email{abstraus@@Princeton.Edu}. #' @seealso \code{ecoML} #' @references Imai, Kosuke, Ying Lu and Aaron Strauss. (2011). \dQuote{eco: R #' Package for Ecological Inference in 2x2 Tables} Journal of Statistical #' Software, Vol. 42, No. 5, pp. 1-23. available at #' \url{http://imai.princeton.edu/software/eco.html} #' #' Imai, Kosuke, Ying Lu and Aaron Strauss. (2008). \dQuote{Bayesian and #' Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data #' Approach} Political Analysis, Vol. 16, No. 1 (Winter), pp. 41-69. available #' at \url{http://imai.princeton.edu/research/eiall.html} #' @keywords models Qfun <- function(theta, suff.stat, n) { mu<-rep(0,2) Sigma<-matrix(0, 2,2) Suff1<-rep(0,2) Suff2<-matrix(0,2,2) mu <- theta[1:2] Sigma[1,1]<-theta[3] Sigma[2,2]<-theta[4] Sigma[1,2]<-Sigma[2,1]<-theta[5]*sqrt(Sigma[1,1]*Sigma[2,2]) Suff1 <- n*suff.stat[1:2] Suff2[1,1]<-n*suff.stat[3] Suff2[2,2]<-n*suff.stat[4] Suff2[1,2]<-n*suff.stat[5] invSigma<-solve(Sigma) return(-0.5*n*log(det(Sigma))-0.5*sum(diag(invSigma%*%(Suff2-mu%*%t(Suff1)-Suff1%*%t(mu)+n*mu%*%t(mu))))) } eco/R/summary.ecoML.R0000644000175100001440000001640113104457061014060 0ustar hornikusers## for simlicity, this summary function only reports parameters related to W_1 and W_2 #' Summarizing the Results for the Maximum Likelihood Parametric Model for #' Ecological Inference in 2x2 Tables #' #' \code{summary} method for class \code{eco}. #' #' #' @aliases summary.ecoML #' @param object An output object from \code{eco}. #' @param CI A vector of lower and upper bounds for the Bayesian credible #' intervals used to summarize the results. The default is the equal tail 95 #' percent credible interval. #' @param param Ignored. #' @param subset A numeric vector indicating the subset of the units whose #' in-sample predications to be provided when \code{units} is \code{TRUE}. The #' default value is \code{NULL} where the in-sample predictions for each unit #' will be provided. #' @param units Logical. If \code{TRUE}, the in-sample predictions for each #' unit or for a subset of units will be provided. The default value is #' \code{FALSE}. #' @param ... further arguments passed to or from other methods. #' @return \code{summary.eco} yields an object of class \code{summary.eco} #' containing the following elements: #' \item{call}{The call from \code{eco}.} #' \item{sem}{Whether the SEM algorithm was executed, as specified by the user #' upon calling \code{ecoML}.} #' \item{fix.rho}{Whether the correlation parameter was fixed or allowed to #' vary, as specified by the user upon calling \code{ecoML}.} #' \item{epsilon}{The convergence threshold specified by the user upon #' calling \code{ecoML}.} #' \item{n.obs}{The number of units.} #' \item{iters.em}{The number iterations the EM algorithm cycled through before #' convergence or reaching the maximum number of iterations allowed.} #' \item{iters.sem}{The number iterations the SEM algorithm cycled through #' before convergence or reaching the maximum number of iterations allowed.} #' \item{loglik}{The final observed log-likelihood.} #' \item{rho}{A matrix of \code{iters.em} rows specifying the correlation parameters at each iteration #' of the EM algorithm. The number of columns depends on how many correlation #' parameters exist in the model. Column order is the same as the order of the #' parameters in \code{param.table}.} #' \item{param.table}{Final estimates of the parameter values for the model. #' Excludes parameters fixed by the user upon calling \code{ecoML}. #' See \code{ecoML} documentation for order of parameters.} #' \item{agg.table}{Aggregate estimates of the marginal means of #' \eqn{W_1} and \eqn{W_2}} #' \item{agg.wtable}{Aggregate estimates of the marginal means #' of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} #' If \code{units = TRUE}, the following elements are also included: #' \item{W.table}{Unit-level estimates for \eqn{W_1} and \eqn{W_2}.} #' #' This object can be printed by \code{print.summary.eco} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu}; Aaron Strauss, #' Department of Politics, Princeton University, #' \email{abstraus@@Princeton.Edu} #' @seealso \code{ecoML} #' @keywords methods summary.ecoML <- function(object, CI = c(2.5, 97.5), param = TRUE, units = FALSE, subset = NULL, ...) { n.col<-5 if(object$context) n.col<-7 if (object$fix.rho) n.col<-n.col-1 n.row<-1 if (object$sem) n.row<-3 param.table<-matrix(NA, n.row, n.col) if (!object$context) { param.table[1,]<-object$theta.em cname<-c("mu1", "mu2", "sigma1", "sigma2", "rho") } else if (object$context && !object$fix.rho) { cname<-c("mu1", "mu2", "sigma1", "sigma2", "rho1X","rho2X","rho12") param.table[1,]<-object$theta.em[c(2,3,5,6,7,8,9)] } else if (object$context && object$fix.rho) { cname<-c("mu1", "mu2", "sigma1", "sigma2", "rho1X","rho2X") param.table[1,]<-object$theta.em[c(2,3,5,6,7,8)] } if (n.row>1) { if (!object$context) { param.table[2,]<-sqrt(diag(object$Vobs)) param.table[3,]<-Fmis<-1-diag(object$Iobs)/diag(object$Icom) } else if (object$context && !object$fix.rho) { param.table[2,]<-sqrt(diag(object$Vobs)[c(2,3,5,6,7,8,9)]) param.table[3,]<-Fmis<-(1-diag(object$Iobs)/diag(object$Icom))[c(2,3,5,6,7,8,9)] } else if (object$context && object$fix.rho) { param.table[2,]<-sqrt(diag(object$Vobs)[c(2,3,5,6)]) param.table[3,]<-Fmis<-(1-diag(object$Iobs)/diag(object$Icom))[c(2,3,5,6)] } } rname<-c("ML est.", "std. err.", "frac. missing") rownames(param.table)<-rname[1:n.row] colnames(param.table)<-cname[1:n.col] n.obs <- nrow(object$W) if (is.null(subset)) subset <- 1:n.obs else if (!is.numeric(subset)) stop("Subset should be a numeric vector.") else if (!all(subset %in% c(1:n.obs))) stop("Subset should be any numbers in 1:obs.") table.names<-c("mean", "std.dev", paste(min(CI), "%", sep=" "), paste(max(CI), "%", sep=" ")) W1.mean <- mean(object$W[,1]) W2.mean <- mean(object$W[,2]) W1.sd <- sd(object$W[,1]) W2.sd <- sd(object$W[,2]) # W1.q1 <- W1.mean-1.96*W1.sd # W1.q2 <- W1.mean+1.96*W1.sd # W2.q1 <- W2.mean-1.96*W2.sd # W2.q2 <- W2.mean+1.96*W2.sd W1.q1 <- quantile(object$W[,1],min(CI)/100) W1.q2 <- quantile(object$W[,1],max(CI)/100) W2.q1 <- quantile(object$W[,2],min(CI)/100) W2.q2 <- quantile(object$W[,2],max(CI)/100) agg.table <- rbind(cbind(W1.mean, W1.sd, W1.q1, W1.q2), cbind(W2.mean, W2.sd, W2.q1, W2.q2)) colnames(agg.table) <- table.names rownames(agg.table) <- c("W1", "W2") # if (is.null(object$N)) # N <- rep(1, nrow(object$X)) # else agg.wtable<-NULL if (!is.null(object$N)) { N <- object$N } else { N <- rep(1:n.obs) } weighted.var <- function(x, w) { return(sum(w * (x - weighted.mean(x,w))^2)/((length(x)-1)*mean(w))) } W1.mean <- weighted.mean(object$W[,1], object$X*N) W2.mean <- weighted.mean(object$W[,2], (1-object$X)*N) W1.sd <- weighted.var(object$W[,1], object$X*N)^0.5 W2.sd <- weighted.var(object$W[,1], (1-object$X)*N)^0.5 W1.q1 <- W1.mean-1.96*W1.sd W1.q2 <- W1.mean+1.96*W1.sd W2.q1 <- W2.mean-1.96*W2.sd W2.q2 <- W2.mean+1.96*W2.sd # W1.q1 <- quantile(object$W[,1] * object$X*N/mean(object$X*N),min(CI)/100) # W1.q2 <- quantile(object$W[,1] * object$X*N/mean(object$X*N),max(CI)/100) # W2.q1 <- quantile(object$W[,2]*(1-object$X)*N/(mean((1-object$X)*N)),min(CI)/100) # W2.q2 <- quantile(object$W[,2]*(1-object$X)*N/(mean((1-object$X)*N)),max(CI)/100) agg.wtable <- rbind(cbind(W1.mean, W1.sd, W1.q1, W1.q2), cbind(W2.mean, W2.sd, W2.q1, W2.q2)) colnames(agg.wtable) <- table.names rownames(agg.wtable) <- c("W1", "W2") if (units) W.table <- object$W[subset,] else W.table <- NULL ans <- list(call = object$call, iters.sem = object$iters.sem, iters.em = object$iters.em, epsilon = object$epsilon, sem = object$sem, fix.rho = object$fix.rho, loglik = object$loglik, rho=object$rho, param.table = param.table, W.table = W.table, agg.wtable = agg.wtable, agg.table=agg.table, n.obs = n.obs) # if (object$fix.rho) # ans$rho<-object$rho class(ans) <-"summary.ecoML" return(ans) } eco/R/varcov.R0000644000175100001440000000343013061770754012674 0ustar hornikusersvarcov <- function(object, ...) UseMethod("varcov") varcov.eco <- function(object, subset = NULL, ...) { if (is.null(subset)) subset <- 1:nrow(object$Sigma) else if (max(subset) > nrow(object$Sigma)) stop(paste("invalid input for `subset.' only", nrow(object$Sigma), "draws are stored.")) p <- ncol(object$mu) n <- length(subset) Sigma <- array(0, c(p, p, n)) cov <- object$Sigma[subset,] for (i in 1:n) { count <- 1 for (j in 1:p) { Sigma[j,j:p,i] <- cov[i,count:(count+p-j)] count <- count + p - j + 1 } diag(Sigma[,,i]) <- diag(Sigma[,,i]/2) Sigma[,,i] <- Sigma[,,i] + t(Sigma[,,i]) } if (n > 1) return(Sigma) else return(Sigma[,,1]) } varcov.ecoNP <- function(object, subset = NULL, obs = NULL, ...) { if (is.null(subset)) subset <- 1:nrow(object$Sigma) else if (max(subset) > nrow(object$Sigma)) stop(paste("invalid input for `subset.' only", nrow(object$Sigma), "draws are stored.")) if (is.null(obs)) obs <- 1:dim(object$Sigma)[3] else if (max(subset) > dim(object$Sigma)[3]) stop(paste("invalid input for `obs.' only", dim(object$Sigma)[3], "draws are stored.")) p <- ncol(object$mu) n <- length(subset) m <- length(obs) Sigma <- array(0, c(p, p, n, m)) cov <- object$Sigma[subset,,obs] for (k in 1:m) { for (i in 1:n) { count <- 1 for (j in 1:p) { Sigma[j,j:p,i,k] <- cov[i,count:(count+p-j),k] count <- count + p - j + 1 } diag(Sigma[,,i,k]) <- diag(Sigma[,,i,k]/2) Sigma[,,i,k] <- Sigma[,,i,k] + t(Sigma[,,i,k]) } } if (n > 1) if (m > 1) return(Sigma) else return(Sigma[,,,1]) else if (m > 1) return(Sigma[,,1,]) else return(Sigma[,,1,1]) } eco/R/print.summary.ecoNP.R0000644000175100001440000000617013104457061015222 0ustar hornikusers#' Print the Summary of the Results for the Bayesian Nonparametric Model for Ecological #' Inference in 2x2 Tables #' #' \code{summary} method for class \code{ecoNP}. #' #' #' @aliases print.summary.ecoNP #' @param x An object of class \code{summary.ecoNP}. #' @param digits the number of significant digits to use when printing. #' @param ... further arguments passed to or from other methods. #' @return \code{summary.ecoNP} yields an object of class \code{summary.ecoNP} #' containing the following elements: #' \item{call}{The call from \code{ecoNP}.} #' \item{n.obs}{The number of units.} #' \item{n.draws}{The number of Monte Carlo samples.} #' \item{agg.table}{Aggregate posterior estimates of the marginal #' means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If #' \code{param = TRUE}, the following elements are also included: #' \item{param.table}{Posterior estimates of model parameters: population mean #' estimates of \eqn{W_1} and \eqn{W_2}. If \code{subset} is specified, only a #' subset of the population parameters are included.} If \code{unit = TRUE}, #' the following elements are also included: #' \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} #' \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} #' #' This object can be printed by \code{print.summary.ecoNP} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{ecoNP}, \code{predict.eco} #' @keywords methods print.summary.ecoNP <- function(x, digits=max(3, getOption("digits")-3), ...) { cat("\nCall: ") cat(paste(deparse(x$call), sep="\n", collapse="\n")) cat("\n\nIn-sample Predictions:\n") cat("\nUnweighted:\n") print(x$agg.table, digits=digits, na.print="NA",...) if (!is.null(x$agg.wtable)) { cat("\nWeighted:\n") print(x$agg.wtable, digits=digits, na.print="NA",...) } cat("\nNumber of Units:", x$n.obs) cat("\nNumber of Monte Carlo Draws:", x$n.draws) if (!is.null(x$param.table)) { tt <- x$param.table cat("\nParameter Estimates of mu1:\n") print(tt$mu1.table, digits=digits, na.print="NA",...) cat("\nParameter Estimates of mu2:\n") print(tt$mu2.table, digits=digits, na.print="NA",...) cat("\nParameter Estimates of Sigma11:\n") print(tt$Sigma11.table, digits=digits, na.print="NA",...) cat("\nParameter Estimates of Sigma12:\n") print(tt$Sigma12.table, digits=digits, na.print="NA",...) cat("\nParameter Estimates of Sigma22:\n") print(tt$Sigma22.table, digits=digits, na.print="NA",...) } if (!is.null(x$W1.table)) { cat("\n\nUnit-level Estimates of W1:\n") print(x$W1.table, digits=digits, na.print="NA",...) cat("\n\nUnit-level Estimates of W2:\n") print(x$W2.table, digits=digits, na.print="NA",...) } cat("\n") invisible(x) } eco/R/print.ecoBD.R0000644000175100001440000000146213061770754013506 0ustar hornikusersprint.ecoBD <- function(x, digits = max(3, getOption("digits") -3), ...) { cat("\nCall:\n", deparse(x$call), "\n\n", sep="") cat("Aggregate Lower Bounds (Proportions):\n") print.default(format(x$aggWmin, digits = digits), print.gap = 2, quote = FALSE) cat("\nAggregate Upper Bounds (Proportions):\n") print.default(format(x$aggWmax, digits = digits), print.gap = 2, quote = FALSE) if (!is.null(x$aggNmin)) { cat("\nAggregate Lower Bounds (Counts):\n") print.default(format(x$aggNmin, digits = digits), print.gap = 2, quote = FALSE) cat("\nAggregate Upper Bounds (Counts):\n") print.default(format(x$aggNmax, digits = digits), print.gap = 2, quote = FALSE) } cat("\n") invisible(x) } eco/R/census.R0000644000175100001440000000245313104457061012667 0ustar hornikusers #' Black Illiteracy Rates in 1910 US Census #' #' This data set contains the proportion of the residents who are black, the #' proportion of those who can read, the total population as well as the actual #' black literacy rate and white literacy rate for 1040 counties in the US. The #' dataset was originally analyzed by Robinson (1950) at the state level. King #' (1997) recoded the 1910 census at county level. The data set only includes #' those who are older than 10 years of age. #' #' #' @name census #' @docType data #' @format A data frame containing 5 variables and 1040 observations #' \tabular{lll}{ X \tab numeric \tab the proportion of Black residents in each #' county\cr Y \tab numeric \tab the overall literacy rates in each county\cr N #' \tab numeric \tab the total number of residents in each county \cr W1 \tab #' numeric \tab the actual Black literacy rate \cr W2 \tab numeric \tab the #' actual White literacy rate } #' @references Robinson, W.S. (1950). ``Ecological Correlations and the #' Behavior of Individuals.'' \emph{American Sociological Review}, vol. 15, #' pp.351-357. \cr \cr King, G. (1997). \dQuote{A Solution to the Ecological #' Inference Problem: Reconstructing Individual Behavior from Aggregate Data}. #' Princeton University Press, Princeton, NJ. #' @keywords datasets NULL eco/R/forgnlit30c.R0000644000175100001440000000240613104457061013517 0ustar hornikusers #' Foreign-born literacy in 1930, County Level #' #' This data set contains, on a county level, the proportion of white residents #' ten years and older who are foreign born, and the proportion of those #' residents who are literate. Data come from the 1930 census and were first #' analyzed by Robinson (1950). Counties with fewer than 100 foreign born #' residents are dropped. #' #' #' @name forgnlit30c #' @docType data #' @format A data frame containing 6 variables and 1976 observations #' \tabular{lll}{ X \tab numeric \tab proportion of the white population at #' least 10 years of age that is foreign born \cr Y \tab numeric \tab #' proportion of the white population at least 10 years of age that is #' illiterate \cr W1 \tab numeric \tab proportion of the foreign-born white #' population at least 10 years of age that is illiterate \cr W2 \tab numeric #' \tab proportion of the native-born white population at least 10 years of age #' that is illiterate \cr state \tab numeric \tab the ICPSR state code \cr #' county \tab numeric \tab the ICPSR (within state) county code } #' @references Robinson, W.S. (1950). ``Ecological Correlations and the #' Behavior of Individuals.'' \emph{American Sociological Review}, vol. 15, #' pp.351-357. #' @keywords datasets NULL eco/R/print.summary.predict.eco.R0000644000175100001440000000046213061770754016424 0ustar hornikusersprint.summary.predict.eco <- function(x, digits=max(3, getOption("digits") -3), ...) { cat("\nOut-of-sample Prediction:\n") print(x$W.table, digits=digits, na.print="NA",...) cat("\nNumber of Monte Carlo Draws:", x$n.draws) cat("\n") invisible(x) } eco/R/summary.eco.R0000644000175100001440000001304313104457061013626 0ustar hornikusers#' Summarizing the Results for the Bayesian Parametric Model for Ecological #' Inference in 2x2 Tables #' #' \code{summary} method for class \code{eco}. #' #' #' @aliases summary.eco print.eco #' @param object An output object from \code{eco}. #' @param CI A vector of lower and upper bounds for the Bayesian credible #' intervals used to summarize the results. The default is the equal tail 95 #' percent credible interval. #' @param param Logical. If \code{TRUE}, the posterior estimates of the #' population parameters will be provided. The default value is \code{TRUE}. #' @param units Logical. If \code{TRUE}, the in-sample predictions for each #' unit or for a subset of units will be provided. The default value is #' \code{FALSE}. #' @param subset A numeric vector indicating the subset of the units whose #' in-sample predications to be provided when \code{units} is \code{TRUE}. The #' default value is \code{NULL} where the in-sample predictions for each unit #' will be provided. #' @param ... further arguments passed to or from other methods. #' @return \code{summary.eco} yields an object of class \code{summary.eco} #' containing the following elements: #' \item{call}{The call from \code{eco}.} #' \item{n.obs}{The number of units.} #' \item{n.draws}{The number of Monte Carlo samples.} #' \item{agg.table}{Aggregate posterior estimates of the marginal #' means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If #' \code{param = TRUE}, the following elements are also included: #' \item{param.table}{Posterior estimates of model parameters: population mean #' estimates of \eqn{W_1} and \eqn{W_2} and their logit transformations.} If #' \code{units = TRUE}, the following elements are also included: #' \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} #' \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} #' #' This object can be printed by \code{print.summary.eco} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{eco}, \code{predict.eco} #' @keywords methods summary.eco <- function(object, CI = c(2.5, 97.5), param = TRUE, units = FALSE, subset = NULL,...) { n.obs <- ncol(object$W[,1,]) n.draws <- nrow(object$W[,1,]) if (is.null(subset)) subset <- 1:n.obs else if (!is.numeric(subset)) stop("Subset should be a numeric vector.") else if (!all(subset %in% c(1:n.obs))) stop("Subset should be any numbers in 1:obs.") table.names<-c("mean", "std.dev", paste(min(CI), "%", sep=" "), paste(max(CI), "%", sep=" ")) agg.table <-agg.wtable <-NULL N<-rep(1, length(object$X)) W1.agg.mean <- as.vector(object$W[,1,]%*% (object$X*N/sum(object$X*N))) W2.agg.mean <- as.vector(object$W[,2,]%*% ((1-object$X)*N/sum((1-object$X)*N))) agg.table <- rbind(cbind(mean(W1.agg.mean), sd(W1.agg.mean), quantile(W1.agg.mean, min(CI)/100), quantile(W1.agg.mean, max(CI)/100)), cbind(mean(W2.agg.mean), sd(W2.agg.mean), quantile(W2.agg.mean, min(CI)/100), quantile(W2.agg.mean, max(CI)/100))) colnames(agg.table) <- table.names rownames(agg.table) <- c("W1", "W2") if (!is.null(object$N)) { N <- object$N W1.agg.wmean <- as.vector(object$W[,1,] %*% (object$X*N/sum(object$X*N))) W2.agg.wmean <- as.vector(object$W[,2,] %*% ((1-object$X)*N/sum((1-object$X)*N))) agg.wtable <- rbind(cbind(mean(W1.agg.wmean), sd(W1.agg.wmean), quantile(W1.agg.wmean, min(CI)/100), quantile(W1.agg.wmean, max(CI)/100)), cbind(mean(W2.agg.wmean), sd(W2.agg.wmean), quantile(W2.agg.wmean, min(CI)/100), quantile(W2.agg.wmean, max(CI)/100))) colnames(agg.wtable) <- table.names rownames(agg.wtable) <- c("W1", "W2") } if (units) { W1.table <- cbind(apply(object$W[,1,subset], 2, mean), apply(object$W[,1,subset], 2, sd), apply(object$W[,1,subset], 2, quantile, min(CI)/100), apply(object$W[,1,subset], 2, quantile, max(CI)/100)) W2.table <- cbind(apply(object$W[,2,subset], 2, mean), apply(object$W[,2,subset], 2, sd), apply(object$W[,2,subset], 2, quantile, min(CI)/100), apply(object$W[,2,subset], 2, quantile, max(CI)/100)) colnames(W2.table) <- colnames(W1.table) <- table.names rownames(W1.table) <- rownames(W2.table) <- row.names(object$X[subset]) } else W1.table <- W2.table <- NULL if (param) { if (is.null(object$mu) || is.null(object$Sigma)) stop("Parameters are missing values.") else { param <- cbind(object$mu, object$Sigma) param.table <- cbind(apply(param, 2, mean), apply(param, 2, sd), apply(param, 2, quantile, min(CI)/100), apply(param, 2, quantile, max(CI)/100)) colnames(param.table) <- table.names } } else param.table <- NULL ans <- list(call = object$call, W1.table = W1.table, W2.table = W2.table, agg.table = agg.table, agg.wtable=agg.wtable, param.table = param.table, n.draws = n.draws, n.obs = n.obs) class(ans) <-"summary.eco" return(ans) } eco/R/reg.R0000644000175100001440000000202413104457061012136 0ustar hornikusers #' Voter Registration in US Southern States #' #' This data set contains the racial composition, the registration rate, the #' number of eligible voters as well as the actual observed racial registration #' rates for every county in four US southern states: Florida, Louisiana, North #' Carolina, and South Carolina. #' #' #' @name reg #' @docType data #' @format A data frame containing 5 variables and 275 observations #' \tabular{lll}{ X \tab numeric \tab the fraction of Black voters \cr Y \tab #' numeric \tab the fraction of voters who registered themselves\cr N \tab #' numeric \tab the total number of voters in each county \cr W1 \tab numeric #' \tab the actual fraction of Black voters who registered themselves \cr W2 #' \tab numeric \tab the actual fraction of White voters who registered #' themselves } #' @references King, G. (1997). \dQuote{A Solution to the Ecological Inference #' Problem: Reconstructing Individual Behavior from Aggregate Data}. Princeton #' University Press, Princeton, NJ. #' @keywords datasets NULL eco/R/print.summary.ecoML.R0000644000175100001440000000747613104457061015227 0ustar hornikusers## for simlicity, this summary function only reports parameters related to W_1 and W_2 #' Print the Summary of the Results for the Maximum Likelihood Parametric Model for #' Ecological Inference in 2x2 Tables #' #' \code{summary} method for class \code{eco}. #' #' #' @aliases print.summary.ecoML #' @param x An object of class \code{summary.ecoML}. #' @param digits the number of significant digits to use when printing. #' @param ... further arguments passed to or from other methods. #' @return \code{summary.eco} yields an object of class \code{summary.eco} #' containing the following elements: #' \item{call}{The call from \code{eco}.} #' \item{sem}{Whether the SEM algorithm was executed, as specified by the user #' upon calling \code{ecoML}.} #' \item{fix.rho}{Whether the correlation parameter was fixed or allowed to vary, #' as specified by the user upon calling \code{ecoML}.} #' \item{epsilon}{The convergence threshold specified by the #' user upon calling \code{ecoML}.} #' \item{n.obs}{The number of units.} #' \item{iters.em}{The number iterations the EM algorithm cycled through before #' convergence or reaching the maximum number of iterations allowed.} #' \item{iters.sem}{The number iterations the SEM algorithm cycled through #' before convergence or reaching the maximum number of iterations allowed.} #' \item{loglik}{The final observed log-likelihood.} #' \item{rho}{A matrix of \code{iters.em} rows specifying the correlation parameters #' at each iteration of the EM algorithm. The number of columns depends on how many #' correlation parameters exist in the model. Column order is the same as the order of the #' parameters in \code{param.table}.} #' \item{param.table}{Final estimates of the parameter values for the model. #' Excludes parameters fixed by the user upon calling \code{ecoML}. #' See \code{ecoML} documentation for order of parameters.} #' \item{agg.table}{Aggregate estimates of the marginal means of \eqn{W_1} and \eqn{W_2}} #' \item{agg.wtable}{Aggregate estimates of the marginal means of \eqn{W_1} and \eqn{W_2} #' using \eqn{X} and \eqn{N} as weights.} If \code{units = TRUE}, the following elements #' are also included: #' \item{W.table}{Unit-level estimates for \eqn{W_1} and \eqn{W_2}.} #' #' This object can be printed by \code{print.summary.eco} #' @author Kosuke Imai, Department of Politics, Princeton University, #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu}; Aaron Strauss, #' Department of Politics, Princeton University, #' \email{abstraus@@Princeton.Edu} #' @seealso \code{ecoML} #' @keywords methods print.summary.ecoML <- function(x, digits=max(3, getOption("digits")-3), ...) { cat("\nCall: ", paste(deparse(x$call), sep="\n", collapse="\n")) cat("\n") if (!is.null(x$param.table)) { cat("\n*** Parameter Estimates ***\n") if (x$fix.rho) cat("\nOriginal Model Parameters (rho is fixed at ", x$rho, "):\n", sep="") else cat("\nOriginal Model Parameters:\n") print(x$param.table, digits=digits, na.print="NA",...) } cat("\n*** Insample Predictions ***\n") cat("\nUnweighted:\n") print(x$agg.table, digits=digits, na.print="NA",...) if (!is.null(x$agg.wtable)) { cat("\nWeighted:\n") print(x$agg.wtable, digits=digits, na.print="NA",...) } if (!is.null(x$W.table)) { cat("\n\nUnit-level Estimates of W:\n") print(x$W.table, digits=digits, na.print="NA",...) } cat("\n\nLog-likelihood:", x$loglik) cat("\nNumber of Observations:", x$n.obs) cat("\nNumber of EM iterations:", x$iters.em) if (x$sem) cat("\nNumber of SEM iterations:", x$iters.sem) cat("\nConvergence threshold for EM:", x$epsilon) cat("\n\n") invisible(x) } eco/R/print.eco.R0000644000175100001440000000110613061770754013273 0ustar hornikusersprint.eco <- function(x, digits = max(3, getOption("digits") -3), ...){ cat("\nCall:\n", deparse(x$call), "\n\n", sep="") if (is.null(x$N)) N <- rep(1, nrow(x$X)) else N <- x$N W.mean <- cbind(mean(x$W[,1,] %*% (x$X*N/sum(x$X*N))), mean(x$W[,2,] %*% ((1-x$X)*N/sum((1-x$X)*N)))) colnames(W.mean) <- c("W1", "W2") rownames(W.mean) <- "posterior mean" cat("Aggregate In-sample Estimates:\n\n") print.default(format(W.mean, digits = digits), print.gap = 2, quote = FALSE) cat("\n") invisible(x) } eco/R/eminfo.R0000644000175100001440000004016413061770754012656 0ustar hornikusers##logit and invlogit transformation logit <- function(X) { Y<-log(X/(1-X)) Y } invlogit <-function(Y) { X<-exp(Y)/(1+exp(Y)) X } ####assuming theta.em ##2 d: mu1, mu2, sig1, sig2, r12 ##3 d: mu3, mu1, mu2, sig3, sig1, sig2, r13, r23, r12 param.pack<-function(theta.em, fix.rho=FALSE,r12=0, dim) { mu<-rep(0, dim) Sig<-matrix(0,dim, dim) mu<-theta.em[1:dim] for (i in 1:dim) Sig[i,i]<-theta.em[dim+i] if (!fix.rho) { Sig[1,2]<-Sig[2,1]<-theta.em[2*dim+1]*sqrt(Sig[1,1]*Sig[2,2]) if (dim==3) { Sig[1,3]<-Sig[3,1]<-theta.em[2*dim+2]*sqrt(Sig[1,1]*Sig[3,3]) Sig[2,3]<-Sig[3,2]<-theta.em[2*dim+3]*sqrt(Sig[2,2]*Sig[3,3]) } } if (fix.rho) { if (dim==2) Sig[1,2]<-Sig[2,1]<-r12*sqrt(Sig[1,1]*Sig[2,2]) if (dim==3) { Sig[1,2]<-Sig[2,1]<-theta.em[2*dim+1]*sqrt(Sig[1,1]*Sig[2,2]) Sig[1,3]<-Sig[3,1]<-theta.em[2*dim+2]*sqrt(Sig[1,1]*Sig[3,3]) Sig[2,3]<-Sig[3,2]<-r12*sqrt(Sig[2,2]*Sig[3,3]) } } return(list(mu=mu, Sigma=Sig)) } ## transformation of BVN parameter into ## Fisher scale or unit scale ## in 2 D, mu1, mu2, sigma1, sigma2, r12 ## in 3 D, mu3, mu1, mu2, sigma3, sigma1, sigma2, sigma31, sigma32, sigma12 param.trans <-function(X, transformation="Fisher") { p<-length(X) Y<-rep(0,p) if (transformation=="Fisher") { if (p<=5) { Y[1:2]<-X[1:2] Y[3:4]<-log(X[3:4]) if (p==5) Y[5]<-0.5*log((1+X[5])/(1-X[5])) } if (p>5) { Y[1:3]<-X[1:3] Y[4:6]<-log(X[4:6]) Y[7:8]<-0.5*log((1+X[7:8])/(1-X[7:8])) if (p==9) Y[9]<-0.5*log((1+X[9])/(1-X[9])) } } if (transformation=="unitscale") { if (p<=5) { Y[1:2] <- invlogit(X[1:2]) Y[3:4] <- X[3:4]*exp(2*X[1:2])/(1+exp(X[1:2]))^4 if (p==5) Y[5] <- X[5] } if (p>5) { Y[1:3]<-invlogit(X[1:3]) Y[4:6]<-X[4:6]*exp(2*X[4:6])/(1+exp(X[4:6]))^4 Y[7:8]<-X[7:8] if (p==9) Y[9]<-X[9] } } return(Y) } vec<-function(mat) { v<-as.vector(mat, mode="any") v } tr<-function(mat) { trace<-sum(diag(mat)) trace } ## I_{com} ## the gradient function for multivariate normal function #du.theta and dSig.theta are the first derivative of mu and Sigma #with respect to theta #du.theta[n.u, n.theta] #dSig.theta[n.u, n.u, n.theta] d1st.mvn<-function(mu,Sigma, fix.rho=FALSE) { #r12, r13,r23 are internal here, # r12 doesn't correspond to cor(w1, w2) in 3d case (intead, r12=>cor(W1,x) d<-length(mu) p<-d+d+d*(d-1)/2 u1<-mu[1] u2<-mu[2] s1<-Sigma[1,1] s2<-Sigma[2,2] r12<-Sigma[1,2]/sqrt(s1*s2) if (d==3) { u3<-mu[3] s3<-Sigma[3,3] r13<-Sigma[1,3]/sqrt(s1*s3) r23<-Sigma[2,3]/sqrt(s2*s3) } if (fix.rho) p<-p-1 du.theta<-matrix(0,d,p) for (j in 1:d) du.theta[j,j]<-1 dSig.theta<-array(0,c(d,d,p)) for (i in 1:d) dSig.theta[i,i,d+i]<-1 dSig.theta[1,2,d+1]<-dSig.theta[2,1,d+1]<-1/2*s1^(-1/2)*s2^(1/2)*r12 dSig.theta[1,2,d+2]<-dSig.theta[2,1,d+2]<-1/2*s2^(-1/2)*s1^(1/2)*r12 if (d==3) { dSig.theta[1,3,d+1]<-dSig.theta[3,1,d+1]<-1/2*s1^(-1/2)*s3^(1/2)*r13 dSig.theta[1,3,d+3]<-dSig.theta[3,1,d+3]<-1/2*s3^(-1/2)*s1^(1/2)*r13 dSig.theta[2,3,d+2]<-dSig.theta[3,2,d+2]<-1/2*s2^(-1/2)*s3^(1/2)*r23 dSig.theta[2,3,d+3]<-dSig.theta[3,2,d+3]<-1/2*s3^(-1/2)*s2^(1/2)*r23 } if (!fix.rho) { dSig.theta[1,2,2*d+1]<-dSig.theta[2,1,2*d+1]<-sqrt(s1*s2) if (d==3) { dSig.theta[1,3,2*d+2]<-dSig.theta[3,1,2*d+2]<-sqrt(s1*s3) dSig.theta[2,3,2*d+3]<-dSig.theta[3,2,2*d+3]<-sqrt(s2*s3) } } if (fix.rho) { if (d==3) { dSig.theta[1,3,2*d+1]<-dSig.theta[3,1,2*d+1]<-sqrt(s1*s3) dSig.theta[2,3,2*d+2]<-dSig.theta[3,2,2*d+2]<-sqrt(s2*s3) } } return(list(du.theta=du.theta, dSig.theta=dSig.theta)) } d2nd.mvn<-function(mu,Sigma, fix.rho=FALSE) { #r12, r13,r23 are internal here, # r12 doesn't correspond to cor(w1, w2) in 3d case (intead, r12=>cor(W1,x) d<-length(mu) p<-d+d+d*(d-1)/2 u1<-mu[1] u2<-mu[2] s1<-Sigma[1,1] s2<-Sigma[2,2] r12<-Sigma[1,2]/sqrt(s1*s2) if (d==3) { u3<-mu[3] s3<-Sigma[3,3] r13<-Sigma[1,3]/sqrt(s1*s3) r23<-Sigma[2,3]/sqrt(s2*s3) } if (fix.rho) p<-p-1 ddu.theta<-array(0,c(d,p,p)) ddSig.theta<-array(0,c(d,d,p,p)) ddSig.theta[1,2,d+1,d+1]<-ddSig.theta[2,1,d+1,d+1]<- -1/4*s1^(-3/2)*s2^(1/2)*r12 ddSig.theta[1,2,d+1,d+2]<-ddSig.theta[2,1,d+1,d+2]<- 1/4*s1^(-1/2)*s2^(-1/2)*r12 ddSig.theta[1,2,d+2,d+2]<-ddSig.theta[2,1,d+2,d+2]<- -1/4*s1^(1/2)*s2^(-3/2)*r12 if (d==3) { ddSig.theta[1,3,d+1,d+1]<-ddSig.theta[3,1,d+1,d+1]<- -1/4*s1^(-3/2)*s3^(1/2)*r13 ddSig.theta[1,3,d+1,d+3]<-ddSig.theta[3,1,d+1,d+3]<- 1/4*s1^(-1/2)*s3^(-1/2)*r13 ddSig.theta[2,3,d+2,d+2]<-ddSig.theta[3,2,d+2,d+2]<- -1/4*s2^(-3/2)*s3^(1/2)*r23 ddSig.theta[2,3,d+2,d+3]<-ddSig.theta[3,2,d+2,d+3]<- 1/4*s2^(-1/2)*s3^(-1/2)*r23 ddSig.theta[1,3,d+3,d+3]<-ddSig.theta[3,1,d+3,d+3]<- -1/4*s1^(1/2)*s3^(-3/2)*r13 ddSig.theta[2,3,d+3,d+3]<-ddSig.theta[3,2,d+3,d+3]<- -1/4*s2^(1/2)*s3^(-3/2)*r23 } if (!fix.rho) { ddSig.theta[1,2,d+1,2*d+1]<-ddSig.theta[2,1,d+1,2*d+1]<- 1/2*s1^(-1/2)*s2^(1/2) ddSig.theta[1,2,d+2,2*d+1]<-ddSig.theta[2,1,d+2,2*d+1]<- 1/2*s1^(1/2)*s2^(-1/2) if (d==3) { ddSig.theta[1,3,d+1,2*d+2]<-ddSig.theta[3,1,d+1,2*d+2]<- 1/2*s1^(-1/2)*s3^(1/2) ddSig.theta[2,3,d+2,2*d+3]<-ddSig.theta[3,2,d+2,2*d+3]<- 1/2*s2^(-1/2)*s3^(1/2) ddSig.theta[1,3,d+3,2*d+2]<-ddSig.theta[3,1,d+3,2*d+2]<- 1/2*s1^(1/2)*s3^(-1/2) ddSig.theta[2,3,d+3,2*d+3]<-ddSig.theta[3,2,d+3,2*d+3]<- 1/2*s2^(1/2)*s3^(-1/2) } } if (fix.rho) { if (d==3) { ddSig.theta[1,2,d+1,2*d+1]<-ddSig.theta[2,1,d+1,2*d+1]<- 1/2*s1^(-1/2)*s3^(1/2) ddSig.theta[2,3,d+2,2*d+2]<-ddSig.theta[3,2,d+2,2*d+2]<- 1/2*s2^(-1/2)*s3^(1/2) ddSig.theta[1,3,d+3,2*d+1]<-ddSig.theta[3,1,d+3,2*d+1]<- 1/2*s1^(1/2)*s3^(-1/2) ddSig.theta[2,3,d+3,2*d+2]<-ddSig.theta[3,2,d+3,2*d+2]<- 1/2*s2^(1/2)*s3^(-1/2) } } for (i in 1:(p-1)) for (j in (i+1):p) { ddSig.theta[,,j,i]<-ddSig.theta[,,i,j] ddu.theta[,j,i]<-ddu.theta[,i,j] } return(list(ddu.theta=ddu.theta, ddSig.theta=ddSig.theta)) } ##assuming the order of sufficient statistics ## 2d, mean(W1), mean(W2), mean(W1^2) mean(W2^2), mean(W1W2) ## 3d, mean(X), mean(W1), mean(W2), mean(X^2),mean(W1^2) mean(W2^2), ## mean(XW1), mean(XW2), mean(W1W2) suff<-function(mu, suff.stat,n) { d<-length(mu) p<-d+d+d*(d-1)/2 u1<-mu[1] u2<-mu[2] if (d==3) u3<-mu[3] S1<-n*suff.stat[1] S2<-n*suff.stat[2] S11<-n*suff.stat[d+1] S22<-n*suff.stat[d+2] S12<-n*suff.stat[2*d+1] if (d==3) { S3<-n*suff.stat[d] S33<-n*suff.stat[2*d] S13<-n*suff.stat[2*d+2] S23<-n*suff.stat[2*d+3] } Vv<-rep(0,d) Vv[1]<-S1-n*u1 Vv[2]<-S2-n*u2 if (d==3) Vv[3]<-S3-n*u3 Ss<-matrix(0,d,d) Ss[1,1]<-S11-2*S1*u1+n*u1^2 Ss[2,2]<-S22-2*S2*u2+n*u2^2 Ss[1,2]<-Ss[2,1]<-S12-S1*u2-S2*u1+n*u1*u2 if (d==3) { Ss[3,3]<-S33-2*S3*u3+n*u3^2 Ss[1,3]<-Ss[3,1]<-S13-S1*u3-S3*u1+n*u1*u3 Ss[2,3]<-Ss[3,2]<-S23-S3*u2-S2*u3+n*u2*u3 } return(list(Ss=Ss, Vv=Vv)) } #du.theta and dSig.theta are the second derivative of mu and Sigma #with respect to theta #ddu.theta[n.u, n.theta, n.theta] #ddSig.theta[n.u, n.u, n.theta, n.theta] ##comput the gradient vector (expected first derivatives) for MVN ##not actually used here. Dcom.mvn<-function(mu, Sigma, suff.stat,n, fix.rho=FALSE) { d<-dim(Sigma)[1] p<-d*2+0.5*d*(d-1) if (fix.rho) { p<-p-1 } Dcom<-rep(0,p) invSigma<-solve(Sigma) temp<-suff(mu, suff.stat, n) Ss<-temp$Ss Vv<-temp$Vv temp<-d1st.mvn(mu=mu, Sigma=Sigma, fix.rho=fix.rho) du.theta<-temp$du.theta dSig.theta<-temp$dSig.theta for (i in 1:p) Dcom[i]<- -n/2*t(vec(invSigma))%*%vec(dSig.theta[,,i])+ 0.5*tr(invSigma%*%dSig.theta[,,i]%*%invSigma%*%Ss)+ t(du.theta[,i])%*%invSigma%*%Vv Dcom } #compute the information matrix of MVN # -1*second derivatives Icom.mvn<-function(mu, Sigma, suff.stat,n, fix.rho=FALSE) { d<-dim(Sigma)[1] p<-d*2+1/2*d*(d-1) if (fix.rho) { p<-p-1 } Icom<-matrix(0,p,p) invSigma<-solve(Sigma) temp<-suff(mu, suff.stat, n) Ss<-temp$Ss Vv<-temp$Vv temp<-d1st.mvn(mu, Sigma, fix.rho) du.theta<-temp$du.theta dSig.theta<-temp$dSig.theta temp<-d2nd.mvn(mu, Sigma, fix.rho) ddu.theta<-temp$ddu.theta ddSig.theta<-temp$ddSig.theta for (i in 1:p) { dinvSig.theta.i<- -invSigma%*%dSig.theta[,,i]%*%invSigma for (j in 1:i) { dinvSig.theta.j<- -invSigma%*%dSig.theta[,,j]%*%invSigma ddinvSig.theta.ij<- -dinvSig.theta.j%*%dSig.theta[,,i]%*%invSigma -invSigma%*%ddSig.theta[,,i,j]%*%invSigma-invSigma%*%dSig.theta[,,i]%*%dinvSig.theta.j a1<- -n/2*(t(vec(dinvSig.theta.j))%*%vec(dSig.theta[,,i]) + t(vec(invSigma))%*%vec(ddSig.theta[,,i,j])) a2<- t(du.theta[,j])%*%dinvSig.theta.i%*%Vv - 0.5*tr(ddinvSig.theta.ij%*%Ss) a3<- t(ddu.theta[,i,j])%*%invSigma%*%Vv + t(du.theta[,i])%*%dinvSig.theta.j%*%Vv - n*t(du.theta[,i])%*%invSigma%*%du.theta[,j] Icom[i,j]<-a1+a2+a3 if (i!=j) Icom[j,i]<-Icom[i,j] } } -Icom } ###compute the information matrix for various parameter transformation ### "Fisher" transformation (variance stablization?) ### unit scale transformation: first order approximation of mean and var, rho ##express T1 and T2 in more general form Icom.transform<-function(Icom, Dvec, theta, transformation="Fisher", context, fix.rho) { if (!context) { mu<-theta[1:2] sigma<-theta[3:4] rho<-theta[5] } if (context) { mu<-theta[1:3] # x,w1,w2 sigma<-theta[4:6] #x, w1, w2 rho<-theta[7:9] #r_xw1, r_xw2, r_w1w2 } ##T1: d(theta)/d(f(theta)), theta is the MVN parameterization ##T2, d2(theta)/d(f(theta))(d(f(theta))') ### transformation=Fisher, Icom_normal==>Icom_fisher Imat<- -Icom n.par<-dim(Imat)[1] if (transformation=="Fisher") { if (!context) { T1<-c(1,1,sigma[1], sigma[2]) T2<-matrix(0, n.par^2, n.par) T2[(2*n.par+3), 3]<-sigma[1] T2[(3*n.par+4), 4]<-sigma[2] if (!fix.rho) { T1<-c(T1, (1-(rho[1]^2))) T2[(4*n.par+5),5]<- -2*rho[1]*(1-rho[1]^2) } T1<-diag(T1) } if (context) { T1<-c(1,1,1,sigma[1:3],(1-(rho[1:2]^2))) T2<-matrix(0, n.par^2, n.par) T2[(3*n.par+4), 4]<-sigma[1] T2[(4*n.par+5), 5]<-sigma[2] T2[(5*n.par+6), 6]<-sigma[3] T2[(6*n.par+7),7]<- -2*rho[1]*(1-rho[1]^2) T2[(7*n.par+8),8]<- -2*rho[2]*(1-rho[2]^2) if (!fix.rho) { T1<-c(T1, (1-(rho[3]^2))) T2[(8*n.par+9),9]<- -2*rho[3]*(1-rho[3]^2) } T1<-diag(T1) } } ### transformation=unitscale, Icom_normal==>Icom_unitscale if (transformation=="unitscale") { T1<-matrix(0,n.par,n.par) T1[1,1]<-exp(-mu[1])*(1+exp(mu[1]))^2 T1[1,3]<-1/(sigma[1]*2*exp(2*mu[1])*(1+exp(mu[1]))^(-4)*(1-2*(1+exp(mu[1]))^(-1))) T1[2,2]<-exp(-mu[2])*(1+exp(mu[2]))^2 T1[2,4]<-1/(sigma[2]*2*exp(2*mu[2])*(1+exp(mu[2]))^(-4)*(1-2*(1+exp(mu[2]))^(-1))) T1[3,3]<-2*sigma[1]^0.5*(1+exp(mu[1]))^4*exp(-2*mu[1]) T1[4,4]<-2*sigma[2]^0.5*(1+exp(mu[2]))^4*exp(-2*mu[2]) # T2<-matrix(0, n.par^2, n.par) # T2[1,1]<- # T2[(1*n.par+2), (1*n.par+2)]<- ##compute T1 and T2 } Icom.tran<-matrix(NA, n.par, n.par) Icom.tran<-T1%*%Imat%*%t(T1) temp1<-matrix(0,n.par,n.par) for (i in 1:n.par) for (j in 1:n.par) temp1[i,j]<- Dvec%*%T2[((i-1)*n.par+(1:n.par)),j] Icom.tran<-Icom.tran+temp1 return(-Icom.tran) } ecoINFO<-function(theta.em, suff.stat, DM, context=TRUE, fix.rho=FALSE, sem=TRUE, r12=0, n) { if (context) fix.rho<-FALSE ndim<-2 if (context) ndim<-3 n.var<-2*ndim+ ndim*(ndim-1)/2 n.par<-n.var if (context) { n.par<-n.var-2 } if (!context & fix.rho) n.par<-n.par-1 mu<-param.pack(theta.em, fix.rho=fix.rho, r12=r12, dim=ndim)$mu Sigma<-param.pack(theta.em, fix.rho=fix.rho, r12=r12, dim=ndim)$Sigma theta.fisher<-param.trans(theta.em) Icom<-Icom.mvn(mu=mu, Sigma=Sigma, fix.rho=fix.rho, suff.stat=suff.stat, n=n) Dvec<-Dcom.mvn(mu=mu, Sigma=Sigma, fix.rho=fix.rho, suff.stat=suff.stat, n=n) theta.icom<-theta.em if (fix.rho) theta.icom<-c(theta.em[-n.var], r12) Icom.fisher<-Icom.transform(Icom=Icom, Dvec=Dvec, theta=theta.icom, transformation="Fisher", context=context, fix.rho=fix.rho) Vcom.fisher <- solve(Icom.fisher) if (!context) { dV <- Vcom.fisher%*%DM%*%solve(diag(1,n.par)-DM) Vobs.fisher <- Vcom.fisher+dV } ###verify with the parameters. ###repartition Icom if (context & !fix.rho) { index<-c(1,4,2,3,5,6,7,8,9) Itemp<-Icom.fisher[index,index] invItemp<-solve(Itemp) A1<-invItemp[1:2,1:2] A2<-invItemp[1:2,3:9] A3<-invItemp[3:9, 1:2] A4<-invItemp[3:9, 3:9] dV1<-(A4-t(A2)%*%solve(A1)%*%A2)%*%DM%*%solve(diag(rep(1,7))-DM) dV<-matrix(0,9,9) dV[3:9,3:9]<-dV1 Vobs.fisher<-invItemp+dV index2<-c(1,3,4,2,5,6,7,8,9) Vobs.fisher<-Vobs.fisher[index2,index2] } Iobs.fisher <- solve(Vobs.fisher) ##transform Iobs.fisher to Iobs via delta method ##V(theta)=d(fisher^(-1))V(bvn.trans(theta))d(fisher^(-1))' if (!context) { grad.invfisher <- c(1,1, exp(theta.fisher[3:4])) if (! fix.rho) grad.invfisher <- c(grad.invfisher,4*exp(2*theta.fisher[5])/(exp(2*theta.fisher[5])+1)^2) } if (context) { grad.invfisher <- c(1,1, 1, exp(theta.fisher[4:6])) grad.invfisher <- c(grad.invfisher,4*exp(2*theta.fisher[7:8])/(exp(2*theta.fisher[7:8])+1)^2) if (!fix.rho) grad.invfisher <- c(grad.invfisher,4*exp(2*theta.fisher[9])/(exp(2*theta.fisher[9])+1)^2) } Vobs<-diag(grad.invfisher)%*%Vobs.fisher%*%diag(grad.invfisher) Iobs<-solve(Vobs) ## obtain a symmetric Cov matrix Vobs.sym <- 0.5*(Vobs+t(Vobs)) ###unitscale transformation #theta.unit<-param.trans(theta.em, transformation="unitscale") #Icom.unit<-Icom.transform(Icom, Dvec,theta.em, transformation="unitscale") #Vobs.unit<-delta method if (!context) { names(mu)<-c("W1","W2") colnames(Sigma)<-rownames(Sigma)<-c("W1","W2") names(suff.stat)<-c("S1","S2","S11","S22","S12") if (!fix.rho) colnames(DM)<-rownames(DM)<-c("u1","u2","s1","s2","r12") if (fix.rho) colnames(DM)<-rownames(DM)<-c("u1","u2","s1","s2") } if (context) { names(mu)<-c("X","W1","W2") colnames(Sigma)<-rownames(Sigma)<-c("X","W1","W2") names(suff.stat)<-c("Sx","S1","S2","Sxx","S11","S22","Sx1","Sx2","S12") if (!fix.rho) { colnames(DM)<-rownames(DM)<-c("u1","u2","s1","s2","r1x","r2x","r12") colnames(Icom)<-rownames(Icom)<-c("ux","u1","u2","sx","s1","s2","r1x","r2x","r12") } if (fix.rho) { colnames(DM)<-rownames(DM)<-c("u1","u2","s1","s2","r1x","r2x") colnames(Icom)<-rownames(Icom)<-c("ux","u1","u2","sx","s1","s2","r1x","r2x") } } colnames(Iobs)<-colnames(Iobs.fisher)<-colnames(Icom.fisher)<-colnames(Vobs)<-colnames(Vobs.sym)<-colnames(Icom) rownames(Iobs)<-rownames(Iobs.fisher)<-rownames(Icom.fisher)<-rownames(Vobs)<-rownames(Vobs.sym)<-rownames(Icom) res.out<-list(mu=mu, Sigma=Sigma, suff.stat=suff.stat, context=context, fix.rho=fix.rho) res.out$DM<-DM res.out$Icom<-Icom res.out$Iobs<-Iobs res.out$Fmis<-1-diag(Iobs)/diag(Icom) res.out$Vcom<-Vcom<-solve(Icom) res.out$Vobs.original<-Vobs res.out$VFmis<-1-diag(Vcom)/diag(Vobs) res.out$Vobs<-Vobs.sym res.out$Icom.trans<-Icom.fisher res.out$Iobs.trans<-Iobs.fisher res.out$Fmis.trans<-1-diag(Iobs.fisher)/diag(Icom.fisher) res.out$Imiss<-res.out$Icom-res.out$Iobs res.out$Ieigen<-eigen(res.out$Imiss)[[1]][1] res.out } eco/R/summary.predict.eco.R0000644000175100001440000000133113061770754015265 0ustar hornikuserssummary.predict.eco <- function(object, CI=c(2.5, 97.5), ...) { if (any(CI < 0) || any(CI > 100)) stop("Invalid input for CI") n.draws <- nrow(object) n.var <- ncol(object) table.names<-c("mean", "std.dev", paste(min(CI), "%", sep=" "), paste(max(CI), "%", sep=" ")) W.table <- matrix(NA, ncol=length(table.names), nrow=n.var) for (i in 1:n.var) W.table[i,] <- cbind(mean(object[,i]), sd(object[,i]), quantile(object[,i], min(CI)/100), quantile(object[,i], max(CI)/100)) colnames(W.table) <- table.names rownames(W.table) <- colnames(object) res <- list(W.table = W.table, n.draws = n.draws) class(res) <- "summary.predict.eco" return(res) } eco/R/wallace.R0000644000175100001440000000226013104457061012773 0ustar hornikusers #' Black voting rates for Wallace for President, 1968 #' #' This data set contains, on a county level, the proportion of county #' residents who are Black and the proportion of presidential votes cast for #' Wallace. Demographic data is based on the 1960 census. Presidential returns #' are from ICPSR study 13. County data from 10 southern states (Alabama, #' Arkansas, Georgia, Florida, Louisiana, Mississippi, North Carolina, South #' Carolina, Tennessee, Texas) are included. (Virginia is excluded due to the #' difficulty of matching counties between the datasets.) This data is #' analyzed in Wallace and Segal (1973). #' #' #' @name wallace #' @docType data #' @format A data frame containing 3 variables and 1009 observations #' \tabular{lll}{ #' X \tab numeric \tab proportion of the population that is Black \cr #' Y \tab numeric \tab proportion presidential votes cast for Wallace \cr #' FIPS \tab numeric \tab the FIPS county code #' } #' @references Wasserman, Ira M. and David R. Segal (1973). ``Aggregation #' Effects in the Ecological Study of Presidential Voting.'' American Journal #' of Political Science. vol. 17, pp. 177-81. #' @keywords datasets NULL eco/R/ecoBD.R0000644000175100001440000002441113104457061012341 0ustar hornikusers#' Calculating the Bounds for Ecological Inference in RxC Tables #' #' \code{ecoBD} is used to calculate the bounds for missing internal cells of #' \eqn{R \times C} ecological table. The data can be entered either in the #' form of counts or proportions. #' #' The data may be entered either in the form of counts or proportions. If #' proportions are used, \code{formula} may omit the last row and/or column of #' tables, which can be calculated from the remaining margins. For example, #' \code{Y ~ X} specifies \code{Y} as the first column margin and \code{X} as #' the first row margin in \eqn{2 \times 2} tables. If counts are used, #' \code{formula} may omit the last row and/or column margin of the table only #' if \code{N} is supplied. In this example, the columns will be labeled as #' \code{X} and \code{not X}, and the rows will be labeled as \code{Y} and #' \code{not Y}. #' #' For larger tables, one can use \code{cbind()} and \code{+}. For example, #' \code{cbind(Y1, Y2, Y3) ~ X1 + X2 + X3 + X4)} specifies \eqn{3 \times 4} #' tables. #' #' An \eqn{R \times C} ecological table in the form of counts: \tabular{lcccc}{ #' \eqn{n_{i11}} \tab \eqn{n_{i12}} \tab \dots{} \tab \eqn{n_{i1C}} \tab #' \eqn{n_{i1.}} \cr \eqn{n_{i21}} \tab \eqn{n_{i22}} \tab \dots{} \tab #' \eqn{n_{i2C}} \tab \eqn{n_{i2.}} \cr \dots{} \tab \dots{} \tab \dots{} \tab #' \dots{} \tab \dots{}\cr \eqn{n_{iR1}} \tab \eqn{n_{iR2}} \tab \dots{} \tab #' \eqn{n_{iRC}} \tab \eqn{n_{iR.}} \cr \eqn{n_{i.1}} \tab \eqn{n_{i.2}} \tab #' \dots{} \tab \eqn{n_{i.C}} \tab \eqn{N_i} } where \eqn{n_{nr.}} and #' \eqn{n_{i.c}} represent the observed margins, \eqn{N_i} represents the size #' of the table, and \eqn{n_{irc}} are unknown variables. Note that for each #' \eqn{i}, the following deterministic relationships hold; \eqn{n_{ir.} = #' \sum_{c=1}^C n_{irc}} for \eqn{r=1,\dots,R}, and \eqn{n_{i.c}=\sum_{r=1}^R #' n_{irc}} for \eqn{c=1,\dots,C}. Then, each of the unknown inner cells can be #' bounded in the following manner, \deqn{\max(0, n_{ir.}+n_{i.c}-N_i) \le #' n_{irc} \le \min(n_{ir.}, n_{i.c}).} If the size of tables, \code{N}, is #' provided, #' #' An \eqn{R \times C} ecological table in the form of proportions: #' \tabular{lcccc}{ \eqn{W_{i11}} \tab \eqn{W_{i12}} \tab \dots{} \tab #' \eqn{W_{i1C}} \tab \eqn{Y_{i1}} \cr \eqn{W_{i21}} \tab \eqn{W_{i22}} \tab #' \dots{} \tab \eqn{W_{i2C}} \tab \eqn{Y_{i2}} \cr \dots{} \tab \dots{} \tab #' \dots{} \tab \dots{} \tab \dots{} \cr \eqn{W_{iR1}} \tab \eqn{W_{iR2}} \tab #' \dots{} \tab \eqn{W_{iRC}} \tab \eqn{Y_{iR}} \cr \eqn{X_{i1}} \tab #' \eqn{X_{i2}} \tab \dots{} \tab \eqn{X_{iC}} \tab } where \eqn{Y_{ir}} and #' \eqn{X_{ic}} represent the observed margins, and \eqn{W_{irc}} are unknown #' variables. Note that for each \eqn{i}, the following deterministic #' relationships hold; \eqn{Y_{ir} = \sum_{c=1}^C X_{ic} W_{irc}} for #' \eqn{r=1,\dots,R}, and \eqn{\sum_{r=1}^R W_{irc}=1} for \eqn{c=1,\dots,C}. #' Then, each of the inner cells of the table can be bounded in the following #' manner, \deqn{\max(0, (X_{ic} + Y_{ir}-1)/X_{ic}) \le W_{irc} \le \min(1, #' Y_{ir}/X_{ir}).} #' #' @param formula A symbolic description of ecological table to be used, #' specifying the column and row margins of \eqn{R \times C} ecological tables. #' Details and specific examples are given below. #' @param data An optional data frame in which to interpret the variables in #' \code{formula}. The default is the environment in which \code{ecoBD} is #' called. #' @param N An optional variable representing the size of the unit; e.g., the #' total number of voters. If \code{formula} is entered as counts and the last #' row and/or column is omitted, this input is necessary. #' @return An object of class \code{ecoBD} containing the following elements #' (When three dimensional arrays are used, the first dimension indexes the #' observations, the second dimension indexes the row numbers, and the third #' dimension indexes the column numbers): #' \item{call}{The matched call.} #' \item{X}{A matrix of the observed row margin, \eqn{X}.} #' \item{Y}{A matrix of the observed column margin, \eqn{Y}.} #' \item{N}{A vector of the size of ecological tables, \eqn{N}.} #' \item{aggWmin}{A three dimensional array of #' aggregate lower bounds for proportions.} #' \item{aggWmax}{A three dimensional array of aggregate upper bounds for proportions.} #' \item{Wmin}{A three dimensional array of lower bounds for proportions.} #' \item{Wmax}{A three dimensional array of upper bounds for proportions.} #' \item{Nmin}{A three dimensional array of lower bounds for counts.} #' \item{Nmax}{A three dimensional array of upper bounds for counts.} The object #' can be printed through \code{print.ecoBD}. #' @author Kosuke Imai, Department of Politics, Princeton University #' \email{kimai@@Princeton.Edu}, \url{http://imai.princeton.edu/}; Ying Lu, #' Center for Promoting Research Involving Innovative Statistical Methodology #' (PRIISM), New York University \email{ying.lu@@nyu.Edu} #' @seealso \code{eco}, \code{ecoNP} #' @references Imai, Kosuke, Ying Lu and Aaron Strauss. (2011) \dQuote{eco: R #' Package for Ecological Inference in 2x2 Tables} Journal of Statistical #' Software, Vol. 42, No. 5, pp. 1-23. available at #' \url{http://imai.princeton.edu/software/eco.html} #' #' Imai, Kosuke, Ying Lu and Aaron Strauss. (2008) \dQuote{Bayesian and #' Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data #' Approach} Political Analysis, Vol. 16, No. 1, (Winter), pp. 41-69. #' available at \url{http://imai.princeton.edu/research/eiall.html} #' @keywords models #' @examples #' #' #' ## load the registration data #' data(reg) #' #' ## calculate the bounds #' res <- ecoBD(Y ~ X, N = N, data = reg) #' ## print the results #' print(res) #' ecoBD <- function(formula, data = parent.frame(), N=NULL){ mf <- match.call() tt <- terms(formula) attr(tt, "intercept") <- 0 vnames <- attr(tt, "variables") vnamesR <- vnames[[2]] if (is.matrix(eval.parent(mf$data))) data <- as.data.frame(data) X <- model.matrix(tt, data) Y <- as.matrix(model.response(model.frame(tt, data = data))) N <- eval(mf$N, data) n.obs <- nrow(X) ## counts if (all(X>1) & all(Y>1)) { if (!is.null(N)) { if (!all(apply(X, 1, sum) == N)) X <- cbind(X, N-apply(X, 1, sum)) if (!all(apply(Y, 1, sum) == N)) Y <- cbind(Y, N-apply(Y, 1, sum)) if(any(X<0) || any(Y<0)) stop("Invalid inputs for X, Y, or/and N") } else { if (!all(apply(X, 1, sum) == apply(Y, 1, sum))) stop("X and Y do not sum to the same number. Input N.") N <- apply(X, 1, sum) } C <- ncol(X) R <- ncol(Y) Wmin <- Wmax <- Nmin <- Nmax <- array(NA, c(n.obs, R, C)) clab <- rlab <- NULL if (length(vnames) == 3) clab <- c(vnames[[3]], paste("not",vnames[[3]])) else { for (j in 1:C) { if ((j == C) & (length(vnames) < j+2)) clab <- c(clab, "other") else clab <- c(clab, vnames[[j+2]]) } } if (length(vnamesR) == 1) rlab <- c(vnamesR, paste("not",vnamesR)) else { for (i in 1:R) { if ((i == R) & (length(vnamesR) < i+1)) rlab <- c(rlab, "other") else rlab <- c(rlab, vnamesR[[i]]) } } for (i in 1:R) { for (j in 1:C) { Nmin[,i,j] <- apply(cbind(0, X[,j]+Y[,i]-N), 1, max) Nmax[,i,j] <- apply(cbind(Y[,i], X[,j]), 1, min) Wmin[,i,j] <- Nmin[,i,j]/X[,j] Wmax[,i,j] <- Nmax[,i,j]/X[,j] } } dimnames(Wmin) <- dimnames(Wmax) <- dimnames(Nmin) <- dimnames(Nmax) <- list(if (is.null(rownames(X))) 1:n.obs else rownames(X), rlab, clab) } else { ## proportions if (any(apply(X, 1, sum) > 1.000000001)) stop("invalid input for X") if (any(apply(X, 1, sum) < 0.9999999999)) X <- cbind(X, 1-X) if (any(apply(Y, 1, sum) > 1.0000000001)) stop("invalid input for Y") if (any(apply(Y, 1, sum) < 0.9999999999)) Y <- cbind(Y, 1-Y) C <- ncol(X) R <- ncol(Y) Wmin <- Wmax <- array(NA, c(n.obs, R, C)) clab <- rlab <- NULL if (length(vnames) == 3) clab <- c(vnames[[3]], paste("not",vnames[[3]])) else { for (j in 1:C) { if ((j == C) & (length(vnames) < j+2)) clab <- c(clab, "other") else clab <- c(clab, vnames[[j+2]]) } } if (length(vnamesR) == 1) rlab <- c(vnamesR, paste("not",vnamesR)) else { for (i in 1:R) { if ((i == R) & (length(vnamesR) < i+1)) rlab <- c(rlab, "other") else rlab <- c(rlab, vnamesR[[i]]) } } for (i in 1:R) { for (j in 1:C) { Wmin[,i,j] <- apply(cbind(0, (X[,j]+Y[,i]-1)/X[,j]), 1, max) Wmax[,i,j] <- apply(cbind(1, Y[,i]/X[,j]), 1, min) } } dimnames(Wmin) <- dimnames(Wmax) <- list(if (is.null(rownames(X))) 1:n.obs else rownames(X), rlab, clab) colnames(X) <- clab colnames(Y) <- rlab if (!is.null(N)) { Nmin <- Nmax <- array(NA, c(n.obs, R, C), dimnames = dimnames(Wmin)) for (i in 1:R) for (j in 1:C) { Nmin[,i,j] <- Wmin[,i,j]*X[,j]*N Nmax[,i,j] <- Wmax[,i,j]*X[,j]*N } } else Nmin <- Nmax <- NULL } ## aggregate bounds aggWmin <- aggWmax <- matrix(NA, R, C, dimnames = list(dimnames(Wmin)[[2]], dimnames(Wmin)[[3]])) if (is.null(N)) for (j in 1:C) { aggWmin[,j] <- apply(Wmin[,,j], 2, weighted.mean, X[,j]) aggWmax[,j] <- apply(Wmax[,,j], 2, weighted.mean, X[,j]) } else for (j in 1:C) { aggWmin[,j] <- apply(Wmin[,,j], 2, weighted.mean, X[,j]*N) aggWmax[,j] <- apply(Wmax[,,j], 2, weighted.mean, X[,j]*N) } if (!is.null(Nmin) & !is.null(Nmax)) { aggNmin <- aggNmax <- matrix(NA, R, C, dimnames = list(dimnames(Nmin)[[2]], dimnames(Nmin)[[3]])) for (j in 1:C) { aggNmin[,j] <- apply(Nmin[,,j], 2, sum) aggNmax[,j] <- apply(Nmax[,,j], 2, sum) } } else aggNmin <- aggNmax <- NULL ## output res <- list(call = mf, X = X, Y = Y, N = N, aggWmin = aggWmin, aggWmax = aggWmax, aggNmin = aggNmin, aggNmax = aggNmax, Wmin = Wmin, Wmax = Wmax, Nmin = Nmin, Nmax = Nmax) class(res) <- c("ecoBD", "eco") return(res) } eco/MD50000644000175100001440000001073113140010242011333 0ustar hornikusersa97e444214f6bc2f0dc91e77059aeb58 *ChangeLog 69fcff33f43261b9ebb165aee6079d2b *DESCRIPTION 82661102615f33d350638c7923217ea3 *NAMESPACE 82bfbbce207fde61df8337e9e842f6a1 *R/Qfun.R b74ced70c45cdb899135650f263f04fe *R/census.R 19b54ec2f8a821715be3881948ab4dfd *R/checkdata.R b739dfc6d215a18af2bbeed867ce8dd2 *R/coef.eco.R 4e0835221af546dde07cc910439fd29c *R/coef.ecoNP.R c43a1de04f4f229ed5d6617d193413bc *R/eco.R fc0afad120e9c0a80cc1db98ff519134 *R/ecoBD.R ec74fb120755d764a8c07ef534831b50 *R/ecoCV.R 005a4d42a4789517caf062a33011abae *R/ecoNP.R d571c7dcb6ffae9532bff0b392edd3a1 *R/ecoRC.R 42549ecc00ca7e5580315616518b8709 *R/emeco.R 6c644c7e6e990443dcf79b10722e8180 *R/eminfo.R 0ecadfff0304da67d092fea6ae6e7e9d *R/forgnlit30.R 6460331fb0043c2c77d012e4a0a89830 *R/forgnlit30c.R fedd2983b7afaea7298382918e90115d *R/housep88.R 8b136280b6d870259d087afe9fb8f5c6 *R/logit.R 74be3d5191777b2fd500f602a998e000 *R/onAttach.R 943ad8b1c83e94027885bd15dccec97f *R/predict.eco.R 211fd8465e7d1832c720f7af2b41a217 *R/predict.ecoNP.R ecc1895271f0c80d1e439d264250c2d7 *R/predict.ecoNPX.R 5b19a3e918ccff3c9969c25226b4803b *R/predict.ecoX.R ec3456b70b939df343420cc1d3f6aa14 *R/print.eco.R 076356bd800db18b690efb01af2cc8ba *R/print.ecoBD.R 14bcd129eb23ba5341fbc7e49d53c121 *R/print.ecoML.R 395905d2e7ab1b95fbdf638d7daf1968 *R/print.summary.eco.R da8f571bd9e956968e9fbde845fd79a6 *R/print.summary.ecoML.R 0f94822aeda6d553bddcecad380921e4 *R/print.summary.ecoNP.R 053e97b9a3e773e0f451394ba26e1f52 *R/print.summary.predict.eco.R c0265cba5df4817d065bc0ea179351ac *R/reg.R b9b3e61083ba6cc7ad26d906f29d55f8 *R/summary.eco.R 6c6e77fffcc64accc9d1cd821db5f2c7 *R/summary.ecoML.R 4f9a6fac61c66f10773b2798fa9cf249 *R/summary.ecoNP.R b16954c324c6f0cda61d97a97e58c626 *R/summary.predict.eco.R c3b40e569a714b410c08a60c3881db57 *R/varcov.R 0d0a29d123b6cefc03ac008d319ee66f *R/wallace.R 4999fe2d5c10c20ef7953c519ea4b864 *data/census.txt.gz bab848bf01c09ff663551d74a091aacb *data/forgnlit30.txt.gz 72a68f958f3d09b6bfbc57ac2999c31c *data/forgnlit30c.txt.gz 7232655f0724246d816712ee30d5dea6 *data/housep88.txt.gz 997a61242cc887b3b0e7167b850dc5fd *data/reg.txt.gz 2329fbd925f12169a0b92cbb3bc8863d *data/wallace.txt.gz 6762185d8bce0126591ba4a32c5dd39c *inst/CITATION 24e77ebb2f3a53c3394c2ccb99a48fea *man/Qfun.Rd 7b20faf0e8f3ec97bbac0320bd3a3c10 *man/census.Rd 900ba355c27630ab275274f86bcd4784 *man/eco.Rd 9befa053e1b48ad1c4aa21db9002643c *man/ecoBD.Rd 10f78bb22d8a352f2781eb68988c8668 *man/ecoML.Rd c1c71c88af648e9ebc1c5b45cf5ce506 *man/ecoNP.Rd c520fd06d22c76c92a45ae84bd520691 *man/forgnlit30.Rd cc4ba227d20570081def3f9830151e9f *man/forgnlit30c.Rd d025fe7ff575d074d108f09aa5e80002 *man/housep88.Rd 19323471a8664780b2eb9465b55475b8 *man/predict.eco.Rd 4f423bc5c7fa02c071f4e23eec718c9b *man/predict.ecoNP.Rd 56675900f901c4008a15172bc7f1a786 *man/predict.ecoNPX.Rd 58a352241a365fee452945573780d79c *man/predict.ecoX.Rd 3dd1539fe012fa5480a3821fe5ef1f86 *man/print.summary.eco.Rd 54f935978fa7cb7ebf19664094327543 *man/print.summary.ecoML.Rd bf995b21af9506cd47b2e82776d07fb3 *man/print.summary.ecoNP.Rd 7f26c7c6bd63a4014b6b5f185b89687b *man/reg.Rd 524bc89a424071e15f8c1e9135a48dfa *man/summary.eco.Rd 25c5e39725905952364835a506ffcc54 *man/summary.ecoML.Rd 92d2d80cb3bc32cd8a446a0bd6b3ba58 *man/summary.ecoNP.Rd 8b8d3acc9b7559381dd73afce8950724 *man/wallace.Rd f009e46fcf131d28ea4ead122961b7bd *src/Makevars 61d0335fbb10bbacb4a0c133d1eda041 *src/bayes.c de17d4ca6e1eadef448d31e5bb278be9 *src/bayes.h 6d1c67e5b20580efdd22e3ccb4d6b930 *src/fintegrate.c 6547650d65505a06b847b26c2f0dfcdf *src/fintegrate.h e4f4765b9dbde486d170894f9084daf5 *src/gibbsBase.c 82a00f75e3c796b5b66e24a5b3fc1198 *src/gibbsBase2C.c cd03908bee96f1538c50e907fcd5eb7b *src/gibbsBaseRC.c 33f0950281de3da321bfe80cac8e00c9 *src/gibbsDP.c 0f4793b8a4f4ca98a88e5b3ca596072f *src/gibbsEM.c 48c80c9da450292d7566da2dc4bcc1db *src/gibbsXBase.c 1b532d75ab6bdb2439666141b3d81c6f *src/gibbsXDP.c 9838dce871783dc1e06daee8da07a315 *src/gibbsZBase.c 4b04b59b076f6ce11a7977f09892fc99 *src/init.c c24852e22728b2f506134dd8221e522f *src/macros.h 1f95f3a7a65183b82d0fb016496dc84f *src/preBaseX.c b0dd2bd8e7ed47ae7d5327055b8b92ca *src/preDP.c 304c6f667aed46416a1336b67ce9cb49 *src/preDPX.c fcb06c890afff62b4b0e2513a64c5a61 *src/rand.c 9a7e8d0aaa99088d05813349cf590f07 *src/rand.h fc17ca85ae3c58d8730cfec91fdc06dc *src/sample.c d32b15707595f439df5fbaabee5b85c3 *src/sample.h 74c4d37cfec10a5bfa9983f84d70ca2f *src/subroutines.c 80400b50a31ad1b68a2c5b594edf0bf8 *src/subroutines.h fb277bf399a12283c95c33f0b990ead8 *src/vector.c 9f7d40b1458a95830ba736c18ab76522 *src/vector.h eco/DESCRIPTION0000644000175100001440000000322413140010242012530 0ustar hornikusersPackage: eco Version: 4.0-1 Date: 2017-7-26 Title: Ecological Inference in 2x2 Tables Authors@R: c( person("Kosuke", "Imai", , "kimai@Princeton.Edu", c("aut")), person("Ying", "Lu", , "ying.lu@nyu.edu", c("aut", "cre")), person("Aaron", "Strauss", , "aaronbstrauss@gmail.com", c("aut")), person("Hubert", "Jin", , "hubertj@princeton.edu", c("ctb")) ) Maintainer: Ying Lu Depends: R (>= 2.0), MASS, utils Description: Implements the Bayesian and likelihood methods proposed in Imai, Lu, and Strauss (2008 ) and (2011 ) for ecological inference in 2 by 2 tables as well as the method of bounds introduced by Duncan and Davis (1953). The package fits both parametric and nonparametric models using either the Expectation-Maximization algorithms (for likelihood models) or the Markov chain Monte Carlo algorithms (for Bayesian models). For all models, the individual-level data can be directly incorporated into the estimation whenever such data are available. Along with in-sample and out-of-sample predictions, the package also provides a functionality which allows one to quantify the effect of data aggregation on parameter estimation and hypothesis testing under the parametric likelihood models. LazyLoad: yes LazyData: yes License: GPL (>= 2) URL: https://github.com/kosukeimai/eco BugReports: https://github.com/kosukeimai/eco/issues RoxygenNote: 6.0.1 NeedsCompilation: yes Packaged: 2017-07-27 03:00:22 UTC; kimai Author: Kosuke Imai [aut], Ying Lu [aut, cre], Aaron Strauss [aut], Hubert Jin [ctb] Repository: CRAN Date/Publication: 2017-08-01 05:24:50 UTC eco/ChangeLog0000644000175100001440000000162313114241145012606 0ustar hornikusers4.0-1 05.10.17 Roxygen2 compliant, C functions registered 3.1-7 03.04.15 minor fixes 3.1-6 06.12.12 minor fixes 3.1-5 05.29.12 minor fixes 3.1-4 07.12.09 minor fixes 3.1-3 07.05.09 minor fixes 3.1-2 01.29.09 minor documentation fixes 3.1-1 06.27.07 some minor improvements; final version for JSS publication 3.0-2 01.11.07 made it comparible with the Windows; a bug fix in summary.ecoML() 3.0-1 12.27.06 a major revision; added ML estimation, calculation of fraction of missing information, stable release for R-2.4.1 2.2-2 09.23.06 changed due to updates in R 2.2-1 09.28.05 nonparametric model with contextual effects added 2.1-1 07.06.05 a major revision; added bounds and prediction; added/updated other functionalities 1.1-1 06.15.05 add the Metropolis algorithm to sample W 1.0-1 12.21.04 first official version; submitted to CRAN 0.9-1 09.07.04 first beta version eco/man/0000755000175100001440000000000013104457061011612 5ustar hornikuserseco/man/print.summary.ecoNP.Rd0000644000175100001440000000350113104457061015733 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.summary.ecoNP.R \name{print.summary.ecoNP} \alias{print.summary.ecoNP} \title{Print the Summary of the Results for the Bayesian Nonparametric Model for Ecological Inference in 2x2 Tables} \usage{ \method{print}{summary.ecoNP}(x, digits = max(3, getOption("digits") - 3), ...) } \arguments{ \item{x}{An object of class \code{summary.ecoNP}.} \item{digits}{the number of significant digits to use when printing.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{summary.ecoNP} yields an object of class \code{summary.ecoNP} containing the following elements: \item{call}{The call from \code{ecoNP}.} \item{n.obs}{The number of units.} \item{n.draws}{The number of Monte Carlo samples.} \item{agg.table}{Aggregate posterior estimates of the marginal means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If \code{param = TRUE}, the following elements are also included: \item{param.table}{Posterior estimates of model parameters: population mean estimates of \eqn{W_1} and \eqn{W_2}. If \code{subset} is specified, only a subset of the population parameters are included.} If \code{unit = TRUE}, the following elements are also included: \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} This object can be printed by \code{print.summary.ecoNP} } \description{ \code{summary} method for class \code{ecoNP}. } \seealso{ \code{ecoNP}, \code{predict.eco} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/predict.ecoX.Rd0000644000175100001440000000615113104457061014433 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.ecoX.R \name{predict.ecoX} \alias{predict.ecoX} \title{Out-of-Sample Posterior Prediction under the Parametric Bayesian Model for Ecological Inference in 2x2 Tables} \usage{ \method{predict}{ecoX}(object, newdraw = NULL, subset = NULL, newdata = NULL, cond = FALSE, verbose = FALSE, ...) } \arguments{ \item{object}{An output object from \code{eco} or \code{ecoNP}.} \item{newdraw}{An optional list containing two matrices (or three dimensional arrays for the nonparametric model) of MCMC draws of \eqn{\mu} and \eqn{\Sigma}. Those elements should be named as \code{mu} and \code{Sigma}, respectively. The default is the original MCMC draws stored in \code{object}.} \item{subset}{A scalar or numerical vector specifying the row number(s) of \code{mu} and \code{Sigma} in the output object from \code{eco}. If specified, the posterior draws of parameters for those rows are used for posterior prediction. The default is \code{NULL} where all the posterior draws are used.} \item{newdata}{An optional data frame containing a new data set for which posterior predictions will be made. The new data set must have the same variable names as those in the original data.} \item{cond}{logical. If \code{TRUE}, then the conditional prediction will made for the parametric model with contextual effects. The default is \code{FALSE}.} \item{verbose}{logical. If \code{TRUE}, helpful messages along with a progress report on the Monte Carlo sampling from the posterior predictive distributions are printed on the screen. The default is \code{FALSE}.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{predict.eco} yields a matrix of class \code{predict.eco} containing the Monte Carlo sample from the posterior predictive distribution of inner cells of ecological tables. \code{summary.predict.eco} will summarize the output, and \code{print.summary.predict.eco} will print the summary. } \description{ Obtains out-of-sample posterior predictions under the fitted parametric Bayesian model for ecological inference. \code{predict} method for class \code{eco} and \code{ecoX}. } \details{ The posterior predictive values are computed using the Monte Carlo sample stored in the \code{eco} output (or other sample if \code{newdraw} is specified). Given each Monte Carlo sample of the parameters, we sample the vector-valued latent variable from the appropriate multivariate Normal distribution. Then, we apply the inverse logit transformation to obtain the predictive values of proportions, \eqn{W}. The computation may be slow (especially for the nonparametric model) if a large Monte Carlo sample of the model parameters is used. In either case, setting \code{verbose = TRUE} may be helpful in monitoring the progress of the code. } \seealso{ \code{eco}, \code{predict.ecoNP} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/Qfun.Rd0000644000175100001440000000323613104457061013016 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Qfun.R \name{Qfun} \alias{Qfun} \title{Fitting the Parametric Bayesian Model of Ecological Inference in 2x2 Tables} \usage{ Qfun(theta, suff.stat, n) } \arguments{ \item{theta}{A vector that contains the MLE \eqn{E(W_1)},\eqn{E(W_2)}, \eqn{var(W_1)},\eqn{var(W_2)}, and \eqn{cov(W_1,W_2)}. Typically it is the element \code{theta.em} of an object of class \code{ecoML}.} \item{suff.stat}{A vector of sufficient statistics of \eqn{E(W_1)}, \eqn{E(W_2)}, \eqn{var(W_1)},\eqn{var(W_2)}, and \eqn{cov(W_1,W_2)}.} \item{n}{A integer representing the sample size.} } \description{ \code{Qfun} returns the complete log-likelihood that is used to calculate the fraction of missing information. } \references{ Imai, Kosuke, Ying Lu and Aaron Strauss. (2011). \dQuote{eco: R Package for Ecological Inference in 2x2 Tables} Journal of Statistical Software, Vol. 42, No. 5, pp. 1-23. available at \url{http://imai.princeton.edu/software/eco.html} Imai, Kosuke, Ying Lu and Aaron Strauss. (2008). \dQuote{Bayesian and Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data Approach} Political Analysis, Vol. 16, No. 1 (Winter), pp. 41-69. available at \url{http://imai.princeton.edu/research/eiall.html} } \seealso{ \code{ecoML} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} Aaron Strauss, Department of Politics, Princeton University, \email{abstraus@Princeton.Edu}. } \keyword{models} eco/man/housep88.Rd0000644000175100001440000000307513104457061013571 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/housep88.R \docType{data} \name{housep88} \alias{housep88} \title{Electoral Results for the House and Presidential Races in 1988} \format{A data frame containing 5 variables and 424 observations \tabular{lll}{ X \tab numeric \tab proportion voting for the Democrat in the presidential race \cr Y \tab numeric \tab proportion voting for the Democrat in the House race \cr N \tab numeric \tab number of major party voters in the presidential contest \cr HPCT \tab numeric \tab House election turnout divided by presidential election turnout (set to 1 if House turnout exceeds presidential turnout) \cr DIST \tab numeric \tab 4-digit ICPSR state and district code: first 2 digits for the state code, last two digits for the district number (e.g., 2106=IL 6th) }} \description{ This data set contains, on a House district level, the percentage of the vote for the Democratic House candidate, the percentage of the vote for the Democratic presidential candidate (Dukakis), the number of voters who voted for a major party candidate in the presidential race, and the ratio of voters in the House race versus the number who cast a ballot for President. Eleven (11) uncontested races are not included. Dataset compiled and analyzed by Burden and Kimball (1988). Complete dataset and documentation available at ICSPR study number 1140. } \references{ Burden, Barry C. and David C. Kimball (1988). ``A New Approach To Ticket- Splitting.'' The American Political Science Review. vol 92., no. 3, pp. 553-544. } \keyword{datasets} eco/man/predict.ecoNP.Rd0000644000175100001440000000600213104457061014534 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.ecoNP.R \name{predict.ecoNP} \alias{predict.ecoNP} \title{Out-of-Sample Posterior Prediction under the Nonparametric Bayesian Model for Ecological Inference in 2x2 Tables} \usage{ \method{predict}{ecoNP}(object, newdraw = NULL, subset = NULL, obs = NULL, verbose = FALSE, ...) } \arguments{ \item{object}{An output object from \code{ecoNP}.} \item{newdraw}{An optional list containing two matrices (or three dimensional arrays for the nonparametric model) of MCMC draws of \eqn{\mu} and \eqn{\Sigma}. Those elements should be named as \code{mu} and \code{Sigma}, respectively. The default is the original MCMC draws stored in \code{object}.} \item{subset}{A scalar or numerical vector specifying the row number(s) of \code{mu} and \code{Sigma} in the output object from \code{eco}. If specified, the posterior draws of parameters for those rows are used for posterior prediction. The default is \code{NULL} where all the posterior draws are used.} \item{obs}{An integer or vector of integers specifying the observation number(s) whose posterior draws will be used for predictions. The default is \code{NULL} where all the observations in the data set are selected.} \item{verbose}{logical. If \code{TRUE}, helpful messages along with a progress report on the Monte Carlo sampling from the posterior predictive distributions are printed on the screen. The default is \code{FALSE}.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{predict.eco} yields a matrix of class \code{predict.eco} containing the Monte Carlo sample from the posterior predictive distribution of inner cells of ecological tables. \code{summary.predict.eco} will summarize the output, and \code{print.summary.predict.eco} will print the summary. } \description{ Obtains out-of-sample posterior predictions under the fitted nonparametric Bayesian model for ecological inference. \code{predict} method for class \code{ecoNP} and \code{ecoNPX}. } \details{ The posterior predictive values are computed using the Monte Carlo sample stored in the \code{eco} or \code{ecoNP} output (or other sample if \code{newdraw} is specified). Given each Monte Carlo sample of the parameters, we sample the vector-valued latent variable from the appropriate multivariate Normal distribution. Then, we apply the inverse logit transformation to obtain the predictive values of proportions, \eqn{W}. The computation may be slow (especially for the nonparametric model) if a large Monte Carlo sample of the model parameters is used. In either case, setting \code{verbose = TRUE} may be helpful in monitoring the progress of the code. } \seealso{ \code{eco}, \code{ecoNP}, \code{summary.eco}, \code{summary.ecoNP} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/ecoBD.Rd0000644000175100001440000001316213104457061013060 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ecoBD.R \name{ecoBD} \alias{ecoBD} \title{Calculating the Bounds for Ecological Inference in RxC Tables} \usage{ ecoBD(formula, data = parent.frame(), N = NULL) } \arguments{ \item{formula}{A symbolic description of ecological table to be used, specifying the column and row margins of \eqn{R \times C} ecological tables. Details and specific examples are given below.} \item{data}{An optional data frame in which to interpret the variables in \code{formula}. The default is the environment in which \code{ecoBD} is called.} \item{N}{An optional variable representing the size of the unit; e.g., the total number of voters. If \code{formula} is entered as counts and the last row and/or column is omitted, this input is necessary.} } \value{ An object of class \code{ecoBD} containing the following elements (When three dimensional arrays are used, the first dimension indexes the observations, the second dimension indexes the row numbers, and the third dimension indexes the column numbers): \item{call}{The matched call.} \item{X}{A matrix of the observed row margin, \eqn{X}.} \item{Y}{A matrix of the observed column margin, \eqn{Y}.} \item{N}{A vector of the size of ecological tables, \eqn{N}.} \item{aggWmin}{A three dimensional array of aggregate lower bounds for proportions.} \item{aggWmax}{A three dimensional array of aggregate upper bounds for proportions.} \item{Wmin}{A three dimensional array of lower bounds for proportions.} \item{Wmax}{A three dimensional array of upper bounds for proportions.} \item{Nmin}{A three dimensional array of lower bounds for counts.} \item{Nmax}{A three dimensional array of upper bounds for counts.} The object can be printed through \code{print.ecoBD}. } \description{ \code{ecoBD} is used to calculate the bounds for missing internal cells of \eqn{R \times C} ecological table. The data can be entered either in the form of counts or proportions. } \details{ The data may be entered either in the form of counts or proportions. If proportions are used, \code{formula} may omit the last row and/or column of tables, which can be calculated from the remaining margins. For example, \code{Y ~ X} specifies \code{Y} as the first column margin and \code{X} as the first row margin in \eqn{2 \times 2} tables. If counts are used, \code{formula} may omit the last row and/or column margin of the table only if \code{N} is supplied. In this example, the columns will be labeled as \code{X} and \code{not X}, and the rows will be labeled as \code{Y} and \code{not Y}. For larger tables, one can use \code{cbind()} and \code{+}. For example, \code{cbind(Y1, Y2, Y3) ~ X1 + X2 + X3 + X4)} specifies \eqn{3 \times 4} tables. An \eqn{R \times C} ecological table in the form of counts: \tabular{lcccc}{ \eqn{n_{i11}} \tab \eqn{n_{i12}} \tab \dots{} \tab \eqn{n_{i1C}} \tab \eqn{n_{i1.}} \cr \eqn{n_{i21}} \tab \eqn{n_{i22}} \tab \dots{} \tab \eqn{n_{i2C}} \tab \eqn{n_{i2.}} \cr \dots{} \tab \dots{} \tab \dots{} \tab \dots{} \tab \dots{}\cr \eqn{n_{iR1}} \tab \eqn{n_{iR2}} \tab \dots{} \tab \eqn{n_{iRC}} \tab \eqn{n_{iR.}} \cr \eqn{n_{i.1}} \tab \eqn{n_{i.2}} \tab \dots{} \tab \eqn{n_{i.C}} \tab \eqn{N_i} } where \eqn{n_{nr.}} and \eqn{n_{i.c}} represent the observed margins, \eqn{N_i} represents the size of the table, and \eqn{n_{irc}} are unknown variables. Note that for each \eqn{i}, the following deterministic relationships hold; \eqn{n_{ir.} = \sum_{c=1}^C n_{irc}} for \eqn{r=1,\dots,R}, and \eqn{n_{i.c}=\sum_{r=1}^R n_{irc}} for \eqn{c=1,\dots,C}. Then, each of the unknown inner cells can be bounded in the following manner, \deqn{\max(0, n_{ir.}+n_{i.c}-N_i) \le n_{irc} \le \min(n_{ir.}, n_{i.c}).} If the size of tables, \code{N}, is provided, An \eqn{R \times C} ecological table in the form of proportions: \tabular{lcccc}{ \eqn{W_{i11}} \tab \eqn{W_{i12}} \tab \dots{} \tab \eqn{W_{i1C}} \tab \eqn{Y_{i1}} \cr \eqn{W_{i21}} \tab \eqn{W_{i22}} \tab \dots{} \tab \eqn{W_{i2C}} \tab \eqn{Y_{i2}} \cr \dots{} \tab \dots{} \tab \dots{} \tab \dots{} \tab \dots{} \cr \eqn{W_{iR1}} \tab \eqn{W_{iR2}} \tab \dots{} \tab \eqn{W_{iRC}} \tab \eqn{Y_{iR}} \cr \eqn{X_{i1}} \tab \eqn{X_{i2}} \tab \dots{} \tab \eqn{X_{iC}} \tab } where \eqn{Y_{ir}} and \eqn{X_{ic}} represent the observed margins, and \eqn{W_{irc}} are unknown variables. Note that for each \eqn{i}, the following deterministic relationships hold; \eqn{Y_{ir} = \sum_{c=1}^C X_{ic} W_{irc}} for \eqn{r=1,\dots,R}, and \eqn{\sum_{r=1}^R W_{irc}=1} for \eqn{c=1,\dots,C}. Then, each of the inner cells of the table can be bounded in the following manner, \deqn{\max(0, (X_{ic} + Y_{ir}-1)/X_{ic}) \le W_{irc} \le \min(1, Y_{ir}/X_{ir}).} } \examples{ ## load the registration data data(reg) ## calculate the bounds res <- ecoBD(Y ~ X, N = N, data = reg) ## print the results print(res) } \references{ Imai, Kosuke, Ying Lu and Aaron Strauss. (2011) \dQuote{eco: R Package for Ecological Inference in 2x2 Tables} Journal of Statistical Software, Vol. 42, No. 5, pp. 1-23. available at \url{http://imai.princeton.edu/software/eco.html} Imai, Kosuke, Ying Lu and Aaron Strauss. (2008) \dQuote{Bayesian and Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data Approach} Political Analysis, Vol. 16, No. 1, (Winter), pp. 41-69. available at \url{http://imai.princeton.edu/research/eiall.html} } \seealso{ \code{eco}, \code{ecoNP} } \author{ Kosuke Imai, Department of Politics, Princeton University \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu/}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{models} eco/man/predict.eco.Rd0000644000175100001440000000534513104457061014307 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.eco.R \name{predict.eco} \alias{predict.eco} \title{Out-of-Sample Posterior Prediction under the Parametric Bayesian Model for Ecological Inference in 2x2 Tables} \usage{ \method{predict}{eco}(object, newdraw = NULL, subset = NULL, verbose = FALSE, ...) } \arguments{ \item{object}{An output object from \code{eco} or \code{ecoNP}.} \item{newdraw}{An optional list containing two matrices (or three dimensional arrays for the nonparametric model) of MCMC draws of \eqn{\mu} and \eqn{\Sigma}. Those elements should be named as \code{mu} and \code{Sigma}, respectively. The default is the original MCMC draws stored in \code{object}.} \item{subset}{A scalar or numerical vector specifying the row number(s) of \code{mu} and \code{Sigma} in the output object from \code{eco}. If specified, the posterior draws of parameters for those rows are used for posterior prediction. The default is \code{NULL} where all the posterior draws are used.} \item{verbose}{logical. If \code{TRUE}, helpful messages along with a progress report on the Monte Carlo sampling from the posterior predictive distributions are printed on the screen. The default is \code{FALSE}.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{predict.eco} yields a matrix of class \code{predict.eco} containing the Monte Carlo sample from the posterior predictive distribution of inner cells of ecological tables. \code{summary.predict.eco} will summarize the output, and \code{print.summary.predict.eco} will print the summary. } \description{ Obtains out-of-sample posterior predictions under the fitted parametric Bayesian model for ecological inference. \code{predict} method for class \code{eco} and \code{ecoX}. } \details{ The posterior predictive values are computed using the Monte Carlo sample stored in the \code{eco} output (or other sample if \code{newdraw} is specified). Given each Monte Carlo sample of the parameters, we sample the vector-valued latent variable from the appropriate multivariate Normal distribution. Then, we apply the inverse logit transformation to obtain the predictive values of proportions, \eqn{W}. The computation may be slow (especially for the nonparametric model) if a large Monte Carlo sample of the model parameters is used. In either case, setting \code{verbose = TRUE} may be helpful in monitoring the progress of the code. } \seealso{ \code{eco}, \code{predict.ecoNP} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/print.summary.ecoML.Rd0000644000175100001440000000534313104457061015734 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.summary.ecoML.R \name{print.summary.ecoML} \alias{print.summary.ecoML} \title{Print the Summary of the Results for the Maximum Likelihood Parametric Model for Ecological Inference in 2x2 Tables} \usage{ \method{print}{summary.ecoML}(x, digits = max(3, getOption("digits") - 3), ...) } \arguments{ \item{x}{An object of class \code{summary.ecoML}.} \item{digits}{the number of significant digits to use when printing.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{summary.eco} yields an object of class \code{summary.eco} containing the following elements: \item{call}{The call from \code{eco}.} \item{sem}{Whether the SEM algorithm was executed, as specified by the user upon calling \code{ecoML}.} \item{fix.rho}{Whether the correlation parameter was fixed or allowed to vary, as specified by the user upon calling \code{ecoML}.} \item{epsilon}{The convergence threshold specified by the user upon calling \code{ecoML}.} \item{n.obs}{The number of units.} \item{iters.em}{The number iterations the EM algorithm cycled through before convergence or reaching the maximum number of iterations allowed.} \item{iters.sem}{The number iterations the SEM algorithm cycled through before convergence or reaching the maximum number of iterations allowed.} \item{loglik}{The final observed log-likelihood.} \item{rho}{A matrix of \code{iters.em} rows specifying the correlation parameters at each iteration of the EM algorithm. The number of columns depends on how many correlation parameters exist in the model. Column order is the same as the order of the parameters in \code{param.table}.} \item{param.table}{Final estimates of the parameter values for the model. Excludes parameters fixed by the user upon calling \code{ecoML}. See \code{ecoML} documentation for order of parameters.} \item{agg.table}{Aggregate estimates of the marginal means of \eqn{W_1} and \eqn{W_2}} \item{agg.wtable}{Aggregate estimates of the marginal means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If \code{units = TRUE}, the following elements are also included: \item{W.table}{Unit-level estimates for \eqn{W_1} and \eqn{W_2}.} This object can be printed by \code{print.summary.eco} } \description{ \code{summary} method for class \code{eco}. } \seealso{ \code{ecoML} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu}; Aaron Strauss, Department of Politics, Princeton University, \email{abstraus@Princeton.Edu} } \keyword{methods} eco/man/summary.ecoNP.Rd0000644000175100001440000000470513104457061014607 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.ecoNP.R \name{summary.ecoNP} \alias{summary.ecoNP} \title{Summarizing the Results for the Bayesian Nonparametric Model for Ecological Inference in 2x2 Tables} \usage{ \method{summary}{ecoNP}(object, CI = c(2.5, 97.5), param = FALSE, units = FALSE, subset = NULL, ...) } \arguments{ \item{object}{An output object from \code{ecoNP}.} \item{CI}{A vector of lower and upper bounds for the Bayesian credible intervals used to summarize the results. The default is the equal tail 95 percent credible interval.} \item{param}{Logical. If \code{TRUE}, the posterior estimates of the population parameters will be provided. The default value is \code{FALSE}.} \item{units}{Logical. If \code{TRUE}, the in-sample predictions for each unit or for a subset of units will be provided. The default value is \code{FALSE}.} \item{subset}{A numeric vector indicating the subset of the units whose in-sample predications to be provided when \code{units} is \code{TRUE}. The default value is \code{NULL} where the in-sample predictions for each unit will be provided.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{summary.ecoNP} yields an object of class \code{summary.ecoNP} containing the following elements: \item{call}{The call from \code{ecoNP}.} \item{n.obs}{The number of units.} \item{n.draws}{The number of Monte Carlo samples.} \item{agg.table}{Aggregate posterior estimates of the marginal means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If \code{param = TRUE}, the following elements are also included: \item{param.table}{Posterior estimates of model parameters: population mean estimates of \eqn{W_1} and \eqn{W_2}. If \code{subset} is specified, only a subset of the population parameters are included.} If \code{unit = TRUE}, the following elements are also included: \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} This object can be printed by \code{print.summary.ecoNP} } \description{ \code{summary} method for class \code{ecoNP}. } \seealso{ \code{ecoNP}, \code{predict.eco} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/print.summary.eco.Rd0000644000175100001440000000335513104457061015504 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print.summary.eco.R \name{print.summary.eco} \alias{print.summary.eco} \title{Print the Summary of the Results for the Bayesian Parametric Model for Ecological Inference in 2x2 Tables} \usage{ \method{print}{summary.eco}(x, digits = max(3, getOption("digits") - 3), ...) } \arguments{ \item{x}{An object of class \code{summary.eco}.} \item{digits}{the number of significant digits to use when printing.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{summary.eco} yields an object of class \code{summary.eco} containing the following elements: \item{call}{The call from \code{eco}.} \item{n.obs}{The number of units.} \item{n.draws}{The number of Monte Carlo samples.} \item{agg.table}{Aggregate posterior estimates of the marginal means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If \code{param = TRUE}, the following elements are also included: \item{param.table}{Posterior estimates of model parameters: population mean estimates of \eqn{W_1} and \eqn{W_2} and their logit transformations.} If \code{units = TRUE}, the following elements are also included: \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} This object can be printed by \code{print.summary.eco} } \description{ \code{summary} method for class \code{eco}. } \seealso{ \code{eco}, \code{predict.eco} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/ecoML.Rd0000644000175100001440000002733613104457061013113 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/emeco.R \name{ecoML} \alias{ecoML} \title{Fitting Parametric Models and Quantifying Missing Information for Ecological Inference in 2x2 Tables} \usage{ ecoML(formula, data = parent.frame(), N = NULL, supplement = NULL, theta.start = c(0, 0, 1, 1, 0), fix.rho = FALSE, context = FALSE, sem = TRUE, epsilon = 10^(-6), maxit = 1000, loglik = TRUE, hyptest = FALSE, verbose = FALSE) } \arguments{ \item{formula}{A symbolic description of the model to be fit, specifying the column and row margins of \eqn{2 \times 2} ecological tables. \code{Y ~ X} specifies \code{Y} as the column margin (e.g., turnout) and \code{X} (e.g., percent African-American) as the row margin. Details and specific examples are given below.} \item{data}{An optional data frame in which to interpret the variables in \code{formula}. The default is the environment in which \code{ecoML} is called.} \item{N}{An optional variable representing the size of the unit; e.g., the total number of voters. \code{N} needs to be a vector of same length as \code{Y} and \code{X} or a scalar.} \item{supplement}{An optional matrix of supplemental data. The matrix has two columns, which contain additional individual-level data such as survey data for \eqn{W_1} and \eqn{W_2}, respectively. If \code{NULL}, no additional individual-level data are included in the model. The default is \code{NULL}.} \item{theta.start}{A numeric vector that specifies the starting values for the mean, variance, and covariance. When \code{context = FALSE}, the elements of \code{theta.start} correspond to (\eqn{E(W_1)}, \eqn{E(W_2)}, \eqn{var(W_1)}, \eqn{var(W_2)}, \eqn{cor(W_1,W_2)}). When \code{context = TRUE}, the elements of \code{theta.start} correspond to (\eqn{E(W_1)}, \eqn{E(W_2)}, \eqn{var(W_1)}, \eqn{var(W_2)}, \eqn{corr(W_1, X)}, \eqn{corr(W_2, X)}, \eqn{corr(W_1,W_2)}). Moreover, when \code{fix.rho=TRUE}, \eqn{corr(W_1,W_2)} is set to be the correlation between \eqn{W_1} and \eqn{W_2} when \code{context = FALSE}, and the partial correlation between \eqn{W_1} and \eqn{W_2} given \eqn{X} when \code{context = FALSE}. The default is \code{c(0,0,1,1,0)}.} \item{fix.rho}{Logical. If \code{TRUE}, the correlation (when \code{context=TRUE}) or the partial correlation (when \code{context=FALSE}) between \eqn{W_1} and \eqn{W_2} is fixed through the estimation. For details, see Imai, Lu and Strauss(2006). The default is \code{FALSE}.} \item{context}{Logical. If \code{TRUE}, the contextual effect is also modeled. In this case, the row margin (i.e., X) and the individual-level rates (i.e., \eqn{W_1} and \eqn{W_2}) are assumed to be distributed tri-variate normally (after logit transformations). See Imai, Lu and Strauss (2006) for details. The default is \code{FALSE}.} \item{sem}{Logical. If \code{TRUE}, the standard errors of parameter estimates are estimated via SEM algorithm, as well as the fraction of missing data. The default is \code{TRUE}.} \item{epsilon}{A positive number that specifies the convergence criterion for EM algorithm. The square root of \code{epsilon} is the convergence criterion for SEM algorithm. The default is \code{10^(-6)}.} \item{maxit}{A positive integer specifies the maximum number of iterations before the convergence criterion is met. The default is \code{1000}.} \item{loglik}{Logical. If \code{TRUE}, the value of the log-likelihood function at each iteration of EM is saved. The default is \code{TRUE}.} \item{hyptest}{Logical. If \code{TRUE}, model is estimated under the null hypothesis that means of \eqn{W1} and \eqn{W2} are the same. The default is \code{FALSE}.} \item{verbose}{Logical. If \code{TRUE}, the progress of the EM and SEM algorithms is printed to the screen. The default is \code{FALSE}.} } \value{ An object of class \code{ecoML} containing the following elements: \item{call}{The matched call.} \item{X}{The row margin, \eqn{X}.} \item{Y}{The column margin, \eqn{Y}.} \item{N}{The size of each table, \eqn{N}.} \item{context}{The assumption under which model is estimated. If \code{context = FALSE}, CAR assumption is adopted and no contextual effect is modeled. If \code{context = TRUE}, NCAR assumption is adopted, and contextual effect is modeled.} \item{sem}{Whether SEM algorithm is used to estimate the standard errors and observed information matrix for the parameter estimates.} \item{fix.rho}{Whether the correlation or the partial correlation between \eqn{W_1} an \eqn{W_2} is fixed in the estimation.} \item{r12}{If \code{fix.rho = TRUE}, the value that \eqn{corr(W_1, W_2)} is fixed to.} \item{epsilon}{The precision criterion for EM convergence. \eqn{\sqrt{\epsilon}} is the precision criterion for SEM convergence.} \item{theta.sem}{The ML estimates of \eqn{E(W_1)},\eqn{E(W_2)}, \eqn{var(W_1)},\eqn{var(W_2)}, and \eqn{cov(W_1,W_2)}. If \code{context = TRUE}, \eqn{E(X)},\eqn{cov(W_1,X)}, \eqn{cov(W_2,X)} are also reported.} \item{W}{In-sample estimation of \eqn{W_1} and \eqn{W_2}.} \item{suff.stat}{The sufficient statistics for \code{theta.em}.} \item{iters.em}{Number of EM iterations before convergence is achieved.} \item{iters.sem}{Number of SEM iterations before convergence is achieved.} \item{loglik}{The log-likelihood of the model when convergence is achieved.} \item{loglik.log.em}{A vector saving the value of the log-likelihood function at each iteration of the EM algorithm.} \item{mu.log.em}{A matrix saving the unweighted mean estimation of the logit-transformed individual-level proportions (i.e., \eqn{W_1} and \eqn{W_2}) at each iteration of the EM process.} \item{Sigma.log.em}{A matrix saving the log of the variance estimation of the logit-transformed individual-level proportions (i.e., \eqn{W_1} and \eqn{W_2}) at each iteration of EM process. Note, non-transformed variances are displayed on the screen (when \code{verbose = TRUE}).} \item{rho.fisher.em}{A matrix saving the fisher transformation of the estimation of the correlations between the logit-transformed individual-level proportions (i.e., \eqn{W_1} and \eqn{W_2}) at each iteration of EM process. Note, non-transformed correlations are displayed on the screen (when \code{verbose = TRUE}).} Moreover, when \code{sem=TRUE}, \code{ecoML} also output the following values: \item{DM}{The matrix characterizing the rates of convergence of the EM algorithms. Such information is also used to calculate the observed-data information matrix} \item{Icom}{The (expected) complete data information matrix estimated via SEM algorithm. When \code{context=FALSE, fix.rho=TRUE}, \code{Icom} is 4 by 4. When \code{context=FALSE, fix.rho=FALSE}, \code{Icom} is 5 by 5. When \code{context=TRUE}, \code{Icom} is 9 by 9.} \item{Iobs}{The observed information matrix. The dimension of \code{Iobs} is same as \code{Icom}.} \item{Imiss}{The difference between \code{Icom} and \code{Iobs}. The dimension of \code{Imiss} is same as \code{miss}.} \item{Vobs}{The (symmetrized) variance-covariance matrix of the ML parameter estimates. The dimension of \code{Vobs} is same as \code{Icom}.} \item{Iobs}{The (expected) complete-data variance-covariance matrix. The dimension of \code{Iobs} is same as \code{Icom}.} \item{Vobs.original}{The estimated variance-covariance matrix of the ML parameter estimates. The dimension of \code{Vobs} is same as \code{Icom}.} \item{Fmis}{The fraction of missing information associated with each parameter estimation. } \item{VFmis}{The proportion of increased variance associated with each parameter estimation due to observed data. } \item{Ieigen}{The largest eigen value of \code{Imiss}.} \item{Icom.trans}{The complete data information matrix for the fisher transformed parameters.} \item{Iobs.trans}{The observed data information matrix for the fisher transformed parameters.} \item{Fmis.trans}{The fractions of missing information associated with the fisher transformed parameters.} } \description{ \code{ecoML} is used to fit parametric models for ecological inference in \eqn{2 \times 2} tables via Expectation Maximization (EM) algorithms. The data is specified in proportions. At it's most basic setting, the algorithm assumes that the individual-level proportions (i.e., \eqn{W_1} and \eqn{W_2}) and distributed bivariate normally (after logit transformations). The function calculates point estimates of the parameters for models based on different assumptions. The standard errors of the point estimates are also computed via Supplemented EM algorithms. Moreover, \code{ecoML} quantifies the amount of missing information associated with each parameter and allows researcher to examine the impact of missing information on parameter estimation in ecological inference. The models and algorithms are described in Imai, Lu and Strauss (2008, 2011). } \details{ When \code{SEM} is \code{TRUE}, \code{ecoML} computes the observed-data information matrix for the parameters of interest based on Supplemented-EM algorithm. The inverse of the observed-data information matrix can be used to estimate the variance-covariance matrix for the parameters estimated from EM algorithms. In addition, it also computes the expected complete-data information matrix. Based on these two measures, one can further calculate the fraction of missing information associated with each parameter. See Imai, Lu and Strauss (2006) for more details about fraction of missing information. Moreover, when \code{hytest=TRUE}, \code{ecoML} allows to estimate the parametric model under the null hypothesis that \code{mu_1=mu_2}. One can then construct the likelihood ratio test to assess the hypothesis of equal means. The associated fraction of missing information for the test statistic can be also calculated. For details, see Imai, Lu and Strauss (2006) for details. } \examples{ ## load the census data data(census) ## NOTE: convergence has not been properly assessed for the following ## examples. See Imai, Lu and Strauss (2006) for more complete analyses. ## In the first example below, in the interest of time, only part of the ## data set is analyzed and the convergence requirement is less stringent ## than the default setting. ## In the second example, the program is arbitrarily halted 100 iterations ## into the simulation, before convergence. ## load the Robinson's census data data(census) ## fit the parametric model with the default model specifications \dontrun{res <- ecoML(Y ~ X, data = census[1:100,], N=census[1:100,3], epsilon=10^(-6), verbose = TRUE)} ## summarize the results \dontrun{summary(res)} ## obtain out-of-sample prediction \dontrun{out <- predict(res, verbose = TRUE)} ## summarize the results \dontrun{summary(out)} ## fit the parametric model with some individual ## level data using the default prior specification surv <- 1:600 \dontrun{res1 <- ecoML(Y ~ X, context = TRUE, data = census[-surv,], supplement = census[surv,c(4:5,1)], maxit=100, verbose = TRUE)} ## summarize the results \dontrun{summary(res1)} } \references{ Imai, Kosuke, Ying Lu and Aaron Strauss. (2011). \dQuote{eco: R Package for Ecological Inference in 2x2 Tables} Journal of Statistical Software, Vol. 42, No. 5, pp. 1-23. available at \url{http://imai.princeton.edu/software/eco.html} Imai, Kosuke, Ying Lu and Aaron Strauss. (2008). \dQuote{Bayesian and Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data Approach} Political Analysis, Vol. 16, No. 1 (Winter), pp. 41-69. available at \url{http://imai.princeton.edu/research/eiall.html} } \seealso{ \code{eco}, \code{ecoNP}, \code{summary.ecoML} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University, \email{ying.lu@nyu.Edu}; Aaron Strauss, Department of Politics, Princeton University, \email{abstraus@Princeton.Edu}. } \keyword{models} eco/man/forgnlit30c.Rd0000644000175100001440000000247613104457061014244 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/forgnlit30c.R \docType{data} \name{forgnlit30c} \alias{forgnlit30c} \title{Foreign-born literacy in 1930, County Level} \format{A data frame containing 6 variables and 1976 observations \tabular{lll}{ X \tab numeric \tab proportion of the white population at least 10 years of age that is foreign born \cr Y \tab numeric \tab proportion of the white population at least 10 years of age that is illiterate \cr W1 \tab numeric \tab proportion of the foreign-born white population at least 10 years of age that is illiterate \cr W2 \tab numeric \tab proportion of the native-born white population at least 10 years of age that is illiterate \cr state \tab numeric \tab the ICPSR state code \cr county \tab numeric \tab the ICPSR (within state) county code }} \description{ This data set contains, on a county level, the proportion of white residents ten years and older who are foreign born, and the proportion of those residents who are literate. Data come from the 1930 census and were first analyzed by Robinson (1950). Counties with fewer than 100 foreign born residents are dropped. } \references{ Robinson, W.S. (1950). ``Ecological Correlations and the Behavior of Individuals.'' \emph{American Sociological Review}, vol. 15, pp.351-357. } \keyword{datasets} eco/man/reg.Rd0000644000175100001440000000211013104457061012650 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reg.R \docType{data} \name{reg} \alias{reg} \title{Voter Registration in US Southern States} \format{A data frame containing 5 variables and 275 observations \tabular{lll}{ X \tab numeric \tab the fraction of Black voters \cr Y \tab numeric \tab the fraction of voters who registered themselves\cr N \tab numeric \tab the total number of voters in each county \cr W1 \tab numeric \tab the actual fraction of Black voters who registered themselves \cr W2 \tab numeric \tab the actual fraction of White voters who registered themselves }} \description{ This data set contains the racial composition, the registration rate, the number of eligible voters as well as the actual observed racial registration rates for every county in four US southern states: Florida, Louisiana, North Carolina, and South Carolina. } \references{ King, G. (1997). \dQuote{A Solution to the Ecological Inference Problem: Reconstructing Individual Behavior from Aggregate Data}. Princeton University Press, Princeton, NJ. } \keyword{datasets} eco/man/eco.Rd0000644000175100001440000002173013104457061012652 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/eco.R \name{eco} \alias{eco} \title{Fitting the Parametric Bayesian Model of Ecological Inference in 2x2 Tables} \usage{ eco(formula, data = parent.frame(), N = NULL, supplement = NULL, context = FALSE, mu0 = 0, tau0 = 2, nu0 = 4, S0 = 10, mu.start = 0, Sigma.start = 10, parameter = TRUE, grid = FALSE, n.draws = 5000, burnin = 0, thin = 0, verbose = FALSE) } \arguments{ \item{formula}{A symbolic description of the model to be fit, specifying the column and row margins of \eqn{2 \times 2} ecological tables. \code{Y ~ X} specifies \code{Y} as the column margin (e.g., turnout) and \code{X} as the row margin (e.g., percent African-American). Details and specific examples are given below.} \item{data}{An optional data frame in which to interpret the variables in \code{formula}. The default is the environment in which \code{eco} is called.} \item{N}{An optional variable representing the size of the unit; e.g., the total number of voters. \code{N} needs to be a vector of same length as \code{Y} and \code{X} or a scalar.} \item{supplement}{An optional matrix of supplemental data. The matrix has two columns, which contain additional individual-level data such as survey data for \eqn{W_1} and \eqn{W_2}, respectively. If \code{NULL}, no additional individual-level data are included in the model. The default is \code{NULL}.} \item{context}{Logical. If \code{TRUE}, the contextual effect is also modeled, that is to assume the row margin \eqn{X} and the unknown \eqn{W_1} and \eqn{W_2} are correlated. See Imai, Lu and Strauss (2008, 2011) for details. The default is \code{FALSE}.} \item{mu0}{A scalar or a numeric vector that specifies the prior mean for the mean parameter \eqn{\mu} for \eqn{(W_1,W_2)} (or for \eqn{(W_1, W_2, X)} if \code{context=TRUE}). When the input of \code{mu0} is a scalar, its value will be repeated to yield a vector of the length of \eqn{\mu}, otherwise, it needs to be a vector of same length as \eqn{\mu}. When \code{context=TRUE}, the length of \eqn{\mu} is 3, otherwise it is 2. The default is \code{0}.} \item{tau0}{A positive integer representing the scale parameter of the Normal-Inverse Wishart prior for the mean and variance parameter \eqn{(\mu, \Sigma)}. The default is \code{2}.} \item{nu0}{A positive integer representing the prior degrees of freedom of the Normal-Inverse Wishart prior for the mean and variance parameter \eqn{(\mu, \Sigma)}. The default is \code{4}.} \item{S0}{A positive scalar or a positive definite matrix that specifies the prior scale matrix of the Normal-Inverse Wishart prior for the mean and variance parameter \eqn{(\mu, \Sigma)} . If it is a scalar, then the prior scale matrix will be a diagonal matrix with the same dimensions as \eqn{\Sigma} and the diagonal elements all take value of \code{S0}, otherwise \code{S0} needs to have same dimensions as \eqn{\Sigma}. When \code{context=TRUE}, \eqn{\Sigma} is a \eqn{3 \times 3} matrix, otherwise, it is \eqn{2 \times 2}. The default is \code{10}.} \item{mu.start}{A scalar or a numeric vector that specifies the starting values of the mean parameter \eqn{\mu}. If it is a scalar, then its value will be repeated to yield a vector of the length of \eqn{\mu}, otherwise, it needs to be a vector of same length as \eqn{\mu}. When \code{context=FALSE}, the length of \eqn{\mu} is 2, otherwise it is 3. The default is \code{0}.} \item{Sigma.start}{A scalar or a positive definite matrix that specified the starting value of the variance matrix \eqn{\Sigma}. If it is a scalar, then the prior scale matrix will be a diagonal matrix with the same dimensions as \eqn{\Sigma} and the diagonal elements all take value of \code{S0}, otherwise \code{S0} needs to have same dimensions as \eqn{\Sigma}. When \code{context=TRUE}, \eqn{\Sigma} is a \eqn{3 \times 3} matrix, otherwise, it is \eqn{2 \times 2}. The default is \code{10}.} \item{parameter}{Logical. If \code{TRUE}, the Gibbs draws of the population parameters, \eqn{\mu} and \eqn{\Sigma}, are returned in addition to the in-sample predictions of the missing internal cells, \eqn{W}. The default is \code{TRUE}.} \item{grid}{Logical. If \code{TRUE}, the grid method is used to sample \eqn{W} in the Gibbs sampler. If \code{FALSE}, the Metropolis algorithm is used where candidate draws are sampled from the uniform distribution on the tomography line for each unit. Note that the grid method is significantly slower than the Metropolis algorithm. The default is \code{FALSE}.} \item{n.draws}{A positive integer. The number of MCMC draws. The default is \code{5000}.} \item{burnin}{A positive integer. The burnin interval for the Markov chain; i.e. the number of initial draws that should not be stored. The default is \code{0}.} \item{thin}{A positive integer. The thinning interval for the Markov chain; i.e. the number of Gibbs draws between the recorded values that are skipped. The default is \code{0}.} \item{verbose}{Logical. If \code{TRUE}, the progress of the Gibbs sampler is printed to the screen. The default is \code{FALSE}.} } \value{ An object of class \code{eco} containing the following elements: \item{call}{The matched call.} \item{X}{The row margin, \eqn{X}.} \item{Y}{The column margin, \eqn{Y}.} \item{N}{The size of each table, \eqn{N}.} \item{burnin}{The number of initial burnin draws.} \item{thin}{The thinning interval.} \item{nu0}{The prior degrees of freedom.} \item{tau0}{The prior scale parameter.} \item{mu0}{The prior mean.} \item{S0}{The prior scale matrix.} \item{W}{A three dimensional array storing the posterior in-sample predictions of \eqn{W}. The first dimension indexes the Monte Carlo draws, the second dimension indexes the columns of the table, and the third dimension represents the observations.} \item{Wmin}{A numeric matrix storing the lower bounds of \eqn{W}.} \item{Wmax}{A numeric matrix storing the upper bounds of \eqn{W}.} The following additional elements are included in the output when \code{parameter = TRUE}. \item{mu}{The posterior draws of the population mean parameter, \eqn{\mu}.} \item{Sigma}{The posterior draws of the population variance matrix, \eqn{\Sigma}.} } \description{ \code{eco} is used to fit the parametric Bayesian model (based on a Normal/Inverse-Wishart prior) for ecological inference in \eqn{2 \times 2} tables via Markov chain Monte Carlo. It gives the in-sample predictions as well as the estimates of the model parameters. The model and algorithm are described in Imai, Lu and Strauss (2008, 2011). } \details{ An example of \eqn{2 \times 2} ecological table for racial voting is given below: \tabular{llccc}{ \tab \tab black voters \tab white voters \tab \cr \tab vote \tab \eqn{W_{1i}} \tab \eqn{W_{2i}} \tab \eqn{Y_i} \cr \tab not vote \tab \eqn{1-W_{1i}} \tab \eqn{1-W_{2i}} \tab \eqn{1-Y_i} \cr \tab \tab \eqn{X_i} \tab \eqn{1-X_i} \tab } where \eqn{Y_i} and \eqn{X_i} represent the observed margins, and \eqn{W_1} and \eqn{W_2} are unknown variables. In this exmaple, \eqn{Y_i} is the turnout rate in the ith precint, \eqn{X_i} is the proproption of African American in the ith precinct. The unknowns \eqn{W_{1i}} an d\eqn{W_{2i}} are the black and white turnout, respectively. All variables are proportions and hence bounded between 0 and 1. For each \eqn{i}, the following deterministic relationship holds, \eqn{Y_i=X_i W_{1i}+(1-X_i)W_{2i}}. } \examples{ ## load the registration data \dontrun{data(reg) ## NOTE: convergence has not been properly assessed for the following ## examples. See Imai, Lu and Strauss (2008, 2011) for more ## complete analyses. ## fit the parametric model with the default prior specification res <- eco(Y ~ X, data = reg, verbose = TRUE) ## summarize the results summary(res) ## obtain out-of-sample prediction out <- predict(res, verbose = TRUE) ## summarize the results summary(out) ## load the Robinson's census data data(census) ## fit the parametric model with contextual effects and N ## using the default prior specification res1 <- eco(Y ~ X, N = N, context = TRUE, data = census, verbose = TRUE) ## summarize the results summary(res1) ## obtain out-of-sample prediction out1 <- predict(res1, verbose = TRUE) ## summarize the results summary(out1) } } \references{ Imai, Kosuke, Ying Lu and Aaron Strauss. (2011). \dQuote{eco: R Package for Ecological Inference in 2x2 Tables} Journal of Statistical Software, Vol. 42, No. 5, pp. 1-23. available at \url{http://imai.princeton.edu/software/eco.html} Imai, Kosuke, Ying Lu and Aaron Strauss. (2008). \dQuote{Bayesian and Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data Approach} Political Analysis, Vol. 16, No. 1 (Winter), pp. 41-69. available at \url{http://imai.princeton.edu/research/eiall.html} } \seealso{ \code{ecoML}, \code{ecoNP}, \code{predict.eco}, \code{summary.eco} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu,Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University, \email{ying.lu@nyu.Edu} } \keyword{models} eco/man/census.Rd0000644000175100001440000000253413104457061013405 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/census.R \docType{data} \name{census} \alias{census} \title{Black Illiteracy Rates in 1910 US Census} \format{A data frame containing 5 variables and 1040 observations \tabular{lll}{ X \tab numeric \tab the proportion of Black residents in each county\cr Y \tab numeric \tab the overall literacy rates in each county\cr N \tab numeric \tab the total number of residents in each county \cr W1 \tab numeric \tab the actual Black literacy rate \cr W2 \tab numeric \tab the actual White literacy rate }} \description{ This data set contains the proportion of the residents who are black, the proportion of those who can read, the total population as well as the actual black literacy rate and white literacy rate for 1040 counties in the US. The dataset was originally analyzed by Robinson (1950) at the state level. King (1997) recoded the 1910 census at county level. The data set only includes those who are older than 10 years of age. } \references{ Robinson, W.S. (1950). ``Ecological Correlations and the Behavior of Individuals.'' \emph{American Sociological Review}, vol. 15, pp.351-357. \cr \cr King, G. (1997). \dQuote{A Solution to the Ecological Inference Problem: Reconstructing Individual Behavior from Aggregate Data}. Princeton University Press, Princeton, NJ. } \keyword{datasets} eco/man/forgnlit30.Rd0000644000175100001440000000224713104457061014075 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/forgnlit30.R \docType{data} \name{forgnlit30} \alias{forgnlit30} \title{Foreign-born literacy in 1930} \format{A data frame containing 5 variables and 48 observations \tabular{lll}{ X \tab numeric \tab proportion of the white population at least 10 years of age that is foreign born \cr Y \tab numeric \tab proportion of the white population at least 10 years of age that is illiterate \cr W1 \tab numeric \tab proportion of the foreign-born white population at least 10 years of age that is illiterate \cr W2 \tab numeric \tab proportion of the native-born white population at least 10 years of age that is illiterate \cr ICPSR \tab numeric \tab the ICPSR state code }} \description{ This data set contains, on a state level, the proportion of white residents ten years and older who are foreign born, and the proportion of those residents who are literate. Data come from the 1930 census and were first analyzed by Robinson (1950). } \references{ Robinson, W.S. (1950). ``Ecological Correlations and the Behavior of Individuals.'' \emph{American Sociological Review}, vol. 15, pp.351-357. } \keyword{datasets} eco/man/predict.ecoNPX.Rd0000644000175100001440000000626413104457061014676 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.ecoNPX.R \name{predict.ecoNPX} \alias{predict.ecoNPX} \title{Out-of-Sample Posterior Prediction under the Nonparametric Bayesian Model for Ecological Inference in 2x2 Tables} \usage{ \method{predict}{ecoNPX}(object, newdraw = NULL, subset = NULL, obs = NULL, cond = FALSE, verbose = FALSE, ...) } \arguments{ \item{object}{An output object from \code{ecoNP}.} \item{newdraw}{An optional list containing two matrices (or three dimensional arrays for the nonparametric model) of MCMC draws of \eqn{\mu} and \eqn{\Sigma}. Those elements should be named as \code{mu} and \code{Sigma}, respectively. The default is the original MCMC draws stored in \code{object}.} \item{subset}{A scalar or numerical vector specifying the row number(s) of \code{mu} and \code{Sigma} in the output object from \code{eco}. If specified, the posterior draws of parameters for those rows are used for posterior prediction. The default is \code{NULL} where all the posterior draws are used.} \item{obs}{An integer or vector of integers specifying the observation number(s) whose posterior draws will be used for predictions. The default is \code{NULL} where all the observations in the data set are selected.} \item{cond}{logical. If \code{TRUE}, then the conditional prediction will made for the parametric model with contextual effects. The default is \code{FALSE}.} \item{verbose}{logical. If \code{TRUE}, helpful messages along with a progress report on the Monte Carlo sampling from the posterior predictive distributions are printed on the screen. The default is \code{FALSE}.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{predict.eco} yields a matrix of class \code{predict.eco} containing the Monte Carlo sample from the posterior predictive distribution of inner cells of ecological tables. \code{summary.predict.eco} will summarize the output, and \code{print.summary.predict.eco} will print the summary. } \description{ Obtains out-of-sample posterior predictions under the fitted nonparametric Bayesian model for ecological inference. \code{predict} method for class \code{ecoNP} and \code{ecoNPX}. } \details{ The posterior predictive values are computed using the Monte Carlo sample stored in the \code{eco} or \code{ecoNP} output (or other sample if \code{newdraw} is specified). Given each Monte Carlo sample of the parameters, we sample the vector-valued latent variable from the appropriate multivariate Normal distribution. Then, we apply the inverse logit transformation to obtain the predictive values of proportions, \eqn{W}. The computation may be slow (especially for the nonparametric model) if a large Monte Carlo sample of the model parameters is used. In either case, setting \code{verbose = TRUE} may be helpful in monitoring the progress of the code. } \seealso{ \code{eco}, \code{ecoNP}, \code{summary.eco}, \code{summary.ecoNP} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/summary.eco.Rd0000644000175100001440000000460313104457061014346 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.eco.R \name{summary.eco} \alias{summary.eco} \alias{print.eco} \title{Summarizing the Results for the Bayesian Parametric Model for Ecological Inference in 2x2 Tables} \usage{ \method{summary}{eco}(object, CI = c(2.5, 97.5), param = TRUE, units = FALSE, subset = NULL, ...) } \arguments{ \item{object}{An output object from \code{eco}.} \item{CI}{A vector of lower and upper bounds for the Bayesian credible intervals used to summarize the results. The default is the equal tail 95 percent credible interval.} \item{param}{Logical. If \code{TRUE}, the posterior estimates of the population parameters will be provided. The default value is \code{TRUE}.} \item{units}{Logical. If \code{TRUE}, the in-sample predictions for each unit or for a subset of units will be provided. The default value is \code{FALSE}.} \item{subset}{A numeric vector indicating the subset of the units whose in-sample predications to be provided when \code{units} is \code{TRUE}. The default value is \code{NULL} where the in-sample predictions for each unit will be provided.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{summary.eco} yields an object of class \code{summary.eco} containing the following elements: \item{call}{The call from \code{eco}.} \item{n.obs}{The number of units.} \item{n.draws}{The number of Monte Carlo samples.} \item{agg.table}{Aggregate posterior estimates of the marginal means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If \code{param = TRUE}, the following elements are also included: \item{param.table}{Posterior estimates of model parameters: population mean estimates of \eqn{W_1} and \eqn{W_2} and their logit transformations.} If \code{units = TRUE}, the following elements are also included: \item{W1.table}{Unit-level posterior estimates for \eqn{W_1}.} \item{W2.table}{Unit-level posterior estimates for \eqn{W_2}.} This object can be printed by \code{print.summary.eco} } \description{ \code{summary} method for class \code{eco}. } \seealso{ \code{eco}, \code{predict.eco} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{methods} eco/man/summary.ecoML.Rd0000644000175100001440000000634713104457061014606 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary.ecoML.R \name{summary.ecoML} \alias{summary.ecoML} \title{Summarizing the Results for the Maximum Likelihood Parametric Model for Ecological Inference in 2x2 Tables} \usage{ \method{summary}{ecoML}(object, CI = c(2.5, 97.5), param = TRUE, units = FALSE, subset = NULL, ...) } \arguments{ \item{object}{An output object from \code{eco}.} \item{CI}{A vector of lower and upper bounds for the Bayesian credible intervals used to summarize the results. The default is the equal tail 95 percent credible interval.} \item{param}{Ignored.} \item{units}{Logical. If \code{TRUE}, the in-sample predictions for each unit or for a subset of units will be provided. The default value is \code{FALSE}.} \item{subset}{A numeric vector indicating the subset of the units whose in-sample predications to be provided when \code{units} is \code{TRUE}. The default value is \code{NULL} where the in-sample predictions for each unit will be provided.} \item{...}{further arguments passed to or from other methods.} } \value{ \code{summary.eco} yields an object of class \code{summary.eco} containing the following elements: \item{call}{The call from \code{eco}.} \item{sem}{Whether the SEM algorithm was executed, as specified by the user upon calling \code{ecoML}.} \item{fix.rho}{Whether the correlation parameter was fixed or allowed to vary, as specified by the user upon calling \code{ecoML}.} \item{epsilon}{The convergence threshold specified by the user upon calling \code{ecoML}.} \item{n.obs}{The number of units.} \item{iters.em}{The number iterations the EM algorithm cycled through before convergence or reaching the maximum number of iterations allowed.} \item{iters.sem}{The number iterations the SEM algorithm cycled through before convergence or reaching the maximum number of iterations allowed.} \item{loglik}{The final observed log-likelihood.} \item{rho}{A matrix of \code{iters.em} rows specifying the correlation parameters at each iteration of the EM algorithm. The number of columns depends on how many correlation parameters exist in the model. Column order is the same as the order of the parameters in \code{param.table}.} \item{param.table}{Final estimates of the parameter values for the model. Excludes parameters fixed by the user upon calling \code{ecoML}. See \code{ecoML} documentation for order of parameters.} \item{agg.table}{Aggregate estimates of the marginal means of \eqn{W_1} and \eqn{W_2}} \item{agg.wtable}{Aggregate estimates of the marginal means of \eqn{W_1} and \eqn{W_2} using \eqn{X} and \eqn{N} as weights.} If \code{units = TRUE}, the following elements are also included: \item{W.table}{Unit-level estimates for \eqn{W_1} and \eqn{W_2}.} This object can be printed by \code{print.summary.eco} } \description{ \code{summary} method for class \code{eco}. } \seealso{ \code{ecoML} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu}; Aaron Strauss, Department of Politics, Princeton University, \email{abstraus@Princeton.Edu} } \keyword{methods} eco/man/wallace.Rd0000644000175100001440000000234113104457061013511 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/wallace.R \docType{data} \name{wallace} \alias{wallace} \title{Black voting rates for Wallace for President, 1968} \format{A data frame containing 3 variables and 1009 observations \tabular{lll}{ X \tab numeric \tab proportion of the population that is Black \cr Y \tab numeric \tab proportion presidential votes cast for Wallace \cr FIPS \tab numeric \tab the FIPS county code }} \description{ This data set contains, on a county level, the proportion of county residents who are Black and the proportion of presidential votes cast for Wallace. Demographic data is based on the 1960 census. Presidential returns are from ICPSR study 13. County data from 10 southern states (Alabama, Arkansas, Georgia, Florida, Louisiana, Mississippi, North Carolina, South Carolina, Tennessee, Texas) are included. (Virginia is excluded due to the difficulty of matching counties between the datasets.) This data is analyzed in Wallace and Segal (1973). } \references{ Wasserman, Ira M. and David R. Segal (1973). ``Aggregation Effects in the Ecological Study of Presidential Voting.'' American Journal of Political Science. vol. 17, pp. 177-81. } \keyword{datasets} eco/man/ecoNP.Rd0000644000175100001440000002140513104457061013107 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ecoNP.R \name{ecoNP} \alias{ecoNP} \title{Fitting the Nonparametric Bayesian Models of Ecological Inference in 2x2 Tables} \usage{ ecoNP(formula, data = parent.frame(), N = NULL, supplement = NULL, context = FALSE, mu0 = 0, tau0 = 2, nu0 = 4, S0 = 10, alpha = NULL, a0 = 1, b0 = 0.1, parameter = FALSE, grid = FALSE, n.draws = 5000, burnin = 0, thin = 0, verbose = FALSE) } \arguments{ \item{formula}{A symbolic description of the model to be fit, specifying the column and row margins of \eqn{2 \times 2} ecological tables. \code{Y ~ X} specifies \code{Y} as the column margin (e.g., turnout) and \code{X} as the row margin (e.g., percent African-American). Details and specific examples are given below.} \item{data}{An optional data frame in which to interpret the variables in \code{formula}. The default is the environment in which \code{ecoNP} is called.} \item{N}{An optional variable representing the size of the unit; e.g., the total number of voters. \code{N} needs to be a vector of same length as \code{Y} and \code{X} or a scalar.} \item{supplement}{An optional matrix of supplemental data. The matrix has two columns, which contain additional individual-level data such as survey data for \eqn{W_1} and \eqn{W_2}, respectively. If \code{NULL}, no additional individual-level data are included in the model. The default is \code{NULL}.} \item{context}{Logical. If \code{TRUE}, the contextual effect is also modeled, that is to assume the row margin \eqn{X} and the unknown \eqn{W_1} and \eqn{W_2} are correlated. See Imai, Lu and Strauss (2008, 2011) for details. The default is \code{FALSE}.} \item{mu0}{A scalar or a numeric vector that specifies the prior mean for the mean parameter \eqn{\mu} of the base prior distribution \eqn{G_0} (see Imai, Lu and Strauss (2008, 2011) for detailed descriptions of Dirichlete prior and the normal base prior distribution) . If it is a scalar, then its value will be repeated to yield a vector of the length of \eqn{\mu}, otherwise, it needs to be a vector of same length as \eqn{\mu}. When \code{context=TRUE }, the length of \eqn{\mu} is 3, otherwise it is 2. The default is \code{0}.} \item{tau0}{A positive integer representing the scale parameter of the Normal-Inverse Wishart prior for the mean and variance parameter \eqn{(\mu_i, \Sigma_i)} of each observation. The default is \code{2}.} \item{nu0}{A positive integer representing the prior degrees of freedom of the variance matrix \eqn{\Sigma_i}. the default is \code{4}.} \item{S0}{A positive scalar or a positive definite matrix that specifies the prior scale matrix for the variance matrix \eqn{\Sigma_i}. If it is a scalar, then the prior scale matrix will be a diagonal matrix with the same dimensions as \eqn{\Sigma_i} and the diagonal elements all take value of \code{S0}, otherwise \code{S0} needs to have same dimensions as \eqn{\Sigma_i}. When \code{context=TRUE}, \eqn{\Sigma} is a \eqn{3 \times 3} matrix, otherwise, it is \eqn{2 \times 2}. The default is \code{10}.} \item{alpha}{A positive scalar representing a user-specified fixed value of the concentration parameter, \eqn{\alpha}. If \code{NULL}, \eqn{\alpha} will be updated at each Gibbs draw, and its prior parameters \code{a0} and \code{b0} need to be specified. The default is \code{NULL}.} \item{a0}{A positive integer representing the value of shape parameter of the gamma prior distribution for \eqn{\alpha}. The default is \code{1}.} \item{b0}{A positive integer representing the value of the scale parameter of the gamma prior distribution for \eqn{\alpha}. The default is \code{0.1}.} \item{parameter}{Logical. If \code{TRUE}, the Gibbs draws of the population parameters, \eqn{\mu} and \eqn{\Sigma}, are returned in addition to the in-sample predictions of the missing internal cells, \eqn{W}. The default is \code{FALSE}. This needs to be set to \code{TRUE} if one wishes to make population inferences through \code{predict.eco}. See an example below.} \item{grid}{Logical. If \code{TRUE}, the grid method is used to sample \eqn{W} in the Gibbs sampler. If \code{FALSE}, the Metropolis algorithm is used where candidate draws are sampled from the uniform distribution on the tomography line for each unit. Note that the grid method is significantly slower than the Metropolis algorithm.} \item{n.draws}{A positive integer. The number of MCMC draws. The default is \code{5000}.} \item{burnin}{A positive integer. The burnin interval for the Markov chain; i.e. the number of initial draws that should not be stored. The default is \code{0}.} \item{thin}{A positive integer. The thinning interval for the Markov chain; i.e. the number of Gibbs draws between the recorded values that are skipped. The default is \code{0}.} \item{verbose}{Logical. If \code{TRUE}, the progress of the Gibbs sampler is printed to the screen. The default is \code{FALSE}.} } \value{ An object of class \code{ecoNP} containing the following elements: \item{call}{The matched call.} \item{X}{The row margin, \eqn{X}.} \item{Y}{The column margin, \eqn{Y}.} \item{burnin}{The number of initial burnin draws.} \item{thin}{The thinning interval.} \item{nu0}{The prior degrees of freedom.} \item{tau0}{The prior scale parameter.} \item{mu0}{The prior mean.} \item{S0}{The prior scale matrix.} \item{a0}{The prior shape parameter.} \item{b0}{The prior scale parameter.} \item{W}{A three dimensional array storing the posterior in-sample predictions of \eqn{W}. The first dimension indexes the Monte Carlo draws, the second dimension indexes the columns of the table, and the third dimension represents the observations.} \item{Wmin}{A numeric matrix storing the lower bounds of \eqn{W}.} \item{Wmax}{A numeric matrix storing the upper bounds of \eqn{W}.} The following additional elements are included in the output when \code{parameter = TRUE}. \item{mu}{A three dimensional array storing the posterior draws of the population mean parameter, \eqn{\mu}. The first dimension indexes the Monte Carlo draws, the second dimension indexes the columns of the table, and the third dimension represents the observations.} \item{Sigma}{A three dimensional array storing the posterior draws of the population variance matrix, \eqn{\Sigma}. The first dimension indexes the Monte Carlo draws, the second dimension indexes the parameters, and the third dimension represents the observations. } \item{alpha}{The posterior draws of \eqn{\alpha}.} \item{nstar}{The number of clusters at each Gibbs draw.} } \description{ \code{ecoNP} is used to fit the nonparametric Bayesian model (based on a Dirichlet process prior) for ecological inference in \eqn{2 \times 2} tables via Markov chain Monte Carlo. It gives the in-sample predictions as well as out-of-sample predictions for population inference. The models and algorithms are described in Imai, Lu and Strauss (2008, 2011). } \examples{ ## load the registration data data(reg) ## NOTE: We set the number of MCMC draws to be a very small number in ## the following examples; i.e., convergence has not been properly ## assessed. See Imai, Lu and Strauss (2006) for more complete examples. ## fit the nonparametric model to give in-sample predictions ## store the parameters to make population inference later \dontrun{res <- ecoNP(Y ~ X, data = reg, n.draws = 50, param = TRUE, verbose = TRUE) ##summarize the results summary(res) ## obtain out-of-sample prediction out <- predict(res, verbose = TRUE) ## summarize the results summary(out) ## density plots of the out-of-sample predictions par(mfrow=c(2,1)) plot(density(out[,1]), main = "W1") plot(density(out[,2]), main = "W2") ## load the Robinson's census data data(census) ## fit the parametric model with contextual effects and N ## using the default prior specification res1 <- ecoNP(Y ~ X, N = N, context = TRUE, param = TRUE, data = census, n.draws = 25, verbose = TRUE) ## summarize the results summary(res1) ## out-of sample prediction pres1 <- predict(res1) summary(pres1)} } \references{ Imai, Kosuke, Ying Lu and Aaron Strauss. (2011). \dQuote{eco: R Package for Ecological Inference in 2x2 Tables} Journal of Statistical Software, Vol. 42, No. 5, pp. 1-23. available at \url{http://imai.princeton.edu/software/eco.html} Imai, Kosuke, Ying Lu and Aaron Strauss. (2008). \dQuote{Bayesian and Likelihood Inference for 2 x 2 Ecological Tables: An Incomplete Data Approach} Political Analysis, Vol. 16, No. 1 (Winter), pp. 41-69. available at \url{http://imai.princeton.edu/research/eiall.html} } \seealso{ \code{eco}, \code{ecoML}, \code{predict.eco}, \code{summary.ecoNP} } \author{ Kosuke Imai, Department of Politics, Princeton University, \email{kimai@Princeton.Edu}, \url{http://imai.princeton.edu}; Ying Lu, Center for Promoting Research Involving Innovative Statistical Methodology (PRIISM), New York University \email{ying.lu@nyu.Edu} } \keyword{models}