source: trunk/lang/R/RpLibraryRInterface.cc @ 2661

Last change on this file since 2661 was 2661, checked in by dkearney, 13 years ago

initial code for R bindings
File size: 16.5 KB
Line 
1/*
2 * ----------------------------------------------------------------------
3 *  INTERFACE: Fortran Rappture Library Source
4 *
5 * ======================================================================
6 *  AUTHOR:  Derrick Kearney, Purdue University
7 *  Copyright (c) 2005-2011  Purdue Research Foundation
8 *
9 *  See the file "license.terms" for information on usage and
10 *  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 * ======================================================================
12 */
13
14#include "RpLibrary.h"
15#include "RpBindingsDict.h"
16
17#include <R.h>
18#include <Rinternals.h>
19
20#ifdef __cplusplus
21extern "C" {
22#endif
23
24static void
25rp_lib_finalizer(SEXP ptr)
26{
27    RpLibrary* lib = NULL;
28    if (!R_ExternalPtrAddr(ptr)) {
29        return;
30    }
31    lib = (RpLibrary *) R_ExternalPtrAddr(ptr);
32    if (lib != NULL) {
33        delete lib;
34        lib = NULL;
35    }
36    R_ClearExternalPtr(ptr);
37
38}
39
40
41
42/**********************************************************************/
43// FUNCTION: rp_lib(const char* filePath, int handle)
44/// Open the file at 'filePath' and return Rappture Library Object.
45/**
46 */
47
48SEXP
49RPRLib(SEXP fname)
50{
51    RpLibrary* lib = NULL;
52    int handle = -1;
53    SEXP ans, ptr;
54
55    ans = allocVector(INTSXP,1);
56    PROTECT(ans);
57    INTEGER(ans)[0] = -1;
58
59    if (!isString(fname) || length(fname) != 1) {
60        error("fname is not a single string");
61        UNPROTECT(1);
62        return ans;
63    }
64
65    // create a RapptureIO object and store in dictionary
66    lib = new RpLibrary(CHAR(STRING_ELT(fname, 0)));
67    if (lib == NULL) {
68        error("could not allocate new RpLibrary object");
69        UNPROTECT(1);
70        return ans;
71    }
72
73    ptr = R_MakeExternalPtr((void *)lib,install("RapptureLib"),R_NilValue);
74    PROTECT(ptr);
75    R_RegisterCFinalizerEx(ptr, rp_lib_finalizer, TRUE);
76
77    handle = storeObject_Void((void*)lib);
78
79    INTEGER(ans)[0] = handle;
80    UNPROTECT(2);
81
82    return(ans);
83}
84
85/**********************************************************************/
86// FUNCTION: RPRLibGetString()
87/// Get data located at 'path' and return it as a string value.
88/**
89 */
90SEXP
91RPRLibGetString(
92    SEXP handle,            // integer handle of library
93    SEXP path)              // null terminated path
94{
95    RpLibrary* lib = NULL;
96    SEXP ans;
97    int handleVal = -1;
98    std::string data;
99
100    ans = allocVector(STRSXP,1);
101    PROTECT(ans);
102
103    SET_STRING_ELT(ans,0,mkChar(""));
104
105    if (!isInteger(handle) || length(handle) != 1) {
106        error("handle is not an integer");
107        UNPROTECT(1);
108        return ans;
109    }
110
111    if (!isString(path) || length(path) != 1) {
112        error("path is not a string");
113        UNPROTECT(1);
114        return ans;
115    }
116
117    handleVal = asInteger(handle);
118
119    if (handleVal == 0) {
120        error("invalid handle");
121        UNPROTECT(1);
122        return ans;
123    }
124
125    lib = (RpLibrary*) getObject_Void(handleVal);
126
127    if (lib == NULL) {
128        error("invalid Rappture Library Object");
129        UNPROTECT(1);
130        return ans;
131    }
132
133    data = lib->getString(CHAR(STRING_ELT(path, 0)));
134
135    SET_STRING_ELT(ans, 0, mkChar(data.c_str()));
136
137    UNPROTECT(1);
138
139    return ans;
140}
141
142
143/**********************************************************************/
144// FUNCTION: RPRLibGetDouble()
145/// Get data located at 'path' and return it as a double precision value.
146/**
147 */
148SEXP
149RPRLibGetDouble(
150    SEXP handle,            // integer handle of library
151    SEXP path)              // null terminated path
152{
153    RpLibrary* lib = NULL;
154    SEXP ans;
155    int handleVal = -1;
156    double data;
157
158    ans = allocVector(REALSXP,1);
159    PROTECT(ans);
160
161    REAL(ans)[0] = 0.0;
162
163    if (!isInteger(handle) || length(handle) != 1) {
164        error("handle is not a single integer");
165        UNPROTECT(1);
166        return ans;
167    }
168
169    if (!isString(path) || length(path) != 1) {
170        error("path is not a string");
171        UNPROTECT(1);
172        return ans;
173    }
174
175    handleVal = asInteger(handle);
176
177    if (handleVal == 0) {
178        error("invalid handle");
179        UNPROTECT(1);
180        return ans;
181    }
182
183    lib = (RpLibrary*) getObject_Void(handleVal);
184
185    if (lib == NULL) {
186        error("invalid Rappture Library Object");
187        UNPROTECT(1);
188        return ans;
189    }
190
191    data = lib->getDouble(CHAR(STRING_ELT(path, 0)));
192
193    REAL(ans)[0] = data;
194
195    UNPROTECT(1);
196
197    return ans;
198}
199
200
201/**********************************************************************/
202// FUNCTION: RPRLibInteger()
203/// Get data located at 'path' and return it as an integer value.
204/**
205 */
206SEXP
207RPRLibGetInteger(
208    SEXP handle,            // integer handle of library
209    SEXP path)              // null terminated path
210{
211    RpLibrary* lib = NULL;
212    SEXP ans;
213    int handleVal = -1;
214    int data;
215
216    ans = allocVector(INTSXP,1);
217    PROTECT(ans);
218
219    INTEGER(ans)[0] = 0;
220
221    if (!isInteger(handle) || length(handle) != 1) {
222        error("handle is not a single integer");
223        UNPROTECT(1);
224        return ans;
225    }
226
227    if (!isString(path) || length(path) != 1) {
228        error("path is not a string");
229        UNPROTECT(1);
230        return ans;
231    }
232
233    handleVal = asInteger(handle);
234
235    if (handleVal == 0) {
236        error("invalid handle");
237        UNPROTECT(1);
238        return ans;
239    }
240
241    lib = (RpLibrary*) getObject_Void(handleVal);
242
243    if (lib == NULL) {
244        error("invalid Rappture Library Object");
245        UNPROTECT(1);
246        return ans;
247    }
248
249    data = lib->getInt(CHAR(STRING_ELT(path, 0)));
250
251    INTEGER(ans)[0] = data;
252
253    UNPROTECT(1);
254
255    return ans;
256}
257
258
259/**********************************************************************/
260// FUNCTION: RPRLibGetBoolean()
261/// Get data located at 'path' and return it as an integer value.
262/**
263 */
264SEXP
265RPRLibGetBoolean(
266    SEXP handle,            // integer handle of library
267    SEXP path)              // null terminated path
268{
269    RpLibrary* lib = NULL;
270    SEXP ans;
271    int handleVal = -1;
272    bool data;
273
274    ans = allocVector(LGLSXP,1);
275    PROTECT(ans);
276
277    LOGICAL(ans)[0] = false;
278
279    if (!isInteger(handle) || length(handle) != 1) {
280        error("handle is not a single integer");
281        UNPROTECT(1);
282        return ans;
283    }
284
285    if (!isString(path) || length(path) != 1) {
286        error("path is not a string");
287        UNPROTECT(1);
288        return ans;
289    }
290
291    handleVal = asInteger(handle);
292
293    if (handleVal == 0) {
294        error("invalid handle");
295        UNPROTECT(1);
296        return ans;
297    }
298
299    lib = (RpLibrary*) getObject_Void(handleVal);
300
301    if (lib == NULL) {
302        error("invalid Rappture Library Object");
303        UNPROTECT(1);
304        return ans;
305    }
306
307    data = lib->getBool(CHAR(STRING_ELT(path, 0)));
308
309    LOGICAL(ans)[0] = data;
310
311    UNPROTECT(1);
312
313    return ans;
314}
315
316
317/**********************************************************************/
318// FUNCTION: RPRLibGetFile()
319/// Get data located at 'path' and write it to the file 'fileName'.
320/**
321 * Returns if any bytes were written to the file
322 */
323SEXP
324RPRLibGetFile (
325    SEXP handle,            // integer handle of library
326    SEXP path,              // null terminated path
327    SEXP fileName)          // name of file to write data to
328{
329    RpLibrary* lib = NULL;
330    SEXP ans;
331    int handleVal = -1;
332    int nbytes = 0;
333
334    ans = allocVector(INTSXP,1);
335    PROTECT(ans);
336
337    INTEGER(ans)[0] = -1;
338
339    if (!isInteger(handle) || length(handle) != 1) {
340        error("handle is not a single integer");
341        UNPROTECT(1);
342        return ans;
343    }
344
345    if (!isString(path) || length(path) != 1) {
346        error("path is not a string");
347        UNPROTECT(1);
348        return ans;
349    }
350
351    if (!isString(fileName) || length(fileName) != 1) {
352        error("fileName is not a string");
353        UNPROTECT(1);
354        return ans;
355    }
356
357    handleVal = asInteger(handle);
358
359    if (handleVal == 0) {
360        error("invalid handle");
361        UNPROTECT(1);
362        return ans;
363    }
364
365    lib = (RpLibrary*) getObject_Void(handleVal);
366
367    if (lib == NULL) {
368        error("invalid Rappture Library Object");
369        UNPROTECT(1);
370        return ans;
371    }
372
373    nbytes = lib->getFile(  CHAR(STRING_ELT(path, 0)),
374                            CHAR(STRING_ELT(fileName, 0)));
375
376    INTEGER(ans)[0] = nbytes;
377
378    UNPROTECT(1);
379
380    return ans;
381}
382
383
384
385/**********************************************************************/
386// FUNCTION: RPRLibPutString()
387/// Put string into Rappture Library Object at location 'path'.
388/**
389 */
390SEXP
391RPRLibPutString(
392    SEXP handle,
393    SEXP path,
394    SEXP value,
395    SEXP append)
396{
397    RpLibrary* lib = NULL;
398    SEXP ans;
399    int handleVal = -1;
400    int nbytes = 0;
401    unsigned int appendVal;
402
403    ans = allocVector(INTSXP,1);
404    PROTECT(ans);
405
406    INTEGER(ans)[0] = -1;
407
408    if (!isInteger(handle) || length(handle) != 1) {
409        error("handle is not an integer");
410        UNPROTECT(1);
411        return ans;
412    }
413
414    if (!isString(path) || length(path) != 1) {
415        error("path is not a string");
416        UNPROTECT(1);
417        return ans;
418    }
419
420    if (!isString(value) || length(value) != 1) {
421        error("value is not a string");
422        UNPROTECT(1);
423        return ans;
424    }
425
426    if (!isLogical(append) || length(append) != 1) {
427        error("append is not a logical");
428        UNPROTECT(1);
429        return ans;
430    }
431
432    handleVal = asInteger(handle);
433
434    if (handleVal == 0) {
435        error("invalid handle");
436        UNPROTECT(1);
437        return ans;
438    }
439
440    lib = (RpLibrary*) getObject_Void(handleVal);
441
442    if (lib == NULL) {
443        error("invalid Rappture Library Object");
444        UNPROTECT(1);
445        return ans;
446    }
447
448    appendVal = asLogical(append);
449    if (appendVal == 1) {
450        appendVal = RPLIB_APPEND;
451    } else if (appendVal == 0) {
452        appendVal = RPLIB_OVERWRITE;
453    } else {
454        // NA_LOGICAL was returned?
455        error("invalid append value");
456        UNPROTECT(1);
457        return ans;
458    }
459
460    lib->put(CHAR(STRING_ELT(path, 0)),
461             CHAR(STRING_ELT(value, 0)),
462             "",
463             appendVal,
464             RPLIB_TRANSLATE);
465
466
467    INTEGER(ans)[0] = 1;
468
469    UNPROTECT(1);
470
471    return ans;
472}
473
474
475/**********************************************************************/
476// FUNCTION: RPRLibPutData()
477/// Put string into Rappture Library Object at location 'path'.
478/**
479 */
480/*
481SEXP
482RPRLibPutData(
483    SEXP handle,
484    SEXP path,
485    SEXP bytes,
486    SEXP nbytes,
487    SEXP append)
488{
489    RpLibrary* lib = NULL;
490    SEXP ans;
491    int handleVal = -1;
492    int nbytes = 0;
493    unsigned int appendVal;
494
495    ans = allocVector(INTSXP,1);
496    PROTECT(ans);
497
498    INTEGER(ans)[0] = -1;
499
500    if (!isInteger(handle) || length(handle) != 1) {
501        error("handle is not an integer");
502        UNPROTECT(1);
503        return ans;
504    }
505
506    if (!isString(path) || length(path) != 1) {
507        error("path is not a string");
508        UNPROTECT(1);
509        return ans;
510    }
511
512    if (!isString(bytes) || length(bytes) != 1) {
513        error("bytes is not a string");
514        UNPROTECT(1);
515        return ans;
516    }
517
518    if (!isInteger(nbytes) || length(nbytes) != 1) {
519        error("nbytes is not an integer");
520        UNPROTECT(1);
521        return ans;
522    }
523
524    if (!isLogical(append) || length(append) != 1) {
525        error("append is not a logical");
526        UNPROTECT(1);
527        return ans;
528    }
529
530    handleVal = asInteger(handle);
531
532    if (handleVal == 0) {
533        error("invalid handle");
534        UNPROTECT(1);
535        return ans;
536    }
537
538    lib = (RpLibrary*) getObject_Void(handleVal);
539
540    if (lib == NULL) {
541        error("invalid Rappture Library Object");
542        UNPROTECT(1);
543        return ans;
544    }
545
546    if (asLogical(append)) {
547        appendVal = RPLIB_APPEND;
548    } else {
549        appendVal = RPLIB_OVERWRITE;
550    }
551
552    lib->putData(CHAR(STRING_ELT(path, 0)),
553                 CHAR(STRING_ELT(value, 0)),
554                 INTEGER(nbytes),
555                 appendVal);
556
557    INTEGER(ans)[0] = 1;
558
559    UNPROTECT(1);
560
561    return ans;
562}
563*/
564
565/**********************************************************************/
566// FUNCTION: RPRLibPutDouble()
567/// Put double value into Rappture Library Object at location 'path'.
568/**
569 */
570SEXP
571RPRLibPutDouble(
572    SEXP handle,
573    SEXP path,
574    SEXP value,
575    SEXP append)
576{
577    RpLibrary* lib = NULL;
578    SEXP ans;
579    int handleVal = -1;
580    int nbytes = 0;
581    unsigned int appendVal;
582
583    ans = allocVector(INTSXP,1);
584    PROTECT(ans);
585
586    INTEGER(ans)[0] = -1;
587
588    if (!isInteger(handle) || length(handle) != 1) {
589        error("handle is not an integer");
590        UNPROTECT(1);
591        return ans;
592    }
593
594    if (!isString(path) || length(path) != 1) {
595        error("path is not a string");
596        UNPROTECT(1);
597        return ans;
598    }
599
600    if (!isReal(value) || length(value) != 1) {
601        error("value is not a real");
602        UNPROTECT(1);
603        return ans;
604    }
605
606    if (!isLogical(append) || length(append) != 1) {
607        error("append is not a logical");
608        UNPROTECT(1);
609        return ans;
610    }
611
612    handleVal = asInteger(handle);
613
614    if (handleVal == 0) {
615        error("invalid handle");
616        UNPROTECT(1);
617        return ans;
618    }
619
620    lib = (RpLibrary*) getObject_Void(handleVal);
621
622    if (lib == NULL) {
623        error("invalid Rappture Library Object");
624        UNPROTECT(1);
625        return ans;
626    }
627
628    appendVal = asLogical(append);
629    if (appendVal == 1) {
630        appendVal = RPLIB_APPEND;
631    } else if (appendVal == 0) {
632        appendVal = RPLIB_OVERWRITE;
633    } else {
634        // NA_LOGICAL was returned?
635        error("invalid append value");
636        UNPROTECT(1);
637        return ans;
638    }
639
640    lib->put(CHAR(STRING_ELT(path, 0)),
641             asReal(value),
642             "",
643             appendVal);
644
645    INTEGER(ans)[0] = 1;
646
647    UNPROTECT(1);
648
649    return ans;
650}
651
652
653/**********************************************************************/
654// FUNCTION: RPRLibPutFile()
655/// Put double value into Rappture Library Object at location 'path'.
656/**
657 */
658SEXP
659RPRLibPutFile(
660    SEXP handle,
661    SEXP path,
662    SEXP fname,
663    SEXP compress,
664    SEXP append)
665{
666    RpLibrary* lib = NULL;
667    SEXP ans;
668    int handleVal = -1;
669    unsigned int appendVal;
670    unsigned int compressVal;
671
672    ans = allocVector(INTSXP,1);
673    PROTECT(ans);
674
675    INTEGER(ans)[0] = -1;
676
677    if (!isInteger(handle) || length(handle) != 1) {
678        error("handle is not an integer");
679        UNPROTECT(1);
680        return ans;
681    }
682
683    if (!isString(path) || length(path) != 1) {
684        error("path is not a string");
685        UNPROTECT(1);
686        return ans;
687    }
688
689    if (!isString(fname) || length(fname) != 1) {
690        error("fileName is not a string");
691        UNPROTECT(1);
692        return ans;
693    }
694
695    if (!isLogical(compress) || length(compress) != 1) {
696        error("compress is not a logical");
697        UNPROTECT(1);
698        return ans;
699    }
700
701    if (!isLogical(append) || length(append) != 1) {
702        error("append is not a logical");
703        UNPROTECT(1);
704        return ans;
705    }
706
707    handleVal = asInteger(handle);
708
709    if (handleVal == 0) {
710        error("invalid handle");
711        UNPROTECT(1);
712        return ans;
713    }
714
715    lib = (RpLibrary*) getObject_Void(handleVal);
716
717    if (lib == NULL) {
718        error("invalid Rappture Library Object");
719        UNPROTECT(1);
720        return ans;
721    }
722
723    compressVal = asLogical(compress);
724    if (compressVal == 1) {
725        compressVal = RPLIB_COMPRESS;
726    } else {
727        compressVal = RPLIB_NO_COMPRESS;
728    }
729
730    appendVal = asLogical(append);
731    if (appendVal == 1) {
732        appendVal = RPLIB_APPEND;
733    } else {
734        appendVal = RPLIB_OVERWRITE;
735    }
736
737    lib->putFile(CHAR(STRING_ELT(path, 0)),
738                 CHAR(STRING_ELT(fname,0)),
739                 compressVal,
740                 appendVal);
741
742    INTEGER(ans)[0] = 1;
743
744    UNPROTECT(1);
745
746    return ans;
747}
748
749/**********************************************************************/
750// FUNCTION: rp_result()
751/// Write xml text to a run.xml file and signal the program has completed
752/**
753 */
754SEXP
755RPRLibResult(
756    SEXP handle)
757{
758    RpLibrary* lib = NULL;
759    SEXP ans;
760    int handleVal = -1;
761
762    ans = allocVector(INTSXP,1);
763    PROTECT(ans);
764
765    INTEGER(ans)[0] = -1;
766
767    if (!isInteger(handle) || length(handle) != 1) {
768        error("handle is not an integer");
769        UNPROTECT(1);
770        return ans;
771    }
772
773    handleVal = asInteger(handle);
774
775    if (handleVal == 0) {
776        error("invalid handle");
777        UNPROTECT(1);
778        return ans;
779    }
780
781    lib = (RpLibrary*) getObject_Void(handleVal);
782
783    if (lib == NULL) {
784        error("invalid Rappture Library Object");
785        UNPROTECT(1);
786        return ans;
787    }
788
789    lib->put("tool.version.rappture.language", "R");
790    lib->result();
791
792    INTEGER(ans)[0] = 1;
793
794    UNPROTECT(1);
795
796    return ans;
797}
798
799#ifdef __cplusplus
800}
801#endif // ifdef __cplusplus
802
Note: See TracBrowser for help on using the repository browser.