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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
nnls <- function(A, b) {
if(anyNA(A) || anyNA(b))
stop("NA in input.")
if(any(is.nan(A)) || any(is.nan(b)))
stop("NaN in input.")
if(is.null(A) || is.null(b))
stop("NULL in input.")
if(any(is.infinite(A)) || any(is.infinite(b)))
stop("Infinite value in input.")
if(!(length(b) == nrow(A)))
stop("Arguments `A' and `b' have incompatible dimensions.")
MDA <- M <- nrow(A)
N <- ncol(A)
RNORM <- MODE <- NSETP <- 0
W <- INDEX <- X <- rep(0, N)
ZZ <- rep(0, M)
sol <- .Fortran("nnls", A = as.numeric(A), MDA = as.integer(MDA), M =
as.integer(M), N = as.integer(N), B = as.numeric(b),
X = as.numeric(X), RNORM = as.numeric(RNORM), W =
as.numeric(W), ZZ = as.numeric(ZZ), INDEX =
as.integer(INDEX), MODE = as.integer(MODE),
NSETP = as.integer(NSETP), PACKAGE="nnls")
fitted <- A %*% sol$X
resid <- b - fitted
index <- sol$INDEX
nsetp <- sol$NSETP
if(nsetp > 0)
passive <- index[1:nsetp]
else passive <- vector()
if(nsetp == N)
bound <- vector()
else
bound <- index[(nsetp+1):N]
nnls.out <- list(x=sol$X, deviance=sol$RNORM^2,
residuals=resid, fitted = fitted,mode=sol$MODE,
passive = passive, bound = bound, nsetp = nsetp)
class(nnls.out) <- "nnls"
nnls.out
}
nnnpls <- function(A, b, con) {
if(anyNA(A) || anyNA(b))
stop("NA in input.")
if(any(is.nan(A)) || any(is.nan(b)))
stop("NaN in input.")
if(is.null(A) || is.null(b))
stop("NULL in input.")
if(any(is.infinite(A)) || any(is.infinite(b)))
stop("Infinite value in input.")
if(!(length(b) == nrow(A)))
stop("Arguments `A' and `b' have incompatible dimensions.")
if(!(length(con) == ncol(A)))
stop("Argument `con' has wrong length.")
MDA <- M <- nrow(A)
N <- ncol(A)
RNORM <- MODE <- NSETP <- 0
W <- INDEX <- X <- rep(0, N)
ZZ <- rep(0, M)
sol <- .Fortran("nnnpls", A = as.numeric(A), MDA = as.integer(MDA), M =
as.integer(M), N = as.integer(N),
CON = as.numeric(con),
B = as.numeric(b),
X = as.numeric(X),
RNORM = as.numeric(RNORM), W =
as.numeric(W), ZZ = as.numeric(ZZ), INDEX =
as.integer(INDEX), MODE = as.integer(MODE),
NSETP = as.integer(NSETP), PACKAGE="nnls")
fitted <- A %*% sol$X
resid <- b - fitted
index <- sol$INDEX
nsetp <- sol$NSETP
if(nsetp > 0)
passive <- index[1:nsetp]
else passive <- vector()
if(nsetp == N)
bound <- vector()
else
bound <- index[(nsetp+1):N]
nnnpls.out <- list(x=sol$X, deviance=sol$RNORM^2,
residuals=resid, fitted = fitted,mode=sol$MODE,
passive = passive, bound = bound, nsetp = nsetp)
class(nnnpls.out) <- "nnnpls"
nnnpls.out
}
print.nnnpls <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
cat("Nonnegative-nonpositive least squares model\n")
cat("x estimates:", x$x, "\n")
cat("residual sum-of-squares: ", format(x$deviance, digits = digits),
"\n", sep = '')
stopmess <- switch(x$mode, "The solution has been computed sucessfully.",
"The dimensions of the problem are bad",
"Iteration count exceded. More than 3*N iterations.")
cat("reason terminated: ", stopmess, "\n", sep='')
invisible(x)
}
print.nnls <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
cat("Nonnegative least squares model\n")
cat("x estimates:", x$x, "\n")
cat("residual sum-of-squares: ", format(x$deviance, digits = digits),
"\n", sep = '')
stopmess <- switch(x$mode, "The solution has been computed sucessfully.",
"The dimensions of the problem are bad",
"Iteration count exceded. More than 3*N iterations.")
cat("reason terminated: ", stopmess, "\n", sep='')
invisible(x)
}
residuals.nnls <- residuals.nnnpls <- function(object, ...) object$residuals
coef.nnls <- coef.nnnpls <- function(object, ...) object$x
fitted.nnls <- fitted.nnnpls <- function(object, ...) object$fitted
deviance.nnls <- deviance.nnnpls <- function(object, ...) object$deviance
|
