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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
## optimx-package.R
## This file contains support routines (methods) for the optimx() function
##################################################################
summary.opm <- summary.optimx <- function(object, order = NULL, par.select = TRUE, ...) {
# internally object is referred to as x and par.select as par
x <- object
par <- par.select
# first npar columns of object are the parameters
npar <- attr(x,"npar")
if (is.character(par)) {
idx <- which(par %in% names(x))
} else if (is.logical(par)) {
idx <- which(rep(par, length = npar))
} else if (is.numeric(par)) {
idx <- intersect(par, seq_len(npar))
} else stop("par.select must be character, logical or numeric")
selidx <- union(idx, (npar+1):ncol(x))
x <- x[, selidx]
# xx same as x except:
# - it has a rownames column
# - it has a natural column reflecting the input ordering
# - if objective maximized then value column negated
xx <- cbind(rownames = rownames(x), x, natural=1:nrow(x))
maximize <- attr(x,"maximize")
if (maximize) xx$value <- - xx$value
# try to evaluate order using standard evaluation
order.try <- try(order, silent = TRUE)
# did it work?
if (is.null(order.try)) order.try <- "natural"
e <- if (!inherits(order.try, "try-error") && is.character(order.try)) {
# if all components are names then convert to a string
if (all(order.try %in% names(xx))) {
order.try <- paste0("list(", toString(order.try), ")")
}
# order.try is now the string representation of an R expression
# so parse it
e <- parse(text = order.try)
} else substitute(order)
# perform non-standard evaluation (as in transform and subset functions)
order. <- eval(e, xx, parent.frame())
# ensure order. is a list
if (!is.list(order.)) order. <- list(order.)
o <- do.call(base::order, order.)
x <- x[o, ]
# ensure details attribute corresponds to data
attr(x, "details") <- attr(x, "details")[rownames(x), ]
x
}
##################################################################
coef.opm <- coef.optimx <- function(object, ...) {
npar <- attr(object, "npar")
ix <- seq_len(npar)
cc <- object[, ix]
attr(cc,"details") <- NULL
attr(cc,"maximize") <- NULL
attr(cc,"npar") <- NULL
## attr(cc,"follow.on") <- NULL # leave follow.on?
cc<-as.matrix(cc) # coerce to matrix to accord with other uses 130406
cc
}
"coef<-" <- function(x, value) UseMethod("coef<-")
"coef<-.opm" <- "coef<-.optimx" <- function(x, value) {
npar <- attr(x, "npar")
ix <- seq_len(npar)
structure(cbind(value, x[, -ix, drop = FALSE]),
npar = NCOL(value),
class = class(x))
}
"[.opm" <- "[.optimx" <- function(x, ...) {
xx <- NextMethod()
if (is.data.frame(xx)) {
details <- attr(x, "details")
# temporarily convert to data.frame so missing ..1 acts as
# in data frames rather than as in matrices
if (is.matrix(details)) details <-
as.matrix(as.data.frame(details)[..1, , drop=FALSE])
structure(xx,
details = details,
maximize = attr(x, "maximize"),
npar = attr(x, "npar"),
class = class(x))
} else xx
}
##################################################################
as.data.frame.opm <- as.data.frame.optimx <- function(x, row.names = NULL, optional = FALSE, ...) {
result <- do.call(data.frame, as.list(x))
rownames(result) <- if (is.null(row.names)) rownames(x) else row.names
result # NOTE: seems "details" are stripped away
}
##################################################################
scalecheck<-function(par, lower=lower, upper=upper,dowarn){
# a function to check the initial parameters and bounds for inputs to optimization codes
# Arguments:
# par -- starting parameters supplied
# lower, upper -- lower and upper bounds supplied
#
# Returns:
# list(lpratio, lbratio) -- the log of the ratio of largest to smallest parameters
# and bounds intervals (upper-lower) in absolute value (ignoring Inf, NULL, NA)
######################################
if (is.null(par)) { stop("Null parameter vector") }
npar<-length(par)
if (is.null(lower)) {
if (dowarn) warning("Null lower bounds vector")
lower<-rep(-Inf,npar)
}
if (is.null(upper)) {
if (dowarn) warning("Null upper bounds vector")
upper<-rep(Inf,npar)
}
newpar<-abs(par[which(is.finite(par))])
logpar<-log10(newpar[which(newpar>0)]) # Change 20100711
newlower<-abs(lower[which(is.finite(lower))])
loglower<-log10(newlower[which(newlower>0)]) # Change 20100711
newupper<-abs(upper[which(is.finite(upper))])
logupper<-log10(newupper[which(newupper>0)]) # Change 20100711
bddiff<-upper-lower
bddiff<-bddiff[which(is.finite(bddiff))]
lbd<-log10(bddiff[which(bddiff>0)]) # Change 20100711
lpratio<-max(logpar) - min(logpar)
if (length(lbd) > 0) {
lbratio<-max(lbd)-min(lbd)
} else {
lbratio<-NA
}
ratios<-list(lpratio=lpratio,lbratio=lbratio)
# return(ratios)
}
# -------------- end scalecheck ----------------- #
#################################################################
|
