Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- # surf.R
- # 名前の検索
- findConventionalNames <- function(mod) {
- # モジュールに属するオブジェクト名、モジュール名が接頭辞に付く
- modulePattern <- paste("^", mod, "\\.*", sep = "")
- # モジュールに属するがプライベート扱いのオブジェクト名、先頭がドット
- modulePrivatePattern <- paste("^\\.", mod, "\\.*", sep="")
- # クラスに属するメソッド名
- classPattern <- paste("^.+\\.", mod, "$", sep="")
- # クラスに属するライベートメソッド名
- classPrivatePattern <- paste("^\\..+\\.", mod, "$", sep="")
- list(
- module = ls(envir = .GlobalEnv, pattern=modulePattern),
- modulePrivate = ls(envir = .GlobalEnv, pattern=modulePrivatePattern, all=TRUE),
- class = ls(envir = .GlobalEnv, pattern=classPattern),
- classPrivate = ls(envir = .GlobalEnv, pattern=classPrivatePattern, all=TRUE)
- )
- }
- # この“モジュール”で使用されている名前を列挙する
- surf.names <- function() {
- # モジュール名
- mod <- "surf"
- # このモジュールで定義した大域名
- global <- c("findConventionalNames", "makeZMatrix")
- names <- findConventionalNames(mod)
- names[["global"]] <- global
- names
- }
- # 2変数関数の値(zの値)を成分とする行列を作成する
- makeZMatrix <-
- function (
- # 2変数関数の式、コールオブジェクトを渡す
- expr,
- # 2変数関数の第1変数、第2変数の名前、文字列で指定する
- xname = "x", yname = "y",
- # 2変数関数の第1変数、第2変数の描画域
- xlim = c(-1, 1), ylim = c(-1, 1),
- # 描画域を幾つの少区間に分割するか(分割数)
- xdiv = 20, ydiv = 20,
- # 2変数関数の式が評価される環境、リストか環境オブジェクト
- bind = list(),
- # 関数値マトリックス作成時にouterを用いるかどうか
- use.outer = FALSE)
- {
- x0 <- xlim[1]
- x1 <- xlim[2]
- y0 <- ylim[1]
- y1 <- ylim[2]
- xStep <- (x1 - x0)/xdiv
- yStep <- (y1 - y0)/ydiv
- xBreaks <- seq(from = x0, to = x1, by = xStep)
- yBreaks <- seq(from = y0, to = y1, by = yStep)
- # 関数の仮引数リストの作成
- fplist <- list(noDefault(), noDefault()) # デフォルト値なし2変数
- names(fplist) <- c(xname, yname) # 引数名を指定
- # 関数の作成
- envir <- new.env(parent = .GlobalEnv)
- for (nm in names(bind)) {
- envir[[nm]] <- bind[[nm]]
- }
- fun <- makeFunction(fplist, expr, envir)
- if (use.outer) {
- zMatrix <- outer(xBreaks, yBreaks, fun)
- } else {
- zMatrix <- matrix(NA, xdiv + 1, ydiv + 1)
- for (i in 1:(xdiv + 1)) {
- for (j in 1:(ydiv + 1)) {
- zMatrix[i, j] <- fun(xBreaks[i], yBreaks[j])
- }
- }
- }
- list(
- x = xBreaks,
- y = yBreaks,
- z = zMatrix
- )
- }
- # 2変数関数の曲面(3Dグラフ)を描く
- # 非標準評価方式
- surf <-
- function (
- # 2変数関数の式、引数として式を書く
- z,
- # 2変数関数の第1変数、第2変数の名前、文字列でもシンボルでもどっちでもよい
- xname = "x", yname = "y",
- # 2変数関数の第1変数、第2変数の描画域、原点中心正方形の辺長の半分
- half = 1,
- # 2変数関数の第1変数、第2変数の描画域、共通
- lim = c(-1*half, half),
- # 2変数関数の第1変数、第2変数の描画域、個別
- xlim = lim, ylim = lim,
- # 描画域を幾つの少区間に分割するか(分割数)、共通
- div = 20,
- # 描画域を幾つの少区間に分割するか(分割数)、個別
- xdiv = div, ydiv = div,
- # 2変数関数の式が評価される環境、リストで指定
- bind = list(),
- # 関数値マトリックス作成時にouterを用いるかどうか
- use.outer = FALSE,
- # ラベル文字列
- xlab = NULL, ylab = NULL, zlab = NULL,
- # 関数値の描画域
- zlim = NULL,
- # perspのオプション
- theta = 30, phi = 30, expand = 0.5, col = "skyblue",
- # perspへの引数リストを戻り値として出力するか
- output.args = FALSE
- )
- {
- z <- substitute(z) # 式を評価せずに取り出す
- xname <- substitute(xname) # 文字列、または評価しない名前を取り出す
- yname <- substitute(yname) # 文字列、または評価しない名前を取り出す
- # 名前を文字列にする
- xname <- as.character(xname)
- yname <- as.character(yname)
- surf_(z, xname, yname, half, lim, xlim, ylim, div, xdiv, ydiv,
- bind,
- use.outer, xlab, ylab, zlab, zlim, theta, phi, expand, col, output.args)
- }
- # 2変数関数の曲面(3Dグラフ)を描く
- # 標準評価方式
- surf_ <-
- function (
- # 2変数関数の式、callオブジェクトを渡す
- z,
- # 2変数関数の第1変数、第2変数の名前、文字列で渡す
- xname = "x", yname = "y",
- # 2変数関数の第1変数、第2変数の描画域、原点中心正方形の辺長の半分
- half = 1,
- # 2変数関数の第1変数、第2変数の描画域、共通
- lim = c(-1*half, half),
- # 2変数関数の第1変数、第2変数の描画域、個別
- xlim = lim, ylim = lim,
- # 描画域を幾つの少区間に分割するか(分割数)、共通
- div = 20,
- # 描画域を幾つの少区間に分割するか(分割数)、個別
- xdiv = div, ydiv = div,
- # 2変数関数の式が評価される環境、リストで指定
- bind = list(),
- # 関数値マトリックス作成時にouterを用いるかどうか
- use.outer = FALSE,
- # ラベル文字列
- xlab = NULL, ylab = NULL, zlab = NULL,
- # 関数値の描画域
- zlim = NULL,
- # perspのオプション
- theta = 30, phi = 30, expand = 0.5, col = "skyblue",
- # perspへの引数リストを戻り値として出力するか
- output.args = FALSE
- )
- {
- # 関数値のマトリックスを作成する
- xyz <- makeZMatrix(z,
- xname = xname, yname = yname,
- xlim = xlim, ylim = ylim,
- xdiv = xdiv, ydiv = ydiv,
- bind = bind,
- use.outer = use.outer)
- # perspの引数リストを作成する
- args <- list(
- x = xyz$x,
- y = xyz$y,
- z = xyz$z,
- xlab = if (is.null(xlab)) xname else xlab,
- ylab = if (is.null(ylab)) yname else ylab,
- zlab = if (is.null(zlab)) deparse(z) else zlab,
- xlim = xlim,
- ylim = ylim,
- theta = theta,
- phi = phi,
- expand = expand,
- col = col
- )
- if (!is.null(zlim)) {
- args[["zlim"]] <- zlim
- }
- # 描画関数の呼び出し
- do.call("persp", args)
- # output.argsがTRUEなら引数リストを返す
- if (output.args) args
- }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement