Description Usage Arguments Details Value Examples
Provides a wrapper around user gradient function for nonlinear optimization to try to control for inadmissible arguments to user objective, gradient or hessian functions, as well as provide for maximization.
1 |
par |
A vector of parameters to the user-supplied function |
fnuser |
A user-supplied function object that has three sub-functions fn, gr, and hess. fn generates the scalar numerical value of the objective function, gr its vector valued gradient (or is NULL) and hess a numerical matrix for the Hessian (or is NULL). |
The usual dot arguments (...) are subsumed in fnuser$dots to save complexity in the function call. Note that we need to unlist() these is the call to the actual user function.
ugr
returns a vector numeric value, but all elements are set to the R
constant .Machine$double.xmax if the inputs to the function are inadmissible and the
computation of gr
fails. The returned value has an attribute
inadmissible
which is returned TRUE in this case, but otherwise
is FALSE.
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 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | cat("Show how ugr works\n")
cat("matrix function\n")
aa<-matrix(c(2,1,1,2),nrow=2)
myxp<-function(par, A=NULL){
if(is.null(A))stop("MUST have matrix A")
f<-as.numeric((t(par) %*% A) %*% par)+(as.numeric(crossprod(par))-1)^2
}
myxpg<-function(par, A=NULL){
if(is.null(A))stop("MUST have matrix A")
gg<-2.0*as.vector(A %*% par)+4.0*(as.numeric(crossprod(par))-1)*par
}
npar<-2
opxfn<-list2env(list(fn=myxp, gr=myxpg, hess=NULL, MAXIMIZE=FALSE, PARSCALE=rep(1,npar), FNSCALE=1,
KFN=0, KGR=0, KHESS=0, dots=list(A=aa)))
x0<-c(1,1)
g0<-myxpg(x0, A=aa)
print(g0)
cat("using numDeriv on myxp\n")
gn<-grad(myxp, x0, A=aa)
print(gn)
cat("using ugr with myxpg\n")
g0u<-ugr(x0,opxfn)
print(g0u)
rm(opxfn)
cat("using ugr with numderiv \"grnd\"\n")
opxfn<-list2env(list(fn=myxp, gr="grnd", hess=NULL, MAXIMIZE=FALSE, PARSCALE=rep(1,npar), FNSCALE=1,
KFN=0, KGR=0, KHESS=0, dots=list(A=aa)))
g0un<-ugr(x0,opxfn)
print(g0un)
tmp<-readline("next")
rm(opxfn)
cat("=====================================\n\n")
badlogf<-function(x, skale=10){
# cat("in badlogf, skale=",skale,"\n")
sq<-seq(1:length(x))
r<-(10-x)^2 + skale*log(x-sq)
f<-as.double(crossprod(r))
} # note that this will fail when length(x)>x for some element of x
badlogg<-function(x, skale=10){# This is the gradient of badlogf
sq<-seq(1:length(x))
r<-(10-x)^2 + skale*log(x-sq)
g<-2*r*(-2*(10-x)+skale/(x-sq))
} # note that this will fail when length(x)>x for some element of x
#badlogh<-function(x, skale=10){
# sq<-seq(1:length(x))
# r<-(10-x)^2 + skale*log(x-sq)
# H<-r%*%t(r) # WRONG!
# 2*r*(-2*(10-x)+skale/(x-sq))
## NOT YET SET UP PROPERLY #
#} # note that this will fail when length(x)>x for some element of x
x0<-rep(20, 4)
npar<-4
opxfn<-list2env(list(fn=badlogf, gr=badlogg, hess=NULL, MAXIMIZE=FALSE, PARSCALE=rep(1,npar), FNSCALE=1,
KFN=0, KGR=0, KHESS=0, dots=NULL))
ps1<-rep(1,4)
cat("skale= NULL, parameters:")
print(x0)
cat("Calling analytical badlogg:")
gval0<-badlogg(x0)
print(gval0)
gvalu<-ugr(x0, opxfn)
cat("result:")
print(gvalu)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grfwd"
gvalunf<-ugr(x0, opxfn)
cat("result from grfwd:")
print(gvalunf)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grcentral"
gvalunc<-ugr(x0, opxfn)
cat("result from grcentral:")
print(gvalunc)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grback"
gvalunb<-ugr(x0, opxfn)
cat("result from grback:")
print(gvalunb)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grnd"
gvalund<-ugr(x0, opxfn)
cat("result from grnd:")
print(gvalund)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
cat("======================================\n")
tmp<-readline("change parameter scaling")
x0<-rep(20, 4)
npar<-4
opxfn<-list2env(list(fn=badlogf, gr=badlogg, hess=NULL, MAXIMIZE=FALSE, PARSCALE=rep(1,npar), FNSCALE=1,
KFN=0, KGR=0, KHESS=0, dots=NULL))
ps1<-1/(1:4)
opxfn$PARSCALE<-ps1
cat("skale= NULL, parameters:")
print(x0)
cat("parscale:")
print(ps1)
cat("and in opxfn:")
print(opxfn$PARSCALE)
cat("Calling badlogg function:\n")
gval0<-badlogg(x0)
print(gval0)
cat("grad on badlogf:\n")
print(grad(badlogf,x0))
x0s<-x0/ps1
cat("x0s:")
print(x0s)
gvalu<-ugr(x0s, opxfn)
cat("result of ugr:\n")
print(gvalu)
cat("rescaled:")
print(gvalu/ps1)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grfwd"
gvalunf<-ugr(x0s, opxfn)
cat("result from grfwd:")
print(gvalunf)
cat("rescaled:")
print(gvalunf/ps1)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grcentral"
gvalunc<-ugr(x0s, opxfn)
cat("result from grcentral:")
print(gvalunc)
cat("rescaled:")
print(gvalunc/ps1)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grback"
gvalunb<-ugr(x0s, opxfn)
cat("result from grback:")
print(gvalunb)
cat("rescaled:")
print(gvalunb/ps1)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
opxfn$gr<-"grnd"
gvalund<-ugr(x0s, opxfn)
cat("result from grnd:")
print(gvalund)
cat("rescaled:")
print(gvalund/ps1)
cat("counter: kfn=",opxfn$KFN," kgr=",opxfn$KGR,"\n")
cat("======================================\n")
|
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.