Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Develop data #2

Merged
merged 9 commits into from
Oct 30, 2017
Merged

Develop data #2

Changes from 1 commit
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
929cb64
modification in the explanation of the argument data (help file frfas…
sestelo Oct 30, 2017
50e4ad6
changes in the data argument (now you can ommit it)
sestelo Oct 30, 2017
99933f7
best output of allotest
sestelo Oct 30, 2017
1d18aaf
nothing important
sestelo Oct 30, 2017
22c3d8a
changed the data argument, now you can ommit it
sestelo Oct 30, 2017
34ed96e
changes in data argument help file
sestelo Oct 30, 2017
9f35a91
return to the previous version of globaltest with only one test stati…
sestelo Oct 30, 2017
d53763d
changes at data argument
sestelo Oct 30, 2017
20afed0
minor changes: version, date and news file
sestelo Oct 30, 2017
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
changed the data argument, now you can ommit it
  • Loading branch information
@sestelo
sestelo committed Oct 30, 2017
commit 22c3d8afcedc637df1d9e231394f76ee777acc7d
178 changes: 149 additions & 29 deletions R/localtest.R
View file
Open in desktop
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