¥È¥Ã¥× º¹Ê¬ °ìÍ÷ ¥½¡¼¥¹ ¸¡º÷ ¥Ø¥ë¥× RSS ¥í¥°¥¤¥ó

BugTrack-£ÒÈ÷˺Ͽ/57

£ÒÈ÷˺Ͽ /¾õÂÖ¶õ´Ö¥â¥Ç¥ê¥ó¥°/donlp2/¤½¤Î¾¤Î¥á¥â

£ÒÈ÷˺Ͽ - µ­»ö°ìÍ÷

R¡ÊR¸À¸ì¡Ë¤«¤éC¤ò¸Æ¤Ö¡ÊLinuxÊÔ¡Ë - ¤Á¤ç¤Ã¤È¤·¤¿¥³¥Ä

  • Åê¹Æ¼Ô¡§ ¤ß¤å
  • ¥«¥Æ¥´¥ê¡§ ¤Ê¤·
  • Í¥ÀèÅÙ¡§ ÉáÄÌ
  • ¾õÂÖ¡§ ´°Î»
  • Æü»þ¡§ 2010ǯ01·î23Æü 20»þ41ʬ35ÉÃ

ÆâÍÆ

  • ¡Ö¤Á¤ç¤Ã¤È¤·¤¿¥³¥Ä¡×½¸
  • ´ÉÍý¿Í¤ß¤å¤ÎÈ÷˺Ͽ¡Ê¾Ð
  • ¤³¤³¤«¤éÀè¤Ï¡¢BugTrack-£ÒÈ÷˺Ͽ/56¤ÎC¤Î¥½¡¼¥¹¤Ë¤É¤ó¤É¤óÄɲ䷤Ƥ¤¤¯¤À¤±¤Ç¡¢Æ°¤¯¤Ï¤º¤Ç¤¹¡¥
  • ¥½¡¼¥¹ ¢ª test.c(107)
  • ¥Ð¥°Êó¹ð¤ä¼ÁÌä¤ÏÊ̴ۤǤª´ê¤¤¤·¤Þ¤¹¡¥

C¤ËÅϤ·¤¿R¥ª¥Ö¥¸¥§¥¯¥È¤Î¥Ç¥£¥á¥ó¥¸¥ç¥ó¤òÆÀ¤ë

  • GET_DIM
  • ¹ÔÎó¤Ê¤ó¤«¤òÅϤ¹¤È¤­¤Ë¡¢¤½¤Î¥Ç¥£¥á¥ó¥¸¥ç¥ó¤ò¤¤¤Á¤¤¤ÁÀ°¿ô¤ÇÅϤµ¤Ê¤¯¤Æ¤è¤¤¡¥C¤ÎÃæ¤Ç¼èÆÀ¤Ç¤­¤ë¡¥
  • C¥µ¥ó¥×¥ë
SEXP test001(SEXP a){
  int n, m;
  n = INTEGER(GET_DIM(a))[0];
  m = INTEGER(GET_DIM(a))[1];
  printf("nrow of a : %d\n", n);
  printf("ncol of a : %d\n", m);
  return a;
}
  • R¤«¤é¸Æ¤Ö
> a <- matrix(double(1), 3,5)
> .Call("test001", a)
nrow of a : 3
ncol of a : 5
     [,1] [,2] [,3] [,4] [,5]
[1,]    0    0    0    0    0
[2,]    0    0    0    0    0
[3,]    0    0    0    0    0

dgesv¡Êlapack¡Ë¤ò»È¤¦

  • Solves a general system of linear equations AX=B.
  • http://www.netlib.org/lapack/double/dgesv.f
  • ¤³¤ó¤Ê·×»»¤ÏR¤Ç¤Á¤ç¤Á¤ç¤¤¤Î¤Á¤ç¤¤¤Ê¤ó¤Ç¤¹¤¬¡¢¥¹¥Ô¡¼¥É¥¢¥Ã¥×¤òÁÀ¤Ã¤ÆC¤Çµ­½Ò¤·¤¿¤¤¤È¤­¤Ë¡¢¤³¤ó¤Ê·×»»¤ò¤¹¤ë¤¿¤á¤Ë¤¤¤Á¤¤¤ÁR¤ËÌá¤Ã¤Æ·×»»¤µ¤»¤Æ¤¤¤Æ¤Ï¡¢¤½¤ì¤³¤½¥Ñ¥Õ¥©¡¼¥Þ¥ó¥¹¤¬½Ð¤Ê¤¤¤Î¤Ç¡¦¡¦¡¦¡¥¤³¤ó¤Ê·×»»¤Ç¤âC¤ÎÃæ¤Ç¤ä¤é¤»¤¿¤Û¤¦¤¬¤è¤¤¤Ç¤¹¡¥¤Ç¤¹¤Î¤Ç¡¢blas¤È¤«lapack¤Ïɬ¿Ü¤À¤Ã¤¿¤ê¤·¤Þ¤¹¡¥
  • C¸À¸ì
