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
|
hesschk <- function(xpar, ffn, ggr, hhess, trace=0, testtol=(.Machine$double.eps)^(1/3), ...) {
# check Hessian code in hess for function in fn and gradient in gr
asymtol<-testtol # ?? may want to change this
hessOK<-FALSE
if (is.null(hhess)) {
attr(hessOK, "nullhess")<-TRUE
attr(hessOK, "asym")<-NA
attr(hessOK, "ha")<-NA
attr(hessOK, "hn")<-NA
msg<-"Analytic Hessian not made available."
attr(hessOK, "msg")<-msg
if (trace > 0) cat(msg,"\n")
} else {
attr(hessOK, "nullhess")<-FALSE
hname <- deparse(substitute(hhess))
if (trace > 0) cat("Analytic hessian from function ",hname,"\n\n")
ha <- hhess(xpar, ... ) # analytic hessian
# if (attr(ha,"inadmissible")) {
# msg<-"Analytic Hessian inadmissible."
# attr(hessOK, "msg")<-msg
# if (trace > 0) cat(msg,"\n")
# }
if (is.null(ggr)) {
hn <- hessian(func=ffn, x=xpar, ...)
} else {
hn <- jacobian(func=ggr, x=xpar, ...)
}
asym<-0.0 # to ensure defined
if (!isSymmetric(hn)) {
asym <- sum(abs(t(hn) - hn))/sum(abs(hn))
asw <- paste("hn from hess() is reported non-symmetric with asymmetry ratio ",
asym, sep = "")
if (trace > 0) cat(asw, "\n")
else warning(asw)
if (asym > asymtol) {
msg<-"Analytic Hessian not symmetric."
attr(hessOK, "msg")<-msg
if (trace > 0) cat(msg,"\n")
} else hessOK <- TRUE
hn <- 0.5 * (t(hn) + hn)
} # end if ! isSymmetric
# Now test for equality ?? again have to consider tolerance
fval<-ffn(xpar, ...) # Could consider providing this externally
if (max(abs(hn-ha))/(1 + abs(fval)) >= testtol) {
hessOK<-FALSE
msg<-paste("Analytic Hessian and numeric Hessian differ more than ", testtol,"")
attr(hessOK, "msg")<-msg
if (trace > 0) cat(msg,"\n")
}
attr(hessOK, "asym")<-asym
attr(hessOK, "ha")<-ha
attr(hessOK, "hn")<-hn
} # end gradient/hessian tests
hessOK
}
## >>> End of code common to funtest, funcheck and optimx, with mods for local needs
|
