Rcpp Version 0.12.12
r_cast.h
Go to the documentation of this file.
1 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
2 //
3 // rcast.h: Rcpp R/C++ interface class library -- cast from one SEXP type to another
4 //
5 // Copyright (C) 2010 - 2017 Dirk Eddelbuettel and Romain Francois
6 //
7 // This file is part of Rcpp.
8 //
9 // Rcpp is free software: you can redistribute it and/or modify it
10 // under the terms of the GNU General Public License as published by
11 // the Free Software Foundation, either version 2 of the License, or
12 // (at your option) any later version.
13 //
14 // Rcpp is distributed in the hope that it will be useful, but
15 // WITHOUT ANY WARRANTY; without even the implied warranty of
16 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 // GNU General Public License for more details.
18 //
19 // You should have received a copy of the GNU General Public License
20 // along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
21 
22 #ifndef Rcpp_rcast_h
23 #define Rcpp_rcast_h
24 
25 #include <Rcpp/exceptions.h>
26 
27 namespace Rcpp {
28  namespace internal {
29 
30  inline SEXP convert_using_rfunction(SEXP x, const char* const fun) { // #nocov start
31  Armor<SEXP> res;
32  try{
33  SEXP funSym = Rf_install(fun);
34  res = Rcpp_eval(Rf_lang2(funSym, x));
35  } catch( eval_error& e) {
36  const char* fmt = "Could not convert using R function: %s.";
37  throw not_compatible(fmt, fun);
38  }
39  return res; // #nocov end
40  }
41 
42  // r_true_cast is only meant to be used when the target SEXP type
43  // is different from the SEXP type of x
44  template <int TARGET>
45  SEXP r_true_cast( SEXP x) {
46 
47  const char* fmt = "Not compatible conversion to target: "
48  "[type=%s; target=%s].";
49 
50  throw not_compatible(fmt,
51  Rf_type2char(TYPEOF(x)),
52  Rf_type2char(TARGET));
53 
54  return x; // makes solaris happy
55  }
56 
57  template <int RTYPE>
58  SEXP basic_cast( SEXP x) { // #nocov start
59  if( TYPEOF(x) == RTYPE ) return x;
60  switch( TYPEOF(x) ){
61  case REALSXP:
62  case RAWSXP:
63  case LGLSXP:
64  case CPLXSXP:
65  case INTSXP:
66  return Rf_coerceVector(x, RTYPE);
67  default:
68  const char* fmt = "Not compatible with requested type: "
69  "[type=%s; target=%s].";
70  throw ::Rcpp::not_compatible(fmt,
71  Rf_type2char(TYPEOF(x)),
72  Rf_type2char(RTYPE));
73  } // #nocov end
74  return R_NilValue; /* -Wall */
75  }
76 
77  template<>
78  inline SEXP r_true_cast<INTSXP>(SEXP x){
79  return basic_cast<INTSXP>(x);
80  }
81  template<>
82  inline SEXP r_true_cast<REALSXP>(SEXP x){ // #nocov
83  return basic_cast<REALSXP>(x); // #nocov
84  }
85  template<>
86  inline SEXP r_true_cast<RAWSXP>(SEXP x){
87  return basic_cast<RAWSXP>(x);
88  }
89  template<>
90  inline SEXP r_true_cast<CPLXSXP>(SEXP x){
91  return basic_cast<CPLXSXP>(x);
92  }
93  template<>
94  inline SEXP r_true_cast<LGLSXP>(SEXP x){ // #nocov
95  return basic_cast<LGLSXP>(x); // #nocov
96  }
97 
98  template <>
99  inline SEXP r_true_cast<STRSXP>(SEXP x){ // #nocov start
100  switch( TYPEOF(x)) {
101  case CPLXSXP:
102  case RAWSXP:
103  case LGLSXP:
104  case REALSXP:
105  case INTSXP:
106  {
107  // return Rf_coerceVector( x, STRSXP );
108  // coerceVector does not work for some reason
109  Shield<SEXP> call( Rf_lang2( Rf_install( "as.character" ), x ) );
110  Shield<SEXP> res( Rcpp_eval( call, R_GlobalEnv ) );
111  return res;
112  }
113  case CHARSXP:
114  return Rf_ScalarString( x );
115  case SYMSXP:
116  return Rf_ScalarString( PRINTNAME( x ) );
117  default:
118  const char* fmt = "Not compatible with STRSXP: [type=%s].";
119  throw ::Rcpp::not_compatible(fmt, Rf_type2char(TYPEOF(x)));
120  }
121  return R_NilValue; /* -Wall */
122  }
123  template<>
124  inline SEXP r_true_cast<VECSXP>(SEXP x) {
125  return convert_using_rfunction(x, "as.list"); // #nocov end
126  }
127  template<>
128  inline SEXP r_true_cast<EXPRSXP>(SEXP x) {
129  return convert_using_rfunction(x, "as.expression" );
130  }
131  template<>
132  inline SEXP r_true_cast<LISTSXP>(SEXP x) {
133  switch( TYPEOF(x) ){
134  case LANGSXP:
135  {
136  Shield<SEXP> y( Rf_duplicate( x ));
137  SET_TYPEOF(y,LISTSXP);
138  return y;
139  }
140  default:
141  return convert_using_rfunction(x, "as.pairlist" );
142  }
143  }
144  template<>
145  inline SEXP r_true_cast<LANGSXP>(SEXP x) {
146  return convert_using_rfunction(x, "as.call" );
147  }
148 
149  } // namespace internal
150 
151  template <int TARGET> SEXP r_cast(SEXP x) {
152  if (TYPEOF(x) == TARGET) {
153  return x;
154  } else {
155  #ifdef RCPP_WARN_ON_COERCE
156  Shield<SEXP> result( internal::r_true_cast<TARGET>(x) );
157  ::Rcpp::warning("Coerced object from '%s' to '%s'.",
158  Rf_type2char(TYPEOF(x)),
159  Rf_type2char(TARGET)
160  );
161  return result;
162  #else
163  return internal::r_true_cast<TARGET>(x); // #nocov
164  #endif
165  }
166  }
167 
168 } // namespace Rcpp
169 
170 #endif
void warning(const char *fmt, Args &&...args)
Definition: exceptions.h:46
SEXP Rcpp_eval(SEXP expr, SEXP env)
Definition: Rcpp_eval.h:25
SEXP r_true_cast(SEXP x)
Definition: r_cast.h:45
SEXP r_cast(SEXP x)
Definition: r_cast.h:151
Rcpp API.
Definition: algo.h:28
SEXP convert_using_rfunction(SEXP x, const char *const fun)
Definition: r_cast.h:30
SEXP basic_cast(SEXP x)
Definition: r_cast.h:58