SEXP Rdgesv01(SEXP A, SEXP b, SEXP info)
{
  int i;
  long int n = INTEGER(GET_DIM(A))[0];
  long int nrhs=1;
  long int piv[n];   // ¤³¤ó¤Ê½ñ¤­Êý¤Ç¤­¤¿¤Ã¤±¡©¡©¡©

  printf("N = %ld\n", n);
  dgesv_(&n, &nrhs, REAL(A), &n, piv, REAL(b), &n, INTEGER(info));
  for(i=0; i<n; ++i) printf("%lf\n", REAL(b)[i]);
  return(b);
}
  • R¤«¤é¡¢A£ø=£â¤ò²ò¤¯
A <- cbind(c(1, 3, 1), c(1, 1, -2), c(1, -3, -5))
b <- c(3,1,-6)
solve(A, b)
> solve(A, b)
[1] 1 1 1   # R¤Ë¤è¤ë²ò
> info <- integer(1)
> .Call("Rdgesv01", A, b, info)
N = 3   #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
1.000000   #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
1.000000   #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
1.000000   #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
[1] 1 1 1   #¡Ö.Call¡×¤ÎÌá¤êÃÍ
  • ¤¿¤À¤·º£¤ÎC¤Î½ñ¤­Êý¤À¤È¡¢°ú¿ô¤Ë¤·¤¿¡Ö£â¡×¼«ÂΤÎÃæ¿È¤â½ñ¤­´¹¤ï¤Ã¤Æ¤·¤Þ¤Ã¤Æ¤¤¤Þ¤¹¡¥dgesv¤Î»ÅÍͤʤΤǻÅÊý¤¢¤ê¤Þ¤»¤ó¡¥¡Ê¤Ä¤¤¤Ç¤Ë¸À¤¦¤ÈA¤â½ñ¤­´¹¤ï¤ë¡¦¡¦¡¦¡Ë
> b
[1] 1 1 1
  • ¤³¤ì¤ò¡¢Ëɤ°¤Ë¤Ï·ë²Ì¤òÆþ¤ì¤ë¾ì½ê¤òÍÑ°Õ¤·¤Æ¡¢¤½¤³¤Ë·ë²Ì¤ò¥»¥Ã¥È¤·¤ÆÊÖ¤¹¤·¤«¤¢¤ê¤Þ¤»¤ó¡¥
  • R¤Ç¤³¤ì¤ò¼Â¸½¤¹¤ë¤Î¤Ï´Êñ¤Ç¤¹¡¥¡ÖA¡×¡Ö£â¡×¤¬´û¤Ë¥»¥Ã¥È¤µ¤ì¤Æ¤¤¤ë¤È²¾Äꤹ¤ë¤È
tmpA <- A
tmpb <- b
.Call("Rdgesv01", tmpA, tmpb, info)
  • Ê̤ÎÆþ¤ìʪ¤òºî¤Ã¤Æ¤½¤ì¤Ç·×»»¤µ¤»¤ì¤Ð¤¤¤¤¤À¤±¤Ç¤¹¡¦¡¦¡¦
  • ¤Ç¤â¤³¤ì¤À¤È¡¢R¤ÇÂå¤ï¤ê¤ÎÆþ¤ìʪ¤òÍÑ°Õ¤·¤Æ¤¤¤ë¤Î¤Ç¡¢C¤ÎÃæ¤Ç°ìÏ¢¤Î½èÍý¤ò¤µ¤»¤¿¤¤¾ì¹ç¤Ë¤Ï»È¤¨¤Þ¤»¤ó¡¥¤½¤³¤Ç¤³¤ì¤òC¤ÎÃæ¤Ç¤Á¤ã¤ó¤ÈÍÑ°Õ¤¹¤ë¤è¤¦¤Ë¤·¤Þ¤¹¡¥
