File: etsTargetFunctionWrapper.cpp

package info (click to toggle)
r-cran-forecast 8.13-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 2,248 kB
  • sloc: cpp: 975; ansic: 648; sh: 13; makefile: 2
file content (180 lines) | stat: -rw-r--r-- 4,786 bytes parent folder | download
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
171
172
173
174
175
176
177
178
179
180

#include <vector>
#include <string>

#include <R_ext/Error.h>

//For R's Nelder-Mead solver
#include <R_ext/Applic.h>

#include <Rcpp.h>

#include "etsTargetFunction.h"

// This function initializes all the parameters, constructs an
// object of type EtsTargetFunction and adds an external pointer
// to this object with name "ets.xptr"
// to the environment submitted as p_rho
//
RcppExport SEXP etsTargetFunctionInit(SEXP p_y, SEXP p_nstate, SEXP p_errortype, SEXP p_trendtype,
		SEXP p_seasontype, SEXP p_damped, SEXP p_lower, SEXP p_upper,
		SEXP p_opt_crit, SEXP p_nmse, SEXP p_bounds, SEXP p_m,
		SEXP p_optAlpha, SEXP p_optBeta, SEXP p_optGamma, SEXP p_optPhi,
		SEXP p_givenAlpha, SEXP p_givenBeta, SEXP p_givenGamma, SEXP p_givenPhi,
		SEXP p_alpha, SEXP p_beta, SEXP p_gamma, SEXP p_phi, SEXP p_rho) {

	BEGIN_RCPP;

	EtsTargetFunction* sp = new EtsTargetFunction();

	std::vector<double> y = Rcpp::as< std::vector<double> >(p_y);

	int nstate = Rcpp::as<int>(p_nstate);

	int errortype = Rcpp::as<int>(p_errortype);
	int trendtype = Rcpp::as<int>(p_trendtype);
	int seasontype = Rcpp::as<int>(p_seasontype);

	bool damped = Rcpp::as<bool>(p_damped);

	std::vector<double> lower = Rcpp::as< std::vector<double> >(p_lower);
	std::vector<double> upper = Rcpp::as< std::vector<double> >(p_upper);

	std::string opt_crit = Rcpp::as<std::string>(p_opt_crit);
	int nmse = Rcpp::as<int>(p_nmse);

	std::string bounds = Rcpp::as< std::string >(p_bounds);
	int m = Rcpp::as<int>(p_m);

	bool optAlpha = Rcpp::as<bool>(p_optAlpha);
	bool optBeta = Rcpp::as<bool>(p_optBeta);
	bool optGamma = Rcpp::as<bool>(p_optGamma);
	bool optPhi = Rcpp::as<bool>(p_optPhi);

	bool givenAlpha = Rcpp::as<bool>(p_givenAlpha);
	bool givenBeta = Rcpp::as<bool>(p_givenBeta);
	bool givenGamma = Rcpp::as<bool>(p_givenGamma);
	bool givenPhi = Rcpp::as<bool>(p_givenPhi);

	double alpha = Rcpp::as<double>(p_alpha);
	double beta = Rcpp::as<double>(p_beta);
	double gamma = Rcpp::as<double>(p_gamma);
	double phi = Rcpp::as<double>(p_phi);


	sp->init(y, nstate, errortype, trendtype, seasontype, damped, lower, upper, opt_crit,
			nmse, bounds, m, optAlpha, optBeta, optGamma, optPhi,
			givenAlpha, givenBeta, givenGamma, givenPhi,
			alpha, beta, gamma, phi);

	Rcpp::Environment e(p_rho);
	e["ets.xptr"] = Rcpp::XPtr<EtsTargetFunction>( sp, true );

	return Rcpp::wrap(e);

	END_RCPP;
}

// RcppExport double targetFunctionRmalschains(SEXP p_par, SEXP p_env)
// {
// 	Rcpp::NumericVector par(p_par);

// 	Rcpp::Environment e(p_env);
// 	Rcpp::XPtr<EtsTargetFunction> sp(e.get("ets.xptr"));

// 	sp->eval(par.begin(), par.size());

// 	//return Rcpp::wrap(sp->getObjVal());
// 	return sp->getObjVal();

// }

// RcppExport SEXP etsGetTargetFunctionRmalschainsPtr() {

// 	typedef double (*funcPtr)(SEXP, SEXP);
// 	return (Rcpp::XPtr<funcPtr>(new funcPtr(&targetFunctionRmalschains)));
// }

/*
RcppExport SEXP targetFunctionRdonlp2(SEXP p_var, SEXP p_env)
{

	Rcpp::Environment e(p_env);
	Rcpp::XPtr<EtsTargetFunction> sp(e.get("ets.xptr"));

	Rcpp::NumericVector var(p_var);

	int mode = var[0];
	int fun_id = var[1];

	sp->eval(var.begin()+2, var.size()-2);

	if(mode == 0) {
		if(fun_id == 0) {
			return Rcpp::wrap(sp->getObjVal());
		} else {
			return Rcpp::wrap(0);
			//return Rcpp::wrap(sp->restrictions[fun_id-1]);
		}
	} else if(mode==1) {
		//		error("Gradients are not implemented, exiting.");
	};

	return R_NilValue;
}

RcppExport SEXP etsGetTargetFunctionRdonlp2Ptr() {

	typedef SEXP (*funcPtr)(SEXP, SEXP);
	return (Rcpp::XPtr<funcPtr>(new funcPtr(&targetFunctionRdonlp2)));
}
*/


double targetFunctionEtsNelderMead(int n, double *par, void *ex)
{
	EtsTargetFunction* sp = (EtsTargetFunction*) ex;

	sp->eval(par, n);
	return sp->getObjVal();

}


RcppExport SEXP etsNelderMead(SEXP p_var, SEXP p_env, SEXP p_abstol,
		SEXP p_intol, SEXP p_alpha, SEXP p_beta, SEXP p_gamma,
		SEXP p_trace, SEXP p_maxit)
{

	double abstol = Rcpp::as<double>(p_abstol);
	double intol = Rcpp::as<double>(p_intol);
	double alpha = Rcpp::as<double>(p_alpha);
	double beta= Rcpp::as<double>(p_beta);
	double gamma= Rcpp::as<double>(p_gamma);

	int trace = Rcpp::as<int>(p_trace);
	int maxit = Rcpp::as<int>(p_maxit);

	int fncount = 0, fail=0;
	double Fmin = 0.0;

	Rcpp::NumericVector dpar(p_var);
	Rcpp::NumericVector opar(dpar.size());

	Rcpp::Environment e(p_env);
	Rcpp::XPtr<EtsTargetFunction> sp(e.get("ets.xptr"));

	double (*funcPtr)(int n, double *par, void *ex) = targetFunctionEtsNelderMead;

	nmmin(dpar.size(), dpar.begin(), opar.begin(), &Fmin, funcPtr,
			&fail, abstol, intol, sp, alpha, beta, gamma, trace, &fncount, maxit);

	return Rcpp::List::create(Rcpp::Named("value") = Fmin,
			Rcpp::Named("par") = opar,
			Rcpp::Named("fail") = fail,
			Rcpp::Named("fncount") = fncount);

}