Rcpp Version 1.0.9
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  Shield<SEXP> call(Rf_lang2(funSym, x));
35  res = Rcpp_fast_eval(call, R_GlobalEnv);
36  } catch( eval_error& e) {
37  const char* fmt = "Could not convert using R function: %s.";
38  throw not_compatible(fmt, fun);
39  }
40  return res; // #nocov end
41  }
42 
43  // r_true_cast is only meant to be used when the target SEXP type
44  // is different from the SEXP type of x
45  template <int TARGET>
46  SEXP r_true_cast( SEXP x) {
47 
48  const char* fmt = "Not compatible conversion to target: "
49  "[type=%s; target=%s].";
50 
51  throw not_compatible(fmt,
52  Rf_type2char(TYPEOF(x)),
53  Rf_type2char(TARGET));
54 
55  return x; // makes solaris happy
56  }
57 
58  template <int RTYPE>
59  SEXP basic_cast( SEXP x) { // #nocov start
60  if( TYPEOF(x) == RTYPE ) return x;
61  switch( TYPEOF(x) ){
62  case REALSXP:
63  case RAWSXP:
64  case LGLSXP:
65  case CPLXSXP:
66  case INTSXP:
67  return Rf_coerceVector(x, RTYPE);
68  default:
69  const char* fmt = "Not compatible with requested type: "
70  "[type=%s; target=%s].";
71 #ifndef NDEBUG
72  REprintf(fmt,
73  Rf_type2char(TYPEOF(x)),
74  Rf_type2char(RTYPE));
75  abort();
76 #else
77  throw ::Rcpp::not_compatible(fmt,
78  Rf_type2char(TYPEOF(x)),
79  Rf_type2char(RTYPE));
80 #endif
81  } // #nocov end
82  return R_NilValue; /* -Wall */
83  }
84 
85  template<>
86  inline SEXP r_true_cast<INTSXP>(SEXP x){
87  return basic_cast<INTSXP>(x);
88  }
89  template<>
90  inline SEXP r_true_cast<REALSXP>(SEXP x){ // #nocov
91  return basic_cast<REALSXP>(x); // #nocov
92  }
93  template<>
94  inline SEXP r_true_cast<RAWSXP>(SEXP x){
95  return basic_cast<RAWSXP>(x);
96  }
97  template<>
98  inline SEXP r_true_cast<CPLXSXP>(SEXP x){
99  return basic_cast<CPLXSXP>(x);
100  }
101  template<>
102  inline SEXP r_true_cast<LGLSXP>(SEXP x){ // #nocov
103  return basic_cast<LGLSXP>(x); // #nocov
104  }
105 
106  template <>
107  inline SEXP r_true_cast<STRSXP>(SEXP x){ // #nocov start
108  switch( TYPEOF(x)) {
109  case CPLXSXP:
110  case RAWSXP:
111  case LGLSXP:
112  case REALSXP:
113  case INTSXP:
114  {
115  // return Rf_coerceVector( x, STRSXP );
116  // coerceVector does not work for some reason
117  Shield<SEXP> call( Rf_lang2( Rf_install( "as.character" ), x ) );
118  Shield<SEXP> res( Rcpp_fast_eval( call, R_GlobalEnv ) );
119  return res;
120  }
121  case CHARSXP:
122  return Rf_ScalarString( x );
123  case SYMSXP:
124  return Rf_ScalarString( PRINTNAME( x ) );
125  default:
126  const char* fmt = "Not compatible with STRSXP: [type=%s].";
127 #ifndef NDEBUG
128  REprintf(fmt, Rf_type2char(TYPEOF(x)));
129  abort();
130 #else
131  throw ::Rcpp::not_compatible(fmt, Rf_type2char(TYPEOF(x)));
132 #endif
133  }
134  return R_NilValue; /* -Wall */
135  }
136  template<>
137  inline SEXP r_true_cast<VECSXP>(SEXP x) {
138  return convert_using_rfunction(x, "as.list"); // #nocov end
139  }
140  template<>
141  inline SEXP r_true_cast<EXPRSXP>(SEXP x) {
142  return convert_using_rfunction(x, "as.expression" );
143  }
144  template<>
145  inline SEXP r_true_cast<LISTSXP>(SEXP x) {
146  switch( TYPEOF(x) ){
147  case LANGSXP:
148  {
149  Shield<SEXP> y( Rf_duplicate( x ));
150  SET_TYPEOF(y,LISTSXP);
151  return y;
152  }
153  default:
154  return convert_using_rfunction(x, "as.pairlist" );
155  }
156  }
157  template<>
158  inline SEXP r_true_cast<LANGSXP>(SEXP x) {
159  return convert_using_rfunction(x, "as.call" );
160  }
161 
162  } // namespace internal
163 
164  template <int TARGET> SEXP r_cast(SEXP x) {
165  if (TYPEOF(x) == TARGET) {
166  return x;
167  } else {
168  #ifdef RCPP_WARN_ON_COERCE
169  Shield<SEXP> result( internal::r_true_cast<TARGET>(x) );
170  ::Rcpp::warning("Coerced object from '%s' to '%s'.",
171  Rf_type2char(TYPEOF(x)),
172  Rf_type2char(TARGET)
173  );
174  return result;
175  #else
176  return internal::r_true_cast<TARGET>(x); // #nocov
177  #endif
178  }
179  }
180 
181 } // namespace Rcpp
182 
183 #endif
SEXP r_true_cast< EXPRSXP >(SEXP x)
Definition: r_cast.h:141
SEXP r_true_cast< STRSXP >(SEXP x)
Definition: r_cast.h:107
SEXP r_true_cast< CPLXSXP >(SEXP x)
Definition: r_cast.h:98
SEXP r_true_cast(SEXP x)
Definition: r_cast.h:46
SEXP r_true_cast< LISTSXP >(SEXP x)
Definition: r_cast.h:145
SEXP r_true_cast< REALSXP >(SEXP x)
Definition: r_cast.h:90
SEXP convert_using_rfunction(SEXP x, const char *const fun)
Definition: r_cast.h:30
SEXP r_true_cast< LANGSXP >(SEXP x)
Definition: r_cast.h:158
SEXP basic_cast(SEXP x)
Definition: r_cast.h:59
SEXP r_true_cast< VECSXP >(SEXP x)
Definition: r_cast.h:137
SEXP r_true_cast< LGLSXP >(SEXP x)
Definition: r_cast.h:102
SEXP r_true_cast< INTSXP >(SEXP x)
Definition: r_cast.h:86
SEXP r_true_cast< RAWSXP >(SEXP x)
Definition: r_cast.h:94
Rcpp API.
Definition: algo.h:28
void warning(const char *fmt, Args &&... args)
Definition: exceptions.h:46
SEXP r_cast(SEXP x)
Definition: r_cast.h:164
SEXP Rcpp_fast_eval(SEXP expr, SEXP env)
Definition: Rcpp_eval.h:68