[r-cran-zelig] 20/102: Import Upstream version 2.5-3
Andreas Tille
tille at debian.org
Sun Jan 8 16:58:10 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-zelig.
commit 654d71e46b92fdafd45c24371cbb37707b5b7ed4
Author: Andreas Tille <tille at debian.org>
Date: Sun Jan 8 09:39:03 2017 +0100
Import Upstream version 2.5-3
---
DESCRIPTION | 8 +-
R/ate/sate.R | 53 ++++++++++
R/categories.R | 8 +-
R/current.packages.R | 33 ++++--
R/describe.exp.R | 2 +-
R/describe.factor.bayes.R | 10 +-
R/describe.factor.mix.R | 4 +-
R/describe.factor.ord.R | 4 +-
R/describe.gamma.R | 2 +-
R/describe.irt1d.R | 2 +-
R/describe.irtkd.R | 2 +-
R/describe.lognorm.R | 2 +-
R/describe.negbin.R | 2 +-
R/describe.normal.R | 2 +-
R/describe.normal.bayes.R | 2 +-
R/describe.poisson.R | 2 +-
R/describe.poisson.bayes.R | 4 +-
R/{describe.normal.bayes.R => describe.tobit.R} | 10 +-
R/describe.tobit.bayes.R | 2 +-
R/describe.weibull.R | 2 +-
R/model.frame.multiple.R | 30 ++----
R/model.matrix.multiple.R | 28 ++---
R/multipleUtil.R | 51 +++++++++
R/qi.BetaReg.R | 4 +-
R/qi.MCMCZelig.R | 16 +--
R/qi.glm.R | 8 +-
R/qi.lm.R | 4 +-
R/qi.polr.R | 12 +--
R/qi.relogit.R | 8 +-
R/qi.survreg.R | 8 +-
R/qi.vglm.R | 14 +--
R/setx.default.R | 52 ++++-----
R/summary.zelig.strata.R | 2 +-
R/terms.multiple.R | 44 ++++++--
R/vdc.R | 134 +++++++++++++-----------
README | 3 +
demo/match.R | 88 ++++++++--------
37 files changed, 409 insertions(+), 253 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index d6ab540..15e71e2 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,13 +1,13 @@
Package: Zelig
-Version: 2.5-2
-Date: 2006-02-03
+Version: 2.5-3
+Date: 2006-03-09
Title: Zelig: Everyone's Statistical Software
Author: Kosuke Imai <kimai at Princeton.Edu>,
Gary King <king at harvard.edu>,
Olivia Lau <olau at fas.harvard.edu>
Maintainer: Olivia Lau <olau at fas.harvard.edu>
Depends: R (>= 2.0.0), MASS, boot
-Suggests: VGAM, mvtnorm, survival, sandwich (>= 1.1-0), zoo (>= 1.0-4), MCMCpack, coda
+Suggests: VGAM (>= 0.6-7), mvtnorm, survival, sandwich (>= 1.1-0), zoo (>= 1.0-4), MCMCpack, coda
Description: Zelig is an easy-to-use program that can estimate, and
help interpret the results of, an enormous range of
statistical models. It literally is ``everyone's statistical
@@ -23,4 +23,4 @@ Description: Zelig is an easy-to-use program that can estimate, and
translates them into quantities of direct interest.
License: GPL version 2 or newer
URL: http://gking.harvard.edu/zelig
-Packaged: Sat Feb 4 17:52:31 2006; olau
+Packaged: Fri Mar 10 09:45:44 2006; olau
diff --git a/R/ate/sate.R b/R/ate/sate.R
new file mode 100644
index 0000000..c495dc3
--- /dev/null
+++ b/R/ate/sate.R
@@ -0,0 +1,53 @@
+sate <- function(formula, model, treat, data, sims, zARGS = NULL, sARGS = NULL) {
+ tmp <- as.formula(paste(deparse(formula[[2]]), deparse(formula[[1]]),
+ paste(treat, "+", deparse(formula[[3]]))))
+ D <- model.frame(tmp, data = data)
+ idx <- names(model.frame(formula, data = D))
+ if (treat %in% idx)
+ one.reg <- TRUE
+ else
+ one.reg <- FALSE
+ tname <- treat
+ treat <- D[[treat]]
+ check <- unique(treat)
+ if (length(na.omit(check)) > 2)
+ stop("Treatment indicator must be binary.")
+ treat <- as.numeric(as.factor(treat))
+ if (!all(unique(treat) %in% c(0,1))) {
+ treat[treat == min(treat)] <- 0
+ treat[treat == max(treat)] <- 1
+ }
+ if (one.reg) {
+ z.out <- zelig(formula, data = D, model = model, ... = zARGS)
+ x.out <- setx(z.out, fn = NULL, cond = TRUE)
+ tidx <- match(tname, colnames(x.out))
+ x.out[, tidx] <- 1 - x.out[, tidx]
+ x.all <- x.out[, 2:ncol(x.out)]
+ x.all <- as.data.frame(x.all)
+ s.out <- sim(z.out, x = x.all[, 2:nrow(x.all)], num = sims, ... = sARGS)
+ pr.all <- matrix(as.numeric(s.out$qi$pr), nrow = sims, ncol = nrow(x.all))
+### replace with model.response
+ y.all <- matrix(x.out[,1], nrow = sims, ncol nrow(x.out), byrow = TRUE)
+ te.all <- y.all - pr.all
+ te.all[, treat == 0] <- -1 * te.all[, treat == 0]
+ s.out$qi <- s.out$qi.name <- NULL
+ s.out$qi <- list(sate = apply(te.all, 1, mean),
+ satt = apply(te.all[, treat == 1], 1, mean))
+ s.out$qi.name <- list(sate = "Sample Average Treatment Effect for Everyone: E[Y(1)-Y(0)]",
+ satt = "Sample Average Treatment Effect for Treated: E[Yobs(1) - Ymiss(1)]")
+ return(s.out)
+ }
+ else {
+ z0 <- zelig(formula, data = D[treat == 0,], model = model, ... = zARGS)
+ z1 <- zelig(formula, data = D[treat == 1,], model = model, ... = zARGS)
+ x0 <- setx(z0, fn = NULL, cond = TRUE)
+ x1 <- setx(z1, fn = NULL, cond = TRUE)
+ tidx <- match(tname, colnames(x0))
+ x0[, tidx] <- 1 - x0[, tidx]
+ x1[, tidx] <- 1 - x1[, tidx]
+ y0 <-
+
+ s0 <- sim(z0, x = x0, num = round(sims / 2), ... = sARGS)
+ s1 <- sim(z1, x = x1, num = round(sims / 2), ... = sARGS)
+ pr.all <- rbind(s0$qi$pr, s1$qi$pr)
+ y.all <-
diff --git a/R/categories.R b/R/categories.R
index b1f80f0..6f76b3b 100644
--- a/R/categories.R
+++ b/R/categories.R
@@ -1,9 +1,9 @@
categories <-function(){
-list(continuous="Regression Models for Continous Dependent Variables",
+list(continuous="Models for Continous Dependent Variables",
dichotomous="Models for Dichotomous Dependent Variables",
ordinal="Models for Ordinal Dependent Variables",
- bivariate.dichotomous="Models for pairs of Dichotomous Dependent Variables",
+ bounded="Models for Continous Bounded Dependent Variables",
multinomial="Multinomial Choice Models",
- event.count="Event Count Models",
- censored="Models for Censored (and Duration) Variables")
+ count="Event Count Models",
+ mixed="Models for Mixed Dependent Variables")
}
diff --git a/R/current.packages.R b/R/current.packages.R
index e820aaa..1a6d57f 100644
--- a/R/current.packages.R
+++ b/R/current.packages.R
@@ -7,15 +7,22 @@ current.packages <- function(package){
if (!is.null(depends)) {
depends <- strsplit(depends, ", ")[[1]]
Rdepends <- pmatch("R (", depends)
- if (is.na(Rdepends))
+ if (is.na(Rdepends)) {
Rdepends <- pmatch("R(", depends)
+ if (is.na(Rdepends))
+ Rdepends <- match("R", depends)
+ }
if (!is.na(Rdepends))
- depends <- depends[-pmatch("R (", depends)]
+ depends <- depends[-Rdepends]
}
suggests <- description$Suggests
if (!is.null(suggests))
suggests <- strsplit(suggests, ", ")[[1]]
total <- c(depends, suggests)
+ if (!is.null(total))
+ total <- unlist(strsplit(total, "\n"))
+ if (!is.null(total))
+ total <- unlist(strsplit(total, ","))
if (!is.null(total)) {
conditions <- grep(")", total)
if (length(conditions) > 0) {
@@ -29,16 +36,24 @@ current.packages <- function(package){
}
old <- packages <- required.packages(package)
- for (zpack in packages) {
- new <- required.packages(zpack)
- tmp <- new[!(new %in% old)]
- old <- packages <- c(packages, tmp)
+ check.start <- 1
+ check.end <- length(packages)-1
+ while(check.end < length(packages)) {
+ check.end <- length(packages)
+ for (i in check.start:check.end)
+ packages <- c(packages, required.packages(packages[i]))
+ check.start <- check.end+1
+ packages <- na.omit(unique(packages))
}
ver <- array()
- for (zpack in na.omit(packages)) {
- mylib <- dirname(system.file(package = zpack))
- ver[zpack] <- packageDescription(zpack, lib = mylib)$Ver
+ for (i in 1:length(packages)) {
+ mylib <- dirname(system.file(package = packages[i]))
+ if (sum(!is.na(packageDescription(packages[i], lib = mylib))))
+ ver[i] <- packageDescription(packages[i], lib = mylib)$Ver
+ else
+ stop()
+ names(ver)[i] <- packages[i]
}
ver[1] <- paste(paste(paste(R.Version()$major, R.Version()$minor, sep = "."),
R.Version()$status, sep = " "),
diff --git a/R/describe.exp.R b/R/describe.exp.R
index 0421b39..1bf95b8 100644
--- a/R/describe.exp.R
+++ b/R/describe.exp.R
@@ -1,5 +1,5 @@
describe.exp<-function(){
-category <- "censored"
+category <- "bounded"
description <- "Exponential Regression for Duration Dependent Variables"
package <-list( name ="survival",
version ="2.0",
diff --git a/R/describe.factor.bayes.R b/R/describe.factor.bayes.R
index 2d925ae..44aa637 100644
--- a/R/describe.factor.bayes.R
+++ b/R/describe.factor.bayes.R
@@ -1,14 +1,16 @@
describe.factor.bayes<-function(){
-category <- "censored"
+category <- "continuous"
description <- "Bayesian Factor Analysis"
package <-list( name ="MCMCpack",
version ="0.6"
)
parameters<-list(mu="mu")
parameters$mu<-list(equations=c(1,1),
- tagsAllowed=FALSE,
- depVar=TRUE,
- expVar=TRUE,
+ tagsAllowed=FALSE,
+ depVar=TRUE,
+ expVar=FALSE,
+ specialFunction="cbind",
+ varInSpecialFunction=c(3,Inf)
)
list(category=category,description=description,package=package,parameters=parameters)
diff --git a/R/describe.factor.mix.R b/R/describe.factor.mix.R
index b605f93..5d1d13c 100644
--- a/R/describe.factor.mix.R
+++ b/R/describe.factor.mix.R
@@ -1,5 +1,5 @@
describe.factor.mix<-function(){
-category <- "censored"
+category <- "mixed"
description <- "Mixed Data Factor Analysis"
package <-list( name ="MCMCpack",
version ="0.6"
@@ -10,7 +10,7 @@ parameters$mu<-list(equations=c(1,1),
depVar=TRUE,
expVar=FALSE,
specialFunction="cbind",
- varInSpecialFunction=c(1,Inf)
+ varInSpecialFunction=c(2,Inf)
)
list(category=category,description=description,package=package,parameters=parameters)
diff --git a/R/describe.factor.ord.R b/R/describe.factor.ord.R
index a84885c..fcfacf1 100644
--- a/R/describe.factor.ord.R
+++ b/R/describe.factor.ord.R
@@ -1,5 +1,5 @@
describe.factor.ord<-function(){
-category <- "censored"
+category <- "ordinal"
description <- "Ordinal Data Factor Analysis"
package <-list( name ="MCMCpack",
version ="0.6"
@@ -10,7 +10,7 @@ parameters$mu<-list(equations=c(1,1),
depVar=TRUE,
expVar=FALSE,
specialFunction="cbind",
- varInSpecialFunction=c(1,Inf)
+ varInSpecialFunction=c(2,Inf)
)
list(category=category,description=description,package=package,parameters=parameters)
diff --git a/R/describe.gamma.R b/R/describe.gamma.R
index b7bb59c..da3814b 100644
--- a/R/describe.gamma.R
+++ b/R/describe.gamma.R
@@ -1,5 +1,5 @@
describe.gamma<-function(){
-category <- "continuous"
+category <- "bounded"
description <- "Gamma Regression for Continuous, Positive Dependent Variables"
package <-list( name ="stats",
version ="0.1"
diff --git a/R/describe.irt1d.R b/R/describe.irt1d.R
index c18711d..0fe0dfc 100644
--- a/R/describe.irt1d.R
+++ b/R/describe.irt1d.R
@@ -1,5 +1,5 @@
describe.factor.irt1d<-function(){
-category <- "censored"
+category <- "dichotomous"
description <- "One Dimensional Item Response Model"
package <-list( name ="MCMCpack",
version ="0.6"
diff --git a/R/describe.irtkd.R b/R/describe.irtkd.R
index cabfefd..30769ef 100644
--- a/R/describe.irtkd.R
+++ b/R/describe.irtkd.R
@@ -1,5 +1,5 @@
describe.irtkd<-function(){
-category <- "censored"
+category <- "dichotomous"
description <- "K-Dimensional Item Response Model"
package <-list( name ="MCMCpack",
version ="0.6"
diff --git a/R/describe.lognorm.R b/R/describe.lognorm.R
index 57d6e31..2690c02 100644
--- a/R/describe.lognorm.R
+++ b/R/describe.lognorm.R
@@ -1,5 +1,5 @@
describe.lognorm<-function(){
-category <- "censored"
+category <- "bounded"
description <- "Log-Normal Regression for Duration Dependent Variables"
package <-list( name ="survival",
version ="2.2"
diff --git a/R/describe.negbin.R b/R/describe.negbin.R
index b6c72b8..94a841b 100644
--- a/R/describe.negbin.R
+++ b/R/describe.negbin.R
@@ -1,5 +1,5 @@
describe.negbin<-function(){
-category <- "event.count"
+category <- "count"
description <- "Negative Binomial Regression for Event Count Dependent Variables"
package <-list( name ="MASS",
version ="0.1"
diff --git a/R/describe.normal.R b/R/describe.normal.R
index 112fcbc..aa703b8 100644
--- a/R/describe.normal.R
+++ b/R/describe.normal.R
@@ -1,5 +1,5 @@
describe.normal<-function(){
-category <- "countinuous"
+category <- "continuous"
description <- "Normal Regression for Continuous Dependent Variables"
package <-list( name ="stats",
version ="0.1"
diff --git a/R/describe.normal.bayes.R b/R/describe.normal.bayes.R
index e62cdfb..576b9de 100644
--- a/R/describe.normal.bayes.R
+++ b/R/describe.normal.bayes.R
@@ -1,5 +1,5 @@
describe.normal.bayes<-function(){
-category <- "countinuous"
+category <- "continuous"
description <- "Bayesian Normal Linear Regression"
package <-list( name ="MCMCpack",
version ="0.6"
diff --git a/R/describe.poisson.R b/R/describe.poisson.R
index 19e82e3..3f1a5ec 100644
--- a/R/describe.poisson.R
+++ b/R/describe.poisson.R
@@ -1,5 +1,5 @@
describe.poisson<-function(){
-category <- "event.count"
+category <- "count"
description <- "Poisson Regression for Event Count Dependent Variables"
package <-list( name ="stats",
version ="0.1"
diff --git a/R/describe.poisson.bayes.R b/R/describe.poisson.bayes.R
index d31b69e..6676e9e 100644
--- a/R/describe.poisson.bayes.R
+++ b/R/describe.poisson.bayes.R
@@ -1,6 +1,6 @@
describe.poisson.bayes<-function(){
-category <- "event.count"
-description <- "Ordinal Probit Regression for Ordered Categorical Dependent Variables"
+category <- "count"
+description <- "Bayesian Poisson Regression"
package <-list( name ="MCMCpack",
version ="0.6"
)
diff --git a/R/describe.normal.bayes.R b/R/describe.tobit.R
similarity index 55%
copy from R/describe.normal.bayes.R
copy to R/describe.tobit.R
index e62cdfb..cce9cdf 100644
--- a/R/describe.normal.bayes.R
+++ b/R/describe.tobit.R
@@ -1,8 +1,8 @@
-describe.normal.bayes<-function(){
-category <- "countinuous"
-description <- "Bayesian Normal Linear Regression"
-package <-list( name ="MCMCpack",
- version ="0.6"
+describe.tobit<-function(){
+category <- "continuous"
+description <- "Linear regression for Left-Censored Dependet Variable"
+package <-list( name ="survival",
+ version ="2.2"
)
parameters<-list(mu="mu")
parameters$mu<-list(equations=c(1,1),
diff --git a/R/describe.tobit.bayes.R b/R/describe.tobit.bayes.R
index 469d98f..f135fbe 100644
--- a/R/describe.tobit.bayes.R
+++ b/R/describe.tobit.bayes.R
@@ -1,5 +1,5 @@
describe.tobit.bayes<-function(){
-category <- "censored"
+category <- "continuous"
description <- "Bayesian Linear Regression for a Censored Dependent Variable"
package <-list( name ="MCMCpack",
version ="0.6"
diff --git a/R/describe.weibull.R b/R/describe.weibull.R
index f7a12f6..f6bd8ca 100644
--- a/R/describe.weibull.R
+++ b/R/describe.weibull.R
@@ -1,5 +1,5 @@
describe.weibull<-function(){
-category <- "censored"
+category <- "bounded"
description <- "Weibull Regression for Duration Dependent Variables"
package <-list( name ="survival",
version ="2.2"
diff --git a/R/model.frame.multiple.R b/R/model.frame.multiple.R
index 44b80a3..d83a8b3 100644
--- a/R/model.frame.multiple.R
+++ b/R/model.frame.multiple.R
@@ -4,25 +4,14 @@ model.frame.multiple <- function (formula,data,...){
}else{
terms<-terms(formula)
}
- # print(terms)
+
+ #is multilevel?
+ if(!(is.logical(attr(terms,"subs"))))
+ return (multilevel(terms,data,mode=2))
+
"%w/o%" <- function(x,y) x[!x %in% y]
- #print("model.frame.multiple is called")
- toBuildFormula<-function(Xnames,sepp="+"){
- lng<-length(Xnames)
- rhs<-NULL
- if (lng!=0){
- if(lng==1){
- rhs=Xnames
- }else{
- for (j in 1:(lng-1)){
- rhs<-paste(rhs,as.name(Xnames[[j]]))
- rhs<-paste(rhs,sepp)
- }
- rhs<-paste(rhs,Xnames[[lng]])
- }
- }
- return (rhs)
- }
+
+
eqn<-names(formula)
eqn<-attr(terms,"systEqns")
nrEquations<-length(eqn)
@@ -89,8 +78,6 @@ model.frame.multiple <- function (formula,data,...){
lhs=Ynames
}
lhs<-as.formula(paste(lhs,rhs))
-#print(lhs)
-#print(names(my.data.frame))
Y<-model.frame.default(lhs,data=my.data.frame)
result=Y
if(cb)
@@ -100,5 +87,8 @@ model.frame.multiple <- function (formula,data,...){
attr(result,"terms")<-terms
class(result)<-c(class(result),"multiple")
return(result)
+
}
+
+
diff --git a/R/model.matrix.multiple.R b/R/model.matrix.multiple.R
index 28e284e..ea1a341 100644
--- a/R/model.matrix.multiple.R
+++ b/R/model.matrix.multiple.R
@@ -1,24 +1,16 @@
model.matrix.multiple <- function (object,data,shape="compact",eqn=NULL,...){
intersect <- function(x, y) y[match(x, y, nomatch = 0)]
-
- toBuildFormula<-function(Xnames,sepp="+"){
- lng<-length(Xnames)
- rhs<-NULL
- if (lng!=0){
- if(lng==1){
- rhs=Xnames
- }else{
- for (j in 1:(lng-1)){
- rhs<-paste(rhs,as.name(Xnames[[j]]))
- rhs<-paste(rhs,sepp)
- }
- rhs<-paste(rhs,Xnames[[lng]])
- }
- }
- return (rhs)
+
+ #olny for multilevel
+ if(class(formula)[[1]]=="terms"){
+ terms <-object
+ }else{
+ terms<-terms(object)
}
-
+ if(!(is.logical(attr(terms,"subs"))))
+ return (multilevel(terms,data,mode=1))
+ ##
if((shape != "compact") && (shape != "array") && (shape !="stacked"))
stop("wrong shape argument! Choose from \"compact\", \"array\" or \"stacked\" \n")
@@ -31,6 +23,7 @@ model.matrix.multiple <- function (object,data,shape="compact",eqn=NULL,...){
terms<-attr(data,"terms")
+
whiche<-which(eqn %in% names(terms)==FALSE)
if (length(whiche)!=0)
stop("Unknown eqn name \"",eqn[whiche],"\"\n")
@@ -98,3 +91,4 @@ model.matrix.multiple <- function (object,data,shape="compact",eqn=NULL,...){
return(res)
}
+
diff --git a/R/multipleUtil.R b/R/multipleUtil.R
new file mode 100644
index 0000000..40a5b78
--- /dev/null
+++ b/R/multipleUtil.R
@@ -0,0 +1,51 @@
+ toBuildFormula<-function(Xnames,sepp="+"){
+ lng<-length(Xnames)
+ rhs<-NULL
+ if (lng!=0){
+ if(lng==1){
+ rhs=Xnames
+ }else{
+ for (j in 1:(lng-1)){
+ rhs<-paste(rhs,as.name(Xnames[[j]]))
+ rhs<-paste(rhs,sepp)
+ }
+ rhs<-paste(rhs,Xnames[[lng]])
+ }
+ }
+ return (rhs)
+ }
+
+#mode=1 model.matrix
+#mode=2 model.frame
+multilevel<-function(tt,data,mode,...){
+ if(!(mode %in% c(1,2)))
+ stop("Wrong mode argument")
+res<-list()
+ eqn<-attr(tt,"systEqns")
+ subs<-attr(tt,"subs")
+depVars<-attr(tt,"depVars")
+
+ nrEquations<-length(eqn)
+ termlabels<-attr(tt,"term.labels")
+for(i in 1:nrEquations){
+ rhs<-toBuildFormula(termlabels[[eqn[[i]]]],"+")
+ if(!is.null(rhs))
+ rhs<-paste("~",rhs)
+ else
+ rhs<-"~1"
+ Ynamei<-depVars[[eqn[[i]]]]
+ if(!(Ynamei %in% colnames(subs)))
+ lhs<-Ynamei
+ else
+ lhs<-NULL
+ f<-as.formula(paste(lhs,rhs))
+ if(mode==1)
+ res[[eqn[[i]]]]<-model.matrix.default(f,data[[eqn[[i]]]])
+ # res[[eqn[[i]]]]<-f
+ else
+ res[[eqn[[i]]]]<-model.frame.default(f,data[[eqn[[i]]]])
+ # res[[eqn[[i]]]]<-f
+}
+attr(res,"terms")<-tt
+return(res)
+}
diff --git a/R/qi.BetaReg.R b/R/qi.BetaReg.R
index 229fd14..340982b 100644
--- a/R/qi.BetaReg.R
+++ b/R/qi.BetaReg.R
@@ -22,8 +22,8 @@ qi.BetaReg <- function(object, simpar, x, x1 = NULL, y = NULL) {
if (!is.null(y)) {
yvar <- matrix(rep(y, nrow(simpar)), nrow = nrow(simpar), byrow = TRUE)
tmp.ev <- yvar - qi$ev
- qi$ate.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
+ qi$att.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
}
list(qi=qi, qi.name=qi.name)
}
diff --git a/R/qi.MCMCZelig.R b/R/qi.MCMCZelig.R
index 4b887d0..81624d7 100644
--- a/R/qi.MCMCZelig.R
+++ b/R/qi.MCMCZelig.R
@@ -120,11 +120,11 @@ qi.MCMCZelig <- function(object, simpar=NULL, x, x1 = NULL, y = NULL, ...) {
tmp.pr <- yvar - as.integer(qi$pr)
else
tmp.pr <- yvar - qi$pr
- qi$ate.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
+ qi$att.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
if (model %in% c("logit", "probit", "poisson")) {
- qi$ate.pr <- matrix(apply(tmp.pr, 1, mean), nrow = nrow(simpar))
- qi.name$ate.pr <- "Average Treatment Effect: Y - PR"
+ qi$att.pr <- matrix(apply(tmp.pr, 1, mean), nrow = nrow(simpar))
+ qi.name$att.pr <- "Average Treatment Effect for the Treated: Y - PR"
}
}
out <- list(qi=qi, qi.name=qi.name)
@@ -239,11 +239,11 @@ qi.MCMCZelig <- function(object, simpar=NULL, x, x1 = NULL, y = NULL, ...) {
}
tmp.ev <- yvar1 - qi$ev
tmp.pr <- yvar1 - pr1
- qi$ate.ev <- matrix(apply(tmp.ev, 2, rowMeans), nrow = nrow(simpar))
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
+ qi$att.ev <- matrix(apply(tmp.ev, 2, rowMeans), nrow = nrow(simpar))
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
if (model %in% c("oprobit.bayes", "mlogit.bayes", "normal.bayes")) {
- qi$ate.pr <- matrix(apply(tmp.pr, 2, rowMeans), nrow = nrow(simpar))
- qi.name$ate.pr <- "Average Treatment Effect: Y - PR"
+ qi$att.pr <- matrix(apply(tmp.pr, 2, rowMeans), nrow = nrow(simpar))
+ qi.name$att.pr <- "Average Treatment Effect for the Treated: Y - PR"
}
}
out <- list(qi=qi, qi.name=qi.name)
diff --git a/R/qi.glm.R b/R/qi.glm.R
index 7ad0d8e..119f4f0 100644
--- a/R/qi.glm.R
+++ b/R/qi.glm.R
@@ -59,10 +59,10 @@ qi.glm <- function(object, simpar, x, x1 = NULL, y = NULL) {
tmp.pr <- yvar - as.integer(qi$pr)
else
tmp.pr <- yvar - qi$pr
- qi$ate.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
- qi$ate.pr <- matrix(apply(tmp.pr, 1, mean), nrow = nrow(simpar))
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
- qi.name$ate.pr <- "Average Treatment Effect: Y - PR"
+ qi$att.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
+ qi$att.pr <- matrix(apply(tmp.pr, 1, mean), nrow = nrow(simpar))
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
+ qi.name$att.pr <- "Average Treatment Effect for the Treated: Y - PR"
}
list(qi=qi, qi.name=qi.name)
}
diff --git a/R/qi.lm.R b/R/qi.lm.R
index 0b29a3b..2e23f43 100644
--- a/R/qi.lm.R
+++ b/R/qi.lm.R
@@ -14,8 +14,8 @@ qi.lm <- function(object, simpar, x, x1 = NULL, y = NULL) {
if (!is.null(y)) {
yvar <- matrix(rep(y, nrow(simpar)), nrow = nrow(simpar), byrow = TRUE)
tmp.ev <- yvar - qi$ev
- qi$ate.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
+ qi$att.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
}
list(qi=qi, qi.name=qi.name)
}
diff --git a/R/qi.polr.R b/R/qi.polr.R
index d6a13e9..331631a 100644
--- a/R/qi.polr.R
+++ b/R/qi.polr.R
@@ -42,7 +42,7 @@ qi.polr <- function(object, simpar, x, x1 = NULL, y = NULL) {
yvar <- matrix(NA, nrow = length(y), ncol = length(lev))
tmp.ev <- tmp.pr <- array(NA, dim = dim(qi$ev))
pr.idx <- array(NA, dim = c(nrow(pr), length(lev), nrow(x)))
- qi$ate.ev <- qi$ate.pr <- matrix(NA, dim(qi$ev)[1], dim(qi$ev)[2])
+ qi$att.ev <- qi$att.pr <- matrix(NA, dim(qi$ev)[1], dim(qi$ev)[2])
for (i in 1:length(lev)) {
yvar[,i] <- as.integer(y == lev[i])
pr.idx[,i,] <- as.integer(pr[,i] == lev[i])
@@ -51,12 +51,12 @@ qi.polr <- function(object, simpar, x, x1 = NULL, y = NULL) {
for (j in 1:ncol(yvar)) {
tmp.ev[,j,] <- yvar[,j] - qi$ev[,j,]
tmp.pr[,j,] <- yvar[,j] - pr.idx[,j,]
- qi$ate.ev[,j] <- apply(tmp.ev[,j,], 1, mean)
- qi$ate.pr[,j] <- apply(tmp.pr[,j,], 1, mean)
+ qi$att.ev[,j] <- apply(tmp.ev[,j,], 1, mean)
+ qi$att.pr[,j] <- apply(tmp.pr[,j,], 1, mean)
}
- colnames(qi$ate.ev) <- colnames(qi$ate.pr) <- lev
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
- qi.name$ate.pr <- "Average Treatment Effect: Y - PR"
+ colnames(qi$att.ev) <- colnames(qi$att.pr) <- lev
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
+ qi.name$att.pr <- "Average Treatment Effect for the Treated: Y - PR"
}
list(qi=qi, qi.name=qi.name)
}
diff --git a/R/qi.relogit.R b/R/qi.relogit.R
index 9cc4324..922f72b 100644
--- a/R/qi.relogit.R
+++ b/R/qi.relogit.R
@@ -63,10 +63,10 @@ qi.relogit <- function(object, simpar, x, x1 = NULL, y = NULL) {
yvar <- matrix(rep(y, num), nrow = num, byrow = TRUE)
tmp.ev <- yvar - qi$ev
tmp.pr <- yvar - as.integer(qi$pr)
- qi$ate.ev <- matrix(apply(tmp.ev, 1, mean), nrow = num)
- qi$ate.pr <- matrix(apply(tmp.pr, 1, mean), nrow = num)
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
- qi.name$ate.pr <- "Average Treatment Effect: Y - PR"
+ qi$att.ev <- matrix(apply(tmp.ev, 1, mean), nrow = num)
+ qi$att.pr <- matrix(apply(tmp.pr, 1, mean), nrow = num)
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
+ qi.name$att.pr <- "Average Treatment Effect for the Treated: Y - PR"
}
return(list(qi = qi, qi.name = qi.name))
}
diff --git a/R/qi.survreg.R b/R/qi.survreg.R
index 26a9b1e..f5c142e 100644
--- a/R/qi.survreg.R
+++ b/R/qi.survreg.R
@@ -94,10 +94,10 @@ qi.survreg <- function(object, simpar, x, x1 = NULL, y = NULL) {
yvar <- matrix(y, ncol = length(y), nrow = nrow(qi$ev), byrow = TRUE)
tmp.ev <- yvar - qi$ev
tmp.pr <- yvar - qi$pr
- qi$ate.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
- qi$ate.pr <- matrix(apply(tmp.pr, 1, mean), nrow = nrow(simpar))
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
- qi.name$ate.pr <- "Average Treatment Effect: Y - PR"
+ qi$att.ev <- matrix(apply(tmp.ev, 1, mean), nrow = nrow(simpar))
+ qi$att.pr <- matrix(apply(tmp.pr, 1, mean), nrow = nrow(simpar))
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
+ qi.name$att.pr <- "Average Treatment Effect for the Treated: Y - PR"
}
list(qi=qi, qi.name=qi.name)
}
diff --git a/R/qi.vglm.R b/R/qi.vglm.R
index fe223f8..d857bdd 100644
--- a/R/qi.vglm.R
+++ b/R/qi.vglm.R
@@ -148,7 +148,7 @@ qi.vglm <- function (object, simpar, x, x1=NULL, y = NULL) {
}
if (!is.null(y)) {
tmp.ev <- tmp.pr <- array(NA, dim = dim(qi$ev))
- qi$ate.ev <- qi$ate.pr <- matrix(NA, dim(qi$ev)[1], dim(qi$ev)[2])
+ qi$att.ev <- qi$att.pr <- matrix(NA, dim(qi$ev)[1], dim(qi$ev)[2])
if (model=="mlogit" || model=="oprobit") {
yvar <- matrix(NA, nrow = length(y), ncol = length(ynames))
pr.idx <- array(NA, dim = c(nrow(pr), length(ynames), nrow(x)))
@@ -156,7 +156,7 @@ qi.vglm <- function (object, simpar, x, x1=NULL, y = NULL) {
yvar[,i] <- as.integer(y == ynames[i])
pr.idx[,i,] <- as.integer(pr[,i] == ynames[i])
}
- colnames(qi$ate.ev) <- colnames(qi$ate.pr) <- ynames
+ colnames(qi$att.ev) <- colnames(qi$att.pr) <- ynames
}
else if (model=="blogit" || model=="bprobit") {
yvar <- matrix(NA, nrow = nrow(y), ncol = 4)
@@ -167,7 +167,7 @@ qi.vglm <- function (object, simpar, x, x1=NULL, y = NULL) {
pr.idx <- array(NA, dim = c(nrow(pr), 4, nrow(x)))
for (i in 1:4)
pr.idx[,i,] <- as.integer(pr[,i,])
- colnames(qi$ate.ev) <- colnames(qi$ate.pr) <-
+ colnames(qi$att.ev) <- colnames(qi$att.pr) <-
c("(Y1=0, Y2=0)", "(Y1=0, Y2=1)",
"(Y1=1, Y2=0)", "(Y1=1, Y2=1)")
}
@@ -176,11 +176,11 @@ qi.vglm <- function (object, simpar, x, x1=NULL, y = NULL) {
tmp.ev[i,j,] <- yvar[,j] - qi$ev[i,j,]
tmp.pr[i,j,] <- yvar[,j] - pr.idx[i,j,]
}
- qi$ate.ev[,j] <- apply(tmp.ev[,j,], 1, mean)
- qi$ate.pr[,j] <- apply(tmp.pr[,j,], 1, mean)
+ qi$att.ev[,j] <- apply(tmp.ev[,j,], 1, mean)
+ qi$att.pr[,j] <- apply(tmp.pr[,j,], 1, mean)
}
- qi.name$ate.ev <- "Average Treatment Effect: Y - EV"
- qi.name$ate.pr <- "Average Treatment Effect: Y - PR"
+ qi.name$att.ev <- "Average Treatment Effect for the Treated: Y - EV"
+ qi.name$att.pr <- "Average Treatment Effect for the Treated: Y - PR"
}
list(qi=qi, qi.name=qi.name)
}
diff --git a/R/setx.default.R b/R/setx.default.R
index 94d340d..68ea897 100644
--- a/R/setx.default.R
+++ b/R/setx.default.R
@@ -65,7 +65,7 @@ setx.default <- function(object, fn = list(numeric = mean, ordered =
dta <- as.data.frame(data)
## extract variables we need
mf <- model.frame(tt, data = dta, na.action = na.pass)
- vars <- all.vars(object$call)
+ vars <- all.vars(tt)
if (!is.null(tt.attr$response) && tt.attr$response)
resvars <- all.vars(tt.attr$variables[[1+tt.attr$response]])
else
@@ -108,8 +108,9 @@ setx.default <- function(object, fn = list(numeric = mean, ordered =
warning("when cond = TRUE, fn is coerced to NULL")
fn <- NULL
}
+ maxl <- nrow(data)
}
- else if (!is.null(fn)) {
+ else if (!is.null(fn)) {
if (is.null(fn$numeric) || !is.function(fn$numeric)) {
warning("fn$numeric coerced to mean().")
fn$numeric <- mean
@@ -140,30 +141,33 @@ setx.default <- function(object, fn = list(numeric = mean, ordered =
data[,i] <- value
}
}
- opt <- vars[na.omit(pmatch(names(mc), vars))]
maxl <- 1
- if (length(opt) > 0)
- for (i in 1:length(opt)) {
- value <- eval(mc[[opt[i]]], envir = env)
- lv <- length(value)
- if (lv>1)
- if (maxl==1 || maxl==lv) {
- maxl <- lv
- data <- data[1:lv,]
- }
- else
- stop("vector inputs should have the same length.")
- if (is.factor(data[,opt[i]]))
- data[,opt[i]] <- list(factor(value, levels=levels(data[,opt[i]])))
- else if (is.numeric(data[,opt[i]]))
- data[,opt[i]] <- list(as.numeric(value))
- else if (is.logical(data[,opt[i]]))
- data[,opt[i]] <- list(as.logical(value))
- else
- data[,opt[i]] <- list(value)
- }
- data <- data[1:maxl,]
+ } else {
+ maxl <- nrow(data)
}
+ opt <- vars[na.omit(pmatch(names(mc), vars))]
+ if (length(opt) > 0)
+ for (i in 1:length(opt)) {
+ value <- eval(mc[[opt[i]]], envir = env)
+ lv <- length(value)
+ if (lv>1)
+ if (maxl==1 || maxl==lv) {
+ maxl <- lv
+ data <- data[1:lv,]
+ }
+ else
+ stop("vector inputs should have the same length.")
+ if (is.factor(data[,opt[i]]))
+ data[,opt[i]] <- list(factor(value, levels=levels(data[,opt[i]])))
+ else if (is.numeric(data[,opt[i]]))
+ data[,opt[i]] <- list(as.numeric(value))
+ else if (is.logical(data[,opt[i]]))
+ data[,opt[i]] <- list(as.logical(value))
+ else
+ data[,opt[i]] <- list(value)
+ }
+ data <- data[1:maxl,]
+
if (!is.data.frame(data)) {
data <- data.frame(data)
names(data) <- vars
diff --git a/R/summary.zelig.strata.R b/R/summary.zelig.strata.R
index 71c3d8e..9252a21 100644
--- a/R/summary.zelig.strata.R
+++ b/R/summary.zelig.strata.R
@@ -37,7 +37,7 @@ summary.zelig.strata <-function(object, subset = NULL, CI=95,
if(length(dim(qi1i))==3)
tmp[(sum(w[1:(j-1)])+1):sum(w[1:j]),,] <- qiji[1:w[j],,]
else
- tmp <- rbind(tmp, as.matrix(qiji))
+ tmp <- cbind(tmp, as.matrix(qiji))
}
}
qi[[i]] <- tmp
diff --git a/R/terms.multiple.R b/R/terms.multiple.R
index c52b6a4..d6f8ffe 100644
--- a/R/terms.multiple.R
+++ b/R/terms.multiple.R
@@ -56,21 +56,50 @@ terms.multiple<-function(x, data=NULL,...){
termlabels[[namei]]<-attr(TT,"term.labels")
intercAttr[[namei]]<-attr(TT,"intercept")
}
+
namesOfEquations<-names(objectNew)
myattr<-list()
result<-objectNew
+ subs<-constraints<-FALSE
+
if(length(constr)>0){
+ dvars<-unique(unlist(depVars))
namesConstr<-unique(namesConstr)
- constraints<-matrix(NA,nrow=nrEquationsNew,ncol=length(namesConstr),dimnames=list(namesOfEquations,namesConstr))
+ namesC<-namesConstr %w/o% dvars
+ namesS <-namesConstr %w/o% namesC
+ nrC<-nrS<-0
+ constrC<-constrS<-list()
+ rownamesS<-c()
for(i in 1:length(constr)){
constri<-constr[[i]]
- eqind<-constri[[1]]
- eq<-namesOfEquations[as.numeric(eqind)]
- lab<-constri[[2]]
- constraints[eq,lab]<-constri[[3]]
+ if(constri[[2]] %in% dvars){
+ nrS=nrS+1
+ constrS[[nrS]]<-constr[[i]]
+ rownamesS<-c(rownamesS,namesOfEquations[[which(constri[[2]] ==dvars)]])
+ }else{
+ nrC=nrC+1
+ constrC[[nrC]]<-constr[[i]]
+ }
+ }
+ if(length(constrC)>0){
+ constraints<-matrix(NA,nrow=nrEquationsNew,ncol=length(namesC),dimnames=list(namesOfEquations,namesC))
+ for(i in 1:length(constrC)){
+ constri<-constrC[[i]]
+ eqind<-constri[[1]]
+ eq<-namesOfEquations[as.numeric(eqind)]
+ lab<-constri[[2]]
+ constraints[eq,lab]<-constri[[3]]
+ }
+ }
+ if(length(constrS)>0){ #subs
+ subs<-matrix(NA,nrow=length(rownamesS),ncol=length(namesS),dimnames=list(rownamesS,namesS))
+ for(i in 1:length(constrS)){
+ constri<-constrS[[i]]
+ lab<-constri[[2]]
+ subs[rownamesS[[i]],lab]<-constri[[3]]
+ }
}
- }else
- constraints<-FALSE
+ }
indVars<-unique(unlist(termlabels))
if(length(depFactorVar) !=0)
@@ -89,6 +118,7 @@ terms.multiple<-function(x, data=NULL,...){
myattr$depVars<-depVars
myattr$depFactors<-depFactors
myattr$constraints<-constraints
+ myattr$subs<-subs
myattr$response<-1
myattr$intercept<-intercAttr
attributes(result)<-myattr
diff --git a/R/vdc.R b/R/vdc.R
index 58d370f..c98e62e 100644
--- a/R/vdc.R
+++ b/R/vdc.R
@@ -8,21 +8,24 @@ zeligListModels<-function(inZeligOnly=T) {
sub("zelig2","", tmp)
}
+
+
+
+
zeligInstalledModels<-function(inZeligOnly=T,schemaVersion="1.1") {
chkpkgs<-function(name) {
- zd=zeligDescribeModelXML(name,schemaVersion=schemaVersion)
- if (is.null(zd)) {
- return (FALSE)
- }
- zdpd= zeligModelDependency(name)[,1]
- if (is.null(zdpd)) {
- return(TRUE)
- }
- ow=options(warn=-1)
- ret = (class(try(sapply(zdpd,function(x)require(x,character.only=T)),silent=T))
- !="try-error")
- options(ow)
- return (ret)
+ zd=zeligDescribeModelXML(name,schemaVersion=schemaVersion)
+ if (is.null(zd)) {
+ return (FALSE)
+ }
+ zdpd= zeligModelDependency(name)[,1]
+ if (is.null(zdpd)) {
+ return(TRUE)
+ }
+ ow=options(warn=-1)
+ ret=sapply(zdpd,function(x) require(x,character.only=T)==T)
+ options(ow)
+ return (ret)
}
models<-zeligListModels(inZeligOnly=inZeligOnly)
# Not being the trusting sort, lets check to see if we can run
@@ -87,16 +90,16 @@ printZeligSchemaInstance<-function(filename=NULL, serverName=NULL,vdcAbsDirPrefi
serverName<-system('hostname -f', intern=T)
}
if (is.null(vdcAbsDirPrefix)){
- locationURL<-paste('http://', serverName, '/VDC/schema/analysis/ZeligInterfaceDefinition.xsd',sep="");
+ locationURL<-paste('http://', serverName, '/VDC/Schema/analysis/ZeligInterfaceDefinition.xsd',sep="");
} else {
- locationURL<-paste('file://', vdcAbsDirPrefix, '/VDC/schema/analysis/ZeligInterfaceDefinition.xsd',sep="");
+ locationURL<-paste('file://', vdcAbsDirPrefix, '/VDC/Schema/analysis/ZeligInterfaceDefinition.xsd',sep="");
}
schemaLocation<-paste(schemaURL, ' ', locationURL, sep='');
con<-"";
if (!is.null(filename)){
con<-file(filename,"w");
}
- cat(file=con, "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<zelig xmlns=\"",schemaURL,"\" xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xsi:schemaLocation=\"",schemaLocation,"\">", sep="");
+ cat(file=con, "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<zelig xmlns=\"",schemaURL,"\" xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xsi:schemaLocation=\"",schemaLocation,"\">\n", sep="");
mssg<- sapply(zeligInstalledModels(),function(x){cat(file=con,zmodel2string(zeligDescribeModel(x)),sep="")},simplify=F);
cat(file=con,"\n</zelig>\n",sep="");
}
@@ -124,21 +127,19 @@ xmlList<-function(z){
res<-paste(res,">\n",sep="")
res<-paste(res,"<description>",z$description, "</description>\n",sep="")
if(z$name=="irtkd")
- res<-paste(res,"<helpLink url=","http://gking.harvard.edu/zelig/docs/_TT_irtkd_TT__tex2htm.html",sep="")
+ res<-paste(res,"<helpLink url=",'"',"http://gking.harvard.edu/zelig/docs/_TT_irtkd_TT__tex2htm.html",'"',sep="")
else
res<-paste(res,"<helpLink url=",'"',modelURL(z$name,z$description),'"',sep="")
res<-paste(res,"/>\n", sep="")
- if(any(!(is.null(z$packageDependency)))){
+ if(any(!(is.null(z$package)))){
res<-paste(res,"<packageDependency",sep="")
- if(!(is.na(z$packageDependency$name)))
- res<-paste(res," name= ",'"',z$packageDependency$name,'"',sep="")
- if(!(is.na(z$packageDependency$version)))
- res<-paste(res," version= ",'"',z$packageDependency$version,'"',sep="")
- if(!(is.na(z$packageDependency$relationship)))
- res<-paste(res," relationship= ",'"',z$packageDependency$relationship,'"',sep="")
- if(!(is.na(z$packageDependency$CRAN)))
- res<-paste(res," CRAN= ",'"',z$packageDependency$CRAN,'"',sep="")
+ if(!(is.na(z$package$name)))
+ res<-paste(res," name= ",'"',z$package$name,'"',sep="")
+ if(!(is.na(z$package$version)))
+ res<-paste(res," version= ",'"',z$package$version,'"',sep="")
+ if(!is.null(z$package$CRAN) && !(is.na(z$package$CRAN)))
+ res<-paste(res," CRAN= ",'"',z$package$CRAN,'"',sep="")
res<-paste(res,"/>\n",sep="")
}
res<-paste(res,"<formula minEquations=",'"',min,'"',sep="")
@@ -146,32 +147,30 @@ xmlList<-function(z){
res<-paste(res," maxEquations=",'"',max,'"',sep="")
if(max==1)
res<-paste(res," simulEq=",'"',0,'"',sep="")
- res<-paste(res,"/>\n",sep="")
+ res<-paste(res,">\n",sep="")
- res<-paste(res,"<equation name=",'"',names(z$parameters)[[1]],'"',"/>\n",sep="")
- if(z$parameters[[1]]$depVar){
- res<-paste(res,"<outcome",sep="")
- if(!is.na(z$parameters[[1]]$specialFunction))
- {
- if(is.finite(z$parameters[[1]]$varInSpecialFunction[[2]] ))
- res<-paste(res," maxVar=",'"',z$parameters[[1]]$varInSpecialFunction[[2]],'"',sep="")
- res<-paste(res," minVar=",'"',z$parameters[[1]]$varInSpecialFunction[[1]],'"',sep="")
- }
- else
- {
- if(z$parameters[[1]]$depVar == TRUE)
- res<-paste(res," minVar=",'"',1,'"',sep="")
- else
- res<-paste(res," minVar=",'"',0,'"'," maxVar=",'"',0,'"',sep="")
- }
- res<-paste(res,">\n")
-
-
- for(i in 1:length(modeling.types()$depVar[[z$category]]))
- res<-paste(res,"<modelingType>",modeling.types()$depVar[[z$category]][[i]],"</modelingType>\n",sep="")
-
- res<-paste(res,"</outcome>\n",sep="")
- }
+ res<-paste(res,"<equation name=",'"',names(z$parameters)[[1]],'"',">\n",sep="")
+ if(!(z$name %in% c("exp","lognorm","weibull"))){ ##we are going to delete this !!!
+ if(z$parameters[[1]]$depVar){
+ res<-paste(res,"<outcome",sep="")
+ if(!is.na(z$parameters[[1]]$specialFunction))
+ {
+ if(is.finite(z$parameters[[1]]$varInSpecialFunction[[2]] ))
+ res<-paste(res," maxVar=",'"',z$parameters[[1]]$varInSpecialFunction[[2]],'"',sep="")
+ res<-paste(res," minVar=",'"',z$parameters[[1]]$varInSpecialFunction[[1]],'"',sep="")
+ }
+ else
+ {
+ if(z$parameters[[1]]$depVar !=TRUE)
+ res<-paste(res," minVar=",'"',0,'"'," maxVar=",'"',0,'"',sep="")
+ }
+ res<-paste(res,">\n")
+ for(i in 1:length(modeling.types()$depVar[[z$category]]))
+ res<-paste(res,"<modelingType>",modeling.types()$depVar[[z$category]][[i]],"</modelingType>\n",sep="")
+ res<-paste(res,"</outcome>\n",sep="")
+ }
+ } else
+ res<-paste(res,durOutput())
#explanatory
if(z$parameters[[1]]$expVar){
res<-paste(res,"<explanatory ")
@@ -188,7 +187,11 @@ xmlList<-function(z){
}
res<-paste(res,"</equation>\n",sep="")
res<-paste(res,"</formula>\n",sep="")
- res<-paste(res,"<setx maxSetx=",'"',2,'"',"/>\n",sep="")
+ if(z$parameters[[1]]$expVar)
+ sext<-2
+ else
+ sext<-0
+ res<-paste(res,"<setx maxSetx=",'"',sext,'"',"/>\n",sep="")
res<-paste(res,"</model>\n")
return(res)
}
@@ -203,16 +206,13 @@ check.full<-function(z,name){
for (i in length(z$parameters)){
if(is.null(z$parameters[[i]]$specialFunction)) z$parameters[[i]]$specialFunction<-NA
- if(is.null(z$parameters[[i]]$varInSpecial)) z$parameters[[i]]$varInSpecial<-NA
+ if(is.null(z$parameters[[i]]$varInSpecialFunction)) z$parameters[[i]]$varInSpecialFunction<-NA
}
return(z)
}
-
-
-
modelURL<-function(modelName,modelDesc){
baseUrl<-"http://gking.harvard.edu/zelig/docs/"
spec<-"_TT_"
@@ -227,18 +227,26 @@ modeling.types <-function(){
expVar=list(continuous=c("continuous","discrete","nominal","ordinal","binary"),
dichotomous=c("continuous","discrete","nominal","ordinal","binary"),
ordinal=c("continuous","discrete","nominal","ordinal","binary"),
- bivariate.dichotomous=c("continuous","discrete","nominal","ordinal","binary"),
+ bounded=c("continuous","discrete","nominal","ordinal","binary"),
multinomial=c("continuous","discrete","nominal","ordinal","binary"),
- event.count=c("continuous","discrete","nominal","ordinal","binary"),
- censored=c("continuous","discrete","nominal","ordinal","binary")),
+ count=c("continuous","discrete","nominal","ordinal","binary"),
+ mixed=c("continuous","discrete","nominal","ordinal","binary")),
depVar=list(
- continuous="continous",
+ continuous="continuous",
dichotomous="binary",
ordinal="ordinal",
- bivariate.dichotomous="binary",
+ bounded="continuous",
multinomial=c("nominal","ordinal"),
- event.count="discrete",
- censored="continuous"))
+ count="discrete",
+ mixed=c("continuous","discrete","nominal","ordinal","binary")))
res
}
+
+## this is a temporary function; Is going to be removed after we change "describe" for this duration models;
+
+durOutput <-function(){
+res<-"<outcome minVar=\"1\" maxVar=\"1\" label=\"Duration\">\n<modelingType>continuous</modelingType>\n</outcome>\n<outcome maxVar=\"1\" minVar=\"0\" label=\"Censored\">\n<modelingType>binary</modelingType>\n</outcome>\n"
+return (res)
+
+}
diff --git a/README b/README
index b562ee3..a9683bd 100644
--- a/README
+++ b/README
@@ -1,3 +1,6 @@
+2.5-3 (March 9, 2006): Stable release for R 2.0.0-2.2.1. Fixed bugs related to VDC
+ GUI. First level dependencies are the same as in version 2.5-1.
+
2.5-2 (February 3, 2006): Stable release for R 2.0.0-2.2.1. Fixed bugs related to
VDC GUI. First level dependencies are the same as in version 2.5-1.
diff --git a/demo/match.R b/demo/match.R
index 28676a2..fefd4c7 100644
--- a/demo/match.R
+++ b/demo/match.R
@@ -1,5 +1,7 @@
###
-### Example 1: calculating the average treatment effect for the treated
+### Example 1: Calculating the conditional average treatment effect
+### for the matched treatment group using nearest neighbor
+### propensity score matching
###
## load the Lalonde data
@@ -12,19 +14,18 @@ m.out1 <- matchit(treat ~ age + educ + black + hispan + nodegree + married + re7
method = "nearest", data = lalonde)
user.prompt()
-## fit the linear model to the control group controlling for propensity score and
-## other covariates
-z.out1 <- zelig(re78 ~ age + educ + black + hispan + nodegree + married + re74 + re75 +
- distance, data = match.data(m.out1, "control"), model = "ls")
+## fit the linear model to the entire sample controlling for propensity score and other covariates
+z.out1 <- zelig(re78 ~ treat + age + educ + black + hispan + nodegree + married + re74 + re75 +
+ distance, data = match.data(m.out1), model = "ls")
user.prompt()
-## set the covariates to the covariates of matched treated units
-## use conditional prediction by setting cond = TRUE.
-x.out1 <- setx(z.out1, data = match.data(m.out1, "treat"), fn = NULL, cond = TRUE)
+## set the covariates to the covariates using only matched treated units:
+x.out0 <- setx(z.out1, data = match.data(m.out1, "treat"), fn = NULL, treat=0)
+x.out1 <- setx(z.out1, data = match.data(m.out1, "treat"), fn = NULL)
user.prompt()
-## simulate quantities of interest
-s.out1 <- sim(z.out1, x = x.out1)
+## simulate conditional average treatment effect for the treated
+s.out1 <- sim(z.out1, x = x.out0, x1 = x.out1)
user.prompt()
## obtain a summary
@@ -33,45 +34,49 @@ user.prompt()
###
-### Example 2: calculating the average treatment effect for the entire sample
+### Example 2: Calculating the conditional average treatment effect
+### for the matched control group using nearest neighbor
+### propensity score matching
###
-## fit the linear model to the treatment group controlling for propensity score and
-## other covariates
-z.out2 <- zelig(re78 ~ age + educ + black + hispan + nodegree + married + re74 + re75 +
- distance, data = match.data(m.out1, "control"), model = "ls")
-user.prompt()
-## conducting the simulation procedure for the control group
-x.out2 <- setx(z.out2, data = match.data(m.out1, "control"), fn = NULL, cond = TRUE)
+## set the covariates to the covariates using only matched control units:
+x.out2 <- setx(z.out1, data = match.data(m.out1, "control"), fn = NULL)
+x.out3 <- setx(z.out1, data = match.data(m.out1, "control"), fn = NULL, treat = 1)
user.prompt()
-s.out2 <- sim(z.out2, x = x.out2)
+## simulate conditional average treatment effect for the treated
+s.out2 <- sim(z.out1, x = x.out2, x1 = x.out3)
user.prompt()
-## Note that Zelig calculates the difference between observed and
-## either predicted or expected values. This means that the treatment
-## effect for the control units is actually the effect of control
-## (observed control outcome minus the imputed outcome under treatment
-## from the model). Hence, to combine treatment effects just reverse
-## the signs of the estimated treatment effect of controls.
-ate.all <- c(s.out1$qi$ate.ev, -s.out2$qi$ate.ev)
+## obtain a summary
+summary(s.out2)
user.prompt()
-## some summaries
-## point estimate
-mean(ate.all)
+
+###
+### Example 3: Calculating the conditional average treatment effect
+### for the entire matched sample using nearest neighbor
+### propensity score matching
+###
+
+## set the covariates to the covariates using all matched units:
+x.out4 <- setx(z.out1, fn = NULL, treat = 0)
+x.out5 <- setx(z.out1, fn = NULL, treat = 1)
user.prompt()
-## standard error
-sd(ate.all)
+
+## simulate conditional average treatment effect for the treated
+s.out3 <- sim(z.out1, x = x.out4, x1 = x.out5)
user.prompt()
-## 95% confidence interval
-quantile(ate.all, c(0.025, 0.975))
+
+## obtain a summary
+summary(s.out3)
user.prompt()
###
-### Example 3: subclassification
+### Example 4: Calculating the conditional average treatment effect
+### for the entire sample using subclassification
###
## subclassification with 4 subclasses
@@ -81,29 +86,30 @@ user.prompt()
## controlling only for the estimated prpensity score and lagged Y within each subclass
## one can potentially control for more
-z.out3 <- zelig(re78 ~ re74 + re75 + distance, data = match.data(m.out2, "control"),
+z.out2 <- zelig(re78 ~ treat + re74 + re75 + distance, data = match.data(m.out2),
model = "ls", by = "subclass")
user.prompt()
## conducting simulations
-x.out3 <- setx(z.out3, data = match.data(m.out2, "treat"), fn = NULL, cond = TRUE)
+x.out6 <- setx(z.out2, fn = NULL, treat = 0)
+x.out7 <- setx(z.out2, fn = NULL, treat = 1)
user.prompt()
## for the demonstration purpose, we set the number of simulations to be 100
-s.out3 <- sim(z.out3, x = x.out3, num = 100)
+s.out4 <- sim(z.out2, x = x.out6, x1 = x.out7, num = 100)
user.prompt()
## overall results
-summary(s.out3)
+summary(s.out4)
user.prompt()
## summary for each subclass
-summary(s.out3, subset = 1)
+summary(s.out4, subset = 1)
user.prompt()
-summary(s.out3, subset = 2)
+summary(s.out4, subset = 2)
user.prompt()
-summary(s.out3, subset = 3)
+summary(s.out4, subset = 3)
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-zelig.git
More information about the debian-science-commits
mailing list