RiDMC/src/r_model.c

   1 /*
   2 ridmc: iDMC->R interface
   3
   4 Copyright (C) 2007 Marji Lines and Alfredo Medio.
   5
   6 Written by Antonio, Fabio Di Narzo <antonio.fabio@gmail.com>.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or any
  11 later version.
  12
  13 This program is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 Last modified: $Date: 2007-05-24 16:41:18 +0200 (gio, 24 mag 2007) $
  19 */
  20 #include "ridmc.h"
  21 #include <idmclib/model.h>
  22
  23 void ridmc_model_free(SEXP p);
  24
  25 SEXP ridmc_model_alloc(SEXP in_buf) {
  26         SEXP sxp_buf;
  27         SEXP ans;
  28         char *buf;
  29         char msg[IDMC_MAXSTRLEN];
  30         int buflen, ians;
  31         idmc_model *model;
  32         PROTECT( sxp_buf = coerceVector( in_buf, STRSXP ) );
  33         buf = (char*) CHAR( STRING_ELT(sxp_buf,0) );
  34         buflen = strlen(buf);
  35         ians = idmc_model_alloc(buf, buflen, &model);
  36         UNPROTECT(1);
  37         if(ians == IDMC_ELUASYNTAX) {
  38                 strcpy(msg, model->errorMessage);
  39                 idmc_model_free(model);
  40                 error("[idmclib error: %s] %s\n", idmc_err_message[ians], msg);
  41         } else if(ians != IDMC_OK)
  42                 RIDMC_GENERIC_ERROR(ians);
  43         PDEBUG("allocated model %p\n", model);
  44         PROTECT(ans = R_MakeExternalPtr(model, R_NilValue, R_NilValue));
  45         R_RegisterCFinalizer(ans, ridmc_model_free);
  46         UNPROTECT(1);
  47         return ans;
  48 }
  49
  50 void ridmc_model_free(SEXP p) {
  51         PDEBUG("deallocating model %p\n", R_ExternalPtrAddr(p));
  52         idmc_model_free( R_ExternalPtrAddr(p) );
  53 }
  54
  55 SEXP ridmc_model_clone(SEXP m) {
  56         SEXP ans;
  57         idmc_model* pans = idmc_model_clone(R_ExternalPtrAddr(m));
  58         PROTECT(ans = R_MakeExternalPtr(pans, R_NilValue, R_NilValue));
  59         R_RegisterCFinalizer(ans, ridmc_model_free);
  60         UNPROTECT(1);
  61         return ans;
  62 }
  63
  64 SEXP ridmc_model_f(SEXP m, SEXP par, SEXP var) {
  65         SEXP ans;
  66         PROTECT(ans = allocVector(REALSXP, length(var)) );
  67         int ians = idmc_model_f(R_ExternalPtrAddr(m),
  68                 REAL(par),
  69                 REAL(var),
  70                 REAL(ans));
  71         UNPROTECT(1);
  72         if(ians!=IDMC_OK)
  73                 RIDMC_ERROR(ians);
  74         return ans;
  75 }
  76 SEXP ridmc_model_g(SEXP m, SEXP par, SEXP var) {
  77         SEXP ans;
  78         PROTECT(ans = allocVector(REALSXP, length(var)) );
  79         int ians = idmc_model_g(R_ExternalPtrAddr(m),
  80                 REAL(par),
  81                 REAL(var),
  82                 REAL(ans));
  83         UNPROTECT(1);
  84         if(ians!=IDMC_OK)
  85                 RIDMC_ERROR(ians);
  86         return ans;
  87 }
  88
  89 SEXP ridmc_model_Jf(SEXP m, SEXP par, SEXP var) {
  90         SEXP ans;
  91         PROTECT( ans = allocVector(REALSXP, length(var) * length(var) ) );
  92         int ians = idmc_model_Jf(
  93                 R_ExternalPtrAddr(m),
  94                 REAL(par),
  95                 REAL(var),
  96                 REAL(ans));
  97         UNPROTECT(1);
  98         if(ians!=IDMC_OK)
  99                 RIDMC_ERROR(ians);
 100         return ans;
 101 }
 102
 103 SEXP ridmc_model_Jg(SEXP m, SEXP par, SEXP var) {
 104         SEXP ans;
 105         PROTECT( ans = allocVector(REALSXP, length(var) * length(var) ) );
 106         int ians = idmc_model_Jg(
 107                 R_ExternalPtrAddr(m),
 108                 REAL(par),
 109                 REAL(var),
 110                 REAL(ans));
 111         UNPROTECT(1);
 112         if(ians!=IDMC_OK)
 113                 RIDMC_ERROR(ians);
 114         return ans;
 115 }
 116
 117 SEXP ridmc_model_NumJf(SEXP m, SEXP par, SEXP var) {
 118         SEXP ans;
 119         double *util;
 120         int nvar = length(var);
 121         PROTECT( ans = allocVector(REALSXP, nvar * nvar ) );
 122         util = (double*) R_alloc( 3 * nvar, sizeof(double) );
 123         int ians = idmc_model_NumJf(
 124                 R_ExternalPtrAddr(m),
 125                 REAL(par),
 126                 REAL(var),
 127                 REAL(ans),
 128                 util, util+nvar, util + (2*nvar));
 129         UNPROTECT(1);
 130         if(ians!=IDMC_OK)
 131                 RIDMC_ERROR(ians);
 132         return ans;
 133 }
 134
 135 SEXP ridmc_model_setGslRngSeed(SEXP m, SEXP seed) {
 136         int ians = idmc_model_setGslRngSeed(R_ExternalPtrAddr(m), INTEGER(seed)[0]);
 137         if(ians!=IDMC_OK)
 138                 RIDMC_ERROR(ians);
 139         return R_NilValue;
 140 }
 141
 142 /*
 143 Get a list filled with model infos
 144 */
 145 SEXP ridmc_model_getInfos(SEXP m) {
 146         SEXP ans, strings, flags, lens, parNames, varNames;
 147         int i;
 148         idmc_model *pm = (idmc_model*) R_ExternalPtrAddr(m);
 149         PROTECT(ans = allocVector(VECSXP, 5));
 150         PROTECT(strings = allocVector(STRSXP, 3));
 151         PROTECT(flags = allocVector(INTSXP, 2));
 152         PROTECT(lens = allocVector(INTSXP, 2) );
 153         SET_STRING_ELT( strings, 0, mkChar(pm->name));
 154         SET_STRING_ELT( strings, 1, mkChar(pm->desc));
 155         SET_STRING_ELT( strings, 2, mkChar(pm->type));
 156         INTEGER(flags)[0] = pm->has_inverse;
 157         INTEGER(flags)[1] = pm->has_jacobian;
 158         INTEGER(lens)[0] = pm->par_len;
 159         INTEGER(lens)[1] = pm->var_len;
 160         PROTECT(parNames = allocVector(STRSXP, pm->par_len) );
 161         for(i=0; i<pm->par_len; i++)
 162                 SET_STRING_ELT( parNames, i, mkChar(pm->par[i]));
 163         PROTECT(varNames = allocVector(STRSXP, pm->var_len) );
 164         for(i=0; i<pm->var_len; i++)
 165                 SET_STRING_ELT( varNames, i, mkChar(pm->var[i]));
 166         SET_VECTOR_ELT(ans, 0, strings);
 167         SET_VECTOR_ELT(ans, 1, flags);
 168         SET_VECTOR_ELT(ans, 2, lens);
 169         SET_VECTOR_ELT(ans, 3, parNames);
 170         SET_VECTOR_ELT(ans, 4, varNames);
 171         UNPROTECT(6);
 172         return ans;
 173 }