#include #include #include #include namespace rstpm2 { using namespace arma; using namespace Rcpp; aft::aft(SEXP sexp) : ConstrBFGSx() { args = as(sexp); init = as(args("init")); X_vector = as>(args("X_list")); X_vector0 = as>(args("X_list0")); X = as(args("X")); XD = as(args("XD")); X0 = as(args("X0")); XD0 = as(args("XD0")); Xc = as(args("Xc")); gnodes = as(args("gnodes")); gweights = as(args("gweights")); bhazard = as(args("bhazard")); event = as(args("event")); time = as(args("time")); time0 = as(args("time0")); boundaryKnots = as(args("boundaryKnots")); interiorKnots = as(args("interiorKnots")); q_matrix = as(args("q.const")); cure = as(args("cure")); mixture = as(args("mixture")); tvc_integrated = as(args("tvc.integrated")); add_penalties = as(args("add.penalties")); s = ns(boundaryKnots, interiorKnots, q_matrix, 1, cure); kappa = 1.0e3; eps1 = 1.0e-100; delayed = arma::find(time0>0.0); } mat aft::rmult(mat m, vec v) { mat out(m); out.each_col() %= v; return out; } mat aft::rmult(mat m, uvec v) { mat out(m); out.each_col() %= conv_to::from(v); return out; } double aft::objective(vec betafull) { if (tvc_integrated==1) return objective_integrated(betafull); else return objective_cumulative(betafull); } vec aft::gradient(vec betafull) { if (tvc_integrated==1) return gradient_integrated(betafull); else return gradient_cumulative(betafull); } double aft::objective_integrated(vec betafull) { vec beta, betac, betas, etac; if (mixture) { beta = betafull.subvec(0,X.n_cols-1); betac = betafull.subvec(X.n_cols, X.n_cols + Xc.n_cols - 1); betas = betafull.subvec(X.n_cols+Xc.n_cols, betafull.size()-1); } else { beta = betafull.subvec(0,X.n_cols-1); betas = betafull.subvec(X.n_cols, betafull.size()-1); } vec tstar = time*0.0; vec scale = time/2.0; // Can this be done more efficiently using a cube? for(size_t i=0; i0.0) ll=-100.0; return -ll; } double aft::objective_cumulative(vec betafull) { vec beta, betac, betas, etac; if (mixture) { beta = betafull.subvec(0,X.n_cols-1); betac = betafull.subvec(X.n_cols, X.n_cols + Xc.n_cols - 1); betas = betafull.subvec(X.n_cols+Xc.n_cols, betafull.size()-1); } else { beta = betafull.subvec(0,X.n_cols-1); betas = betafull.subvec(X.n_cols, betafull.size()-1); } vec eta = X * beta; vec etaD = XD * beta; vec logtstar = log(time) - eta; vec etas = s.basis(logtstar) * betas; vec etaDs = s.basis(logtstar,1) * betas; vec etaDs_old = etaDs; // fix bounds on etaDs vec eps = etaDs*0. + eps1; double pens = dot(min(etaDs,eps), min(etaDs,eps)); etaDs = max(etaDs, eps); // replacement // fix bounds on etaD double pen = dot(min(1.0-etaD,eps), min(1-etaD,eps)); etaD = 1.0 - max(1.0-etaD, eps); // replacement // add penalty for monotone splines vec betasStar = s.q_matrix.t() * betas; for (size_t i=1; i(wrap(betafull))); } NumericVector aft::gradient(NumericVector betafull) { vec value = gradient(as(wrap(betafull))); return as(wrap(value)); } // vec aft::survival(vec time, mat X) { // vec beta = init.subvec(0,X.n_cols-1); // vec betas = init.subvec(X.n_cols,init.size()-1); // vec eta = X * beta; // vec logtstar = log(time) - eta; // vec etas = s.basis(logtstar) * betas; // vec S = exp(-exp(etas)); // return S; // } // vec aft::haz(vec time, mat X, mat XD) // { // vec beta = init.subvec(0,X.n_cols-1); // vec betas = init.subvec(X.n_cols,init.size()-1); // vec eta = X * beta; // vec etaD = XD * beta; // vec logtstar = log(time) - eta; // mat Xs = s.basis(logtstar); // mat XDs = s.basis(logtstar,1); // mat XDDs = s.basis(logtstar,2); // vec etas = Xs * betas; // vec etaDs = XDs * betas; // vec etaDDs = XDDs * betas; // // penalties // vec eps = etaDs*0. + eps1; // uvec pindexs = (etaDs < eps); // uvec pindex = ((1.0/time - etaD) < eps); // // fix bounds on etaDs // etaDs = max(etaDs, eps); // // fix bounds on etaD // etaD = 1/time - max(1/time-etaD, eps); // vec logh = etas + log(etaDs) + log(1/time -etaD); // vec h = exp(logh); // return h; // } // mat aft::gradh(vec time, mat X, mat XD) // { // vec beta = init.subvec(0,X.n_cols-1); // vec betas = init.subvec(X.n_cols,init.size()-1); // vec eta = X * beta; // vec etaD = XD * beta; // vec logtstar = log(time) - eta; // mat Xs = s.basis(logtstar); // mat XDs = s.basis(logtstar,1); // mat XDDs = s.basis(logtstar,2); // vec etas = Xs * betas; // vec etaDs = XDs * betas; // vec etaDDs = XDDs * betas; // // penalties // vec eps = etaDs*0. + eps1; // uvec pindexs = (etaDs < eps); // uvec pindex = ((1.0/time - etaD) < eps); // // fix bounds on etaDs // etaDs = max(etaDs, eps); // // fix bounds on etaD // etaD = 1/time - max(1/time-etaD, eps); // vec logh = etas + log(etaDs) + log(1/time -etaD); // vec h = exp(logh); // mat dloghdbetas = Xs+rmult(XDs,1/etaDs % (1-pindexs)); // mat dloghdbeta = -rmult(X,etaDs % (1-pindexs) % (1-pindex)) - rmult(X,etaDDs/etaDs % (1-pindexs) % (1-pindex)) - rmult(XD, (1-pindexs) % (1-pindex)/(1/time-etaD)); // mat gradh = join_rows(rmult(dloghdbeta,h), rmult(dloghdbetas,h)); // return gradh; // } RcppExport SEXP aft_model_output(SEXP args) { aft model(args); List list = as(args); std::string return_type = as(list["return_type"]); if (return_type == "nmmin") { // model.pre_process(); NelderMead nm; nm.trace = as(list("trace")); nm.maxit = as(list("maxit")); nm.reltol = as(list("reltol")); NumericVector betafull = as(wrap(model.init)); nm.optim(betafull,model); // model.post_process(); return List::create(_("fail")=nm.fail, _("coef")=wrap(nm.coef), _("hessian")=wrap(nm.hessian)); } else if (return_type == "vmmin") { model.trace = as(list("trace")); model.maxit = as(list("maxit")); model.reltol = as(list("reltol")); NumericVector betafull = as(wrap(model.init)); model.optim(betafull); if (as(list("constrOptim"))) { betafull = as(wrap(model.coef)); // nudge this slightly... for (int i=0; i(list("ui")), as(list("ci")), 1.0e-10, 100, 1.0e-10); } // model.post_process(); return List::create(_("fail")=model.fail, _("coef")=wrap(model.coef), _("hessian")=wrap(model.hessian)); } // else if (return_type == "vmmin") { // // model.pre_process(); // BFGS bfgs; // bfgs.trace = as(list("trace")); // bfgs.maxit = as(list("maxit")); // bfgs.reltol = as(list("reltol")); // NumericVector betafull = as(wrap(model.init)); // bfgs.optim(betafull,model); // // model.post_process(); // return List::create(_("fail")=bfgs.fail, // _("coef")=wrap(bfgs.coef), // _("hessian")=wrap(bfgs.hessian)); // } else if (return_type == "objective") return wrap(model.objective(model.init)); else if (return_type == "gradient") return wrap(model.gradient(model.init)); // else if (return_type == "survival") // return wrap(model.survival(as(list("time")),as(list("X")))); // else if (return_type == "haz") // return wrap(model.haz(as(list("time")),as(list("X")),as(list("XD")))); // else if (return_type == "gradh") // return wrap(model.gradh(as(list("time")),as(list("X")),as(list("XD")))); else { REprintf("Unknown return_type.\n"); return wrap(-1); } } } // namespace rstpm2