Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
共立出版usefulRシリーズ第10巻『Rのパッケージおよびツールの作成と応用』 サンプルコード
#include <R.h>
#include <Rinternals.h>
SEXP dfmake(SEXP x, SEXP y, SEXP z){
int pc=0;
SEXP df, varlabels, tmp, row_names;//DataTypes;
const char* xx = CHAR(STRING_ELT(x, 0));
const char* yy = CHAR(STRING_ELT(y, 0));
const char* zz = CHAR(STRING_ELT(z, 0));
PROTECT(df = allocVector(VECSXP, 2));pc++;// ベクトル要素を二つ持つ data.frame
// df内第一ベクトルは三つの要素からなる 文字ベクトル
SET_VECTOR_ELT(df, 0, allocVector(STRSXP, 3));
SET_STRING_ELT(VECTOR_ELT(df,0), 0, mkChar(xx));
SET_STRING_ELT(VECTOR_ELT(df,0), 1, mkChar(yy));
SET_STRING_ELT(VECTOR_ELT(df,0), 2, mkChar(zz));
// df内第二ベクトルは三つの要素からなる 整数ベクトル
SET_VECTOR_ELT(df, 1, allocVector(INTSXP, 3));
INTEGER(VECTOR_ELT(df,1))[0] = 10;
INTEGER(VECTOR_ELT(df,1))[1] = 20;
INTEGER(VECTOR_ELT(df,1))[2] = 30;
//データフレームの属性などを設定
PROTECT(varlabels = allocVector(STRSXP, 2));pc++;//df 内ベクトルの名前を用意
SET_STRING_ELT(varlabels, 0, mkChar("Name"));
SET_STRING_ELT(varlabels, 1, mkChar("Age"));
PROTECT(tmp = mkString("data.frame")); pc++;
PROTECT(row_names = allocVector(STRSXP, 3)); pc++;
SET_STRING_ELT(row_names, 0, mkChar("1"));
SET_STRING_ELT(row_names, 1, mkChar("2"));
SET_STRING_ELT(row_names, 2, mkChar("3"));
setAttrib(df, R_ClassSymbol, tmp);
setAttrib(df, R_NamesSymbol, varlabels);
setAttrib(df, R_RowNamesSymbol, row_names);
UNPROTECT(pc);
return(df);
}
#include "Rcpp.h"
using namespace Rcpp;
RcppExport SEXP dfMake2 (SEXP x, SEXP y, SEXP z){
CharacterVector cv = CharacterVector::create(as<std::string>(x),
as<std::string>(y),
as<std::string>(z));
IntegerVector nv = IntegerVector::create(10,20,30);
return DataFrame::create(Named("Name") = cv,
Named ("Age") = nv,
Named("stringsAsFactors") = false );
}
int fib(const int x){
if(x==0)return(0);
if(x==1)return(1);
return fib(x-1)+fib(x-2);
}
#include<Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
int fibonacci(const int x){
if(x < 2)
return x;
else
return(fibonacci(x - 1))+fibonacci(x-2);
}
#include <Rcpp.h>
extern int fib(const int x);
extern "C" SEXP fibWrapper (SEXP xs ) {
int x = Rcpp::as<int>(xs);
int z = fib (x);
return Rcpp::wrap(z);
}
## 金 明哲編・石田 基広・神田 善伸・樋口 耕一・永井 達大・鈴木 了太著
## シリーズ名 シリーズ Useful R 全10巻 【10】巻
## ISBN 978-4-320-12373-1
## 判型 B5
## ページ数 212ページ
## 発売日 2014年12月10日
## 本体価格 3,400円
## http://www.kyoritsu-pub.co.jp/bookdetail/9784320123731
### 第1章
#### 1.1
f <- function(x){
tmp <- 0.0
for (i in x) tmp <- tmp + i
return (tmp)
}
f(1:10)
system.time(f(1:10^6))
library(compiler)
f2 <- cmpfun(f)
system.time(f2(1:10^6))
# install.packages ("rbenchmark")
fib1 <- function(n){
if (n == 0) return (0)
if (n == 1) return (1)
return (fib1 (n - 1) + fib1 (n - 2))
}
system.time(fib1(30))
fib2 <- cmpfun(fib1)
library(rbenchmark)
benchmark(
res1 = fib1(30),
res2 = fib2(30),
replications = 3,
order = c('replications', 'elapsed')
)
txt <- '
int fibonacci(const int x) {
if (x == 0) return(0);
if (x == 1) return(1);
return fibonacci(x-1) + fibonacci(x-2);
}'
library(Rcpp)
library(inline)
fibRcpp <- cxxfunction(signature(xs = "int" ),
plugin = "Rcpp",
incl = txt,
body = '
int x = Rcpp::as<int>(xs);
return Rcpp::wrap(fibonacci(x));
')
benchmark(
res1 = fib1(30),
res2 = fib2(30),
res3 = fibRcpp(30),
replications = 3,
order = c('replications', 'elapsed')
)
### 第2章
#### 2.2
/* twice.c */
#include <R.h>
#include <Rinternals.h>
SEXP twice (SEXP input) {
long x = asReal (input);
SEXP res = PROTECT (allocVector(REALSXP, 1));
REAL (res)[0] = x * 2;
UNPROTECT(1);
return res;
}
dyn.load("twice.so")
.Call("twice", 6)
dyn.unload("twice.so")
/* setChar.c */
#include <R.h>
#include <Rinternals.h>
extern int utf8locale;
SEXP setChar (SEXP x){
const char* xx = CHAR(STRING_ELT(x, 0));
SEXP res = PROTECT(allocVector(STRSXP, 2));
SET_STRING_ELT(res, 0, mkChar(xx));
SET_STRING_ELT(res, 1, mkChar("さん"));
UNPROTECT(1);
return res;
}
dyn.load("setChar.so")
.Call("setChar", "山田")
dyn.unload("setChar.so")
/* to make a data frame */
#include <R.h>
#include <Rinternals.h>
extern int utf8locale;
SEXP dfmake(SEXP x, SEXP y, SEXP z){
int pc=0;
SEXP df, varlabels, tmp, row_names;//DataTypes;
const char* xx = CHAR(STRING_ELT(x, 0));
const char* yy = CHAR(STRING_ELT(y, 0));
const char* zz = CHAR(STRING_ELT(z, 0));
PROTECT(df = allocVector(VECSXP, 2));pc++;// ベクトル要素を二つ持つ data.frame
// df内第一ベクトルは三つの要素からなる 文字ベクトル
SET_VECTOR_ELT(df, 0, allocVector(STRSXP, 3));
SET_STRING_ELT(VECTOR_ELT(df,0), 0, mkCharCE(xx, (utf8locale)?CE_UTF8:CE_NATIVE));
SET_STRING_ELT(VECTOR_ELT(df,0), 1, mkCharCE(yy, (utf8locale)?CE_UTF8:CE_NATIVE));
SET_STRING_ELT(VECTOR_ELT(df,0), 2, mkCharCE(zz, (utf8locale)?CE_UTF8:CE_NATIVE));
// df内第二ベクトルは三つの要素からなる 整数ベクトル
SET_VECTOR_ELT(df, 1, allocVector(INTSXP, 3));
INTEGER(VECTOR_ELT(df,1))[0] = 10;
INTEGER(VECTOR_ELT(df,1))[1] = 20;
INTEGER(VECTOR_ELT(df,1))[2] = 30;
//データフレームの属性などを設定
PROTECT(varlabels = allocVector(STRSXP, 2));pc++;//df 内ベクトルの名前を用意
SET_STRING_ELT(varlabels, 0, mkCharCE("Name", (utf8locale)?CE_UTF8:CE_NATIVE));
SET_STRING_ELT(varlabels, 1, mkCharCE("Age", (utf8locale)?CE_UTF8:CE_NATIVE));
PROTECT(tmp = mkString("data.frame")); pc++;
PROTECT(row_names = allocVector(STRSXP, 3)); pc++;
SET_STRING_ELT(row_names, 0, mkCharCE("1", (utf8locale)?CE_UTF8:CE_NATIVE));
SET_STRING_ELT(row_names, 1, mkCharCE("2", (utf8locale)?CE_UTF8:CE_NATIVE));
SET_STRING_ELT(row_names, 2, mkCharCE("3", (utf8locale)?CE_UTF8:CE_NATIVE));
setAttrib(df, R_ClassSymbol, tmp);
setAttrib(df, R_NamesSymbol, varlabels);
setAttrib(df, R_RowNamesSymbol, row_names);
UNPROTECT(pc);
return(df);
}
/* to make a dataframe 2 */
#include "Rcpp.h"
using namespace Rcpp;
RcppExport SEXP dfMake2 (SEXP x, SEXP y, SEXP z){
CharacterVector cv = CharacterVector::create(as<std::string>(x),
as<std::string>(y),
as<std::string>(z));
IntegerVector nv = IntegerVector::create(10,20,30);
return DataFrame::create(Named("Name") = cv,
Named ("Age") = nv,
Named("stringsAsFactors") = false );
}
#### 2.3
install.packages(c("inline", "Rcpp"))
#### 2.4
library(inline)
fx <- cxxfunction( signature(x = "integer", y = "numeric" ) ,
body = 'return ScalarReal( INTEGER(x)[0] * REAL(y)[0] ) ;'
)
fx(2L, 5)
#is.null.cxxfun(fx)
### 2.5
/* fib.cpp*/
int fib(const int x){
if(x==0)return(0);
if(x==1)return(1);
return fib(x-1)+fib(x-2);
}
/* fibWrapepr.cpp */
#include <Rcpp.h>
extern int fib(const int x);
extern "C" SEXP fibWrapper (SEXP xs ) {
int x = Rcpp::as<int>(xs);
int z = fib (x);
return Rcpp::wrap(z);
}
export PKG_CPPFLAGS="-I/home/ishida/R/3.1/Rcpp/include"
R CMD SHLIB fib.cpp fibWrapper.cpp
system.file(package = "Rcpp")
dyn.load ("fib.so")
.Call ("fibWrapper", 10)
dyn.unload ("fib.so")
#### 2.5.2
/* fibonacci.cpp */
#include<Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
int fibonacci(const int x){
if(x < 2)
return x;
else
return(fibonacci(x - 1))+fibonacci(x-2);
}
sourceCpp("fibonacci.cpp")
fibonacci(10)
fibonacci
#### 2.5.3
src <- "
int fibonacci(const int x) {
if (x == 0) return(0);
if (x == 1) return(1);
return fibonacci(x-1) + fibonacci(x-2);
}"
fibRcpp <- cxxfunction(signature(xs = "int" ),
plugin = "Rcpp",
incl = src,
body = "
int x = Rcpp::as<int>(xs);
return Rcpp::wrap(fibonacci(x));
")
fibRcpp(10)
#### 2.5.4
src2 <- '
using namespace std;
vector< string > sortR (vector< string > strings ) {
int len = strings.size();
for( int i=0; i < len; i++ ) {
sort( strings[i].begin(), strings[i].end() );
}
return strings;
}'
fun <- cppFunction(src2)
str <- c("Apple", "Microsoft")
fun (str)
#### 2.6.1
src <- "
Rcpp::IntegerVector vec(4);
vec[0] = 1;
vec[1] = 2;
vec[2] = 3;
vec[3] = 4;
return vec;
"
fun <- cxxfunction (signature(), src, plugin = "Rcpp")
fun()
src <- '
Rcpp::NumericVector vec(x);
double sum = 0.0;
for (int i = 0; i < vec.size(); i++) {
sum += vec[i];
}
return Rcpp::wrap(sum);
'
fun <- cxxfunction (signature(x="numeric"), src, plugin = "Rcpp")
x <- c(1.1, 2.2, 3.3)
fun (x)
src <- '
double x = Rcpp::as<double> (vec);
x = x * x;
return Rcpp::wrap(x);
'
fun <- cxxfunction (signature(vec ="numeric"), src, plugin = "Rcpp")
fun(5.0)
src <- '
using namespace Rcpp;
CharacterVector strVec =
CharacterVector::create(Named ("Japanese") = "日本語",
_["English"] = "英語");
return strVec;
'
fun <- cxxfunction (signature(), src, plugin = "Rcpp")
fun()
#### 2.6.2
src <- '
using namespace std;
using namespace Rcpp;
vector<int> num{1,2,3};
vector<string> str {"山田","加藤","佐藤"};
return DataFrame::create(Named("id") = num,
Named("name") = str);
'
settings <- getPlugin("Rcpp")
settings$env$PKG_CXXFLAGS='-std=c++11'
fun <- cxxfunction (signature(), src, plugin = "Rcpp",settings = settings)
fun()
#### 2.6.3
src <- '
using namespace std;
using namespace Rcpp;
vector<int> num{1,2, 3,4, 5,6};
NumericMatrix mat (2,3, num.begin());
return mat;
'
fun <- cxxfunction (signature(), src, plugin = "Rcpp",settings=settings)
fun()
#### 2.6.4
src <- '
Rcpp::NumericVector vec(x);
int n = vec.size();
Rcpp::NumericVector res (n);
for (int i = 0; i < n; i++) {
if(vec[i] > 0) {
res[i] = 100/ vec[i];
} else{
res[i] = vec[i] * 100;
}
}
return res;
'
fun <- cxxfunction(signature(x = "numeric" ), body = src, plugin = "Rcpp")
x <- c(-2:2)
x
fun(x)
src <- '
NumericVector vec(x);
return wrap (ifelse (vec > 0, 100 / vec, 100 * vec ) );
'
fun <- cxxfunction(signature(x = "numeric"), body = src, plugin = "Rcpp")
fun(x)
### 第3章
#### 3.1
//' @useDynLib myFib
//' Calcuate Fibonacchi number
//'
//' This simple function calcuate Fibonacci numbers
//' @name fibonacchi
//' @param x integer
//' @return Fibonacchi number
//' @keywords Fibonacchi
#include<Rcpp.h>
using namespace Rcpp;
//' @export
// [[Rcpp::export]]
int fibonacci(const int x){
if (x < 0)
return -99;
else if(x < 2)
return x;
else
return(fibonacci(x - 1))+fibonacci(x-2);
}
Rcpp.package.skeleton("myFib", example_code = FALSE, cpp_files = "myFib.cpp") #'
roxygen2::upgradeRoxygen ('myFib')
roxygen2::roxygenize ('myFib')
install.packages ("myFib", repos = NULL)
library(myFib)
fibonacci (10)
#### 3.2
install.packages("devtools")
library(devtools)
load_all ("myFib")
fibonacci(10)
int fibonacci(const int x){
if (x < 0)
return -999;//0未満は-999を返す
else if(x < 2)
return x;
else
return(fibonacci(x - 1)) + fibonacci(x-2);
}
fibonacci(-1)
load_all ("myFib", recompile = TRUE)
fibonacci(-1)
dev_mode()
install ("myFib")
ibonacci(-3)
dev_mode()
#### 3.3
test_that("test",{
x <- fibonacci(10)
expect_equal(x, 53)
})
load_all ("myFib", recompile = TRUE)
test_package("myFib")
### 第4章
https://github.com/IshidaMotohiro/R2MeCab/
を利用してください
##################################################
library(Rcpp)
Rcpp.package.skeleton("R2MeCab",
author = "Motohiro ISHIDA", maintainer = "Motohiro ISHIDA",
email = "ishida-m@ias.tokushima-u.ac.jp",
example_code = FALSE,
cpp_files = c("Makevars", "mecab_test.cpp","setMap.cpp", "util.cpp",
"mecab_test.h", "setMap.h", "util.h"),
code_files = "mecab_test.R")
roxygen2::upgradeRoxygen('R2MeCab')
roxygen2::roxygenize("R2MeCab", roclets = "rd")
library(devtools)
load_all ("R2MeCab", recompile = TRUE)
mecab_test("すもももももももものうち")
dyn.load ("R2MeCab/src/R2MeCab.so")
.Call("mecab_test", "すもももももももものうち")
.Call("R2MeCab_mecab_test", PACKAGE = "R2MeCab", "すもももももももものうち" )
/* setChar.c */
#include <R.h>
#include <Rinternals.h>
extern int utf8locale;
SEXP setChar (SEXP x){
const char* xx = CHAR(STRING_ELT(x, 0));
SEXP res = PROTECT(allocVector(STRSXP, 2));
SET_STRING_ELT(res, 0, mkChar(xx));
SET_STRING_ELT(res, 1, mkChar("さん"));
UNPROTECT(1);
return res;
}
/* twice.c */
#include <R.h>
#include <Rinternals.h>
SEXP twice (SEXP input) {
long x = asReal (input );
SEXP res = PROTECT (allocVector(REALSXP, 1));
REAL (res)[0] = x * 2;
UNPROTECT(1);
return res;
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.