R version 3.4.0 (2017-04-21) -- "You Stupid Darkness"
Copyright (C) 2017 The R Foundation for Statistical Computing
Platform: x86_64-apple-darwin15.6.0 (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.
R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.
Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
> ##
> ## Calibration examples
> ##
>
>
> ## Example of calibration to first-stage clusters
> library(survey)
Loading required package: grid
Loading required package: Matrix
Loading required package: survival
Attaching package: 'survey'
The following object is masked from 'package:graphics':
dotchart
> data(api)
>
> clusters<-table(apiclus2$dnum)
> clusters<-clusters[clusters>1 & names(clusters)!="639"]
> apiclus2a<-subset(apiclus2, dnum %in% as.numeric(names(clusters)))
>
> dclus2<-svydesign(id=~dnum+snum, fpc=~fpc1+fpc2, data=apiclus2a)
>
> popclusters<-subset(apipop, dnum %in% as.numeric(names(clusters)))
>
> pop<-lapply(as.numeric(names(clusters)), function(cluster) {
+ colSums(model.matrix(~api99, model.frame(~api99, subset(popclusters, dnum %in% cluster))))})
>
> names(pop)<-names(clusters)
>
> dclus2g<-calibrate(dclus2, ~api99, pop,stage=1)
>
> svymean(~api99, dclus2)
mean SE
api99 642.14 31.434
> svymean(~api99, dclus2g)
mean SE
api99 654.49 29.82
>
> round(svyby(~api99, ~dnum, design=dclus2, svymean),4)
dnum api99 se
83 83 694.3333 0.0000
132 132 505.0000 0.0000
152 152 574.0000 0.0000
173 173 894.7500 0.0000
198 198 533.7500 0.0000
200 200 589.8000 6.8335
228 228 477.0000 0.0000
295 295 646.4000 0.0000
302 302 903.5000 0.0000
403 403 852.4000 0.0000
452 452 533.0000 0.0000
480 480 614.2000 0.0000
523 523 580.5000 0.0000
534 534 564.6000 0.0000
549 549 896.2000 0.0000
552 552 730.0000 0.0000
570 570 518.4000 7.5478
575 575 800.8000 4.2513
596 596 785.6000 2.4155
620 620 591.6000 10.5869
638 638 560.2000 4.0954
674 674 760.0000 0.0000
679 679 610.2500 0.0000
687 687 718.6667 0.0000
701 701 651.5000 0.0000
711 711 690.5000 0.0000
731 731 702.0000 2.1744
768 768 562.5000 0.0000
781 781 854.4000 0.7456
>
> round(svyby(~api99, ~dnum, design=dclus2g, svymean),4)
dnum api99 se
83 83 694.3333 0
132 132 505.0000 0
152 152 574.0000 0
173 173 894.7500 0
198 198 533.7500 0
200 200 567.5455 0
228 228 477.0000 0
295 295 646.4000 0
302 302 903.5000 0
403 403 852.4000 0
452 452 533.0000 0
480 480 614.2000 0
523 523 580.5000 0
534 534 564.6000 0
549 549 896.2000 0
552 552 730.0000 0
570 570 548.9444 0
575 575 824.5357 0
596 596 787.5714 0
620 620 609.3750 0
638 638 585.6429 0
674 674 760.0000 0
679 679 610.2500 0
687 687 718.6667 0
701 701 651.5000 0
711 711 690.5000 0
731 731 700.6667 0
768 768 562.5000 0
781 781 851.0000 0
>
> ## Averaging to first stage
>
> dclus1<- svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)
> pop<-colSums(cbind(1,apipop$enroll),na.rm=TRUE)
>
> dclus1g<-calibrate(dclus1, ~enroll, pop, aggregate=1)
>
> svytotal(~enroll,dclus1g)
total SE
enroll 3811472 0
> svytotal(~api.stu,dclus1g)
total SE
api.stu 3242857 38967
>
> #variation within clusters should be zero
> all.equal(0, max(ave(weights(dclus1g),dclus1g$cluster,FUN=var),na.rm=TRUE))
[1] TRUE
>
> ##bounded weights
> dclus1g<-calibrate(dclus1, ~enroll, pop)
> range(weights(dclus1g)/weights(dclus1))
[1] 0.7906782 1.7891164
> dclus1gb<-calibrate(dclus1, ~enroll, pop, bounds=c(.6,1.5))
> range(weights(dclus1gb)/weights(dclus1))
[1] 0.7198751 1.5000000
>
> ## Ratio estimators
> dstrat<-svydesign(id=~1,strata=~stype, weights=~pw, data=apistrat, fpc=~fpc)
> svytotal(~api.stu,dstrat)
total SE
api.stu 3086009 99477
> common<-svyratio(~api.stu, ~enroll, dstrat, separate=FALSE)
> total.enroll<-sum(apipop$enroll,na.rm=TRUE)
> predict(common, total=total.enroll)
$total
enroll
api.stu 3190038
$se
enroll
api.stu 29565.98
> dstratg<-calibrate(dstrat,~enroll-1, total.enroll, variance=1)
> svytotal(~api.stu, dstratg)
total SE
api.stu 3190038 29566
>
> ## postStratify vs calibrate in stratified sample (Ben French)
> set.seed(17)
> dat<-data.frame(y=rep(0:1,each=100),x=rnorm(200)+2*rep(0:1,each=100),
+ z=rbinom(200,1,.2), fpc=rep(c(100,10000),each=100))
> dat$w<-ifelse(dat$y,dat$z,1-dat$z)
> popw<-data.frame(w=c("0","1"), Freq=c(2000,8000))
> des<-svydesign(id=~1,fpc=~fpc, data=dat,strata=~y)
> postStratify(des,~w,popw)->dps
> dcal<-calibrate(des,~factor(w), pop=c(10000,8000))
>
> all.equal(SE(svymean(~x,dcal)),SE(svymean(~x,dps)))
[1] TRUE
>
> ## missing data in calibrated design
> dps$variables$z[1]<-NA
> summary(svyglm(y~z+x,design=dps,family=quasibinomial))
Call:
svyglm(formula = y ~ z + x, design = dps, family = quasibinomial)
Survey design:
postStratify(des, ~w, popw)
Coefficients:
Estimate Std. Error t value Pr(>|t|)
(Intercept) -0.1203 0.3380 -0.356 0.722
z 6.2118 0.6451 9.630 <2e-16 ***
x 2.2602 0.2514 8.992 <2e-16 ***
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
(Dispersion parameter for quasibinomial family taken to be 1.919987)
Number of Fisher Scoring iterations: 9
>
> ## Ratio estimator using the heteroskedasticity parameter (Daniel Oehm)
> # should match the ratio estmate above
> dstratgh <- calibrate(dstrat,~enroll-1, total.enroll, variance=apistrat$enroll)
> svytotal(~api.stu, dstratgh)
total SE
api.stu 3190038 29566
>
> ## individual boundary constraints as multiplicative values (Daniel Oehm)
> bnds <- list(
+ lower = c(1, 1, rep(-Inf, nrow(apistrat)-2)),
+ upper = c(1, 1, rep(Inf, nrow(apistrat)-2))) # the first two weights will remain unchanged the others are free to move
> lapply(bnds, head)
$lower
[1] 1 1 -Inf -Inf -Inf -Inf
$upper
[1] 1 1 Inf Inf Inf Inf
> dstratg1<-calibrate(dstrat, ~enroll-1, total.enroll, bounds = bnds, variance=apistrat$enroll)
> svytotal(~api.stu, dstratg1)
total SE
api.stu 3190133 29561
> head(weights(dstrat))
1 2 3 4 5 6
44.21 44.21 44.21 44.21 44.21 44.21
> head(weights(dstratg1))
1 2 3 4 5 6
44.21000 44.21000 45.72055 45.72055 45.72055 45.72055
> all.equal(weights(dstrat)[1:2], weights(dstratg1)[1:2])
[1] TRUE
>
> ## individual boundary constraints as constant values (Daniel Oehm)
> bnds <- list(
+ lower = c(44.21, 44.21, rep(-Inf, nrow(apistrat)-2)),
+ upper = c(44.21, 44.21, rep(Inf, nrow(apistrat)-2))) # the first two weights will remain unchanged
> lapply(bnds, head)
$lower
[1] 44.21 44.21 -Inf -Inf -Inf -Inf
$upper
[1] 44.21 44.21 Inf Inf Inf Inf
> dstratg2<-calibrate(dstrat, ~enroll-1, total.enroll, bounds = bnds, bounds.const = TRUE, variance=apistrat$enroll)
> svytotal(~api.stu, dstratg2)
total SE
api.stu 3190133 29561
> head(weights(dstrat))
1 2 3 4 5 6
44.21 44.21 44.21 44.21 44.21 44.21
> head(weights(dstratg2))
1 2 3 4 5 6
44.21000 44.21000 45.72055 45.72055 45.72055 45.72055
> all.equal(round(weights(dstrat)[1:2], 8), round(weights(dstratg2)[1:2]), 8) # minor rounding error but all good
[1] TRUE
>
> # sparse matrix support (Daniel Oehm)
> dclus1<-svydesign(id=~dnum, weights=~pw, data=apiclus1, fpc=~fpc)
> pop.totals<-c(`(Intercept)`=6194, stypeH=755, stypeM=1018)
> dclus1g<-calibrate(dclus1, ~stype, pop.totals)
> svymean(~api00, dclus1g)
mean SE
api00 642.31 23.921
> svytotal(~enroll, dclus1g)
total SE
enroll 3680893 406293
>
> pop.totals<-c(`(Intercept)`=6194, stypeH=755, stypeM=1018)
> dclus1g<-calibrate(dclus1, ~stype, pop.totals, sparse = TRUE)
> svymean(~api00, dclus1g)
mean SE
api00 642.31 23.921
> svytotal(~enroll, dclus1g)
total SE
enroll 3680893 406293
>
> pop.totals<-c(`(Intercept)`=6194, stypeH=755, stypeM=1018)
> dclus1g<-calibrate(dclus1, ~stype, pop.totals, sparse = TRUE, calfun = "raking")
> svymean(~api00, dclus1g)
mean SE
api00 642.31 23.921
> svytotal(~enroll, dclus1g)
total SE
enroll 3680893 406293
>
> proc.time()
user system elapsed
2.591 0.084 2.712
Generated by dwww version 1.15 on Sun Jun 16 10:49:36 CEST 2024.