SEXP Rdgesv01(SEXP A, SEXP b, SEXP info)
{
  int i;
  long int n = INTEGER(GET_DIM(A))[0];
  long int nrhs=1;
  long int incx=1;
  long int incy=1;
  long int piv[n];
  
  SEXP tmpA, tmpb;
  
  PROTECT(tmpA = allocMatrix(REALSXP, n, n));
  PROTECT(tmpb = allocVector(REALSXP, n));
  long int nn = n*n;
  dcopy_(&nn, REAL(A), &incx, REAL(tmpA), &incy);
  dcopy_(&n, REAL(b), &incx, REAL(tmpb), &incy);
  
  printf("N = %ld\n", n);
  dgesv_(&n, &nrhs, REAL(tmpA), &n, piv, REAL(tmpb), &n, INTEGER(info));
  for(i=0; i<n; ++i) printf("%lf\n", REAL(b)[i]);
  UNPROTECT(2);
  return(tmpb);
}
  • R¤ÎAPI¤òC¤Ç»È¤¦¤È¤­¤Î¤ªºîË¡¤Ê¤Î¤Ç¤¹¤¬¡¢¿·¤¿¤Ë¥á¥â¥ê¤ò³ÎÊݤ¹¤ë¾ì¹ç¤ÏPROTECT¤È¤¤¤¦¥Þ¥¯¥í¤ò»È¤ï¤Í¤Ð¤Ê¤ê¤Þ¤»¤ó¡¥¾¡¼ê¤Ë¥¬¥Ù¡¼¥¸¥³¥ì¥¯¥·¥ç¥ó¤µ¤ì¤ë¤Î¤òËɤ°¤¿¤á¤Î¤è¤¦¤Ç¤¹¡¥¤½¤·¤Æ¡¢¤½¤ì¤ò¤É¤³¤«¤ÇUNPROTECT¤¹¤ëɬÍפ¬¤¢¤ê¤Þ¤¹¡¥
  • ¡Ödcopy_¡×¤Ïblas¤Î´Ø¿ô¤Ç¡¢ÊÑ¿ô¤ÎÃæ¿È¤ò¥³¥Ô¡¼¤·¤Æ¤¯¤ì¤Þ¤¹¡¥A¤Ï£î¡ß£î¤Ê¤Î¤Ç¡¢Æó¾è¤·¤Æ¤¤¤Þ¤¹¡¥
  • R¤«¤é¸Æ¤Ö
> A <- cbind(c(1, 3, 1), c(1, 1, -2), c(1, -3, -5))
> b <- c(3,1,-6)
> solve(A, b)
[1] 1 1 1
> info <- integer(1)
> .Call("Rdgesv01", A, b, info)
N = 3
3.000000   #¸µ¤Î£â¤òɽ¼¨¤·¤Æ¤¤¤ë¡¥
1.000000   #¸µ¤Î£â¤òɽ¼¨¤·¤Æ¤¤¤ë¡¥
-6.000000   #¸µ¤Î£â¤òɽ¼¨¤·¤Æ¤¤¤ë¡¥
[1] 1 1 1   # ·ë²Ì¤Ï¤³¤ÎÄ̤ê
> A   #½ñ¤­´¹¤ï¤Ã¤Æ¤¤¤Ê¤¤
     [,1] [,2] [,3]
[1,]    1    1    1
[2,]    3    1   -3
[3,]    1   -2   -5
> b   #½ñ¤­´¹¤ï¤Ã¤Æ¤¤¤Ê¤¤
[1]  3  1 -6
  • ¥Ñ¥Á¥Ñ¥Á

C¤ÎÃæ¤ÇR¤Î´Ø¿ô¤òɾ²Á¤¹¤ë­¡

  • ¤³¤ì¤ò¼Â¸½
print(x, digits=3)
  • C
SEXP eval_fun01(SEXP a, SEXP rho)
{
  SEXP s, t;
  SEXP ret;
  PROTECT(t = s = allocList(3));
  // Setting the type to LANGSXP makes this a call which can be evaluated
  SET_TYPEOF(s, LANGSXP);
  // set a symbol (pointing to the function to be called)
  SETCAR(t, install("print")); t = CDR(t);
  // set the first unnamed
  SETCAR(t, a); t = CDR(t);
  // set the second named
  SETCAR(t, allocVector(INTSXP, 1));
  INTEGER(CAR(t))[0] = 3;
  SET_TAG(t, install("digits"));
  PROTECT(ret = eval(s, rho));
  //PrintValue(ret);
  UNPROTECT(2);
  return R_NilValue;
}
  • R¤Ç¼Â¹Ô
