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
|
fnchk <- function(xpar, ffn, trace=0, ... ) {
# fnchk <- function(xpar, ffn, cctrl=list(trace=0), ... )
# A function to check the nonlinear optimization file that is "ffn", with gradient gr
# The intention is to automatically test the gradient, hessian, Jacobian, Jacobian second derivatives,
# as well as bounds
#
# This function can take-in multiple starting values
#
# Input:
# xpar = a vector of starting values (may be scaled)
# ffn = objective function (assumed to be sufficiently differentiable). May be created by setup program.
# cctrl = a list of control information FOR THE CHECKING PROGRAM. See Details.
# The name has been changed from control to avoid confusion with control list in optim/optimx
# ... = other arguments to the function identified by fname
#
# NOTE: bounds do NOT appear here.
#
# Output:
# fval
# infeasible
# excode
# msg
#
# Author: John Nash
# Date: Sept 18, 2011, mod July 2015
#################################################################
maxard10<-function(one, two) {
# get max abs relative difference scaled by 10.0 in denominator
# This internal function is used to make comparisons using a
# relative difference, but avoiding zero divide
result<-max(abs((one-two)/(abs(one)+abs(two)+10.0)))
return(result)
}
#########
if (trace > 2) {
cat("fnchk: ffn =\n")
print(ffn)
cat("fnchk: xpar:")
print(xpar)
cat("fnchk: dots:")
print(list(...))
}
infeasible<-FALSE # set value OK, then alter if not feasible later
excode <- 0 # ditto
msg <- "fnchk OK" # ditto
if (trace > 1) {
cat("about to call ffn(xpar, ...)\n")
cat("ffn:")
print(ffn)
cat("xpar & dots:")
print(xpar)
print(list(...))
}
test<-try(fval<-ffn(xpar, ...)) # !! KEY LINE
if (trace > 1) {
cat("test in fnchk:")
print(test)
}
# Note: This incurs one EXTRA function evaluation because optimx wraps other methods
if (inherits(test, "try-error") ) {
fval<-NA
attr(fval, "inadmissible")<-TRUE
}
if (trace > 0) {
cat("Function value at supplied parameters =")
print(fval) # Use "print" rather than "cat" to allow extra structure to be displayed
print(str(fval))
print(is.vector(fval))
}
if (!is.null(attr(fval,"inadmissible")) && (attr(fval, "inadmissible"))) {
infeasible <- TRUE
excode <- -1
msg <- "Function evaluation returns INADMISSIBLE"
if (trace > 0) cat(msg,"\n")
}
# Also check that it is returned as a scalar
if (is.vector(fval)) {
if (length(fval)>1) { # added 120411
excode <- -4
msg <- "Function evaluation returns a vector not a scalar"
fval <- NA # and force to NA to control possible later actions
infeasible <- TRUE
if (trace > 0) cat(msg,"\n")
}
}
if (is.list(fval)) {
excode <- -4
msg <- "Function evaluation returns a list not a scalar"
fval <- NA # and force to NA to control possible later actions
infeasible <- TRUE
if (trace > 0) cat(msg,"\n")
}
if (is.matrix(fval)) {
excode <- -4
msg <- "Function evaluation returns a matrix list not a scalar"
fval <- NA # and force to NA to control possible later actions
infeasible <- TRUE
if (trace > 0) cat(msg,"\n")
}
if (is.array(fval)) {
excode <- -4
msg <- "Function evaluation returns an array not a scalar"
fval <- NA # and force to NA to control possible later actions
infeasible <- TRUE
if (trace > 0) cat(msg,"\n")
}
if ((length(fval)!=1) && !(is.vector(fval))) { #this may never get executed
excode <- -4
msg <- "Function returned not length 1, despite not vector, matrix or array"
fval <- NA # and force to NA to control possible later actions
infeasible <- TRUE
if (trace > 0) cat(msg,"\n")
}
if ( ! (is.numeric(fval)) ) {
excode <- -1
msg <- "Function evaluation returned non-numeric value"
fval <- NA # and force to NA to control possible later actions
infeasible <- TRUE
if (trace > 0) cat(msg,"\n")
}
if (is.infinite(fval) || is.na(fval)) {
excode <- -1
msg <- "Function evaluation returned Inf or NA (non-computable)"
infeasible <- TRUE
if (trace > 0) cat(msg,"\n")
}
if (trace > 0) cat("Function at given point=",fval,"\n")
answer <- list(fval=fval, infeasible=infeasible, excode=excode, msg=msg)
}
### end of fnchk ***
|
