← Back to branch summary

~ubuntu-branches/ubuntu/trusty/fportfolio/trusty

« back to all changes in this revision

Viewing changes to R/donlp2.R

  • Committer: Bazaar Package Importer
  • Author(s): Dirk Eddelbuettel
  • Date: 2008-12-04 11:36:54 UTC
  • mfrom: (1.1.6 upstream) (2.1.3 squeeze)
  • Revision ID: james.westby@ubuntu.com-20081204113654-gr832nfs44blp5ph
Tags: 280.74-1
* New upstream release
* Finally uploading as r-cran-rglpk is out of NEW after five weeks

* debian/control: Updated (Build-)Depends: and Suggests:

* debian/control: Set (Build-)Depends: to current R version
* debian/control: Set Standards-Version: to current version

Show diffs side-by-side

added added

removed removed

Lines of Context:
R/donlp2.R
1
 
 
2
 
 
3
 
# DW
4
 
# .onLoad <- function(libname, pkgname){
5
 
#   verbose <- .Options$Hverbose
6
 
#   if(!length(verbose) || verbose){
7
 
#     cat("Rdonlp2 - a wrapper library for \"DONLP2 (C) Peter Spellucci\"\n\n")
8
 
#   }
9
 
#   library.dynam("Rdonlp2", pkgname, libname)
10
 
#   invisible()
11
 
# }
12
 
 
13
 
 
14
 
# ------------------------------------------------------------------------------
15
 
 
16
 
 
17
 
rdonlp2Control <- 
18
 
function(            
19
 
    # setup
20
 
    iterma = 4000, nstep = 20,fnscale = 1,
21
 
    report = FALSE, rep.freq = 1,
22
 
    # perfomance and tunings
23
 
    tau0 = 1.0, tau = 0.1, del0 = 1.0,
24
 
    # termination criteria
25
 
    epsx = 1e-5, delmin = 0.1*del0,
26
 
    epsdif = 1e-8, nreset.multiplier = 1,
27
 
    # numerical differentiation
28
 
    difftype = 3, epsfcn = 1e-16, taubnd = 1.0,
29
 
    hessian = FALSE,
30
 
    # information
31
 
    te0 = TRUE, te1 = FALSE, te2 = FALSE, te3 = FALSE,
32
 
    silent = FALSE, intakt = TRUE )
33
 
{
34
 
    # FUNCTION:
35
 
    
36
 
    # Return Value:
37
 
    list(
38
 
        iterma = as.integer(iterma), 
39
 
        nstep = as.integer(nstep),
40
 
        fnscale = fnscale,
41
 
        report = report,
42
 
        rep.freq = as.integer(ifelse(rep.freq<1, 1, rep.freq)),
43
 
        tau0 = tau0, 
44
 
        tau = tau, 
45
 
        del0 = del0,
46
 
        epsx = epsx, 
47
 
        delmin = delmin, 
48
 
        epsdif = epsdif,
49
 
        nreset.multiplier = nreset.multiplier,
50
 
        difftype = as.integer(ifelse(!difftype%in%c(1,2,3), 3, difftype)),
51
 
        epsfcn = epsfcn, 
52
 
        taubnd = taubnd, 
53
 
        hessian = hessian,
54
 
        te0 = te0, 
55
 
        te1 = te1, 
56
 
        te2 = te2, 
57
 
        te3 = te3,
58
 
        silent = silent, 
59
 
        intakt = intakt)
60
 
}
61
 
 
62
 
 
63
 
# ------------------------------------------------------------------------------
64
 
 
65
 
 
66
 
rdonlp2 <- 
67
 
function(
68
 
    par, fn,
69
 
    par.upper = rep(+Inf, length(par)),
70
 
    par.lower = rep(-Inf, length(par)),
71
 
    
72
 
    A = NULL,
73
 
    lin.upper = rep(+Inf, length(par)),
74
 
    lin.lower = rep(-Inf, length(par)),
75
 
    
76
 
    nlin = list(),
77
 
    nlin.upper = rep(+Inf, length(nlin)),
78
 
    nlin.lower = rep(-Inf, length(nlin)),
79
 
    
80
 
    control = rdonlp2Control(),
81
 
    control.fun = function(lst){return(TRUE)},
82
 
    env = .GlobalEnv, name = NULL)
83
 