> print("Hello", digits=3)
[1] "Hello"
> .Call("eval_fun01", "Hello", .GlobalEnv)
[1] "Hello"
NULL
> print(3.123456789, digits=3)
[1] 3.12
> .Call("eval_fun01", 3.123456789, .GlobalEnv)
[1] 3.12
NULL

C¤ÎÃæ¤ÇR¤Î´Ø¿ô¤òɾ²Á¤¹¤ë­¢

  • °ú¿ô¤¬£±¤Ä¤À¤±¤Ê¤é¡Ölang2¡×¤¬»È¤¨¤Þ¤¹¡¥
  • ¡Öprint("Hello")¡×¤ò¼Â¸½
SEXP eval_fun02(SEXP a, SEXP rho)
{
  SEXP call;
  SEXP ret;
  
  PROTECT(call = lang2(install("print"), a));
  eval(call, rho);
  UNPROTECT(1);
  return R_NilValue;
}
  • R¤Ç¼Â¹Ô
> .Call("eval_fun02", "Hello", .GlobalEnv)
[1] "Hello"
NULL

C¤ÎÃæ¤ÇR¤Î´Ø¿ô¤òɾ²Á¤¹¤ë­£

  • ɾ²Á¤·¤¿¤¤expression¤ò¡Öquote¡×¤Ç¤ï¤¿¤¹¡¥
SEXP eval_fun03(SEXP fr, SEXP env)
{
  SEXP ans;
  
  if(!isEnvironment(env)) error(" 'env' should be an environment");
  PROTECT(ans = eval(fr, env));
  UNPROTECT(1);
  return(ans);
}
  • R¤Ç¼Â¹Ô
> f <- function(x) x^2
> .Call("eval_fun03", quote(f(x)), new.env())
 °Ê²¼¤Ë¥¨¥é¡¼ f(x) :  ¥ª¥Ö¥¸¥§¥¯¥È 'x' ¤¬¤¢¤ê¤Þ¤»¤ó
  • ¡Öf(x)¡×¤ò·×»»¤·¤¿¤¤¤Î¤Ç¤¹¤¬¡¢¡Önew.env()¡×¤Ç»ØÄꤷ¤¿´Ä¶­¡©¤Ë£ø¤¬¤Ê¤¤¤Î¤Ç¡¢£ø¤¬¸«¤Ä¤«¤é¤Ê¤¤¤È¤¤¤ï¤ì¤Þ¤¹¡¥¥°¥í¡¼¥Ð¥ë´Ä¶­¤Ç£ø¤òºî¤Ã¤Æ¤¢¤²¤ë¤È¡¢¡Önew.env()¡×¤Ë£ø¤¬¤Ê¤¤¾ì¹ç¤Ë¤Ï¥°¥í¡¼¥Ð¥ë´Ä¶­¤Þ¤Çõ¤·¤Ë¤­¤Æ¤¯¤ì¤Þ¤¹¡¥
> f <- function(x) x^2
> .Call("eval_fun03", quote(f(x)), new.env())
 °Ê²¼¤Ë¥¨¥é¡¼ f(x) :  ¥ª¥Ö¥¸¥§¥¯¥È 'x' ¤¬¤¢¤ê¤Þ¤»¤ó
> x <- 2
> .Call("eval_fun03", quote(f(x)), new.env())
[1] 4
> x <- pi
> .Call("eval_fun03", quote(f(x)), new.env())
[1] 9.869604

C¤ÎÃæ¤ÇR¤Î´Ø¿ô¤òɾ²Á¤¹¤ë­¤

  • ­£¤ò¤â¤¦¤Á¤ç¤Ã¤È°ìÈÌŪ¤Ë¤ä¤í¤¦¤È¤¹¤ë¤È¤³¤ó¤Ê´¶¤¸¤Ë¤Ê¤ë¤Ç¤·¤ç¤¦¤«¡©
SEXP eval_fun04(SEXP fr, SEXP x, SEXP env)
{
  SEXP ans;
  
  if(!isEnvironment(env)) error(" 'env' should be an environment");
  defineVar(install("x"), x, env);
  PROTECT(ans = eval(fr, env));
  UNPROTECT(1);
  return(ans);
}
  • ¤³¤ì¤ÏC¤ÎÃæ¤Ç¡¢ÅϤµ¤ì¤¿¿·´Ä¶­¤Ç£ø¤òÄêµÁ¤·¤Æ¤¤¤Þ¤¹¤«¤é¡¢¥°¥í¡¼¥Ð¥ë´Ä¶­¤Ë£ø¤¬¤Ê¤¯¤Æ¤â¥¨¥é¡¼¤Ï¤Ç¤Þ¤»¤ó¡¥
