R で一部の関数のメッセージの言語が実行条件によって変わる理由とその回避策
(
)
knitr::knit で require を実行すると、次のように言語設定が日本語になっていても無視されます。
$ R
R version 3.0.1 (2013-05-16) -- "Good Sport"
Copyright (C) 2013 The R Foundation for Statistical Computing
Platform: x86_64-apple-darwin10.8.0 (64-bit)
R は、自由なソフトウェアであり、「完全に無保証」です。
一定の条件に従えば、自由にこれを再配布することができます。
配布条件の詳細に関しては、'license()' あるいは 'licence()' と入力してください。
R は多くの貢献者による共同プロジェクトです。
詳しくは 'contributors()' と入力してください。
また、R や R のパッケージを出版物で引用する際の形式については
'citation()' と入力してください。
'demo()' と入力すればデモをみることができます。
'help()' とすればオンラインヘルプが出ます。
'help.start()' で HTML ブラウザによるヘルプがみられます。
'q()' と入力すれば R を終了します。
> file.show("require.Rmd", pager = "cat")
```{r}
require(MASS)
```
> knitr::knit("require.Rmd")
processing file: require.Rmd
|................................ | 50%
label: unnamed-chunk-1
|.................................................................| 100%
ordinary text without R code
output file: require.md
[1] "require.md"
> file.show("require.md", pager = "cat")
```r
require(MASS)
```
```
## Loading required package: MASS
```
問題となっている箇所を切り出すと、base パッケージ以外にパッケージの関数から require を実行すると言語設定が無視されるということみたいです。
> detach("package:MASS", unload = TRUE)
> require("MASS")
要求されたパッケージ MASS をロード中です
> detach("package:MASS", unload = TRUE)
> f <- function() require("MASS")
> environment(f) <- getNamespace("utils")
> f()
Loading required package: MASS
何故か？
require 関数で表示するメッセージを生成しているのが次の式です。
gettextf("Loading required package: %s", package)
これは本来次のように domain を指定すべきです。
gettextf("Loading required package: %s", package, domain = "R-base")
domain を指定しない場合の挙動としては次のように定められています。 cf. ?gettext
If ‘domain’ is ‘NULL’ or ‘”“’, a domain is searched for based on the namespace
which contains the function calling‘gettext’ or ‘ngettext’.
おそらく gettext を実行する関数の属する namespace を基に決定するという意味だと思われます。今回の場合は gettext を実行している関数が require であり、require は base パッケージの namespace に定義されているので、domain は base パッケージのものにならなければならないはずです。
ところが、do_gettext 関数 (defined in src/main/errors.c) を見てみると、domain が指定されない場合は次のコードによって決定されます。
RCNTXT *cptr;
SEXP rho = R_BaseEnv;
for (cptr = R_GlobalContext->nextcontext;
cptr != NULL && cptr->callflag != CTXT_TOPLEVEL;
cptr = cptr->nextcontext)
if (cptr->callflag & CTXT_FUNCTION) {
/* stop() etc have internal call to .makeMessage */
cfn = CHAR(STRING_ELT(deparse1s(CAR(cptr->call)), 0));
if(streql(cfn, "stop") || streql(cfn, "warning")
|| streql(cfn, "message")) continue;
rho = cptr->cloenv;
}
while(rho != R_EmptyEnv) {
if (rho == R_GlobalEnv) break;
else if (R_IsNamespaceEnv(rho)) {
domain = translateChar(STRING_ELT(R_NamespaceEnvSpec(rho), 0));
}
rho = CDR(rho);
}
何をやっているかというと、関数の呼び出し元の親環境から R_GlobalEnv に向かって環境を遡り、最初に見つかった namespace の環境を domain としています。
なので、R_GlobalEnv に定義した関数から require を実行しても言語設定が無視されるということが想像できます。
> detach("package:MASS", unload = TRUE)
> g <- function() require("MASS")
> g()
Loading required package: MASS
これは while 文の直前の rho が関数 g の環境（enclosure ではなく関数 g 自体の環境）になっていて、その enclosure が R_GlobalEnv なので2回目のループで while 文から抜けるのが原因です。domain が NULL なので翻訳されません。
utils パッケージに定義した関数 f から require を実行した場合、while 文の直前の rho が関数 f の環境、その enclosure が utils の namespace なので、そこでループから抜けます。つまり、domain は utils のものになります。utils パッケージには当然 base パッケージのテキストは定義されていないので翻訳されません。
というわけで、.Rprofile などに次のようなコードを書いておけば万事解決です。
gettext <- function(..., domain = NULL) {
if (is.null(domain)) {
env <- NULL
for (n in sys.nframe():1) {
if (as.character(sys.call(n)[1]) %in% c("gettextf", "gettext")) {
env <- sys.frame(n - 1)
}
}
while (!(isNamespace(env) || identical(env, globalenv()) || identical(env, emptyenv()))) {
env <- parent.env(env)
}
if (identical(env, .BaseNamespaceEnv)) {
domain <- "R-base"
} else if (exists(".__NAMESPACE__.", env)) {
domain <- paste0("R-", get("spec", get(".__NAMESPACE__.", env))["name"])
}
}
args <- lapply(list(...), as.character)
.Internal(gettext(domain, unlist(args)))
}
environment(gettext) <- .BaseNamespaceEnv
unlockBinding("gettext", .BaseNamespaceEnv)
assign("gettext", gettext, .BaseNamespaceEnv)
lockBinding("gettext", .BaseNamespaceEnv)
2013/07/07 追記ここから
上記コードだと上手くいかないケースがあります。次のようなコードにすればイタズラに特殊な書き方をされない限り上手くいくと思います。
gettext <- function(..., domain = NULL) {
if (is.null(domain)) {
env <- NULL
n <- sys.nframe()
while (n > 0) {
n <- n - 1
if (as.character(sys.call(n + 1)[1]) %in% c("gettextf", "gettext")) {
while (length(grep("^gettextf?\\s*\\(", sys.call(n), perl = TRUE)) > 0 && n > 0) {
n <- n - 1
}
env <- sys.frame(n)
}
}
while (!(isNamespace(env) || identical(env, globalenv()) || identical(env, emptyenv()))) {
env <- parent.env(env)
}
if (identical(env, .BaseNamespaceEnv)) {
domain <- "R-base"
} else if (exists(".__NAMESPACE__.", env)) {
domain <- paste0("R-", get("spec", get(".__NAMESPACE__.", env))["name"])
}
}
args <- lapply(list(...), as.character)
.Internal(gettext(domain, unlist(args)))
}
environment(gettext) <- .BaseNamespaceEnv
unlockBinding("gettext", .BaseNamespaceEnv)
assign("gettext", gettext, .BaseNamespaceEnv)
lockBinding("gettext", .BaseNamespaceEnv)
追記ここまで
再度 knit を実行してみます。
$ R
R version 3.0.1 (2013-05-16) -- "Good Sport"
Copyright (C) 2013 The R Foundation for Statistical Computing
Platform: x86_64-apple-darwin10.8.0 (64-bit)
R は、自由なソフトウェアであり、「完全に無保証」です。
一定の条件に従えば、自由にこれを再配布することができます。
配布条件の詳細に関しては、'license()' あるいは 'licence()' と入力してください。
R は多くの貢献者による共同プロジェクトです。
詳しくは 'contributors()' と入力してください。
また、R や R のパッケージを出版物で引用する際の形式については
'citation()' と入力してください。
'demo()' と入力すればデモをみることができます。
'help()' とすればオンラインヘルプが出ます。
'help.start()' で HTML ブラウザによるヘルプがみられます。
'q()' と入力すれば R を終了します。
> knitr::knit("require.Rmd")
processing file: require.Rmd
|................................ | 50%
label: unnamed-chunk-1
|.................................................................| 100%
ordinary text without R code
output file: require.md
[1] "require.md"
> file.show("require.md", pager = "cat")
```r
require(MASS)
```
```
## 要求されたパッケージ MASS をロード中です
```
直りましたね！！
根本的に直したい場合、src/main/errors.c に次の patch を適用してビルドし直すと良いと思います。（2013/07/07 追記：これだと上手くいかないケースがあります）
--- errors.c.orig 2013-07-03 07:28:16.000000000 +0900
+++ errors.c 2013-07-04 08:10:25.000000000 +0900
@@ -943,9 +943,9 @@
if (cptr->callflag & CTXT_FUNCTION) {
/* stop() etc have internal call to .makeMessage */
cfn = CHAR(STRING_ELT(deparse1s(CAR(cptr->call)), 0));
- if(streql(cfn, "stop") || streql(cfn, "warning")
- || streql(cfn, "message")) continue;
- rho = cptr->cloenv;
+ if (streql(cfn, "gettext") || streql(cfn, "gettextf")) {
+ rho = cptr->sysparent;
+ }
}
while(rho != R_EmptyEnv) {
if (rho == R_GlobalEnv) break;
気が向いたらどなたか Bugzilla にファイルすると良いと思います。見向きもされない可能性が9割、反応があったとしてもすんなり修正される可能性が1割ってところじゃないでしょうか（つまりすんなり修正される可能性は1%程度）。説得するのが物凄く大変そうです。
2013/07/07 追記
動作確認としては次のようなケースを試せば大丈夫かと思います。全て日本語で表示されるのが所望の動作のはずです。
デフォルトの設定の場合
> f <- function() gettextf("no documentation for %s found in package %s", "a", "b")
> environment(f) <- getNamespace("utils")
> g <- function() f()
> environment(g) <- getNamespace("base")
> f()
[1] " a に対するドキュメントがパッケージ b 中に見当たりません "
> (function() f())()
[1] "no documentation for a found in package b"
> g()
[1] "no documentation for a found in package b"
> body(f) <- quote(message(gettextf("no documentation for %s found in package %s", "a", "b")))
> f()
a に対するドキュメントがパッケージ b 中に見当たりません
> (function() f())()
no documentation for a found in package b
> g()
no documentation for a found in package b
> body(f) <- quote(gettext("no documentation for %s found in package %s"))
> f()
[1] " %s に対するドキュメントがパッケージ %s 中に見当たりません "
> (function() f())()
[1] "no documentation for %s found in package %s"
> g()
[1] "no documentation for %s found in package %s"
base::gettext を上書きした場合
> f <- function() gettextf("no documentation for %s found in package %s", "a", "b")
> environment(f) <- getNamespace("utils")
> g <- function() f()
> environment(g) <- getNamespace("base")
> f()
[1] " a に対するドキュメントがパッケージ b 中に見当たりません "
> (function() f())()
[1] " a に対するドキュメントがパッケージ b 中に見当たりません "
> g()
[1] " a に対するドキュメントがパッケージ b 中に見当たりません "
> body(f) <- quote(message(gettextf("no documentation for %s found in package %s", "a", "b")))
> f()
a に対するドキュメントがパッケージ b 中に見当たりません
> (function() f())()
a に対するドキュメントがパッケージ b 中に見当たりません
> g()
a に対するドキュメントがパッケージ b 中に見当たりません
> body(f) <- quote(gettext("no documentation for %s found in package %s"))
> f()
[1] " %s に対するドキュメントがパッケージ %s 中に見当たりません "
> (function() f())()
[1] " %s に対するドキュメントがパッケージ %s 中に見当たりません "
> g()
[1] " %s に対するドキュメントがパッケージ %s 中に見当たりません "