Rcpp Version 1.0.0
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_fast_eval(Rf_lang2(funSym, x), R_GlobalEnv);
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 #ifndef NDEBUG
71  REprintf(fmt,
72  Rf_type2char(TYPEOF(x)),
73  Rf_type2char(RTYPE));
74  abort();
75 #else
76  throw ::Rcpp::not_compatible(fmt,
77  Rf_type2char(TYPEOF(x)),
78  Rf_type2char(RTYPE));
79 #endif
80  } // #nocov end
81  return R_NilValue; /* -Wall */
82  }
83 
84  template<>
85  inline SEXP r_true_cast<INTSXP>(SEXP x){
86  return basic_cast<INTSXP>(x);
87  }
88  template<>
89  inline SEXP r_true_cast<REALSXP>(SEXP x){ // #nocov
90  return basic_cast<REALSXP>(x); // #nocov
91  }
92  template<>
93  inline SEXP r_true_cast<RAWSXP>(SEXP x){
94  return basic_cast<RAWSXP>(x);
95  }
96  template<>
97  inline SEXP r_true_cast<CPLXSXP>(SEXP x){
98  return basic_cast<CPLXSXP>(x);
99  }
100  template<>
101  inline SEXP r_true_cast<LGLSXP>(SEXP x){ // #nocov
102  return basic_cast<LGLSXP>(x); // #nocov
103  }
104 
105  template <>
106  inline SEXP r_true_cast<STRSXP>(SEXP x){ // #nocov start
107  switch( TYPEOF(x)) {
108  case CPLXSXP:
109  case RAWSXP:
110  case LGLSXP:
111  case REALSXP:
112  case INTSXP:
113  {
114  // return Rf_coerceVector( x, STRSXP );
115  // coerceVector does not work for some reason
116  Shield<SEXP> call( Rf_lang2( Rf_install( "as.character" ), x ) );
117  Shield<SEXP> res( Rcpp_fast_eval( call, R_GlobalEnv ) );
118  return res;
119  }
120  case CHARSXP:
121  return Rf_ScalarString( x );
122  case SYMSXP:
123  return Rf_ScalarString( PRINTNAME( x ) );
124  default:
125  const char* fmt = "Not compatible with STRSXP: [type=%s].";
126 #ifndef NDEBUG
127  REprintf(fmt, Rf_type2char(TYPEOF(x)));
128  abort();
129 #else
130  throw ::Rcpp::not_compatible(fmt, Rf_type2char(TYPEOF(x)));
131 #endif
132  }
133  return R_NilValue; /* -Wall */
134  }
135  template<>
136  inline SEXP r_true_cast<VECSXP>(SEXP x) {
137  return convert_using_rfunction(x, "as.list"); // #nocov end
138  }
139  template<>
140  inline SEXP r_true_cast<EXPRSXP>(SEXP x) {
141  return convert_using_rfunction(x, "as.expression" );
142  }
143  template<>
144  inline SEXP r_true_cast<LISTSXP>(SEXP x) {
145  switch( TYPEOF(x) ){
146  case LANGSXP:
147  {
148  Shield<SEXP> y( Rf_duplicate( x ));
149  SET_TYPEOF(y,LISTSXP);
150  return y;
151  }
152  default:
153  return convert_using_rfunction(x, "as.pairlist" );
154  }
155  }
156  template<>
157  inline SEXP r_true_cast<LANGSXP>(SEXP x) {
158  return convert_using_rfunction(x, "as.call" );
159  }
160 
161  } // namespace internal
162 
163  template <int TARGET> SEXP r_cast(SEXP x) {
164  if (TYPEOF(x) == TARGET) {
165  return x;
166  } else {
167  #ifdef RCPP_WARN_ON_COERCE
168  Shield<SEXP> result( internal::r_true_cast<TARGET>(x) );
169  ::Rcpp::warning("Coerced object from '%s' to '%s'.",
170  Rf_type2char(TYPEOF(x)),
171  Rf_type2char(TARGET)
172  );
173  return result;
174  #else
175  return internal::r_true_cast<TARGET>(x); // #nocov
176  #endif
177  }
178  }
179 
180 } // namespace Rcpp
181 
182 #endif
SEXP Rcpp_fast_eval(SEXP expr, SEXP env)
Definition: Rcpp_eval.h:68
SEXP r_true_cast(SEXP x)
Definition: r_cast.h:45
SEXP r_cast(SEXP x)
Definition: r_cast.h:163
void warning(const char *fmt, Args &&... args)
Definition: exceptions.h:46
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