1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
|
##' Generic method for removing elements of object
##'
##' @title Remove variables from (model) object.
##' @aliases rmvar rmvar<- kill kill<-
##' @param x Model object
##' @param value Vector of variables or formula specifying which nodes to
##' remove
##' @param \dots additional arguments to lower level functions
##' @usage
##' rmvar(x, ...) <- value
##' @seealso \code{cancel}
##' @author Klaus K. Holst
##' @keywords models regression
##' @export
##' @examples
##' m <- lvm()
##' addvar(m) <- ~y1+y2+x
##' covariance(m) <- y1~y2
##' regression(m) <- c(y1,y2) ~ x
##' ### Cancel the covariance between the residuals of y1 and y2
##' cancel(m) <- y1~y2
##' ### Remove y2 from the model
##' rmvar(m) <- ~y2
##'
"rmvar" <- function(x, ...) UseMethod("rmvar")
##' @export
"kill" <- function(x, ...) UseMethod("kill")
##' @export
"kill<-" <- function(x, ..., value) UseMethod("kill<-")
##' @export
"rmvar<-" <- function(x, ..., value) UseMethod("rmvar<-")
##' @export
"kill<-.lvm" <- function(x, ..., value) {
kill(x,value)
}
##' @export
"rmvar<-.lvm" <- get("kill<-.lvm")
##' @export
"kill.lvm" <- function(x, value, ...) {
if (inherits(value,"formula")) value <- all.vars(value)
idx <- which(names(x$exfix)%in%value)
if (length(idx)>0) {
x$attributes$parameter[idx] <- x$expar[idx] <- x$exfix[idx] <- NULL
if (length(x$exfix)==0) {
x$exfix <- x$expar <- x$attributes$parameter <- NULL
}
index(x) <- reindex(x)
}
idx <- which(vars(x)%in%value)
if (length(idx)!=0){
vv <- vars(x)[idx]
keep <- setdiff(seq_along(vars(x)),idx)
x$M <- x$M[keep,keep,drop=FALSE]
x$par <- x$par[keep,keep,drop=FALSE]
x$fix <- x$fix[keep,keep,drop=FALSE]
x$covpar <- x$covpar[keep,keep,drop=FALSE]
x$covfix <- x$covfix[keep,keep,drop=FALSE]
x$cov <- x$cov[keep,keep,drop=FALSE]
x$mean <- (x$mean)[-idx]
x$exogenous <- setdiff(exogenous(x),vv)
x$latent[vv] <- NULL
} else{ ## remove variables that cannot be accessed by vars in the hook
vv <- value
}
myhooks <- gethook("remove.hooks")
for (f in myhooks) {
x <- do.call(f, list(x=x,var=vv,...))
}
index(x) <- reindex(x)
return(x)
}
##' @export
"rmvar.lvm" <- get("kill.lvm")
|
