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
|
##' Generic cancel method
##'
##' @title Generic cancel method
##' @param x Object
##' @param \dots Additioal arguments
##' @author Klaus K. Holst
##' @aliases cancel<-
##' @export
"cancel" <- function(x,...) UseMethod("cancel")
##' @export
"cancel<-" <- function(x,...,value) UseMethod("cancel<-")
##' @export
"cancel<-.lvm" <- function(x, ..., value) {
cancel(x,value,...)
}
##' @export
cancel.lvm <- function(x,value,...) {
if (inherits(value,"formula")) {
lhs <- getoutcome(value)
if (length(lhs)==0) yy <- NULL else yy <- decomp.specials(lhs)
xf <- attributes(terms(value))$term.labels
if(identical(all.vars(value),xf))
return(cancel(x,xf))
res <- lapply(xf,decomp.specials)
xx <- unlist(lapply(res, function(z) z[1]))
for (i in yy) {
for (j in xx)
cancel(x) <- c(i,j)
}
index(x) <- reindex(x)
return(x)
}
for (v1 in value)
for (v2 in value)
if (v1!=v2)
{
if (all(c(v1,v2)%in%vars(x))) {
x$M[v1,v2] <- 0
x$par[v1,v2] <- x$fix[v1,v2] <-
x$covpar[v1,v2] <- x$covfix[v1,v2] <- NA
x$cov[v1,v2] <- 0
}
}
x$parpos <- NULL
index(x) <- reindex(x)
return(x)
}
|
