SCM

SCM Repository

[lspm] Annotation of /pkg/src/objectiveFunction.c
ViewVC logotype

Annotation of /pkg/src/objectiveFunction.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 52 - (view) (download) (as text)

1 : bodanker 50 /*
2 :     #
3 :     # LSPM: The Leverage Space Portfolio Modeler
4 :     #
5 :     # Copyright (C) 2009-2010 Soren Macbeth, Joshua Ulrich, and Ralph Vince
6 :     #
7 :     # This program is free software: you can redistribute it and/or modify
8 :     # it under the terms of the GNU General Public License as published by
9 :     # the Free Software Foundation, either version 3 of the License, or
10 :     # (at your option) any later version.
11 :     #
12 :     # This program is distributed in the hope that it will be useful,
13 :     # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     # GNU General Public License for more details.
16 :     #
17 :     # You should have received a copy of the GNU General Public License
18 :     # along with this program. If not, see <http://www.gnu.org/licenses/>.
19 :     #
20 :     */
21 :    
22 :     #include <R.h>
23 :     #include <Rinternals.h>
24 :     #include "lspm.h"
25 :    
26 :     SEXP objFun_optimalf ( SEXP f, SEXP lsp, SEXP margin, SEXP equity,
27 :     SEXP constrFun, SEXP constrVal, SEXP env )
28 :     {
29 :     int P=0;
30 :    
31 : bodanker 52 double *d_fval = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
32 :     double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;
33 : bodanker 50
34 : bodanker 52 double *d_f = REAL(PROTECT(AS_NUMERIC(f))); P++;
35 :     double *d_margin, d_equity, maxU; /* -Wall */
36 :    
37 : bodanker 50 int len = length(f);
38 :    
39 :     /* is changing 'lsp' stupid / dangerous? */
40 :     for(int i=0; i < len; i++) {
41 :     d_fval[i] = d_f[i];
42 :     }
43 :    
44 :     SEXP s_ghpr, s_cval, fcall;
45 :     /* Calculate GHPR */
46 :     PROTECT(s_ghpr = ghpr(lsp)); P++;
47 : bodanker 52 double d_ghpr = -asReal(s_ghpr);
48 : bodanker 50
49 :     if(d_ghpr < -1) {
50 :     /* Margin constraint */
51 :     if( !isNull(margin) && !isNull(equity) ) {
52 :    
53 : bodanker 52 d_margin = REAL(PROTECT(AS_NUMERIC(margin))); P++;
54 :     d_equity = asReal(equity);
55 : bodanker 50
56 :     maxU = 0;
57 :     for(int i=0; i < len; i++) {
58 :     maxU += d_f[i] * d_margin[i] / -d_maxloss[i];
59 :     }
60 :     maxU *= d_equity;
61 :    
62 :     if(maxU > d_equity) {
63 :     d_ghpr = R_PosInf;
64 :     }
65 :     } /* Margin constraint */
66 :    
67 :     /* Constraint function */
68 :     if( !isNull(constrFun) ) {
69 :    
70 :     if( !isFunction(constrFun) )
71 :     error("constrFun is not a function");
72 :    
73 :     PROTECT(fcall = lang3(constrFun, lsp, R_DotsSymbol)); P++;
74 :     PROTECT(s_cval = eval(fcall, env)); P++;
75 :    
76 : bodanker 52 if( asReal(s_cval) >= asReal(constrVal) ) {
77 : bodanker 50 d_ghpr = R_PosInf;
78 :     }
79 :     }
80 :     } else {
81 :     d_ghpr = R_PosInf;
82 :     }
83 :    
84 :     UNPROTECT(P);
85 :     return(ScalarReal(d_ghpr));
86 :     }
87 :    

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge