Skip to content

Commit

Permalink
changed the data argument, now you can ommit it
Browse files Browse the repository at this point in the history
  • Loading branch information
@sestelo
sestelo committed Oct 30, 2017
1 parent 1d18aaf commit 22c3d8a
Showing 1 changed file with 149 additions and 29 deletions.
178 changes: 149 additions & 29 deletions R/localtest.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -187,40 +187,78 @@ localtest <- function(formula, data = data, na.action = "na.omit",

ncmax <- 5
c2 <- NULL
# if(is.null(seed)) seed <- -1


nalfas <- length(ci.level)





if (smooth != "splines") {

ffr <- interpret.frfastformula(formula, method = "frfast")
varnames <- ffr$II[2, ]
aux <- unlist(strsplit(varnames,split = ":"))
cl <- match.call()
mf <- match.call(expand.dots = FALSE)
m <- match(x = c("formula", "data", "subset", "weights",
"na.action", "offset"), table = names(mf), nomatch = 0L)
mf <- mf[c(1L, m)]
mf$drop.unused.levels <- TRUE
mf[[1L]] <- quote(stats::model.frame)
mf <- eval(expr = mf, envir = parent.frame())
mt <- attr(mf, "terms")
y <- model.response(mf, "numeric")
w <- as.vector(model.weights(mf))
if (!is.null(w) && !is.numeric(w))
stop("'weights' must be a numeric vector")

terms <- attr(mt, "term.labels")
aux <- unlist(strsplit(terms,split = ":"))
varnames <- aux[1]
namef <- aux[2]
response <- as.character(attr(mt, "variables")[2])

if (unlist(strsplit(varnames,split = ""))[1] == "s") {
stop("Argument \"formula\" is wrong specified, see details of
model specification in 'Details' of the frfast help." )
}
namef <- aux[2]
if (length(aux) == 1) {f <- NULL}else{f <- data[ ,namef]}
newdata <- data
data <- data[ ,c(ffr$response, varnames)]

data <- mf

if (na.action == "na.omit"){ # ver la f
if (na.action == "na.omit"){ # ver la f, corregido
data <- na.omit(data)
}else{
stop("The actual version of the package only supports 'na.omit' (observations are removed
if they contain any missing values)")
}
#newdata <- na.omit(newdata[ ,varnames])

if (length(aux) == 1) {f <- NULL}else{f <- data[ ,namef]}
n <- nrow(data)



}else{


ffr <- interpret.gam(formula)
varnames <- ffr$pred.names[1]
cl <- match.call()
mf <- match.call(expand.dots = FALSE)
mf$formula <- ffr$fake.formula

m <- match(x = c("formula", "data", "subset", "weights",
"na.action", "offset"), table = names(mf), nomatch = 0L)
mf <- mf[c(1L, m)]
mf$drop.unused.levels <- TRUE
mf[[1L]] <- quote(stats::model.frame)
mf <- eval(expr = mf, envir = parent.frame())
mt <- attr(mf, "terms")
y <- model.response(mf, "numeric")
w <- as.vector(model.weights(mf))
if (!is.null(w) && !is.numeric(w))
stop("'weights' must be a numeric vector")

terms <- attr(mt, "term.labels")
response <- as.character(attr(mt, "variables")[2])
varnames <- terms[1]
if (":" %in% unlist(strsplit(ffr$fake.names,split = ""))) {
stop("Argument \"formula\" is wrong specified, see details of
model specification in 'Details' of the frfast help." )
Expand All @@ -230,28 +268,110 @@ localtest <- function(formula, data = data, na.action = "na.omit",
model specification in 'Details' of the frfast help." )
}

namef <- ffr$pred.names[2]
if (length(ffr$pred.names) == 1) {f <- NULL}else{f <- data[ ,namef]}
newdata <- data
datam <- mf

if (length(ffr$pred.names) == 1) {
data <- data[ ,c(ffr$response, varnames)]
if (na.action == "na.omit"){
datam <- na.omit(datam)
}else{
data <- data[ ,c(ffr$response, varnames, namef)]
stop("The actual version of the package only supports 'na.omit'
(observations are removed if they contain any missing values)")
}

if (na.action == "na.omit"){
data <- na.omit(data)
if (length(terms) == 1) {
f <- NULL
namef <- 1
}else{
stop("The actual version of the package only supports 'na.omit' (observations are removed
if they contain any missing values)")
namef <- terms[2]
f <- mf[ ,namef]
}

n <- nrow(data)
n <- nrow(datam)
}


if(missing(data)) {

response <- strsplit(response, "\\$")[[1]][2]
terms2 <- strsplit(terms, "\\$")

if(length(terms) == 1){
formula <- as.formula(paste0(response, "~s(",terms2[[1]][2],")"))
names(datam) <- c(response, terms2[[1]][2])
varnames <- terms2[[1]][2]
namef <- "F"
}else{
formula <- as.formula(paste0(response, "~s(",terms2[[1]][2],", by = ", terms2[[2]][2],")"))
#data2 <- data
names(datam) <- c(response, terms2[[1]][2], terms2[[2]][2])
varnames <- terms2[[1]][2]
namef <- terms2[[2]][2]
}

data <- datam
}




#
# if (smooth != "splines") {
#
# ffr <- interpret.frfastformula(formula, method = "frfast")
# varnames <- ffr$II[2, ]
# aux <- unlist(strsplit(varnames,split = ":"))
# varnames <- aux[1]
# if (unlist(strsplit(varnames,split = ""))[1] == "s") {
# stop("Argument \"formula\" is wrong specified, see details of
# model specification in 'Details' of the frfast help." )
# }
# namef <- aux[2]
# if (length(aux) == 1) {f <- NULL}else{f <- data[ ,namef]}
# newdata <- data
# data <- data[ ,c(ffr$response, varnames)]
#
#
# if (na.action == "na.omit"){ # ver la f
# data <- na.omit(data)
# }else{
# stop("The actual version of the package only supports 'na.omit' (observations are removed
# if they contain any missing values)")
# }
# #newdata <- na.omit(newdata[ ,varnames])
# n <- nrow(data)
#
# }else{
# ffr <- interpret.gam(formula)
# varnames <- ffr$pred.names[1]
# if (":" %in% unlist(strsplit(ffr$fake.names,split = ""))) {
# stop("Argument \"formula\" is wrong specified, see details of
# model specification in 'Details' of the frfast help." )
# }
# if (length(ffr$smooth.spec) == 0) {
# warning("Argument \"formula\" could be wrong specified without an 's', see details of
# model specification in 'Details' of the frfast help." )
# }
#
# namef <- ffr$pred.names[2]
# if (length(ffr$pred.names) == 1) {f <- NULL}else{f <- data[ ,namef]}
# newdata <- data
#
# if (length(ffr$pred.names) == 1) {
# data <- data[ ,c(ffr$response, varnames)]
# }else{
# data <- data[ ,c(ffr$response, varnames, namef)]
# }
#
# if (na.action == "na.omit"){
# data <- na.omit(data)
# }else{
# stop("The actual version of the package only supports 'na.omit' (observations are removed
# if they contain any missing values)")
# }
#
# n <- nrow(data)
# }
#
#
#


if (is.null(f)) f <- rep(1, n)
Expand Down Expand Up @@ -305,8 +425,8 @@ localtest <- function(formula, data = data, na.action = "na.omit",

localtest <-.Fortran("localtest_",
f = as.integer(f),
x = as.double(data[,varnames]),
y = as.double(data[,ffr$response]),
x = as.double(data[ ,varnames]),
y = as.double(data[ ,response]),
w = as.double(weights),
n = as.integer(n),
h0 = as.double(h0),
Expand Down Expand Up @@ -357,7 +477,7 @@ localtest <- function(formula, data = data, na.action = "na.omit",
# grid
xgrid <- seq(min(data[ ,varnames]), max(data[ ,varnames]), length.out = kbin)
newd <- expand.grid(xgrid, unique(f))
names(newd) <- ffr$pred.names
names(newd) <- c(varnames, namef)

# estimations
p <- array(NA, dim = c(kbin, 3, nf))
Expand All @@ -379,7 +499,7 @@ localtest <- function(formula, data = data, na.action = "na.omit",
FUN.VALUE = numeric(kfino))

newdfino <- data.frame(as.vector(xgridfino), rep(unique(f), each = kfino))
names(newdfino) <- ffr$pred.names
names(newdfino) <- c(varnames, namef)

# max
muhatfino <- as.vector(predict(m, newdata = newdfino, type = "response"))
Expand Down Expand Up @@ -426,7 +546,7 @@ localtest <- function(formula, data = data, na.action = "na.omit",
# bootstrap
m <- gam(formula, weights = weights, data = data.frame(data, weights), ...)
muhat <- as.vector(predict(m, type = "response"))
err <- data[, ffr$response] - muhat
err <- data[, response] - muhat
err <- err - mean(err)
yboot <- replicate(nboot, muhat + err *
sample(c(-sqrt(5) + 1, sqrt(5) + 1)/2, size = n,
Expand All @@ -436,7 +556,7 @@ localtest <- function(formula, data = data, na.action = "na.omit",
i <- NULL
d_allboot <- foreach(i = 1:nboot) %dopar% {
datab <- data
datab[, ffr$response] <- yboot[, i]
datab[, response] <- yboot[, i]
aux <- mainfun_localtest(formula, data = data.frame(datab, weights),
weights = weights, ...)
return(aux)
Expand Down

0 comments on commit 22c3d8a

Please sign in to comment.