> .Call("eval_fun03", quote(f(x)), new.env())
[1] 9.869604   #­£¤ÎÎã
> f <- function(x) x^3
> .Call("eval_fun04", quote(f(x)), 2, new.env())
[1] 8
  • ¤Ç¤âx1¤À¤È¡¦¡¦¡¦
> .Call("eval_fun04", quote(f(x1)), 2, new.env())
 °Ê²¼¤Ë¥¨¥é¡¼ f(x1) :  ¥ª¥Ö¥¸¥§¥¯¥È 'x1' ¤¬¤¢¤ê¤Þ¤»¤ó

C¤ÎÃæ¤ÇR¤Î´Ø¿ô¤òɾ²Á¤¹¤ë­¥

  • ʸ»úÎó¤ò¤½¤Î¤Þ¤Þɾ²Á¤·¤¿¤¤¤È¤¤¤¦¤½¤ó¤Ê¤¢¤Ê¤¿¤Ë¤Ï¡¦¡¦¡¦
  • C¤Î¥½¡¼¥¹
    • ¡Ú#include <R_ext/Parse.h>¡Û¤ÎÄɲä¬É¬ÍפǤ¹¡¥
SEXP eval_fun05(SEXP a, SEXP env)
{
  SEXP cv, call, call2;
  SEXP ans;
  int i;
  ParseStatus status;
  char *cmd1 = "print(a)";  //¤Ê¤ó¤Ç¤âOK¡¥Ê¸»úÎó¤ò½àÈ÷
  PROTECT(cv = allocVector(STRSXP, 1));  //ʸ»úÎóÍѤΥª¥Ö¥¸¥§¥¯¥È¤òÍÑ°Õ
  SET_STRING_ELT(cv, 0, mkChar(cmd1));  //ʸ»úÎóÊÑ¿ô¤ËÆþ¤ì¤ë
  PROTECT(call = R_ParseVector(cv, 1, &status, R_NilValue));  //¤ªºîË¡¤Ç¤¹¡¥
  PROTECT(call2 = lang2(install("eval"), call));  //eval´Ø¿ô¤Ë¥»¥Ã¥È¤¹¤ë
  for(i=0; i<5; i++){
    INTEGER(a)[0] = INTEGER(a)[0] + i;
    defineVar(install("a"), a, env);
    PROTECT(ans = eval(call2, env));
    UNPROTECT(1);
  }
  UNPROTECT(3);
  return ans;
}
  • R¤Î·ë²Ì
> dyn.load("test.so")
> is.loaded("eval_fun05")
[1] TRUE
> .Call("eval_fun05", as.integer(2), new.env())
[1] 2
[1] 3
[1] 5
[1] 8
[1] 12
  • ¡Öcall2¡×¤È¤¤¤¦¥ª¥Ö¥¸¥§¥¯¥È¡Ê̾Á°¤Ï¤Ê¤ó¤Ç¤âÎɤ¤¡Ë¤òÍÑ°Õ¤·¤Æ¤ª¤±¤Ð¡¢Î㤨¤Ð¥ë¡¼¥×¤ÎÃæ¤Ç²¿ÅÙ¤âɾ²Á¤Ç¤­¤ë¡¥
  • ɾ²Á¤¹¤ëÁ°¤Ë¡¢¡Ê¤³¤ÎÎã¤Ç¤Ï¡Ëɽ¼¨¤µ¤»¤ë¡Öa¡×¤È¤¤¤¦¥ª¥Ö¥¸¥§¥¯¥È¤ò¡ÖR_env¡×´Ä¶­¤Ç¤­¤Á¤ó¤ÈÄêµÁ¤·¤Æ¤ª¤¯É¬Íפ¬¤¢¤ë¡¥¤½¤¦¤Ç¤Ê¤±¤ì¤Ð¡¢²¿ÅÙɾ²Á¤·¤Æ¤â¡¢Æ±¤¸Ãͤ·¤«É½¼¨¤µ¤ì¤Þ¤»¤ó¡Ê¾Ð
  • ʸ»úÎó¤òR¤«¤éÅϤ¹¤Ê¤ê¡¢C¤Ë¥Ï¡¼¥É¥³¡¼¥Ç¥£¥ó¥°¤¹¤ë¤Ê¤ê¡¢¤ª¹¥¤­¤Ë¤É¤¦¤¾¡¥
  • ´ÉÍý¿Í¤ß¤å¤â¤³¤ì¤ò¿ÍÍ¡¥

¥³¥á¥ó¥È