[Gmm-commits] r134 - pkg/gmm4/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Sep 21 23:16:45 CEST 2018
Author: chaussep
Date: 2018-09-21 23:16:45 +0200 (Fri, 21 Sep 2018)
New Revision: 134
Modified:
pkg/gmm4/R/gmmData.R
Log:
added the na.action in the gmmData utilities
Modified: pkg/gmm4/R/gmmData.R
===================================================================
--- pkg/gmm4/R/gmmData.R 2018-09-20 21:27:29 UTC (rev 133)
+++ pkg/gmm4/R/gmmData.R 2018-09-21 21:16:45 UTC (rev 134)
@@ -1,17 +1,9 @@
######### Function to arrange the data for the gmmModel objects #################
-
-
-.multiToSys <- function(formula, h, data)
+.multiToSys <- function(formula, h, data, omit=TRUE)
{
- mf <- match.call()
- m <- match(c("formula", "data"), names(mf), 0L)
- mf <- mf[c(1L, m)]
- mf$drop.unused.levels <- TRUE
- mf$na.action <- "na.pass"
- mfh <- mf
- mf[[1L]] <- quote(stats::model.frame)
- modelF <- eval(mf, parent.frame())
+ modelF <- model.frame(formula, data, na.action="na.pass",
+ drop.unused.levels=TRUE)
Y <- model.response(modelF)
modelF <- modelF[-1]
Yn <- formula[[2]]
@@ -23,55 +15,46 @@
colnames(Y) <- Yn
modelF <- cbind(Y, modelF)
if (any(class(h) == "formula"))
- {
- mfh$formula <- h
- mfh[[1L]] <- quote(stats::model.frame)
- instF <- eval(mfh, parent.frame())
- } else {
- h <- as.data.frame(h)
- chk <- apply(h, 2, function(x) all(x==x[1]))
- h <- h[, !chk]
- intercept <- any(chk)
- if (ncol(h) == 0)
- {
- mfh$formula <- ~1
+ {
+ instF <- model.frame(h, data, na.action="na.pass",
+ drop.unused.levels=TRUE)
} else {
- if (is.null(colnames(h)))
- colnames(h) <- paste("h", 1:ncol(h), sep="")
- formh <- paste(colnames(h), collapse="+")
- if (!intercept)
- formh <- paste(formh, "-1", sep="")
- mfh$formula <- as.formula(paste("~",formh))
- mfh$data <- quote(h)
- }
- mfh[[1L]] <- quote(stats::model.frame)
- instF <- eval(mfh)
- }
+ h <- as.data.frame(h)
+ chk <- apply(h, 2, function(x) all(x==x[1]))
+ h <- h[, !chk]
+ intercept <- any(chk)
+ if (ncol(h) == 0)
+ {
+ formula <- ~1
+ } else {
+ if (is.null(colnames(h)))
+ colnames(h) <- paste("h", 1:ncol(h), sep="")
+ formh <- paste(colnames(h), collapse="+")
+ if (!intercept)
+ formh <- paste(formh, "-1", sep="")
+ formula <- as.formula(paste("~",formh))
+ }
+ instF <- model.frame(formula, h, na.action="na.pass",
+ drop.unused.levels=TRUE)
+ }
h <- lapply(1:ncol(Y), function(i) formula(terms(instF), .GlobalEnv))
data <- cbind(modelF, instF)
data <- data[,!duplicated(colnames(data))]
- return(.slGmmData(g,h,data))
+ return(.slGmmData(g,h,data,omit))
}
-.lGmmData <- function(formula, h, data)
+.lGmmData <- function(formula, h, data, omit=TRUE)
{
- mf <- match.call()
- m <- match(c("formula", "data"), names(mf), 0L)
- mf <- mf[c(1L, m)]
- mf$drop.unused.levels <- TRUE
- mf$na.action <- "na.pass"
- mfh <- mf
- mf[[1L]] <- quote(stats::model.frame)
- modelF <- eval(mf, parent.frame())
+ modelF <- model.frame(formula, data, na.action="na.pass",
+ drop.unused.levels=TRUE)
if (is.matrix(modelF[[1]]))
return(.multiToSys(formula, h, data))
parNames <- colnames(model.matrix(terms(modelF), modelF))
k <- length(parNames)
if (any(class(h) == "formula"))
{
- mfh$formula <- h
- mfh[[1L]] <- quote(stats::model.frame)
- instF <- eval(mfh, parent.frame())
+ instF <- model.frame(h, data, na.action="na.pass",
+ drop.unused.levels=TRUE)
} else {
h <- as.data.frame(h)
chk <- apply(h, 2, function(x) all(x==x[1]))
@@ -79,36 +62,35 @@
intercept <- any(chk)
if (ncol(h) == 0)
{
- mfh$formula <- ~1
+ formula <- ~1
} else {
if (is.null(colnames(h)))
colnames(h) <- paste("h", 1:ncol(h), sep="")
formh <- paste(colnames(h), collapse="+")
if (!intercept)
formh <- paste(formh, "-1", sep="")
- mfh$formula <- as.formula(paste("~",formh))
- mfh$data <- quote(h)
+ formula <- as.formula(paste("~",formh))
}
- mfh[[1L]] <- quote(stats::model.frame)
- instF <- eval(mfh)
+ instF <- model.frame(formula, h, na.action="na.pass",
+ drop.unused.levels=TRUE)
}
momNames <- colnames(model.matrix(terms(instF), instF))
q <- length(momNames)
isEndo <- !(parNames %in% momNames)
na <- attr(na.omit(cbind(modelF, instF)), "na.action")
- if (!is.null(na))
+ if (!is.null(na) && omit)
{
modelF <- modelF[-na,,drop=FALSE]
instF <- instF[-na,,drop=FALSE]
}
n <- nrow(modelF)
list(modelF=modelF, instF=instF, n=n, k=k, q=q, momNames=momNames,
- parNames=parNames, isEndo=isEndo, varNames=parNames)
+ parNames=parNames, isEndo=isEndo, varNames=parNames, na.action=na)
}
-.formGmmData <- function(formula, tet0, data)
+.formGmmData <- function(formula, tet0, data,omit=TRUE)
{
res <- lapply(formula, function(f) .nlGmmData(f, ~1, tet0, data))
fRHS <- lapply(res, function(r) r$fRHS)
@@ -120,7 +102,10 @@
chkRHS <- sapply(fRHS, function(r) any(all.vars(r) %in% names(tet0)))
isMDE <- all(chkLHS) | all(chkRHS)
modelF <- sapply(varNames, function(n) data[[n]])
- modelF <- as.data.frame(modelF)
+ modelF <- as.data.frame(modelF)
+ na <- attr(na.omit(modelF), "na.action")
+ if (!is.null(na) && omit)
+ modelF <- modelF[-na,,drop=FALSE]
k <- length(tet0)
q <- length(formula)
if (is.null(names(formula)))
@@ -131,12 +116,12 @@
n <- nrow(modelF)
list(modelF=modelF, fRHS=fRHS, fLHS=fLHS, n=n, k=k, q=q,
momNames=momNames, parNames=parNames, varNames=varNames, isEndo=isEndo,
- isMDE=isMDE)
+ isMDE=isMDE,na.action=na)
}
-.nlGmmData <- function(formula, h, tet0, data)
+.nlGmmData <- function(formula, h, tet0, data, omit=TRUE)
{
varNames <- all.vars(formula)
parNames <- names(tet0)
@@ -165,15 +150,9 @@
stop("Cannot evaluate the RHS")
}
if (any(class(h) == "formula"))
- {
- mfh <- match.call()
- m <- match(c("formula", "data"), names(mfh), 0L)
- mfh <- mfh[c(1L, m)]
- mfh$drop.unused.levels <- TRUE
- mfh$na.action <- "na.pass"
- mfh$formula <- h
- mfh[[1L]] <- quote(stats::model.frame)
- instF <- eval(mfh, parent.frame())
+ {
+ instF <- model.frame(h, data, na.action="na.pass",
+ drop.unused.levels=TRUE)
} else {
h <- as.data.frame(h)
chk <- apply(h, 2, function(x) all(x==x[1]))
@@ -181,34 +160,34 @@
intercept <- any(chk)
if (ncol(h) == 0)
{
- mfh$formula <- ~1
+ formula <- ~1
} else {
if (is.null(colnames(h)))
colnames(h) <- paste("h", 1:ncol(h), sep="")
formh <- paste(colnames(h), collapse="+")
if (!intercept)
formh <- paste(formh, "-1", sep="")
- mfh$formula <- as.formula(paste("~",formh))
- mfh$data <- quote(h)
+ formula <- as.formula(paste("~",formh))
}
- mfh[[1L]] <- quote(stats::model.frame)
- instF <- eval(mfh)
+ instF <- model.frame(formula, h, na.action="na.pass",
+ drop.unused.levels=TRUE)
}
momNames <- colnames(model.matrix(terms(instF), instF))
isEndo <- !(varNames %in% momNames)
q <- length(momNames)
na <- attr(na.omit(cbind(modelF, instF)), "na.action")
- if (!is.null(na))
+ if (!is.null(na) && omit)
{
modelF <- modelF[-na,,drop=FALSE]
instF <- instF[-na,,drop=FALSE]
}
n <- nrow(modelF)
list(modelF=modelF, instF=instF, fRHS=fRHS, fLHS=fLHS, n=n, k=k, q=q,
- momNames=momNames, parNames=parNames, varNames=varNames, isEndo=isEndo)
+ momNames=momNames, parNames=parNames, varNames=varNames, isEndo=isEndo,
+ na.action=na)
}
-.fGmmData <- function(g, x, thet0)
+.fGmmData <- function(g, x, thet0, omit=NULL)
{
mom <- try(g(thet0, x))
k <- length(thet0)
@@ -233,13 +212,17 @@
varNames=character(), isEndo=logical())
}
-.slGmmData <- function(g,h,data)
+.slGmmData <- function(g,h,data,omit=TRUE)
{
- res <- lapply(1:length(g), function(i) .lGmmData(g[[i]], h[[i]], data))
+ res <- lapply(1:length(g), function(i) .lGmmData(g[[i]], h[[i]], data, FALSE))
modelT <- lapply(res, function(x) terms(x$modelF))
instT <- lapply(res, function(x) terms(x$instF))
allDat <- do.call(cbind, lapply(res, function(x) cbind(x$modelF, x$instF)))
allDat <- allDat[,!duplicated(colnames(allDat))]
+ allDat <- na.omit(allDat)
+ na <- attr(allDat, "na.action")
+ if (omit && !is.null(na))
+ allDat <- allDat[-na,]
parNames <- lapply(1:length(g), function(i) res[[i]]$parNames)
momNames <- lapply(1:length(g), function(i) res[[i]]$momNames)
isEndo <- lapply(1:length(g), function(i) res[[i]]$isEndo)
@@ -253,18 +236,22 @@
eqnNames <- paste("Eqn", 1:length(g), sep="")
list(data=allDat, modelT=modelT, instT=instT, parNames=parNames,
momNames=momNames, k=k,q=q,n=n, eqnNames=eqnNames,
- varNames=varNames, isEndo=isEndo)
+ varNames=varNames, isEndo=isEndo, na.action=na)
}
-.snlGmmData <- function(g,h,tet0, data)
+.snlGmmData <- function(g,h,tet0, data, omit=TRUE)
{
res <- lapply(1:length(g), function(i) .nlGmmData(g[[i]], h[[i]],
- tet0[[i]], data))
+ tet0[[i]], data, FALSE))
fRHS <- lapply(res, function(x) x$fRHS)
fLHS <- lapply(res, function(x) x$fLHS)
instT <- lapply(res, function(x) terms(x$instF))
allDat <- do.call(cbind, lapply(res, function(x) cbind(x$modelF, x$instF)))
allDat <- allDat[,!duplicated(colnames(allDat))]
+ allDat <- na.omit(allDat)
+ na <- attr(allDat, "na.action")
+ if (omit && !is.null(na))
+ allDat <- allDat[-na,]
parNames <- lapply(1:length(g), function(i) res[[i]]$parNames)
momNames <- lapply(1:length(g), function(i) res[[i]]$momNames)
isEndo <- lapply(1:length(g), function(i) res[[i]]$isEndo)
@@ -278,5 +265,5 @@
eqnNames <- paste("Eqn", 1:length(g), sep="")
list(data=allDat, fRHS=fRHS, fLHS=fLHS, parNames=parNames,
momNames=momNames, k=k,q=q,n=n, eqnNames=eqnNames, instT=instT,
- varNames=varNames, isEndo=isEndo)
+ varNames=varNames, isEndo=isEndo, na.action=na)
}
More information about the Gmm-commits
mailing list