ugr: Wrapper for user gradient function for optimization tools

Description Usage Arguments Details Value Examples

View source: R/ugr.R

Description

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.

Usage

1
ugr(par, fnuser)

Arguments

par

A vector of parameters to the user-supplied function fn

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).

Details

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.

Value

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.

Examples

  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")

optfntools documentation built on May 2, 2019, 4:26 p.m.