{
84
 
    
85
 
    # FUNCTION:
86
 
    
87
 
    # use analytical gradients?
88
 
    if (is.function(attr(fn, "gr")) &
89
 
        all(lapply(nlin, function(e)is.function(attr(e,"gr"))))){
90
 
        control["analyt"] = TRUE
91
 
    } else {
92
 
        control["analyt"] = FALSE
93
 
    }
94
 
  
95
 
    # check parameter and its box constraints
96
 
    if (length(par) != length(par.upper) | length(par) != length(par.lower) ){
97
 
        stop("# of elements for box constraints != # of parameters")
98
 
    }
99
 
 
100
 
    # check linear constraints matrix A
101
 
    if (is.null(A)){
102
 
        num.lin <- 0
103
 
        conmat <- c()
104
 
        lin.upper <- lin.lower <- c()
105
 
    } else {
106
 
        num.lin <- nrow(A)
107
 
        if (ncol(A) != length(par))
108
 
            stop("# of ncol(A) should be equal to # of par")
109
 
        if (length(lin.upper) != num.lin | length(lin.lower) != num.lin)
110
 
            stop("# of bounds for linear constraints should be equal to nrow(A)")
111
 
        conmat <- t(A)
112
 
    }
113
 
  
114
 
    # nonlinear constraints
115
 
    num.nlin <- length(nlin)
116
 
    if (length(nlin.upper)!=num.nlin | length(nlin.lower)!=num.nlin)
117
 
    stop("# of bounds for nonlinear constraints should be equal to length(nlin)")
118
 
    # concatenate bounds for internal use
119
 
    lbd <- c(par.lower, lin.lower, nlin.lower)
120
 
    ubd <- c(par.upper, lin.upper, nlin.upper)
121
 
    
122
 
    #
123
 
    # the wrapper for objective and constraint function 
124
 
    # (called from eval_extern())
125
 
    # mode == 0: EVAL_FN(evaluate objective and constraint function)
126
 
    # mode == 1: EVAL_GR(evaluate gr of objective and constraint function)
127
 
    #
128
 
    # fun.id == 0: evaluate objective function 'fn'
129
 
    # fun.id >= 1: evaluate constraint function 'nlin[[fun.id]]'
130
 
    #
131
 
    
132
 
    confun <- function(arg) {
133
 
        mode = arg[1]
134
 
        fun.id = arg[2]
135
 
        p = arg[c(-1,-2)]
136
 
        if (mode == 0){      # evaluate function values
137
 
            if (fun.id == 0){
138
 
                return(as.double(eval(fn(p), env)))
139
 
            }
140
 
            return(as.double(eval(nlin[[fun.id]](p), env)))
141
 
        } else if (mode == 1) { # evaluate gradient values
142
 
            if (fun.id == 0){
143
 
                return(as.double(eval(fn@gr(p), env)))
144
 
            }
145
 
            return(as.double(eval((nlin[[fun.id]]@gr)(p), env)))
146
 
        } else {
147
 
            stop("unknown evaluation mode: %d", mode)
148
 
        }
149
 
    } 
150
 
 
151
 
    # accfun
152
 
    accfun <- function(lst){
153
 
        return(as.logical(control.fun(lst)))
154
 
    }
155
 
    
156
 
    fsilent <- FALSE
157
 
    if (is.null(name)){
158
 
        fsilent <- TRUE
159
 
        name = "dummy"
160
 
    }
161
 
    
162
 
    # start donlp2
163
 
    tryCatch(
164
 
        # start donlp2
165
 
        ans <- .Call("call_donlp2",
166
 
            as.double(par),
167
 
            as.integer(num.lin),
168
 
            as.integer(num.nlin),
169
 
            fsilent,
170
 
            name,
171
 
            nchar(name),
172
 
            as.double(lbd), as.double(ubd),
173
 
            as.double(conmat),
174
 
            control,
175
 
            accfun,
176
 
            confun, environment(confun), 
177
 
            PACKAGE = "Rdonlp2"),
178
 
            # ensure to free memory and close .mes .pro files if opened
179
 
            finally=.Call("teardown", 0, 
180
 
            PACKAGE = "Rdonlp2"))
181
 
    ans$nr.update <- matrix(ans$nr.update, nr = length(par))
182
 
    if (control$hessian) {
183
 
        ans$hessian = matrix(ans$hessian, nr = length(par))
184
 
    } else {
185
 
        ans$hessian = NULL
186
 
    }
187
 
    
188
 
    # Return Value:
189
 
    ans
190
 
}
191
 
 
192
 
 
193
 
################################################################################
194