surf.R

# 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
}